pax_global_header00006660000000000000000000000064147464154450014530gustar00rootroot0000000000000052 comment=77c8a6dd7c48cd4ab9e5d175c37025a759cab59d Coq-HoTT-9.0/000077500000000000000000000000001474641544500127365ustar00rootroot00000000000000Coq-HoTT-9.0/.dir-locals.el000066400000000000000000000000411474641544500153620ustar00rootroot00000000000000((nil . ((mode . visual-line)))) Coq-HoTT-9.0/.github/000077500000000000000000000000001474641544500142765ustar00rootroot00000000000000Coq-HoTT-9.0/.github/workflows/000077500000000000000000000000001474641544500163335ustar00rootroot00000000000000Coq-HoTT-9.0/.github/workflows/ci.yml000066400000000000000000000533601474641544500174600ustar00rootroot00000000000000name: CI on: [ push , pull_request , merge_group ] concurrency: group: "${{ github.workflow }} @ ${{ github.event.pull_request.head.label || github.head_ref || github.ref }}" cancel-in-progress: true # We set the supported coq-version from here. In order to use this environment variable correctly, look at how they are used in the following jobs. env: coq-version-supported: '8.19' ocaml-version: '4.14-flambda' deployment-branch: 'gh-pages' # Our jobs come in 3 stages, the latter stages depending on the former: # - Stage 1: Build jobs # - Stage 2: Documentation and validation jobs # - Stage 3: Deployment job # - Stage 4: Clean-up job jobs: # # Stage 1: # # Here we define the build jobs: # - opam-build: Building the library using opam # - quick-build: Building the library quickly using make # - build: Building with timeing information for use in doc jobs # Building the library using opam opam-build: strategy: fail-fast: false matrix: coq-version-dummy: - 'supported' - 'latest' - 'dev' os: - ubuntu-latest env: coq-version: ${{ matrix.coq-version-dummy }} runs-on: ${{ matrix.os }} steps: # Github actions doesn't let us set workflow level enviornment variables inside the stategy of a job. Therefore we use the dummy variable coq-version in the matrix to set an environment varible env.coq-version, which uses the globablly set coq-version-supported when running the 'supported' case. - name: Set supported coq-version if: matrix.coq-version-dummy == 'supported' run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV - name: Checkout repo uses: actions/checkout@v4 - name: Build HoTT uses: coq-community/docker-coq-action@v1 with: opam_file: 'coq-hott.opam' coq_version: ${{ env.coq-version }} ocaml_version: ${{ env.ocaml-version }} export: 'OPAMWITHTEST' env: OPAMWITHTEST: 'true' # Quick build quick-build: strategy: fail-fast: false matrix: coq-version-dummy: - 'supported' - 'latest' - 'dev' os: - ubuntu-latest env: coq-version: ${{ matrix.coq-version-dummy }} runs-on: ${{ matrix.os }} steps: # Github actions doesn't let us set workflow level enviornment variables inside the stategy of a job. Therefore we use the dummy variable coq-version in the matrix to set an environment varible env.coq-version, which uses the globablly set coq-version-supported when running the 'supported' case. - name: Set supported coq-version if: matrix.coq-version-dummy == 'supported' run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV - name: Checkout repo uses: actions/checkout@v4 - name: Build HoTT uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ env.coq-version }} ocaml_version: ${{ env.ocaml-version }} custom_script: | startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions sudo chown -R coq:coq . endGroup echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations make -j2 - name: Revert permissions # to avoid a warning at cleanup time - https://github.com/coq-community/docker-coq-action#permissions if: ${{ always() }} run: sudo chown -R 1001:116 . # Main build which docs will run off build: strategy: fail-fast: false matrix: # We build on our supported version of coq and the master version coq-version-dummy: - 'supported' - 'latest' include: - coq-version-dummy: 'dev' extra-gh-reportify: '--warnings' env: coq-version: ${{ matrix.coq-version-dummy }} runs-on: ubuntu-latest steps: # Github actions doesn't let us set workflow level enviornment variables inside the stategy of a job. Therefore we use the dummy variable coq-version in the matrix to set an environment varible env.coq-version, which uses the globablly set coq-version-supported when running the 'supported' case. - name: Set supported coq-version if: matrix.coq-version-dummy == 'supported' run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV # Checkout branch - uses: actions/checkout@v4 with: submodules: recursive # We use the coq docker so we don't have to build coq - uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ env.coq-version }} ocaml_version: ${{ env.ocaml-version }} custom_script: | startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions sudo chown -R coq:coq . endGroup echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations sudo apt-get -o Acquire::Retries=30 update -q sudo apt-get -o Acquire::Retries=30 install python3 python-is-python3 -y --allow-unauthenticated etc/coq-scripts/github/reportify-coq.sh --errors ${{ matrix.extra-gh-reportify }} make TIMED=1 -j2 --output-sync - name: Revert permissions # to avoid a warning at cleanup time - https://github.com/coq-community/docker-coq-action#permissions if: ${{ always() }} run: sudo chown -R 1001:116 . # Tar workspace files - name: 'Tar .vo files' run: tar -cf workspace.tar . # We upload build artifacts for use by documentation - name: 'Upload Artifact' uses: actions/upload-artifact@v4 with: name: workspace-${{ env.coq-version }} path: workspace.tar # Nix build nix: runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 - uses: cachix/install-nix-action@v20 with: name: coq-hott authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' extraPullNames: coq-hott - run: nix build # # Stage 2: # # Here we define the documentation and validation jobs: # - doc-alectryon: Builds the alectryon documentation # - doc-dep-graph: Builds dependency graphs # - doc-coqdoc: Builds the coqdoc documentation # - doc-timing: Builds the timing documentation # - coqchk: Runs coqchk # - install: Tests install target # alectryon job doc-alectryon: needs: build runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 with: submodules: recursive # Download artifact - uses: actions/download-artifact@v4 with: name: workspace-${{ env.coq-version-supported }} # Unpack Tar - run: tar -xf workspace.tar - name: add problem matchers run: | #echo "::add-matcher::etc/coq-scripts/github/coq-oneline-error.json" # now via a script #echo "::add-matcher::etc/coq-scripts/github/coqdoc.json" # disabled for now, since they don't have file names echo "::add-matcher::etc/coq-scripts/github/alectryon-error.json" #echo "::add-matcher::etc/coq-scripts/github/alectryon-warning.json" # too noisy right now, cf https://github.com/cpitclaudel/alectryon/issues/34 and https://github.com/cpitclaudel/alectryon/issues/33 - uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ env.coq-version-supported }} ocaml_version: ${{ env.ocaml-version }} custom_script: | opam install -y coq-serapi sudo apt-get -o Acquire::Retries=30 update -q sudo apt-get -o Acquire::Retries=30 install python3-pip python3-venv autoconf -y --allow-unauthenticated startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions sudo chown -R coq:coq . endGroup # Create and activate a virtual environment python3 -m venv myenv source myenv/bin/activate # Install the required Python packages in the virtual environment python -m pip install --upgrade pip python -m pip install pygments dominate beautifulsoup4 docutils==0.17.1 echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations make alectryon ALECTRYON_EXTRAFLAGS=--traceback - name: Revert permissions # to avoid a warning at cleanup time - https://github.com/coq-community/docker-coq-action#permissions if: ${{ always() }} run: sudo chown -R 1001:116 . - name: tar alectryon artifact run: tar -cf alectryon-html.tar alectryon-html - name: upload alectryon artifact uses: actions/upload-artifact@v4 with: name: alectryon-html path: alectryon-html.tar # dependency graph doc job doc-dep-graphs: needs: build runs-on: ubuntu-latest steps: # Checkout branch - uses: actions/checkout@v4 with: submodules: recursive # Download artifact - uses: actions/download-artifact@v4 with: name: workspace-${{ env.coq-version-supported }} # Unpack Tar - run: tar -xf workspace.tar # We use the coq docker so we don't have to build coq - uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ env.coq-version-supported }} ocaml_version: ${{ env.ocaml-version }} custom_script: | sudo apt-get update sudo apt-get install -y ghc cabal-install sudo apt-get install -y --allow-unauthenticated \ libssl-dev aspcud \ graphviz xsltproc python3-lxml python-pexpect-doc \ libxml2-dev libxslt1-dev time lua5.1 unzip npm # libnode-dev node-gyp cabal update cabal install --lib graphviz text fgl sudo -E npm config set strict-ssl false #sudo -E npm i -g npm sudo -E npm install -g doctoc startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions sudo chown -R coq:coq . endGroup echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations ## Make dependency graph make HoTT.deps HoTTCore.deps runhaskell etc/DepsToDot.hs --coqdocbase="http://hott.github.io/Coq-HoTT/alectryon-html/" --title="HoTT Library Dependency Graph" < HoTT.deps > HoTT.dot runhaskell etc/DepsToDot.hs --coqdocbase="http://hott.github.io/Coq-HoTT/alectryon-html/" --title="HoTT Core Library Dependency Graph" < HoTTCore.deps > HoTTCore.dot dot -Tsvg HoTT.dot -o HoTT.svg dot -Tsvg HoTTCore.dot -o HoTTCore.svg rm -rf dep-graphs mkdir -p dep-graphs mv HoTT.svg HoTTCore.svg dep-graphs/ ## Install coq-dpdgraph opam install coq-dpdgraph.1.0+8.19 -y # For some reason, we get a stackoverflow. So we are lax # with making these. ulimit -s unlimited make svg-file-dep-graphs -k || true ## Try to make again to see errors make svg-file-dep-graphs -k || true # `dot` hates file-dep-graphs/hott-all.dot, because it's too big, and # makes `dot` spin for over a dozen minutes. So disable it for now. #make svg-aggregate-dep-graphs -k || exit $? # We try to make the index.html but there might be some dead # links if the previous didn't succeed. make file-dep-graphs/index.html -k || true - name: Revert permissions # to avoid a warning at cleanup time - https://github.com/coq-community/docker-coq-action#permissions if: ${{ always() }} run: sudo chown -R 1001:116 . # Tar dependency graph files - name: 'Tar .svg files' run: | tar -cf dep-graphs.tar dep-graphs tar -cf file-dep-graphs.tar file-dep-graphs # We upload the artifacts - name: 'Upload Artifact dep-graphs.tar' uses: actions/upload-artifact@v4 with: name: dep-graphs path: dep-graphs.tar - name: 'Upload Artifact file-dep-graphs.tar' uses: actions/upload-artifact@v4 with: name: file-dep-graphs path: file-dep-graphs.tar # doc-coqdoc job # This builds coqdoc and timing docs and uploads their artifacts doc-coqdoc: needs: build runs-on: ubuntu-latest steps: # Checkout branch - uses: actions/checkout@v4 with: submodules: recursive # Download artifact - uses: actions/download-artifact@v4 with: name: workspace-${{ env.coq-version-supported }} # Unpack Tar - run: tar -xf workspace.tar # We use the coq docker so we don't have to build coq - uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ env.coq-version-supported }} ocaml_version: ${{ env.ocaml-version }} custom_script: | startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions sudo chown -R coq:coq . endGroup echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations ## Make HTML doc make -j2 html mv html coqdoc-html - name: Revert permissions # to avoid a warning at cleanup time - https://github.com/coq-community/docker-coq-action#permissions if: ${{ always() }} run: sudo chown -R 1001:116 . # Tar html files - name: 'Tar doc files' run: tar -cf coqdoc-html.tar coqdoc-html # Upload coqdoc-html artifact - name: 'Upload coqdoc-html Artifact' uses: actions/upload-artifact@v4 with: name: coqdoc-html path: coqdoc-html.tar # doc-timing job # This builds coqdoc and timing docs and uploads their artifacts doc-timing: needs: build runs-on: ubuntu-latest steps: # Checkout branch - uses: actions/checkout@v4 with: submodules: recursive # Download artifact - uses: actions/download-artifact@v4 with: name: workspace-${{ env.coq-version-supported }} # Unpack Tar - run: tar -xf workspace.tar # We use the coq docker so we don't have to build coq - uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ env.coq-version-supported }} ocaml_version: ${{ env.ocaml-version }} custom_script: | sudo apt-get update sudo apt-get install -y time python3 python-is-python3 lua5.1 startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions sudo chown -R coq:coq . endGroup echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations ## Make timing doc make -j2 timing-html - name: Revert permissions # to avoid a warning at cleanup time - https://github.com/coq-community/docker-coq-action#permissions if: ${{ always() }} run: sudo chown -R 1001:116 . # Tar html files - name: 'Tar doc files' run: tar -cf timing-html.tar timing-html # Upload timing-html artifact - name: 'Upload timing-html Artifact' uses: actions/upload-artifact@v4 with: name: timing-html path: timing-html.tar # The coqchk job coqchk: needs: build strategy: fail-fast: false matrix: # We build on our supported version of coq and the master version coq-version-dummy: - 'supported' - 'latest' - 'dev' env: coq-version: ${{ matrix.coq-version-dummy }} runs-on: ubuntu-latest steps: # Github actions doesn't let us set workflow level enviornment variables inside the stategy of a job. Therefore we use the dummy variable coq-version in the matrix to set an environment varible env.coq-version, which uses the globablly set coq-version-supported when running the 'supported' case. - name: Set supported coq-version if: matrix.coq-version-dummy == 'supported' run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV # Checkout branch - uses: actions/checkout@v4 with: submodules: recursive # Download artifact - uses: actions/download-artifact@v4 with: name: workspace-${{ env.coq-version }} # Unpack Tar - run: tar -xf workspace.tar # We use the coq docker so we don't have to build coq - uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ env.coq-version }} ocaml_version: ${{ env.ocaml-version }} custom_script: | startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions sudo chown -R coq:coq . endGroup echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations make validate - name: Revert permissions # to avoid a warning at cleanup time - https://github.com/coq-community/docker-coq-action#permissions if: ${{ always() }} run: sudo chown -R 1001:116 . # Test install target install: needs: build strategy: fail-fast: false matrix: # We build on our supported version of coq and the master version coq-version-dummy: - 'supported' - 'latest' - 'dev' env: coq-version: ${{ matrix.coq-version-dummy }} runs-on: ubuntu-latest steps: # Github actions doesn't let us set workflow level enviornment variables inside the stategy of a job. Therefore we use the dummy variable coq-version in the matrix to set an environment varible env.coq-version, which uses the globablly set coq-version-supported when running the 'supported' case. - name: Set supported coq-version if: matrix.coq-version-dummy == 'supported' run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV # Checkout branch - uses: actions/checkout@v4 with: submodules: recursive # Download artifact - uses: actions/download-artifact@v4 with: name: workspace-${{ env.coq-version }} # Unpack Tar - run: tar -xf workspace.tar # We use the coq docker so we don't have to build coq - uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ env.coq-version }} ocaml_version: ${{ env.ocaml-version }} custom_script: | startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions sudo chown -R coq:coq . endGroup echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations ## Test install target make install echo 'Require Import HoTT.HoTT.' | coqtop -q - name: Revert permissions # to avoid a warning at cleanup time - https://github.com/coq-community/docker-coq-action#permissions if: ${{ always() }} run: sudo chown -R 1001:116 . # # Stage 3 # deploy-doc: # We only deploy when the reference is the master branch if: ${{ github.ref == 'refs/heads/master' }} # This job relies on the documentation jobs having finished. Technically we don't need to rely on coqchk and install, but it is simpler this way. needs: - coqchk - install - doc-alectryon - doc-dep-graphs - doc-coqdoc - doc-timing runs-on: ubuntu-latest steps: # Checkout branch - uses: actions/checkout@v4 # Download alectryon artifact - uses: actions/download-artifact@v4 with: name: alectryon-html # Download dependency graph artifacts - uses: actions/download-artifact@v4 with: name: dep-graphs # Download file dependency graph artifacts - uses: actions/download-artifact@v4 with: name: file-dep-graphs # Download coqdoc artifact - uses: actions/download-artifact@v4 with: name: coqdoc-html # Download timing artifact - uses: actions/download-artifact@v4 with: name: timing-html # Unpack Tar files - run: | mkdir doc tar -xf alectryon-html.tar -C doc tar -xf dep-graphs.tar -C doc tar -xf file-dep-graphs.tar -C doc tar -xf coqdoc-html.tar -C doc tar -xf timing-html.tar -C doc - name: Deploy 🚀 uses: JamesIves/github-pages-deploy-action@4.1.8 with: branch: ${{ env.deployment-branch }} folder: doc single-commit: true # # Stage 4 # # Here we define the cleanup job: # - delete-artifacts: We delete the artifacts from the previous jobs delete-artifacts: # We always want to run this job even if we cancel if: ${{ always() }} # We depend on the stage 3 jobs needs: - deploy-doc runs-on: ubuntu-latest steps: # Delete workspace artifacts - uses: geekyeggo/delete-artifact@v5 with: name: workspace-${{ env.coq-version-supported }} - uses: geekyeggo/delete-artifact@v5 with: name: workspace-latest - uses: geekyeggo/delete-artifact@v5 with: name: workspace-dev # Delete documentation artifacts - uses: geekyeggo/delete-artifact@v5 with: name: dep-graphs - uses: geekyeggo/delete-artifact@v5 with: name: file-dep-graphs - uses: geekyeggo/delete-artifact@v5 with: name: alectryon-html - uses: geekyeggo/delete-artifact@v5 with: name: coqdoc-html - uses: geekyeggo/delete-artifact@v5 with: name: timing-html Coq-HoTT-9.0/.gitignore000066400000000000000000000026361474641544500147350ustar00rootroot00000000000000# Ignore Emacs backup files *~ # Ignore Emacs temp files *#*# # Ignore the .DS_Store file generated on a Mac .DS_Store # Ignore files generated by the Coq compiler .*.aux .*.d *.a *.cma *.cmi *.cmo *.cmx *.cmxa *.cmxs *.glob *.ml.d *.ml4.d *.mlg.d *.mli.d *.mllib.d *.mlpack.d *.native *.o *.v.d *.vio *.vo *.vok *.vos .coq-native .csdp.cache .lia.cache .nia.cache .nlia.cache .nra.cache csdp.cache lia.cache nia.cache nlia.cache nra.cache native_compute_profile_*.data # generated timing files *.timing.diff *.v.after-timing *.v.before-timing *.v.timing time-of-build-after.log time-of-build-before.log time-of-build-both.log time-of-build-pretty.log *.vo *.vos *.vok *.glob *.v.d *.native *.ml4.d *.mli.d *.mllib.d *.timing # Ignore makefiles generated by coq_makefile /Makefile.coq /Makefile.coq.conf html/ file-dep-graphs/ alectryon-html/ alectryon-cache/ HoTT.deps HoTT.dot # Ignore files generated by LaTeX *.aux *.log *.out # Ignore stuff from autobuild configure html-done.timestamp alectryon-html-done.timestamp # generated dependency files: TAGS # ignore compiled python files *.pyc # ignore backup files generated by etc/Book.py contrib/*.bak.* # ignore backup files generated by etc/coqcstriprequires.py *.bak *.crashcoqide .vscode/ # ignore dune _build directory _build/ # ignore _CoqProject since we autogenerate it _CoqProject # ignore nix profiles nix/profiles/ # Ignore the file to bench file_to_bench Coq-HoTT-9.0/.gitmodules000066400000000000000000000003201474641544500151060ustar00rootroot00000000000000[submodule "etc/coq-scripts"] path = etc/coq-scripts url = https://github.com/JasonGross/coq-scripts.git [submodule "etc/alectryon"] path = etc/alectryon url = https://github.com/JasonGross/alectryon.git Coq-HoTT-9.0/.mailmap000066400000000000000000000053611474641544500143640ustar00rootroot00000000000000## 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 Andrej Bauer Andrej Bauer Andrej Bauer andrejbauer Andrej Bauer Andrej Bauer Andrej Bauer Homotopy Type Theory Assia Mahboubi amahboubi Bas Spitters Bas Spitters Bas Spitters spitters Gaetan Gilbert Gaetan Gilbert Georgy Dunaev georgedunaev Jason Gross Jason Gross Jérémy Ledent Jérémy Jesse C. McKeown jcmckeown Jesse C. McKeown jcmckeown Kevin Quirin KevinQuirin Kevin Quirin Kevin Quirin Kevin Quirin Kevin Quirin Kristina Sojakova Kristina Kristina Sojakova U-KristinaSojakov\Kristina Sojakova Marc Bezem marcbezem Matěj Grabovský Matěj G. Mike Shulman Mike Shulman Mike Shulman mikeshulman Peter LeFanu Lumsdaine Peter LeFanu Lumsdaine Peter LeFanu Lumsdaine Peter LeFanu Lumsdaine Simon Boulier SimonBoulier Steve Awodey Steve Coq-HoTT-9.0/CREDITS.txt000066400000000000000000000020411474641544500145710ustar00rootroot00000000000000THE HoTT DEVELOPMENT TEAM ========================= The HoTT library was jointly developed by the following people, listed in alphabetical order: * Andrej Bauer, University of Ljubljana * Jason Gross, Massachusetts Institute of Technology * Peter LeFanu Lumsdaine, Institute for Advanced Study * Michael Shulman, University of San Diego * Bas Spitters, Radboud University Nijmegen For a complete list of all contributors, please see the git commit logs, available at https://github.com/HoTT/HoTT. INSTITUTIONAL SUPPORT ===================== We acknowledge the support of the following instutitions and funding agencies, listed in alphabetical order: * Institute for Advanced Study, Princeton, USA (http://www.ias.edu/) * Institute for Mathematics, Physics and Mechanics, Ljubljana, Slovenia (http://www.imfm.si/) * Faculty of Mathematics and Physics, University of Ljubljana, Slovenia (http://www.fmf.uni-lj.si/) * Slovenian Research Agency (http://www.arrs.gov.si/), grant P1-0294 * European Science Foundation project GReGAS (http://www.gregas.eu) Coq-HoTT-9.0/INSTALL.md000066400000000000000000000207151474641544500143730ustar00rootroot00000000000000We recommend [these install instructions](#1-installation-using-coq-platform) if you wish to install the HoTT library to use in your own project or to play around with. ## Table of contents - [1. Installation using Coq Platform](#1-installation-using-coq-platform) - [2. Installation of HoTT library using opam](#2-installation-of-hott-library-using-opam) - [Released Versions](#released-versions) - [Source Versions](#source-versions) - [Development Versions](#development-versions) - [3. Setup for developers (using git)](#3-setup-for-developers-using-git) - [3.1. Prequisites (Installing Coq)](#31-prequisites-installing-coq) - [3.1.1. Development in OSX and Windows](#311-development-in-osx-and-windows) - [3.2. Forking and obtaining the HoTT library](#32-forking-and-obtaining-the-hott-library) - [3.3. Building the HoTT library](#33-building-the-hott-library) - [3.4. Installing the library using git](#34-installing-the-library-using-git) - [4. Editors](#4-editors) - [4.1. Tags for Emacs](#41-tags-for-emacs) - [5. Updating the library](#5-updating-the-library) - [6. Troubleshooting](#6-troubleshooting) # 1. Installation using Coq Platform In order to install the HoTT library, we recommend that you use the [Coq Platform][1]. This will install the [Coq Proof Assistant][2] together with the HoTT library. The Coq Platform supports installation on **Linux**, **MacOS** and **Windows**. In order to use the HoTT library in your project, make sure you have a file called `_CoqProject` in your working directory which contains the following lines: ``` -arg -noinit -arg -indices-matter ``` This way when you open `.v` files using `coqide` or any other text editor for coq (see [Editors](#editors)), the editor will pass the correct arguments to `coq`. To import modules from the HoTT library inside your own file, you will need to write the following: ```coq From HoTT Require Import Basics. ``` This, for example, will import the `Basics` module from the HoTT library. If you wish to import the entire library you can write: ```coq From HoTT Require Import HoTT. ``` > ### Warning > > The versions of the HoTT library appearing in the Coq Platform are released > twice a year. This means that there is a good chance that the Coq Platform > version is lagging behind the latest version of the library. If you wish to > use the latest version of the library, you should install it using `opam` as > described in the next section. # 2. Installation of HoTT library using opam ## Released Versions More advanced users may wish to install the HoTT library via `opam` ([See here for details on installing `opam`][3]). You need to add the released coq-archive packages to `opam` which can be done as follows: ```shell $ opam repo add coq-released https://coq.inria.fr/opam/released ``` This will let you install the released versions of the library. We typically do a release for each major version of `coq`. Note that the name of the HoTT library is `coq-hott` inside the coq-archive. ```shell $ opam install coq-hott ``` ## Source Versions After cloning the repository, you can install the library using `opam` by running `opam install .` in the root of the repository. ## Development Versions We also have the current development versions of the library available via `opam`. For this however, you will need to add the dev coq-archive packages: ```shell $ opam repo add coq-core-dev https://coq.inria.fr/opam/core-dev $ opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev ``` This will make `coq.dev` the latest available version of `coq`. You can pin `coq` to a stable version by running `opam pin add coq.dev 8.19.1` for example. Then install the library with `opam install coq-hott`, as for the released version. # 3. Setup for developers (using git) ## 3.1. Prequisites (Installing Coq) We recommend that you use the `opam` package manager to install `coq`. Details about [installing Opam can be found here][3]. Using `opam` you can install the latest version of `coq` by doing the following: ```shell $ opam install coq ``` You will also need `make` and `git` in a typical workflow. ### 3.1.1. Development in OSX and Windows We don't recommend developing on platforms other than Linux, however it is still possible. Windows and OSX users may install `coq` directly using the [installer for the appropriate coq release][9]. For OSX users `git` and `make` should be readily availble. Windows users can install [`git` as described here][18] and [`make` as described here][17]. ## 3.2. Forking and obtaining the HoTT library In order to do development on the HoTT library, we recommend that you [fork it on Github][4]. More details [about forking can be found here][5]. Use `git` to clone your fork locally: ```shell $ git clone https://github.com/YOUR-USERNAME/HoTT ``` Of course, you may clone the library directly, but for development it is recommended to work on a fork. To follow the rest of the instructions, it is best to change your working directory to the `HoTT` directory. ```shell $ cd HoTT ``` We also recommend that you [add the main repository as a git remote][6]. This makes it easier to track changes happening on the main repository. This can be done as follows: ```shell $ git remote add upstream https://github.com/HoTT/HoTT.git ``` ## 3.3. Building the HoTT library In order to compile the files of the HoTT library, run `make`: ```shell $ make ``` You can speed up the build by passing `-jN` where `N` is the number of parallel recipes `make` will execute. You can also use `dune` to build the library. ```shell $ dune build ``` ## 3.4. Installing the library using git We don't recommend you install the library using the repository and instead recommend [installing via opam](#installation-of-hott-library-using-opam), especially if you are intending to develop the library. However the `makefile` contains a target called `install` and therefore running ```shell $ make install ``` will install the library. # 4. Editors We recommend the following text editors for the development of `.v` files: * [Emacs][10] together with [Proof General][11]. * [CoqIDE][12] part of the [Coq Proof Assistant][13]. * [Visual Studio Code][14] together with [coq-lsp][15]. * For more editors, see the Coq website article on [User Interfaces][19]. ## 4.1. Tags for Emacs To use the Emacs tags facility with the `*.v` files here, run the command: ```shell $ make TAGS ``` The Emacs command `M-x find-tag`, bound to `M-.` , will take you to a definition or theorem, the default name for which is located under your cursor. Read the help on that Emacs command with `C-h k M-.` , and learn the other facilities provided, such as the use of `M-*` to get back where you were, or the use of `M-x tags-search` to search throughout the code for locations matching a given regular expression. Dune users may use the following to generate tags: ```shell dune build TAGS ``` # 5. Updating the library If you installed the library via Coq Platform then [update your version of Coq Platform][1]. If you installed the library via `opam` then simply run `opam update` and then `opam ugprade`. To upgrade your clone of the GitHub repository as set up in [the instructions on using git](#forking-and-obtaining-the-hott-library): Pull the latest version using `git pull upstream master` and then rebuild using `make` as above. To update your fork, use `git push origin master`. We also [have tags in the GitHub repository][7] for our released versions which you can use instead of `master`. # 6. Troubleshooting In case of any problems, feel free to contact us by [opening an issue on GitHub](https://github.com/HoTT/HoTT). [1]: https://github.com/coq/platform/releases [2]: https://github.com/coq/coq [3]: https://opam.ocaml.org/doc/Install.html [4]: https://github.com/HoTT/HoTT [5]: https://docs.github.com/en/github/getting-started-with-github/fork-a-repo [6]: https://docs.github.com/en/github/collaborating-with-issues-and-pull-requests/configuring-a-remote-for-a-fork [7]: https://github.com/HoTT/HoTT/releases [8]: https://opam.ocaml.org/doc/Install.html#OSX [9]: https://github.com/coq/coq/releases [10]: http://www.gnu.org/software/emacs/ [11]: http://proofgeneral.inf.ed.ac.uk [12]: https://coq.inria.fr/refman/practical-tools/coqide.html [13]: https://github.com/coq/coq [14]: https://code.visualstudio.com/ [15]: https://github.com/ejgallego/coq-lsp [16]: https://cygwin.com/install.html [17]: https://stackoverflow.com/a/54086635 [18]: https://git-scm.com/book/en/v2/Getting-Started-Installing-Git [19]: https://coq.inria.fr/user-interfaces.htmlCoq-HoTT-9.0/LICENSE.txt000066400000000000000000000031171474641544500145630ustar00rootroot00000000000000PREAMBLE ======== The HoTT library is distributed under the BSD 2-clause licence, included below, except for files which contain a specific copyright notice and licencing information. The members of the HoTT development team and their contributions are described in the file CREDITS.txt. LICENSE ======= Copyright (c) 2012, the HoTT development team All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * 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 HOLDER 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. Coq-HoTT-9.0/Makefile000066400000000000000000000023151474641544500143770ustar00rootroot00000000000000# KNOWNTARGETS will not be passed along to Makefile.coq KNOWNTARGETS := Makefile.coq # KNOWNFILES will not get implicit targets from the final rule, and so # depending on them won't invoke the submake # Warning: These files get declared as PHONY, so any targets depending # on them always get rebuilt KNOWNFILES := Makefile _CoqProject .DEFAULT_GOAL := invoke-coqmakefile Makefile.coq: Makefile _CoqProject # Generate _CoqProject file bash etc/generate_coqproject.sh # Generate Makefile $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq # We replace the html target with real-html, because we want to make # the timestamp file. We use patsubst rather than subst to do this so # that we only replace entire words. invoke-coqmakefile: Makefile.coq $(MAKE) --no-print-directory -f Makefile.coq $(patsubst html,real-html,$(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS))) .PHONY: invoke-coqmakefile $(KNOWNFILES) #################################################################### ## Your targets here ## #################################################################### # This should be the last rule, to handle any targets not declared above %: invoke-coqmakefile @true Coq-HoTT-9.0/Makefile.coq.local000066400000000000000000000272741474641544500162640ustar00rootroot00000000000000#TODO: REMOVE GLOB? # Once https://github.com/coq/coq/pull/12411 is merged and we bump the # minimum version to a version including that PR, this file should # become Makefile.coq.local-late, and we should rename # Makefile.coq.local-early to Makefile.coq.local; # Makefile.coq.local-early contains code that overrides the relevant # variables in Makefile.coq, while Makefile.coq.local currently # contains additional targets that need access to the variables in # Makefile.coq. Until then, this file MUST NOT use := to access any # variables defined after its inclusion in Makefile.coq. By contrast # variable definitions with lazy setting (=) and the recipe of rules # are allowed to make use of variables defined later on in # Makefile.coq. Prerequisites of targets which depend on the contents # of variables which (transitively) make use of variables defined # after this file's inclusion in Makefile.coq MUST be doubly escaped # so that they are evaluated late enough. We use .SECONDEXPANSION: to # enable double-escaping. Targets themselves also MUST NOT make # (transitive) use of variables defined after this file's inclusion in # Makefile.coq include Makefile.coq.local-early .SECONDEXPANSION: # TODO(not yet ported from automake): install these files: theories etc LICENSE.txt CREDITS.txt INSTALL.md README.md # the alectryon binary ALECTRYON = python3 etc/alectryon/alectryon.py ALECTRYON_EXTRAFLAGS ?= # In the old makefile set up we silence noise coming from coqc by # setting TIMING=1. By doing so here we get the same effect. TIMING ?= 1 CATEGORY_VFILES = $(filter theories/Categories%.v, $(VFILES)) CORE_VFILES = $(filter-out $(CATEGORY_VFILES),$(filter theories/%.v, $(VFILES))) CONTRIB_VFILES = $(filter contrib/%.v, $(VFILES)) # This setting is already present in Makefile.coq, but it comes after # Makefile.coq.local is included, and we have targets that depend on # the value of this variable, so we must duplicate the setting. Since # the only use of this variable is to allow users to pass VO=vio on # the command line to build the non-proofs version, it does not hurt # to set it again. Once https://github.com/coq/coq/pull/12411 is # merged and we bump the minimum version to include this, we can drop # `VO=vo` VO=vo # likewise, the `strip_dotslash` helper function is a duplicate from # Makefile.coq and will not be needed once coq/coq#12411 is merged strip_dotslash = $(patsubst ./%,%,$(1)) # The list of files that comprise the HoTT library CORE_VOFILES=$(CORE_VFILES:.v=.$(VO)) CORE_GLOBFILES=$(CORE_VFILES:.v=.glob) CORE_HTMLFILES=$(patsubst theories.%,html/HoTT.%,$(subst /,.,$(CORE_VFILES:.v=.html))) CORE_TIMING_HTMLFILES=$(patsubst html/%,timing-html/%,$(CORE_HTMLFILES)) CORE_DPDFILES=$(patsubst theories.%,file-dep-graphs/HoTT.%,$(subst /,.,$(CORE_VFILES:.v=.dpd))) # The list of files from contrib CONTRIB_VOFILES=$(CONTRIB_VFILES:.v=.$(VO)) CONTRIB_GLOBFILES=$(CONTRIB_VFILES:.v=.glob) CONTRIB_HTMLFILES=$(patsubst contrib.%,html/HoTT.Contrib.%,$(subst /,.,$(CONTRIB_VFILES:.v=.html))) CONTRIB_TIMING_HTMLFILES=$(patsubst html/%,timing-html/%,$(CONTRIB_HTMLFILES)) # I'm not sure why we needs = rather than :=, but we seem to ALL_BUILT_HOTT_VFILES = $(CORE_VFILES) $(CATEGORY_VFILES) $(CONTRIB_VFILES) ALL_HOTT_VFILES = $(call strip_dotslash,$(shell find -name "*.v" -not -path "./coq-HoTT/*" -not -path "./etc/*")) UNBUILT_VFILES = $(filter-out $(ALL_BUILT_HOTT_VFILES),$(ALL_HOTT_VFILES)) # TODO(leftover from porting from automake): get rid of redundancy # between MAIN_* and ALL_*, and maybe remove the ones redundant with # the Makefile.coq variables entirely. Note that # {MAIN,ALL}_{V,VO,GLOB}FILES should be the same as the corresponding # Makefile.coq variable, but {MAIN,ALL}_HTMLFILES is NOT the same as # HTMLFILES from Makefile.coq (the latter lives alongside the .v # files, while the former lives in the html/ directory) # The list of all files, mainly used for html MAIN_VFILES = $(CORE_VFILES) $(CATEGORY_VFILES) $(CONTRIB_VFILES) MAIN_VOFILES = $(MAIN_VFILES:.v=.$(VO)) MAIN_GLOBFILES = $(MAIN_VFILES:.v=.glob) MAIN_HTMLFILES = $(CORE_HTMLFILES) $(CATEGORY_HTMLFILES) $(CONTRIB_HTMLFILES) MAIN_TIMING_HTMLFILES = $(CORE_TIMING_HTMLFILES) $(CATEGORY_TIMING_HTMLFILES) $(CONTRIB_TIMING_HTMLFILES) MAIN_DPDFILES = $(CORE_DPDFILES) $(CATEGORY_DPDFILES) ALL_VFILES = $(MAIN_VFILES) ALL_VOFILES = $(MAIN_VOFILES) ALL_GLOBFILES=$(MAIN_GLOBFILES) ALL_HTMLFILES=$(MAIN_HTMLFILES) ALL_TIMING_HTMLFILES=$(MAIN_TIMING_HTMLFILES) ALL_TIMINGFILES=$(ALL_VFILES:.v=.v.timing) ALL_ALECTRYON_HTMLFILES=$(patsubst html/%,alectryon-html/%,$(ALL_HTMLFILES)) ALL_DPDFILES=$(MAIN_DPDFILES) ALL_SVGFILES=$(ALL_DPDFILES:.dpd=.svg) ALL_DOTFILES=$(ALL_DPDFILES:.dpd=.dot) HOTT_LIB_FILES=$(subst /,.,$(patsubst theories/%.v,HoTT.%,$(CORE_VFILES))) # Which extra files should be cleaned EXTRA_CLEANFILES = html-done.timestamp HoTT.deps HoTTCore.deps file-dep-graphs/hott-all.dot file-dep-graphs/hott-all.dpd file-dep-graphs/hott-all.svg file-dep-graphs/hott-lib.dot file-dep-graphs/hott-lib.dpd file-dep-graphs/hott-lib.svg .PHONY: hottlib hott-core hott-categories contrib alectryon timing-html svg-file-dep-graphs svg-aggregate-dep-graphs svg-dep-graphs strict strict-test strict-no-axiom # The HoTT library as a single target hott-core: $(CORE_VOFILES) hott-categories: $(CATEGORY_VOFILES) contrib: $(CONTRIB_VOFILES) hottlib: hott-core hott-categories contrib # a strict rule that will error if there are .v files around which aren't in _CoqProject strict-test: $(HIDE) if [ x"$(UNBUILT_VFILES)" != x ]; then \ echo "Error: The files '$(UNBUILT_VFILES)' are present but are not in _CoqProject"; \ exit 1; \ fi # a rule that will error if there are any .v files that require FunextAxiom or UnivalenceAxiom # coq_makefile-based makefiles don't handle building .vo and .glob in # parallel, so we never depend on .glob files, we just depend on the # corresponding .vo files strict-no-axiom: $(ALL_VOFILES) $(HIDE) if [ ! -z "$$(grep 'HoTT\.\(FunextAxiom\|UnivalenceAxiom\) <> <> lib' -l $(GLOBFILES))" ]; then \ echo "Error: The files '$$(grep 'HoTT\.\(FunextAxiom\|UnivalenceAxiom\) <> <> lib' -l $(GLOBFILES))' depend on FunextAxiom or UnivalenceAxiom."; \ exit 1; \ fi strict: strict-test strict-no-axiom hottlib hott-core hott-categories contrib # The deps file, for graphs HoTT.deps: $(ALL_VFILES) $(SHOW)'COQDEP > $@' $(HIDE)$(COQDEP) $(COQLIBS) $(ALL_VFILES) | sed s'#\\#/#g' >$@ HoTTCore.deps: $(CORE_VFILES) $(SHOW)'COQDEP > $@' $(HIDE)$(COQDEP) $(COQLIBS) $(CORE_VFILES) | sed s'#\\#/#g' >$@ # The HTML files # We have a dummy file, to allow us to depend on the html files # without remaking them every time, and to prevent make -j2 from # running coqdoc twice. We also add a real-html target so that we can # force a rebuild of html while still updating the timestamp file, # with a single target. .PHONY: real-html html-done.timestamp real-html: $(ALL_VOFILES) $(ALL_VFILES) $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" html touch html-done.timestamp timing-html: $(ALL_TIMING_HTMLFILES) timing-html/coqdoc.css timing-html/toc.html timing-html/coqdoc.css timing-html/toc.html: timing-html/% : html/% @ mkdir -p timing-html cp "$<" "$@" $(ALL_HTMLFILES) html/index.html html/coqdoc.css html/toc.html : html-done.timestamp $(CORE_TIMING_HTMLFILES) $(CATEGORY_TIMING_HTMLFILES): timing-html/HoTT.%.html : theories/$$(subst .,/,$$*).vo etc/time2html @ mkdir -p $(dir $@) $(SHOW)'TIME2HTML HoTT.$* > $@' $(HIDE) etc/time2html "$(<:.vo=.v.timing)" "$(<:.vo=.v)" > $@ $(CONTRIB_TIMING_HTMLFILES): timing-html/HoTT.Contrib.%.html : contrib/$$(subst .,/,$$*).vo etc/time2html @ mkdir -p $(dir $@) $(SHOW)'TIME2HTML $* > $@' $(HIDE) etc/time2html "$(<:.vo=.v.timing)" "$(<:.vo=.v)" > $@ # the alectryon files alectryon-html/index.html alectryon-html/toc.html alectryon-html/coqdoc.css : alectryon-html/% : html/% @ mkdir -p alectryon-html cp -f $< $@ alectryon-html-done.timestamp: $(ALL_VOFILES) $(ALL_VFILES) @ mkdir -p alectryon-html $(TIMER) $(ALECTRYON) --frontend coq+rst --backend webpage --sertop-arg=--no_prelude --sertop-arg=--indices-matter $(COQLIBS_NOML) --output-directory alectryon-html --cache-directory alectryon-cache --long-line-threshold=99999 $(ALECTRYON_EXTRAFLAGS) $(ALL_VFILES) touch alectryon-html-done.timestamp alectryon-html: rm -f alectryon-html-done.timestamp $(MAKE) alectryon-html-done.timestamp $(ALL_ALECTRYON_HTMLFILES) : alectryon-html-done.timestamp alectryon: $(ALL_ALECTRYON_HTMLFILES) alectryon-html/toc.html alectryon-html/coqdoc.css alectryon-html/index.html # dpdgraphs %.svg: %.dot $(SHOW)'DOT $< -o $@' $(HIDE) if [ -s "$<" ]; then dot -Tsvg "$<" -o "$@"; else (echo "" > "$@"; touch "$@"); fi # don't do anything if zero size file-dep-graphs/%.dot: file-dep-graphs/%.dpd $(SHOW)'DPD2DOT $< -o $@' $(HIDE) if [ -s "$<" ]; then dpd2dot $< -graphname $(subst -,_,$(subst .,_,$*)) -o $@ >/dev/null; else (echo "" > "$@"; touch "$@"); fi $(MAIN_DPDFILES): file-dep-graphs/HoTT.%.dpd : theories/$$(subst .,/,$$*).vo @ mkdir -p $(dir $@) $(SHOW)'COQTHMDEP HoTT.$* > $@' $(HIDE)rm -f $@.ok $(HIDE) ((echo "Require HoTT.$*."; echo 'Require Import dpdgraph.dpdgraph.'; echo 'Set DependGraph File "$@".'; echo 'Print FileDependGraph HoTT.$*.') | $(COQTOP) $(COQFLAGS) $(COQLIBS) && touch $@.ok) >/dev/null 2>&1 | grep -v '^Coq <' >&2 || true $(HIDE)rm $@.ok file-dep-graphs/hott-lib.dpd: $(CORE_VOFILES) @ mkdir -p $(dir $@) $(SHOW)'COQTHMDEP HoTTLib' $(HIDE) ((echo "Require $(HOTT_LIB_FILES)."; echo 'Require Import dpdgraph.dpdgraph.'; echo 'Set DependGraph File "$@".'; echo 'Print FileDependGraph $(HOTT_LIB_FILES).') | $(COQTOP) $(COQFLAGS) $(COQLIBS) && touch $@.ok) >/dev/null 2>&1 | grep -v '^Coq <' >&2 || true $(HIDE)rm $@.ok #file-dep-graphs/hott-all.dpd: $(CORE_VOFILES) $(CATEGORY_VOFILES) # @ mkdir -p $(dir $@) # $(SHOW)'HOQTHMDEP HoTT' # HOTT_ALL_FILES=$(subst /,.,$(patsubst $(srcdir)/theories/%.v,HoTT.%,$(CORE_VFILES) $(CATEGORY_VFILES))) # $(HIDE) ((echo "Require $(HOTT_ALL_FILES)."; echo 'Require Import dpdgraph.dpdgraph.'; echo 'Set DependGraph File "$@".'; echo 'Print FileDependGraph $(HOTT_ALL_FILES).') | $(COQTOP) $(COQFLAGS) $(COQLIBS) && touch $@.ok) >/dev/null 2>&1 | grep -v '^Coq <' >&2 || true # $(HIDE)rm $@.ok file-dep-graphs/index.html: Makefile _CoqProject Makefile.coq.local Makefile.coq @ mkdir -p $(dir $@) $(SHOW)'MAKE $@' $(HIDE) (echo "Dependency Graphs"; \ echo '
    '; \ echo '
  • HoTT Core Library
    • '; \ for i in $(patsubst file-dep-graphs/%.svg,%,$(ALL_SVGFILES)); \ do echo "
  • $$i
    • "; \ done; \ echo "
") \ > $@ svg-dep-graphs: svg-file-dep-graphs svg-aggregate-dep-graphs dot-dep-graphs: dot-file-dep-graphs dot-aggregate-dep-graphs svg-aggregate-dep-graphs: file-dep-graphs/hott-lib.svg #file-dep-graphs/hott-all.svg dot-aggregate-dep-graphs: file-dep-graphs/hott-lib.dot #file-dep-graphs/hott-all.dot svg-file-dep-graphs: $(ALL_SVGFILES) $(ALL_DOTFILES) dot-file-dep-graphs: $(ALL_DOTFILES) # The TAGS file TAGS_FILES = $(ALL_VFILES) TAGS : $(TAGS_FILES) ./etc/emacs/run-etags.sh $^ # We separate things to work around `make: execvp: /bin/bash: Argument list too long` clean:: $(SHOW)"RM *.HTML" $(HIDE)rm -f $(ALL_HTMLFILES) $(SHOW)"RM *.XML" $(HIDE)rm -f $(ALL_XMLFILES) $(SHOW)"RM *.HTML" $(HIDE)rm -f $(ALL_ALECTRYON_HTMLFILES) $(SHOW)"RM *.TIMING" $(HIDE)rm -f $(ALL_TIMINGFILES) $(SHOW)"RM *.TIMING.HTML" $(HIDE)rm -f $(ALL_TIMING_HTMLFILES) $(SHOW)"RM *.SVG" $(HIDE)rm -f $(ALL_SVGFILES) $(SHOW)"RM *.DPD" $(HIDE)rm -f $(ALL_DPDFILES) $(SHOW)"RM *.DOT" $(HIDE)rm -f $(ALL_DOTFILES) rm -f $(EXTRA_CLEANFILES) find theories contrib test \( -name \*.vo -o -name \*.glob -o -name \*.timing \) -delete Coq-HoTT-9.0/Makefile.coq.local-early000066400000000000000000000010531474641544500173610ustar00rootroot00000000000000# Once https://github.com/coq/coq/pull/12411 is merged and we bump the # minimum version to a version including that PR, this file should # become Makefile.coq.local, and we should rename Makefile.coq.local # to Makefile.coq.local-late; Makefile.coq.local-early contains code # that overrides the relevant variables in Makefile.coq, while # Makefile.coq.local currently contains additional targets that need # access to the variables in Makefile.coq COQDOCEXTRAFLAGS?= COQDOCFLAGS?=--interpolate --utf8 --no-externals --parse-comments $(COQDOCEXTRAFLAGS) Coq-HoTT-9.0/README.md000066400000000000000000000064051474641544500142220ustar00rootroot00000000000000[![Github Actions CI][1]][2] [![HoTT Zulip chat][3]][4] [Homotopy Type Theory][5] is an interpretation of Martin-Löf’s intensional type theory into abstract homotopy theory. Propositional equality is interpreted as homotopy and type isomorphism as homotopy equivalence. Logical constructions in type theory then correspond to homotopy-invariant constructions on spaces, while theorems and even proofs in the logical system inherit a homotopical meaning. As the natural logic of homotopy, type theory is also related to higher category theory as it is used e.g. in the notion of a higher topos. The HoTT library is a development of homotopy-theoretic ideas in the Coq proof assistant. It draws many ideas from Vladimir Voevodsky's [Foundations][6] library (which has since been incorporated into the [UniMath][7] library) and also cross-pollinates with the [HoTT-Agda][8] library. See also: [HoTT in Lean2][9], [Spectral Sequences in Lean2][10], and [Cubical Agda][11]. More information about this library can be found in: - _The HoTT Library: A formalization of homotopy type theory in Coq_, Andrej Bauer, Jason Gross, Peter LeFanu Lumsdaine, Mike Shulman, Matthieu Sozeau, Bas Spitters, 2016 [arXiv][12] [CPP17][13] Other publications related to the library can be found [here][14]. # Installation The HoTT library is part of the [Coq Platform][15] and can be installed using the installation instructions there. More detailed installation instructions are provided in the file [INSTALL.md](/INSTALL.md). # Usage The HoTT library can be used like any other Coq library. If you wish to use the HoTT library in your own project, make sure to put the following arguments in your `_CoqProject` file: ``` -arg -noinit -arg -indices-matter ``` For more advanced use such as contribution see [INSTALL.md](/INSTALL.md). For **recommended text editors** see [our recommended editors list](./INSTALL.md#4-editors). Other methods of developing in `coq` will work as long as the correct arguments are passed. # Contributing Contributions to the HoTT library are very welcome! For style guidelines and further information, see the file [STYLE.md](/STYLE.md). # Licensing The library is released under the permissive BSD 2-clause license, see the file [LICENSE.txt](/LICENSE.txt) for further information. In brief, this means you can do whatever you like with it, as long as you preserve the Copyright messages. And of course, no warranty! # Wiki More information can be found in the [Wiki][22]. [1]: https://github.com/HoTT/HoTT/workflows/CI/badge.svg?branch=master [2]: https://github.com/HoTT/HoTT/actions?query=workflow%3ACI+branch%3Amaster [3]: https://img.shields.io/badge/zulip-join_chat-brightgreen.svg [4]: https://hott.zulipchat.com/ [5]: http://homotopytypetheory.org/ [6]: https://github.com/vladimirias/Foundations [7]: https://github.com/UniMath/UniMath [8]: https://github.com/HoTT/HoTT-Agda [9]: https://github.com/leanprover/lean2/tree/master/hott [10]: https://github.com/cmu-phil/Spectral [11]: https://agda.readthedocs.io/en/v2.6.0.1/language/cubical.html [12]: https://arxiv.org/abs/1610.04591 [13]: http://cpp2017.mpi-sws.org/ [14]: https://github.com/HoTT/HoTT/wiki/Publications-based-on-the-HoTT-library [15]: https://github.com/coq/platform/releases [22]: https://github.com/HoTT/HoTT/wikiCoq-HoTT-9.0/STYLE.md000066400000000000000000002063151474641544500141670ustar00rootroot00000000000000 ## Table of Contents - [Conventions And Style Guide](#conventions-and-style-guide) - [1. Organization](#1-organization) - [1.1. The Core library](#11-the-core-library) - [1.2. Non-core files](#12-non-core-files) - [1.3. Tests](#13-tests) - [1.4. Dependencies](#14--dependencies) - [2. Naming Conventions](#2-naming-conventions) - [2.1. General principles](#21-general-principles) - [2.2. Capitalization and spacing](#22-capitalization-and-spacing) - [2.3. Suffixes](#23-suffixes) - [2.4. Induction and recursion principles](#24-induction-and-recursion-principles) - [2.5. Path algebra functions](#25-path-algebra-functions) - [2.6. Equivalences](#26-equivalences) - [3. Records, Structures, Typeclasses](#3-records-structures-typeclasses) - [3.1. Two-component records](#31-two-component-records) - [3.2. Typeclasses](#32-typeclasses) - [3.3. When to declare instances](#33-when-to-declare-instances) - [3.4. Local and Global Instances](#34-local-and-global-instances) - [3.5. Using Typeclasses](#35-using-typeclasses) - [3.6. Truncation](#36-truncation) - [3.7. Coercions and Existing Instances](#37-coercions-and-existing-instances) - [4. Axioms](#4-axioms) - [4.1. Univalence, function extensionality and propositional resizing](#41-univalence-function-extensionality-and-propositional-resizing) - [4.2. Higher inductive types](#42-higher-inductive-types) - [4.3. Relationships between axioms](#43-relationships-between-axioms) - [4.4. Assuming axioms](#44-assuming-axioms) - [4.5. Technical note: Universe-polymorphic axioms](#45-technical-note-universe-polymorphic-axioms) - [5. Higher Inductive Types](#5-higher-inductive-types) - [5.1. Case analysis on private inductive](#51-case-analysis-on-private-inductive) - [6. Universe Polymorphism](#6-universe-polymorphism) - [6.1. Displaying universes](#61-displaying-universes) - [6.2. Universe annotations](#62-universe-annotations) - [6.3. Unexpected universes](#63-unexpected-universes) - [6.4. Lifting and lowering](#64-lifting-and-lowering) - [6.5. Universes and HITs](#65-universes-and-hits) - [7. Transparency and Opacity](#7-transparency-and-opacity) - [8. Imports/exports](#8-importsexports) - [9. Formatting](#9-formatting) - [9.1. Location of commands](#91-location-of-commands) - [9.2. Indentation](#92-indentation) - [9.3. Line lengths and comments](#93-line-lengths-and-comments) - [9.4. Tactic scripts](#94-tactic-scripts) - [9.5. Placement of Arguments and types](#95-placement-of-arguments-and-types) - [10. Implicit Arguments](#10-implicit-arguments) - [11. Coding Hints](#11-coding-hints) - [11.1. Notations](#111-notations) - [11.2. Unfolding definitions](#112-unfolding-definitions) - [11.3. Finding theorems](#113-finding-theorems) - [11.4. Simpl nomatch](#114-simpl-nomatch) - [11.5. Available tactics](#115-available-tactics) - [12. Contributing to the library](#12-contributing-to-the-library) - [12.1. Fork \& Pull](#121-fork--pull) - [12.2. Approval of pull requests](#122-approval-of-pull-requests) - [12.3. Commit messages](#123-commit-messages) - [12.4. Creating new files](#124-creating-new-files) - [12.5. Travis](#125-travis) - [12.6. Git rebase](#126-git-rebase) - [12.7. Timing scripts](#127-timing-scripts) - [13. Bugs in Coq](#13-bugs-in-coq) - [13.1. Reporting bugs](#131-reporting-bugs) - [13.2. Minimizing bugs](#132-minimizing-bugs) # Conventions And Style Guide # ## 1. Organization ## ### 1.1. The Core library ### We do not use the Coq standard library, instead working from scratch. We do not use the Coq universes `Prop` and `SProp`. The Coq files of the HoTT library live in the `theories/` directory. Many are in subdirectories, and a subdirectory `Foo/` often has a corresponding file `Foo.v` that imports everything in the subdirectory. - `Basics/*`: These files contain basic definitions that underlie everything else. Nothing in the Basics directory should depend on anything outside the Basics directory. The file `Basics` in the root imports everything from the directory `Basics/`, so most other files in the library start with `Require Import HoTT.Basics.` (See remarks below on qualified imports.) - `Types/*`: This subdirectory contains a file corresponding to each basic type former (e.g. sigma-types, pi-types, etc.), which proves the "computational" rules for the path-types, transport, functorial action, etc. of that type former. It also `Types/Equiv`, which proves that being an equivalence is an hprop. The univalence axiom is introduced, as a typeclass (see below) in `Types/Universe`. Function extensionality is introduced in `Basics/Overture` for dependency reasons, but developed further in `Types/Forall` and `Types/Arrow`. Some type formers are defined in their corresponding `Types/` file, while others are defined in `Basics/Overture` for dependency reasons but studied further in their `Types/` file. Files in `Types/` should not depend on anything except `Basics` and other `Types/` files. - `Universes/*`: Files related to universe levels, classifying maps, or to particular subuniverses, including `UniverseLevel`, `Smallness`, `ObjectClassifier`, `BAut`, `HProp`, `HSet`, `DProp`, and `TruncType`. The files here depend on files in `Types/`, and occasionally on some files mentioned below. - There are files in the root `theories/` directory, including `EquivGroupoids`, `ExcludedMiddle`, `Factorization`, `HFiber`, `Extensions`, `Projective`, `Idempotents`, `Constant`, `BoundedSearch`, etc. These contain more advanced results which may depend on files in the whole library. We try to limit the number of files in the top-level folder, and would like to reduce the number. - `WildCat/*`: Files related to wild categories. They are used extensively in the library, so we try to minimize the files they depend on. - `Modalities/*`: Files involving modalities. The most important files here are `Modalities/ReflectiveSubuniverse` and `Modalities/Modality`. - `Basics/Trunc`, `TruncType`, `Truncations/*`: Files involving truncations. There are interdependencies between the files in `Truncations/` and some of the `Modalities/*` files. - `Equiv/*`: Files showing that various definitions of equivalence agree. - `Pointed/*`: Files related to pointed types. - `HIT/*`: Files involving higher inductive types. Each higher inductive type is defined in a corresponding file (see conventions on defining HITs, below). These are only lightly used in the rest of the library. See `Colimits/*` for the HIT that is most commonly used. - `Diagrams/*`: Files involving graphs and diagrams, used for colimits and limits. - `Colimits/*`: Files involving colimits. `Colimits/GraphQuotient` defines graph quotients as a HIT, and other constructions are built from this. - `Limits/*`: Files involving limits. - `Cubical/*`: Files involving cubical methods in HoTT. - `Algebra/*`: Files related to algebra. - `Analysis/*`: Files related to analysis. - `Sets/*`: Files related to set theory. - `Spaces/*`: Files involving various spaces, including `Spaces/Nat/*`, `Spaces/Pos/*`, `Spaces/Int/*`, `Spaces/Finite/*`, `Spaces/List/*`, `Spaces/Circle`, `Spaces/Torus/*`, `Spaces/Universe`, `Spaces/BAut/*` and `Spaces/No/*` (the surreal numbers), - `Homotopy/*`: Files related to synthetic homotopy theory. Also contains `Homotopy/IdentitySystems` and `Homotopy/EncodeDecode`, which give results for computing path types. - `Spectra/*`: Files related to spectra in the sense of stable homotopy theory. - `Tactics, Tactics/*`: some more advanced tactics. - `HoTT`: This file imports and exports everything in the core (that is, everything mentioned above). Thus, in a development based on the HoTT library, you can say simply `Require Import HoTT` to pull in everything (but don't do this for files in the core itself). - `theories/Classes/*`: The math classes library. While we don't regard this as part of the core library, and don't explicitly export the contents in `HoTT`, some files in the classes library are used by files in the core library. ### 1.2. Non-core files ### - `theories/Axioms/`: Contains `FunextAxiom` and `UnivalenceAxiom`: You can import these files to assume the axioms globally (in the core, we track them with typeclasses). - `theories/Metatheory/*`: Contains `UnivalenceImpliesFunext`, `IntervalImpliesFunext`, `ImpredicativeTruncation`, `PropTrunc`, `Nat` (a definition of the natural numbers using univalence and propositional resizing), and other meta-theoretic results. - `theories/Utf8` and `theories/Utf8Minimal`: optional Unicode notations for the basic definitions (we avoid Unicode in the core library). - `theories/Categories/*`: The categories library, which is not considered part of the core (e.g. it uses unicode), but nevertheless lives in `theories/`. - `contrib/HoTTBook`: This file lists all the definitions and theorems from the HoTT Book and gives pointers to where the corresponding fact is defined in the library. It is not intended to be a formalization of the book, but rather a guide to the library for a reader familiar with the book. - `contrib/HoTTBookExercises`: This file contains both formalizations of the exercises from the HoTT Book, and pointers to the corresponding facts in the library. The latter pointers serve the same purpose as `contrib/HoTTBook`, but the former may contain alternative solutions, such as ones that depend only on the concepts that are introduced prior to the exercise in the book. - `contrib/*`: Other work in progress, or files not judged appropriate for the core. ### 1.3. Tests ### - `test/*`: Tests of the library. See the file `test/README.md` for more information. ### 1.4. Dependencies ### A dependency graph of all the files in the library can be found on the [wiki][wiki]; this may be helpful in avoiding circular dependencies. It is updated automatically by Travis (see below) on every push to the master branch. [wiki]: https://github.com/HoTT/HoTT/wiki ## 2. Naming Conventions ## ### 2.1. General principles ### In general, the name of a theorem (or definition, or instance, etc.) should begin with the property (or structure, or class, or record, etc.) being proven, and then state the object or construction it is being proven about. For instance, `isequiv_idmap` proves `IsEquiv idmap`, and `equiv_compose` constructs an "Equiv" record by composing two given equivalences. In particular, a prefix of `path_` means a theorem that constructs a path in some type. For instance, `path_sigma` is a theorem constructing paths in a sigma-type. More generally, where applicable the order of parts in a lemma name should roughly respect their placement in (the syntax tree of) the goal, from outermost to deepest. For instance, `path_equiv` constructs a path in the type `Equiv f g`, while `isequiv_path_equiv` shows that `path_equiv` is an equivalence. ### 2.2. Capitalization and spacing ### Names of types, such as `Unit` and `Equiv` and `IsHProp`, should generally be capitalized. Names of functions and definitions should be lowercase, including the names of types when they appear therein. Thus, for instance, the theorem that `Unit` is contractible is `contr_unit : Contr Unit`. Multiple-word names, especially in lowercase, should generally be separated with underscores. We make an exception for names of types beginning with `is`, such as `IsEquiv` and `IsTrunc`. ### 2.3. Suffixes ### A suffix of `D` indicates a dependent version of something ordinarily non-dependent. For instance, `ap` applies to non-dependent functions while `apD` applies to dependent ones. When possible, the non-dependent version should be an instantiation of the dependent one using constant type families, but sometimes they are more different than this, usually due to the fact that `transport_const` is not the identity (e.g. `ap` and `apD`). When there is more than one theorem that seems to merit the same name, and no obvious concise way to distinguish them, one of them can be given a prime suffix, e.g. we have `path_sigma` and `path_sigma'`. Do this with caution. ### 2.4. Induction and recursion principles ### In conformity with the HoTT Book, the induction principle of a (perhaps higher) inductive type `thing` (that is, its dependent eliminator) should be named `thing_ind`, while its recursion principle (non-dependent eliminator) should be named `thing_rec`. However, by default, when you declare a (non-higher) inductive type, Coq automatically defines induction principles named `thing_rect`, `thing_rec`, and `thing_ind` that vary only in the sort of their target (`Type`, `Set`, or `Prop`). In order to turn this off, you must say `Local Unset Elimination Schemes` before defining an inductive type. You can then have Coq automatically generate the correctly named induction principles with ```coq Scheme thing_ind := Induction for thing Sort Type. Scheme thing_rec := Minimality for thing Sort Type. ``` Unfortunately, Coq's built-in tactics `induction` and `elim` assume that the induction principles are named in Coq's default manner. We are hoping that this will be [fixed eventually][inductionbug], but in the meantime, to make those tactics work, you need to also say ```coq Definition thing_rect := thing_ind. ``` (We have not turned on `Global Unset Elimination Schemes` because this would cause `induction` and `elim` to fail for all newly defined inductive types unless these `Scheme` commands are also given, which might be an unpleasant and confusing surprise to people who haven't read (or don't remember) these instructions.) Note that elimination schemes are always off for `Private Inductive` types such as are used to hack HITs. For HITs, you must always define both the induction and recursion principles by hand, as described in the appropriate section below. Some types have a "coinduction" or "corecursion" principle; these should have instead the suffix `_coind` or `_corec`. Finally, a type will often have a universal property expressed by saying that its induction or recursion (or coinduction or corecursion) principle is an equivalence. These should be named according to the naming conventions for equivalences below, e.g. `isequiv_thing_rec` and `equiv_thing_rec`. [inductionbug]: https://github.com/coq/coq/issues/3745 ### 2.5. Path algebra functions ### The path algebra functions defined mainly in `Basics/PathGroupoids` follow a particular set of naming conventions. Generally they are named according to the head constant of their primary input and the pattern of paths appearing therein. For more details, see the comments in `Basics/PathGroupoids`. ### 2.6. Equivalences ### When defining an equivalence, the standard naming procedure is to - Define the function in one direction with a name, say `foo`. - Define an `IsEquiv` instance for this function, called `isequiv_foo`. - Define an `Equiv` record putting them together, called `equiv_foo`. The inverse function can then be referred to as `foo ^-1`. Avoid using `equiv_foo` unless you really do need an `Equiv` object, rather than a function which happens to be an equivalence. On the other hand, sometimes it is easier to define an equivalence by composing together existing equivalences, in which case one goes immediately to the last step, defining `equiv_foo`. If the equivalence is used frequently as an ordinary function, one might also define `foo` as the underlying function of `equiv_foo`; see `path_equiv`, as an example. ## 3. Records, Structures, Typeclasses ## We use Coq Records when appropriate for important definitions. For instance, being an equivalence (`IsEquiv`) and equivalences (`Equiv`) are both Record types (in fact, the former is a typeclass). The file `Basics/Tactics` contains a tactic `issig` for proving semiautomatically that record types are equivalent to the corresponding sigma-types, so that the relevant general theorems can be applied to them. ### 3.1. Two-component records ### Sometimes a two-component record is better defined as a sigma-type, especially if it is a "subset type" whose second component is an hprop. For instance, this has the advantage that we do not need new names for its constructor and its fields, and we can apply theorems in `Types/Sigma` to it directly rather than via `issig`. TODO: Decide about `hProp` and `hSet` and `TruncType` (issue [#514](https://github.com/HoTT/HoTT/issues/514)). ### 3.2. Typeclasses ### We are using typeclasses in preference to canonical structures. Typeclasses are particularly convenient for h-properties of objects. Here are some of the typeclasses we are using: - equivalences: `IsEquiv` - truncation levels: `IsTrunc` (a notation for `IsTrunc_internal`) - axioms (see below): `Funext`, `Univalence` - subuniverses: `In`, `Replete`, `MapIn`, `IsConnected`, `IsConnMap` `IsHSet`, `IsHProp`, and `Contr` are notations for `IsTrunc 0`, `IsTrunc -1`, and `IsTrunc -2` respectively. See the comments in `Overture.v` for more details. ### 3.3. When to declare instances ### When constructing terms in a typeclass record such as `IsEquiv`, `Contr`, or `IsTrunc`, one has the choice to declare it as an `Instance`, in which case it is added to the hint database that is searched when Coq tries to do typeclass instance resolution. Care must be taken with this, as indiscriminately adding theorems to this database can easily result in infinite loops (or at least very long loops). In general, it seems to be better not to add instances which suggest an open-ended search. E.g. the theorem that truncation levels are closed under equivalence is a bad candidate for an `Instance`, because when Coq is searching for a proof of `Contr B` this theorem could cause it to look through all possible types A for an equivalence `A <~> B` and a proof of `Contr A`. Results of this sort should be proven as `Definition`s or `Theorem`s, not as `Instance`s. If you need to use a result of this sort in the middle of a proof, use a tactic like `pose` or `assert` to add a particular instance of its conclusion to the context; then it will be found by subsequent typeclass resolution. If you have determined through trial and error that a particular result should not be an `Instance` (e.g. when making it an `Instance`, a tactic in some other proof loops, but changing it to a `Definition` prevents this), please add a comment to that effect where it is defined. This way no one else will come along and helpfully change it back to an `Instance`. If a particular fact should not be made an ordinary instance, it can still be made an "immediate instance", meaning that Coq will use it automatically to solve a goal *if* its hypotheses are already present in the context, but will not initiate an instance search for those hypotheses otherwise. This avoids infinite instance-search loops. To declare a fact as an immediate instance, make it a `Definition` rather than an `Instance` and then say ```coq Hint Immediate foo : typeclass_instances. ``` ### 3.4. Local and Global Instances ### When declaring an `Instance` you should *always* use either the `Local` or the `Global` keyword. The former makes the instance local to the current section, module, or file (although its *definition* will still be visible globally, it won't be in the instance database for typeclass resolution outside its containing section, module or file), while the latter puts it in the instance database globally. If you write `Instance` without `Local` or `Global`, Coq will sometimes make it local and sometimes global, so to avoid confusion it is better to always specify explicitly which you intend. ### 3.5. Using Typeclasses ### Try to avoid ever giving a name to variables inhabiting typeclasses. When introducing such a variable, you can write `intros ?` to put it in the hypotheses without specifying a name for it. When using such a variable, typeclass resolution means you shouldn't even need to refer to it by name: you can write `_` in tactics such as `refine` and Coq will find typeclass instances from the context. Even `exact _` works. (You can usually also use `typeclasses eauto` or `eauto with typeclass_instances`, but `exact _` is preferable when it works, as it is shorter and uses a tactic name the reader is presumably already familiar with.) Unfortunately, it is not currently possible to write `_` in a `refine`d term for an inhabitant of a typeclass and have Coq generate a subgoal if it can't find an instance; Coq will fail if it can't resolve a typeclass variable from the context. You have to `assert` or `pose` such an inhabitant first, or give an explicit term for it. Note that when you don't give a name to a variable, Coq often names it `H` or some modification thereof. For that reason, it's often better avoid using `H` for your own explicitly named variables, since if you do and later on someone introduces a new unnamed hypothesis that Coq names `H`, your name will result in a conflict. Conversely, we sometimes give a hypothesis a name that won't be used, to preempt such conflicts, such as `{ua : Univalence}` or `{fs : Funext}`. One gotcha about typeclass arguments is that they cannot be inferred automatically when preceded by non-implicit arguments. So for instance if we write ```coq Definition foo (A : Type) `{Funext} ``` then the `Funext` argument will not generally be inferable. Thus, typeclass arguments should generally come first if possible. In addition, note that when section variables are generalized at the close of a section, they appear first. Thus, if anything in a section requires `Funext` or `Univalence`, those hypotheses should go in the `Context` at the top of the section in order that they'll come first in the eventual argument lists. ### 3.6. Truncation ### The conventions for the typeclass `IsTrunc` are: * We prefer to do inference with `IsTrunc n A` rather than `IsTrunc n (a = b)`. * We prefer to expand `IsTrunc n (forall a, P a)` into `forall a, IsTrunc n (P a)`, and similarly for other data types. For instance, `IsTrunc n (A * B)` gets transformed to `IsTrunc n A` and `IsTrunc n B`, as a goal. * Due to the desire to use `IsTrunc` rather than `Contr`, we have `Contr` as a notation for `IsTrunc minus_two`. ### 3.7. Coercions and Existing Instances ### A "coercion" from `A` to `B` is a function that Coq will insert silently if given an `A` when it expects a `B`, and which it doesn't display. For example, we have declared `equiv_fun` as a coercion from `A <~> B` to `A -> B`, so that we can use an equivalence as a function without needing to manually apply the projection `equiv_fun`. Coercions can make code easier to read and write, but when used carelessly they can have the opposite effect. When defining a `Record`, Coq allows you to declare a field as a coercion by writing its type with `:>` instead of `:`. When defining a `Class`, the `:>` notation has a different meaning: it declares a field as an `Existing Instance`. (In addition, the `:>` notation is used when needed for path types to indicate the type in which the paths are taken: `x = y :> A` for `x, y : A`.) ## 4. Axioms ## ### 4.1. Univalence, function extensionality and propositional resizing ### The "axioms" of `Univalence`, `Funext` (function extensionality) and `PropResizing` (propositional resizing) are typeclasses rather than Coq `Axiom`s. (But see the technical note below on universe polymorphism.) In the core, we use these typeclasses to keep track of which theorems depend on the axioms and which don't. This means that any theorem which depends on one or the other must take an argument of the appropriate type. It is simple to write this using typeclass magic as follows: ```coq Theorem uses_univalence `{Univalence} (A : Type) ... ``` The axiom-term witnessing univalence does not have to be named, nor does it have to be passed explicitly to any other lemma which uses univalence; once it is in the typeclass context, it should be found automatically. For longer developments using `Univalence` or `Funext`, it is probably preferable to assume it as part of the context. ```coq Section UsesUnivalence. Context `{Univalence}. ``` Now everything defined and proven in this section can use univalence without saying so explicitly, and at the end of the section it will be implicitly generalized if necessary. (Results that don't use univalence won't get an univalence argument.) The backquote syntax ``{Univalence}` allows us to avoid giving a name to the hypothesis. (Backquote syntax is also used for implicit generalization of variables, but that is not needed for univalence and funext.) ### 4.2. Higher inductive types ### Every higher inductive type technically assumes some `Axioms`. These axioms are asserted globally by the corresponding `HIT/` file or `Colimits/GraphQuotient`, since there's not much point to assuming a HIT without the axioms that make it work. ### 4.3. Relationships between axioms ### The file `UnivalenceImpliesFunext` shows, as its name implies, that univalence implies funext. However, this file is not needed in practice, since in `Types/Universe` we assert axiomatically that univalence implies funext. Similarly, the file `HIT/IntervalImpliesFunext` proves funext from the interval type assumed in `HIT/Interval`, so if you import this file then funext is always true automatically (just as if you'd imported `FunextAxiom`). Of course, once you've imported `HIT/Interval` it is always possible to prove funext by hand, but by importing `HIT/Interval` without `HIT/IntervalImpliesFunext` you can still use the interval in some places and track moral uses of funext elsewhere. ### 4.4. Assuming axioms ### When working in a derived development using the HoTT library, you may import the files `FunextAxiom` and/or `UnivalenceAxiom` to assume these axioms globally. You should _not_ assume these axioms yourself by writing something such as `Axiom fs : Funext`. The problem with this is that if two different files do this, and then a third file imports them both, it ends up with two different witnesses for `Funext`, not definitionally equal. Thus, derived objects that should be judgmentally equal might fail to be so because they use different witnesses. ### 4.5. Technical note: Universe-polymorphic axioms ### In order for the "axioms" univalence and funext to be usable at different universe levels, the types `Univalence` and `Funext` do not technically assert the axioms themselves. Rather they assert inhabitants of dummy types, while the axioms are actually declared globally but depending on elements of those dummy types. This is not something you generally need to worry about; see the comments in `Basics/Overture` for more information. However, one situation in which this matters is when proving an implication between axioms. Because `Univalence` and `Funext` are dummy types, we cannot actually prove that `Univalence -> Funext`. Instead we define placeholders with names like `Funext_type` and `Univalence_type` that have the actual type that the axiom would have except for the polymorphism trick, and prove that `Univalence_type -> Funext_type`. Then we feel justified in asserting as a further `Axiom` that `Univalence -> Funext`. When introducing further axioms, please use this same naming convention. For another example, see `ExcludedMiddle.v`. ## 5. Higher Inductive Types ## Most higher inductive types are defined in the `HIT/` directory, but `Colimits/GraphQuotient` also uses a HIT. All are defined using [Dan Licata's "private inductive types" hack][hit-hack] which was [implemented in Coq](https://coq.inria.fr/files/coq5_submission_3.pdf) by Yves Bertot. This means the procedure for defining a HIT is: 1. Wrap the entire definition in a module, which you will usually want to export to the rest of the file containing the definition. 2. Define a `Private Inductive` type whose constructors are the desired point-constructors of your HIT. 3. Assert the desired path-constructors as `Axiom`s. 4. Define the induction principle, with all the correct hypotheses, by matching against the point-constructors. There is an important additional hack here. If the path-hypotheses are not "used" anywhere in the `match`, then Coq will notice and will consider two invocations of the induction principle to be judgmentally equal if they have the same point-hypotheses, even if their path-hypotheses differ. Thus, it is important to "use" the path-hypotheses trivially by making the `match` return a function which is then applied to all the path-hypotheses. For example, with the circle we write `fun x => match x with base => fun _ => b end l` instead of `fun x => match x with base => b end`. 5. Assert the "computation rules" for the path-constructors, in the form of propositional equalities, as `Axiom`s. 6. Close the module. It is important to do this immediately after defining the induction principle, so that the private inductive type can't be matched against anywhere else; any other uses of it have to call the correct induction principle. 7. Usually, you will want to also define a non-dependent recursor and its computation rules as well. Look at some of the existing files in `HIT/*` for examples. Going forward, we try to use `Colimits/GraphQuotient` to define further higher inductive types. [hit-hack]: http://homotopytypetheory.org/2011/04/23/running-circles-around-in-your-proof-assistant/ ### 5.1. Case analysis on private inductive ### You may get this error at `Qed`/`Defined` if unification unfolded the induction principle and used its value to produce the proof term. To fix this, you need to identify which tactic produced the problematic term, then either avoid unification by annotating more (e.g. `apply (@foo bla)` instead of `apply foo`), or guide unification by manipulating the goal (e.g. using `rewrite` with the lemma witnessing the computation rule of the inductive principle) or making related definitions opaque. ## 6. Universe Polymorphism ## We have Coq's "universe polymorphism" feature turned on throughout the library. Thus, all definitions are universe polymorphic by default, i.e. they can be applied to types that live in any universe level. Usually, this is not something you have to worry about, as Coq tries to automatically make everything maximally polymorphic, but sometimes a bit of attention is required. If Coq is claiming that an instance is not found which is "obviously" present, or a term doesn't have a type that it "clearly" does (or, of course, if it complains about a universe inconsistency), then a universe problem may be the culprit. ### 6.1. Displaying universes ### If you suspect a universe problem, usually the first thing to do is to turn on the display of universes with the command `Set Printing Universes`. This causes Coq to print the universe parameters of every occurrence of a definition when displaying the current proof state or when giving an error message, and also to print the universe parameters and the constraints imposed on them when displaying a definition with `Print` or `About` or a typechecking a term with `Check`. (Nowadays Coq is sometimes smart enough to display universes automatically when giving an error message that would otherwise look like "unable to unify `A` with `A`".) To display the current universe _constraints_ during a proof, use `Show Universes` (this is not to be confused with `Print Universes`, which displays the current list of _global_ universes; the latter is usually quite small with universe polymorphism enabled). The universe parameters of an occurrence of a definition are displayed as `foo@{Top.1 Top.2}`. Here `foo` is a definition which takes two universe parameters, and this occurrence of `foo` has those two parameters instantiated to the universes `Top.1` and `Top.2`. When displaying a definition with `Print` or `About`, its universe parameters are shown in a comment below the definition, followed by `|-` and a list of the constraints on those parameters. In general, the universe parameters of a definition are automatically computed from the parameters of its constituents, and the order of the parameters is likewise induced by the order in which they occur in the definition. This means you must generally pay close attention to the output of `Print` or `About` to learn which universe parameter is which, and insignificant-seeming changes in a definition can sometimes cause changes in the number or order of its universe parameters. Note that `Check foo` will often give a different list of universes than `Print foo` and `About foo`. This is because the latter two display information about `foo` as a _definition_, while `Check` treats its argument as a _term_ to be typechecked, and Coq is willing to collapse some universes during typechecking. ### 6.2. Universe annotations ### You can exert a certain degree of control over universe polymorphism by using explicit universe annotations, which use the same syntax as the display of universes: if you write `foo@{i j}`, that means `foo` with its two universe parameters instantiated to the universes `i` and `j`. You are required to supply exactly the right number of universes, and be careful about the order in which they occur. It is very important to note that universe names such as `i` and `j` are _definition local_ and _implicitly declared_. This means that whenever you write `i` inside a universe annotation, Coq implicitly declares a universe named `i`, and all occurrences of the universe `i` _in the same definition_ refer to the same universe. When the definition is complete, this universe will become one of its universe parameters. An annotation named `i` in a different definition will instead become one of _that_ definition's parameters. Thus, if you define `foo` using a universe `i`, and then define `bar` which uses `foo`, in order to force a particular universe parameter of `bar` to coincide with `i` in `foo`, you must annotate the occurrences of `foo` in `bar` appropriately. It is also possible to explicitly declare and name universes globally with the `Universe` command, usually within a section. Universes declared with `Universe` will be discharged on each section definition independently. The universe variables of a definition can be declared and their constraints can be chosen by hand. This is good practice for delicate situations, as it serves to both document the expected constraints and to cause an error if a future change causes the universe variables or constraints to change. We also use `Check` commands, mostly in `test/*`, to verify that universe variables before as expected. There are several uses for universe annotations. One is to force a definition to have fewer universe parameters than it would otherwise. This can sometimes improve performance: if you know that in practice, several of the universes occurring in a definition will always be the same, then saving Coq the burden of carrying them all around separately can sometimes make it run faster. Additionally, reducing the number of universe parameters in a definition can make it significantly easier to universe-annotate uses of that definition later on. Another reason for universe annotations is to make a definition _more_ universe polymorphic. In some situations, in the absence of annotations Coq will automatically collapse one or more universe parameters which could be kept separate if annotated. It is not clear under exactly what situations this occurs, but one culprit appears to be section variables: if you declare a section variable which you need to be universe polymorphic, you may need to annotate it. (Another occasional culprit of less-polymorphic-than-expected definitions seems to be giving type parameters without a type. At least in some situations, writing `Definition foo {A B} ...` rather than `Definition foo {A B : Type} ...` can cause `A` and `B` to live in the same universe.) Finally, universe annotations can also be necessary to instruct Coq how to instantiate the universes when using a definition. In some situations, Coq seems to make a default guess that doesn't work (perhaps collapsing some universes that need to remain distinct) and then complains without trying anything else; an annotation can point it in the right direction. In Coq, the bottom universe is denoted `Set`, but this does not mean that its elements 0-truncated. In `Basics/Overture`, we define a notation `Type0` for this universe. Coq also has universes `Prop` and `SProp` which we do not use in the library. ### 6.3. Unexpected universes ### If you ever need to pay close attention to universes, it is useful to know that there are several ways in which extra universe parameters can creep into a definition unexpectedly. Here are a few. The `induction` tactic invokes the appropriate induction principle, which is a function generally named `*_ind` or `*_rect` (see notes on naming conventions above). This function, in turn, requires a universe parameter describing the size of its output. Therefore, if you prove something by `induction` that is generalized over a "large" argument (e.g. a type or a type family), the resulting definition will pick up an extra universe parameter that's strictly larger than the argument in question. One way to avoid this is to instead use a `Fixpoint` definition, or the tactic `fix`, along with `destruct`. There is a tactic `simple_induction` defined in `Basics/Tactics` whose interface is almost the same as `induction` but does this internally, although it only works for induction over `nat` and `trunc_index`. If you apply the `symmetry` tactic when constructing an equivalence to reverse the direction of the goal, then rather than applying `equiv_inverse` directly it goes through the `Symmetric` typeclass. This involves a universe for the size of the type *on which* the symmetric relation lives, which in the case of `Equiv` is the universe. Thus, applying `symmetry` to an `Equiv` introduces a strictly larger universe. A solution is to `apply equiv_inverse` instead. Similarly, use `equiv_compose'` instead of `transitivity`. Typeclass inference doesn't always find the simplest solution, and may insert unnecessary calls to instances that introduce additional universes. One solution is to alter the proofs of those instances as described above; another is to call the instance(s) you need explicitly, rather than relying on typeclass inference to find them. Sometimes binders without type annotations, like `forall n, foo n` where `foo : nat -> Type0`, will produce a fresh universe for the variable's type, eg `forall n : (? : Type@{fresh}), foo n`, which will remain in the definition as a phantom type: `fresh |= forall n : nat, foo n`. Annotating the binder will get rid of it. See also [bug #4868](https://coq.inria.fr/bugs/show_bug.cgi?id=4868). ### 6.4. Lifting and lowering ### The file `Universes/UniverseLevel` contains an operation `Lift` which lifts a type from one universe to a larger one, with maps `lift` and `lower` relating the two types and forming an equivalence. There are primed versions `Lift'`, `lift'`, and `lower'` which allow the two universe levels to possibly be the same. In the past, `Lift` was used to force universe levels to be distinct, but now that Coq supports constraints between universe variables, this is no longer needed in practice. The file `Universes/Smallness` contains results allowing us to show that a type lives in a certain universe. ### 6.5. Universes and HITs ### Another use for universe annotations is to force HITs to live in the correct universe. Coq assigns a universe level to an inductive type based on the levels of its indices and constructors, which is correct for ordinary inductive types. However, the universe level of a HIT should depend also on the levels of its path-constructors, but since these are not actually constructors of the `Private Inductive`, Coq doesn't take them into account. We have not yet formulated a general method for resolving this. In the few cases when it arises, it should be solvable with universe annotations, but we have not yet implemented such a fix; see bug #565. ## 7. Transparency and Opacity ## If the value of something being defined matters, then you must either give an explicit term defining it, or construct it with tactics and end the proof with `Defined.` But if all that matters is that you have defined something with a given type, you can construct it with tactics and end the proof with `Qed.` The latter makes the term "opaque" so that it doesn't "compute". If something *can* be made opaque, it is generally preferable to do so, for performance reasons. However, many things which a traditional type theorist would make opaque cannot be opaque in homotopy type theory. For instance, none of the higher-groupoid structure in PathGroupoids can be made opaque, not even the "coherence laws". If you doubt this, try making some of it opaque and you will find that the "higher coherences" such as `pentagon` and `eckmann_hilton` will fail to typecheck. In general, it is okay to construct something transparent using tactics; it's often a matter of aesthetics whether an explicit proof term or a tactic proof is more readable or elegant, and personal aesthetics may differ. Consider, for example, the explicit proof term given for `eckmann_hilton`: some may consider it optimally elegant, while others would prefer to be able to step through a tactic proof to understand what is happening step-by-step. One thing to beware of is explicit `match` terms that require `in` or `return` annotations, as these are particularly difficult for newcomers to understand. Avoiding them is not a hard and fast rule, but when there is a short proof using tactics that produces an acceptable proof term, it should probably be preferred. The important thing is that when defining a transparent term with tactics, you should restrict yourself to tactics which maintain a high degree of control over the resulting term; "blast" tactics like `autorewrite` should be eschewed. Even plain `rewrite` is usually to be avoided in this context: although the terms it produces are at least predictable, they are one big `transport` (under a different name) whereas a term we would want to reason about ought to be constructed using smaller pieces like `ap` and `concat` which we can understand. Here are some acceptable tactics to use in transparent definitions (this is not an exhaustive list): - `intros`, `revert`, `generalize`, `generalize dependent` - `pose`, `assert`, `set`, `cut` - `transparent assert` (see below) - `fold`, `unfold`, `simpl`, `cbn`, `hnf`, `change` - `case`, `elim`, `destruct`, `induction` - `apply`, `eapply`, `assumption`, `eassumption`, `exact` - `refine`, `nrefine`, `srefine`, `snrefine` (see below for the last three) - `rapply`, `nrapply`, `srapply`, `snrapply` (see below) - `lhs`, `lhs_V`, `rhs`, `rhs_V` - `reflexivity`, `symmetry`, `transitivity`, `etransitivity` - `by`, `done` Conversely, if you want to use `rewrite`, that is fine, but you might then make the thing you are defining opaque. If it turns out later that you need it to be transparent, then you should go back and prove it without using `rewrite`. Currently, there are some basic facts in the library, such as the "adjointify" lemma, which are proven using `rewrite` and hence are at least partially opaque. It might be desirable one day to prove these more explicitly and make them transparent, but so far it has not been necessary. Note that it *is* acceptable for the definition of a transparent theorem to invoke other theorems which are opaque. For instance, the `isequiv_adjointify` lemma itself is actually transparent, but it invokes an opaque sublemma that computes the triangle identity (using `rewrite`). Making the main lemma transparent is necessary so that the other parts of an equivalence -- the inverse function and homotopies -- will compute. Thus, a transparent definition will not generally be "completely transparent". It is possible to make subterms of a term opaque by using the `abstract` tactic, although that requires grouping the entire proof script to be abstracted into a single command with semicolons, e.g. `abstract (apply lem1; apply lem2; reflexivity)`. Note that the `assert` tactic produces subterms that cannot be inspected by the rest of the proof script, but they remain transparent in the resulting proof term (at least if the proof is ended with `Defined.`). For a transparent subterm, use `refine` or `transparent assert` (the latter defined in `Basics/Overture`; see "Available tactics", below). ## 8. Imports/exports ## Most `Require` commands should be just `Require Import` rather than `Require Export`: imports should not be re-exported, by default. However, if you can't imagine making practical use of file `Foo` without file `Bar`, then `Bar` may export `Foo` via `Require Export Foo`. For instance, `Modality` exports `ReflectiveSubuniverse` because so many of the theorems about modalities are actually theorems about reflective subuniverses. ## 9. Formatting ## ### 9.1. Location of commands All `Require` commands should be placed at the top of a file. Ideally, they should be grouped onto lines according to the rough grouping of files listed under "Organization". Requires should generally be followed by all `[Local] Open Scope` commands, and then by `Generalizable Variables` commands. The latter two might also occur in Sections later on in the file, but in that case they should usually come at the beginning of the Section. The assumptions of a section, such as `Variable` and `Context`, should also generally come at the beginning of that section. ### 9.2. Indentation In general, the bodies of sections and modules should be indented, two spaces per nested section or module. This is the default behavior of ProofGeneral. However, when enclosing existing code in a new section or module, it is acceptable to avoid re-indenting it at the same time, to avoid excessive churn in the diff. If you wish, you can submit a separate pull request or commit for the re-indentation, labeled as "only whitespace changes" so that no one bothers reading the diff carefully. ### 9.3. Line lengths and comments Lines of code should be of limited width; try to restrict yourself to not much more than 70 characters. Remember that when Coq code is often edited in split-screen so that the screen width is cut in half, and that not everyone's screen is as wide as yours. [coqdoc](https://coq.inria.fr/refman/using/tools/coqdoc.html) is used to produce a browsable [view of the library](https://hott.github.io/Coq-HoTT/coqdoc-html/toc.html). coqdoc treats comments specially, so comments should follow the conventions described on the coqdoc page. The most important ones are that Coq expressions within comments are surrounded by square brackets, and that headings are indicated with comments of the form ```coq (** * This is a top-level section *) (** ** This is a subsection *) (** *** This is a sub-subsection *) ``` Section titles should be less than 80 characters, on one line, and not end in a period. Other comments are generally written using the style `(** This is a comment. *)` or `(* This is a comment. *)`, with the latter generally used for inline comments during a proof. Text in comments should not contain hard newlines. Putting hard newlines in text makes it extremely ugly when viewed in a window that is narrower than the width to which you filled it. If editing in Emacs, turn off `auto-fill-mode` and turn on `visual-line-mode`; then you'll be able to read comment paragraphs without scrolling horizontally, no matter how narrow your window is. The repository contains a file .dir-locals.el in the top-level directory which turns on `visual-line-mode` when emacs visits any file in the repository. Documentation can be built locally using `make doc` or `dune build @theories/doc`. The HTML files generated by Dune are placed in `_build/default/HoTT.html/`. Unfortunately, when viewing source code on Github, these long comment lines are not wrapped, making them hard to read. If you use the Stylish plugin, you can make them wrap by adding the following style: @-moz-document domain(github.com) { div.line { white-space: pre-wrap; } } This messes up the line-numbering, though, you'll have to turn it off in order to link to or comment on a particular line. ### 9.4. Tactic scripts ### When writing tactic scripts, `Proof.` and `Defined.` should be given as individual lines, and the tactic code should be indented. Within the tactic script, use newlines as a "logical grouping" construct. Important tactic invocations, such as a top-level `induction` which create a branch point in the proof, should generally be on lines by themselves. Other lines can contain several short tactic commands (separated by either periods or semicolons), if they together implement a single idea or finish off a subgoal. For long proofs with multiple significant subgoals, use branching constructs such as bullets and braces to clarify the structure. See the section of the Coq Reference Manual entitled "Navigation in the proof tree". ### 9.5. Placement of Arguments and types ### If the entire type of a theorem or definition does not fit on one line, then it is better to put the result type (the part after the colon) on an indented line by itself, together with the colon to make it clear that this is the result type. ```coq Definition triangulator {A : Type} {x y z : A} (p : x = y) (q : y = z) : concat_p_pp p 1 q @ whiskerR (concat_p1 p) q. ``` Of course, if the list of input types does not fit on a line by itself, it should be broken across lines as well, with later lines indented, and similarly for the result type. ```coq Definition pentagon {A : Type} {v w x y z : A} (p : v = w) (q : w = x) (r : x = y) (s : y = z) : whiskerL p (concat_p_pp q r s) @ concat_p_pp p (q@r) s @ whiskerR (concat_p_pp p q r) s. ``` For definitions given with an explicit term, that term should usually also be on an indented line by itself, together with the := to make it clear that this is the definition. ```coq Definition concat_p1 {A : Type} {x y : A} (p : x = y) : p @ 1 = p := match p with idpath => 1 end. ``` Of course, if the term is longer than one line, it should be broken across lines, with later lines indented further. ## 10. Implicit Arguments ## Do not use `Set Implicit Arguments` in the core. It makes it difficult for a newcomer to read the code; use braces `{...}` to explicitly mark which arguments are implicit. If necessary, you can use the `Arguments` command to adjust implicitness of arguments after a function is defined, but braces are preferable when possible. If you want to use `Arguments` to make *all* the arguments of a function explicit, the obvious-looking syntax `Arguments foo a b` does not work: you have to write `Arguments foo : clear implicits` instead. ## 11. Coding Hints ## ### 11.1. Notations ### The operation `compose`, notation `g o f`, is simply a notation for `fun x => g (f x)` rather than a defined constant. We define `compose := (fun g f x => g (f x))` so that typeclass inference can pick up `isequiv_compose` instances. This has the unfortunate side-effect that `simpl`/`cbn` is enough to "unfold" `compose`, and there's no way to prevent this. We could additionally define `g o f := (fun x => g (f x))` to change this, but this would result in identically looking goals which are really different. We consider it poor style to use `compose` as a partially applied constant, such as `compose g`; we take the point of view that `fun f => g o f` is more readable anyway. ### 11.2. Unfolding definitions ### When a definition has to be unfolded repeatedly in the middle of proofs, you can say `Local Arguments name / .`, which tells `simpl` and related tactics to automatically unfold `name`. In particular, this allows the tactic `simpl rewrite` (defined in `Tactics`) to apply theorems containing `name` to goals in which it has been unfolded. It seems better not to make these declarations globally, however. It may not always be obvious which definition this needs to be applied to; sometimes the unification failure happens in an implicit argument that is not directly visible in the output. One way to discover where the problem lies is to turn on printing of all implicit arguments with `Set Printing All`; another is to use `Set Debug Tactic Unification` and inspect the output to see where `rewrite` is failing to unify. ### 11.3. Finding theorems ### The naming conventions mentioned above often help to guess the name of a theorem. However, it still may happen that you expect that a theorem should exist but don't know what it is called. One approach to finding it is to guess what file it should live in and look there; for instance, theorems about sigma-types are often in `Types/Sigma.v`, and so on. Another approach is to use Coq's command `Search` to display all the theorems that relate to a particular definition. For example, `Search (IsHProp ?A)` will show all results in which the expression `IsHProp A` appears for some `A`, and `Search "ishprop"` will show all results having "ishprop" in the name. However, some results about `HProp` are true for any truncation level, so you may want to expand your search to include `IsTrunc`. In general, if you can't find something at first using `Search`, think about ways that your desired theorem might be generalized and search for those instead. Generalizing from a particular truncation level (like `IsHProp`) to all truncation levels is a good example. Another one that it's important to be aware of is a generalization from truncation (`IsTrunc` and `Trunc`) to all reflective subuniverses or modalities; many many theorems about truncation are actually proven more generally in the latter situations. ### 11.4. Simpl nomatch ### If a theorem or definition is defined by `destruct` or `match` (as many operations on paths are), and if its value needs to be reasoned about in tactic proofs, then it is helpful to declare its arguments as `Arguments foo ... : simpl nomatch`. This instructs `simpl` and related tactics never to simplify it if doing so would result in a `match` that doesn't reduce, which is usually what you want. ### 11.5. Available tactics ### Here are some tactics defined in the core that you may find useful. They are described more fully, usually with examples, in the files where they are defined. - `nrefine`, `srefine`, `snrefine`: Defined in `Basics/Overture`, these are shorthands for `notypeclasses refine`, `simple refine`, and `simple notypeclasses refine`. It's good to avoid typeclass search if it isn't needed. - `rapply`, `nrapply`, `srapply`, `snrapply`: Defined in `Basics/Overture`, these tactics use `refine`, `nrefine`, `srefine` and `snrefine`, except that additional holes are added to the function so they behave like `apply` does. The unification algorithm used by `apply` is different and often less powerful than the one used by `refine`, though it is occasionally better at pattern matching. Here are some tips: - If `apply` fails with a unification error you think it shouldn't have, try `nrapply`. - If you want to use type class resolution as well, try `rapply`. But it's better to use `nrapply` if it works. - You could add a prime to the tactic, to try with many arguments first, decreasing the number on each try. - If you don't want Coq to create evars for certain subgoals, add an `s` to the tactic name to make it use `simple refine`. - `lhs`, `lhs_V`, `rhs`, `rhs_V`: Defined in `Basics/Tactics`. These are tacticals that apply a specified tactic to one side of an equality. E.g. `lhs nrapply concat_1p.` - `transparent assert`: Defined in `Basics/Overture`, this tactic is like `assert` but produces a transparent subterm rather than an opaque one. Due to restrictions of tactic notations, you have to write `transparent assert (foo : (bar baz))` rather than `transparent assert (foo : bar baz)`. - `issig`: Defined in `Basics/Tactics`, this tactic proves automatically that a record type is equivalent to a nested sigma-type. - `make_equiv`: Defined in `Basics/Equivalences`, this tactic can prove two types are equivalent if the proof involves juggling components. See also `make_equiv_contr_basedpaths`. - `pointed_reduce`: Defined in `Pointed/Core`, this tactic lets you assume that functions are strictly pointed. See related tactics there. - `strip_truncations`, `strip_modalities` and `strip_reflections`: These let you lift an element from `O X` to `X` when the goal is `O`-local, for various `O`. - `simpl rewrite`: Defined in `Tactics`, this tactic applies `simpl` to the type of a lemma, and to the goal, before rewriting the goal with the lemma. In particular, this is useful for rewriting with lemmas containing definitions like `compose` that appear unfolded in the goal: if the operation has `Arguments ... / .` as above then `simpl` will unfold it. - `binder apply`: Defined in `Tactics/BinderApply`, this tactic applies a lemma inside of a lambda abstraction, in the goal or in a hypothesis. ## 12. Contributing to the library ## ### 12.1. Fork & Pull ### We mainly work by the "Fork & Pull" model. Briefly: to contribute, [create your own fork][fork] of the repository, do your main work there, and [issue pull requests][pull] when work is ready to be brought into the main library. Direct pushes to the library should never be made. There are various reasons for preferring the fork/pull workflow. Firstly, it helps maintain code consistency. Secondly, it makes it easier for all to keep track of what is being added --- it’s easier to survey changes grouped into pull requests than in individual commits. Thirdly, it means we can make our work in progress as messy and uncertain as we want, while keeping the main library clean and tidy. Submit your pull request not from the master branch of your fork, but from another branch created specially for that purpose. Among other things, this allows you to continue developing on your fork without changing the pull request, since a pull request is automatically updated to contain all commits pushed to the branch that it was made from. It also allows you to submit multiple unrelated pull requests at the same time that do not depend on each other. [fork]: https://help.github.com/articles/fork-a-repo [pull]: https://help.github.com/articles/using-pull-requests [minor]: http://en.wikipedia.org/wiki/Help:Minor_edit ### 12.2. Approval of pull requests ### Before being merged, pull requests must be approved by one of the core developers, not counting whoever submitted it. An approval can be an official "Approving review" through the GitHub UI, or just a comment such as LGTM ("Looks Good To Me"). Currently the rules are: - Any objections or requested changes must be addressed somehow before merging (which doesn't always mean making the changes, but a discussion must be had and resolved). - In general, a pull request should not be merged unless the CI tests confirm that it builds successfully. Exceptions to this rule sometimes have to be made if the CI configuration is broken for some unrelated reason, but in that case it is better if the person(s) approving the pull request confirms locally that it builds successfully. Note also that the CI doesn't automatically restart itself on a pull request when the master branch changes. Thus, if other pull requests have been merged in the interval since a given pull request was first submitted, it may be necessary to rebase that pull request against the new master, to make sure before merging it that it won't break the master branch. - In the absence of objections, one approval suffices for a pull request to be merged. - In the absence of objections, a minor pull request may be merged if at least 48 hours have passed after its submission. In some cases, this can be done immediately. If a pull request is lacking approval and hasn't received any discussion, feel free to bump it back to attention with a comment. ### 12.3. Commit messages ### Please try to keep commit messages clear and informative. We don’t currently have a specific preferred convention, but the answers [here][commits1] and [here][commits2] (not just the top answers!) give excellent, if varied, advice. That said, this is a minor point. Good code with bad commit messages is much better than the reverse! Some good examples, showing what kind of change was made (additions, updates, fixes), and what material it was on: - "adapt to the new version of coqtop by disabling the native compiler" - "resolved universe inconsistency in Freudenthal" - "epis are surjective" Some bad examples: - "further progress" Progress in what files? - "Bug in [Equivalences.v]." Was the bug fixed, or just noticed and flagged in comments, or what? - "asdfjkl" [commits1]: http://stackoverflow.com/questions/43598/suggestions-for-a-good-commit-message-format-guideline [commits2]: http://stackoverflow.com/questions/3580013/should-i-use-past-or-present-tense-in-git-commit-messages ### 12.4. Creating new files ### If you create a new file, `make` will only compile it if it is being tracked by `git`, so you will need to `git add` it. You will probably also want to add your new file to `HoTT.v`, unless it is outside the core (e.g. in `contrib/`) or should not be exported for some other reason. ### 12.5. Travis ### We use the [Travis Continuous Integration Platform][travis] to check that pull requests do not break anything, and also to automatically update various things (such as the documentation and dependency graph linked on the [project wiki][wiki]). Normally you shouldn't need to know anything about this; Travis automatically checks every pull request made to the central repository. [travis]: https://travis-ci.org/ [wiki]: https://github.com/HoTT/HoTT/wiki ### 12.6. Git rebase ### If the master branch has diverged in some significant way since a pull request was made, then merging it may result in non-compiling code. Or the changes may conflict so that github becomes unable to merge it automatically. In either case, the situation should be resolved manually before the pull request can be merged, and the resolution should generally be done by the submitter of the pull request. One way to do the resolution is to merge the current master branch into the branch from which the pull request was made, resolving conflicts manually, and then make and commit whatever other changes may be necessary. This has the disadvantage of creating new merge commits, so another option is to `git rebase` against the master branch. We encourage the use of `rebase` if you are comfortable with it; but for newcomers to git, rebasing can be intimidating, so merges are also perfectly acceptable. ### 12.7. Timing scripts ### There are scripts in `etc/timing` to track (compile-time) performance changes in the library. When you make large changes, you may want to include performance information in your commit message (recommended, but certainly not required!). **Note:** Make sure you have gnu time installed. Many terminals have their own `time` command but this will not work. To install time run `sudo apt install time`. You will also need to rerun the `./configure` script so that it detects the newly installed time. To run the timing scripts, use the following work-flow from the root of the repository after you have made your edits. To make use of these scripts, you must first run `git submodule update --init --recursive`. $ git status $ git add $ git status It's good practice at this point to ensure that there are no `.v` files mentioned. $ ./etc/coq-scripts/timing/make-pretty-timed-diff.sh $ make Ensure that `make` succeeds, since `make-pretty-timed-diff.sh` will succeed even if some files fail to build. $ git commit -at ./time-of-build-both.log This pops open an editor. You should add lines at the beginning of the commit message, leaving at least one blank line before the performance table. See the comments at the top of `make-pretty-timed-diff.sh` for more detailed instructions and caveats. ## 13. Bugs in Coq ## More often than we would like, we run across bugs in Coq. A sure sign of a bug in Coq is when you get a message about an "Anomaly", but a bug can also be unjustifiable behavior. If you aren't sure whether something is a bug in Coq, feel free to [open an issue][new issue] about it on the Coq-HoTT GitHub project. [new issue]: https://github.com/HoTT/HoTT/issues/new ### 13.1. Reporting bugs ### Bugs in Coq should be reported on the [Coq bug tracker][bugs]. You should search the tracker first to see whether your bug has already been reported. After reporting a bug, you may need to add a temporary workaround to the HoTT library until the bug is fixed. In this case, please add a comment labeling this as a workaround and citing the bug report. That way when the bug is fixed, we can remove the workaround. [bugs]: https://coq.inria.fr/bugs ### 13.2. Minimizing bugs ### When submitting a bug report, it is appreciated to submit a minimal test example. Since the HoTT library is quite large, it can be quite some work to track down the actual trigger of a bug. Fortunately, Jason Gross has written a convenient "bug minimizing" script, which is available in his [coq-tools][coq-tools] repository. To use it: 1. Clone the coq-tools repository somewhere (usually somewhere outside the HoTT library directory). 2. Attempt to compile the file where the bug occurs, e.g. by running `make theories/Path/To/Buggy.vo` from the root of the HoTT library directory. This creates a `.glob` file which the bug-finder needs. 3. `cd theories` and then run the bug-finder script `find-bug.py`. It will combine the file with all the rest of the library that it needs, ask you to confirm the error, and then proceed to minimize it as much as possible. You will need to pass the bug-finder several arguments to tell it to pass the right flags and where to find the rest of the library; a common invocation would be something like $ /path/to/find-bug.py --arg -noinit --arg -indices-matter -R . HoTT Path/To/Buggy.v bug_minimized.v When it exits, the minimized code producing the bug will be in `bug_minimized.v`. Note that sometimes `coqc` and `coqtop` can exhibit different behavior, and one may produce a bug while the other doesn't. (One reason for this is that they give different names to universe parameters, `Top.1` versus `Filename.1`, and this can result in different results from sorting, which can affect the output of the universe minimization algorithm, yielding different numbers or different ordering of universe parameters for the same definitions. This is [itself a bug][instance bug], but as of June 2015 it has not yet been fixed.) The bug-finder normally uses both `coqc` and `coqtop`, but you can tell it to "fake" `coqc` using `coqtop` by passing the argument `--coqc-as-coqtop` instead of `--coqc`. [coq-tools]: https://github.com/JasonGross/coq-tools [instance bug]: https://coq.inria.fr/bugs/show_bug.cgi?id=3863 Coq-HoTT-9.0/UNICODE.txt000066400000000000000000000020101474641544500145560ustar00rootroot00000000000000To insert unicode characters into emacs, you can set the TeX input method by typing `C-u C-\` (or `M-x set-input-method RET`), typing `TeX`, and pressing RETURN. You can then insert characters as you would in TeX, such as `•` by typing `\bullet`. There are other unicode input methods, as well. For example, if you have Agda installed, you can enter `Agda` as the input method, and then you can enter `•` by typing `\bu`. Emacs can tell you how to enter a pre-existing character: place the cursor right before the character, and type `C-u C-x =` (or `M-x describe-char RET`). To default to TeX input method when editing Coq files, add the following to your ~/.emacs: (defun my-coq-hook () (set-input-method "TeX")) (add-hook 'coq-mode-hook 'my-coq-hook) Instructions for entering unicode into CoqIDE are documented in the Coq Reference Manual (http://coq.inria.fr/refman/toc.html). You can find the v8.4 documentation about unicode input at http://coq.inria.fr/distrib/8.4pl4/refman/Reference-Manual018.html#sec628. Coq-HoTT-9.0/contrib/000077500000000000000000000000001474641544500143765ustar00rootroot00000000000000Coq-HoTT-9.0/contrib/HoTTBook.v000066400000000000000000001753611474641544500162330ustar00rootroot00000000000000(** The HoTT Book formalization. *) (** This file links the results of the HoTT Book with their formalizations in the HoTT library. You can lookup definitions and theorems by their number in the HoTT Book. *) (* IMPORTANT NOTE FOR THE HoTT DEVELOPERS: This files is processed automagically by the etc/Book.py script. The script parses the file according to the markers present in it (the comment lines with many = signs followed by a LaTeX label). It reorders the entries according to entry number X.Y.Z and inserts missing entries. You must therefore obey the following rules: 0. Read the description below of what the correct procedure is. 1. Do not mess with the markers and do not insert new entries by hand. If a LaTeX label has been renamed you may rename the corresponding marker, but for addition of new entries you have to use the etc/Book.py script, as described below. 2. If a theorem is gone, you may delete the corresponding entry, but make sure first that it was not just moved elsewhere. 3. Make entries independent of other entries, as they may get reordered or deleted. 4. If you need to import anything, do it before the first entry. 5. Each entry should define Book_X_Y_Z, but you can also put in auxiliary definitions and lemmas (keep it short please). The script renames the Book_X_Y_Z to whatever the correct number is, so initially you can use whatever number you like. If you are formalizing a Lemma with several part, use Book_X_Y_Z_item_i, Book_X_Y_Z_item_ii, or some such. 6. If there is a corresponding HoTT library theorem or definition, please use that one, even if it is not exactly the same. PROCEDURE FOR UPDATING THE FILE: 1. Compile the latest version of the HoTT Book to update the LaTeX labels. Do not forget to pull in changes from HoTT/HoTT. 2. Run `cat ../book/*.aux | etc/Book.py contrib/HoTTBook.v`. If it complains, fix things. 3. Add contents to new entries. 4. Run `etc/Book.py` again to make sure it is happy. 5. Compile this file with `make contrib` or `make contrib/HoTTBook.vo`. 6. Do the git thing to submit your changes. *) From HoTT Require Import Basics Truncations. From HoTT Require Idempotents Spaces.No Spaces.Nat. From HoTT Require HIT.V HIT.Flattening Homotopy.WhiteheadsPrinciple Homotopy.Hopf. From HoTT Require Categories. From HoTT Require Metatheory.IntervalImpliesFunext Metatheory.UnivalenceImpliesFunext. From HoTT Require Classes.theory.premetric. (* END OF PREAMBLE *) (* ================================================== lem:opp *) (** Lemma 2.1.1 *) Definition Book_2_1_1 := @HoTT.Basics.Overture.inverse. (* ================================================== lem:concat *) (** Lemma 2.1.2 *) Definition Book_2_1_2 := @HoTT.Basics.Overture.transitive_paths. (* ================================================== thm:omg *) (** Lemma 2.1.4 *) Definition Book_2_1_4_item_i := @HoTT.Basics.PathGroupoids.concat_p1. Definition Book_2_1_4_item_i' := @HoTT.Basics.PathGroupoids.concat_1p. Definition Book_2_1_4_item_ii := @HoTT.Basics.PathGroupoids.concat_Vp. Definition Book_2_1_4_item_ii' := @HoTT.Basics.PathGroupoids.concat_pV. Definition Book_2_1_4_item_iii := @HoTT.Basics.PathGroupoids.inv_V. Definition Book_2_1_4_item_iv := @HoTT.Basics.PathGroupoids.concat_p_pp. (* ================================================== thm:EckmannHilton *) (** Theorem 2.1.6 *) Definition Book_2_1_6 := @HoTT.Basics.PathGroupoids.eckmann_hilton. (* ================================================== def:pointedtype *) (** Definition 2.1.7 *) Definition Book_2_1_7 := @HoTT.Basics.Overture.pType. (* ================================================== def:loopspace *) (** Definition 2.1.8 *) Definition Book_2_1_8 := @HoTT.Pointed.Loops.iterated_loops. (* ================================================== lem:map *) (** Lemma 2.2.1 *) Definition Book_2_2_1 := @HoTT.Basics.Overture.ap. (* ================================================== lem:ap-functor *) (** Lemma 2.2.2 *) Definition Book_2_2_2_item_i := @HoTT.Basics.PathGroupoids.ap_pp. Definition Book_2_2_2_item_ii := @HoTT.Basics.PathGroupoids.inverse_ap. Definition Book_2_2_2_item_iii := @HoTT.Basics.PathGroupoids.ap_compose. Definition Book_2_2_2_item_iv := @HoTT.Basics.PathGroupoids.ap_idmap. (* ================================================== lem:transport *) (** Lemma 2.3.1 *) Definition Book_2_3_1 := @HoTT.Basics.Overture.transport. (* ================================================== thm:path-lifting *) (** Lemma 2.3.2 *) (* special case of *) Definition Book_2_3_2 := @HoTT.Types.Sigma.equiv_path_sigma. (* ================================================== lem:mapdep *) (** Lemma 2.3.4 *) Definition Book_2_3_4 := @HoTT.Basics.Overture.apD. (* ================================================== thm:trans-trivial *) (** Lemma 2.3.5 *) Definition Book_2_3_5 := @HoTT.Basics.PathGroupoids.transport_const. (* ================================================== thm:apd-const *) (** Lemma 2.3.8 *) Definition Book_2_3_8 := @HoTT.Basics.PathGroupoids.apD_const. (* ================================================== thm:transport-concat *) (** Lemma 2.3.9 *) Definition Book_2_3_9 := @HoTT.Basics.PathGroupoids.transport_compose. (* ================================================== thm:transport-compose *) (** Lemma 2.3.10 *) Definition Book_2_3_10 := @HoTT.Basics.PathGroupoids.ap_transport. (* ================================================== thm:ap-transport *) (** Lemma 2.3.11 *) Definition Book_2_3_11 := @HoTT.Basics.PathGroupoids.transport_pp. (* ================================================== defn:homotopy *) (** Definition 2.4.1 *) Definition Book_2_4_1 := @HoTT.Basics.Overture.pointwise_paths. (* ================================================== lem:homotopy-props *) (** Lemma 2.4.2 *) Definition Book_2_4_2 := @HoTT.Basics.Overture.pointwise_paths. (* ================================================== lem:htpy-natural *) (** Lemma 2.4.3 *) Definition Book_2_4_3 := @HoTT.Basics.PathGroupoids.concat_Ap. (* ================================================== cor:hom-fg *) (** Corollary 2.4.4 *) Definition Book_2_4_4 := @HoTT.Basics.PathGroupoids.concat_A1p. (* ================================================== defn:quasi-inverse *) (** Definition 2.4.6 *) (** Quasi-inverses do not occur explicitly in the library since they are `not good'. They do only occur implicitly as input to isequiv_adjointify : IsEquiv f. Therefore we link to the half adjoint equivalence extending the quasi-inverse *) Definition Book_2_4_6 := @HoTT.Basics.Equivalences.isequiv_adjointify. (* ================================================== eg:idequiv *) (** Example 2.4.7 *) Definition Book_2_4_7 := @HoTT.Basics.Equivalences.equiv_idmap. (* ================================================== eg:concatequiv *) (** Example 2.4.8 *) Definition Book_2_4_8_i := @HoTT.Types.Paths.isequiv_concat_l. Definition Book_2_4_8_ii := @HoTT.Types.Paths.isequiv_concat_r. (* ================================================== thm:transportequiv *) (** Example 2.4.9 *) Definition Book_2_4_9 := @HoTT.Basics.Equivalences.isequiv_transport. (* ================================================== thm:equiv-eqrel *) (** Lemma 2.4.12 *) Definition Book_2_4_12_item_i := @HoTT.Basics.Equivalences.reflexive_equiv. Definition Book_2_4_12_item_ii := @HoTT.Basics.Equivalences.symmetric_equiv. Definition Book_2_4_12_item_iii := @HoTT.Basics.Equivalences.transitive_equiv. (* ================================================== thm:path-prod *) (** Theorem 2.6.2 *) Definition Book_2_6_2 := @HoTT.Types.Prod.equiv_path_prod. (* ================================================== thm:trans-prod *) (** Theorem 2.6.4 *) Definition Book_2_6_4 := @HoTT.Types.Prod.transport_prod. (* ================================================== thm:ap-prod *) (** Theorem 2.6.5 *) Definition Book_2_6_5 := @HoTT.Types.Prod.ap_functor_prod. (* ================================================== thm:path-sigma *) (** Theorem 2.7.2 *) Definition Book_2_7_2 := @HoTT.Types.Sigma.equiv_path_sigma. (* ================================================== thm:eta-sigma *) (** Corollary 2.7.3 *) Definition Book_2_7_3 := @HoTT.Types.Sigma.eta_sigma. (* ================================================== transport-Sigma *) (** Theorem 2.7.4 *) Definition Book_2_7_4 := @HoTT.Types.Sigma.transportD_is_transport. (* ================================================== thm:path-unit *) (** Theorem 2.8.1 *) Definition Book_2_8_1 := @HoTT.Types.Unit.equiv_path_unit. (* ================================================== axiom:funext *) (** Axiom 2.9.3 *) Definition Book_2_9_3 := @HoTT.Basics.Overture.path_forall. (* ================================================== thm:dpath-arrow *) (** Lemma 2.9.6 *) Definition Book_2_9_6 := @HoTT.Types.Arrow.dpath_arrow. (* ================================================== thm:dpath-forall *) (** Lemma 2.9.7 *) Definition Book_2_9_7 := @HoTT.Types.Forall.dpath_forall. (* ================================================== thm:idtoeqv *) (** Lemma 2.10.1 *) Definition Book_2_10_1 := @HoTT.Types.Universe.equiv_path. (* ================================================== axiom:univalence *) (** Axiom 2.10.3 *) Definition Book_2_10_3 := @HoTT.Types.Universe.isequiv_equiv_path. (* ================================================== thm:transport-is-ap *) (** Lemma 2.10.5 *) (** Lemma 2.10.5 is a special case of Lemma 2.3.10, but also of: *) Definition Book_2_10_5 := @HoTT.Types.Universe.transport_path_universe'. (* ================================================== thm:paths-respects-equiv *) (** Theorem 2.11.1 *) Definition Book_2_11_1 := @HoTT.Basics.Equivalences.isequiv_ap. (* ================================================== cor:transport-path-prepost *) (** Lemma 2.11.2 *) Definition Book_2_11_2_item_1 := @HoTT.Types.Paths.transport_paths_l. Definition Book_2_11_2_item_2 := @HoTT.Types.Paths.transport_paths_r. Definition Book_2_11_2_item_3 := @HoTT.Types.Paths.transport_paths_lr. (* ================================================== thm:transport-path *) (** Theorem 2.11.3 *) Definition Book_2_11_3 := @HoTT.Types.Paths.transport_paths_FlFr. (* ================================================== thm:transport-path2 *) (** Theorem 2.11.4 *) Definition Book_2_11_4 := @HoTT.Types.Paths.transport_paths_FlFr_D. (* ================================================== thm:dpath-path *) (** Theorem 2.11.5 *) Definition Book_2_11_5 := @HoTT.Types.Paths.dpath_path_lr. (* ================================================== thm:path-coprod *) (** Theorem 2.12.5 *) Definition Book_2_12_5 := @HoTT.Types.Sum.equiv_path_sum. (* ================================================== thm:path-nat *) (** Theorem 2.13.1 *) Definition Book_2_13_1 := @HoTT.Spaces.Nat.Paths.equiv_path_nat. (* ================================================== thm:prod-ump *) (** Theorem 2.15.2 *) (** non-dependent as special case of dependent, Theorem 2.15.5 *) Definition Book_2_15_2 := @HoTT.Types.Prod.isequiv_prod_coind. (* ================================================== thm:prod-umpd *) (** Theorem 2.15.5 *) Definition Book_2_15_5 := @HoTT.Types.Prod.isequiv_prod_coind. (* ================================================== thm:ttac *) (** Theorem 2.15.7 *) Definition Book_2_15_7 := @HoTT.Types.Sigma.isequiv_sig_coind. (* ================================================== defn:set *) (** Definition 3.1.1 *) Definition Book_3_1_1 := fun A => @HoTT.Basics.Overture.IsTrunc 0 A. (* ================================================== eg:isset-unit *) (** Example 3.1.2 *) Definition Book_3_1_2 := @HoTT.Types.Unit.contr_unit. (* ================================================== eg:isset-empty *) (** Example 3.1.3 *) Definition Book_3_1_3 := @HoTT.Types.Empty.istrunc_Empty (-2). (* ================================================== thm:nat-set *) (** Example 3.1.4 *) Definition Book_3_1_4 := @HoTT.Spaces.Nat.Core.ishset_nat. (* ================================================== thm:isset-prod *) (** Example 3.1.5 *) Definition Book_3_1_5 := @HoTT.Types.Prod.istrunc_prod. (* ================================================== thm:isset-forall *) (** Example 3.1.6 *) Definition Book_3_1_6 `{Funext} A P := @HoTT.Basics.Trunc.istrunc_forall _ A P 0. (* ================================================== defn:1type *) (** Definition 3.1.7 *) Definition Book_3_1_7 := fun A => @HoTT.Basics.Overture.IsTrunc 1 A. (* ================================================== thm:isset-is1type *) (** Lemma 3.1.8 *) Definition Book_3_1_8 := @HoTT.Basics.Trunc.istrunc_succ 0. (* ================================================== thm:type-is-not-a-set *) (** Example 3.1.9 *) Definition Book_3_1_9 := @HoTT.Types.Universe.not_hset_Type. (* ================================================== thm:not-dneg *) (** Theorem 3.2.2 *) (* ================================================== thm:not-lem *) (** Corollary 3.2.7 *) (* ================================================== defn:isprop *) (** Definition 3.3.1 *) Definition Book_3_3_1 := fun A => @HoTT.Basics.Overture.IsTrunc (-1) A. (* ================================================== thm:inhabprop-eqvunit *) (** Lemma 3.3.2 *) Definition Book_3_3_2 := @HoTT.Universes.HProp.if_hprop_then_equiv_Unit. (* ================================================== lem:equiv-iff-hprop *) (** Lemma 3.3.3 *) Definition Book_3_3_3 := @HoTT.Basics.Trunc.equiv_iff_hprop. (* ================================================== thm:prop-set *) (** Lemma 3.3.4 *) Definition Book_3_3_4 := @HoTT.Basics.Trunc.istrunc_succ (-1). (* ================================================== thm:isprop-isset *) (** Lemma 3.3.5 *) Definition Book_3_3_5_i := @HoTT.Basics.Trunc.ishprop_istrunc. (* ================================================== thm:isprop-isprop *) (** Lemma 3.3.5 *) Definition Book_3_3_5_ii := @HoTT.Basics.Trunc.ishprop_istrunc. (* ================================================== defn:decidable-equality *) (** Definition 3.4.3 *) Definition Book_3_4_3_part_i := @HoTT.Basics.Decidable.Decidable. (** Definition Book_3_4_3_part_ii := *) Definition Book_3_4_3_part_iii := @HoTT.Basics.Decidable.DecidablePaths. (* ================================================== defn:setof *) (** Lemma 3.5 *) (* ================================================== thm:path-subset *) (** Lemma 3.5.1 *) Definition Book_3_5_1 := @HoTT.Types.Sigma.path_sigma_hprop. (* ================================================== thm:isprop-forall *) (** Example 3.6.2 *) Definition Book_3_6_2 `{Funext} (A : Type) (B : A -> Type) := @HoTT.Basics.Trunc.istrunc_forall _ A B (-1). (* ================================================== defn:logical-notation *) (** Definition 3.7.1 *) (* ================================================== thm:ac-epis-split *) (** Lemma 3.8.2 *) (* ================================================== thm:no-higher-ac *) (** Lemma 3.8.5 *) (* ================================================== thm:prop-equiv-trunc *) (** Lemma 3.9.1 *) Definition Book_3_9_1 := @HoTT.Modalities.ReflectiveSubuniverse.isequiv_to_O_inO (Tr (-1)). (* ================================================== cor:UC *) (** Corollary 3.9.2 *) Definition Book_3_9_2 := @HoTT.HIT.unique_choice.unique_choice. (* ================================================== defn:contractible *) (** Definition 3.11.1 *) Definition Book_3_11_1 := fun A => @HoTT.Basics.Overture.IsTrunc (-2) A. (* ================================================== thm:contr-unit *) (** Lemma 3.11.3 *) Definition Book_3_11_3 := @HoTT.Types.Unit.contr_unit. (* ================================================== thm:isprop-iscontr *) (** Lemma 3.11.4 *) Definition Book_3_11_4 := @HoTT.Basics.Trunc.ishprop_istrunc. (* ================================================== thm:contr-contr *) (** Corollary 3.11.5 *) Definition Book_3_11_5 `{Funext} := @HoTT.Basics.Trunc.contr_istrunc _ (-2). (* ================================================== thm:contr-forall *) (** Lemma 3.11.6 *) Definition Book_3_11_6 `{Funext} A P := @HoTT.Basics.Trunc.istrunc_forall _ A P (-2). (* ================================================== thm:retract-contr *) (** Lemma 3.11.7 *) Definition Book_3_11_7a := @HoTT.Idempotents.contr_retracttype. Definition Book_3_11_7 := @HoTT.Modalities.ReflectiveSubuniverse.inO_to_O_retract (Tr (-2)). (* ================================================== thm:contr-paths *) (** Lemma 3.11.8 *) Definition Book_3_11_8 := @HoTT.Basics.Contractible.contr_basedpaths. (* ================================================== thm:omit-contr *) (** Lemma 3.11.9 *) Definition Book_3_11_9_part_i := @HoTT.Types.Sigma.equiv_sigma_contr. Definition Book_3_11_9_part_ii := @HoTT.Types.Sigma.equiv_contr_sigma. (* ================================================== thm:prop-minusonetype *) (** Lemma 3.11.10 *) Definition Book_3_11_10_if := @HoTT.Basics.Trunc.path_ishprop. Definition Book_3_11_10_onlyif := @HoTT.Basics.Trunc.hprop_allpath. (* ================================================== lem:qinv-autohtpy *) (** Lemma 4.1.1 *) (* ================================================== lem:autohtpy *) (** Lemma 4.1.2 *) (* ================================================== thm:qinv-notprop *) (** Theorem 4.1.3 *) (* ================================================== defn:ishae *) (** Definition 4.2.1 *) Definition Book_4_2_1 := @HoTT.Basics.Overture.IsEquiv. (* ================================================== lem:coh-equiv *) (** Lemma 4.2.2 *) (* The proof of Lemma 4.2.2 is embedded in the proof of isequiv_inverse. *) Definition Book_4_2_2 := fun (A B : Type) (f : A -> B) (feq : IsEquiv f) (y : B) => @HoTT.Basics.Overture.eisadj B A f^-1 (@HoTT.Basics.Equivalences.isequiv_inverse A B f feq) y. (* ================================================== thm:equiv-iso-adj *) (** Theorem 4.2.3 *) Definition Book_4_2_3 := @HoTT.Basics.Equivalences.isequiv_adjointify. (* ================================================== defn:homotopy-fiber *) (** Definition 4.2.4 *) Definition Book_4_2_4 := @HoTT.Basics.Overture.hfiber. (* ================================================== lem:hfib *) (** Lemma 4.2.5 *) Definition Book_4_2_5 := @HoTT.HFiber.equiv_path_hfiber. (* ================================================== thm:contr-hae *) (** Theorem 4.2.6 *) Definition Book_4_2_6 := @HoTT.Types.Equiv.contr_map_isequiv. (* ================================================== defn:linv-rinv *) (** Definition 4.2.7 *) Definition Book_4_2_7_i {A B} (f : A -> B) := {g : B -> A & g o f == idmap }. Definition Book_4_2_7_ii {A B} (f : A -> B) := {g : B -> A & f o g == idmap }. (* ================================================== thm:equiv-compose-equiv *) (** Lemma 4.2.8 *) Definition Book_4_2_8_i := @HoTT.Basics.Equivalences.isequiv_postcompose. Definition Book_4_2_8_ii := @HoTT.Basics.Equivalences.isequiv_precompose. (* ================================================== lem:inv-hprop *) (** Lemma 4.2.9 *) Definition Book_4_2_9_i := @HoTT.Types.Equiv.contr_sect_equiv. Definition Book_4_2_9_ii := @HoTT.Types.Equiv.contr_retr_equiv. (* ================================================== defn:lcoh-rcoh *) (** Definition 4.2.10 *) (* ================================================== lem:coh-hfib *) (** Lemma 4.2.11 *) (* ================================================== lem:coh-hprop *) (** Lemma 4.2.12 *) (* ================================================== thm:hae-hprop *) (** Theorem 4.2.13 *) Definition Book_4_2_13 := @HoTT.Types.Equiv.hprop_isequiv. (* ================================================== defn:biinv *) (** Definition 4.3.1 *) Definition Book_4_3_1 := @HoTT.Equiv.BiInv.BiInv. (* ================================================== thm:isprop-biinv *) (** Theorem 4.3.2 *) Definition Book_4_3_2 := @HoTT.Equiv.BiInv.ishprop_biinv. (* ================================================== thm:equiv-biinv-isequiv *) (** Corollary 4.3.3 *) Definition Book_4_3_3 := @HoTT.Equiv.BiInv.equiv_biinv_isequiv. (* ================================================== defn:equivalence *) (** Definition 4.4.1 *) Definition Book_4_4_1 := @HoTT.Basics.Trunc.IsTruncMap (-2). (* ================================================== thm:lequiv-contr-hae *) (** Theorem 4.4.3 *) Definition Book_4_4_3 := @HoTT.Types.Equiv.isequiv_contr_map. (* ================================================== thm:contr-hprop *) (** Lemma 4.4.4 *) Definition Book_4_4_4 := @HoTT.Basics.Trunc.ishprop_istrunc. (* ================================================== thm:equiv-contr-hae *) (** Theorem 4.4.5 *) Definition Book_4_4_5 := @HoTT.Types.Equiv.equiv_contr_map_isequiv. (* ================================================== thm:equiv-inhabcod *) (** Corollary 4.4.6 *) Definition Book_4_4_6 := @HoTT.Types.Equiv.isequiv_inhab_codomain. (* ================================================== defn:surj-emb *) (** Definition 4.6.1 *) Definition Book_4_6_1 := @HoTT.Basics.Trunc.IsTruncMap (-1). (* ================================================== thm:mono-surj-equiv *) (** Theorem 4.6.3 *) Definition Book_4_6_3 := @HoTT.Modalities.ReflectiveSubuniverse.isequiv_conn_ino_map. (* ================================================== thm:two-out-of-three *) (** Theorem 4.7.1 *) Definition Book_4_7_1_part_i := @HoTT.Basics.Equivalences.isequiv_compose. Definition Book_4_7_1_part_ii := @HoTT.Basics.Equivalences.cancelR_isequiv. Definition Book_4_7_1_part_iii := @HoTT.Basics.Equivalences.cancelL_isequiv. (* ================================================== defn:retract *) (** Definition 4.7.2 *) (* ================================================== lem:func_retract_to_fiber_retract *) (** Lemma 4.7.3 *) (* ================================================== thm:retract-equiv *) (** Theorem 4.7.4 *) (* ================================================== defn:total-map *) (** Definition 4.7.5 *) Definition Book_4_7_5 := @HoTT.Types.Sigma.functor_sigma. (* ================================================== fibwise-fiber-total-fiber-equiv *) (** Theorem 4.7.6 *) Definition Book_4_7_6 := @HoTT.Types.Sigma.hfiber_functor_sigma. (* ================================================== thm:total-fiber-equiv *) (** Theorem 4.7.7 *) Definition Book_4_7_7 := @HoTT.Types.Equiv.equiv_total_iff_equiv_fiberwise. (* ================================================== thm:fiber-of-a-fibration *) (** Lemma 4.8.1 *) Definition Book_4_8_1 := @HoTT.HFiber.hfiber_fibration. (* ================================================== thm:total-space-of-the-fibers *) (** Lemma 4.8.2 *) Definition Book_4_8_2 := @HoTT.HFiber.equiv_fibration_replacement. (* ================================================== thm:nobject-classifier-appetizer *) (** Theorem 4.8.3 *) Definition Book_4_8_3 := @HoTT.Universes.ObjectClassifier.equiv_sigma_fibration. (* ================================================== thm:object-classifier *) (** Theorem 4.8.4 *) Definition Book_4_8_4 := @HoTT.Universes.ObjectClassifier.ispullback_objectclassifier_square. (* ================================================== weakfunext *) (** Definition 4.9.1 *) Definition Book_4_9_1 := @HoTT.Metatheory.FunextVarieties.WeakFunext. (* ================================================== UA-eqv-hom-eqv *) (** Lemma 4.9.2 *) Definition Book_4_9_2 := @HoTT.Metatheory.UnivalenceImpliesFunext.univalence_isequiv_postcompose. (* ================================================== contrfamtotalpostcompequiv *) (** Corollary 4.9.3 *) (* ================================================== uatowfe *) (** Theorem 4.9.4 *) Definition Book_4_9_4 := @HoTT.Metatheory.UnivalenceImpliesFunext.Univalence_implies_WeakFunext. (* ================================================== wfetofe *) (** Theorem 4.9.5 *) Definition Book_4_9_5 := @HoTT.Metatheory.FunextVarieties.WeakFunext_implies_Funext. (* ================================================== thm:nat-uniq *) (** Theorem 5.1.1 *) (* ================================================== thm:w-uniq *) (** Theorem 5.3.1 *) (* ================================================== defn:nalg *) (** Definition 5.4.1 *) (* ================================================== defn:nhom *) (** Definition 5.4.2 *) (* ================================================== thm:nat-hinitial *) (** Theorem 5.4.5 *) (* ================================================== thm:w-hinit *) (** Theorem 5.4.7 *) (* ================================================== lem:homotopy-induction-times-3 *) (** Lemma 5.5.4 *) (* ================================================== defn:identity-systems *) (** Definition 5.8.1 *) (* ================================================== thm:identity-systems *) (** Theorem 5.8.2 *) Definition Book_5_8_2_i_implies_ii := @HoTT.Homotopy.IdentitySystems.homocontr_pfammap_identitysystem. Definition Book_5_8_2_ii_implies_iii := @HoTT.Homotopy.IdentitySystems.equiv_path_homocontr_pfammap. Definition Book_5_8_2_iii_implies_iv := @HoTT.Homotopy.IdentitySystems.contr_sigma_equiv_path. Definition Book_5_8_2_iv_implies_i := @HoTT.Homotopy.IdentitySystems.identitysystem_contr_sigma. (* ================================================== thm:ML-identity-systems *) (** Theorem 5.8.4 *) (* ================================================== thm:equiv-induction *) (** Corollary 5.8.5 *) Definition Book_5_8_5 := @HoTT.Types.Universe.equiv_induction'. Definition Book_5_8_5_comp := @HoTT.Types.Universe.equiv_induction'_comp. (* ================================================== thm:htpy-induction *) (** Corollary 5.8.6 *) (* ================================================== thm:S1rec *) (** Lemma 6.2.5 *) Definition Book_6_2_5 := @HoTT.Spaces.Circle.Circle_rec. (* ================================================== thm:uniqueness-for-functions-on-S1 *) (** Lemma 6.2.8 *) (* ================================================== thm:S1ump *) (** Lemma 6.2.9 *) Definition Book_6_2_9 := @HoTT.Spaces.Circle.isequiv_Circle_rec_uncurried. (* ================================================== thm:contr-interval *) (** Lemma 6.3.1 *) Definition Book_6_3_1 := @HoTT.HIT.Interval.contr_interval. (* ================================================== thm:interval-funext *) (** Lemma 6.3.2 *) Definition Book_6_3_2 := @HoTT.Metatheory.IntervalImpliesFunext.funext_type_from_interval. (* ================================================== thm:loop-nontrivial *) (** Lemma 6.4.1 *) (* ================================================== thm:S1-autohtpy *) (** Lemma 6.4.2 *) (* ================================================== thm:ap2 *) (** Lemma 6.4.4 *) Definition Book_6_4_4 := @HoTT.Basics.PathGroupoids.ap02. (* ================================================== thm:transport2 *) (** Lemma 6.4.5 *) Definition Book_6_4_5 := @HoTT.Basics.PathGroupoids.transport2. (* ================================================== thm:apd2 *) (** Lemma 6.4.6 *) Definition Book_6_4_6 := @HoTT.Basics.PathGroupoids.apD02. (* ================================================== thm:suspbool *) (** Lemma 6.5.1 *) Definition Book_6_5_1 := @HoTT.Spaces.Spheres.isequiv_S1_to_Circle. (* ================================================== lem:susp-loop-adj *) (** Lemma 6.5.4 *) Definition Book_6_5_4 := @HoTT.Pointed.pSusp.loop_susp_adjoint. (* ================================================== defn:cocone *) (** Definition 6.8.1 *) (* ================================================== thm:pushout-ump *) (** Lemma 6.8.2 *) (* ================================================== thm:trunc0-ind *) (** Lemma 6.9.1 *) Definition Book_6_9_1 := @HoTT.Truncations.Core.Trunc.Trunc_ind 0. (* ================================================== thm:trunc0-lump *) (** Lemma 6.9.2 *) Definition Book_6_9_2 := @HoTT.Modalities.ReflectiveSubuniverse.isequiv_o_to_O. (* ================================================== thm:set-pushout *) (** Lemma 6.9.3 *) (* ================================================== thm:quotient-surjective *) (** Lemma 6.10.2 *) Definition Book_6_10_2 := @HoTT.HIT.quotient.quotient_surjective. (* ================================================== thm:quotient-ump *) (** Lemma 6.10.3 *) Definition Book_6_10_3 := @HoTT.HIT.quotient.quotient_ump. (* ================================================== def:VVquotient *) (** Definition 6.10.5 *) (* ================================================== lem:quotient-when-canonical-representatives *) (** Lemma 6.10.8 *) (* ================================================== thm:retraction-quotient *) (** Corollary 6.10.10 *) (* ================================================== thm:sign-induction *) (** Lemma 6.10.12 *) (* ================================================== thm:looptothe *) (** Corollary 6.10.13 *) (* ================================================== thm:homotopy-groups *) (** Example 6.11.4 *) (* ================================================== thm:free-monoid *) (** Lemma 6.11.5 *) (* ================================================== thm:transport-is-given *) (** Lemma 6.12.1 *) Definition Book_6_12_1 := @HoTT.Types.Universe.transport_path_universe'. (* ================================================== thm:flattening *) (** Lemma 6.12.2 *) Definition Book_6_12_2 := @HoTT.HIT.Flattening.equiv_flattening. (* ================================================== thm:flattening-cp *) (** Lemma 6.12.3 *) (* ================================================== thm:flattening-rect *) (** Lemma 6.12.4 *) Definition Book_6_12_4 := @HoTT.HIT.Flattening.sWtil_ind. (* ================================================== thm:flattening-rectnd *) (** Lemma 6.12.5 *) Definition Book_6_12_5 := @HoTT.HIT.Flattening.sWtil_rec. (* ================================================== thm:ap-sigma-rect-path-pair *) (** Lemma 6.12.7 *) Definition Book_6_12_7 := @HoTT.Types.Sigma.ap_sig_rec_path_sigma. (* ================================================== thm:flattening-rectnd-beta-ppt *) (** Lemma 6.12.8 *) Definition Book_6_12_8 := @HoTT.HIT.Flattening.sWtil_rec_beta_ppt. (* ================================================== eg:unnatural-hit *) (** Example 6.13.1 *) (* ================================================== def:hlevel *) (** Definition 7.1.1 *) (* ================================================== thm:h-level-retracts *) (** Theorem 7.1.4 *) (* ================================================== cor:preservation-hlevels-weq *) (** Corollary 7.1.5 *) (* ================================================== thm:isntype-mono *) (** Theorem 7.1.6 *) (* ================================================== thm:hlevel-cumulative *) (** Theorem 7.1.7 *) (* ================================================== thm:ntypes-sigma *) (** Theorem 7.1.8 *) (* ================================================== thm:hlevel-prod *) (** Theorem 7.1.9 *) Definition Book_7_1_9 := @HoTT.Basics.Trunc.istrunc_forall. (* ================================================== thm:isaprop-isofhlevel *) (** Theorem 7.1.10 *) (* ================================================== thm:hleveln-of-hlevelSn *) (** Theorem 7.1.11 *) Definition Book7_1_11 := @HoTT.Universes.TruncType.istrunc_trunctype. (* ================================================== thm:h-set-uip-K *) (** Theorem 7.2.1 *) (* ================================================== thm:h-set-refrel-in-paths-sets *) (** Theorem 7.2.2 *) Definition Book_7_2_2 := @HoTT.Universes.HSet.ishset_hrel_subpaths. (* ================================================== notnotstable-equality-to-set *) (** Corollary 7.2.3 *) (* ================================================== lem:hedberg-helper *) (** Lemma 7.2.4 *) (* ================================================== thm:hedberg *) (** Theorem 7.2.5 *) (* ================================================== prop:nat-is-set *) (** Theorem 7.2.6 *) (* ================================================== thm:hlevel-loops *) (** Theorem 7.2.7 *) (* ================================================== lem:hlevel-if-inhab-hlevel *) (** Lemma 7.2.8 *) (* ================================================== thm:ntype-nloop *) (** Theorem 7.2.9 *) (* ================================================== thm:truncn-ind *) (** Theorem 7.3.2 *) (* ================================================== thm:trunc-reflective *) (** Lemma 7.3.3 *) (* ================================================== thm:trunc-htpy *) (** Lemma 7.3.5 *) (* ================================================== cor:trunc-prod *) (** Theorem 7.3.8 *) (* ================================================== thm:trunc-in-truncated-sigma *) (** Theorem 7.3.9 *) (* ================================================== thm:refl-over-ntype-base *) (** Corollary 7.3.10 *) (* ================================================== thm:path-truncation *) (** Theorem 7.3.12 *) Definition Book_7_3_12 := @HoTT.Truncations.SeparatedTrunc.equiv_path_Tr. (* ================================================== lem:truncation-le *) (** Lemma 7.3.15 *) (* ================================================== thm:conemap-funct *) (** Lemma 7.4.10 *) (* ================================================== reflectcommutespushout *) (** Theorem 7.4.12 *) (* ================================================== thm:minusoneconn-surjective *) (** Lemma 7.5.2 *) (* ================================================== lem:nconnected_postcomp *) (** Lemma 7.5.6 *) (* ================================================== cor:totrunc-is-connected *) (** Corollary 7.5.8 *) Definition Book_7_5_8 := @HoTT.Modalities.Modality.conn_map_to_O. (* ================================================== thm:nconn-to-ntype-const *) (** Corollary 7.5.9 *) (* ================================================== connectedtotruncated *) (** Corollary 7.5.9 *) (* ================================================== lem:nconnected_to_leveln_to_equiv *) (** Lemma 7.5.10 *) (* ================================================== thm:connected-pointed *) (** Lemma 7.5.11 *) (* ================================================== lem:nconnected_postcomp_variation *) (** Lemma 7.5.12 *) (* ================================================== prop:nconn_fiber_to_total *) (** Lemma 7.5.13 *) (* ================================================== lem:connected-map-equiv-truncation *) (** Lemma 7.5.14 *) (* ================================================== thm:modal-mono *) (** Lemma 7.6.2 *) Definition Book_7_6_2 := @HoTT.HFiber.equiv_istruncmap_ap. (* ================================================== defn:modal-image *) (** Definition 7.6.3 *) (* ================================================== prop:to_image_is_connected *) (** Lemma 7.6.4 *) (* ================================================== prop:factor_equiv_fiber *) (** Lemma 7.6.5 *) (* ================================================== thm:orth-fact *) (** Theorem 7.6.6 *) (* ================================================== lem:hfiber_wrt_pullback *) (** Lemma 7.6.8 *) (* ================================================== thm:stable-images *) (** Theorem 7.6.9 *) (* ================================================== defn:reflective-subuniverse *) (** Definition 7.7.1 *) (* ================================================== thm:reflsubunv-forall *) (** Theorem 7.7.2 *) (* ================================================== cor:trunc_prod *) (** Corollary 7.7.3 *) (* ================================================== thm:modal-char *) (** Theorem 7.7.4 *) (* ================================================== defn:modality *) (** Definition 7.7.5 *) (* ================================================== prop:lv_n_deptype_sec_equiv_by_precomp *) (** Theorem 7.7.7 *) (* ================================================== def-of-homotopy-groups *) (** Definition 8.0.1 *) (* ================================================== S1-universal-cover *) (** Definition 8.1.1 *) (* ================================================== lem:transport-s1-code *) (** Lemma 8.1.2 *) (* ================================================== thm:pi1s1-decode *) (** Definition 8.1.6 *) (* ================================================== lem:s1-decode-encode *) (** Lemma 8.1.7 *) (* ================================================== lem:s1-encode-decode *) (** Lemma 8.1.8 *) (* ================================================== cor:omega-s1 *) (** Corollary 8.1.10 *) (* ================================================== cor:pi1s1 *) (** Corollary 8.1.11 *) (* ================================================== thm:iscontr-s1cover *) (** Lemma 8.1.12 *) (* ================================================== thm:encode-total-equiv *) (** Corollary 8.1.13 *) (* ================================================== thm:suspension-increases-connectedness *) (** Theorem 8.2.1 *) (* ================================================== cor:sn-connected *) (** Corollary 8.2.2 *) (* ================================================== lem:pik-nconnected *) (** Lemma 8.3.2 *) (* ================================================== def:pointedmap *) (** Definition 8.4.1 *) (* ================================================== def:loopfunctor *) (** Definition 8.4.2 *) (* ================================================== thm:fiber-of-the-fiber *) (** Lemma 8.4.4 *) (* ================================================== thm:les *) (** Theorem 8.4.6 *) (* ================================================== thm:ses *) (** Lemma 8.4.7 *) (* ================================================== thm:conn-pik *) (** Corollary 8.4.8 *) (* ================================================== thm:hopf-fibration *) (** Theorem 8.5.1 *) (* ================================================== cor:pis2-hopf *) (** Corollary 8.5.2 *) (* ================================================== lem:fibration-over-pushout *) (** Lemma 8.5.3 *) (* ================================================== lem:hopf-construction *) (** Lemma 8.5.7 *) Definition Book_8_5_6 := @HoTT.Homotopy.Hopf.hopf_construction. Definition Book_8_5_7 := @HoTT.Homotopy.Hopf.pequiv_hopf_total_join. (* ================================================== lem:hspace-S1 *) (** Lemma 8.5.8 *) (* ================================================== thm:conn-trunc-variable-ind *) (** Lemma 8.6.1 *) (* ================================================== thm:wedge-connectivity *) (** Lemma 8.6.2 *) (* ================================================== thm:freudenthal *) (** Theorem 8.6.4 *) (* ================================================== thm:freudcode *) (** Definition 8.6.5 *) (* ================================================== thm:freudlemma *) (** Lemma 8.6.10 *) (* ================================================== cor:freudenthal-equiv *) (** Corollary 8.6.14 *) (* ================================================== cor:stability-spheres *) (** Corollary 8.6.15 *) (* ================================================== thm:pinsn *) (** Theorem 8.6.17 *) (* ================================================== thm:pi3s2 *) (** Corollary 8.6.19 *) (* ================================================== thm:naive-van-kampen *) (** Theorem 8.7.4 *) (* ================================================== eg:circle *) (** Example 8.7.6 *) (* ================================================== eg:suspension *) (** Example 8.7.7 *) (* ================================================== eg:wedge *) (** Example 8.7.8 *) (* ================================================== thm:kbar *) (** Lemma 8.7.9 *) (* ================================================== thm:van-Kampen *) (** Theorem 8.7.12 *) (* ================================================== eg:clvk *) (** Example 8.7.13 *) (* ================================================== eg:cofiber *) (** Example 8.7.14 *) (* ================================================== eg:torus *) (** Example 8.7.15 *) (* ================================================== eg:kg1 *) (** Example 8.7.17 *) (* ================================================== thm:whitehead0 *) (** Theorem 8.8.1 *) Definition Book_8_8_1 := @HoTT.Homotopy.WhiteheadsPrinciple.isequiv_issurj_tr0_isequiv_ap. (* ================================================== thm:whitehead1 *) (** Corollary 8.8.2 *) Definition Book_8_8_2 := @HoTT.Homotopy.WhiteheadsPrinciple.isequiv_isbij_tr0_isequiv_loops. (* ================================================== thm:whiteheadn *) (** Theorem 8.8.3 *) Definition Book_8_8_3 := @HoTT.Homotopy.WhiteheadsPrinciple.whiteheads_principle. (* ================================================== thm:whitehead-contr *) (** Corollary 8.8.4 *) (* ================================================== thm:pik-conn *) (** Corollary 8.8.5 *) (* ================================================== lem:encode-decode-loop *) (** Lemma 8.9.1 *) (* ================================================== Blakers-Massey *) (** Theorem 8.10.2 *) (* ================================================== Eilenberg-Mac-Lane-Spaces *) (** Theorem 8.10.3 *) (* ================================================== thm:covering-spaces *) (** Theorem 8.10.4 *) (* ================================================== ct:precategory *) (** Definition 9.1.1 *) Definition Book_9_1_1 := @HoTT.Categories.Category.Core.PreCategory. (* ================================================== ct:isomorphism *) (** Definition 9.1.2 *) Definition Book_9_1_2 := @HoTT.Categories.Category.Morphisms.Isomorphic. (* ================================================== ct:isoprop *) (** Lemma 9.1.3 *) Definition Book_9_1_3 := @HoTT.Categories.Category.Morphisms.istrunc_isisomorphism. (* ================================================== ct:idtoiso *) (** Lemma 9.1.4 *) Definition Book_9_1_4 := @HoTT.Categories.Category.Morphisms.idtoiso. (* ================================================== ct:precatset *) (** Example 9.1.5 *) Definition Book_9_1_5 := @HoTT.Categories.SetCategory.Core.set_cat. (* ================================================== ct:category *) (** Definition 9.1.6 *) Definition Book_9_1_6 C := (HoTT.Categories.Category.Univalent.IsCategory C). (* ================================================== ct:eg:set *) (** Example 9.1.7 *) (** Once this is proven, we will have << Definition Book_9_1_7 := @HoTT.Categories.SetCategory.Morphisms.iscategory_set_cat. >> *) (* ================================================== ct:obj-1type *) (** Lemma 9.1.8 *) Definition Book_9_1_8 := @HoTT.Categories.Category.Univalent.trunc_category. (* ================================================== ct:idtoiso-trans *) (** Lemma 9.1.9 *) (* ================================================== ct:orders *) (** Example 9.1.14 *) (* ================================================== ct:gaunt *) (** Example 9.1.15 *) Definition Book_9_1_15 A `{H : HoTT.Categories.Category.Univalent.IsCategory A} : IsHSet (HoTT.Categories.Category.Core.object A) <-> (forall a b, IsHProp (@HoTT.Categories.Category.Morphisms.Isomorphic A a b)). Proof. split. - intros H' a b. eapply istrunc_isequiv_istrunc. + refine (H' a b). + apply H. - intros H'; apply istrunc_S; intros a b. eapply istrunc_isequiv_istrunc. + apply (H' a b). + apply (@isequiv_inverse _ _ _ (H _ _)). Defined. (* ================================================== ct:discrete *) (** Example 9.1.16 *) Definition Book_9_1_16 := @HoTT.Categories.GroupoidCategory.Core.groupoid_category. (* ================================================== ct:fundgpd *) (** Example 9.1.17 *) Definition Book_9_1_17 := @HoTT.Categories.FundamentalPreGroupoidCategory.fundamental_pregroupoid_category. (* ================================================== ct:hoprecat *) (** Example 9.1.18 *) Definition Book_9_1_18 := @HoTT.Categories.HomotopyPreCategory.homotopy_precategory. (* ================================================== ct:rel *) (** Example 9.1.19 *) (* ================================================== ct:functor *) (** Definition 9.2.1 *) Definition Book_9_2_1 := @HoTT.Categories.Functor.Core.Functor. (* ================================================== ct:nattrans *) (** Definition 9.2.2 *) Definition Book_9_2_2 := @HoTT.Categories.NaturalTransformation.Core.NaturalTransformation. (* ================================================== ct:functor-precat *) (** Definition 9.2.3 *) Definition Book_9_2_3 := @HoTT.Categories.FunctorCategory.Core.functor_category. (* ================================================== ct:natiso *) (** Lemma 9.2.4 *) Definition Book_9_2_4 := @HoTT.Categories.FunctorCategory.Morphisms.isisomorphism_natural_transformation. (* ================================================== ct:functor-cat *) (** Theorem 9.2.5 *) (** When this is done, it will be << Definition Book_9_2_5 := @HoTT.Categories.FunctorCategory.Morphisms.iscategory_functor_category. >> *) (* ================================================== ct:functor-composition *) (** Definition 9.2.6 *) Definition Book_9_2_6 := @HoTT.Categories.Functor.Composition.Core.compose. (* ================================================== ct:whisker *) (** Definition 9.2.7 *) Definition Book_9_2_7_l := @HoTT.Categories.NaturalTransformation.Composition.Core.whisker_l. Definition Book_9_2_7_r := @HoTT.Categories.NaturalTransformation.Composition.Core.whisker_r. (* ================================================== ct:interchange *) (** Lemma 9.2.8 *) Definition Book_9_2_8 := @HoTT.Categories.NaturalTransformation.Composition.Laws.exchange_whisker. (* ================================================== ct:functor-assoc *) (** Lemma 9.2.9 *) Definition Book_9_2_9 := @HoTT.Categories.Functor.Composition.Laws.associativity. (* ================================================== ct:pentagon *) (** Lemma 9.2.10 *) (* ================================================== ct:units *) (** Lemma 9.2.11 *) Definition Book_9_2_11_l := @HoTT.Categories.Functor.Composition.Laws.left_identity. Definition Book_9_2_11_r := @HoTT.Categories.Functor.Composition.Laws.right_identity. Definition Book_9_2_11 := @HoTT.Categories.Functor.Composition.Laws.triangle. (* ================================================== ct:adjoints *) (** Definition 9.3.1 *) Definition Book_9_3_1 := @HoTT.Categories.Adjoint.UnitCounit.AdjunctionUnitCounit. (* ================================================== ct:adjprop *) (** Lemma 9.3.2 *) (* ================================================== ct:equiv *) (** Definition 9.4.1 *) (* ================================================== ct:adjointification *) (** Lemma 9.4.2 *) Definition Book_9_4_2a := @HoTT.Categories.Functor.Attributes.IsFaithful. Definition Book_9_4_2b := @HoTT.Categories.Functor.Attributes.IsFull. Definition Book_9_4_2c := @HoTT.Categories.Functor.Attributes.IsFullyFaithful. (* ================================================== ct:full-faithful *) (** Definition 9.4.3 *) (* ================================================== ct:split-essentially-surjective *) (** Definition 9.4.4 *) Definition Book_9_4_4 := @HoTT.Categories.Functor.Attributes.IsSplitEssentiallySurjective. (* ================================================== ct:ffeso *) (** Lemma 9.4.5 *) (* ================================================== ct:essentially-surjective *) (** Definition 9.4.6 *) Definition Book_9_4_6_ess := @HoTT.Categories.Functor.Attributes.IsEssentiallySurjective. Definition Book_9_4_6_weq := @HoTT.Categories.Functor.Attributes.IsWeakEquivalence. (* ================================================== ct:catweq *) (** Lemma 9.4.7 *) (* ================================================== ct:isocat *) (** Definition 9.4.8 *) (* ================================================== ct:isoprecat *) (** Lemma 9.4.9 *) (* ================================================== ct:chaotic *) (** Example 9.4.13 *) Definition Book_9_4_13 := @HoTT.Categories.IndiscreteCategory.Core.indiscrete_category. (* ================================================== ct:eqv-levelwise *) (** Lemma 9.4.14 *) (* ================================================== ct:cat-eq-iso *) (** Lemma 9.4.15 *) (* ================================================== ct:cat-2cat *) (** Theorem 9.4.16 *) (* ================================================== ct:opposite-category *) (** Definition 9.5.1 *) Definition Book_9_5_1 := @HoTT.Categories.Category.Dual.opposite. (* ================================================== ct:prod-cat *) (** Definition 9.5.2 *) Definition Book_9_5_2 := @HoTT.Categories.Category.Prod.prod. (* ================================================== ct:functorexpadj *) (** Lemma 9.5.3 *) (** When we prove it, this should be mapped to the law, not the functor. *) Definition Book_9_5_3 := @HoTT.Categories.ExponentialLaws.Law4.Functors.functor. (* ================================================== ct:yoneda *) (** Theorem 9.5.4 *) Definition Book_9_5_4 := @HoTT.Categories.Yoneda.yoneda_lemma. (* ================================================== ct:yoneda-embedding *) (** Corollary 9.5.6 *) Definition Book_9_5_6 := @HoTT.Categories.Yoneda.yoneda_embedding. (* ================================================== ct:yoneda-mono *) (** Corollary 9.5.7 *) (* ================================================== ct:representable *) (** Definition 9.5.8 *) (* ================================================== ct:representable-prop *) (** Theorem 9.5.9 *) (* ================================================== ct:adj-repr *) (** Lemma 9.5.10 *) (* ================================================== ct:adjprop2 *) (** Corollary 9.5.11 *) (* ================================================== ct:strict-category *) (** Definition 9.6.1 *) Definition Book_9_6_1 C := HoTT.Categories.Category.Strict.IsStrictCategory C. (* ================================================== ct:mono-cat *) (** Example 9.6.2 *) (* ================================================== ct:galois *) (** Example 9.6.3 *) (* ================================================== ct:dagger-precategory *) (** Definition 9.7.1 *) (* ================================================== ct:unitary *) (** Definition 9.7.2 *) (* ================================================== ct:idtounitary *) (** Lemma 9.7.3 *) (* ================================================== ct:dagger-category *) (** Definition 9.7.4 *) (* ================================================== ct:rel-dagger-cat *) (** Example 9.7.5 *) (* ================================================== ct:groupoid-dagger-cat *) (** Example 9.7.6 *) (* ================================================== ct:hilb *) (** Example 9.7.7 *) (* ================================================== ct:sig *) (** Definition 9.8.1 *) Definition Book_9_8_1 := @HoTT.Categories.Structure.Core.NotionOfStructure. (* ================================================== thm:sip *) (** Theorem 9.8.2 *) Definition Book_9_8_2 := @HoTT.Categories.Structure.IdentityPrinciple.structure_identity_principle. (* ================================================== ct:sip-functor-cat *) (** Example 9.8.3 *) (* ================================================== defn:fo-notion-of-structure *) (** Definition 9.8.4 *) (* ================================================== ct:esosurj-postcomp-faithful *) (** Lemma 9.9.1 *) (* ================================================== ct:esofull-precomp-ff *) (** Lemma 9.9.2 *) (* ================================================== ct:cat-weq-eq *) (** Theorem 9.9.4 *) (* ================================================== thm:rezk-completion *) (** Theorem 9.9.5 *) (* ================================================== ct:rezk-fundgpd-trunc1 *) (** Example 9.9.6 *) (* ================================================== ct:hocat *) (** Example 9.9.7 *) (* ================================================== ct:weq-iso-precat-cat *) (** Theorem 9.9.8 *) (* ================================================== thm:mono *) (** Lemma 10.1.1 *) (** The third notion in the book is called embedding. No complete equivalence yet, but see:*) Definition Book_10_1_1_iii := @HSet.isinj_embedding. (* ================================================== thm:inj-mono *) (** Lemma 10.1.2 *) Definition Book_10_1_2rl := @HSet.isinj_ismono. Definition Book_10_1_2lr := @HSet.ismono_isinj. (* This one is not in the book, but close to 10.1.2: HSet.isembedding_isinj_hset*) (* ================================================== epis-surj *) (** Lemma 10.1.4 *) Definition Book_10_1_4_i_iii := @HIT.epi.isepi_issurj. Definition Book_10_1_4_i_ii := @HIT.epi.isepi'_contr_cone. Definition Book_10_1_4_iii_i := @HIT.epi.issurj_isepi. (* ================================================== lem:images_are_coequalizers *) (** Theorem 10.1.5 *) (* ================================================== thm:set_regular *) (** Theorem 10.1.5 *) (* ================================================== lem:pb_of_coeq_is_coeq *) (** Lemma 10.1.6 *) (* ================================================== lem:sets_exact *) (** Lemma 10.1.8 *) Definition Book_10_1_8 := @HIT.quotient.sets_exact. (* ================================================== prop:kernels_are_effective *) (** Theorem 10.1.9 *) (* See: HIT.unique_choice.unique_choice theories.ObjectClassifier.PowisoPFam Apparently closure under Pi and Sigma are still missing ? *) (* ================================================== thm:settopos *) (** Theorem 10.1.12 *) (* ================================================== prop:trunc_of_prop_is_set *) (** Lemma 10.1.13 *) (* ================================================== thm:1surj_to_surj_to_pem *) (** Theorem 10.1.14 *) (* ================================================== thm:ETCS *) (** Theorem 10.1.15 *) (* ================================================== defn:card *) (** Definition 10.2.1 *) (* ================================================== card:semiring *) (** Lemma 10.2.4 *) (* ================================================== card:exp *) (** Lemma 10.2.6 *) (* ================================================== thm:injsurj *) (** Lemma 10.2.9 *) (* ================================================== defn:accessibility *) (** Definition 10.3.1 *) (* ================================================== thm:nat-wf *) (** Example 10.3.5 *) (* ================================================== thm:wtype-wf *) (** Example 10.3.6 *) (* ================================================== thm:wfrec *) (** Lemma 10.3.7 *) (* ================================================== thm:wfmin *) (** Lemma 10.3.8 *) (* ================================================== def:simulation *) (** Definition 10.3.11 *) (* ================================================== thm:wfcat *) (** Corollary 10.3.15 *) (* ================================================== thm:ordord *) (** Theorem 10.3.20 *) (* ================================================== thm:ordsucc *) (** Lemma 10.3.21 *) (* ================================================== thm:ordunion *) (** Lemma 10.3.22 *) (* ================================================== thm:wellorder *) (** Theorem 10.4.3 *) (* ================================================== thm:wop *) (** Theorem 10.4.4 *) (* ================================================== defn:V *) (** Definition 10.5.1 *) Definition Book_10_5_1 := @HoTT.HIT.V.CumulativeHierarchy.V. (* ================================================== def:bisimulation *) (** Definition 10.5.4 *) Definition Book_10_5_4 := @HoTT.HIT.V.bisimulation. (* ================================================== lem:BisimEqualsId *) (** Lemma 10.5.5 *) Definition Book_10_5_5 := @HoTT.HIT.V.bisimulation_equiv_id. (* ================================================== lem:MonicSetPresent *) (** Lemma 10.5.6 *) Definition Book_10_5_6 := @HoTT.HIT.V.monic_set_present. (* ================================================== def:TypeOfElements *) (** Definition 10.5.7 *) Definition Book_10_5_7 := @HoTT.HIT.V.type_of_members. (* ================================================== thm:VisCST *) (** Theorem 10.5.8 *) Definition Book_10_5_8_item_i := @HoTT.HIT.V.extensionality. Definition Book_10_5_8_item_ii := @HoTT.HIT.V.not_mem_Vempty. Definition Book_10_5_8_item_iii := @HoTT.HIT.V.pairing. Definition Book_10_5_8_item_iv := @HoTT.HIT.V.infinity. Definition Book_10_5_8_item_v := @HoTT.HIT.V.union. Definition Book_10_5_8_item_vi := @HoTT.HIT.V.function. Definition Book_10_5_8_item_vii := @HoTT.HIT.V.mem_induction. Definition Book_10_5_8_item_viii := @HoTT.HIT.V.replacement. Definition Book_10_5_8_item_ix := @HoTT.HIT.V.separation. (* ================================================== cor:Delta0sep *) (** Corollary 10.5.9 *) (* ================================================== lem:fullsep *) (** Lemma 10.5.10 *) (* ================================================== thm:zfc *) (** Theorem 10.5.11 *) (* ================================================== defn:dedekind-reals *) (** Definition 11.2.1 *) (* ================================================== dedekind-in-cut-as-le *) (** Lemma 11.2.2 *) (* ================================================== RD-inverse-apart-0 *) (** Theorem 11.2.4 *) (* ================================================== RD-archimedean *) (** Theorem 11.2.6 *) (* ================================================== ordered-field *) (** Definition 11.2.7 *) Definition Book_11_2_7 := @HoTT.Classes.interfaces.abstract_algebra.IsField. Definition Book_11_2_7' := @HoTT.Classes.interfaces.orders.FullPseudoSemiRingOrder. (* ================================================== RD-archimedean-ordered-field *) (** Theorem 11.2.8 *) (* ================================================== defn:cauchy-approximation *) (** Definition 11.2.10 *) Definition Book_11_2_10 := @HoTT.Classes.theory.premetric.Approximation. (* ================================================== RD-cauchy-complete *) (** Theorem 11.2.12 *) (* ================================================== RD-final-field *) (** Theorem 11.2.14 *) (* ================================================== lem:cuts-preserve-admissibility *) (** Lemma 11.2.15 *) (* ================================================== RD-dedekind-complete *) (** Corollary 11.2.16 *) (* ================================================== defn:cauchy-reals *) (** Definition 11.3.2 *) (* ================================================== lem:close-reflexive *) (** Lemma 11.3.8 *) (* ================================================== thm:Cauchy-reals-are-a-set *) (** Theorem 11.3.9 *) (* ================================================== RC-lim-onto *) (** Lemma 11.3.10 *) (* ================================================== RC-lim-factor *) (** Lemma 11.3.11 *) (* ================================================== thm:RCsim-symmetric *) (** Lemma 11.3.12 *) (* ================================================== defn:lipschitz *) (** Definition 11.3.14 *) Definition Book_11_3_14 := @HoTT.Classes.theory.premetric.Lipschitz. (* ================================================== RC-extend-Q-Lipschitz *) (** Lemma 11.3.15 *) (* ================================================== defn:RC-approx *) (** Theorem 11.3.16 *) (* ================================================== thm:RC-sim-characterization *) (** Theorem 11.3.32 *) (* ================================================== thm:RC-sim-lim *) (** Lemma 11.3.36 *) (* ================================================== thm:RC-sim-lim-term *) (** Lemma 11.3.37 *) (* ================================================== RC-continuous-eq *) (** Lemma 11.3.39 *) (* ================================================== RC-binary-nonexpanding-extension *) (** Lemma 11.3.40 *) (* ================================================== RC-archimedean *) (** Theorem 11.3.41 *) (* ================================================== thm:RC-le-grow *) (** Lemma 11.3.42 *) (* ================================================== thm:RC-lt-open *) (** Lemma 11.3.43 *) (* ================================================== RC-sim-eqv-le *) (** Theorem 11.3.44 *) (* ================================================== RC-squaring *) (** Theorem 11.3.46 *) (* ================================================== RC-archimedean-ordered-field *) (** Theorem 11.3.48 *) (* ================================================== RC-initial-Cauchy-complete *) (** Theorem 11.3.50 *) (* ================================================== lem:untruncated-linearity-reals-coincide *) (** Lemma 11.4.1 *) (* ================================================== when-reals-coincide *) (** Corollary 11.4.3 *) (* ================================================== defn:metric-space *) (** Definition 11.5.1 *) (* ================================================== defn:complete-metric-space *) (** Definition 11.5.2 *) (* ================================================== defn:total-bounded-metric-space *) (** Definition 11.5.3 *) (* ================================================== defn:uniformly-continuous *) (** Definition 11.5.5 *) (* ================================================== analysis-interval-ctb *) (** Theorem 11.5.6 *) (* ================================================== ctb-uniformly-continuous-sup *) (** Theorem 11.5.7 *) (* ================================================== analysis-bw-lpo *) (** Theorem 11.5.9 *) (* ================================================== classical-Heine-Borel *) (** Theorem 11.5.11 *) (* ================================================== defn:inductive-cover *) (** Definition 11.5.13 *) (* ================================================== reals-formal-topology-locally-compact *) (** Lemma 11.5.14 *) (* ================================================== interval-Heine-Borel *) (** Corollary 11.5.15 *) (* ================================================== inductive-cover-classical *) (** Theorem 11.5.16 *) (* ================================================== defn:surreals *) (** Definition 11.6.1 *) Definition Book_11_6_1 := @HoTT.Spaces.No.Core.No. (* ================================================== thm:NO-simplicity *) (** Theorem 11.6.2 *) (* ================================================== thm:NO-refl-opt *) (** Theorem 11.6.4 *) Definition Book_11_6_4_i := @HoTT.Spaces.No.Core.le_reflexive. Definition Book_11_6_4_ii_l := @HoTT.Spaces.No.Core.lt_lopt. Definition Book_11_6_4_ii_r := @HoTT.Spaces.No.Core.lt_ropt. (* ================================================== thm:NO-set *) (** Corollary 11.6.5 *) Definition Book_11_6_5 := @HoTT.Spaces.No.Core.isset_No. (* ================================================== defn:No-codes *) (** Theorem 11.6.7 *) Definition Book_11_6_7 := @HoTT.Spaces.No.Core.No_codes_package. (* ================================================== thm:NO-encode-decode *) (** Theorem 11.6.16 *) Definition Book_11_6_16_i := @HoTT.Spaces.No.Core.No_encode_le_lt. Definition Book_11_6_16_ii := @HoTT.Spaces.No.Core.No_decode_le_lt. (* ================================================== thm:NO-unstrict-transitive *) (** Corollary 11.6.17 *) Definition Book_11_6_17_i := @HoTT.Spaces.No.Core.lt_le. Definition Book_11_6_17_ii := @HoTT.Spaces.No.Core.le_le_trans. Definition Book_11_6_17_iii := @HoTT.Spaces.No.Core.le_lt_trans. Definition Book_11_6_17_iv := @HoTT.Spaces.No.Core.lt_le_trans. (* ================================================== eg:surreal-addition *) (** Example 11.6.18 *) Definition Book_11_6_18 := @HoTT.Spaces.No.Addition.plus. Coq-HoTT-9.0/contrib/HoTTBookExercises.v000066400000000000000000001763251474641544500201070ustar00rootroot00000000000000(** The HoTT Book Exercises formalization. *) (** This file records formalized solutions to the HoTT Book exercises. *) (* See HoTTBook.v for an IMPORTANT NOTE FOR THE HoTT DEVELOPERS. PROCEDURE FOR UPDATING THE FILE: 1. Compile the latest version of the HoTT Book to update the LaTeX labels. Do not forget to pull in changes from HoTT/HoTT. 2. Run `etc/Book.py` using the `--exercises` flag (so your command should look like `cat ../book/*.aux | etc/Book.py --exercises contrib/HoTTBookExercises.v`) If it complains, fix things. 3. Add contents to new entries. 4. Run `etc/Book.py` again to make sure it is happy. 5. Compile this file with `make contrib` or `make contrib/HoTTBookExercises.vo`. 6. Do the git thing to submit your changes. *) From HoTT Require Import Basics Types HProp HSet Projective TruncType Truncations Modalities.Notnot Modalities.Open Modalities.Closed BoundedSearch Equiv.BiInv Spaces.Nat Spaces.Torus.TorusEquivCircles Classes.implementations.peano_naturals Metatheory.Core Metatheory.FunextVarieties. Local Open Scope nat_scope. Local Open Scope type_scope. Local Open Scope path_scope. (* END OF PREAMBLE *) (* ================================================== ex:composition *) (** Exercise 1.1 *) Definition Book_1_1 := (fun (A B C : Type) (f : A -> B) (g : B -> C) => g o f). Theorem Book_1_1_refl : forall (A B C D : Type) (f : A -> B) (g : B -> C) (h : C -> D), h o (g o f) = (h o g) o f. Proof. reflexivity. Defined. (* ================================================== ex:pr-to-rec *) (** Exercise 1.2 *) (** Recursor as equivalence. *) Definition Book_1_2_prod_lib := @HoTT.Types.Prod.equiv_uncurry. Section Book_1_2_prod. Variable A B : Type. (** Recursor with projection functions instead of pattern-matching. *) Let prod_rec_proj C (g : A -> B -> C) (p : A * B) : C := g (fst p) (snd p). Definition Book_1_2_prod := prod_rec_proj. Proposition Book_1_2_prod_fst : fst = prod_rec_proj A (fun a b => a). Proof. reflexivity. Defined. Proposition Book_1_2_prod_snd : snd = prod_rec_proj B (fun a b => b). Proof. reflexivity. Defined. End Book_1_2_prod. (** Recursor as (dependent) equivalence. *) Definition Book_1_2_sig_lib := @HoTT.Types.Sigma.equiv_sig_ind. Section Book_1_2_sig. Variable A : Type. Variable B : A -> Type. (** Non-dependent recursor with projection functions instead of pattern matching. *) Let sig_rec_proj C (g : forall (x : A), B x -> C) (p : exists (x : A), B x) : C := g (pr1 p) (pr2 p). Definition Book_1_2_sig := @sig_rec_proj. Proposition Book_1_2_sig_fst : @pr1 A B = sig_rec_proj A (fun a => fun b => a). Proof. reflexivity. Defined. (** NB: You cannot implement pr2 with only the recursor, so it is not possible to check its definitional equality as the exercise suggests. *) End Book_1_2_sig. (* ================================================== ex:pr-to-ind *) (** Exercise 1.3 *) (** The propositional uniqueness principles are named with an 'eta' postfix in the HoTT library. *) Definition Book_1_3_prod_lib := @HoTT.Types.Prod.prod_ind. Section Book_1_3_prod. Variable A B : Type. Let prod_ind_eta (C : A * B -> Type) (g : forall (x : A) (y : B), C (x, y)) (x : A * B) : C x := transport C (HoTT.Types.Prod.eta_prod x) (g (fst x) (snd x)). Definition Book_1_3_prod := prod_ind_eta. Proposition Book_1_3_prod_refl : forall C g a b, prod_ind_eta C g (a, b) = g a b. Proof. reflexivity. Defined. End Book_1_3_prod. Definition Book_1_3_sig_lib := @HoTT.Basics.Overture.sig_ind. Section Book_1_3_sig. Variable A : Type. Variable B : A -> Type. Let sig_ind_eta (C : (exists (a : A), B a) -> Type) (g : forall (a : A) (b : B a), C (a; b)) (x : exists (a : A), B a) : C x := transport C (HoTT.Types.Sigma.eta_sigma x) (g (pr1 x) (pr2 x)). Definition Book_1_3_sig := sig_ind_eta. Proposition Book_1_3_sig_refl : forall C g a b, sig_ind_eta C g (a; b) = g a b. Proof. reflexivity. Defined. End Book_1_3_sig. (* ================================================== ex:iterator *) (** Exercise 1.4 *) Section Book_1_4. Fixpoint Book_1_4_iter (C : Type) (c0 : C) (cs : C -> C) (n : nat) : C := match n with | O => c0 | S m => cs (Book_1_4_iter C c0 cs m) end. Definition Book_1_4_rec' (C : Type) (c0 : C) (cs : nat -> C -> C) : nat -> nat * C := Book_1_4_iter (nat * C) (O, c0) (fun x => (S (fst x), cs (fst x) (snd x))). Definition Book_1_4_rec (C : Type) (c0 : C) (cs : nat -> C -> C) (n : nat) : C := snd (Book_1_4_rec' C c0 cs n). Lemma Book_1_4_aux : forall C c0 cs n, fst (Book_1_4_rec' C c0 cs n) = n. Proof. intros C c0 cs n. induction n as [| m IH]. - simpl. reflexivity. - cbn. exact (ap S IH). Qed. Proposition Book_1_4_eq : forall C c0 cs n, Book_1_4_rec C c0 cs n = nat_rect (fun _ => C) c0 cs n. Proof. intros C c0 cs n. induction n as [| m IH]. - simpl. reflexivity. - change (cs (fst (Book_1_4_rec' C c0 cs m)) (Book_1_4_rec C c0 cs m) = cs m (nat_rect (fun _ => C) c0 cs m)). lhs rapply (ap (fun x => cs x _) (Book_1_4_aux _ _ _ _)). exact (ap (cs m) IH). Qed. End Book_1_4. (* ================================================== ex:sum-via-bool *) (** Exercise 1.5 *) Section Book_1_5. Definition Book_1_5_sum (A B : Type) := { x : Bool & if x then A else B }. Notation "'inl' a" := (true; a) (at level 0). Notation "'inr' b" := (false; b) (at level 0). Definition Book_1_5_ind (A B : Type) (C : Book_1_5_sum A B -> Type) (f : forall a, C (inl a)) (g : forall b, C (inr b)) : forall x : Book_1_5_sum A B, C x := fun x => match x with | inl a => f a | inr b => g b end. Theorem inl_red {A B : Type} {C : Book_1_5_sum A B -> Type} f g { a : A } : Book_1_5_ind A B C f g (inl a) = f a. Proof. reflexivity. Defined. Theorem inr_red {A B : Type} {C : Book_1_5_sum A B -> Type} f g { b : B } : Book_1_5_ind A B C f g (inr b) = g b. Proof. reflexivity. Defined. End Book_1_5. (* ================================================== ex:prod-via-bool *) (** Exercise 1.6 *) Section Book_1_6. Context `{Funext}. Definition Book_1_6_prod (A B : Type) := forall x : Bool, (if x then A else B). Definition Book_1_6_mk_pair {A B : Type} (a : A) (b : B) : Book_1_6_prod A B := fun x => match x with | true => a | false => b end. Notation "( a , b )" := (Book_1_6_mk_pair a b) (at level 0). Notation "'pr1' p" := (p true) (at level 0). Notation "'pr2' p" := (p false) (at level 0). Definition Book_1_6_eq {A B : Type} (p : Book_1_6_prod A B) : (pr1 p, pr2 p) == p := fun x => match x with | true => 1 | false => 1 end. Theorem Book_1_6_id {A B : Type} (a : A) (b : B) : Book_1_6_eq (a, b) = (fun x => 1). Proof. apply path_forall. intros x. destruct x; reflexivity. Qed. Definition Book_1_6_eta {A B : Type} (p : Book_1_6_prod A B) : (pr1 p, pr2 p) = p := path_forall (pr1 p, pr2 p) p (Book_1_6_eq p). Definition Book_1_6_ind {A B : Type} (C : Book_1_6_prod A B -> Type) (f : forall a b, C (a, b)) (p : Book_1_6_prod A B) : C p := transport C (Book_1_6_eta p) (f (pr1 p) (pr2 p)). Theorem Book_1_6_red {A B : Type} (C : Book_1_6_prod A B -> Type) f a b : Book_1_6_ind C f (a, b) = f a b. Proof. unfold Book_1_6_ind, Book_1_6_eta. simpl. rewrite Book_1_6_id, path_forall_1. reflexivity. Qed. End Book_1_6. (* ================================================== ex:pm-to-ml *) (** Exercise 1.7 *) Section Book_1_7. Definition Book_1_7_id {A : Type} : forall {x y : A} (p : x = y), (x; 1) = (y; p) :> { a : A & x = a } := paths_ind' (fun (x y : A) (p : x = y) => (x; 1) = (y; p)) (fun x => 1). Definition Book_1_7_transport {A : Type} (P : A -> Type) : forall {x y : A} (p : x = y), P x -> P y := paths_ind' (fun (x y : A) (p : x = y) => P x -> P y) (fun x => idmap). Definition Book_1_7_ind' {A : Type} (a : A) (C : forall x, (a = x) -> Type) (c : C a 1) (x : A) (p : a = x) : C x p := Book_1_7_transport (fun r => C (pr1 r) (pr2 r)) (Book_1_7_id p) c. Definition Book_1_7_eq {A : Type} (a : A) (C : forall x, (a = x) -> Type) (c : C a 1) : Book_1_7_ind' a C c a 1 = c := 1. End Book_1_7. (* ================================================== ex:nat-semiring *) (** Exercise 1.8 *) Section Book_1_8. Fixpoint Book_1_8_rec_nat (C : Type) c0 cs (n : nat) : C := match n with | O => c0 | S m => cs m (Book_1_8_rec_nat C c0 cs m) end. Definition Book_1_8_add : nat -> nat -> nat := Book_1_8_rec_nat (nat -> nat) (fun m => m) (fun n g m => (S (g m))). Definition Book_1_8_mult : nat -> nat -> nat := Book_1_8_rec_nat (nat -> nat) (fun m => 0) (fun n g m => Book_1_8_add m (g m)). (* [Book_1_8_rec_nat] gives back a function with the wrong argument order, so we flip the order of the arguments [p] and [q]. *) Definition Book_1_8_exp : nat -> nat -> nat := fun p q => (Book_1_8_rec_nat (nat -> nat) (fun m => (S 0)) (fun n g m => Book_1_8_mult m (g m))) q p. Example add_example: Book_1_8_add 32 17 = 49 := 1. Example mult_example: Book_1_8_mult 20 5 = 100 := 1. Example exp_example: Book_1_8_exp 2 10 = 1024 := 1. Definition Book_1_8_semiring := HoTT.Classes.implementations.peano_naturals.nat_semiring. End Book_1_8. (* ================================================== ex:fin *) (** Exercise 1.9 *) Section Book_1_9. Fixpoint Book_1_9_Fin (n : nat) : Type := match n with | O => Empty | S m => (Book_1_9_Fin m) + Unit end. Definition Book_1_9_fmax (n : nat) : Book_1_9_Fin (S n) := inr tt. End Book_1_9. (* ================================================== ex:ackermann *) (** Exercise 1.10 *) Fixpoint ack (n m : nat) : nat := match n with | O => S m | S p => let fix ackn (m : nat) := match m with | O => ack p 1 | S q => ack p (ackn q) end in ackn m end. Definition Book_1_10 := ack. (* ================================================== ex:neg-ldn *) (** Exercise 1.11 *) Section Book_1_11. Theorem dblneg : forall A, (~~~A) -> ~A. Proof. intros A f a; apply f. intros g; apply g. exact a. Defined. End Book_1_11. (* ================================================== ex:tautologies *) (** Exercise 1.12 *) Section Book_1_12. Theorem Book_1_12_part1 : forall A B, A -> (B -> A). Proof. intros ? ? a ?. exact a. Defined. Theorem Book_1_12_part2 : forall A, A -> ~~A. Proof. intros A a f. exact (f a). Defined. Theorem Book_1_12_part3 : forall A B, ((~A) + (~B)) -> ~(A * B). Proof. intros A B [na | nb] [a b]. - exact (na a). - exact (nb b). Qed. End Book_1_12. (* ================================================== ex:not-not-lem *) (** Exercise 1.13 *) Section Book_1_13. Lemma Book_1_13_aux: forall A B, ~(A + B) -> ~A * ~B. Proof. intros A B nAorB; split. - intro a; exact (nAorB (inl a)). - intro b; exact (nAorB (inr b)). Qed. Theorem Book_1_13 : forall P, ~~(P + ~P). Proof. intros P f. apply Book_1_13_aux in f. destruct f as [np nnp]. exact (nnp np). Qed. Theorem Book_1_13_direct : forall P, ~~(P + ~P). Proof. intros P f. apply f. apply inr. intro p. apply f. exact (inl p). Qed. End Book_1_13. (* ================================================== ex:without-K *) (** Exercise 1.14 *) (** There is no adequate type family C : Pi_{x, y, p} U such that C(x, x, p) is p = refl x definitionally. *) (* ================================================== ex:subtFromPathInd *) (** Exercise 1.15 *) Definition Book_1_15_paths_rec {A : Type} {C : A -> Type} {x y : A} (p : x = y) : C x -> C y := match p with 1 => idmap end. (** This is exactly the definition of [transport] from Basics.Overture. *) (* ================================================== ex:add-nat-commutative *) (** Exercise 1.16 *) Definition Book_1_16 := HoTT.Spaces.Nat.Core.nat_add_comm. (* ================================================== ex:basics:concat *) (** Exercise 2.1 *) (* Book_2_1_concatenation1 is equivalent to the proof given in the text *) Definition Book_2_1_concatenation1 : forall {A : Type} {x y z : A}, x = y -> y = z -> x = z. Proof. intros A x y z x_eq_y y_eq_z. induction x_eq_y. induction y_eq_z. reflexivity. Defined. Definition Book_2_1_concatenation2 : forall {A : Type} {x y z : A}, x = y -> y = z -> x = z. Proof. intros A x y z x_eq_y y_eq_z. induction x_eq_y. exact y_eq_z. Defined. Definition Book_2_1_concatenation3 : forall {A : Type} {x y z : A}, x = y -> y = z -> x = z. Proof. intros A x y z x_eq_y y_eq_z. induction y_eq_z. exact x_eq_y. Defined. Local Notation "p *1 q" := (Book_2_1_concatenation1 p q) (at level 10). Local Notation "p *2 q" := (Book_2_1_concatenation2 p q) (at level 10). Local Notation "p *3 q" := (Book_2_1_concatenation3 p q) (at level 10). Section Book_2_1_Proofs_Are_Equal. Context {A : Type} {x y z : A}. Variable (p : x = y) (q : y = z). Definition Book_2_1_concatenation1_eq_Book_2_1_concatenation2 : p *1 q = p *2 q. Proof. induction p, q. reflexivity. Defined. Definition Book_2_1_concatenation2_eq_Book_2_1_concatenation3 : p *2 q = p *3 q. Proof. induction p, q. reflexivity. Defined. Definition Book_2_1_concatenation1_eq_Book_2_1_concatenation3 : p *1 q = p *3 q. Proof. induction p, q. reflexivity. Defined. End Book_2_1_Proofs_Are_Equal. (* ================================================== ex:eq-proofs-commute *) (** Exercise 2.2 *) Definition Book_2_2 : forall {A : Type} {x y z : A} (p : x = y) (q : y = z), (Book_2_1_concatenation1_eq_Book_2_1_concatenation2 p q) *1 (Book_2_1_concatenation2_eq_Book_2_1_concatenation3 p q) = (Book_2_1_concatenation1_eq_Book_2_1_concatenation3 p q). Proof. induction p, q. reflexivity. Defined. (* ================================================== ex:fourth-concat *) (** Exercise 2.3 *) (* Since we have x_eq_y : x = y we can transport y_eq_z : y = z along x_eq_y⁻¹ : y = x in the type family λw.(w = z) to obtain a term of type x = z. *) Definition Book_2_1_concatenation4 {A : Type} {x y z : A} : x = y -> y = z -> x = z := fun x_eq_y y_eq_z => transport (fun w => w = z) (inverse x_eq_y) y_eq_z. Local Notation "p *4 q" := (Book_2_1_concatenation4 p q) (at level 10). Definition Book_2_1_concatenation1_eq_Book_2_1_concatenation4 : forall {A : Type} {x y z : A} (p : x = y) (q : y = z), (p *1 q = p *4 q). Proof. induction p, q. reflexivity. Defined. (* ================================================== ex:npaths *) (** Exercise 2.4 *) Definition Book_2_4_npath : nat -> Type -> Type := nat_ind (fun (n : nat) => Type -> Type) (* 0-dimensional paths are elements *) (fun A => A) (* (n+1)-dimensional paths are paths between n-dimimensional paths *) (fun n f A => (exists a1 a2 : (f A), a1 = a2)). (* This is the intuition behind definition of nboundary: As we've defined them, every (n+1)-path is a path between two n-paths. *) Lemma npath_as_sig : forall {n : nat} {A : Type}, (Book_2_4_npath (S n) A) = (exists (p1 p2 : Book_2_4_npath n A), p1 = p2). Proof. reflexivity. Defined. (* It can be helpful to take a look at what this definition does. Try uncommenting the following lines: *) (* Context {A : Type}. Eval compute in (Book_2_4_npath 0 A). (* = A : Type *) Eval compute in (Book_2_4_npath 1 A). (* = {a1 : A & {a2 : A & a1 = a2}} : Type *) Eval compute in (Book_2_4_npath 2 A). (* and so on... *) *) (* Given an (n+1)-path, we simply project to a pair of n-paths. *) Definition Book_2_4_nboundary : forall {n : nat} {A : Type}, Book_2_4_npath (S n) A -> (Book_2_4_npath n A * Book_2_4_npath n A) := fun {n} {A} p => (pr1 p, pr1 (pr2 p)). (* ================================================== ex:ap-to-apd-equiv-apd-to-ap *) (** Exercise 2.5 *) (* Note that "@" is notation for concatentation and ^ is for inversion *) Definition Book_eq_2_3_6 {A B : Type} {x y : A} (p : x = y) (f : A -> B) : (f x = f y) -> (transport (fun _ => B) p (f x) = f y) := fun fx_eq_fy => (HoTT.Basics.PathGroupoids.transport_const p (f x)) @ fx_eq_fy. Definition Book_eq_2_3_7 {A B : Type} {x y : A} (p : x = y) (f : A -> B) : (transport (fun _ => B) p (f x) = f y) -> f x = f y := fun fx_eq_fy => (HoTT.Basics.PathGroupoids.transport_const p (f x))^ @ fx_eq_fy. (* By induction on p, it suffices to assume that x ≡ y and p ≡ refl, so the above equations concatenate identity paths, which are units under concatenation. [isequiv_adjointify] is one way to prove two functions form an equivalence, specifically one proves that they are (category-theoretic) sections of one another, that is, each is a right inverse for the other. *) Definition Equivalence_Book_eq_2_3_6_and_Book_eq_2_3_6 {A B : Type} {x y : A} (p : x = y) (f : A -> B) : IsEquiv (Book_eq_2_3_6 p f). Proof. apply (isequiv_adjointify (Book_eq_2_3_6 p f) (Book_eq_2_3_7 p f)); unfold Book_eq_2_3_6, Book_eq_2_3_7, transport_const; induction p; intros y; do 2 (rewrite concat_1p); reflexivity. Defined. (* ================================================== ex:equiv-concat *) (** Exercise 2.6 *) (* This exercise is solved in the library as HoTT.Types.Paths.isequiv_concat_l *) Definition concat_left {A : Type} {x y : A} (z : A) (p : x = y) : (y = z) -> (x = z) := fun q => p @ q. Definition concat_right {A : Type} {x y : A} (z : A) (p : x = y) : (x = z) -> (y = z) := fun q => (inverse p) @ q. (* Again, by induction on p, it suffices to assume that x ≡ y and p ≡ refl, so the above equations concatenate identity paths, which are units under concatenation. *) Definition Book_2_6 {A : Type} {x y z : A} (p : x = y) : IsEquiv (concat_left z p). Proof. apply (isequiv_adjointify (concat_left z p) (concat_right z p)); induction p; unfold concat_right, concat_left; intros y; do 2 (rewrite concat_1p); reflexivity. Defined. (* ================================================== ex:ap-sigma *) (** Exercise 2.7 *) (* Already solved as ap_functor_sigma; there is a copy here for completeness *) Section Book_2_7. Definition Book_2_7 {A B : Type} {P : A -> Type} {Q : B -> Type} (f : A -> B) (g : forall a, P a -> Q (f a)) (u v : sig P) (p : u.1 = v.1) (q : p # u.2 = v.2) : ap (functor_sigma f g) (path_sigma P u v p q) = path_sigma Q (functor_sigma f g u) (functor_sigma f g v) (ap f p) ((transport_compose Q f p (g u.1 u.2))^ @ (@ap_transport _ P (fun x => Q (f x)) _ _ p g u.2)^ @ ap (g v.1) q). Proof. destruct u as [u1 u2]; destruct v as [v1 v2]; simpl in p, q. destruct p; simpl in q. destruct q. reflexivity. Defined. End Book_2_7. (* ================================================== ex:ap-coprod *) (** Exercise 2.8 *) Definition Book_2_8 := @HoTT.Types.Sum.ap_functor_sum. (* ================================================== ex:coprod-ump *) (** Exercise 2.9 *) (* This exercise is solved in the library as HoTT.Types.Sum.equiv_sum_ind *) (* To extract a function on either summand, compose with the injections *) Definition coprod_ump1 {A B X} : (A + B -> X) -> (A -> X) * (B -> X) := fun f => (f o inl, f o inr). (* To create a function on the direct sum from functions on the summands, work by cases *) Definition coprod_ump2 {A B X} : (A -> X) * (B -> X) -> (A + B -> X) := prod_ind (fun _ => A + B -> X) (fun f g => sum_ind (fun _ => X) f g). Definition Book_2_9 {A B X} `{Funext} : (A -> X) * (B -> X) <~> (A + B -> X). apply (equiv_adjointify coprod_ump2 coprod_ump1). Proof. - intros f. apply path_forall. intros [a | b]; reflexivity. - intros [f g]. reflexivity. Defined. (* ================================================== ex:sigma-assoc *) (** Exercise 2.10 *) (* This exercise is solved in the library as HoTT.Types.Sigma.equiv_sigma_assoc *) Section TwoTen. Context `{A : Type} {B : A -> Type} {C : (exists a : A, B a) -> Type}. Local Definition f210 : (exists a : A, (exists b : B a, (C (a; b)))) -> (exists (p : exists a : A, B a), (C p)) := fun pairpair => match pairpair with (a; pp) => match pp with (b; c) => ((a; b); c) end end. Local Definition g210 : (exists (p : exists a : A, B a), (C p)) -> (exists a : A, (exists b : B a, (C (a; b)))). Proof. intros pairpair. induction pairpair as [pair c]. induction pair as [a b]. exact (a; (b; c)). Defined. Definition Book_2_10 : (exists a : A, (exists b : B a, (C (a; b)))) <~> (exists (p : exists a : A, B a), (C p)). Proof. apply (equiv_adjointify f210 g210); compute; reflexivity. Defined. End TwoTen. (* ================================================== ex:pullback *) (** Exercise 2.11 *) (** The definition of commutative squares in HoTT.Limits.Pullback is slightly different, using a homotopy between the composites instead of a path. *) Definition Book_2_11 `{H : Funext} {X A B C} (f : A -> C) (g : B -> C) : (X -> HoTT.Limits.Pullback.Pullback f g) <~> HoTT.Limits.Pullback.Pullback (fun h : X -> A => f o h) (fun k : X -> B => g o k) := HoTT.Limits.Pullback.equiv_ispullback_commsq f g oE (HoTT.Limits.Pullback.equiv_pullback_corec f g)^-1. (* ================================================== ex:pullback-pasting *) (** Exercise 2.12 *) Definition Book_2_12_i := @HoTT.Limits.Pullback.ispullback_pasting_left. Definition Book_2_12_ii := @HoTT.Limits.Pullback.ispullback_pasting_outer. (* ================================================== ex:eqvboolbool *) (** Exercise 2.13 *) Definition Book_2_13 := @HoTT.Types.Bool.equiv_bool_aut_bool. (* ================================================== ex:equality-reflection *) (** Exercise 2.14 *) (** Assuming the equality reflection rule, given any [q : x = y], [x] and [y] are definitionally equal, so [q] and [refl_x] have the same type [x = x]. We can form the type [forall x y, forall q, q = refl_x]. A path induction produces an element [r], with [r x x p : p = refl_x], which is also definitional by the equality reflection rule. *) (* ================================================== ex:strengthen-transport-is-ap *) (** Exercise 2.15 *) Definition Book_2_15 {A} (B : A -> Type) {x y : A} (p : x = y) : transport B p = HoTT.Types.Universe.equiv_path _ _ (ap B p) := match p with 1 => 1 end. (* ================================================== ex:strong-from-weak-funext *) (** Exercise 2.16 *) Definition Book_2_16 := @HoTT.Metatheory.FunextVarieties.NaiveFunext_implies_Funext. (* ================================================== ex:equiv-functor-types *) (** Exercise 2.17 *) (* ================================================== ex:dep-htpy-natural *) (** Exercise 2.18 *) Definition Book_2_18 := @HoTT.Basics.PathGroupoids.apD_natural. (* ================================================== ex:equiv-functor-set *) (** Exercise 3.1 *) Definition Book_3_1_solution_1 {A B} (f : A <~> B) (H : IsHSet A) := @HoTT.Basics.Trunc.istrunc_equiv_istrunc A B f 0 H. (** Alternative solutions: [Book_3_1_solution_2] using UA, and [Book_3_1_solution_3] using two easy lemmas that may be of independent interest *) Lemma Book_3_1_solution_2 `{Univalence} {A B} : A <~> B -> IsHSet A -> IsHSet B. Proof. intro e. rewrite (path_universe_uncurried e). exact idmap. Defined. Lemma retr_f_g_path_in_B {A B} (f : A -> B) (g : B -> A) (alpha : f o g == idmap) (x y : B) (p : x = y) : p = (alpha x)^ @ (ap f (ap g p)) @ (alpha y). Proof. destruct p. simpl. rewrite concat_p1. rewrite concat_Vp. exact 1. Defined. Lemma retr_f_g_isHSet_A_so_B {A B} (f : A -> B) (g : B -> A) : f o g == idmap -> IsHSet A -> IsHSet B. Proof. intros retr_f_g isHSet_A. srapply hset_axiomK. unfold axiomK. intros x p. assert (ap g p = 1) as g_p_is_1. - apply (axiomK_hset isHSet_A). - assert (1 = (retr_f_g x) ^ @ (ap f (ap g p)) @ (retr_f_g x)) as rhs_is_1. + rewrite g_p_is_1. simpl. rewrite concat_p1. rewrite concat_Vp. exact 1. + rewrite (rhs_is_1). apply (retr_f_g_path_in_B f g retr_f_g). Defined. Lemma Book_3_1_solution_3 {A B} : A <~> B -> IsHSet A -> IsHSet B. Proof. intros equivalent_A_B isHSet_A. elim equivalent_A_B; intros f isequiv_f. elim isequiv_f; intros g retr_f_g sect_f_g coh. apply (retr_f_g_isHSet_A_so_B f g); assumption. Defined. (* ================================================== ex:isset-coprod *) (** Exercise 3.2 *) Definition Book_3_2_solution_1 := @HoTT.Types.Sum.ishset_sum. (** Alternative solution for replaying *) Lemma Book_3_2_solution_2 (A B : Type) : IsHSet A -> IsHSet B -> IsHSet (A+B). Proof. intros isHSet_A isHSet_B. srapply hset_axiomK. unfold axiomK. intros x p. destruct x. - rewrite (inverse (eisretr_path_sum p)). rewrite (axiomK_hset isHSet_A a (path_sum_inv p)). simpl; exact idpath. - rewrite (inverse (eisretr_path_sum p)). rewrite (axiomK_hset isHSet_B b (path_sum_inv p)). simpl; exact idpath. Defined. (* ================================================== ex:isset-sigma *) (** Exercise 3.3 *) Definition Book_3_3_solution_1 (A : Type) (B : A -> Type) := @HoTT.Types.Sigma.istrunc_sigma A B 0. (** This exercise is hard because 2-paths over Sigma types are not treated in the first three chapters of the book. Consult theories/Types/Sigma.v *) Lemma Book_3_3_solution_2 (A : Type) (B : A -> Type) : IsHSet A -> (forall x:A, IsHSet (B x)) -> IsHSet { x:A | B x}. Proof. intros isHSet_A allBx_HSet. srapply hset_axiomK. intros x xx. pose (path_path_sigma B x x xx 1) as useful. apply (useful (axiomK_hset _ _ _) (hset_path2 _ _)). Defined. (* ================================================== ex:prop-endocontr *) (** Exercise 3.4 *) Lemma Book_3_4_solution_1 `{Funext} (A : Type) : IsHProp A <-> Contr (A -> A). Proof. split. - intro isHProp_A. apply (Build_Contr _ idmap). apply path_ishprop. (* automagically, from IsHProp A *) - intro contr_AA. apply hprop_allpath; intros a1 a2. exact (ap10 (path_contr (fun x:A => a1) (fun x:A => a2)) a1). Defined. (* ================================================== ex:prop-inhabcontr *) (** Exercise 3.5 *) Definition Book_3_5_solution_1 := @HoTT.Universes.HProp.equiv_hprop_inhabited_contr. (* ================================================== ex:lem-mereprop *) (** Exercise 3.6 *) Lemma Book_3_6_solution_1 `{Funext} (A : Type) : IsHProp A -> IsHProp (A + ~A). Proof. intro isHProp_A. apply hprop_allpath. intros x y. destruct x as [a1|n1]; destruct y as [a2|n2]; apply path_sum; try apply path_ishprop. - exact (n2 a1). - exact (n1 a2). Defined. (* ================================================== ex:disjoint-or *) (** Exercise 3.7 *) Lemma Book_3_7_solution_1 (A B: Type) : IsHProp A -> IsHProp B -> ~(A*B) -> IsHProp (A+B). Proof. intros isHProp_A isProp_B nab. apply hprop_allpath. intros x y. destruct x as [a1|b1]; destruct y as [a2|b2]; apply path_sum; try apply path_ishprop. - exact (nab (a1,b2)). - exact (nab (a2,b1)). Defined. (* ================================================== ex:brck-qinv *) (** Exercise 3.8 *) (* ================================================== ex:lem-impl-prop-equiv-bool *) (** Exercise 3.9 *) Definition LEM := forall (A : Type), IsHProp A -> A + ~A. Definition LEM_hProp_Bool (lem : LEM) (hprop : HProp) : Bool := match (lem hprop _) with inl _ => true | inr _ => false end. Lemma Book_3_9_solution_1 `{Univalence} : LEM -> HProp <~> Bool. Proof. intro lem. apply (equiv_adjointify (LEM_hProp_Bool lem) is_true). - intros []; simpl. + unfold LEM_hProp_Bool. elim (lem Unit_hp _). * exact (fun _ => 1). * intro nUnit. elim (nUnit tt). + unfold LEM_hProp_Bool. elim (lem False_hp _). * intro fals. elim fals. * exact (fun _ => 1). - intro hprop. unfold LEM_hProp_Bool. elim (lem hprop _). + intro p. apply path_hprop; simpl. (* path_prop is silent *) exact ((if_hprop_then_equiv_Unit hprop p)^-1)%equiv. + intro np. apply path_hprop; simpl. (* path_prop is silent *) exact ((if_not_hprop_then_equiv_Empty hprop np)^-1)%equiv. Defined. (* ================================================== ex:lem-impred *) (** Exercise 3.10 *) (* ================================================== ex:not-brck-A-impl-A *) (** Exercise 3.11 *) (** This theorem extracts the main idea leading to the contradiction constructed in the proof of Theorem 3.2.2, that univalence implies that all functions are natural with respect to equivalences. The terms are complicated, but it pretty much follows the proof in the book, step by step. *) Lemma univalence_func_natural_equiv `{Univalence} : forall (C : Type -> Type) (all_contr : forall A, Contr (C A -> C A)) (g : forall A, C A -> A) {A : Type} (e : A <~> A), e o (g A) = (g A). Proof. intros C all_contr g A e. apply path_forall. intros x. pose (p := path_universe_uncurried e). (* The propositional computation rule for univalence of section 2.10 *) refine (concat (happly (transport_idmap_path_universe_uncurried e)^ (g A x)) _). (** To obtain the situation of 2.9.4, we rewrite x using << x = transport (fun A : Type => C A) p^ x >> This equality holds because [(C A) -> (C A)] is contractible, so << transport (fun A : Type => C A) p^ = idmap >> In both Theorem 3.2.2 and the following result, the hypothesis [Contr ((C A) -> (C A))] will follow from the contractibility of [(C A)]. *) refine (concat (ap _ (ap _ (happly (@path_contr _ (all_contr A) idmap (transport _ p^)) x))) _). (* Equation 2.9.4 is called transport_arrow in the library. *) refine (concat (@transport_arrow _ (fun A => C A) idmap _ _ p (g A) x)^ _). exact (happly (apD g p) x). Defined. (** For this proof, we closely follow the proof of Theorem 3.2.2 from the text, replacing ¬¬A → A by ∥A∥ → A. *) Lemma Book_3_11 `{Univalence} : ~ (forall A, Trunc (-1) A -> A). Proof. (* The proof is by contradiction. We'll assume we have such a function, and obtain an element of 0. *) intros g. assert (end_contr : forall A, Contr (Trunc (-1) A -> Trunc (-1) A)). { intros A. apply Book_3_4_solution_1. apply istrunc_truncation. } (** There are no fixpoints of the fix-point free autoequivalence of 2 (called negb). We will derive a contradiction by showing there must be such a fixpoint by naturality of g. We parametrize over b to emphasize that this proof depends only on the fact that Bool is inhabited, not on any specific value (we use "true" below). *) pose (contr b := (not_fixed_negb (g Bool b)) (happly (univalence_func_natural_equiv _ end_contr g equiv_negb) b)). contradiction (contr (tr true)). Defined. (* ================================================== ex:lem-impl-simple-ac *) (** Exercise 3.12 *) (* ================================================== ex:naive-lem-impl-ac *) (** Exercise 3.13 *) Section Book_3_13. Definition naive_LEM_impl_DN_elim (A : Type) (LEM : A + ~A) : ~~A -> A := fun nna => match LEM with | inl a => a | inr na => match nna na with end end. Lemma naive_LEM_implies_AC : (forall A : Type, A + ~A) -> forall X A P, (forall x : X, ~~{ a : A x | P x a }) -> { g : forall x, A x | forall x, P x (g x) }. Proof. intros LEM X A P H. pose (fun x => @naive_LEM_impl_DN_elim _ (LEM _) (H x)) as H'. exists (fun x => (H' x).1). exact (fun x => (H' x).2). Defined. Lemma Book_3_13 `{Funext} : (forall A : Type, A + ~A) -> forall X A P, IsHSet X -> (forall x : X, IsHSet (A x)) -> (forall x (a : A x), IsHProp (P x a)) -> (forall x, merely { a : A x & P x a }) -> merely { g : forall x, A x & forall x, P x (g x) }. Proof. intros LEM X A P HX HA HP H0. apply tr. apply (naive_LEM_implies_AC LEM). intro x. specialize (H0 x). revert H0. apply Trunc_rec. exact (fun x nx => nx x). Defined. End Book_3_13. (* ================================================== ex:lem-brck *) (** Exercise 3.14 *) Section Book_3_14. Context `{Funext}. Hypothesis LEM : forall A : Type, IsHProp A -> A + ~A. Definition Book_3_14 : forall A (P : ~~A -> Type), (forall a, P (fun na => na a)) -> (forall x y (z : P x) (w : P y), transport P (path_ishprop x y) z = w) -> forall x, P x. Proof. intros A P base p nna. assert (forall x, IsHProp (P x)). - intro x. apply hprop_allpath. intros x' y'. etransitivity; [ symmetry; apply (p x x y' x') | ]. (* Without this it somehow proves [H'] using the wrong universe for hprop_Empty and fails when we do [Defined]. See Coq #4862. *) set (path := path_ishprop x x). assert (H' : idpath = path) by apply path_ishprop. destruct H'. reflexivity. - destruct (LEM (P nna) _) as [pnna|npnna]; trivial. refine (match _ : Empty with end). apply nna. intro a. apply npnna. exact (transport P (path_ishprop _ _) (base a)). Defined. Lemma Book_3_14_equiv A : merely A <~> ~~A. Proof. apply equiv_iff_hprop. - apply Trunc_rec. exact (fun a na => na a). - intro nna. apply (@Book_3_14 A (fun _ => merely A)). * exact tr. * intros x y z w. apply path_ishprop. * exact nna. Defined. End Book_3_14. (* ================================================== ex:impred-brck *) (** Exercise 3.15 *) (* ================================================== ex:lem-impl-dn-commutes *) (** Exercise 3.16 *) (* ================================================== ex:prop-trunc-ind *) (** Exercise 3.17 *) (* ================================================== ex:lem-ldn *) (** Exercise 3.18 *) (* ================================================== ex:decidable-choice *) (** Exercise 3.19 *) Definition Book_3_19 := @HoTT.BoundedSearch.minimal_n. (* ================================================== ex:omit-contr2 *) (** Exercise 3.20 *) (* ================================================== ex:isprop-equiv-equiv-bracket *) (** Exercise 3.21 *) (* ================================================== ex:finite-choice *) (** Exercise 3.22 *) (* ================================================== ex:decidable-choice-strong *) (** Exercise 3.23 *) (* ================================================== ex:n-set *) (** Exercise 3.24 *) (* ================================================== ex:two-sided-adjoint-equivalences *) (** Exercise 4.1 *) (* ================================================== ex:symmetric-equiv *) (** Exercise 4.2 *) (* ================================================== ex:qinv-autohtpy-no-univalence *) (** Exercise 4.3 *) (* ================================================== ex:unstable-octahedron *) (** Exercise 4.4 *) (* ================================================== ex:2-out-of-6 *) (** Exercise 4.5 *) Section Book_4_5. Section parts. Variables A B C D : Type. Variable f : A -> B. Variable g : B -> C. Variable h : C -> D. Context `{IsEquiv _ _ (g o f), IsEquiv _ _ (h o g)}. Local Instance Book_4_5_g : IsEquiv g. Proof. apply isequiv_biinv. split. - exists ((h o g)^-1 o h). exact (eissect (h o g)). - exists (f o (g o f)^-1). exact (eisretr (g o f)). Defined. Local Instance Book_4_5_f : IsEquiv f. Proof. apply (isequiv_homotopic (g^-1 o (g o f))); try exact _. intro; apply (eissect g). Defined. Local Instance Book_4_5_h : IsEquiv h. Proof. apply (isequiv_homotopic ((h o g) o g^-1)); try exact _. intro; apply (ap h); apply (eisretr g). Defined. Definition Book_4_5_hgf : IsEquiv (h o g o f). Proof. typeclasses eauto. Defined. End parts. (*Lemma Book_4_5 A B f `{IsEquiv A B f} (a a' : A) : IsEquiv (@ap _ _ f a a'). Proof. pose (@ap _ _ (f^-1) (f a) (f a')) as f'. pose (fun p : f^-1 (f a) = _ => p @ (@eissect _ _ f _ a')) as g'. pose (fun p : _ = a' => (@eissect _ _ f _ a)^ @ p) as h'. pose (g' o f'). pose (h' o g'). admit. Qed.*) End Book_4_5. (* ================================================== ex:qinv-univalence *) (** Exercise 4.6 *) Section Book_4_6_i. Definition is_qinv {A B : Type} (f : A -> B) := { g : B -> A & (f o g == idmap) * (g o f == idmap) }. Definition qinv (A B : Type) := { f : A -> B & is_qinv f }. Definition qinv_id A : qinv A A := (fun x => x; (fun x => x ; (fun x => 1, fun x => 1))). Definition qinv_path A B : (A = B) -> qinv A B := fun p => match p with 1 => qinv_id _ end. Definition QInv_Univalence_type := forall (A B : Type@{i}), is_qinv (qinv_path A B). Definition isequiv_qinv {A B} {f : A -> B} : is_qinv f -> IsEquiv f. Proof. intros [g [s r]]. exact (isequiv_adjointify f g s r). Defined. Definition equiv_qinv_path (qua: QInv_Univalence_type) (A B : Type) : (A = B) <~> qinv A B := Build_Equiv _ _ (qinv_path A B) (isequiv_qinv (qua A B)). Definition qinv_isequiv {A B} (f : A -> B) `{IsEquiv _ _ f} : qinv A B := (f ; (f^-1 ; (eisretr f , eissect f))). Context `{qua : QInv_Univalence_type}. Theorem qinv_univalence_isequiv_postcompose {A B : Type} {w : A -> B} `{H0 : IsEquiv A B w} C : IsEquiv (fun (g:C->A) => w o g). Proof. unfold QInv_Univalence_type in *. pose (w' := qinv_isequiv w). refine (isequiv_adjointify (fun (g:C->A) => w o g) (fun (g:C->B) => w^-1 o g) _ _); intros g; first [ change ((fun x => w'.1 ( w'.2.1 (g x))) = g) | change ((fun x => w'.2.1 ( w'.1 (g x))) = g) ]; clearbody w'; clear H0 w; rewrite <- (@eisretr _ _ (@qinv_path A B) (isequiv_qinv (qua A B)) w'); generalize ((@equiv_inv _ _ (qinv_path A B) (isequiv_qinv (qua A B))) w'); intro p; clear w'; destruct p; reflexivity. Defined. (** Now the rest is basically copied from UnivalenceImpliesFunext, with name changes so as to use the current assumption of qinv-univalence rather than a global assumption of ordinary univalence. *) Local Instance isequiv_src_compose A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) (fun g => (fst o pr1) o g). Proof. rapply @qinv_univalence_isequiv_postcompose. refine (isequiv_adjointify (fst o pr1) (fun x => ((x, x); idpath)) (fun _ => idpath) _); let p := fresh in intros [[? ?] p]; simpl in p; destruct p; reflexivity. Defined. Local Instance isequiv_tgt_compose A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) (fun g => (snd o pr1) o g). Proof. rapply @qinv_univalence_isequiv_postcompose. refine (isequiv_adjointify (snd o pr1) (fun x => ((x, x); idpath)) (fun _ => idpath) _); let p := fresh in intros [[? ?] p]; simpl in p; destruct p; reflexivity. Defined. Theorem QInv_Univalence_implies_FunextNondep (A B : Type) : forall f g : A -> B, f == g -> f = g. Proof. intros f g p. pose (d := fun x : A => exist (fun xy => fst xy = snd xy) (f x, f x) (idpath (f x))). pose (e := fun x : A => exist (fun xy => fst xy = snd xy) (f x, g x) (p x)). change f with ((snd o pr1) o d). change g with ((snd o pr1) o e). rapply (ap (fun g => snd o pr1 o g)). pose (fun A B x y=> @equiv_inv _ _ _ (@isequiv_ap _ _ _ (@isequiv_src_compose A B) x y)) as H'. apply H'. reflexivity. Defined. Definition QInv_Univalence_implies_Funext_type : Funext_type := NaiveNondepFunext_implies_Funext QInv_Univalence_implies_FunextNondep. End Book_4_6_i. Section EquivFunctorFunextType. (* We need a version of [equiv_functor_forall_id] that takes a [Funext_type] rather than a global axiom [Funext]. *) Context (fa : Funext_type). Definition ft_path_forall {A : Type} {P : A -> Type} (f g : forall x : A, P x) : f == g -> f = g := @equiv_inv _ _ (@apD10 A P f g) (fa _ _ _ _). Local Instance ft_isequiv_functor_forall {A B:Type} `{P : A -> Type} `{Q : B -> Type} {f : B -> A} {g : forall b:B, P (f b) -> Q b} `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} : IsEquiv (functor_forall f g) | 1000. Proof. simple refine (isequiv_adjointify (functor_forall f g) (functor_forall (f^-1) (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y )) _ _); intros h. - abstract ( apply ft_path_forall; intros b; unfold functor_forall; rewrite eisadj; rewrite <- transport_compose; rewrite ap_transport; rewrite eisretr; apply apD ). - abstract ( apply ft_path_forall; intros a; unfold functor_forall; rewrite eissect; apply apD ). Defined. Definition ft_equiv_functor_forall {A B:Type} `{P : A -> Type} `{Q : B -> Type} (f : B -> A) `{IsEquiv B A f} (g : forall b:B, P (f b) -> Q b) `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} : (forall a, P a) <~> (forall b, Q b) := Build_Equiv _ _ (functor_forall f g) _. Definition ft_equiv_functor_forall_id {A:Type} `{P : A -> Type} `{Q : A -> Type} (g : forall a, P a <~> Q a) : (forall a, P a) <~> (forall a, Q a) := ft_equiv_functor_forall (equiv_idmap A) g. End EquivFunctorFunextType. (** Using the Kraus-Sattler space of loops rather than the version in the book, since it is simpler and avoids use of propositional truncation. *) Definition Book_4_6_ii (qua1 qua2 : QInv_Univalence_type) (* Two, since we need them at different universe levels. *) : ~ IsHProp (forall A : { X : Type & X = X }, A = A). Proof. pose (fa := @QInv_Univalence_implies_Funext_type qua2). intros H. pose (K := forall (X:Type) (p:X=X), { q : X=X & p @ q = q @ p }). assert (e : K <~> forall A : { X : Type & X = X }, A = A). { unfold K. refine (equiv_sig_ind _ oE _). refine (ft_equiv_functor_forall_id fa _); intros X. refine (ft_equiv_functor_forall_id fa _); intros p. refine (equiv_path_sigma _ _ _ oE _); cbn. refine (equiv_functor_sigma_id _); intros q. refine ((equiv_concat_l (transport_paths_lr q p)^ p)^-1 oE _). refine ((equiv_concat_l (concat_p_pp _ _ _) _)^-1 oE _). apply equiv_moveR_Vp. } assert (HK := @istrunc_equiv_istrunc _ _ e^-1 (-1)). assert (u : forall (X:Type) (p:X=X), p @ 1 = 1 @ p). { intros X p; rewrite concat_p1, concat_1p; reflexivity. } pose (alpha := (fun X p => (idpath X ; u X p)) : K). pose (beta := (fun X p => (p ; 1)) : K). pose (isequiv_qinv (qua1 Bool Bool)). assert (r := pr1_path (apD10 (apD10 (path_ishprop alpha beta) Bool) ((qinv_path Bool Bool)^-1 (qinv_isequiv equiv_negb)))). unfold alpha, beta in r; clear alpha beta. apply (ap (qinv_path Bool Bool)) in r. rewrite eisretr in r. apply pr1_path in r; cbn in r. exact (true_ne_false (ap10 r true)). Defined. (** Assuming qinv-univalence, every quasi-equivalence automatically satisfies one of the adjoint laws. *) Definition allqinv_coherent (qua : QInv_Univalence_type) (A B : Type) (f : qinv A B) : (fun x => ap f.2.1 (fst f.2.2 x)) = (fun x => snd f.2.2 (f.2.1 x)). Proof. (* Every quasi-equivalence is the image of a path, and can therefore be assumed to be the identity equivalence, for which the claim holds immediately. *) revert f. equiv_intro (equiv_qinv_path qua A B) p. destruct p; cbn; reflexivity. Defined. (** Qinv-univalence is inconsistent. *) Definition Book_4_6_iii (qua1 qua2 : QInv_Univalence_type) : Empty. Proof. apply (Book_4_6_ii qua1 qua2). nrapply istrunc_succ. apply (Build_Contr _ (fun A => 1)); intros u. exact (allqinv_coherent qua2 _ _ (idmap; (idmap; (fun A => 1, u)))). Defined. (* ================================================== ex:embedding-cancellable *) (** Exercise 4.7 *) (* ================================================== ex:cancellable-from-bool *) (** Exercise 4.8 *) (* ================================================== ex:funext-from-nondep *) (** Exercise 4.9 *) (* ================================================== ex:ind-lst *) (** Exercise 5.1 *) (* ================================================== ex:same-recurrence-not-defeq *) (** Exercise 5.2 *) Section Book_5_2. (** Here is one example of functions which are propositionally equal but not judgmentally equal. They satisfy the same reucrrence propositionally. *) Let ez : Bool := true. Let es : nat -> Bool -> Bool := fun _ => idmap. Definition Book_5_2_i : nat -> Bool := nat_ind (fun _ => Bool) ez es. Definition Book_5_2_ii : nat -> Bool := fun _ => true. Fail Definition Book_5_2_not_defn_eq : Book_5_2_i = Book_5_2_ii := idpath. Lemma Book_5_2_i_prop_eq : forall n, Book_5_2_i n = Book_5_2_ii n. Proof. induction n; simpl; trivial. Defined. End Book_5_2. Section Book_5_2'. Local Open Scope nat_scope. (** Here's another example where two functions are not (currently) definitionally equal, but satisfy the same reucrrence judgmentally. This example is a bit less robust; it fails in CoqMT. *) Let ez : nat := 1. Let es : nat -> nat -> nat := fun _ => S. Definition Book_5_2'_i : nat -> nat := fun n => n + 1. Definition Book_5_2'_ii : nat -> nat := fun n => 1 + n. Fail Definition Book_5_2'_not_defn_eq : Book_5_2'_i = Book_5_2'_ii := idpath. Definition Book_5_2'_i_eq_ez : Book_5_2'_i 0 = ez := idpath. Definition Book_5_2'_ii_eq_ez : Book_5_2'_ii 0 = ez := idpath. Definition Book_5_2'_i_eq_es n : Book_5_2'_i (S n) = es n (Book_5_2'_i n) := idpath. Definition Book_5_2'_ii_eq_es n : Book_5_2'_ii (S n) = es n (Book_5_2'_ii n) := idpath. End Book_5_2'. (* ================================================== ex:one-function-two-recurrences *) (** Exercise 5.3 *) Section Book_5_3. Let ez : Bool := true. Let es : nat -> Bool -> Bool := fun _ => idmap. Let ez' : Bool := true. Let es' : nat -> Bool -> Bool := fun _ _ => true. Definition Book_5_3 : nat -> Bool := fun _ => true. Definition Book_5_3_satisfies_ez : Book_5_3 0 = ez := idpath. Definition Book_5_3_satisfies_ez' : Book_5_3 0 = ez' := idpath. Definition Book_5_3_satisfies_es n : Book_5_3 (S n) = es n (Book_5_3 n) := idpath. Definition Book_5_3_satisfies_es' n : Book_5_3 (S n) = es' n (Book_5_3 n) := idpath. Definition Book_5_3_es_ne_es' : ~(es = es') := fun H => false_ne_true (ap10 (ap10 H 0) false). End Book_5_3. (* ================================================== ex:bool *) (** Exercise 5.4 *) Definition Book_5_4 := @HoTT.Types.Bool.equiv_bool_forall_prod. (* ================================================== ex:ind-nat-not-equiv *) (** Exercise 5.5 *) Section Book_5_5. Let ind_nat (P : nat -> Type) := fun x => @nat_ind P (fst x) (snd x). Lemma Book_5_5 `{fs : Funext} : ~forall P : nat -> Type, IsEquiv (@ind_nat P). Proof. intro H. specialize (H (fun _ => Bool)). pose proof (eissect (@ind_nat (fun _ => Bool)) (true, (fun _ _ => true))) as H1. pose proof (eissect (@ind_nat (fun _ => Bool)) (true, (fun _ => idmap))) as H2. cut (ind_nat (fun _ : nat => Bool) (true, fun (_ : nat) (_ : Bool) => true) = (ind_nat (fun _ : nat => Bool) (true, fun _ : nat => idmap))). - intro H'. apply true_ne_false. exact (ap10 (apD10 (ap snd (H1^ @ ap _ H' @ H2)) 0) false). - apply path_forall. intro n; induction n; trivial. unfold ind_nat in *; simpl in *. rewrite <- IHn. destruct n; reflexivity. Defined. End Book_5_5. (* ================================================== ex:no-dep-uniqueness-failure *) (** Exercise 5.6 *) (* ================================================== ex:loop *) (** Exercise 5.7 *) (* ================================================== ex:loop2 *) (** Exercise 5.8 *) (* ================================================== ex:inductive-lawvere *) (** Exercise 5.9 *) (* ================================================== ex:ilunit *) (** Exercise 5.10 *) (* ================================================== ex:empty-inductive-type *) (** Exercise 5.11 *) (* ================================================== ex:Wprop *) (** Exercise 5.12 *) (* ================================================== ex:Wbounds *) (** Exercise 5.13 *) (* ================================================== ex:Wdec *) (** Exercise 5.14 *) (* ================================================== ex:Wbounds-loose *) (** Exercise 5.15 *) (* ================================================== ex:Wimpred *) (** Exercise 5.16 *) (* ================================================== ex:no-nullary-constructor *) (** Exercise 5.17 *) (* ================================================== ex:torus *) (** Exercise 6.1 *) Definition Book_6_1_i := @HoTT.Cubical.DPath.dp_concat. Definition Book_6_1_ii := @HoTT.Cubical.DPath.dp_apD_pp. (** We don't have the full induction principle for the torus *) (* Definition Book_6_1_iii := ? *) (* ================================================== ex:suspS1 *) (** Exercise 6.2 *) (* ================================================== ex:torus-s1-times-s1 *) (** Exercise 6.3 *) Definition Book_6_3 := @HoTT.Spaces.Torus.TorusEquivCircles.equiv_torus_prod_Circle. (* ================================================== ex:nspheres *) (** Exercise 6.4 *) (* ================================================== ex:susp-spheres-equiv *) (** Exercise 6.5 *) (* ================================================== ex:spheres-make-U-not-2-type *) (** Exercise 6.6 *) (* ================================================== ex:monoid-eq-prop *) (** Exercise 6.7 *) (* ================================================== ex:free-monoid *) (** Exercise 6.8 *) (* ================================================== ex:unnatural-endomorphisms *) (** Exercise 6.9 *) Section Book_6_9. Hypothesis LEM : forall A, IsHProp A -> A + ~A. Definition Book_6_9 {ua : Univalence} : forall X, X -> X. Proof. intro X. pose proof (@LEM (Contr { f : X <~> X & ~(forall x, f x = x) }) _) as contrXEquiv. destruct contrXEquiv as [C|notC]. - (** In the case where we have exactly one autoequivalence which is not the identity, use it. *) exact ((@center _ C).1). - (** In the other case, just use the identity. *) exact idmap. Defined. Lemma bool_map_equiv_not_idmap (f : { f : Bool <~> Bool & ~(forall x, f x = x) }) : forall b, ~(f.1 b = b). Proof. intro b. intro H''. apply f.2. intro b'. pose proof (eval_bool_isequiv f.1). destruct b', b, (f.1 true), (f.1 false); simpl in *; match goal with | _ => assumption | _ => reflexivity | [ H : true = false |- _ ] => exact (match true_ne_false H with end) | [ H : false = true |- _ ] => exact (match false_ne_true H with end) end. Qed. Lemma Book_6_9_not_id {ua : Univalence} `{fs : Funext} : Book_6_9 Bool = negb. Proof. apply path_forall; intro b. unfold Book_6_9. destruct (@LEM (Contr { f : Bool <~> Bool & ~(forall x, f x = x) }) _) as [C|H']. - set (f := @center _ C). pose proof (bool_map_equiv_not_idmap f b). destruct (f.1 b), b; match goal with | _ => assumption | _ => reflexivity | [ H : ~(_ = _) |- _ ] => exact (match H idpath with end) | [ H : true = false |- _ ] => exact (match true_ne_false H with end) | [ H : false = true |- _ ] => exact (match false_ne_true H with end) end. - refine (match H' _ with end). apply (Build_Contr _ (exist (fun f : Bool <~> Bool => ~(forall x, f x = x)) (Build_Equiv _ _ negb _) (fun H => false_ne_true (H true)))); simpl. intro f. apply path_sigma_uncurried; simpl. refine ((fun H'' => (equiv_path_equiv _ _ H''; path_ishprop _ _)) _); simpl. apply path_forall; intro b'. pose proof (bool_map_equiv_not_idmap f b'). destruct (f.1 b'), b'; match goal with | _ => assumption | _ => reflexivity | [ H : ~(_ = _) |- _ ] => exact (match H idpath with end) | [ H : true = false |- _ ] => exact (match true_ne_false H with end) | [ H : false = true |- _ ] => exact (match false_ne_true H with end) end. Qed. (** Simpler solution not using univalence **) Definition AllExistsOther(X : Type) := forall x:X, { y:X | y <> x }. Definition centerAllExOthBool : AllExistsOther Bool := fun (b:Bool) => (negb b ; not_fixed_negb b). Lemma centralAllExOthBool `{Funext} (f: AllExistsOther Bool) : centerAllExOthBool = f. Proof. apply path_forall. intro b. pose proof (inverse (negb_ne (f b).2)) as fst. unfold centerAllExOthBool. apply (@path_sigma _ _ (negb b; not_fixed_negb b) (f b) fst); simpl. apply equiv_hprop_allpath. apply istrunc_forall. Defined. Definition contrAllExOthBool `{Funext} : Contr (AllExistsOther Bool) := (Build_Contr _ centerAllExOthBool centralAllExOthBool). Definition solution_6_9 `{Funext} : forall X, X -> X. Proof. intro X. elim (@LEM (Contr (AllExistsOther X)) _); intro. - exact (fun x:X => (center (AllExistsOther X) x).1). - exact (fun x:X => x). Defined. Lemma not_id_on_Bool `{Funext} : solution_6_9 Bool <> idmap. Proof. intro Bad. pose proof ((happly Bad) true) as Ugly. assert ((solution_6_9 Bool true) = false) as Good. - unfold solution_6_9. destruct (LEM (Contr (AllExistsOther Bool)) _) as [C|C];simpl. + elim (centralAllExOthBool (@center _ C)). reflexivity. + elim (C contrAllExOthBool). - apply false_ne_true. rewrite (inverse Good). assumption. Defined. End Book_6_9. (* ================================================== ex:funext-from-interval *) (** Exercise 6.10 *) (* ================================================== ex:susp-lump *) (** Exercise 6.11 *) (* ================================================== ex:alt-integers *) (** Exercise 6.12 *) (* ================================================== ex:trunc-bool-interval *) (** Exercise 6.13 *) (* ================================================== ex:all-types-sets *) (** Exercise 7.1 *) Section Book_7_1. Lemma Book_7_1_part_i (H : forall A, merely A -> A) A : IsHSet A. Proof. apply (@HoTT.Universes.HSet.ishset_hrel_subpaths A (fun x y => merely (x = y))); try typeclasses eauto. - intros ?. apply tr. reflexivity. - intros. apply H. assumption. Defined. Lemma Book_7_1_part_ii (H : forall A B (f : A -> B), (forall b, merely (hfiber f b)) -> forall b, hfiber f b) : forall A, IsHSet A. Proof. apply Book_7_1_part_i. intros A a. apply (fun H' => (@H A (merely A) tr H' a).1). clear a. apply Trunc_ind; try exact _. intro x; compute; apply tr. exists x; reflexivity. Defined. End Book_7_1. (* ================================================== ex:s2-colim-unit *) (** Exercise 7.2 *) (* ================================================== ex:ntypes-closed-under-wtypes *) (** Exercise 7.3 *) (* ================================================== ex:connected-pointed-all-section-retraction *) (** Exercise 7.4 *) (* ================================================== ex:ntype-from-nconn-const *) (** Exercise 7.5 *) (* ================================================== ex:connectivity-inductively *) (** Exercise 7.6 *) (* ================================================== ex:lemnm *) (** Exercise 7.7 *) (* ================================================== ex:acnm *) (** Exercise 7.8 *) (* ================================================== ex:acnm-surjset *) (** Exercise 7.9 *) (** Solution for the case (oo,-1). *) Definition Book_7_9_oo_neg1 `{Univalence} (AC_oo_neg1 : forall X : HSet, HasChoice X) (A : Type) : merely (exists X : HSet, exists p : X -> A, IsSurjection p) := @HoTT.Projective.projective_cover_AC AC_oo_neg1 _ A. (* ================================================== ex:acconn *) (** Exercise 7.10 *) (* ================================================== ex:n-truncation-not-left-exact *) (** Exercise 7.11 *) (* ================================================== ex:double-negation-modality *) (** Exercise 7.12 *) Definition Book_7_12 := @HoTT.Modalities.Notnot.NotNot. (* ================================================== ex:prop-modalities *) (** Exercise 7.13 *) Definition Book_7_13_part_i := @HoTT.Modalities.Open.Op. Definition Book_7_13_part_ii := @HoTT.Modalities.Closed.Cl. (* ================================================== ex:f-local-type *) (** Exercise 7.14 *) (* ================================================== ex:trunc-spokes-no-hub *) (** Exercise 7.15 *) (* ================================================== ex:s2-colim-unit-2 *) (** Exercise 7.16 *) (* ================================================== ex:fiber-map-not-conn *) (** Exercise 7.17 *) (* ================================================== ex:is-conn-trunc-functor *) (** Exercise 7.18 *) (* ================================================== ex:categorical-connectedness *) (** Exercise 7.19 *) (* ================================================== ex:homotopy-groups-resp-prod *) (** Exercise 8.1 *) (* ================================================== ex:decidable-equality-susp *) (** Exercise 8.2 *) (* ================================================== ex:contr-infinity-sphere-colim *) (** Exercise 8.3 *) (* ================================================== ex:contr-infinity-sphere-susp *) (** Exercise 8.4 *) (* ================================================== ex:unique-fiber *) (** Exercise 8.5 *) (* ================================================== ex:ap-path-inversion *) (** Exercise 8.6 *) (* ================================================== ex:pointed-equivalences *) (** Exercise 8.7 *) (* ================================================== ex:HopfJr *) (** Exercise 8.8 *) (* ================================================== ex:SuperHopf *) (** Exercise 8.9 *) (* ================================================== ex:vksusppt *) (** Exercise 8.10 *) (* ================================================== ex:vksuspnopt *) (** Exercise 8.11 *) (* ================================================== ex:slice-precategory *) (** Exercise 9.1 *) (* ================================================== ex:set-slice-over-equiv-functor-category *) (** Exercise 9.2 *) (* ================================================== ex:functor-equiv-right-adjoint *) (** Exercise 9.3 *) (* ================================================== ct:pre2cat *) (** Exercise 9.4 *) (* ================================================== ct:2cat *) (** Exercise 9.5 *) (* ================================================== ct:groupoids *) (** Exercise 9.6 *) (* ================================================== ex:2strict-cat *) (** Exercise 9.7 *) (* ================================================== ex:pre2dagger-cat *) (** Exercise 9.8 *) (* ================================================== ct:ex:hocat *) (** Exercise 9.9 *) (* ================================================== ex:dagger-rezk *) (** Exercise 9.10 *) (* ================================================== ex:rezk-vankampen *) (** Exercise 9.11 *) (* ================================================== ex:stack *) (** Exercise 9.12 *) (* ================================================== ex:utype-ct *) (** Exercise 10.1 *) (* ================================================== ex:surjections-have-sections-impl-ac *) (** Exercise 10.2 *) (* ================================================== ex:well-pointed *) (** Exercise 10.3 *) (* ================================================== ex:add-ordinals *) (** Exercise 10.4 *) (* ================================================== ex:multiply-ordinals *) (** Exercise 10.5 *) (* ================================================== ex:algebraic-ordinals *) (** Exercise 10.6 *) (* ================================================== ex:prop-ord *) (** Exercise 10.7 *) (* ================================================== ex:ninf-ord *) (** Exercise 10.8 *) (* ================================================== ex:well-founded-extensional-simulation *) (** Exercise 10.9 *) (* ================================================== ex:choice-function *) (** Exercise 10.10 *) (* ================================================== ex:cumhierhit *) (** Exercise 10.11 *) (* ================================================== ex:strong-collection *) (** Exercise 10.12 *) (* ================================================== ex:choice-cumulative-hierarchy-choice *) (** Exercise 10.13 *) (* ================================================== ex:plump-ordinals *) (** Exercise 10.14 *) (* ================================================== ex:not-plump *) (** Exercise 10.15 *) (* ================================================== ex:plump-successor *) (** Exercise 10.16 *) (* ================================================== ex:ZF-algebras *) (** Exercise 10.17 *) (* ================================================== ex:monos-are-split-monos-iff-LEM-holds *) (** Exercise 10.18 *) (* ================================================== ex:alt-dedekind-reals *) (** Exercise 11.1 *) (* ================================================== ex:RD-extended-reals *) (** Exercise 11.2 *) (* ================================================== ex:RD-lower-cuts *) (** Exercise 11.3 *) (* ================================================== ex:RD-interval-arithmetic *) (** Exercise 11.4 *) (* ================================================== ex:RD-lt-vs-le *) (** Exercise 11.5 *) (* ================================================== ex:reals-non-constant-into-Z *) (** Exercise 11.6 *) (* ================================================== ex:traditional-archimedean *) (** Exercise 11.7 *) (* ================================================== RC-Lipschitz-on-interval *) (** Exercise 11.8 *) (* ================================================== ex:metric-completion *) (** Exercise 11.9 *) (* ================================================== ex:reals-apart-neq-MP *) (** Exercise 11.10 *) (* ================================================== ex:reals-apart-zero-divisors *) (** Exercise 11.11 *) (* ================================================== ex:finite-cover-lebesgue-number *) (** Exercise 11.12 *) (* ================================================== ex:mean-value-theorem *) (** Exercise 11.13 *) (* ================================================== ex:knuth-surreal-check *) (** Exercise 11.14 *) (* ================================================== ex:reals-into-surreals *) (** Exercise 11.15 *) (* ================================================== ex:ord-into-surreals *) (** Exercise 11.16 *) (* ================================================== ex:hiit-plump *) (** Exercise 11.17 *) (* ================================================== ex:pseudo-ordinals *) (** Exercise 11.18 *) (* ================================================== ex:double-No-recursion *) (** Exercise 11.19 *) Coq-HoTT-9.0/contrib/SetoidRewrite.v000066400000000000000000000170071474641544500173630ustar00rootroot00000000000000(* Typeclass instances to allow rewriting in categories. Examples are given later in the file. *) (* Init.Tactics contains the definition of the Coq stdlib typeclass_inferences database. It must be imported before Basics.Overture. *) (** Warning: This imports Coq.Setoids.Setoid from the standard library. Currently the setoid rewriting machinery requires this to work, it depends on this file explicitly. This imports the whole standard library into the namespace. All files that import WildCat/SetoidRewrite.v will also recursively import the entire Coq.Init standard library. *) (** Because of this, this file needs to be the *first* file Require'd in any file that uses it. Otherwise, the typeclasses hintdb is cleared, breaking typeclass inference. Moreover, if Foo Requires this file, then Foo must also be the first file Require'd in any file that Requires Foo, and so on. In the long term it would be good if this could be avoided.*) #[warnings="-deprecated-from-Coq"] From Coq Require Init.Tactics. From HoTT Require Import Basics.Overture Basics.Tactics. From HoTT Require Import Types.Forall. #[warnings="-deprecated-from-Coq"] From Coq Require Setoids.Setoid. Import CMorphisms.ProperNotations. From HoTT Require Import WildCat.Core WildCat.NatTrans WildCat.Equiv. #[export] Instance reflexive_proper_proxy {A : Type} {R : Relation A} `(Reflexive A R) (x : A) : CMorphisms.ProperProxy R x := reflexivity x. (* forall (x y : A), x $== y -> forall (a b : A), a $== b -> y $== b -> x $==a *) #[export] Instance IsProper_GpdHom_from {A : Type} `{Is0Gpd A} : CMorphisms.Proper (GpdHom ==> GpdHom ==> CRelationClasses.flip CRelationClasses.arrow) GpdHom. Proof. intros x y eq_xy a b eq_ab eq_yb. exact (transitivity eq_xy (transitivity eq_yb (symmetry _ _ eq_ab))). Defined. (* forall (x y : A), x $== y -> forall (a b : A), a $== b -> x $== a -> y $== b *) #[export] Instance IsProper_GpdHom_to {A : Type} `{Is0Gpd A} : CMorphisms.Proper (GpdHom ==> GpdHom ==> CRelationClasses.arrow) GpdHom. Proof. intros x y eq_xy a b eq_ab eq_yb. unshelve refine (transitivity _ eq_ab). unshelve refine (transitivity _ eq_yb). exact (symmetry _ _ eq_xy). Defined. (* forall a : A, x $== y -> a $== x -> a $== y *) #[export] Instance IsProper_GpdHom_to_a {A : Type} `{Is0Gpd A} {a : A} : CMorphisms.Proper (GpdHom ==> CRelationClasses.arrow) (GpdHom a). Proof. intros x y eq_xy eq_ax. by transitivity x. Defined. (* forall a : A, x $== y -> a $== y -> a $== x *) #[export] Instance IsProper_GpdHom_from_a {A : Type} `{Is0Gpd A} {a : A} : CMorphisms.Proper (GpdHom ==> CRelationClasses.flip CRelationClasses.arrow) (GpdHom a). Proof. intros x y eq_xy eq_ay. exact (transitivity eq_ay (symmetry _ _ eq_xy)). Defined. Open Scope signatureT_scope. #[export] Instance symmetry_flip {A B : Type} {f : A -> B} {R : Relation A} {R' : Relation B} `{Symmetric _ R} (H0 : CMorphisms.Proper (R ++> R') f) : CMorphisms.Proper (R --> R') f. Proof. intros a b Rab. apply H0. unfold CRelationClasses.flip. symmetry. exact Rab. Defined. #[export] Instance symmetric_flip_snd {A B C : Type} {R : Relation A} {R' : Relation B} {R'' : Relation C} `{Symmetric _ R'} (f : A -> B -> C) (H1 : CMorphisms.Proper (R ++> R' ++> R'') f) : CMorphisms.Proper (R ++> R' --> R'') f. Proof. intros a b Rab x y R'yx. apply H1; [ assumption | symmetry; assumption ]. Defined. #[export] Instance IsProper_fmap {A B : Type} `{Is1Cat A} `{Is1Cat A} (F : A -> B) `{Is1Functor _ _ F} (a b : A) : CMorphisms.Proper (GpdHom ==> GpdHom) (@fmap _ _ _ _ F _ a b) := fun _ _ eq => fmap2 F eq. #[export] Instance IsProper_catcomp_g {A : Type} `{Is1Cat A} {a b c : A} (g : b $-> c) : CMorphisms.Proper (GpdHom ==> GpdHom) (@cat_comp _ _ _ a b c g). Proof. intros f1 f2. apply (is0functor_postcomp a b c g ). Defined. #[export] Instance IsProper_catcomp {A : Type} `{Is1Cat A} {a b c : A} : CMorphisms.Proper (GpdHom ==> GpdHom ==> GpdHom) (@cat_comp _ _ _ a b c). Proof. intros g1 g2 eq_g f1 f2 eq_f. rewrite eq_f. apply (is0functor_precomp a b c f2). exact eq_g. Defined. #[export] Instance gpd_hom_to_hom_proper {A B : Type} `{Is0Gpd A} {R : Relation B} (F : A -> B) `{CMorphisms.Proper _ (GpdHom ==> R) F} : CMorphisms.Proper (Hom ==> R) F. Proof. intros a b eq_ab; apply H2; exact eq_ab. Defined. #[export] Instance gpd_hom_is_proper1 {A : Type} `{Is0Gpd A} : CMorphisms.Proper (Hom ==> Hom ==> CRelationClasses.arrow) Hom. Proof. intros x y eq_xy a b eq_ab f. refine (transitivity _ eq_ab). refine (transitivity _ f). symmetry; exact eq_xy. Defined. #[export] Instance transitive_hom {A : Type} `{Is01Cat A} {x : A} : CMorphisms.Proper (Hom ==> CRelationClasses.arrow) (Hom x). Proof. intros y z g f. exact (g $o f). Defined. Proposition IsEpic_HasSection {A} `{Is1Cat A} {a b : A} (f : a $-> b) : SectionOf f -> Epic f. Proof. intros section c g h eq_gf_hf. destruct section as [right_inverse is_section]. apply (is0functor_precomp _ _ _ right_inverse) in eq_gf_hf; unfold cat_precomp in eq_gf_hf. rewrite 2 cat_assoc, is_section, 2 cat_idr in eq_gf_hf. exact eq_gf_hf. Defined. Proposition IsMonic_HasRetraction {A} `{Is1Cat A} {b c : A} (f : b $-> c) : RetractionOf f -> Monic f. Proof. intros retraction a g h eq_fg_fh. destruct retraction as [left_inverse is_retraction]. apply (is0functor_postcomp _ _ _ left_inverse) in eq_fg_fh; unfold cat_postcomp in eq_fg_fh. rewrite <- 2 cat_assoc, is_retraction, 2 cat_idl in eq_fg_fh. assumption. Defined. Proposition nat_equiv_faithful {A B : Type} {F G : A -> B} `{Is1Functor _ _ F} `{!Is0Functor G, !Is1Functor G} `{!HasEquivs B} (tau : NatEquiv F G) : Faithful F -> Faithful G. Proof. intros faithful_F x y f g eq_Gf_Gg. apply (@fmap _ _ _ _ _ (is0functor_precomp _ _ _ (cat_equiv_natequiv tau x))) in eq_Gf_Gg. cbn in eq_Gf_Gg. unfold cat_precomp in eq_Gf_Gg. rewrite <- 2 (isnat tau) in eq_Gf_Gg. apply faithful_F. assert (X : RetractionOf (tau y)). { unshelve eapply Build_RetractionOf. - exact ((tau y)^-1$). - exact (cate_issect _ ). } apply IsMonic_HasRetraction in X. apply X in eq_Gf_Gg. assumption. Defined. Section SetoidRewriteTests. Goal forall (A : Type) `(H : Is0Gpd A) (a b c : A), a $== b -> b $== c -> a $== c. Proof. intros A ? ? ? a b c eq_ab eq_bc. rewrite eq_ab, <- eq_bc. Abort. Goal forall (A : Type) `(H : Is0Gpd A) (a b c : A), a $== b -> b $== c -> a $== c. Proof. intros A ? ? ? a b c eq_ab eq_bc. symmetry. rewrite eq_ab, <- eq_bc. rewrite eq_bc. rewrite <- eq_bc. Abort. Goal forall (A B : Type) (F : A -> B) `{Is1Functor _ _ F} (a b : A) (f g : a $-> b), f $== g -> fmap F f $== fmap F g. Proof. do 17 intro. intro eq_fg. rewrite eq_fg. Abort. Goal forall (A : Type) `{Is1Cat A} (a b c : A) (f1 f2 : a $-> b) (g : b $-> c), f1 $== f2 -> g $o f1 $== g $o f2. Proof. do 11 intro. intro eq. rewrite <- eq. rewrite eq. Abort. Goal forall (A : Type) `{Is1Cat A} (a b c : A) (f : a $-> b) (g1 g2 : b $-> c), g1 $== g2 -> g1 $o f $== g2 $o f. Proof. do 11 intro. intro eq. rewrite <- eq. rewrite eq. rewrite <- eq. Abort. Goal forall (A : Type) `{Is1Cat A} (a b c : A) (f1 f2 : a $-> b) (g1 g2 : b $-> c), g1 $== g2 -> f1 $== f2 -> g1 $o f1 $== g2 $o f2. Proof. do 12 intro. intros eq_g eq_f. rewrite eq_g. rewrite <- eq_f. rewrite eq_f. rewrite <- eq_g. Abort. End SetoidRewriteTests. Coq-HoTT-9.0/contrib/dune000066400000000000000000000001071474641544500152520ustar00rootroot00000000000000(coq.theory (name HoTT.Contrib) (package coq-hott) (theories HoTT)) Coq-HoTT-9.0/coq-hott.opam000066400000000000000000000015741474641544500153610ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "The Homotopy Type Theory library" description: """ To use the HoTT library, the following flags must be passed to coqc: -noinit -indices-matter To use the HoTT library in a project, add the following to _CoqProject: -arg -noinit -arg -indices-matter """ maintainer: [ "Jason Gross " "Ali Caglayan " ] authors: ["The HoTT Library Development Team"] license: "BSD-2-Clause" homepage: "http://homotopytypetheory.org/" bug-reports: "https://github.com/HoTT/HoTT/issues" depends: [ "dune" {>= "3.13"} "coq" {>= "8.19.0"} "odoc" {with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/HoTT/HoTT.git" Coq-HoTT-9.0/dune000066400000000000000000000050741474641544500136220ustar00rootroot00000000000000; Rule for generating coq_project ; This uses (mode promote) in order to put _CoqProject in the source tree. ; This isn't actually needed for dune but is useful when working with editors. (rule (target _CoqProject) (deps ./etc/generate_coqproject.sh (source_tree theories) (source_tree contrib) (source_tree test)) (mode promote) (package coq-hott) (action (setenv GENERATE_COQPROJECT_FOR_DUNE true (bash ./etc/generate_coqproject.sh)))) ; Rule for validation: dune build @runtest ; This will also run the tests (rule (alias runtest) (deps (glob_files_rec ./*.vo)) (action (run coqchk -R ./theories HoTT -Q contrib HoTT.Contrib -Q test HoTT.Tests %{deps} -o))) ; We modify the default alias to avoid test/ (alias (name default) (deps (alias_rec contrib/all) (alias_rec theories/all) _CoqProject)) ; Tags for emacs (rule (target TAGS) (alias emacs) (mode promote) (deps etc/emacs/run-etags.sh %{bin:etags} (:vfile (glob_files_rec theories/*.v) (glob_files_rec contrib/*.v))) (action (run etc/emacs/run-etags.sh %{vfile}))) ; Common flags for Coq (env (dev (coq (coqdoc_flags :standard --interpolate --utf8 --no-externals --parse-comments) (flags -noinit -indices-matter -color on))) (_ (coq (coqdoc_flags :standard --interpolate --utf8 --no-externals --parse-comments) (flags -noinit -indices-matter)))) ; Bench ; The following rule allows you to bench the running time of a file using ; "hyperfine". For this to work you must make a file called "file_to_bench" ; which contains the path to the file you want to bench (with brackets around ; it). For instance, if we wanted to bench the file ; "theories/WildCat/Products.v", we would make a file called "file_to_bench" with ; the following content: ; ; (theories/WildCat/Products.v) ; ; Afterwards you run "dune build @bench" and it will output the report. (rule (alias bench) (deps (alias bench-hint) (universe) (sandbox always) (glob_files_rec ./*.vo) (:file (include file_to_bench))) (target bench_report) (action (progn (with-outputs-to %{target} (progn (copy %{file} benched_file.v) (run %{bin:hyperfine} "%{bin:coqc} -R %{project_root}/theories HoTT -noinit -indices-matter benched_file.v"))) (echo "Bench finished, report at %{target}:\n\n") (cat %{target})))) (rule (alias bench-hint) (deps (universe) (glob_files_rec ./*.vo) %{bin:hyperfine} (file file_to_bench)) (action (run echo "Starting bench. This may take a while."))) Coq-HoTT-9.0/dune-project000066400000000000000000000012071474641544500152600ustar00rootroot00000000000000(lang dune 3.13) (using coq 0.8) (name coq-hott) (generate_opam_files true) (source (github HoTT/HoTT)) (homepage "http://homotopytypetheory.org/") (license BSD-2-Clause) (authors "The HoTT Library Development Team") (maintainers "Jason Gross " "Ali Caglayan ") (package (name coq-hott) (synopsis "The Homotopy Type Theory library") (description "To use the HoTT library, the following flags must be passed to coqc:\n -noinit -indices-matter\nTo use the HoTT library in a project, add the following to _CoqProject:\n -arg -noinit\n -arg -indices-matter\n") (depends (coq (>= 8.19.0)))) Coq-HoTT-9.0/etc/000077500000000000000000000000001474641544500135115ustar00rootroot00000000000000Coq-HoTT-9.0/etc/Book.py000077500000000000000000000203411474641544500147600ustar00rootroot00000000000000#!/usr/bin/env python # This script takes as input the content of the *.aux files for # The HoTT Book, see https://github.com/HoTT/book/ and processes # the given *.v file by inserting page and label references into it. # The script expects the content of *.aux files on stdin. Use like this: # cat ../book/*.aux | etc/Book.py contrib/HoTTBook.v import re import sys import shutil import os description = """ Process Coq file (e.g. HoTTBook.v) and refresh with respect to the HoTT book *.aux files. The script expects the content of *.aux files on stdandard input. Typical use: cat ../book/*.aux | etc/Book.py contrib/HoTTBook.v """ parser_args_tuples = ((("--debug",), {'action':'store_true', 'help':'Print debugging info', 'default':False}), (("--exercises",), {'action':'store_true', 'help':'Process exercises', 'default':False})) file_help_string = 'the Coq file that should be processed\n(probably contrib/HoTTBook.v or contrib/HoTTBookExercises.v)' extra_description = r"""positional arguments: file the Coq file that should be processed (probably contrib/HoTTBook.v or contrib/HoTTBookExercises.v) """ # Parse command line arguments # first try argparse, which is Python 2.7+ try: import argparse from argparse import RawTextHelpFormatter parser = argparse.ArgumentParser(description = description, add_help=True, formatter_class=RawTextHelpFormatter) for parser_args, parser_kwargs in parser_args_tuples: parser.add_argument (*parser_args, **parser_kwargs) parser.add_argument ("file", help=file_help_string) args = parser.parse_args() except ImportError: # we don't have argparse, so try the older optparse import optparse opts = ' '.join('[%s]' % parser_args[0] for parser_args, parser_kwargs in parser_args_tuples) usage = "usage: %prog [-h] " + opts + " file" # TODO: Figure out how to make a raw display, and not reflow the description improperly parser = optparse.OptionParser(description = description+extra_description, add_help_option=True, usage=usage) for parser_args, parser_kwargs in parser_args_tuples: parser.add_option (*parser_args, **parser_kwargs) (args, positional_args) = parser.parse_args() if len(positional_args) != 1: parser.error("too few arguments") else: args.file = positional_args[0] lineno = 0 skipped = 0 badlabel = 0 def log(msg): if args.debug: print("Line {0}: {1}".format(lineno, msg)) def warn(msg): print("\n **** WARNING: {0}\n".format(msg)) def die(msg): print("\n ***** FATAL ERROR: {0}\n".format(msg)) sys.exit(1) # Mapping from environment names to names envname = { 'axiom' : 'Axiom', 'chapter' : 'Chapter', 'cor' : 'Corollary', 'defn' : 'Definition', 'equation' : 'Equation', 'eg' : 'Example', 'egs' : 'Examples', 'ex' : 'Exercise', 'figure' : 'Figure', 'lem' : 'Lemma', 'rmk' : 'Remark', 'section' : 'Section', 'subsection' : 'Subsection', 'symindex' : 'Symbol index', 'table' : 'Table', 'thm' : 'Theorem' } # Set of environment names that are formalizable formalizable = set(['axiom', 'cor', 'defn', 'eg', 'egs', 'lem', 'thm']) if args.exercises: formalizable = set(['ex']) # Step 1: Read the standard input and gather entry info into a dictionary entries = {} # The regular expression which matches a label line in a *.aux file # Really we should check for 'balanced braces' instead of '.*?', but # that's hard. We need to catch things involving \texorpdfstring, for # example r = re.compile(r"\\newlabel{([a-zA-Z0-9:=_-]+)}{{([0-9.]+)}{([0-9]+)}{.*?}{([a-z]+)\.[^}]*}{[^}]*}}") print """Reading content of *.aux files from standard input... (If you see this press Ctrl-C, read help with --help option, and try agian.)""", for line in sys.stdin: lineno = lineno + 1 m = r.match(line) if m: if not m.group(4) in envname: warn('unknown environment name {0}, skipping'.format(m.group(4))) badlabel = badlabel + 1 continue label = m.group(1) number = map(int, m.group(2).split(".")) page = int(m.group(3)) typ = envname[m.group(4)] if not m.group(4) in formalizable: continue # entry not formalizable, skip log ('match: label = {0}, number = {1}, page = {2}, type = {3}'.format( label, number, page, typ)) if label in entries: warn ('duplicate label {0} in *.aux files'.format(label)) entries[label] = { 'number' : number, 'page' : page, 'typ' : typ } else: skipped = skipped + 1 print "\r {0}".format(" " * 80) print ("Statistics:\n{0} lines of input\n{1} lines skipped\n{2} labels found\n{3} labels confused me\n".format(lineno,skipped,len(entries), badlabel)) #### Now we munch the file print ("Reading {0}".format(args.file)) # Read the whole file in one go (doing things line by line is so 1970's) with open(args.file, "r") as f: coqfile = f.read() # Break it up # use a separate compile part so that python 2.6 doesn't complain (preamble, rest) = re.compile(r'^\(\* END OF PREAMBLE \*\)\s*$', flags=re.MULTILINE).split(coqfile) snippets = re.compile(r'^\s*\(\* =======+ ([A-Za-z0-9:=_-]+) \*\)\s*$', flags=re.MULTILINE).split(rest) # Pop the first snippet, as it is just an empty string snippets.pop(0) if len(preamble.split()) > 1000: die ('Why is the preamble longer than 1000 lines? Parsing error?') # Put snippets into the entry dictionary k = 0 while snippets: label = snippets.pop(0) content = snippets.pop(0) if re.search("========", content): die ("entry {0} contanins something that looks like a marker, please fix this first.".format(label)) k = k + 1 if label not in entries: die ('unknown entry {0} found in Coq file, please fix this first.'.format(label)) if 'content' in entries[label]: die ('duplicate entry {0} found in Coq file, please fix this first.'.format(label)) entries[label]['content'] = content #### Regenerate the output file newentry = [] coqfile = preamble + "(* END OF PREAMBLE *)\n" # Process entries sorted by page number for label in sorted(entries.keys(), key = lambda k: (entries[k]['page'], entries[k]['number'])): entry = entries[label] if 'content' in entry: # Fix old content content = entry['content'].lstrip() # Strip the comment on the first line content = content[content.index('\n')+1:] # Update Book_X_Y_Z book = "_".join(map(str,entry['number'])) # content = re.sub('Book_[0-9_]*[0-9]', 'Book_{0}'.format(book), content) # content = re.sub('Definition Book_[0-9_]*[0-9]', 'Definition Book_{0}'.format(book), content) # previous two removed since they break Exercise 2.2 and 2.3 # It is a common error to write things like Lemma_X_Y_Z instead of Book_X_Y_Z, # so we warn about those. suspect_names = "|".join(['Axiom', 'Corollary', 'Example', 'Exercise', 'Lemma', 'Remark', 'Theorem']) suspect = re.search('({0})_[0-9]*[0-9]'.format(suspect_names), content) if suspect: better = re.sub('({0})'.format(suspect_names), 'Book', suspect.group(0)) warn ('You wrote "{0}", should it not be "{1}"?'.format(suspect.group(0), better)) else: # Genereate new content content = '' newentry.append(label) # Put in the correct first line content = "(** {0} {1} *)\n\n{2}\n\n".format( entry['typ'], '.'.join(map(str,entry['number'])), content.strip()) coqfile += '(* {0} {1} *)\n{2}'.format('=' * 50, label, content) if newentry: print ("New entries: {0}".format(newentry)) # Copy the file to backup k = 1 while os.path.exists("{0}.bak.{1}".format(args.file, k)): k = k + 1 backupfile = "{0}.bak.{1}".format(args.file, k) print ("Making backup file {0}".format(backupfile)) shutil.move(args.file, backupfile) # Write out the new file with open(args.file, 'w') as f: f.write(coqfile) print ("Wrote new version of {0}".format(args.file)) Coq-HoTT-9.0/etc/DepsToDot.hs000077500000000000000000000123201474641544500157130ustar00rootroot00000000000000#! /usr/bin/env runhaskell {-# LANGUAGE UnicodeSyntax, ViewPatterns #-} {-# OPTIONS_GHC -Wall #-} import Data.Graph.Inductive (reachable, delEdge, mkGraph, nmap, Edge, Gr, DynGraph, UEdge, LEdge, efilter, LNode, labNodes, Graph, delNodes) import Data.GraphViz (Attributes, toGraphID, color, toLabel, printDotGraph, nonClusteredParams, graphToDot, fmtNode, setID, X11Color(..)) import Data.GraphViz.Attributes.Complete (Attribute(URL)) import Data.Text.Lazy (Text, pack, unpack) import Data.List (nub, elemIndex, isSuffixOf, isPrefixOf) import Control.Monad (liftM2) import Data.Maybe import System.Environment import System.Exit import System.IO import System.Console.GetOpt import Prelude hiding ((.)) (.) :: Functor f ⇒ (a → b) → (f a → f b) (.) = fmap dropBack :: Int → [a] → [a] dropBack n = reverse . drop n . reverse uedge :: LEdge a → Edge uedge (x, y, _) = (x, y) nfilter :: Graph gr ⇒ (LNode a → Bool) → gr a b → gr a b nfilter p g = delNodes (map fst $ filter (not . p) $ labNodes g) g untransitive :: DynGraph gr ⇒ gr a b → gr a b untransitive g = efilter (not . redundant . uedge) g where redundant e@(from, to) = to `elem` reachable from (delEdge e g) read_deps :: String → Gr FilePath () read_deps input = mkGraph (zip [0..] nodes) edges where content :: [(FilePath, FilePath)] content = do (left, _ : right) ← break (==':') . lines input liftM2 (,) (words left) (words right) nodes :: [FilePath] nodes = nub $ map fst content ++ map snd content edges :: [UEdge] edges = map (\(from, to) → (fromJust $ elemIndex from nodes, fromJust $ elemIndex to nodes, ())) content cut_dotvo :: String → String cut_dotvo = dropBack 3 -- strip to basename basename :: String → String basename name = if "theories/" `isPrefixOf` name then drop (length "theories/") name else if "coq/theories/" `isPrefixOf` name then "coq/" ++ drop (length "coq/theories/") name else name hottRenameCoqDoc :: String → String hottRenameCoqDoc p = if "theories/" `isPrefixOf` p then "HoTT." ++ drop (length "theories/") p else if "coq/theories/" `isPrefixOf` p then "Coq." ++ drop (length "coq/theories/") p else if "contrib/" `isPrefixOf` p then drop (length "contrib/") p else p coqDocURL :: String → FilePath → String coqDocURL base p = base ++ map (\c -> if c == '/' then '.' else c) (hottRenameCoqDoc (cut_dotvo p)) ++ ".html" label :: Options → FilePath → Attributes label opts p' = [ toLabel (basename $ cut_dotvo p) , color myColor -- , LabelFontColor (X11Color color) ] ++ maybe [] (\base -> [URL (pack $ coqDocURL base p)]) (optCoqDocBase opts) where p = if take 2 p' == "./" then drop 2 p' else p' myColor :: X11Color myColor | "theories/Categories" `isPrefixOf` p = Magenta | "theories/Types" `isPrefixOf` p = BlueViolet | "theories/HIT" `isPrefixOf` p = Orange | "theories/Modalities" `isPrefixOf` p = Black | "contrib/" `isPrefixOf` p = Cyan4 | "coq/theories/" `isPrefixOf` p = Blue | "theories/Basics" `isPrefixOf` p = SaddleBrown | "theories/Tactics" `isPrefixOf` p = Red -- | "quote/" `isPrefixOf` p = Gold3 -- | "theory/" `isPrefixOf` p = BlueViolet -- | "varieties/" `isPrefixOf` p = Red | otherwise = Green makeGraph :: Options -> String -> Text makeGraph opts = printDotGraph . setID (toGraphID $ optTitle opts) . graphToDot (nonClusteredParams {fmtNode = snd}) . nmap (label opts). untransitive . nfilter (isSuffixOf ".vo" . snd) . read_deps data Options = Options { optCoqDocBase :: Maybe String, optTitle :: String, optInput :: IO String, optOutput :: String -> IO () } defaultOptions :: Options defaultOptions = Options { optCoqDocBase = Nothing, optTitle = "", optInput = getContents, optOutput = putStr } options :: [OptDescr (Options -> IO Options)] options = [ Option [] ["coqdocbase"] (ReqArg (\arg opt -> return opt { optCoqDocBase = Just arg }) "URL") "coqdoc base path (include trailing slash)", Option ['i'] ["input"] (ReqArg (\arg opt -> return opt { optInput = readFile arg }) "FILE") "input file, stdin if omitted", Option ['o'] ["output"] (ReqArg (\arg opt -> return opt { optOutput = writeFile arg }) "FILE") "output file, stdout if omitted", Option ['t'] ["title"] (ReqArg (\arg opt -> return opt { optTitle = arg }) "TITLE") "title of the graph page", Option ['h'] ["help"] (NoArg (\_ -> usage >> exitSuccess)) "display this help page"] usage :: IO () usage = do prg <- getProgName hPutStrLn stderr $ usageInfo ("Usage: " ++ prg ++" [OPTION...]") options hPutStrLn stderr "Use dot -Tsvg deps.dot -o deps.svg to render the graph" hPutStrLn stderr $ replicate 30 ' ' ++ "This DepsToDot has Super Coq Powers." main :: IO () main = do argv <- getArgs case getOpt Permute options argv of (actions,_,[]) -> do opts <- foldl (>>=) (return defaultOptions) actions input <- optInput opts optOutput opts $ unpack $ makeGraph opts $ input (_,_,errors) -> do hPutStrLn stderr $ concat errors usage exitFailure Coq-HoTT-9.0/etc/alectryon/000077500000000000000000000000001474641544500155115ustar00rootroot00000000000000Coq-HoTT-9.0/etc/autoreconf-branch000066400000000000000000000000351474641544500170320ustar00rootroot00000000000000master-with-autoreconf-files Coq-HoTT-9.0/etc/autoreconf-files000066400000000000000000000000611474641544500166760ustar00rootroot00000000000000etc/install-sh etc/missing configure Makefile.in Coq-HoTT-9.0/etc/ci/000077500000000000000000000000001474641544500141045ustar00rootroot00000000000000Coq-HoTT-9.0/etc/ci/add_upstream.sh000077500000000000000000000004241474641544500171130ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null echo "Adding remote..." git remote add upstream git://github.com/HoTT/HoTT.git git remote update popd 1>/dev/null Coq-HoTT-9.0/etc/ci/after_success.sh000077500000000000000000000010501474641544500172700ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" # only make if we should ($UPDATE_HTML is not empty) and we're the same as origin/master "$DIR"/generate_and_push_doc.sh "$@" || exit $? "$DIR"/generate_and_push_quick_doc.sh "$@" || exit $? "$DIR"/update_tocs.sh "$@" || exit $? "$DIR"/generate_and_push_dep_graphs.sh "$@" || exit $? popd 1>/dev/null Coq-HoTT-9.0/etc/ci/before_script.sh000077500000000000000000000006011474641544500172660ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # install autoreconf sudo apt-get update sudo apt-get install -q autoconf # install coq if [ ! -z "$UPDATE_QUICK_DOC" ]; then ./install_coq_dot_deps.sh || exit $? ./install_doctoc.sh || exit $? fi popd 1>/dev/null Coq-HoTT-9.0/etc/ci/check_should_dry_run.sh000077500000000000000000000017321474641544500206430ustar00rootroot00000000000000#!/usr/bin/env bash # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" 1>/dev/null BAD_REMOTES="$(git remote -v | grep origin | grep -v 'github.com/HoTT/HoTT')" "$DIR"/add_upstream.sh 1>&2 git remote update 1>&2 UPSTREAM_DIFF="$(git log HEAD..upstream/master)" EXTRA_ARGS="" # only push for real if we line up # only push if match upstream/master if [ "$1" != "-f" ]; then if [ ! -z "$BAD_REMOTES" ]; then echo 'Not pushing doc because there are remotes which are not HoTT/HoTT:' 1>&2 echo "$BAD_REMOTES" 1>&2 EXTRA_ARGS="--dry-run" fi # only make the errata if we're the same as upstream/master if [ ! -z "$UPSTREAM_DIFF" ]; then echo "Not pushing doc beause we do not match with upstream/master; call '$0 -f' to force" 1>&2 EXTRA_ARGS="--dry-run" fi fi echo "$EXTRA_ARGS" popd 1>/dev/null Coq-HoTT-9.0/etc/ci/configure_commit.sh000077500000000000000000000010141474641544500177700ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" echo "Configuring git for commit" if [ -z "$(git config --global user.name)" ]; then git config --global user.name "Travis-CI Bot" fi if [ -z "$(git config --global user.email)" ]; then git config --global user.email "Travis-CI-Bot@travis.fake" fi popd 1>/dev/null Coq-HoTT-9.0/etc/ci/generate_and_push_dep_graphs.sh000077500000000000000000000031601474641544500223120ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" #"$DIR"/add_upstream.sh # copy the push_remote script so it stays around after we change branches cp "$DIR"/{push_remote,push_remote_tmp}.sh if [ -z "$UPDATE_DEP_GRAPHS" ]; then echo 'Not making dep graphs becuase $UPDATE_DEP_GRAPHS variable not set.' exit 0 fi COMMITISH="$(git rev-parse HEAD)" EXTRA_ARGS="$("$DIR"/check_should_dry_run.sh "$@")" "$DIR"/configure_commit.sh export MESSAGE="Autoupdate documentation with dpdgraphs" echo '$ make svg-file-dep-graphs svg-aggregate-dep-graphs' make svg-file-dep-graphs -k || exit $? # `dot` hates file-dep-graphs/hott-all.dot, because it's too big, and # makes `dot` spin for over a dozen minutes. So disable it for now. #make svg-aggregate-dep-graphs -k || exit $? make file-dep-graphs/index.html -k || exit $? mv file-dep-graphs file-dep-graphs-bak git remote update echo '$ git checkout -b gh-pages upstream/gh-pages' git checkout -b gh-pages upstream/gh-pages git rm -rf file-dep-graphs mv file-dep-graphs-bak file-dep-graphs git add -f file-dep-graphs/*.svg file-dep-graphs/index.html # file-dep-graphs/*.dot echo '$ git commit -am "'"$MESSAGE"'"' git commit -m "$MESSAGE" # use the copy of the script which stayed around when we changed branches "$DIR"/push_remote_tmp.sh gh-pages:gh-pages $EXTRA_ARGS || exit $? # checkout the original commit echo '$ git checkout '"$COMMITISH" git checkout "$COMMITISH" -f popd 1>/dev/null Coq-HoTT-9.0/etc/ci/generate_and_push_doc.sh000077500000000000000000000025271474641544500207510ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" 1>/dev/null #"$DIR"/add_upstream.sh # copy the push_remote script so it stays around after we change branches cp "$DIR"/{push_remote,push_remote_tmp}.sh if [ -z "$UPDATE_HTML" ]; then echo 'Not making html becuase $UPDATE_HTML variable not set.' exit 0 fi COMMITISH="$(git rev-parse HEAD)" EXTRA_ARGS="$("$DIR"/check_should_dry_run.sh "$@")" "$DIR"/configure_commit.sh export MESSAGE="Autoupdate documentation with coqdoc and time2html" echo '$ make html' make html || exit $? make timing-html || exit $? mv timing-html timing-html-bak git remote update echo '$ git checkout -b gh-pages upstream/gh-pages' git checkout -b gh-pages upstream/gh-pages rm -rf coqdoc-html rm -rf timing-html mv html coqdoc-html mv timing-html-bak timing-html git add coqdoc-html/* git add timing-html/* echo '$ git commit -am "'"$MESSAGE"'"' git commit -m "$MESSAGE" # use the copy of the script which stayed around when we changed branches "$DIR"/push_remote_tmp.sh gh-pages:gh-pages $EXTRA_ARGS || exit $? # checkout the original commit echo '$ git checkout '"$COMMITISH" git checkout "$COMMITISH" -f popd 1>/dev/null Coq-HoTT-9.0/etc/ci/generate_and_push_quick_doc.sh000077500000000000000000000033161474641544500221420ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" 1>/dev/null #"$DIR"/add_upstream.sh # copy the push_remote script so it stays around after we change branches cp "$DIR"/{push_remote,push_remote_tmp}.sh if [ -z "$UPDATE_QUICK_DOC" ]; then echo 'Not making quick doc becuase $UPDATE_QUICK_DOC variable not set.' exit 0 fi COMMITISH="$(git rev-parse HEAD)" EXTRA_ARGS="$("$DIR"/check_should_dry_run.sh "$@")" "$DIR"/configure_commit.sh export MESSAGE="Autoupdate documentation with DepsToDot.hs" echo '$ make HoTT.deps HoTTCore.deps' make HoTT.deps HoTTCore.deps || exit $? runhaskell etc/DepsToDot.hs --coqdocbase="http://hott.github.io/Coq-HoTT/alectryon-html/" --title="HoTT Library Dependency Graph" < HoTT.deps > HoTT.dot || exit $? runhaskell etc/DepsToDot.hs --coqdocbase="http://hott.github.io/Coq-HoTT/alectryon-html/" --title="HoTT Core Library Dependency Graph" < HoTTCore.deps > HoTTCore.dot || exit $? dot -Tsvg HoTT.dot -o HoTT.svg || exit $? dot -Tsvg HoTTCore.dot -o HoTTCore.svg || exit $? echo '$ git checkout -b gh-pages upstream/gh-pages' git checkout -b gh-pages upstream/gh-pages rm -rf dependencies mkdir -p dependencies mv HoTT.svg HoTTCore.svg dependencies/ git add dependencies/*.svg echo '$ git commit -am "'"$MESSAGE"'"' git commit -m "$MESSAGE" # use the copy of the script which stayed around when we changed branches "$DIR"/push_remote_tmp.sh gh-pages:gh-pages $EXTRA_ARGS || exit $? # checkout the original commit echo '$ git checkout '"$COMMITISH" git checkout "$COMMITISH" -f popd 1>/dev/null Coq-HoTT-9.0/etc/ci/install_coq.sh000077500000000000000000000024511474641544500167550ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -ex # if we're not testing the build of Coq, then install it from debian if [ -z "$BUILD_COQ" ] then #echo | sudo add-apt-repository ppa:ezyang/coq-git #sudo apt-get update -qq sudo apt-get install -q coq libcoq-ocaml-dev || exit $? exit 0 fi # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" pushd "$ROOT_DIR" 1>/dev/null if test ! -d .git then echo 'Error: .git directory does not exist.' echo 'This script only works on a git clone of the HoTT repository.' exit 1 fi echo '$ git submodule sync' git submodule sync echo '$ git submodule update --init --recursive' git submodule update --init --recursive pushd coq-HoTT if [ ! -z "$FORCE_COQ_VERSION" ] then git checkout "$FORCE_COQ_VERSION" || exit $? fi echo '$ git log -1' git log -1 echo '$ ./configure '"$@" ./configure "$@" || exit $? echo '$ make coqocaml' make coqocaml || exit $? echo '$ sudo make install-binaries + rsync plugins theories' touch bin/coqtop.byte bin/coqchk stm/{proof,tac,query}workertop.cma sudo make install-binaries install-devfiles sudo rsync -a plugins theories /usr/local/lib/coq/ popd popd 1>/dev/null popd 1>/dev/null Coq-HoTT-9.0/etc/ci/install_coq_dot_deps.sh000077500000000000000000000004341474641544500206350ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # http://unix.stackexchange.com/questions/82598/how-do-i-write-a-retry-logic-in-script-to-keep-retrying-to-run-it-upto-5-times n=0 until [ $n -ge 10 ] do cabal v1-update && break n=$[$n+1] sleep 10 done cabal v1-install graphviz text Coq-HoTT-9.0/etc/ci/install_doctoc.sh000077500000000000000000000006451474641544500174510ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" 1>/dev/null # Stop npm from failing sudo -E npm config set strict-ssl false # Update npm sudo -E npm i -g npm sudo -E npm install -g doctoc || exit $? popd 1>/dev/null Coq-HoTT-9.0/etc/ci/keep_alive.sh000077500000000000000000000001441474641544500165460ustar00rootroot00000000000000#!/usr/bin/env bash while [ 1 ] do echo "" echo "Travis keep-alive spew" sleep 5m done Coq-HoTT-9.0/etc/ci/pre_push_remote.sh000077500000000000000000000006641474641544500176510ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' # Don't leak secrets set +x if [ ! -z "$OAUTH_TOKEN" ]; then echo "Updating ~/.netrc file" echo >> ~/.netrc echo "machine github.com login $OAUTH_TOKEN" >> ~/.netrc elif [ ! -z "$ACTIONS_DEPLOY_KEY" ]; then echo "Updating ~/.ssh/id_rsa" echo "$ACTIONS_DEPLOY_KEY" > ~/.ssh/id_rsa else echo 'Error: Not pushing because $OAUTH_TOKEN and $ACTIONS_DEPLOY_KEY are empty' exit 0 fi Coq-HoTT-9.0/etc/ci/push_remote.sh000077500000000000000000000022331474641544500167750ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" pushd "$ROOT_DIR" 1>/dev/null # Don't leak secrets set +x if [ ! -z "$OAUTH_TOKEN" ]; then echo "Updating ~/.netrc file" echo >> ~/.netrc echo "machine github.com login $OAUTH_TOKEN" >> ~/.netrc elif [ ! -z "$ACTIONS_DEPLOY_KEY" ]; then echo "Updating ~/.ssh/id_rsa" echo "$ACTIONS_DEPLOY_KEY" > ~/.ssh/id_rsa else echo 'Error: Not pushing because $OAUTH_TOKEN and $ACTIONS_DEPLOY_KEY are empty' exit 0 fi set -x echo "Configuring git for commit" if [ -z "$(git config --global user.name)" ]; then git config --global user.name "CI Bot" fi if [ -z "$(git config --global user.email)" ]; then git config --global user.email "CI-Bot@fake.fake" fi REPO="$(git remote -v | grep -o 'origin\s\+\(.*\?\)\s\+(push)' | sed s'/origin\s\+//g' | sed s'/\s\+(push)//g' | sed s'#git://github.com/#https://github.com/#g')" echo '$ git push '"$REPO ""$@" git push $REPO "$@" || exit $? popd 1>/dev/null popd 1>/dev/null Coq-HoTT-9.0/etc/ci/test-install-target.sh000077500000000000000000000005501474641544500203520ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" sudo make install "$@" || exit $? (echo 'Require Import HoTT.HoTT.' | coqtop -q) || exit $? popd 1>/dev/null Coq-HoTT-9.0/etc/ci/travis_keep_alive.sh000077500000000000000000000002471474641544500201420ustar00rootroot00000000000000#!/usr/bin/env bash # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" "$DIR"/keep_alive.sh & export PID_KEEP_ALIVE=$! Coq-HoTT-9.0/etc/ci/update_tocs.sh000077500000000000000000000047211474641544500167610ustar00rootroot00000000000000#!/usr/bin/env bash PS4='$ ' set -x # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" 1>/dev/null # only make if we should ($UPDATE_QUICK_DOC is not empty) and we're the same as origin/master if [ -z "$UPDATE_QUICK_DOC" ]; then echo 'Not updating TOCs because $UPDATE_QUICK_DOC is not set' exit 0 fi COMMITISH="$(git rev-parse HEAD)" git reset --hard "$DIR"/add_upstream.sh git remote update echo "Updating TOCs..." echo '$ ./etc/update-TOCs' ./etc/update-TOCs || exit $? if [ -z "$(git diff HEAD)" ]; then exit 0 fi "$DIR"/configure_commit.sh echo '$ git branch -a' git branch -a echo '$ git --no-pager diff HEAD' git --no-pager diff HEAD echo '$ git --no-pager diff HEAD..origin/master' git --no-pager diff HEAD..origin/master echo '$ git --no-pager diff HEAD..upstream/master' git --no-pager diff HEAD..upstream/master BAD_REMOTES="$(git remote -v | grep origin | grep -v 'github.com/HoTT/HoTT')" UPSTREAM_LOG="$(git log HEAD..upstream/master)" #MASTER_LOG="$(git log HEAD..master)" #ORIGIN_LOG="$(git log HEAD..origin/master)" git commit -am "Rebuild TOCs (auto)" TOCS_COMMIT="$(git rev-parse HEAD)" # check that we're in the right place, or that we have -f if [ "$1" != "-f" ]; then if [ ! -z "$BAD_REMOTES" ]; then echo 'Not updating TOCs because there are remotes which are not HoTT/HoTT:' echo "$BAD_REMOTES" exit 0 fi # only make the TOCs if we're the same as upstream/master if [ ! -z "$UPSTREAM_LOG" ]; then echo "Not making TOCs beause we do not match with upstream/master; call '$0 -f' to force" exit 0 fi # # only make the TOCs if we're the same as master # if [ ! -z "$MASTER_LOG" ]; then # echo "Not making TOCs beause we do not match with master; call '$0 -f' to force" # exit 0 # fi # # # only make the TOCs if we're the same as upstream/master # if [ ! -z "$ORIGIN_LOG" ]; then # echo "Not making TOCs beause we do not match with origin/master; call '$0 -f' to force" # exit 0 # fi fi echo '$ git reset --hard' git reset --hard echo '$ git rebase origin master && git cherry-pick "'"$TOCS_COMMIT"'" && push_remote.sh HEAD:master' (git rebase origin master && git cherry-pick "$TOCS_COMMIT" && "$DIR"/push_remote.sh HEAD:master) || (git diff; exit 1) echo '$ git checkout '"$COMMITISH" git checkout "$COMMITISH" -f popd 1>/dev/null Coq-HoTT-9.0/etc/coq-scripts/000077500000000000000000000000001474641544500157605ustar00rootroot00000000000000Coq-HoTT-9.0/etc/coqccount.sh000077500000000000000000000040021474641544500160420ustar00rootroot00000000000000#!/bin/bash # A script to help determine where there are bottlenecks in the # parallelization of the build. # This is a wrapper for coqc that indicates when each coqc process # starts and stops and the total number of coqc processes running # at those moments (including the one just about to start and the # one that is just finishing). If you run with -j8, you would # ideally see a lot of 8's in the output. But note that when # multiple processes start at once, they often don't count each other. # When you see smaller numbers transition to larger numbers, # you can look at which jobs ended just before the transition # and which jobs started just after the transition, and check # if the dependencies there are really needed. # To use this script, do # make -jJ COQC=etc/coqccount.sh ... # or # export COQC=etc/coqccount.sh # make -jJ ... # In both cases, fill in J with the number of parallel jobs you want. # The script sends its output to standard error, so use # "make ... >file 2>&1" to save it into a file or # "make ... 2>&1 | command" to pipe it into a command. # The script uses the pgrep utility to count the number of processes # named "coqc". It might seem more sensible to count the coqccount.sh # processes, but for some reason the same process sometimes shows up # multiple times, leading to overcounting. # If the last argument isn't a .v file, we are probably being called # to determine the Coq version, so just transparently call coqc. CURFILE="${@: -1}" if [[ "$CURFILE" != *.v ]]; then exec coqc "$@" fi # Run coqc in the background, and do our first count a bit after it starts. # We do it this way rather than adding 1, as it usually allows us to count # peers that started at about the same time. coqc "$@" & sleep 0.001 CNT=`pgrep -cx '^coqc$'` echo "-> $CNT $CURFILE" >&2 # Do our final count when it ends, and add one for us. wait $! RET=$? CNT=$((`pgrep -cx '^coqc$'` + 1)) echo "<- $CNT $CURFILE" >&2 # We preserve the return value, so that the build stops when there is an error. exit $RET Coq-HoTT-9.0/etc/coqcreplace.py000077500000000000000000000212271474641544500163530ustar00rootroot00000000000000#!/usr/bin/python3 # A wrapper for coqc that will try to replace a regular expression # with a replacement string. The results need to be inspected by # hand, as it will often be too eager. See the "Limitations" section # below. # The patterns are specified using environment variables, using python's # regular expression syntax, e.g.: # export COQC_SEARCH='(^|[^n])(refine|rapply)' # export COQC_REPLACE='\1n\2' # This will replace an occurence of 'refine' or 'rapply' that is either # at the start of the line or preceeded by a character other than 'n' # with the same thing with an 'n' inserted. '\1' and '\2' refer to # the parts of the input line that matched the expressions in parentheses. # - COQC_SEARCH is matched against each *line* of the file separately, # not including newlines. # - Matches are replaced one at a time, from left to right, and each one # is tested and kept only if the file builds successfully and meets the # timing constraint. # - After a replacement, the line is scanned for the next match that # starts *after* that replacement string. # - After a failed replacement, the string is scanned for the next match # that starts one character to the right of the last match, allowing # for overlapping matches. # - Lines containing 'noreplace' are left as is. This can be put in as # a temporary marker inside a comment. # Other examples: # export COQC_SEARCH='\W*`{Univalence}' # export COQC_REPLACE='' # # export COQC_SEARCH='(Truncations|Spaces\.Nat|Spaces\.Pos|Spaces\.Int|Spaces\.No|Pointed|Homotopy.Join|Homotopy.HSpace|WildCat|Algebra.AbSES)' # export COQC_REPLACE='\1.Core' # Search for "min(20" below for how to restrict this to the start of each file. # Can be used as # path/to/coqcreplace.py path/tofile.v # but in order to get the right arguments passed to coqc, it is better to do # make COQC=path/to/coqcreplace.py path/tofile.vo # or # export COQC=path/to/coqcreplace.py # make file.vo # To run on the whole library, avoiding test/ and contrib/, can do: # export COQC=path/to/coqcreplace.py # make clean; make -j theories/HoTT.vo theories/Categories.vo # Use "unset COQC" when done. # You'll need to also adjust the timing policy. See below. # Can be run with -j<#cores> or -j1. Timing is more accurate with -j1. # Note that the make process sometimes calls coqc to, e.g., find out the # Coq version, so we transparently call coqc for such commands. # Also, stdout is usually redirected to a timing file, so we send all of # our additional output to stderr. # Below, file_excludes is set to a list of files to not process. Not sure # if this is needed. # Limitations: # - Doesn't know about comments. # - Shouldn't be run on test/ folder, as many definitions there are preceded # with "Fail". # - It's possible that a change (e.g. to a tactic) doesn't cause a file to fail, # but causes a *later* file to fail. Currently the only work-around is to # add the first file to the file_excludes list below, or to mark the # problematic line with "noreplace". import subprocess import sys import os import time import re # You can choose a fixed timeout or a dynamic timeout. # For this script, you probably always want a dynamic timeout. # A change is only accepted if the new time is <= the time given # by the formula, where duration is the best time seen so far. # Set your timeout policy, in seconds: # This policy only accepts changes that make at least a small # improvement to the timing. This is appropriate for changes that are # intended to improve build speed. But note that there are random # fluctuations, so this will also accept changes that are neutral. # The second part, duration*0.9, is there just to ensure that the # return value is always positive. #def calc_timeout(duration): return max(duration-0.03, duration*0.9) # If changes have other benefits, e.g. reducing dependencies, and are # very unlikely to increase the build time, then you might want to # accept them even if the time increases slightly, to account for # timing noise. def calc_timeout(duration): return max(duration+0.1, duration*1.05) # time.perf_counter is better than time.time, since the latter is # affected by changes to the system clock. Both return a floating point # value in seconds. timer = time.perf_counter # The default timeout value here will be used for the first run. # Returns (exit code of coqc, elapsed time). If the elapsed time # is greater than the timeout, returns (1111, elapsed time). def coqc(quiet=False, timeout=60): start = timer() try: if quiet: cp = subprocess.run(['coqc'] + sys.argv[1:], timeout=timeout, stdout=subprocess.DEVNULL, stderr=subprocess.DEVNULL) else: cp = subprocess.run(['coqc'] + sys.argv[1:], timeout=timeout) except subprocess.TimeoutExpired: return 1111, timer() - start # subprocess.run uses a busy loop to check the timeout, so it may allow # the command to run longer than the limit. So we also check here. elapsed = timer() - start if elapsed > timeout: return 1111, elapsed else: return cp.returncode, elapsed # Files to not process, e.g. summary files, files defining tactics used elsewhere, etc. file_excludes=[ ] # Given a match object match, a replacement string (which can include \1, etc), # and the string s that was searched, return string with the replacement done. def replace_match(match, replace, s): return s[:match.start()] + match.expand(replace) + s[match.end():] def replace(vfile): changes = 0 attempts = 0 timeouts = 0 # Ensure that the file builds with no changes: ret, duration1 = coqc(False) # Exit immediately if it fails, or if the file is excluded from further treatment. if ret != 0 or vfile in file_excludes: return ret, changes, attempts, timeouts # Do a second run to get a more stable duration value: ret2, duration2 = coqc(False) duration = (duration1 + duration2)/2.0 with open(vfile, 'r', encoding="utf-8") as f: lines = f.readlines() os.rename(vfile, vfile+'.bak') # Replace len(lines) with min(20, len(lines)) to only look for matches in first 20 lines: for i in range(len(lines)): # Save last successful line; we'll modify lines[i]: line = lines[i] # Don't make changes to lines with this tag: if 'noreplace' in line: continue end = len(line) # Exclude carriage return and newline from search: while end > 0 and line[end-1] in '\n\r': end -= 1 start = 0 while True: # Note: When start > 0, '^' will never match; but '$' does match endpos match = coqc_search.search(lines[i], pos=start, endpos=end) if not match: break lines[i] = replace_match(match, coqc_replace, lines[i]) attempts += 1 with open(vfile, 'w', encoding="utf-8") as f: f.write(''.join(lines)) ret, newduration = coqc(True, timeout=calc_timeout(duration)) if ret == 0: start = match.end() changes += 1 duration = newduration else: lines[i] = line start = match.start() + 1 if ret == 1111: timeouts += 1 if changes == 0: # Get rid of the backup file if we made no changes: os.rename(vfile+'.bak', vfile) if attempts > 0: # Ensure we are in a consistent state: ret, _ = coqc(True) else: # We only need to do an extra run if the last one failed: if ret != 0: with open(vfile, 'w', encoding="utf-8") as f: f.write(''.join(lines)) ret, _ = coqc() return ret, changes, attempts, timeouts if __name__ == '__main__': vfiles = [arg for arg in sys.argv if arg.endswith('.v')] if len(vfiles) == 0: # We are called for some other reason. Just call coqc and exit. sys.exit(coqc()[0]) elif len(vfiles) > 1: print('!!! Called with more than one vfile???', file=sys.stderr) sys.exit(coqc()[0]) # These will give errors if the environment variables are not set: coqc_search = re.compile(os.environ['COQC_SEARCH']) coqc_replace = os.environ['COQC_REPLACE'] vfile = vfiles[0] ret, changes, attempts, timeouts = replace(vfile) if changes > 0: print('>>> %2d changes made to %s' % (changes, vfile), file=sys.stderr) if attempts > 0: print('--- %2d attempts made to %s' % (attempts, vfile), file=sys.stderr) if timeouts > 0: print('ttt %2d timeouts for %s' % (timeouts, vfile), file=sys.stderr) sys.exit(ret) Coq-HoTT-9.0/etc/coqcstriprequires.py000077500000000000000000000302621474641544500176600ustar00rootroot00000000000000#!/usr/bin/python3 # A wrapper for coqc that will try to strip unneeded imports from a file. # The results need to be inspected by hand, as it will often be too eager. # See the "Limitations" section below. # Can be used as # path/to/coqcstriprequires.py file.v # but in order to get the right arguments passed to coqc, it is better to do # make COQC=path/to/coqcstriprequires.py file.vo # or # export COQC=path/to/coqcstriprequires.py # make file.vo # To run on the whole library, avoiding test/ and contrib/, can do: # export COQC=path/to/coqcstriprequires.py # make clean; make -j theories/HoTT.vo theories/Categories.vo # Use "unset COQC" when done. # Can be run with -j8 or -j1. You should adjust the timeout policy # depending on which case you use. See below. # Note that the make process sometimes calls coqc to, e.g., find out the # Coq version, so we transparently call coqc for such commands. # Also, stdout is usually redirected to a timing file, so we send all of # our additional output to stderr. # Below, file_excludes is set to a list of files to not process. These are # summary files, intended to be used to Require multiple other files. # Also, module_excludes is set to a list of Modules to not try removing. # We use this to keep "Basics" and "Types" present, by default. # "Require" and "Require Import" are both handled, but not "Require Export". # Limitations: # - Doesn't know about comments. # - Won't handle a "Require Import" that occurs on the same line as # (but after) the period from a previous "Require Import". # - If the "Require Import" command spans multiple lines and all # imports are removed, the result won't be syntactically valid. # - It will sometimes remove a module that is transitively required; this has # no advantage, and sometimes makes intermediate goals unclear. # - Shouldn't be run on test/ folder, as many definitions there are preceded # with "Fail". # - It would probably be cleaner to just treat the input as a single string # rather than working line by line. import subprocess import sys import os import time import re # You can choose a fixed timeout or a dynamic timeout. # The former is better for runs with -j8, or any time you don't # trust the timing measurements. # The latter is best run with -j1 to have more stable timings, # as it will exclude changes that slow things down. # Some kind of timeout is important. For example, # Classes/implementations/natpair_integers.v and Classes/theory/rationals.v # both spin when certain lines are removed. # On my system, the slowest file takes 5.5s usually, so a fixed timeout # of 10s is fine, but on a slower system you'll need to increase it. # You can also use a dynamic timeout. This will ensure that no change # is accepted if it increases the time to the value given, where # duration is the best time seen so far. The reason for the displayed # formula is to allow for variations in the timing. In one test, with # max(duration+0.005, duration*1.03), only around 16 changes were # aborted due to the timeout, and only a few of those would have succeeded. # One important one to avoid is Basics from Algebra/.../PullbackFiberSequence, # as removing that Import really does slow things down a lot. # Set your timeout policy, in seconds: def calc_timeout(duration): return max(duration+0.005, duration*1.03) #def calc_timeout(duration): return 10 # time.perf_counter is better than time.time, since the latter is # affected by changes to the system clock. Both return a floating point # value in seconds. timer = time.perf_counter # The default timeout value here will be used for the first run. # Returns (exit code of coqc, elapsed time). If the elapsed time # is greater than the timeout, returns (1111, elapsed time). def coqc(quiet=False, timeout=60): start = timer() try: if quiet: cp = subprocess.run(['coqc'] + sys.argv[1:], timeout=timeout, stdout=subprocess.DEVNULL, stderr=subprocess.DEVNULL) else: cp = subprocess.run(['coqc'] + sys.argv[1:], timeout=timeout) except subprocess.TimeoutExpired: return 1111, timer() - start # subprocess.run uses a busy loop to check the timeout, so it may allow # the command to run longer than the limit. So we also check here. elapsed = timer() - start if elapsed > timeout: return 1111, elapsed else: return cp.returncode, elapsed # Join words with spaces, ignoring None. def myjoin(words): return ' '.join(word for word in words if word is not None) # The various types of Require commands. Match group 2 is the # actual text of the command. require = re.compile(r'(^|\s)(Require)($|\s)') require_import = re.compile(r'(^|\s)(Require Import)($|\s)') require_export = re.compile(r'(^|\s)(Require Export)($|\s)') # The period that marks the end of a Require Import command. period = re.compile(r'[.]\s') # Files to not strip. Most of these files are "summary" files that # Require other files for convenience. Most summary files only contain # Export commands and don't need to be listed here. A couple of files # are excluded for other reasons, as the comments mention. file_excludes=[ 'theories/Categories.v', 'theories/Categories/Adjoint.v', 'theories/Categories/Adjoint/Composition.v', 'theories/Categories/Adjoint/Notations.v', 'theories/Categories/Adjoint/Functorial.v', # breaks Categories/Adjoint.v 'theories/Categories/Category.v', 'theories/Categories/Category/Notations.v', 'theories/Categories/Category/Sigma.v', 'theories/Categories/Comma.v', 'theories/Categories/ExponentialLaws.v', 'theories/Categories/ExponentialLaws/Law1.v', 'theories/Categories/ExponentialLaws/Law2.v', 'theories/Categories/ExponentialLaws/Law3.v', 'theories/Categories/ExponentialLaws/Law4.v', 'theories/Categories/Functor.v', 'theories/Categories/Functor/Composition.v', 'theories/Categories/Functor/Composition/Functorial.v', 'theories/Categories/Functor/Notations.v', 'theories/Categories/Functor/Pointwise.v', 'theories/Categories/Functor/Prod.v', 'theories/Categories/FunctorCategory.v', 'theories/Categories/FunctorCategory/Notations.v', 'theories/Categories/Grothendieck.v', 'theories/Categories/Grothendieck/ToSet.v', 'theories/Categories/GroupoidCategory.v', 'theories/Categories/InitialTerminalCategory.v', 'theories/Categories/KanExtensions.v', 'theories/Categories/LaxComma.v', 'theories/Categories/Limits.v', 'theories/Categories/NaturalTransformation.v', 'theories/Categories/NaturalTransformation/Composition.v', 'theories/Categories/NaturalTransformation/Dual.v', 'theories/Categories/NaturalTransformation/Notations.v', 'theories/Categories/Notations.v', 'theories/Categories/Profunctor.v', 'theories/Categories/Profunctor/Notations.v', 'theories/Categories/Pseudofunctor.v', 'theories/Categories/SetCategory.v', 'theories/Categories/Structure.v', 'theories/Categories/Utf8.v', 'theories/Classes/tests/ring_tac.v', # slow, and nothing changes 'theories/Classes/interfaces/integers.v', # only a comment changes ] module_excludes = ['Basics', 'Types', '(notations)', '(hints)'] def striprequires(vfile): changes = 0 attempts = 0 timeouts = 0 # Ensure that the file builds with no changes: ret, duration = coqc(False) # Exit immediately if it fails, or if the file is excluded from further treatment. if ret != 0 or vfile in file_excludes: return ret, changes, attempts, timeouts with open(vfile, 'r', encoding="utf-8") as f: lines = f.readlines() os.rename(vfile, vfile+'.bak') continuation = False for i in range(len(lines)): line = lines[i] # continued: we are not the first line # continuation: we are not the last line continued = continuation continuation = False if continued: # A previous line had "Require" or "Require Import" and we didn't find the period yet. pos = 0 start = 0 else: m = require_import.search(line) if not m: m = require_export.search(line) if m: # We don't strip any Require Export lines. continue m = require.search(line) if not m: # No "Require" of any kind found. continue pos, start = m.span(2) # pos is where the "R" in "Require" is; start is the first character after # the full command ("Require" or "Require Import"). # Preserve any space characters after the starting position, e.g. indentation: while start < len(line) and line[start] == ' ': start += 1 if start >= len(line): # No imports or period on this line: continutation = True continue end = period.search(line, pos=start) if end: end = end.start() # The position of the period else: # No period found continuation = True end = len(line)-1 # The position of the newline character imports = line[start:end].split() for j in range(len(imports)): save = imports[j] if save in module_excludes: continue attempts += 1 imports[j] = None newimports = myjoin(imports) if newimports or continuation or continued: lines[i] = line[:start] + newimports + line[end:] else: # Completely drop the Require Imports section of the line, including period: lines[i] = line[:pos] + line[end+1:] fixprev = None if lines[i].strip() == '': # If the resulting line is empty, remove it completely: lines[i] = '' elif lines[i].strip() == '.': # Avoid having a line with just a period. fixprev = i-1 while fixprev >= 0 and lines[fixprev] == '': fixprev -= 1 assert(fixprev >= 0) assert(lines[fixprev][-1] == '\n') lines[fixprev] = lines[fixprev][:-1] + '.\n' lines[i] = '' with open(vfile, 'w', encoding="utf-8") as f: f.write(''.join(lines)) ret, newduration = coqc(True, timeout=calc_timeout(duration)) if ret == 0: changes += 1 duration = newduration else: imports[j] = save lines[i] = line[:start] + myjoin(imports) + line[end:] if fixprev is not None: # Remove the period we added: assert(lines[fixprev][-2:] == '.\n') lines[fixprev] = lines[fixprev][:-2] + '\n' if ret == 1111: timeouts += 1 if None not in imports: # Use the saved line, to preserve whitespace: lines[i] = line if changes == 0: # Get rid of the backup file if we made no changes: os.rename(vfile+'.bak', vfile) if attempts > 0: # Ensure we are in a consistent state: ret, _ = coqc(True) else: # We only need to do an extra run if the last one failed: if ret != 0: with open(vfile, 'w', encoding="utf-8") as f: f.write(''.join(lines)) ret, _ = coqc() return ret, changes, attempts, timeouts if __name__ == '__main__': vfiles = [arg for arg in sys.argv if arg.endswith('.v')] if len(vfiles) == 0: # We are called for some other reason. Just call coqc and exit. sys.exit(coqc()[0]) elif len(vfiles) > 1: print('!!! Called with more than one vfile???', file=sys.stderr) sys.exit(coqc()[0]) vfile = vfiles[0] ret, changes, attempts, timeouts = striprequires(vfile) if changes > 0: print('>>> %2d changes made to %s' % (changes, vfile), file=sys.stderr) if attempts > 0: print('--- %2d attempts made to %s' % (attempts, vfile), file=sys.stderr) if timeouts > 0: print('ttt %2d timeouts for %s' % (timeouts, vfile), file=sys.stderr) sys.exit(ret) Coq-HoTT-9.0/etc/emacs/000077500000000000000000000000001474641544500146015ustar00rootroot00000000000000Coq-HoTT-9.0/etc/emacs/run-etags.sh000077500000000000000000000006001474641544500170410ustar00rootroot00000000000000#!/bin/sh etags --language=none -r '/^[ \t]*\(\(Local\|Global\|Cumulative\|NonCumulative\|Monomorphic\|Polymorphic\|Private\)[ \t]+\)*\(Axiom\|Theorem\|Class\|Instance\|Let\|Ltac\|Definition\|Lemma\|Record\|Remark\|Structure\|Fixpoint\|Fact\|Corollary\|Inductive\|CoInductive\|Proposition\|Notation\)[ \t]+\([a-zA-Z0-9_'\'']+\)/\4/' -r '/^[ \t]*\([a-zA-Z0-9_'\'']+\)[ \t]*:/\1/' "$@" Coq-HoTT-9.0/etc/generate_coqproject.sh000077500000000000000000000033771474641544500201050ustar00rootroot00000000000000## List tracked .v files if [ -e .git ]; then TRACKED_V_FILES="$(git ls-files "*.v")" else # This is expected when building using dune, so don't print the warning in that case: if [ "$GENERATE_COQPROJECT_FOR_DUNE" != "true" ]; then echo "Warning: Not a git clone, using find instead" >&2 fi TRACKED_V_FILES="$(find theories contrib test -type f -name "*.v")" fi ## List untracked .v files #UNTRACKED_V_FILES=$(git ls-files --others --exclude-standard "*.v") ## Combine untracked and tracked .v files printf -v UNSORTED_V_FILES '%s\n%s' "$TRACKED_V_FILES" "$UNTRACKED_V_FILES" ## Sort combined .v files SORTED_V_FILES=$(echo "$UNSORTED_V_FILES" | sort) ## _CoqProject header COQPROJECT_HEADER=\ "############################################################################### # WARNING: This file is autogenerated by the generate_coqproject.sh script # found in etc/. It is set to be untracked by git. ############################################################################### -R theories HoTT -Q contrib HoTT.Contrib -Q test HoTT.Tests -arg -noinit -arg -indices-matter -arg -native-compiler -arg no " ## Add additional lines when building with dune if [ "$GENERATE_COQPROJECT_FOR_DUNE" == "true" ]; then COQPROJECT_HEADER="$COQPROJECT_HEADER # Dune compatibility -R _build/default/theories HoTT -Q _build/default/contrib HoTT.Contrib -Q _build/default/test HoTT.Tests " fi ## Store new _CoqProject in a variable printf -v NEW_COQPROJECT '%s\n%s' "$COQPROJECT_HEADER" "$SORTED_V_FILES" ## Look for exisitng _CoqProject if test -f "_CoqProject"; then OLD_COQPROJECT=$(cat _CoqProject) ## If it is the same don't overwrite if [ "$NEW_COQPROJECT" == "$OLD_COQPROJECT" ]; then exit 0 fi fi ## Overwrite _CoqProject echo "$NEW_COQPROJECT" > _CoqProject Coq-HoTT-9.0/etc/homotopy.css000066400000000000000000000114141474641544500161020ustar00rootroot00000000000000/* Adaptation of coqdoc CSS style which does not display ordinary text in crazy fonts and colors. */ body { padding: 0px 0px; margin: 0px 0px; background-color: white } #page { display: block; padding: 0px; margin: 0px; padding-bottom: 10px; } #header { display: block; position: relative; padding: 0; margin: 0; vertical-align: middle; border-bottom-style: solid; border-width: thin } #header h1 { padding: 0; margin: 0;} /* Contents */ #main{ display: block; padding: 10px; font-family: sans-serif; font-size: 100%; line-height: 100% } #main h1 { line-height: 95% } /* allow for multi-line headers */ #main a.idref:visited {color : #416DFF; text-decoration : none; } #main a.idref:link {color : #416DFF; text-decoration : none; } #main a.idref:hover {text-decoration : none; } #main a.idref:active {text-decoration : none; } #main a.modref:visited {color : #416DFF; text-decoration : none; } #main a.modref:link {color : #416DFF; text-decoration : none; } #main a.modref:hover {text-decoration : none; } #main a.modref:active {text-decoration : none; } #main .keyword { color : #cf1d1d } #main { color: black } .section {padding-top: 13px; padding-bottom: 13px; padding-left: 3px; margin-top: 5px; margin-bottom: 5px; font-size : 175% } h2.section {padding-left: 3px; padding-top: 12px; padding-bottom: 10px; font-size : 130% } h3.section {padding-left: 3px; padding-top: 7px; padding-bottom: 7px; font-size : 115% } h4.section { background-color: white; padding-left: 0px; padding-top: 0px; padding-bottom: 0px; font-size : 100%; font-style : bold; text-decoration : underline; } #main .doc { margin: 0px; font-family: sans-serif; font-size: 100%; line-height: 125%; color: black; padding-top: 10px; padding-bottom: 10px; border-style: plain} .inlinecode { display: inline; /* font-size: 125%; */ color: #666666; font-family: monospace } .doc .inlinecode { display: inline; font-size: 120%; color: rgb(30%,30%,70%); font-family: monospace } .doc .inlinecode .id { color: rgb(30%,30%,70%); } .inlinecodenm { display: inline; color: #444444; } .doc .code { display: inline; font-size: 120%; color: rgb(30%,30%,70%); font-family: monospace } .comment { display: inline; font-family: monospace; color: rgb(50%,50%,80%); } .code { display: block; /* padding-left: 15px; */ font-size: 110%; font-family: monospace; } table.infrule { border: 0px; margin-left: 50px; margin-top: 10px; margin-bottom: 10px; } td.infrule { font-family: monospace; text-align: center; /* color: rgb(35%,35%,70%); */ padding: 0px; line-height: 100%; } tr.infrulemiddle hr { margin: 1px 0 1px 0; } .infrulenamecol { color: rgb(60%,60%,60%); font-size: 80%; padding-left: 1em; padding-bottom: 0.1em } /* Pied de page */ #footer { font-size: 80%; font-family: sans-serif; } .id { display: inline; } .id[type="constructor"] { color: rgb(60%,0%,0%); } .id[type="var"] { color: rgb(40%,0%,40%); } .id[type="variable"] { color: rgb(40%,0%,40%); } .id[type="definition"] { color: rgb(0%,40%,0%); } .id[type="abbreviation"] { color: rgb(0%,40%,0%); } .id[type="lemma"] { color: rgb(0%,40%,0%); } .id[type="instance"] { color: rgb(0%,40%,0%); } .id[type="projection"] { color: rgb(0%,40%,0%); } .id[type="method"] { color: rgb(0%,40%,0%); } .id[type="inductive"] { color: rgb(0%,0%,80%); } .id[type="record"] { color: rgb(0%,0%,80%); } .id[type="class"] { color: rgb(0%,0%,80%); } .id[type="keyword"] { color : #cf1d1d; /* color: black; */ } .inlinecode .id { color: rgb(0%,0%,0%); } /* TOC */ #toc h2 { padding: 10px; } #toc li { padding-bottom: 8px; } /* Index */ #index { margin: 0; padding: 0; width: 100%; } #index #frontispiece { margin: 1em auto; padding: 1em; width: 60%; } .booktitle { font-size : 140% } .authors { font-size : 90%; line-height: 115%; } .moreauthors { font-size : 60% } #index #entrance { text-align: center; } #index #entrance .spacer { margin: 0 30px 0 30px; } #index #footer { position: absolute; bottom: 0; text-align: bottom; } .paragraph { height: 0.75em; } ul.doclist { margin-top: 0em; margin-bottom: 0em; } Coq-HoTT-9.0/etc/hoqthmdep000077500000000000000000000030041474641544500154250ustar00rootroot00000000000000#!/usr/bin/env bash # This is a wrapper around coqtop which tricks Coq into using the HoTT # standard library and enables the HoTT-specific options. function readlink_f() { # readlink -f doesn't work on Mac OS. So we roll our own readlink # -f, from # http://stackoverflow.com/questions/1055671/how-can-i-get-the-behavior-of-gnus-readlink-f-on-a-mac TARGET_FILE="$1" cd "$(dirname "$TARGET_FILE")" TARGET_FILE=`basename "$TARGET_FILE"` # Iterate down a (possible) chain of symlinks while [ -L "$TARGET_FILE" ] do TARGET_FILE=`readlink "$TARGET_FILE"` cd "$(dirname "$TARGET_FILE")" TARGET_FILE=`basename "$TARGET_FILE"` done # Compute the canonicalized name by finding the physical path # for the directory we're in and appending the target file. PHYS_DIR=`pwd -P` RESULT="$PHYS_DIR/$TARGET_FILE" echo "$RESULT" } mythmdepdir="$(dirname "$(readlink_f "${BASH_SOURCE[0]}")")/coq-dpdgraph" if [ ! -f "$mythmdepdir/../../hoq-config" ] then echo "Could not find hoq-config. Did you run ./configure?" exit 1 fi . "$mythmdepdir/../../hoq-config" # We could stick the arguments in hoq-config in COQ_ARGS, and then, # using (non-portable) bash arrays, do # $ exec "$COQTOP" "${COQ_ARGS[@]}" "$@" # or using more evil (but portable) 'eval', do # $ eval 'exec "$COQTOP" '"$COQ_ARGS"' "$@"' # Instead, we duplicate code, because it's simpler. exec "$COQTOP" -noinit -R "$HOTTLIB" HoTT -Q "$HOTTCONTRIB" HoTT.Contrib -Q "$mythmdepdir" "" -I "$mythmdepdir" -indices-matter "$@" Coq-HoTT-9.0/etc/install_coq.sh000077500000000000000000000025341474641544500163640ustar00rootroot00000000000000#!/usr/bin/env bash # exit immediately if you interrupt or kill this script trap "exit 1" SIGHUP SIGINT SIGTERM # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" pushd "$DIR" 1>/dev/null || exit 1 # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" pushd "$ROOT_DIR" 1>/dev/null || exit 1 if ! ( [ -d .git ] || [ -f .git ] ) then echo 'Error: we do not seem to be in a git working tree.' echo 'This script only works on a git clone of the HoTT repository.' exit 1 fi echo '$ git submodule sync' git submodule sync || exit 1 echo '$ git submodule update --init --recursive' git submodule update --init --recursive || exit 1 pushd coq-HoTT || exit 1 echo '$ ./configure -local '"$@" ./configure -local "$@" || exit 1 echo '$ make coqlight coqide' make coqlight coqide if [ $? -ne 0 ] then echo "make failed; cleaning the directory and trying again" sleep 3 git clean -xfd || echo 'WARNING: Cleaning failed' git reset --hard || echo 'WARNING: Cleaning failed' echo '$ ./configure -local '"$@" ./configure -local "$@" || exit 1 echo '$ make coqlight coqide' make coqlight coqide || exit 1 fi popd # now clean the HoTT repository, so that we don't have inconsistent compiled files echo '$ make clean' make clean popd 1>/dev/null popd 1>/dev/null Coq-HoTT-9.0/etc/install_coq_deps.sh000077500000000000000000000002331474641544500173710ustar00rootroot00000000000000#!/usr/bin/env bash sudo apt-get update -q sudo apt-get install -q curl sed grep wget tar m4 autoconf libgtk-3-dev libgtksourceview-3.0-dev libexpat1-dev Coq-HoTT-9.0/etc/pipe_out.sh000077500000000000000000000000631474641544500156730ustar00rootroot00000000000000#!/usr/bin/env bash file="$1" shift "$@" > "$file" Coq-HoTT-9.0/etc/time2html000077500000000000000000000044571474641544500153560ustar00rootroot00000000000000#!/usr/bin/env lua time = assert(select(1,...), "arg1 missing: output of coqc -time") vfile = assert(select(2,...), "arg2 missing: .v file") source = assert(io.open(vfile), "unable to open "..vfile):read("*a") function htmlescape(s) return (s:gsub("&","&"):gsub("<","<"):gsub(">",">")) end vname = vfile:match("([^/]+.v)$") print([[ ]]..vname..[[

Timings for ]]..vname..[[

]]) data = {} last_end = -1 lines = 1 for l in io.lines(time) do local b,e,t = l:match("^Chars ([%d]+) %- ([%d]+) [^ ]+ ([%d%.]+) secs") if b then if tonumber(b) > last_end + 1 then local text = string.sub(source,last_end+1,b-1) if not text:match('^%s+$') then local _, n = text:gsub('\n','') data[#data+1] = { start = last_end+1; stop = b-1; time = 0; text = text; lines = lines } lines = lines + n last_end = b end end local text = string.sub(source,last_end+1,e) local _, n = text:gsub('\n','') local _, eoln = text:match('^[%s\n]*'):gsub('\n','') data[#data+1] = { start = b; stop = e; time = tonumber(t); text = text; lines = lines } lines = lines + n last_end = tonumber(e) end end if last_end + 1 <= string.len(source) then local text = string.sub(source,last_end+1,string.len(source)) data[#data+1] = { start = last_end+1; stop = string.len(source); time = 0; text = text; lines = lines+1 } end max = 0; for _,d in ipairs(data) do max = math.max(max,d.time) end for _,d in ipairs(data) do print('
') print('
') if d.text == '\n' then print('
\n\n
') elseif d.text:match('\n$') then print('
'..htmlescape(d.text)..'\n
') else print('
'..htmlescape(d.text)..'
') end print("
") end print [[ ]] -- vim: set ts=4: --for i = 1,#data do -- io.stderr:write(data[i].text) --end Coq-HoTT-9.0/etc/update-TOCs000077500000000000000000000004531474641544500155310ustar00rootroot00000000000000#!/usr/bin/env bash # in case we're run from out of git repo DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" pushd "$DIR" 1>/dev/null # now change to the git root ROOT_DIR="$(git rev-parse --show-toplevel)" cd "$ROOT_DIR" 1>/dev/null doctoc STYLE.md --github || exit $? popd 1>/dev/null Coq-HoTT-9.0/flake.lock000066400000000000000000000027211474641544500146740ustar00rootroot00000000000000{ "nodes": { "flake-utils": { "inputs": { "systems": "systems" }, "locked": { "lastModified": 1726560853, "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", "owner": "numtide", "repo": "flake-utils", "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", "type": "github" }, "original": { "owner": "numtide", "repo": "flake-utils", "type": "github" } }, "nixpkgs": { "locked": { "lastModified": 1728336163, "narHash": "sha256-rISnMC117SHUI19jwOyoBpeH1lg0JkNUwDS2khhEXzc=", "owner": "NixOS", "repo": "nixpkgs", "rev": "df8a060c473cf49d3d3b0480f892ffcbea7bba41", "type": "github" }, "original": { "owner": "NixOS", "ref": "master", "repo": "nixpkgs", "type": "github" } }, "root": { "inputs": { "flake-utils": "flake-utils", "nixpkgs": "nixpkgs" } }, "systems": { "locked": { "lastModified": 1681028828, "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", "owner": "nix-systems", "repo": "default", "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", "type": "github" }, "original": { "owner": "nix-systems", "repo": "default", "type": "github" } } }, "root": "root", "version": 7 } Coq-HoTT-9.0/flake.nix000066400000000000000000000025251474641544500145440ustar00rootroot00000000000000{ description = "A Coq library for Homotopy Type Theory"; inputs = { nixpkgs.url = "github:NixOS/nixpkgs/master"; flake-utils.url = "github:numtide/flake-utils"; }; outputs = { self, nixpkgs, flake-utils }: flake-utils.lib.eachDefaultSystem (system: let pkgs = nixpkgs.legacyPackages.${system}; makeDevShell = { coq ? pkgs.coq }: let coqPackages = pkgs.mkCoqPackages coq // { __attrsFailEvaluation = true; }; in { extraPackages ? [ coqPackages.coq-lsp ] }: pkgs.mkShell { buildInputs = [ pkgs.dune_3 pkgs.ocaml ] ++ extraPackages ++ [ coq ]; }; in { packages.default = pkgs.coqPackages.mkCoqDerivation { pname = "hott"; version = "8.20"; src = self; useDune = true; }; devShells.default = makeDevShell { coq = pkgs.coq_8_20; } { }; devShells.coq_8_19 = makeDevShell { coq = pkgs.coq_8_19; } { }; # To use, pass --impure to nix develop devShells.coq_master = makeDevShell { coq = pkgs.coq.override { version = "master"; }; } { extraPackages = [ ]; }; formatter = pkgs.nixpkgs-fmt; }); } Coq-HoTT-9.0/test/000077500000000000000000000000001474641544500137155ustar00rootroot00000000000000Coq-HoTT-9.0/test/Algebra/000077500000000000000000000000001474641544500152525ustar00rootroot00000000000000Coq-HoTT-9.0/test/Algebra/Groups/000077500000000000000000000000001474641544500165315ustar00rootroot00000000000000Coq-HoTT-9.0/test/Algebra/Groups/Expressions.v000066400000000000000000000105211474641544500212410ustar00rootroot00000000000000From HoTT Require Import Basics.Overture Groups.Group AbGroups.AbelianGroup. Set Universe Minimization ToSet. (** In this file, we test various aspects of writing group expressions. These kinds of expressions appear throughout the library, but since mathclasses is quite sensitive to subtle changes, we keep this file to document and enforce certain behaviours. We use the [Type] vernacular command which is like [Check] but doesn't allow for evars. *) Section Groups. (** We used a fixed universe of groups since the [Type] command doesn't work with polymorphic universes. *) Context {G : Group@{Set}} (x y : G). (** Without opening any scopes, the notation [x * y] will default to the one in [type_scope] which is the product type. In this case it will fail since Coq is expecting a type argument rather than [x : G]. *) Fail Type (x * y : G). (** [x^] will be interpreted as path inversion, therefore Coq will complain about its type. *) Fail Type (x^ : G). (** In [mc_scope], [_ * _] denotes an instance of [Mult], which groups do not have. It is useful for rings, see below. *) Local Open Scope mc_scope. (** We fail saying that no [Mult] instance was found for [G] as expected. *) Fail Type (x * y : G). (** Here [^] is still interpreted as path inversion. *) Fail Type (x^ : G). Local Close Scope mc_scope. (** The correct scope for a general group is [mc_mult_scope], where [x * y] is [sg_op x y] and [^] is [inv]. *) Local Open Scope mc_mult_scope. (** This gets correctly interpreted as the group operation. *) Succeed Type (x * y : G). (** So does the group inverse. *) Succeed Type (x^ * y : G). End Groups. Section AbGroups. Context {A : AbGroup@{Set}} (x y : A). (** Working with abelian groups can be confusing if the correct scopes are not open. We document the correct usage here. *) (** Similar to [*], without any scopes open, the following expression fails since Coq interprets it as the sum type. *) Fail Type (x + y : A). (** The [- _] notation doesn't have any meaning when the correct scope is not open. *) Fail Type (-x : A). (** Nor does the subtraction notation. *) Fail Type (x - y : A). (** Opening [mc_scope] will mean that: - [+] becomes the operation of a [Plus]. - [- x] becomes a [Negate] operation. - [x - y] is interpreted as [x + (- y)] for a [Negate] and [Plus]. *) Local Open Scope mc_scope. (** Notably, even though these instances exist for [Ring]s, they do not in general for abelian groups as we treat those as groups with a commutative [sg_op] rather than a [plus] operation. This allows us to use group lemmas without deforming abelian group expressions. *) (** These fail due to a lack of [Plus]. *) Fail Type (x + y : A). Fail Type (x - y : A). (** This fails due to a lack of [Negate]. *) Fail Type (-x : A). Local Close Scope mc_scope. (** Opening [mc_add_scope] will make writing expressions of abelian groups possible. *) Local Open Scope mc_add_scope. Succeed Type (x + y : A). Succeed Type (-x : A). Succeed Type (-x + y : A). Succeed Type (x - y : A). Local Close Scope mc_add_scope. (** We can also work with the abelian group with a multiplicative notation, as we would for any group. *) Local Open Scope mc_mult_scope. Succeed Type (x * y : A). Succeed Type (x^ : A). Succeed Type (x^ * y : A). (** This can get confusing if we further allow for additive notations to also be shown, so only one of [mc_add_scope] and [mc_mult_scope] should be used. *) Local Open Scope mc_add_scope. Succeed Type (-x * y + x^). Succeed Type (-x^ + --x^). Local Close Scope mc_add_scope. Local Close Scope mc_mult_scope. (** Sometimes, as when working with rings, we want [+] to denote [plus] rather than [sg_op]. In this case, we include a module with hints which can be imported. *) Import AbelianGroup.AdditiveInstances. Local Open Scope mc_scope. (** This allows us to write additive notations even though we don't have [mc_add_scope] or [mc_mult_scope] open. The disadvantage of working like this however, is that any group lemmas applied to abelian groups will have their [plus], [zero] and [negate] unfolded to the underlying group operations. *) Succeed Type (x + y : A). Succeed Type (-x : A). Succeed Type (-x + y : A). Succeed Type (x - y : A). Local Close Scope mc_scope. End AbGroups. Coq-HoTT-9.0/test/Algebra/Groups/Presentation.v000066400000000000000000000005401474641544500213720ustar00rootroot00000000000000From HoTT Require Import Basics Spaces.Finite.Fin Spaces.Finite.FinSeq. From HoTT.Algebra.Groups Require Import Group Presentation FreeGroup. Local Open Scope mc_scope. Local Open Scope mc_mult_scope. Check ⟨ x | x * x * x , x^ ⟩. Check ⟨ x , y | x * y , x * y * x , x * y^ * x * x * x⟩. Check ⟨ x , y , z | x * y * z , x * z^ , x * y⟩. Coq-HoTT-9.0/test/Algebra/Rings/000077500000000000000000000000001474641544500163345ustar00rootroot00000000000000Coq-HoTT-9.0/test/Algebra/Rings/Expressions.v000066400000000000000000000013771474641544500210550ustar00rootroot00000000000000From HoTT Require Import Basics.Overture Algebra.Rings.Ring. Set Universe Minimization ToSet. (** In this file, we test various aspects of writing group expressions. These kinds of expressions appear throughout the library, but since mathclasses is quite sensitive to subtle changes, we keep this file to document and enforce certain behaviours. We use the [Type] vernacular command which is like [Check] but doesn't allow for evars. *) Section Rings. Context {R : Ring@{Set}} (x y : R). (** [mc_scope] is appropriate for rings. *) Local Open Scope mc_scope. Succeed Type (x + y : R). Succeed Type (x - y : R). Succeed Type (x * y * x - x * y : R). Succeed Type (x - y : R). Succeed Type (x - y : R). Local Close Scope mc_scope. End Rings. Coq-HoTT-9.0/test/Algebra/Rings/Matrix.v000066400000000000000000000053071474641544500177740ustar00rootroot00000000000000From HoTT Require Import Basics. From HoTT Require Import Algebra.Rings.Matrix. From HoTT Require Import Spaces.Nat.Core Spaces.List.Core. From HoTT Require Import Algebra.Rings.Z Spaces.Int Algebra.Rings.CRing. From HoTT Require Import Classes.interfaces.canonical_names. Local Open Scope mc_scope. Local Open Scope nat_scope. Local Open Scope list_scope. (** Matrices can be built with lists of lists. *) Definition test1 := Build_Matrix' nat 5 7 [ [ 1 , 2 , 3 , 4 , 5 , 6 , 7 ] , [ 8 , 9 , 10 , 11 , 12 , 13 , 14 ] , [ 15 , 16 , 17 , 18 , 19 , 20 , 21 ] , [ 22 , 23 , 24 , 25 , 26 , 27 , 28 ] , [ 29 , 30 , 31 , 32 , 33 , 34 , 35 ] ] ltac:(decide) ltac:(decide). (** Malformed matrices are not accepted. *) Fail Definition test2 := Build_Matrix' nat 2 2 [ [ 1 , 2 ] , [ 3 , 4 , 5] ] ltac:(decide) ltac:(decide). (** Matrices can also be built with functions. *) Definition test2_A := Build_Matrix nat 4 4 (fun i j _ _ => i * j). Definition test2_B := Build_Matrix' nat 4 4 [ [ 0 , 0 , 0 , 0 ] , [ 0 , 1 , 2 , 3 ] , [ 0 , 2 , 4 , 6 ] , [ 0 , 3 , 6 , 9 ] ] ltac:(decide) ltac:(decide). Definition test2 : entries test2_A = entries test2_B := idpath. Local Open Scope int_scope. (** Matrices with ring entries can be multiplied *) (** This is the first matrix. *) Definition test3_A := Build_Matrix' cring_Z 3 2 [ [ 1 , 3 ] , [ 2 , -1 ] , [ 1 , 1 ] ] ltac:(decide) ltac:(decide). (** This is the second matrix. *) Definition test3_B := Build_Matrix' cring_Z 2 4 [ [ 4 , 1 , 0 , -2 ] , [ -1 , 1 , 5 , 1 ] ] ltac:(decide) ltac:(decide). (** This is the expected result of the multiplication. *) Definition test3_AB := Build_Matrix' cring_Z 3 4 [ [ 1 , 4 , 15 , 1 ] , [ 9 , 1 , -5 , -5 ] , [ 3 , 2 , 5 , -1 ] ] ltac:(decide) ltac:(decide). (** The entries should be the same, although the well-formedness proofs may differ definitionally. *) Definition test3 : entries (matrix_mult test3_A test3_B) = entries test3_AB := idpath. (** Here we check the minors of a matrix are computed correctly. *) Definition test4 := Build_Matrix' cring_Z 3 3 [ [ 1 , 3 , 5 ] , [ 2 , 4 , 6 ] , [ 7 , 8 , 9 ] ] ltac:(decide) ltac:(decide). Definition test4_minor_0_1 := Build_Matrix' cring_Z 2 2 [ [ 2 , 6 ] , [ 7 , 9 ] ] ltac:(decide) ltac:(decide). Definition test4_minor_0_1_eq : entries (matrix_minor 0 1 test4) = entries test4_minor_0_1 := idpath. Definition test4_minor_1_1 := Build_Matrix' cring_Z 2 2 [ [ 1 , 5 ] , [ 7 , 9 ] ] ltac:(decide) ltac:(decide). Definition test4_minor_1_1_eq : entries (matrix_minor 1 1 test4) = entries test4_minor_1_1 := idpath. Coq-HoTT-9.0/test/Algebra/Rings/Ring.v000066400000000000000000000016171474641544500174270ustar00rootroot00000000000000From HoTT Require Import Basics.Overture Algebra.Rings.Ring Algebra.Rings.CRing. From HoTT.Algebra Require Import Groups.Group AbGroups.AbelianGroup. From HoTT Require Import abstract_algebra. Local Open Scope path_scope. (** Test that opposite rings are definitionally involutive. *) Definition test1 (R : Ring) : R = (rng_op (rng_op R)) :> Ring := 1. (** This may look funny, but you will see that Coq discards the [rng_op] during elaboration meaning that we only have [R = R] at the end. The reason this works is that [rng_op] takes in only a [Ring]. Afterwards, Coq is able to see that [rng_op (rng_op R)] should be a [CRing] and the coercion from [Ring] to [CRing] is reversible, therefore Coq tries to unify it with the original commutative ring. This behaviour is a bit surprising but is harmless so we just document it here. *) Definition test2 (R : CRing) : R = (rng_op (rng_op R)) :> CRing := 1. Coq-HoTT-9.0/test/Classes/000077500000000000000000000000001474641544500153125ustar00rootroot00000000000000Coq-HoTT-9.0/test/Classes/ring_tac.v000066400000000000000000000017731474641544500172770ustar00rootroot00000000000000From HoTT Require Import Classes.interfaces.abstract_algebra Classes.implementations.peano_naturals Classes.orders.sum Classes.tactics.ring_tac Classes.tactics.ring_quote. Import Quoting.Instances. Generalizable Variables R. Lemma test1 `{IsSemiCRing R} : forall x y : R, x + (y * x) = x * (y + 1). Proof. intros. ring_with_nat. Qed. Require Import HoTT.Classes.interfaces.naturals. Lemma test2 `{IsSemiCRing R} : forall x y : R, x + (y * x) = x * (y + 1). Proof. intros. apply (by_quoting (naturals_to_semiring nat R)). compute. reflexivity. Qed. Lemma test3 `{IsSemiCRing R} (pa pb pc : R) : pa * (pb * pc) = pa * pb * pc. Proof. intros. apply (by_quoting (naturals_to_semiring nat R)). compute. reflexivity. Qed. Lemma test4 `{IsSemiCRing R} (a b : R) : a * b = b * a. Proof. apply (ring_quote.Quoting.eval_eqquote R). apply (prove_prequoted (naturals_to_semiring nat R)). reflexivity. Qed. Lemma test5 : forall x y : nat, x + (y * x) = x * (y + 1). Proof. intros;ring_with_nat. Qed. Coq-HoTT-9.0/test/Idempotents.v000066400000000000000000000007161474641544500164030ustar00rootroot00000000000000From HoTT Require Import Idempotents. (** Note that [Idempotent X], unlike [RetractOf X], lives in the same universe as [X], even if we demand that it contain the identity. *) Check (fun (X:Type@{i}) => (idem_idmap X : (Idempotent X : Type@{i}))). (** By contrast, [RetractOf X] does not live in the same universe as [X] if it is required to contain the identity retraction. *) Fail Check (fun (X:Type@{i}) => (idmap_retractof X : (RetractOf X : Type@{i}))). Coq-HoTT-9.0/test/Metatheory/000077500000000000000000000000001474641544500160365ustar00rootroot00000000000000Coq-HoTT-9.0/test/Metatheory/FunextVarieties.v000066400000000000000000000003071474641544500213520ustar00rootroot00000000000000From HoTT.Metatheory Require Import FunextVarieties. (** Checking the universes of FunextVarieties.v *) Check NaiveFunext@{i j max}. Check NaiveNondepFunext@{i j max}. Check WeakFunext@{i j max}. Coq-HoTT-9.0/test/Metatheory/UnivalenceImpliesFunext.v000066400000000000000000000005251474641544500230350ustar00rootroot00000000000000From HoTT Require Import Basics. From HoTT.Metatheory Require Import Core FunextVarieties UnivalenceImpliesFunext. (** Note that only the codomain universe of [NaiveNondepFunext] is required to be univalent. *) Check @Univalence_implies_FunextNondep@{j jplusone i max j max} : Univalence_type@{j jplusone} -> NaiveNondepFunext@{i j max}. Coq-HoTT-9.0/test/Pointed/000077500000000000000000000000001474641544500153175ustar00rootroot00000000000000Coq-HoTT-9.0/test/Pointed/Core.v000066400000000000000000000010141474641544500163720ustar00rootroot00000000000000From HoTT Require Import Basics.Overture Pointed.Core. (** Test pelim tactic. *) Open Scope pointed_scope. (** Check that it works for types with explicit base points. *) Definition test1 {X Y : Type} {x : X} {y : Y} (f : [X,x] ->* [Y,y]) : (f x = y) * (point_eq f = point_eq f). Proof. pelim f. split; reflexivity. Defined. (** Check that it works for pointed equivalences. *) Definition test2 {X Y : pType} (f : X <~>* Y) : (f pt = pt) * (point_eq f = point_eq f). Proof. pelim f. split; reflexivity. Defined. Coq-HoTT-9.0/test/README.md000066400000000000000000000014361474641544500152000ustar00rootroot00000000000000# Tests Sometimes there are properties of the library that we would like to test without polluting it with examples and noisy output. Such tests are collected here. We also collect regression tests from various issues and PRs in a subdirectory called `bugs/`. ## Adding a test To add a test, create a new .v file in a subdirectory of this directory. When testing properties of the library, use the same directory structure. For instance, tests about suspensions should be in `test/Homotopy/Suspension.v`. Place regression tests in the subdirectory `bugs`, using file name `github.v` or `github.v`. For example, if you are adding a test for issue #123, the file name should be `test/bugs/github123.v`. ## Running tests To run the tests, simply run ``` dune test ``` Coq-HoTT-9.0/test/Spaces/000077500000000000000000000000001474641544500151335ustar00rootroot00000000000000Coq-HoTT-9.0/test/Spaces/List.v000066400000000000000000000071321474641544500162400ustar00rootroot00000000000000From HoTT Require Import Basics. From HoTT.Spaces.List Require Import Core Theory. (** Here we check the number of universe variables for the definitions from List.Core *) Succeed Check list@{_}. Succeed Check nil@{_}. Succeed Check cons@{_}. Succeed Check list_rect@{_ _}. Succeed Check list_ind@{_ _}. Succeed Check list_rec@{_ _}. Succeed Check length@{_}. Succeed Check app@{_}. Succeed Check fold_left@{_ _}. Succeed Check fold_right@{_ _}. Succeed Check list_map@{_ _}. Succeed Check list_map2@{_ _ _}. Succeed Check reverse_acc@{_}. Succeed Check reverse@{_}. Succeed Check head@{_}. Succeed Check tail@{_}. Succeed Check last@{_}. Succeed Check nth@{_}. Succeed Check remove_last@{_}. Succeed Check seq_rev@{}. Succeed Check seq@{}. Succeed Check repeat@{_}. Succeed Check InList@{_}. Succeed Check for_all@{_ _}. (** Here we check the number of universe variables for the definitions from List.Theory *) Succeed Check length_0@{_}. Succeed Check app_nil@{_}. Succeed Check app_assoc@{_}. Succeed Check list_pentagon@{_}. Succeed Check length_app@{_}. Succeed Check equiv_inlist_app@{_}. Succeed Check fold_left_app@{_ _}. Succeed Check fold_right_app@{_ _}. Succeed Check length_list_map@{_ _}. Succeed Check inlist_map@{_ _}. Succeed Check inlist_map'@{_ _ _}. Succeed Check list_map_id@{_}. Succeed Check list_map_compose@{_ _ _}. Succeed Check length_list_map2@{_ _ _}. Succeed Check inlist_map2@{_ _ _ _}. Succeed Check list_map2_repeat_l@{_ _ _}. Succeed Check list_map2_repeat_r@{_ _ _}. Succeed Check length_reverse_acc@{_}. Succeed Check length_reverse@{_}. Succeed Check list_map_reverse_acc@{_ _}. Succeed Check list_map_reverse@{_ _}. Succeed Check reverse_acc_cons@{_}. Succeed Check reverse_cons@{_}. Succeed Check nth_lt@{_}. Succeed Check nth'@{_}. Succeed Check nth'_nth'@{_}. Succeed Check inlist_nth'@{_}. Succeed Check nth_nth'@{_}. Succeed Check nth'_cons@{_}. Succeed Check index_of@{_}. Succeed Check nth_list_map@{_ _}. Succeed Check nth'_list_map@{_ _}. Succeed Check nth'_list_map2@{_ _ _}. Succeed Check nth'_repeat@{_}. Succeed Check path_list_nth'@{_}. Succeed Check nth_app@{_}. Succeed Check nth_last@{_}. Succeed Check last_app@{_}. Succeed Check drop@{_}. Succeed Check drop_0@{_}. Succeed Check drop_1@{_}. Succeed Check drop_nil@{_}. Succeed Check drop_length_leq@{_}. Succeed Check length_drop@{_}. Succeed Check drop_inlist@{_}. Succeed Check take@{_}. Succeed Check take_0@{_}. Succeed Check take_nil@{_}. Succeed Check take_length_leq@{_}. Succeed Check length_take@{_}. Succeed Check take_inlist@{_}. Succeed Check remove@{_}. Succeed Check remove_0@{_}. Succeed Check remove_length_leq@{_}. Succeed Check length_remove@{_}. Succeed Check remove_inlist@{_}. Succeed Check length_seq_rev@{}. Succeed Check length_seq@{}. Succeed Check seq_rev_cons@{}. Succeed Check seq_succ@{}. Succeed Check seq_rev'@{}. Succeed Check seq'@{}. Succeed Check length_seq_rev'@{}. Succeed Check length_seq'@{}. Succeed Check seq_rev_seq_rev'@{}. Succeed Check seq_seq'@{}. Succeed Check nth_seq_rev@{}. Succeed Check nth_seq@{}. Succeed Check nth'_seq'@{}. Succeed Check length_repeat@{_}. Succeed Check inlist_repeat@{_}. Succeed Check for_all_inlist@{_ _}. Succeed Check inlist_for_all@{_ _}. Succeed Check for_all_list_map@{_ _ _ _}. Succeed Check for_all_list_map'@{_ _ _}. Succeed Check for_all_list_map2@{_ _ _ _ _ _}. Succeed Check for_all_list_map2'@{_ _ _ _ _ _}. Succeed Check fold_left_preserves@{_ _ _ _}. Succeed Check istrunc_for_all@{_ _}. Succeed Check istrunc_for_all'@{_ _}. Succeed Check for_all_repeat@{_ _}. Succeed Check list_sigma@{_ _ _}. Succeed Check length_list_sigma@{_ _ _}. Succeed Check decidable_for_all@{_ _}. Coq-HoTT-9.0/test/WildCat/000077500000000000000000000000001474641544500152445ustar00rootroot00000000000000Coq-HoTT-9.0/test/WildCat/Opposite.v000066400000000000000000000070301474641544500172350ustar00rootroot00000000000000From HoTT Require Import Basics WildCat.Core WildCat.Opposite WildCat.Equiv WildCat.NatTrans WildCat.Bifunctor WildCat.Monoidal. (** Opposites are definitionally involutive. *) Succeed Definition test A : A = (A^op)^op :> Type := 1. Succeed Definition test A `{x : IsGraph A} : x = @isgraph_op A^op (@isgraph_op A x) := 1. Succeed Definition test A `{x : Is01Cat A} : x = @is01cat_op A^op _ (@is01cat_op A _ x) := 1. Succeed Definition test A `{x : Is2Graph A} : x = @is2graph_op A^op _ (@is2graph_op A _ x) := 1. Succeed Definition test A `{x : Is1Cat A} : x = @is1cat_op A^op _ _ _ (@is1cat_op A _ _ _ x) := 1. (** [core] only partially commutes with taking the opposite category. *) Succeed Definition test A `{HasEquivs A} : (core A)^op = core A^op :> Type := 1. Succeed Definition test A `{HasEquivs A} : isgraph_op (A:=core A) = isgraph_core (A:=A^op) := 1. Succeed Definition test A `{HasEquivs A} : is01cat_op (A:=core A) = is01cat_core (A:=A^op) := 1. Succeed Definition test A `{HasEquivs A} : is2graph_op (A:=core A) = is2graph_core (A:=A^op) := 1. (** The Opaque line reduces the time from 0.3s to 0.07s. *) Opaque compose_catie_isretr. Succeed Definition test A `{HasEquivs A} : is1cat_op (A:=core A) = is1cat_core (A:=A^op) := 1. (** Opposite functors are definitionally involutive. *) Succeed Definition test A B (F : A -> B) `{x : Is0Functor A B F} : @is0functor_op _ _ F _ _ (@is0functor_op _ _ F _ _ x) = x := 1. Succeed Definition test A B (F : A -> B) `{x : Is1Functor A B F} : @is1functor_op _ _ F _ _ _ _ _ _ _ _ _ (@is1functor_op _ _ F _ _ _ _ _ _ _ _ _ x) = x := 1. (** Opposite bifunctors are definitionally involutive. *) Succeed Definition test A B C (F : A -> B -> C) `{x : Is0Bifunctor A B C F} : @is0bifunctor_op _ _ _ F _ _ _ (@is0bifunctor_op _ _ _ F _ _ _ x) = x := 1. Succeed Definition test A B C (F : A -> B -> C) `{x : Is1Bifunctor A B C F} : @is1bifunctor_op _ _ _ F _ _ _ _ _ _ _ _ _ _ _ _ _ (@is1bifunctor_op _ _ _ F _ _ _ _ _ _ _ _ _ _ _ _ _ x) = x := 1. (** Opposite natural transformations are definitionally involutive. *) Succeed Definition test A `{Is01Cat A} B `{Is1Cat B} (F G : A -> B) `{!Is0Functor F, !Is0Functor G} (n : NatTrans F G) : nattrans_op (nattrans_op n) = n := 1. (** Opposite natural equivalences are definitionally involutive. *) Succeed Definition test A `{Is01Cat A} B `{HasEquivs B} (F G : A -> B) `{!Is0Functor F, !Is0Functor G} (n : NatEquiv F G) : natequiv_op (natequiv_op n) = n := 1. (** Opposite left unitors are *not* definitionally involutive. *) Fail Definition test A `{HasEquivs A} (unit : A) (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : LeftUnitor F unit) : @left_unitor_op _ _ _ _ _ _ F unit _ _ (@left_unitor_op _ _ _ _ _ _ F unit _ _ a) = a := 1. (** Opposite right unitors are *not* definitionally involutive. *) Fail Definition test A `{HasEquivs A} (unit : A) (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : RightUnitor F unit) : @right_unitor_op _ _ _ _ _ _ F unit _ _ (@right_unitor_op _ _ _ _ _ _ F unit _ _ a) = a := 1. (** Opposite associators are *not* definitionally involutive. *) Fail Definition test A `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : Associator F) : @associator_op _ _ _ _ _ _ F _ _ (@associator_op _ _ _ _ _ _ F _ _ a) = a := 1. (** Opposite braidings are definitionally involutive. *) Succeed Definition test A `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : Braiding F) : @braiding_op _ _ _ _ _ _ _ _ _ (@braiding_op _ _ _ _ _ _ _ _ _ a) = a := 1. Coq-HoTT-9.0/test/bugs/000077500000000000000000000000001474641544500146555ustar00rootroot00000000000000Coq-HoTT-9.0/test/bugs/github1358.v000066400000000000000000000003601474641544500166460ustar00rootroot00000000000000From HoTT Require Import Basics. Axiom A@{i} : Type@{i}. Axiom foo@{i} : A@{i} <~> A@{i}. Definition bar@{i} : A@{i} <~> A@{i}. Proof. reflexivity. Defined. Definition bar'@{i} : A@{i} <~> A@{i}. Proof. exact equiv_idmap. Defined. Coq-HoTT-9.0/test/bugs/github1382.v000066400000000000000000000012731474641544500166470ustar00rootroot00000000000000From HoTT Require Import Basics Types. (* Tests for discriminate tactic *) Goal O = S O -> Empty. discriminate 1. Qed. Goal forall H : O = S O, H = H. discriminate H. Qed. Goal O = S O -> Unit. intros H. discriminate H. Qed. Goal O = S O -> Unit. intros H. Ltac g x := discriminate x. g H. Qed. Goal (forall x y : nat, x = y -> x = S y) -> Unit. intros. try discriminate (H O) || exact tt. Qed. Goal (forall x y : nat, x = y -> x = S y) -> Unit. intros H. ediscriminate (H O). instantiate (1:=O). Abort. (* Check discriminate on types with local definitions *) Inductive A : Type0 := B (T := Unit) (x y : Bool) (z := x). Goal forall x y, B x true = B y false -> Empty. discriminate. Qed. Coq-HoTT-9.0/test/bugs/github1758.v000066400000000000000000000035101474641544500166520ustar00rootroot00000000000000From HoTT Require Import Basics.Overture HIT.Interval HIT.Flattening Colimits.GraphQuotient Spaces.Torus.Torus Cubical.DPath. (* Test that various higher inductive types are defined correctly. If they are defined in the most naive way, two uses of the induction principle that are definitionally equal on the point constructors will be considered definitionally equal, which is inconsistent. There is an idiom that must be used in order to force Coq to regard the supplementary data as being required as well. See, for example, Colimits/GraphQuotient.v for the idiom. *) Fail Definition test_interval (P : interval -> Type) (a : P zero) (b : P one) (p p' : seg # a = b) : interval_ind P a b p = interval_ind P a b p' := 1. Fail Definition test_wtil {A B f g C D} (Q : Wtil A B f g C D -> Type) (cct' : forall a x, Q (cct a x)) (ppt' : forall b y, (ppt b y) # (cct' (f b) y) = cct' (g b) (D b y)) (ppt'' : forall b y, (ppt b y) # (cct' (f b) y) = cct' (g b) (D b y)) : Wtil_ind Q cct' ppt' = Wtil_ind Q cct' ppt'' := 1. Section GraphQuotient_bug. Local Definition R : Unit -> Unit -> Type := fun x y => Unit. (* This should be the circle. *) Local Definition Q := GraphQuotient R. (* This is the identity map. *) Local Definition id : Q -> Q := GraphQuotient_rec gq (fun a b r => gqglue r). (* This is the constant map. *) Local Definition cst : Q -> Q. Proof. refine (GraphQuotient_rec gq _). intros [] [] r. reflexivity. Defined. Fail Definition test_graphquotient : id = cst := 1. End GraphQuotient_bug. Fail Definition test_torus (P : Torus -> Type) (pb : P tbase) (pla pla' : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb) (ps : DPathSquare P surf pla pla plb plb) (ps' : DPathSquare P surf pla' pla' plb plb) : Torus_ind P pb pla plb ps = Torus_ind P pb pla' plb ps' := 1. Coq-HoTT-9.0/test/bugs/github1759.v000066400000000000000000000510121474641544500166530ustar00rootroot00000000000000From HoTT Require Import Basics Spaces.No.Core. (** HITs need to be defined carefully in Coq. If they are defined in the most naive way, two uses of the induction principle that are definitionally equal on the point constructors will be considered definitionally equal, which may be inconsistent. There is an idiom that must be used in order to force Coq to regard the supplementary data as being required as well. See, for example, Colimits/GraphQuotient.v for the idiom. The HIT used in Spaces.No.Core is complicated, so it can't be written using the usual idiom, but instead uses [revert] and [intros] The first section below shows that the most obvious way to use [No_ind] does depend on at least one of [dcut], [dle_lr], [dlt_l] and [dlt_r]. The second section shows that [No_ind] does depend on [ishprop_le]. And the third section shows that it does depend on [dlt_r]. *) Section Foo. Universe i. Context {S : OptionSort@{i}}. Notation GenNo := (GenNo S). Local Open Scope surreal_scope. Context (A : GenNo -> Type) (dle : forall (x y : GenNo), (x <= y) -> A x -> A y -> Type) (dlt : forall (x y : GenNo), (x < y) -> A x -> A y -> Type) {ishprop_le : forall x y a b p, IsHProp (dle x y p a b)} {ishprop_lt : forall x y a b p, IsHProp (dlt x y p a b)} (dcut : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)), A {{ xL | xR // xcut }}) (dcut' : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)), A {{ xL | xR // xcut }}) (dpath : forall (x y : GenNo) (a:A x) (b:A y) (p : x <= y) (q : y <= x) (dp : dle x y p a b) (dq : dle y x q b a), path_No _ _ p q # a = b) (dle_lr : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (p : forall (l:L), xL l < {{ yL | yR // ycut }}) (dp : forall (l:L), dlt _ _ (p l) (fxL l) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (q : forall (r:R'), {{ xL | xR // xcut }} < yR r) (dq : forall (r:R'), dlt _ _ (q r) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyR r)), dle {{ xL | xR // xcut }} {{ yL | yR // ycut }} (le_lr xL xR xcut yL yR ycut p q) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dle_lr' : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (p : forall (l:L), xL l < {{ yL | yR // ycut }}) (dp : forall (l:L), dlt _ _ (p l) (fxL l) (dcut' _ _ _ yL yR ycut fyL fyR fycut)) (q : forall (r:R'), {{ xL | xR // xcut }} < yR r) (dq : forall (r:R'), dlt _ _ (q r) (dcut' _ _ _ xL xR xcut fxL fxR fxcut) (fyR r)), dle {{ xL | xR // xcut }} {{ yL | yR // ycut }} (le_lr xL xR xcut yL yR ycut p q) (dcut' _ _ _ xL xR xcut fxL fxR fxcut) (dcut' _ _ _ yL yR ycut fyL fyR fycut)) (dlt_l : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (l : L') (p : {{ xL | xR // xcut }} <= yL l) (dp : dle _ _ p (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyL l)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_l xL xR xcut yL yR ycut l p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_l' : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (l : L') (p : {{ xL | xR // xcut }} <= yL l) (dp : dle _ _ p (dcut' _ _ _ xL xR xcut fxL fxR fxcut) (fyL l)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_l xL xR xcut yL yR ycut l p) (dcut' _ _ _ xL xR xcut fxL fxR fxcut) (dcut' _ _ _ yL yR ycut fyL fyR fycut)) (dlt_r : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (r : R) (p : (xR r) <= {{ yL | yR // ycut }}) (dp : dle _ _ p (fxR r) (dcut _ _ _ yL yR ycut fyL fyR fycut)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_r xL xR xcut yL yR ycut r p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_r' : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (r : R) (p : (xR r) <= {{ yL | yR // ycut }}) (dp : dle _ _ p (fxR r) (dcut' _ _ _ yL yR ycut fyL fyR fycut)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_r xL xR xcut yL yR ycut r p) (dcut' _ _ _ xL xR xcut fxL fxR fxcut) (dcut' _ _ _ yL yR ycut fyL fyR fycut)). Definition foo : forall x, A x := No_ind A dle dlt dcut dpath dle_lr dlt_l dlt_r. Definition bar : forall x, A x := No_ind A dle dlt dcut' dpath dle_lr' dlt_l' dlt_r'. Fail Definition foobar : forall x, foo x = bar x := fun _ => 1. End Foo. Section Foo2. Universe i. Context {S : OptionSort@{i}}. Notation GenNo := (GenNo S). Local Open Scope surreal_scope. Context (A : GenNo -> Type) (dle : forall (x y : GenNo), (x <= y) -> A x -> A y -> Type) (dlt : forall (x y : GenNo), (x < y) -> A x -> A y -> Type) {ishprop_le : forall x y a b p, IsHProp (dle x y p a b)} {ishprop_le' : forall x y a b p, IsHProp (dle x y p a b)} {ishprop_lt : forall x y a b p, IsHProp (dlt x y p a b)} (dcut : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)), A {{ xL | xR // xcut }}) (dpath : forall (x y : GenNo) (a:A x) (b:A y) (p : x <= y) (q : y <= x) (dp : dle x y p a b) (dq : dle y x q b a), path_No _ _ p q # a = b) (dle_lr : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (p : forall (l:L), xL l < {{ yL | yR // ycut }}) (dp : forall (l:L), dlt _ _ (p l) (fxL l) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (q : forall (r:R'), {{ xL | xR // xcut }} < yR r) (dq : forall (r:R'), dlt _ _ (q r) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyR r)), dle {{ xL | xR // xcut }} {{ yL | yR // ycut }} (le_lr xL xR xcut yL yR ycut p q) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_l : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (l : L') (p : {{ xL | xR // xcut }} <= yL l) (dp : dle _ _ p (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyL l)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_l xL xR xcut yL yR ycut l p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_r : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (r : R) (p : (xR r) <= {{ yL | yR // ycut }}) (dp : dle _ _ p (fxR r) (dcut _ _ _ yL yR ycut fyL fyR fycut)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_r xL xR xcut yL yR ycut r p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)). Definition foo2 : forall x, A x := @No_ind S A dle dlt ishprop_le ishprop_lt dcut dpath dle_lr dlt_l dlt_r. Definition bar2 : forall x, A x := @No_ind S A dle dlt ishprop_le' ishprop_lt dcut dpath dle_lr dlt_l dlt_r. Fail Definition foobar2 : forall x, foo2 x = bar2 x := fun _ => 1. End Foo2. Section Foo3. Universe i. Context (S : OptionSort@{i}). Notation GenNo := (GenNo S). Local Open Scope surreal_scope. Context (A : GenNo -> Type) (dle : forall (x y : GenNo), (x <= y) -> A x -> A y -> Type) (dlt : forall (x y : GenNo), (x < y) -> A x -> A y -> Type) {ishprop_le : forall x y a b p, IsHProp (dle x y p a b)} {ishprop_lt : forall x y a b p, IsHProp (dlt x y p a b)} (dcut : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)), A {{ xL | xR // xcut }}) (dpath : forall (x y : GenNo) (a:A x) (b:A y) (p : x <= y) (q : y <= x) (dp : dle x y p a b) (dq : dle y x q b a), path_No _ _ p q # a = b) (dle_lr : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (p : forall (l:L), xL l < {{ yL | yR // ycut }}) (dp : forall (l:L), dlt _ _ (p l) (fxL l) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (q : forall (r:R'), {{ xL | xR // xcut }} < yR r) (dq : forall (r:R'), dlt _ _ (q r) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyR r)), dle {{ xL | xR // xcut }} {{ yL | yR // ycut }} (le_lr xL xR xcut yL yR ycut p q) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_l : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (l : L') (p : {{ xL | xR // xcut }} <= yL l) (dp : dle _ _ p (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyL l)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_l xL xR xcut yL yR ycut l p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_r : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (r : R) (p : (xR r) <= {{ yL | yR // ycut }}) (dp : dle _ _ p (fxR r) (dcut _ _ _ yL yR ycut fyL fyR fycut)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_r xL xR xcut yL yR ycut r p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_r' : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (r : R) (p : (xR r) <= {{ yL | yR // ycut }}) (dp : dle _ _ p (fxR r) (dcut _ _ _ yL yR ycut fyL fyR fycut)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_r xL xR xcut yL yR ycut r p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)). Definition foo3 : forall x, A x := @No_ind S A dle dlt ishprop_le ishprop_lt dcut dpath dle_lr dlt_l dlt_r. Definition bar3 : forall x, A x := @No_ind S A dle dlt ishprop_le ishprop_lt dcut dpath dle_lr dlt_l dlt_r'. Fail Definition foobar3 : forall x, foo3 x = bar3 x := fun _ => 1. End Foo3. Coq-HoTT-9.0/test/bugs/github1791.v000066400000000000000000000007611474641544500166540ustar00rootroot00000000000000From HoTT Require Import WildCat Join. (** PR #1791 reduced the number of universe variables for several definitions. These tests ensure that they remain reduced. *) (** WildCat/Square.v: *) Check is0functor_idmap@{u1 u2}. Check vinverse@{u1 u2 u3 u4 u5}. Check transpose@{u1 u2 u3}. (** WildCat/Yoneda.v: *) Check opyon_equiv_0gpd@{u1 u2 u3 u4 u5 u6 u7 u8 u9}. (** Join/Core.v: *) Check equiv_join_sym@{u1 u2 u3 u4}. (** Join/JoinAssoc.v: *) Check join_assoc@{u1 u2 u3 u4 u5 u6 u7 u8}. Coq-HoTT-9.0/test/bugs/github1794.v000066400000000000000000000006571474641544500166630ustar00rootroot00000000000000From HoTT Require Import Basics.Overture. (** When [rewrite] is first used, it defines helper lemmas. If the first use is in a Section that has universe variables, then these lemmas get unnecessary universe variables. Overture uses [rewrite] outside of a section to ensure that they have the expected number of universe variables, and we test that here. *) Check internal_paths_rew@{u1 u2}. Check internal_paths_rew_r@{u1 u2}. Coq-HoTT-9.0/test/bugs/github370.v000066400000000000000000000005071474641544500165620ustar00rootroot00000000000000From HoTT Require Import Basics Homotopy.Suspension. Fail Check (fun (P : interval -> Type) (a : P Interval.zero) (b : P Interval.one) (p p' : seg # a = b) => idpath : interval_ind P a b p = interval_rect P a b p'). Fail Check Type0 : Type0. Check Susp nat : Type0. Fail Check Susp Type0 : Type0. Coq-HoTT-9.0/test/bugs/github390.v000066400000000000000000000003521474641544500165620ustar00rootroot00000000000000From HoTT Require Import Basics Pointed Homotopy.Suspension. (** Check that [ispointed_susp] doesn't require just a [Set] *) Check (fun A : Type => _ : IsPointed (Susp A)). Check (@ispointed_susp Type). Check (@ispointed_susp Set). Coq-HoTT-9.0/test/bugs/github726.v000066400000000000000000000002451474641544500165660ustar00rootroot00000000000000From HoTT Require Import Basics Types. (** Check that nested sigma-type notation didn't get clobbered by surreal cuts *) Check ({ l : Unit & { n : Unit & Unit }}). Coq-HoTT-9.0/test/bugs/github754.v000066400000000000000000000016601474641544500165710ustar00rootroot00000000000000From HoTT Require Import Basics Types Universes.DProp Tactics.EquivalenceInduction. Local Open Scope nat_scope. (** Test 1 from issue #754 *) Inductive nat@{i | Set < i} : Type@{i} := | O : nat | S : nat -> nat. Fixpoint code_nat (m n : nat) {struct m} : DProp.DHProp := match m with | O => match n with | O => DProp.True | S _ => DProp.False end | S m' => match n with | O => DProp.False | S n' => code_nat m' n' end end. Local Set Warnings Append "-notation-overridden". Notation "x =n y" := (code_nat x y) : nat_scope. Local Set Warnings Append "notation-overridden". Bind Scope nat_scope with nat. Axiom equiv_path_nat : forall n m : nat, Trunc.trunctype_type (DProp.dhprop_hprop (n =n m)) <~> n = m. Definition nat_discr `{Funext} {n: nat}: O <> S n. Proof. intro H'. equiv_induction (@equiv_path_nat O (S n)). assumption. Qed. Coq-HoTT-9.0/test/bugs/github973.v000066400000000000000000000004161474641544500165720ustar00rootroot00000000000000From HoTT Require Import Basics. Inductive vec (A : Type) : nat -> Type := | nil : vec A 0 | cons : forall n : nat, A -> vec A n -> vec A (S n). Definition hd (A : Type) (n : nat) (v : vec A (S n)) : A := match v in (vec _ (S n)) return A with | cons _ h _ => h end. Coq-HoTT-9.0/test/dune000066400000000000000000000002111474641544500145650ustar00rootroot00000000000000(coq.theory (name HoTT.Tests) (theories HoTT)) (include_subdirs qualified) (alias (name runtest) (deps (glob_files_rec ./*.vo))) Coq-HoTT-9.0/theories/000077500000000000000000000000001474641544500145605ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/000077500000000000000000000000001474641544500161155ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/AbGroups.v000066400000000000000000000011561474641544500200310ustar00rootroot00000000000000(** Theory *) Require Export HoTT.Algebra.Groups. Require Export HoTT.Algebra.AbGroups.AbelianGroup. Require Export HoTT.Algebra.AbGroups.Abelianization. Require Export HoTT.Algebra.AbGroups.AbPullback. Require Export HoTT.Algebra.AbGroups.AbPushout. Require Export HoTT.Algebra.AbGroups.Biproduct. Require Export HoTT.Algebra.AbGroups.AbHom. Require Export HoTT.Algebra.AbGroups.Cyclic. Require Export HoTT.Algebra.AbGroups.Centralizer. Require Export HoTT.Algebra.AbGroups.FiniteSum. (* The theory of Ext groups of abelian groups is in HoTT.Algebra.AbSES. *) (** Examples *) Require Export HoTT.Algebra.AbGroups.Z. Coq-HoTT-9.0/theories/Algebra/AbGroups/000077500000000000000000000000001474641544500176375ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/AbGroups/AbHom.v000066400000000000000000000173561474641544500210300ustar00rootroot00000000000000Require Import Basics Types. Require Import WildCat HSet Truncations.Core Modalities.ReflectiveSubuniverse. Require Import Groups.QuotientGroup AbelianGroup Biproduct. (** * Homomorphisms from a group to an abelian group form an abelian group. *) (** In this file, we use additive notation for the group operation, even though some of the groups we deal with are not assumed to be abelian. *) Local Open Scope mc_add_scope. (** The sum of group homomorphisms [f] and [g] is [fun a => f(a) + g(a)]. While the group *laws* require [Funext], the operations do not, so we make them instances. *) Global Instance sgop_hom {A : Group} {B : AbGroup} : SgOp (A $-> B). Proof. intros f g. exact (grp_homo_compose ab_codiagonal (grp_prod_corec f g)). Defined. (** We can negate a group homomorphism [A -> B] by post-composing with [ab_homo_negation : B -> B]. *) Global Instance inverse_hom {A : Group} {B : AbGroup} : Inverse (@Hom Group _ A B) := grp_homo_compose ab_homo_negation. (** For [A] and [B] groups, with [B] abelian, homomorphisms [A $-> B] form an abelian group. *) Definition grp_hom `{Funext} (A : Group) (B : AbGroup) : Group. Proof. snrapply (Build_Group' (GroupHomomorphism A B) sgop_hom grp_homo_const inverse_hom). 1: exact _. all: hnf; intros; apply equiv_path_grouphomomorphism; intro; cbn. - apply associativity. - apply left_identity. - apply left_inverse. Defined. Definition ab_hom `{Funext} (A : Group) (B : AbGroup) : AbGroup. Proof. snrapply (Build_AbGroup (grp_hom A B)). intros f g; cbn. apply equiv_path_grouphomomorphism; intro x; cbn. apply commutativity. Defined. (** ** Coequalizers *) (** Using the cokernel and addition and negation for the homs of abelian groups, we can define the coequalizer of two group homomorphisms as the cokernel of their difference. *) Definition ab_coeq {A B : AbGroup} (f g : GroupHomomorphism A B) := ab_cokernel ((-f) + g). Definition ab_coeq_in {A B} {f g : A $-> B} : B $-> ab_coeq f g. Proof. snrapply grp_quotient_map. Defined. Definition ab_coeq_glue {A B} {f g : A $-> B} : ab_coeq_in (f:=f) (g:=g) $o f $== ab_coeq_in $o g. Proof. intros x. nrapply qglue. apply tr. by exists x. Defined. Definition ab_coeq_rec {A B : AbGroup} {f g : A $-> B} {C : AbGroup} (i : B $-> C) (p : i $o f $== i $o g) : ab_coeq f g $-> C. Proof. snrapply (grp_quotient_rec _ _ i). cbn. intros b H. strip_truncations. destruct H as [a q]. destruct q; simpl. lhs nrapply grp_homo_op. lhs nrapply (ap (+ _)). 1: apply grp_homo_inv. apply grp_moveL_M1^-1. exact (p a)^. Defined. Definition ab_coeq_rec_beta_in {A B : AbGroup} {f g : A $-> B} {C : AbGroup} (i : B $-> C) (p : i $o f $== i $o g) : ab_coeq_rec i p $o ab_coeq_in $== i := fun _ => idpath. Definition ab_coeq_ind_hprop {A B f g} (P : @ab_coeq A B f g -> Type) `{forall x, IsHProp (P x)} (i : forall b, P (ab_coeq_in b)) : forall x, P x. Proof. rapply Quotient_ind_hprop. exact i. Defined. Definition ab_coeq_ind_homotopy {A B C f g} {l r : @ab_coeq A B f g $-> C} (p : l $o ab_coeq_in $== r $o ab_coeq_in) : l $== r. Proof. srapply ab_coeq_ind_hprop. exact p. Defined. Definition functor_ab_coeq {A B} {f g : A $-> B} {A' B'} {f' g' : A' $-> B'} (a : A $-> A') (b : B $-> B') (p : f' $o a $== b $o f) (q : g' $o a $== b $o g) : ab_coeq f g $-> ab_coeq f' g'. Proof. snrapply ab_coeq_rec. 1: exact (ab_coeq_in $o b). refine (cat_assoc _ _ _ $@ _ $@ cat_assoc_opp _ _ _). refine ((_ $@L p^$) $@ _ $@ (_ $@L q)). refine (cat_assoc_opp _ _ _ $@ (_ $@R a) $@ cat_assoc _ _ _). nrapply ab_coeq_glue. Defined. Definition functor2_ab_coeq {A B} {f g : A $-> B} {A' B'} {f' g' : A' $-> B'} {a a' : A $-> A'} {b b' : B $-> B'} (p : f' $o a $== b $o f) (q : g' $o a $== b $o g) (p' : f' $o a' $== b' $o f) (q' : g' $o a' $== b' $o g) (s : b $== b') : functor_ab_coeq a b p q $== functor_ab_coeq a' b' p' q'. Proof. snrapply ab_coeq_ind_homotopy. intros x. exact (ap ab_coeq_in (s x)). Defined. Definition functor_ab_coeq_compose {A B} {f g : A $-> B} {A' B'} {f' g' : A' $-> B'} (a : A $-> A') (b : B $-> B') (p : f' $o a $== b $o f) (q : g' $o a $== b $o g) {A'' B''} {f'' g'' : A'' $-> B''} (a' : A' $-> A'') (b' : B' $-> B'') (p' : f'' $o a' $== b' $o f') (q' : g'' $o a' $== b' $o g') : functor_ab_coeq a' b' p' q' $o functor_ab_coeq a b p q $== functor_ab_coeq (a' $o a) (b' $o b) (hconcat p p') (hconcat q q'). Proof. snrapply ab_coeq_ind_homotopy. simpl; reflexivity. Defined. Definition functor_ab_coeq_id {A B} (f g : A $-> B) : functor_ab_coeq (f:=f) (g:=g) (Id _) (Id _) (hrefl _) (hrefl _) $== Id _. Proof. snrapply ab_coeq_ind_homotopy. reflexivity. Defined. Definition grp_iso_ab_coeq {A B} {f g : A $-> B} {A' B'} {f' g' : A' $-> B'} (a : A $<~> A') (b : B $<~> B') (p : f' $o a $== b $o f) (q : g' $o a $== b $o g) : ab_coeq f g $<~> ab_coeq f' g'. Proof. snrapply cate_adjointify. - exact (functor_ab_coeq a b p q). - exact (functor_ab_coeq a^-1$ b^-1$ (hinverse _ _ p) (hinverse _ _ q)). - nrefine (functor_ab_coeq_compose _ _ _ _ _ _ _ _ $@ functor2_ab_coeq _ _ _ _ _ $@ functor_ab_coeq_id _ _). rapply cate_isretr. - nrefine (functor_ab_coeq_compose _ _ _ _ _ _ _ _ $@ functor2_ab_coeq _ _ _ _ _ $@ functor_ab_coeq_id _ _). rapply cate_issect. Defined. (** ** The bifunctor [ab_hom] *) Global Instance is0functor_ab_hom01 `{Funext} {A : Group^op} : Is0Functor (ab_hom A). Proof. snrapply (Build_Is0Functor _ AbGroup); intros B B' f. snrapply Build_GroupHomomorphism. 1: exact (fun g => grp_homo_compose f g). intros phi psi. apply equiv_path_grouphomomorphism; intro a; cbn. exact (grp_homo_op f _ _). Defined. Global Instance is0functor_ab_hom10 `{Funext} {B : AbGroup@{u}} : Is0Functor (flip (ab_hom : Group^op -> AbGroup -> AbGroup) B). Proof. snrapply (Build_Is0Functor (Group^op) AbGroup); intros A A' f. snrapply Build_GroupHomomorphism. 1: exact (fun g => grp_homo_compose g f). intros phi psi. by apply equiv_path_grouphomomorphism. Defined. Global Instance is1functor_ab_hom01 `{Funext} {A : Group^op} : Is1Functor (ab_hom A). Proof. nrapply Build_Is1Functor. - intros B B' f g p phi. apply equiv_path_grouphomomorphism; intro a; cbn. exact (p (phi a)). - intros B phi. by apply equiv_path_grouphomomorphism. - intros B C D f g phi. by apply equiv_path_grouphomomorphism. Defined. Global Instance is1functor_ab_hom10 `{Funext} {B : AbGroup@{u}} : Is1Functor (flip (ab_hom : Group^op -> AbGroup -> AbGroup) B). Proof. nrapply Build_Is1Functor. - intros A A' f g p phi. apply equiv_path_grouphomomorphism; intro a; cbn. exact (ap phi (p a)). - intros A phi. by apply equiv_path_grouphomomorphism. - intros A C D f g phi. by apply equiv_path_grouphomomorphism. Defined. Global Instance is0bifunctor_ab_hom `{Funext} : Is0Bifunctor (ab_hom : Group^op -> AbGroup -> AbGroup). Proof. rapply Build_Is0Bifunctor''. Defined. Global Instance is1bifunctor_ab_hom `{Funext} : Is1Bifunctor (ab_hom : Group^op -> AbGroup -> AbGroup). Proof. nrapply Build_Is1Bifunctor''. 1,2: exact _. intros A A' f B B' g phi; cbn. by apply equiv_path_grouphomomorphism. Defined. (** ** Properties of [ab_hom] *) (** Precomposition with a surjection is an embedding. *) (* This could be deduced from [isembedding_precompose_surjection_hset], but relating precomposition of homomorphisms with precomposition of the underlying maps is tedious, so we give a direct proof. *) Global Instance isembedding_precompose_surjection_ab `{Funext} {A B C : AbGroup} (f : A $-> B) `{IsSurjection f} : IsEmbedding (fmap10 (A:=Group^op) ab_hom f C). Proof. apply isembedding_isinj_hset; intros g0 g1 p. apply equiv_path_grouphomomorphism. rapply (conn_map_elim (Tr (-1)) f). exact (equiv_path_grouphomomorphism^-1 p). Defined. Coq-HoTT-9.0/theories/Algebra/AbGroups/AbProjective.v000066400000000000000000000026621474641544500224110ustar00rootroot00000000000000Require Import Basics Types AbelianGroup AbPullback WildCat.Core Limits.Pullback ReflectiveSubuniverse Truncations.Core. (** * Projective abelian groups *) (** We define projective abelian groups and show that [P] is projective if and only if every epimorphism [A -> P] merely splits. *) (** An abelian group [P] is projective if for any map [P -> B] and epimorphism [A -> B], there merely exists a lift [P -> A] making the following triangle commute: A ^ | l / | | e / | V P ---> B f *) Class IsAbProjective@{u +} (P : AbGroup@{u}) : Type := isabprojective : forall (A B : AbGroup@{u}), forall (e : A $-> B), forall (f : P $-> B), IsSurjection e -> merely (exists l : P $-> A, e $o l == f). (** An abelian group is projective iff epis into it merely split. *) Proposition iff_isabprojective_surjections_split (P : AbGroup) : IsAbProjective P <-> (forall A, forall p : A $-> P, IsSurjection p -> merely (exists s : P $-> A, p $o s == grp_homo_id)). Proof. split. - intros H A B. apply H. - intros H A B e f H1. pose proof (s := H (ab_pullback f e) (grp_pullback_pr1 f e) (conn_map_pullback _ f e)). strip_truncations. destruct s as [s h]. refine (tr ((grp_pullback_pr2 f e) $o s; _)); intro x. refine ((pullback_commsq f e _)^ @ _). exact (ap f (h x)). Defined. Coq-HoTT-9.0/theories/Algebra/AbGroups/AbPullback.v000066400000000000000000000016441474641544500220330ustar00rootroot00000000000000Require Import Basics. Require Import Limits.Pullback Cubical.PathSquare. Require Export Algebra.Groups.GrpPullback. Require Import Algebra.AbGroups.AbelianGroup. Require Import WildCat.Core. Local Open Scope mc_add_scope. (** * Pullbacks of abelian groups *) Section AbPullback. (* Variables are named to correspond with Limits.Pullback. *) Context {A B C : AbGroup} (f : B $-> A) (g : C $-> A). Global Instance ab_pullback_commutative : Commutative (@group_sgop (grp_pullback f g)). Proof. unfold Commutative. intros [b [c p]] [d [e q]]. apply equiv_path_pullback; simpl. refine (commutativity _ _; commutativity _ _; _). apply equiv_sq_path. apply path_ishprop. Defined. Definition ab_pullback : AbGroup := Build_AbGroup (grp_pullback f g) _. (** The corecursion principle is inherited from Groups; use grp_pullback_corec and friends from Groups/GrpPullback.v. *) End AbPullback. Coq-HoTT-9.0/theories/Algebra/AbGroups/AbPushout.v000066400000000000000000000152731474641544500217500ustar00rootroot00000000000000Require Import Basics Types Truncations.Core. Require Import WildCat.Core HSet. Require Export Algebra.Groups.QuotientGroup. Require Import AbGroups.AbelianGroup AbGroups.Biproduct. Local Open Scope mc_scope. Local Open Scope mc_add_scope. (** * Pushouts of abelian groups. *) (** The pushout of two morphisms [f : A $-> B] and [g : A $-> C] is constructed as the quotient of the biproduct [B + C] by the image of [f - g]. Since this image comes up repeatedly, we name it. *) Definition ab_pushout_subgroup {A B C : AbGroup} (f : A $-> B) (g : A $-> C) : Subgroup (ab_biprod B C) := grp_image (ab_biprod_corec (ab_homo_negation $o f) g). Definition ab_pushout {A B C : AbGroup} (f : A $-> B) (g : A $-> C) : AbGroup := QuotientAbGroup (ab_biprod B C) (ab_pushout_subgroup f g). (** Recursion principle. *) Theorem ab_pushout_rec {A B C Y : AbGroup} {f : A $-> B} {g : A $-> C} (b : B $-> Y) (c : C $-> Y) (p : b o f == c o g) : ab_pushout f g $-> Y. Proof. srapply grp_quotient_rec. - exact (ab_biprod_rec b c). - intros [x y] q; strip_truncations; simpl. destruct q as [a q]. cbn in q. lhs_V nrapply (ap (fun '(x, y) => b x + c y) q); cbn. lhs rapply (ap011 (+) (preserves_inverse _) (p a)^). apply left_inverse. Defined. Corollary ab_pushout_rec_uncurried {A B C : AbGroup} (f : A $-> B) (g : A $-> C) (Y : AbGroup) : {b : B $-> Y & {c : C $-> Y & b o f == c o g}} -> (ab_pushout f g $-> Y). Proof. intros [b [c p]]; exact (ab_pushout_rec b c p). Defined. Definition ab_pushout_inl {A B C : AbGroup} {f : A $-> B} {g : A $-> C} : B $-> ab_pushout f g := grp_quotient_map $o grp_prod_inl. Definition ab_pushout_inr {A B C : AbGroup} {f : A $-> B} {g : A $-> C} : C $-> ab_pushout f g := grp_quotient_map $o grp_prod_inr. Proposition ab_pushout_commsq {A B C : AbGroup} {f : A $-> B} {g : A $-> C} : (@ab_pushout_inl A B C f g) $o f == ab_pushout_inr $o g. Proof. intro a; simpl. apply qglue, tr; exists a. apply path_prod; simpl. - exact (right_identity _)^. - rewrite grp_inv_unit. exact (left_identity _)^. Defined. (** A map out of the pushout induces itself after restricting along the inclusions. *) Proposition ab_pushout_rec_beta `{Funext} {A B C Y : AbGroup} {f : A $-> B} {g : A $-> C} (phi : ab_pushout f g $-> Y) : ab_pushout_rec (phi $o ab_pushout_inl) (phi $o ab_pushout_inr) (fun a:A => ap phi (ab_pushout_commsq a)) = phi. Proof. rapply (equiv_ap' (equiv_quotient_abgroup_ump (G:=ab_biprod B C) _ Y)^-1%equiv _ _)^-1. srapply path_sigma_hprop. refine (grp_quotient_rec_beta _ Y _ _ @ _). apply equiv_path_grouphomomorphism; intro bc. exact (ab_biprod_rec_eta (phi $o grp_quotient_map) bc). Defined. (** Restricting [ab_pushout_rec] along [ab_pushout_inl] recovers the left inducing map. *) Lemma ab_pushout_rec_beta_left {A B C Y : AbGroup} (f : A $-> B) (g : A $-> C) (l : B $-> Y) (r : C $-> Y) (p : l o f == r o g) : ab_pushout_rec l r p $o ab_pushout_inl == l. Proof. intro x; simpl. rewrite (grp_homo_unit r). apply right_identity. Defined. Lemma ab_pushout_rec_beta_right {A B C Y : AbGroup} (f : A $-> B) (g : A $-> C) (l : B $-> Y) (r : C $-> Y) (p : l o f == r o g) : ab_pushout_rec l r p $o ab_pushout_inr == r. Proof. intro x; simpl. rewrite (grp_homo_unit l). apply left_identity. Defined. Theorem isequiv_ab_pushout_rec `{Funext} {A B C Y : AbGroup} {f : A $-> B} {g : A $-> C} : IsEquiv (ab_pushout_rec_uncurried f g Y). Proof. srapply isequiv_adjointify. - intro phi. refine (phi $o ab_pushout_inl; phi $o ab_pushout_inr; _). intro a. apply (ap phi). exact (ab_pushout_commsq a). - intro phi. exact (ab_pushout_rec_beta phi). - intros [b [c p]]. srapply path_sigma. + apply equiv_path_grouphomomorphism. intro x; simpl. refine (ap (fun k => b x + k) (grp_homo_unit c) @ _). apply right_identity. + refine (transport_sigma' _ _ @ _). apply path_sigma_hprop; simpl. apply equiv_path_grouphomomorphism. intro y; simpl. refine (ap (fun k => k + c y) (grp_homo_unit b) @ _). apply left_identity. Defined. Definition path_ab_pushout `{Univalence} {A B C : AbGroup} (f : A $-> B) (g : A $-> C) (bc0 bc1 : ab_biprod B C) : @in_cosetL (ab_biprod B C) (ab_pushout_subgroup f g) bc0 bc1 <~> (grp_quotient_map bc0 = grp_quotient_map bc1 :> ab_pushout f g). Proof. rapply path_quotient. Defined. (** The pushout of an embedding is an embedding. *) Definition ab_pushout_embedding_inl `{Univalence} {A B C : AbGroup} (f : A $-> B) (g : A $-> C) `{IsEmbedding g} : IsEmbedding (ab_pushout_inl (f:=f) (g:=g)). Proof. apply isembedding_isinj_hset. intros c0 c1. refine (_ o (path_ab_pushout f g (grp_prod_inl c0) (grp_prod_inl c1))^-1). rapply Trunc_ind. cbn; intros [a p]. assert (z : a = mon_unit). - rapply (isinj_embedding g). refine (ap snd p @ _); cbn. exact (left_inverse mon_unit @ (grp_homo_unit g)^). - apply (grp_moveR_M1). refine (_ @ ap fst p); cbn; symmetry. refine (_ @ grp_inv_unit). refine (ap _ _). exact (ap f z @ grp_homo_unit f). Defined. (** Functoriality of pushouts *) Definition functor_ab_pushout {A A' B B' C C' : AbGroup} (f : A $-> B) (f' : A' $-> B') (g : A $-> C) (g' : A' $-> C') (alpha : A $-> A') (beta : B $-> B') (gamma : C $-> C') (h : beta $o f == f' $o alpha) (k : g' $o alpha == gamma $o g) : ab_pushout f g $-> ab_pushout f' g'. Proof. srapply ab_pushout_rec. - exact (ab_pushout_inl $o beta). - exact (ab_pushout_inr $o gamma). - intro a. refine (ap ab_pushout_inl (h a) @ _ @ ap ab_pushout_inr (k a)). exact (ab_pushout_commsq (alpha a)). Defined. (** ** Properties of pushouts of maps *) (** The pushout of an epimorphism is an epimorphism. *) Global Instance ab_pushout_surjection_inr {A B C : AbGroup} (f : A $-> B) (g : A $-> C) `{S : IsSurjection f} : IsSurjection (ab_pushout_inr (f:=f) (g:=g)). Proof. intro x. rapply contr_inhabited_hprop. (* To find a preimage of [x], we may first choose a representative [x']. *) assert (x' : merely (hfiber grp_quotient_map x)). 1: apply center, issurj_class_of. strip_truncations; destruct x' as [[b c] p]. (* Now [x] = [b + c] in the quotient. We find a preimage of [a]. *) assert (a : merely (hfiber f b)). 1: apply center, S. strip_truncations; destruct a as [a q]. refine (tr (g a + c; _)). refine (grp_homo_op _ _ _ @ _). refine (ap (fun z => sg_op z _) _^ @ _). { refine (_^ @ ab_pushout_commsq _). exact (ap _ q). } refine (ap grp_quotient_map _ @ p). apply path_prod'; cbn. - apply right_identity. - apply left_identity. Defined. Coq-HoTT-9.0/theories/Algebra/AbGroups/AbelianGroup.v000066400000000000000000000235021474641544500224000ustar00rootroot00000000000000Require Import Basics Types. Require Import Spaces.Nat.Core Spaces.Int. Require Export Classes.interfaces.canonical_names (Zero, zero, Plus, plus, Negate, negate, Involutive, involutive). Require Export Classes.interfaces.abstract_algebra (IsAbGroup(..), abgroup_group, abgroup_commutative). Require Export Algebra.Groups.Group. Require Export Algebra.Groups.Subgroup. Require Import Algebra.Groups.QuotientGroup. Require Import WildCat. Local Set Polymorphic Inductive Cumulativity. Local Open Scope mc_scope. Local Open Scope mc_add_scope. (** * Abelian groups *) (** Definition of an abelian group *) Record AbGroup := { abgroup_group : Group; abgroup_commutative : @Commutative abgroup_group _ (+); }. Coercion abgroup_group : AbGroup >-> Group. Global Existing Instance abgroup_commutative. Definition zero_abgroup (A : AbGroup) : Zero A := mon_unit. Definition negate_abgroup (A : AbGroup) : Negate A := inv. Definition plus_abgroup (A : AbGroup) : Plus A := sg_op. (** Sometimes we want an abelian group to act as if it has a [Plus], [Zero] and [Negate] operation. For example, when working with rings. We therefore make this module of hints available for import so that consumers can control the way the abelian group operation is treated. Files about abelian groups (apart from this one) typically don't have these instances available, whereas files about rings do. *) Module Import AdditiveInstances. #[export] Hint Immediate zero_abgroup : typeclass_instances. #[export] Hint Immediate negate_abgroup : typeclass_instances. #[export] Hint Immediate plus_abgroup : typeclass_instances. End AdditiveInstances. Global Instance isabgroup_abgroup {A : AbGroup} : IsAbGroup A. Proof. split; exact _. Defined. (** Easier way to build abelian groups without redundant information. *) Definition Build_AbGroup' (G : Type) `{MonUnit G, Inverse G, SgOp G, IsHSet G} (comm : Commutative (A:=G) (+)) (assoc : Associative (A:=G) (+)) (unit_l : LeftIdentity (A:=G) (+) 0) (inv_l : LeftInverse (A:=G) (+) (-) 0) : AbGroup. Proof. snrapply Build_AbGroup. - rapply (Build_Group' G). - exact comm. Defined. Definition issig_abgroup : _ <~> AbGroup := ltac:(issig). Definition ab_neg_op {A : AbGroup} (x y : A) : - (x + y) = -x - y. Proof. lhs nrapply grp_inv_op. apply commutativity. Defined. (** ** Paths between abelian groups *) Definition equiv_path_abgroup `{Univalence} {A B : AbGroup@{u}} : GroupIsomorphism A B <~> (A = B). Proof. refine (equiv_ap_inv issig_abgroup _ _ oE _). refine (equiv_path_sigma_hprop _ _ oE _). exact equiv_path_group. Defined. Definition equiv_path_abgroup_group `{Univalence} {A B : AbGroup} : (A = B :> AbGroup) <~> (A = B :> Group) := equiv_path_group oE equiv_path_abgroup^-1. (** ** Subgroups of abelian groups *) Local Hint Immediate canonical_names.inverse_is_negate : typeclass_instances. (** Subgroups of abelian groups are abelian *) Global Instance isabgroup_subgroup (G : AbGroup) (H : Subgroup G) : IsAbGroup H. Proof. nrapply Build_IsAbGroup. 1: exact _. intros x y. apply path_sigma_hprop. cbn. apply commutativity. Defined. (** Given any subgroup of an abelian group, we can coerce it to an abelian group. Note that Coq complains this coercion doesn't satisfy the uniform-inheritance condition, but in practice it works and doesn't cause any issue, so we ignore it. *) Definition abgroup_subgroup (G : AbGroup) : Subgroup G -> AbGroup := fun H => Build_AbGroup H _. #[warnings="-uniform-inheritance"] Coercion abgroup_subgroup : Subgroup >-> AbGroup. Global Instance isnormal_ab_subgroup (G : AbGroup) (H : Subgroup G) : IsNormalSubgroup H. Proof. intros x y h. by rewrite commutativity. Defined. (** ** Quotients of abelian groups *) Global Instance isabgroup_quotient (G : AbGroup) (H : Subgroup G) : IsAbGroup (QuotientGroup' G H (isnormal_ab_subgroup G H)). Proof. nrapply Build_IsAbGroup. 1: exact _. srapply Quotient_ind2_hprop; intros x y. apply (ap (class_of _)). apply commutativity. Defined. Definition QuotientAbGroup (G : AbGroup) (H : Subgroup G) : AbGroup := (Build_AbGroup (QuotientGroup' G H (isnormal_ab_subgroup G H)) _). Arguments QuotientAbGroup G H : simpl never. Definition quotient_abgroup_rec {G : AbGroup} (N : Subgroup G) (H : AbGroup) (f : GroupHomomorphism G H) (h : forall n : G, N n -> f n = mon_unit) : GroupHomomorphism (QuotientAbGroup G N) H := grp_quotient_rec G (Build_NormalSubgroup G N _) f h. Theorem equiv_quotient_abgroup_ump {F : Funext} {G : AbGroup} (N : Subgroup G) (H : Group) : {f : GroupHomomorphism G H & forall (n : G), N n -> f n = mon_unit} <~> (GroupHomomorphism (QuotientAbGroup G N) H). Proof. exact (equiv_grp_quotient_ump (Build_NormalSubgroup G N _) _). Defined. (** ** The wild category of abelian groups *) Global Instance isgraph_abgroup : IsGraph AbGroup := isgraph_induced abgroup_group. Global Instance is01cat_abgroup : Is01Cat AbGroup := is01cat_induced abgroup_group. Global Instance is01cat_grouphomomorphism {A B : AbGroup} : Is01Cat (A $-> B) := is01cat_induced (@grp_homo_map A B). Global Instance is0gpd_grouphomomorphism {A B : AbGroup} : Is0Gpd (A $-> B) := is0gpd_induced (@grp_homo_map A B). Global Instance is2graph_abgroup : Is2Graph AbGroup := is2graph_induced abgroup_group. (** AbGroup forms a 1Cat *) Global Instance is1cat_abgroup : Is1Cat AbGroup := is1cat_induced _. Global Instance hasmorext_abgroup `{Funext} : HasMorExt AbGroup := hasmorext_induced _. Global Instance hasequivs_abgroup : HasEquivs AbGroup := hasequivs_induced _. (** Zero object of AbGroup *) Definition abgroup_trivial : AbGroup. Proof. rapply (Build_AbGroup grp_trivial). by intros []. Defined. (** AbGroup is a pointed category *) Global Instance ispointedcat_abgroup : IsPointedCat AbGroup. Proof. apply Build_IsPointedCat with abgroup_trivial. all: intro A; apply ispointedcat_group. Defined. (** [abgroup_group] is a functor *) Global Instance is0functor_abgroup_group : Is0Functor abgroup_group := is0functor_induced _. Global Instance is1functor_abgroup_group : Is1Functor abgroup_group := is1functor_induced _. (** Image of group homomorphisms between abelian groups *) Definition abgroup_image {A B : AbGroup} (f : A $-> B) : AbGroup := Build_AbGroup (grp_image f) _. (** First isomorphism theorem of abelian groups *) Definition abgroup_first_iso `{Funext} {A B : AbGroup} (f : A $-> B) : GroupIsomorphism (QuotientAbGroup A (grp_kernel f)) (abgroup_image f). Proof. etransitivity. 2: rapply grp_first_iso. apply grp_iso_quotient_normal. Defined. (** ** Kernels of abelian groups *) Definition ab_kernel {A B : AbGroup} (f : A $-> B) : AbGroup := Build_AbGroup (grp_kernel f) _. (** ** Transporting in families related to abelian groups *) Lemma transport_abgrouphomomorphism_from_const `{Univalence} {A B B' : AbGroup} (p : B = B') (f : GroupHomomorphism A B) : transport (Hom A) p f = grp_homo_compose (equiv_path_abgroup^-1 p) f. Proof. induction p. by apply equiv_path_grouphomomorphism. Defined. Lemma transport_iso_abgrouphomomorphism_from_const `{Univalence} {A B B' : AbGroup} (phi : GroupIsomorphism B B') (f : GroupHomomorphism A B) : transport (Hom A) (equiv_path_abgroup phi) f = grp_homo_compose phi f. Proof. refine (transport_abgrouphomomorphism_from_const _ _ @ _). by rewrite eissect. Defined. Lemma transport_abgrouphomomorphism_to_const `{Univalence} {A A' B : AbGroup} (p : A = A') (f : GroupHomomorphism A B) : transport (fun G => Hom G B) p f = grp_homo_compose f (grp_iso_inverse (equiv_path_abgroup^-1 p)). Proof. induction p; cbn. by apply equiv_path_grouphomomorphism. Defined. Lemma transport_iso_abgrouphomomorphism_to_const `{Univalence} {A A' B : AbGroup} (phi : GroupIsomorphism A A') (f : GroupHomomorphism A B) : transport (fun G => Hom G B) (equiv_path_abgroup phi) f = grp_homo_compose f (grp_iso_inverse phi). Proof. refine (transport_abgrouphomomorphism_to_const _ _ @ _). by rewrite eissect. Defined. (** ** Operations on abelian groups *) (** The negation automorphism of an abelian group *) Definition ab_homo_negation {A : AbGroup} : GroupIsomorphism A A. Proof. snrapply Build_GroupIsomorphism. - snrapply Build_GroupHomomorphism. + exact (fun a => -a). + intros x y. refine (grp_inv_op x y @ _). apply commutativity. - srapply isequiv_adjointify. 1: exact (fun a => -a). 1-2: exact inverse_involutive. Defined. (** Multiplication by [n : Int] defines an endomorphism of any abelian group [A]. *) Definition ab_mul {A : AbGroup} (n : Int) : GroupHomomorphism A A. Proof. snrapply Build_GroupHomomorphism. 1: exact (fun a => grp_pow a n). intros a b. apply grp_pow_mul, commutativity. Defined. (** [ab_mul n] is natural. *) Definition ab_mul_natural {A B : AbGroup} (f : GroupHomomorphism A B) (n : Int) : f o ab_mul n == ab_mul n o f := grp_pow_natural f n. (** The image of an inclusion is a normal subgroup. *) Definition ab_image_embedding {A B : AbGroup} (f : A $-> B) `{IsEmbedding f} : NormalSubgroup B := {| normalsubgroup_subgroup := grp_image_embedding f; normalsubgroup_isnormal := _ |}. Definition ab_image_in_embedding {A B : AbGroup} (f : A $-> B) `{IsEmbedding f} : GroupIsomorphism A (ab_image_embedding f) := grp_image_in_embedding f. (** The cokernel of a homomorphism into an abelian group. *) Definition ab_cokernel {G : Group@{u}} {A : AbGroup@{u}} (f : GroupHomomorphism G A) : AbGroup := QuotientAbGroup _ (grp_image f). Definition ab_cokernel_embedding {G : Group} {A : AbGroup} (f : G $-> A) `{IsEmbedding f} : AbGroup := QuotientAbGroup _ (grp_image_embedding f). Definition ab_cokernel_embedding_rec {G: Group} {A B : AbGroup} (f : G $-> A) `{IsEmbedding f} (h : A $-> B) (p : grp_homo_compose h f $== grp_homo_const) : ab_cokernel_embedding f $-> B. Proof. snrapply (grp_quotient_rec _ _ h). intros a [g q]. induction q. exact (p g). Defined. Coq-HoTT-9.0/theories/Algebra/AbGroups/Abelianization.v000066400000000000000000000360711474641544500227660ustar00rootroot00000000000000Require Import Basics Types Truncations.Core. Require Import Cubical.DPath WildCat. Require Import Colimits.Coeq. Require Import Algebra.AbGroups.AbelianGroup. Require Import Modalities.ReflectiveSubuniverse. (** * Abelianization *) (** In this file we define what it means for a group homomorphism [G -> H] into an abelian group [H] to be an abelianization. We then construct an example of an abelianization. *) Local Open Scope mc_scope. Local Open Scope mc_mult_scope. Local Open Scope wc_iso_scope. (** ** Definition of abelianization. A "unit" homomorphism [eta : G -> G_ab], with [G_ab] abelian, is considered an abelianization if and only if for all homomorphisms [G -> A], where [A] is abelian, there exists a unique [g : G_ab -> A] such that [h == g o eta X]. We express this in funext-free form by saying that precomposition with [eta] in the wild 1-category [Group] induces an equivalence of hom 0-groupoids, in the sense of WildCat/EquivGpd. Unfortunately, if [eta : GroupHomomorphism G G_ab] and we write [cat_precomp A eta] then Coq is unable to guess that the relevant 1-category is [Group]. Even writing [cat_precomp (A := Group) A eta] isn't good enough, I guess because the typeclass inference that finds the instance [is01cat_group] doesn't happen until after the type of [eta] would have to be resolved to a [Hom] in some wild category. However, with the following auxiliary definition we can force the typeclass inference to happen first. (It would be worth thinking about whether the design of the wild categories library could be improved to avoid this.) *) Definition group_precomp {a b} := @cat_precomp Group _ _ a b. Class IsAbelianization {G : Group} (G_ab : AbGroup) (eta : GroupHomomorphism G G_ab) := issurjinj_isabel : forall (A : AbGroup), IsSurjInj (group_precomp A eta). Global Existing Instance issurjinj_isabel. Definition isequiv_group_precomp_isabelianization `{Funext} {G : Group} {G_ab : AbGroup} (eta : GroupHomomorphism G G_ab) `{!IsAbelianization G_ab eta} (A : AbGroup) : IsEquiv (group_precomp A eta). Proof. snrapply isequiv_adjointify. - intros g. rapply (surjinj_inv (group_precomp A eta) g). - intros f. snrapply equiv_path_grouphomomorphism. exact (eisretr0gpd_inv (group_precomp A eta) f). - intros f. snrapply equiv_path_grouphomomorphism. exact (eissect0gpd_inv (group_precomp A eta) f). Defined. Definition equiv_group_precomp_isabelianization `{Funext} {G : Group} {G_ab : AbGroup} (eta : GroupHomomorphism G G_ab) `{!IsAbelianization G_ab eta} (A : AbGroup) : (G_ab $-> A) <~> (G $-> A) := Build_Equiv _ _ _ (isequiv_group_precomp_isabelianization eta A). (** Here we define abelianization as a HIT. Specifically as a set-coequalizer of the following two maps [fun '(a, b, c) => a * (b * c)] and [fun '(a, b, c) => a * (c * b)]. From this we can show that Abel G is an abelian group. In fact this models the following HIT: <<< HIT Abel (G : Group) := | abel_in : G -> Abel G | abel_in_comm : forall x y z, abel_in (x * (y * z)) = abel_in (x * (z * y)). >>> We also derive [abel_in] and [abel_in_comm] from our coequalizer definition, and even prove the induction and computation rules for this HIT. This HIT was suggested by Dan Christensen. *) Section Abel. (** Let G be a group. *) Context (G : Group). (** We locally define a map uncurry2 that lets us uncurry [A * B * C -> D] twice. *) Local Definition uncurry2 {A B C D : Type} : (A -> B -> C -> D) -> A * B * C -> D := fun f '(a, b, c) => f a b c. (** The type [Abel] is defined to be the set coequalizer of the following maps [G^3 -> G]. *) Definition Abel := Tr 0 (Coeq (uncurry2 (fun a b c : G => a * (b * c))) (uncurry2 (fun a b c : G => a * (c * b)))). (** We have a natural map from [G] to [Abel G]. *) Definition abel_in : G -> Abel := tr o coeq. (** This map satisfies the condition [ab_comm]. It's a form of commutativity in a right factor. *) Definition abel_in_comm a b c : abel_in (a * (b * c)) = abel_in (a * (c * b)) := ap tr (cglue (a, b, c)). (** It is clear that Abel is a set. *) Definition istrunc_abel : IsHSet Abel := _. (** We can derive the induction principle from the ones for truncation and the coequalizer. *) Definition Abel_ind (P : Abel -> Type) `{forall x, IsHSet (P x)} (a : forall x, P (abel_in x)) (c : forall x y z, abel_in_comm x y z # a (x * (y * z)) = a (x * (z * y))) : forall (x : Abel), P x. Proof. srapply Trunc_ind. snrapply Coeq_ind. 1: apply a. intros [[x y] z]. nrefine (transport_compose _ _ _ _ @ _). apply c. Defined. (** The computation rule on point constructors holds definitionally. *) Definition Abel_ind_beta_abel_in (P : Abel -> Type) `{forall x, IsHSet (P x)} (a : forall x, P (abel_in x)) (c : forall x y z, DPath P (abel_in_comm x y z) (a (x * (y * z))) (a (x * (z * y)))) (x : G) : Abel_ind P a c (abel_in x) = a x := idpath. (** The computation rule on paths. *) Definition Abel_ind_beta_abel_in_comm (P : Abel -> Type) `{forall x, IsHSet (P x)} (a : forall x, P (abel_in x)) (c : forall x y z, abel_in_comm x y z # a (x * (y * z)) = a (x * (z * y))) (x y z : G) : apD (Abel_ind P a c) (abel_in_comm x y z) = c x y z. Proof. nrefine (apD_compose' tr _ _ @ ap _ _ @ concat_V_pp _ _). rapply Coeq_ind_beta_cglue. Defined. (** We also have a recursion princple. *) Definition Abel_rec (P : Type) `{IsHSet P} (a : G -> P) (c : forall x y z, a (x * (y * z)) = a (x * (z * y))) : Abel -> P. Proof. apply (Abel_ind _ a). intros; apply dp_const, c. Defined. (** Here is a simpler version of [Abel_ind] when our target is an [HProp]. This lets us discard all the higher paths. *) Definition Abel_ind_hprop (P : Abel -> Type) `{forall x, IsHProp (P x)} (a : forall x, P (abel_in x)) : forall (x : Abel), P x. Proof. srapply Trunc_ind. srapply Coeq_ind_hprop. exact a. Defined. End Abel. (** The [IsHProp] argument of [Abel_ind_hprop] can usually be found by typeclass resolution, but [srapply] is slow, so we use this tactic instead. *) Local Ltac Abel_ind_hprop x := snrapply Abel_ind_hprop; [exact _ | intro x]. (** We make sure that [G] is implicit in the arguments of [abel_in] and [abel_in_comm]. *) Arguments abel_in {_} g%_mc_mult_scope. Arguments abel_in_comm {_} (a b c)%_mc_mult_scope. (** Now we can show that [Abel G] is in fact an abelian group. We will denote the operation in [Abel G] by the multiplicative [*] notation even though it is later shown to be commutative. *) Section AbelGroup. Context (G : Group). (** Firstly we define the operation on [Abel G]. This is defined as follows: << abel_in x * abel_in y := abel_in (x * y) >> But we need to also check that it preserves [ab_comm] in the appropriate way. *) Global Instance sgop_abel : SgOp (Abel G). Proof. intro a. srapply Abel_rec. { intro b. revert a. srapply Abel_rec. { intro a. exact (abel_in (a * b)). } intros a c d; hnf. (* The pattern seems to be to alternate [associativity] and [ab_comm]. *) refine (ap _ (associativity _ _ _)^ @ _). refine (abel_in_comm _ _ _ @ _). refine (ap _ (associativity _ _ _) @ _). refine (abel_in_comm _ _ _ @ _). refine (ap _ (associativity _ _ _)^ @ _). refine (abel_in_comm _ _ _ @ _). refine (ap _ (associativity _ _ _)). } intros b c d. revert a. Abel_ind_hprop a; simpl. refine (ap _ (associativity _ _ _) @ _). refine (abel_in_comm _ _ _ @ _). refine (ap _ (associativity _ _ _)^). Defined. (** We can now easily show that this operation is associative by [associativity] in [G] and the fact that being associative is a proposition. *) Global Instance associative_abel_sgop : Associative (.*.). Proof. intros x y. Abel_ind_hprop z; revert y. Abel_ind_hprop y; revert x. Abel_ind_hprop x; simpl. nrapply (ap abel_in); apply associativity. Defined. (** From this we know that [Abel G] is a semigroup. *) Global Instance issemigroup_abel : IsSemiGroup (Abel G) := {}. (** We define the group unit as [abel_in] of the unit of [G] *) Global Instance monunit_abel_zero : MonUnit (Abel G) := abel_in mon_unit. (** By using Abel_ind_hprop we can prove the left and right identity laws. *) Global Instance leftidentity_abel : LeftIdentity (.*.) 1. Proof. Abel_ind_hprop x; cbn beta. nrapply (ap abel_in); apply left_identity. Defined. Global Instance rightidentity_abel : RightIdentity (.*.) 1. Proof. Abel_ind_hprop x; cbn beta. nrapply (ap abel_in); apply right_identity. Defined. (** Hence [Abel G] is a monoid *) Global Instance ismonoid_abel : IsMonoid (Abel G) := {}. (** We can also prove that the operation is commutative! This will come in handy later. *) Global Instance commutative_abel : Commutative (.*.). Proof. intro x. Abel_ind_hprop y. revert x. Abel_ind_hprop x; cbn beta. refine ((ap abel_in (left_identity _))^ @ _). refine (_ @ (ap abel_in (left_identity _))). apply abel_in_comm. Defined. (** Now we can define the inverse operation. This is just << (abel_in g)^ := abel_in g^ >> However when checking that it respects [ab_comm] we have to show the following: << abel_in (z^ * y^ * x^) = abel_in (y^ * z^ * x^) >> there is no obvious way to do this, but we note that [abel_in (x * y)] is exactly the definition of [abel_in x * abel_in y]! Hence by [commutativity] we can show this. *) Global Instance inverse_abel : Inverse (Abel G). Proof. srapply (Abel_rec _ _ (abel_in o inv)). intros x y z; cbn beta. lhs nrapply ap. 2: rhs nrapply ap. 1,3: lhs rapply inverse_sg_op; nrapply (ap (.* _)); rapply inverse_sg_op. change (abel_in z^ * abel_in y^ * abel_in x^ = abel_in y^ * abel_in z^ * abel_in x^). apply (ap (.* _)). exact (commutativity (abel_in z^) (abel_in y^)). Defined. (** Again by [Abel_ind_hprop] and the corresponding laws for [G] we can prove the left and right inverse laws. *) Global Instance leftinverse_abel : LeftInverse (.*.) (^) 1. Proof. Abel_ind_hprop x; simpl. nrapply (ap abel_in); apply left_inverse. Defined. Instance rightinverse_abel : RightInverse (.*.) (^) 1. Proof. Abel_ind_hprop x; simpl. nrapply (ap abel_in); apply right_inverse. Defined. (** Thus [Abel G] is a group *) Global Instance isgroup_abel : IsGroup (Abel G) := {}. (** And furthermore, since the operation is commutative, it is an abelian group. *) Global Instance isabgroup_abel : IsAbGroup (Abel G) := {}. (** By definition, the map [abel_in] is also a group homomorphism. *) Global Instance issemigrouppreserving_abel_in : IsSemiGroupPreserving abel_in. Proof. by unfold IsSemiGroupPreserving. Defined. End AbelGroup. (** We can easily prove that [abel_in] is a surjection. *) Global Instance issurj_abel_in {G : Group} : IsSurjection (@abel_in G). Proof. apply BuildIsSurjection. Abel_ind_hprop x; cbn beta. apply tr. exists x. reflexivity. Defined. (** Now we finally check that our definition of abelianization satisfies the universal property of being an abelianization. *) (** We define [abel] to be the abelianization of a group. This is a map from [Group] to [AbGroup]. *) Definition abel : Group -> AbGroup. Proof. intro G. snrapply Build_AbGroup. - srapply (Build_Group (Abel G)). - exact _. Defined. (** We don't wish for [abel G] to be unfolded when using [simpl] or [cbn]. *) Arguments abel G : simpl never. (** The unit of this map is the map [abel_in] which typeclasses can pick up to be a homomorphism. We write it out explicitly here. *) Definition abel_unit {G : Group} : G $-> abel G := @Build_GroupHomomorphism G (abel G) abel_in _. Definition grp_homo_abel_rec {G : Group} {A : AbGroup} (f : G $-> A) : abel G $-> A. Proof. snrapply Build_GroupHomomorphism. { srapply (Abel_rec _ _ f). intros x y z. nrapply grp_homo_op_agree; trivial. refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^). apply commutativity. } intros y. Abel_ind_hprop x; revert y. Abel_ind_hprop y. apply grp_homo_op. Defined. Definition abel_ind_homotopy {G H : Group} {f g : Hom (A:=Group) (abel G) H} (p : f $o abel_unit $== g $o abel_unit) : f $== g. Proof. rapply Abel_ind_hprop. rapply p. Defined. (** Finally we can prove that our construction abel is an abelianization. *) Global Instance isabelianization_abel {G : Group} : IsAbelianization (abel G) abel_unit. Proof. intros A. constructor. { intros h. snrefine (grp_homo_abel_rec h; _). cbn. reflexivity. } intros g h p. Abel_ind_hprop x. exact (p x). Defined. Theorem groupiso_isabelianization {G : Group} (A B : AbGroup) (eta1 : GroupHomomorphism G A) (eta2 : GroupHomomorphism G B) {isab1 : IsAbelianization A eta1} {isab2 : IsAbelianization B eta2} : A ≅ B. Proof. destruct (esssurj (group_precomp B eta1) eta2) as [a ac]. destruct (esssurj (group_precomp A eta2) eta1) as [b bc]. srapply (Build_GroupIsomorphism _ _ a). srapply (isequiv_adjointify _ b). { refine (essinj (group_precomp B eta2) (x := a $o b) (y := Id (A := Group) B) _). intros x; cbn in *. refine (_ @ ac x). apply ap, bc. } { refine (essinj (group_precomp A eta1) (x := b $o a) (y := Id (A := Group) A) _). intros x; cbn in *. refine (_ @ bc x). apply ap, ac. } Defined. Theorem homotopic_isabelianization {G : Group} (A B : AbGroup) (eta1 : GroupHomomorphism G A) (eta2 : GroupHomomorphism G B) {isab1 : IsAbelianization A eta1} {isab2 : IsAbelianization B eta2} : eta2 == grp_homo_compose (groupiso_isabelianization A B eta1 eta2) eta1. Proof. intros x. symmetry. exact ((esssurj (group_precomp B eta1) eta2).2 x). Defined. (** Hence any abelianization is surjective. *) Global Instance issurj_isabelianization {G : Group} (A : AbGroup) (eta : GroupHomomorphism G A) : IsAbelianization A eta -> IsSurjection eta. Proof. intros k. pose (homotopic_isabelianization A (abel G) eta abel_unit) as p. exact (@cancelL_isequiv_conn_map _ _ _ _ _ _ _ (conn_map_homotopic _ _ _ p _)). Defined. Global Instance isabelianization_identity (A : AbGroup) : IsAbelianization A grp_homo_id. Proof. intros B. constructor. - intros h; exact (h ; fun _ => idpath). - intros g h p; exact p. Defined. Global Instance isequiv_abgroup_abelianization (A B : AbGroup) (eta : GroupHomomorphism A B) {isab : IsAbelianization B eta} : IsEquiv eta. Proof. srapply isequiv_homotopic. - srapply (groupiso_isabelianization A B grp_homo_id eta). - exact _. - symmetry; apply homotopic_isabelianization. Defined. (** ** Functoriality *) Global Instance is0functor_abel : Is0Functor abel. Proof. snrapply Build_Is0Functor. intros A B f. snrapply grp_homo_abel_rec. exact (abel_unit $o f). Defined. Global Instance is1functor_abel : Is1Functor abel. Proof. snrapply Build_Is1Functor. - intros A B f g p. unfold abel. rapply Abel_ind_hprop. intros x. exact (ap abel_in (p x)). - intros A. by rapply Abel_ind_hprop. - intros A B C f g. by rapply Abel_ind_hprop. Defined. Coq-HoTT-9.0/theories/Algebra/AbGroups/Biproduct.v000066400000000000000000000260541474641544500217700ustar00rootroot00000000000000Require Import Basics Types Truncations.Core. Require Import WildCat. Require Import HSet. Require Import AbelianGroup. Require Import Modalities.ReflectiveSubuniverse. Local Open Scope mc_add_scope. (** * Biproducts of abelian groups *) Definition ab_biprod@{u} (A B : AbGroup@{u}) : AbGroup@{u}. Proof. rapply (Build_AbGroup (grp_prod A B)). intros [a b] [a' b']. apply path_prod; simpl; apply commutativity. Defined. (** These inherit [IsEmbedding] instances from their [grp_prod] versions. *) Definition ab_biprod_inl {A B : AbGroup} : A $-> ab_biprod A B := grp_prod_inl. Definition ab_biprod_inr {A B : AbGroup} : B $-> ab_biprod A B := grp_prod_inr. (** These inherit [IsSurjection] instances from their [grp_prod] versions. *) Definition ab_biprod_pr1 {A B : AbGroup} : ab_biprod A B $-> A := grp_prod_pr1. Definition ab_biprod_pr2 {A B : AbGroup} : ab_biprod A B $-> B := grp_prod_pr2. Definition ab_biprod_ind {A B : AbGroup} (P : ab_biprod A B -> Type) (Hinl : forall a, P (ab_biprod_inl a)) (Hinr : forall b, P (ab_biprod_inr b)) (Hop : forall x y, P x -> P y -> P (x + y)) : forall x, P x. Proof. intros [a b]. snrapply ((grp_prod_decompose a b)^ # _). apply Hop. - exact (Hinl a). - exact (Hinr b). Defined. Definition ab_biprod_ind_homotopy {A B C : AbGroup} {f g : ab_biprod A B $-> C} (Hinl : f $o ab_biprod_inl $== g $o ab_biprod_inl) (Hinr : f $o ab_biprod_inr $== g $o ab_biprod_inr) : f $== g. Proof. rapply ab_biprod_ind. - exact Hinl. - exact Hinr. - intros x y p q. lhs nrapply grp_homo_op. rhs nrapply grp_homo_op. f_ap. Defined. (* Maps out of biproducts are determined on the two inclusions. *) Definition equiv_ab_biprod_ind_homotopy `{Funext} {A B X : AbGroup} (phi psi : ab_biprod A B $-> X) : (phi $o ab_biprod_inl == psi $o ab_biprod_inl) * (phi $o ab_biprod_inr == psi $o ab_biprod_inr) <~> phi == psi. Proof. apply equiv_iff_hprop. - exact (uncurry ab_biprod_ind_homotopy). - exact (fun h => (fun a => h _, fun b => h _)). Defined. (** Recursion principle *) Proposition ab_biprod_rec {A B Y : AbGroup} (f : A $-> Y) (g : B $-> Y) : (ab_biprod A B) $-> Y. Proof. snrapply Build_GroupHomomorphism. - intros [a b]; exact (f a + g b). - intros [a b] [a' b']; simpl. rewrite (grp_homo_op f). rewrite (grp_homo_op g). rewrite (associativity _ (g b) _). rewrite <- (associativity _ (f a') _). rewrite (commutativity (f a') _). rewrite (associativity _ (g b) _). exact (associativity _ (f a') _)^. Defined. Corollary ab_biprod_rec_uncurried {A B Y : AbGroup} : (A $-> Y) * (B $-> Y) -> (ab_biprod A B) $-> Y. Proof. intros [f g]. exact (ab_biprod_rec f g). Defined. Proposition ab_biprod_rec_eta {A B Y : AbGroup} (u : ab_biprod A B $-> Y) : ab_biprod_rec (u $o ab_biprod_inl) (u $o ab_biprod_inr) == u. Proof. intros [a b]; simpl. refine ((grp_homo_op u _ _)^ @ ap u _). apply path_prod. - exact (right_identity a). - exact (left_identity b). Defined. Proposition ab_biprod_rec_beta_inl {A B Y : AbGroup} (a : A $-> Y) (b : B $-> Y) : (ab_biprod_rec a b) $o ab_biprod_inl == a. Proof. intro x; simpl. rewrite (grp_homo_unit b). exact (right_identity (a x)). Defined. Proposition ab_biprod_rec_beta_inr {A B Y : AbGroup} (a : A $-> Y) (b : B $-> Y) : (ab_biprod_rec a b) $o ab_biprod_inr == b. Proof. intro y; simpl. rewrite (grp_homo_unit a). exact (left_identity (b y)). Defined. Theorem isequiv_ab_biprod_rec `{Funext} {A B Y : AbGroup} : IsEquiv (@ab_biprod_rec_uncurried A B Y). Proof. srapply isequiv_adjointify. - intro phi. exact (phi $o ab_biprod_inl, phi $o ab_biprod_inr). - intro phi. apply equiv_path_grouphomomorphism. exact (ab_biprod_rec_eta phi). - intros [a b]. apply path_prod. + apply equiv_path_grouphomomorphism. apply ab_biprod_rec_beta_inl. + apply equiv_path_grouphomomorphism. apply ab_biprod_rec_beta_inr. Defined. (** Corecursion principle, inherited from Groups/Group.v. *) Definition ab_biprod_corec {A B X : AbGroup} (f : X $-> A) (g : X $-> B) : X $-> ab_biprod A B := grp_prod_corec f g. (** *** Functoriality of [ab_biprod] *) Definition functor_ab_biprod {A A' B B' : AbGroup} (f : A $-> A') (g: B $-> B') : ab_biprod A B $-> ab_biprod A' B' := (ab_biprod_corec (f $o ab_biprod_pr1) (g $o ab_biprod_pr2)). Definition ab_biprod_functor_beta {Z X Y A B : AbGroup} (f0 : Z $-> X) (f1 : Z $-> Y) (g0 : X $-> A) (g1 : Y $-> B) : functor_ab_biprod g0 g1 $o ab_biprod_corec f0 f1 $== ab_biprod_corec (g0 $o f0) (g1 $o f1) := fun _ => idpath. Global Instance is0bifunctor_ab_biprod : Is0Bifunctor ab_biprod. Proof. srapply Build_Is0Bifunctor'. snrapply Build_Is0Functor. intros [A B] [A' B'] [f g]. exact (functor_ab_biprod f g). Defined. Global Instance is1bifunctor_ab_biprod : Is1Bifunctor ab_biprod. Proof. snrapply Build_Is1Bifunctor'. snrapply Build_Is1Functor. - intros [A B] [A' B'] [f g] [f' g'] [p q] [a b]. snrapply equiv_path_prod. exact (p a, q b). - reflexivity. - cbn; reflexivity. Defined. Definition isequiv_functor_ab_biprod {A A' B B' : AbGroup} (f : A $-> A') (g : B $-> B') `{IsEquiv _ _ f} `{IsEquiv _ _ g} : IsEquiv (functor_ab_biprod f g). Proof. srapply isequiv_adjointify. 1: { rapply functor_ab_biprod; apply grp_iso_inverse. + exact (Build_GroupIsomorphism _ _ f _). + exact (Build_GroupIsomorphism _ _ g _). } all: intros [a b]; simpl. all: apply path_prod'. 1,2: apply eisretr. all: apply eissect. Defined. Definition equiv_functor_ab_biprod {A A' B B' : AbGroup} (f : A $-> A') (g : B $-> B') `{IsEquiv _ _ f} `{IsEquiv _ _ g} : GroupIsomorphism (ab_biprod A B) (ab_biprod A' B') := Build_GroupIsomorphism _ _ _ (isequiv_functor_ab_biprod f g). (** Biproducts preserve embeddings. *) Definition functor_ab_biprod_embedding {A A' B B' : AbGroup} (i : A $-> B) (i' : A' $-> B') `{IsEmbedding i} `{IsEmbedding i'} : IsEmbedding (functor_ab_biprod i i'). Proof. intros [b b']. apply hprop_allpath. intros [[a0 a0'] p] [[a1 a1'] p']; cbn in p, p'. rapply path_sigma_hprop; cbn. pose (q := (equiv_path_prod _ _)^-1 p); cbn in q. pose (q' := (equiv_path_prod _ _)^-1 p'); cbn in q'. destruct q as [q0 q1], q' as [q0' q1']. apply path_prod; rapply isinj_embedding; cbn. - exact (q0 @ q0'^). - exact (q1 @ q1'^). Defined. (** Products preserve surjections. *) Definition functor_ab_biprod_surjection `{Funext} {A A' B B' : AbGroup} (p : A $-> B) (p' : A' $-> B') `{S : IsSurjection p} `{S' : IsSurjection p'} : IsSurjection (functor_ab_biprod p p'). Proof. intros [b b']. pose proof (a := S b); pose proof (a' := S' b'). apply center in a, a'. strip_truncations. rapply contr_inhabited_hprop. apply tr. exists (ab_biprod_inl a.1 + ab_biprod_inr a'.1); cbn. apply path_prod; refine (grp_homo_op _ _ _ @ _); rewrite (grp_homo_unit _); cbn. - exact (right_identity _ @ a.2). - exact (left_identity _ @ a'.2). Defined. (** *** Lemmas for working with biproducts *) (** The swap isomorphism of the biproduct of two groups. *) Definition direct_sum_swap {A B : AbGroup} : ab_biprod A B $<~> ab_biprod B A. Proof. snrapply Build_GroupIsomorphism'. - apply equiv_prod_symm. - intro; reflexivity. Defined. (** Addition [+] is a group homomorphism [A+A -> A]. *) Definition ab_codiagonal {A : AbGroup} : ab_biprod A A $-> A := ab_biprod_rec grp_homo_id grp_homo_id. Definition ab_codiagonal_natural {A B : AbGroup} (f : A $-> B) : f $o ab_codiagonal $== ab_codiagonal $o functor_ab_biprod f f := fun a => grp_homo_op f _ _. Definition ab_diagonal {A : AbGroup} : A $-> ab_biprod A A := ab_biprod_corec grp_homo_id grp_homo_id. (** Given two abelian group homomorphisms [f] and [g], their pairing [(f, g) : B -> A + A] can be written as a composite. Note that [ab_biprod_corec] is an alias for [grp_prod_corec]. *) Lemma ab_biprod_corec_diagonal `{Funext} {A B : AbGroup} (f g : B $-> A) : ab_biprod_corec f g = (functor_ab_biprod f g) $o ab_diagonal. Proof. apply equiv_path_grouphomomorphism; reflexivity. Defined. (** Precomposing the codiagonal with the swap map has no effect. *) Lemma ab_codiagonal_swap `{Funext} {A : AbGroup} : (@ab_codiagonal A) $o direct_sum_swap = ab_codiagonal. Proof. apply equiv_path_grouphomomorphism. intro a; cbn. exact (abgroup_commutative _ _ _). Defined. (** The corresponding result for the diagonal is true definitionally, so it isn't strictly necessary to state it, but we record it anyways. *) Definition ab_diagonal_swap {A : AbGroup} : direct_sum_swap $o (@ab_diagonal A) = ab_diagonal := idpath. (** The biproduct is associative. *) Lemma ab_biprod_assoc {A B C : AbGroup} : ab_biprod A (ab_biprod B C) $<~> ab_biprod (ab_biprod A B) C. Proof. snrapply Build_GroupIsomorphism'. - apply equiv_prod_assoc. - unfold IsSemiGroupPreserving; reflexivity. Defined. (** The iterated diagonals [(ab_diagonal + id) o ab_diagonal] and [(id + ab_diagonal) o ab_diagonal] agree, after reassociating the direct sum. *) Definition ab_commute_id_diagonal {A : AbGroup} : (functor_ab_biprod (@ab_diagonal A) grp_homo_id) $o ab_diagonal = ab_biprod_assoc $o (functor_ab_biprod grp_homo_id ab_diagonal) $o ab_diagonal := idpath. (** A similar result for the codiagonal. *) Lemma ab_commute_id_codiagonal `{Funext} {A : AbGroup} : (@ab_codiagonal A) $o (functor_ab_biprod ab_codiagonal grp_homo_id) $o ab_biprod_assoc = ab_codiagonal $o (functor_ab_biprod grp_homo_id ab_codiagonal). Proof. apply equiv_path_grouphomomorphism. intro a; cbn. exact (grp_assoc _ _ _)^. Defined. (** The next few results are used to prove associativity of the Baer sum. *) (** A "twist" isomorphism [(A + B) + C <~> (C + B) + A]. *) Lemma ab_biprod_twist {A B C : AbGroup@{u}} : ab_biprod (ab_biprod A B) C $<~> ab_biprod (ab_biprod C B) A. Proof. snrapply Build_GroupIsomorphism. - snrapply Build_GroupHomomorphism. + intros [[a b] c]. exact ((c,b),a). + unfold IsSemiGroupPreserving. reflexivity. - snrapply isequiv_adjointify. + intros [[c b] a]. exact ((a,b),c). + reflexivity. + reflexivity. Defined. (** The triagonal and cotriagonal homomorphisms. *) Definition ab_triagonal {A : AbGroup} : A $-> ab_biprod (ab_biprod A A) A := (functor_ab_biprod ab_diagonal grp_homo_id) $o ab_diagonal. Definition ab_cotriagonal {A : AbGroup} : ab_biprod (ab_biprod A A) A $-> A := ab_codiagonal $o (functor_ab_biprod ab_codiagonal grp_homo_id). (** For an abelian group [A], precomposing the triagonal on [A] with the twist map on [A] has no effect. *) Definition ab_triagonal_twist {A : AbGroup} : ab_biprod_twist $o @ab_triagonal A = ab_triagonal := idpath. (** A similar result for the cotriagonal. *) Definition ab_cotriagonal_twist `{Funext} {A : AbGroup} : @ab_cotriagonal A $o ab_biprod_twist = ab_cotriagonal. Proof. apply equiv_path_grouphomomorphism. intro x. cbn. refine ((grp_assoc _ _ _)^ @ _). refine (abgroup_commutative _ _ _ @ _). exact (ap (fun a => a + snd x) (abgroup_commutative _ _ _)). Defined. Coq-HoTT-9.0/theories/Algebra/AbGroups/Centralizer.v000066400000000000000000000065021474641544500223130ustar00rootroot00000000000000Require Import Basics Types Truncations.Core. Require Import HFiber AbelianGroup. (* Given a group [G], we define the centralizer of an element [g : G] as a subgroup and use this to show that the cyclic subgroup generated by [g] is abelian. *) Local Open Scope mc_scope. Local Open Scope mc_mult_scope. (* First we show that the collection of elements that commute with a fixed element [g] is a subgroup. *) Definition centralizer {G : Group} (g : G) := fun h => g * h = h * g. Definition centralizer_unit {G : Group} (g : G) : centralizer g mon_unit := grp_g1_1g _ _ idpath. Definition centralizer_sgop {G : Group} (g h k : G) (p : centralizer g h) (q : centralizer g k) : centralizer g (h * k). Proof. refine (grp_assoc _ _ _ @ _). refine (ap (fun x => x * k) p @ _). refine ((grp_assoc _ _ _)^ @ _). refine (ap (fun x => h * x) q @ _). apply grp_assoc. Defined. Definition centralizer_inverse {G : Group} (g h : G) (p : centralizer g h) : centralizer g h^. Proof. unfold centralizer in *. symmetry. apply grp_g1_1g. refine (ap ((_ * g) *.) (grp_inv_r h)^ @ _ @ ap (.* (g * _)) (grp_inv_l h)). refine (grp_assoc _ _ _ @ _ @ (grp_assoc _ _ _)^). refine (ap (.* h^) _). refine ((grp_assoc _ _ _)^ @ _ @ grp_assoc _ _ _). exact (ap (h^ *.) p). Defined. Global Instance issubgroup_centralizer {G : Group} (g : G) : IsSubgroup (centralizer g). Proof. srapply Build_IsSubgroup. - apply centralizer_unit. - apply centralizer_sgop. - apply centralizer_inverse. Defined. Definition centralizer_subgroup {G : Group} (g : G) := Build_Subgroup G (centralizer g) _. (* Now we define cyclic subgroups. We allow any map [Unit -> G] in this definition, because in applications (such as [Z_commutative]) we have no control over the map. *) Definition cyclic_subgroup_from_unit {G : Group} (gen : Unit -> G) := subgroup_generated (hfiber gen). (* When we have a particular element [g] of [G], we could choose the predicate to be [fun h => h = g], but to fit into the above definition, we use [unit_name g], which gives the predicate [fun h => hfiber (unit_name g) h]. *) Definition cyclic_subgroup {G : Group} (g : G) := cyclic_subgroup_from_unit (unit_name g). (* Any cyclic subgroup is commutative. *) Global Instance commutative_cyclic_subgroup {G : Group} (gen : Unit -> G) : Commutative (@group_sgop (cyclic_subgroup_from_unit gen)). Proof. intros h k. destruct h as [h H]; cbn in H. destruct k as [k K]; cbn in K. strip_truncations. (* It's enough to check equality after including into G: *) apply (equiv_ap_isembedding (subgroup_incl _) _ _)^-1. cbn. induction H as [h [[] p]| |h1 h2 H1 H2 IHH1 IHH2]. - (* The case when h = g: *) induction p. induction K as [k [[] q]| |k1 k2 K1 K2 IHK1 IHK2]. + (* The case when k = g: *) induction q. reflexivity. + (* The case when k = mon_unit: *) apply centralizer_unit. + (* The case when k = k1 (-k2): *) srapply (issubgroup_in_op_inv (H:=centralizer (gen tt))); assumption. - (* The case when h = mon_unit: *) symmetry; apply centralizer_unit. - (* The case when h = h1 (-h2): *) symmetry. srapply (issubgroup_in_op_inv (H:=centralizer k)); unfold centralizer; symmetry; assumption. Defined. Definition abgroup_cyclic_subgroup {G : Group} (g : G) : AbGroup := Build_AbGroup (cyclic_subgroup g) _. Coq-HoTT-9.0/theories/Algebra/AbGroups/Cyclic.v000066400000000000000000000010571474641544500212370ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics WildCat.Core AbelianGroup AbGroups.Z Spaces.Int Groups.QuotientGroup. (** * Cyclic groups *) (** The [n]-th cyclic group is the cokernel of [ab_mul n]. *) Definition cyclic (n : nat) : AbGroup := ab_cokernel (ab_mul (A:=abgroup_Z) n). Definition cyclic_in (n : nat) : abgroup_Z $-> cyclic n := grp_quotient_map. Definition ab_mul_cyclic_in (n : nat) (x y : abgroup_Z) : ab_mul y (cyclic_in n x) = cyclic_in n (y * x)%int. Proof. lhs_V nrapply ab_mul_natural. apply ap, abgroup_Z_ab_mul. Defined. Coq-HoTT-9.0/theories/Algebra/AbGroups/FiniteSum.v000066400000000000000000000050071474641544500217330ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import Spaces.Nat.Core Spaces.Int. Require Export Classes.interfaces.canonical_names (Commutative). Require Export Classes.interfaces.abstract_algebra (IsAbGroup(..), abgroup_group, abgroup_commutative). Require Import AbelianGroup. Local Open Scope mc_scope. Local Open Scope mc_add_scope. (** * Finite Sums *) (** Indexed finite sum of abelian group elements. *) Definition ab_sum {A : AbGroup} (n : nat) (f : forall k, (k < n)%nat -> A) : A. Proof. induction n as [|n IHn]. - exact 0. - refine (f n _ + IHn _). intros k Hk. exact (f k _). Defined. (** If the function is constant in the range of a finite sum then the sum is equal to the constant times [n]. This is a group power in the underlying group. *) Definition ab_sum_const {A : AbGroup} (n : nat) (a : A) (f : forall k, (k < n)%nat -> A) (p : forall k Hk, f k Hk = a) : ab_sum n f = ab_mul n a. Proof. induction n as [|n IHn] in f, p |- *. - reflexivity. - rhs_V nrapply (ap@{Set _} _ (int_nat_succ n)). rhs nrapply grp_pow_succ. simpl. f_ap. apply IHn. intros. apply p. Defined. (** If the function is zero in the range of a finite sum then the sum is zero. *) Definition ab_sum_zero {A : AbGroup} (n : nat) (f : forall k, (k < n)%nat -> A) (p : forall k Hk, f k Hk = 0) : ab_sum n f = 0. Proof. lhs nrapply (ab_sum_const _ 0 f p). apply grp_pow_unit. Defined. (** Finite sums distribute over addition. *) Definition ab_sum_plus {A : AbGroup} (n : nat) (f g : forall k, (k < n)%nat -> A) : ab_sum n (fun k Hk => f k Hk + g k Hk) = ab_sum n (fun k Hk => f k Hk) + ab_sum n (fun k Hk => g k Hk). Proof. induction n as [|n IHn]. 1: by rewrite grp_unit_l. simpl. rewrite <- !grp_assoc; f_ap. rewrite IHn, abgroup_commutative, <- grp_assoc; f_ap. by rewrite abgroup_commutative. Defined. (** Double finite sums commute. *) Definition ab_sum_sum {A : AbGroup} (m n : nat) (f : forall i j, (i < m)%nat -> (j < n)%nat -> A) : ab_sum m (fun i Hi => ab_sum n (fun j Hj => f i j Hi Hj)) = ab_sum n (fun j Hj => ab_sum m (fun i Hi => f i j Hi Hj)). Proof. induction n as [|n IHn] in m, f |- *. 1: by nrapply ab_sum_zero. lhs nrapply ab_sum_plus; cbn; f_ap. Defined. (** Finite sums are equal if the functions are equal in the range. *) Definition path_ab_sum {A : AbGroup} {n : nat} {f g : forall k, (k < n)%nat -> A} (p : forall k Hk, f k Hk = g k Hk) : ab_sum n f = ab_sum n g. Proof. induction n as [|n IHn]. 1: reflexivity. cbn; f_ap. by apply IHn. Defined. Coq-HoTT-9.0/theories/Algebra/AbGroups/FreeAbelianGroup.v000066400000000000000000000057761474641544500232170ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.Equivalences. Require Import Types.Sigma Types.Forall Types.Paths. Require Import WildCat.Core WildCat.EquivGpd WildCat.Universe. Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Abelianization. Require Import Algebra.Groups.FreeGroup. Require Import Spaces.List.Core. (** * Free Abelian Groups *) Definition FactorsThroughFreeAbGroup (S : Type) (F_S : AbGroup) (i : S -> F_S) (A : AbGroup) (g : S -> A) : Type := {f : F_S $-> A & f o i == g}. (** Universal property of a free abelian group on a set (type). *) Class IsFreeAbGroupOn (S : Type) (F_S : AbGroup) (i : S -> F_S) := contr_isfreeabgroupon : forall (A : AbGroup) (g : S -> A), Contr (FactorsThroughFreeAbGroup S F_S i A g). Global Existing Instance contr_isfreeabgroupon. (** A abelian group is free if there exists a generating type on which it is a free group (a basis). *) Class IsFreeAbGroup (F_S : AbGroup) := isfreegroup : {S : _ & {i : _ & IsFreeAbGroupOn S F_S i}}. Global Instance isfreeabgroup_isfreeabgroupon (S : Type) (F_S : AbGroup) (i : S -> F_S) {H : IsFreeAbGroupOn S F_S i} : IsFreeAbGroup F_S := (S; i; H). (** The abelianization of the free group on a set is the free abelian group. *) Definition FreeAbGroup (S : Type) : AbGroup := abel (FreeGroup S). Arguments FreeAbGroup S : simpl never. Definition freeabgroup_in {S : Type} : S -> FreeAbGroup S := abel_unit o freegroup_in. Definition FreeAbGroup_rec {S : Type} {A : AbGroup} (f : S -> A) : FreeAbGroup S $-> A := grp_homo_abel_rec (FreeGroup_rec f). Definition FreeAbGroup_rec_beta_in {S : Type} {A : AbGroup} (f : S -> A) : FreeAbGroup_rec f o freeabgroup_in == f := fun _ => idpath. Definition FreeAbGroup_ind_homotopy {X : Type} {A : AbGroup} {f f' : FreeAbGroup X $-> A} (p : forall x, f (freeabgroup_in x) = f' (freeabgroup_in x)) : f $== f'. Proof. snrapply abel_ind_homotopy. snrapply FreeGroup_ind_homotopy. snrapply p. Defined. (** The abelianization of a free group on a set is a free abelian group on that set. *) Global Instance isfreeabgroupon_isabelianization_isfreegroup `{Funext} {S : Type} {G : Group} {A : AbGroup} (f : S -> G) (g : G $-> A) {H1 : IsAbelianization A g} {H2 : IsFreeGroupOn S G f} : IsFreeAbGroupOn S A (g o f). Proof. unfold IsFreeAbGroupOn. intros B h. specialize (H2 B h). revert H2. unfold FactorsThroughFreeGroup, FactorsThroughFreeAbGroup. snrapply contr_equiv'. symmetry. exact (equiv_functor_sigma_pb (equiv_group_precomp_isabelianization g B)). Defined. (** As a special case, the free abelian group is a free abelian group. *) Global Instance isfreeabgroup_freeabgroup `{Funext} (S : Type) : IsFreeAbGroup (FreeAbGroup S). Proof. exists S, freeabgroup_in. srapply isfreeabgroupon_isabelianization_isfreegroup. Defined. (** Functoriality follows from the functoriality of [abel] and [FreeGroup]. *) Global Instance is0functor_freeabgroup : Is0Functor FreeAbGroup := _. Global Instance is1functor_freeabgroup : Is1Functor FreeAbGroup := _. Coq-HoTT-9.0/theories/Algebra/AbGroups/TensorProduct.v000066400000000000000000001011531474641544500226420ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import Types.Forall Types.Sigma Types.Prod. Require Import WildCat.Core WildCat.Equiv WildCat.Monoidal WildCat.Bifunctor. Require Import WildCat.NatTrans WildCat.MonoidalTwistConstruction. Require Import Algebra.Groups.Group Algebra.Groups.QuotientGroup. Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Biproduct. Require Import Algebra.AbGroups.AbHom Algebra.AbGroups.FreeAbelianGroup. Require Import Algebra.AbGroups.Abelianization Algebra Algebra.Groups.FreeGroup. Require Import Colimits.Quotient. Require Import Spaces.List.Core Spaces.Int. Require Import AbGroups.Z. Require Import Truncations. Local Open Scope mc_add_scope. (** * The Tensor Product of Abelian Groups *) (** Various maps [A * B → C] from the cartesian product of two abelian groups to another abelian group are "biadditive" (also called "bilinear"), meaning that they are group homomorphisms when we fix the left or right argument. The tensor product of abelian groups is a construction that produces an abelian group [A ⊗ B] along with a biadditive map [A * B -> A ⊗ B] which is initial among biadditive maps from [A * B]. This means that any biadditive map [A * B → C] factors uniquely through the tensor product via a group homomorphism [A ⊗ B -> C]. Biadditive functions appear in all sorts of contexts ranging from linear algebra to analysis. Therefore having a way to systematically study them is very useful. *) (** ** Construction *) (** We define the tensor product of abelian groups as a quotient of the free abelian group on pairs of elements of the two groups by the subgroup generated by the biadditive pairs. *) (** Here we define the subgroup of biadditive pairs in two steps. *) Definition family_biadditive_pairs {A B : AbGroup} : FreeAbGroup (A * B) -> Type. Proof. intros x. refine ((exists (a1 a2 : A) (b : B), _) + exists (a : A) (b1 b2 : B), _)%type. - refine (- _ + (_ + _) = x). 1-3: apply freeabgroup_in. + exact (a1 + a2, b). + exact (a1, b). + exact (a2, b). - refine (- _ + (_ + _) = x). 1-3: apply freeabgroup_in. + exact (a, b1 + b2). + exact (a, b1). + exact (a, b2). Defined. Definition subgroup_biadditive_pairs {A B : AbGroup} : Subgroup (FreeAbGroup (A * B)) := subgroup_generated family_biadditive_pairs. (** The tensor product [ab_tensor_prod A B] of two abelian groups [A] and [B] is defined to be a quotient of the free abelian group on pairs of elements [A * B] by the subgroup of biadditive pairs. *) Definition ab_tensor_prod (A B : AbGroup) : AbGroup := QuotientAbGroup (FreeAbGroup (A * B)) subgroup_biadditive_pairs. Arguments ab_tensor_prod A B : simpl never. (** The tensor product of [A] and [B] contains formal sums and differences of pairs of elements from [A] and [B]. We denote these pairs as "simple tensors" and name them [tensor]. *) Definition tensor {A B : AbGroup} : A -> B -> ab_tensor_prod A B := fun a b => grp_quotient_map (freeabgroup_in (a, b)). (** ** Properties of tensors *) (** The characterizing property of simple tensors are that they are biadditive in their arguments. *) (** A [tensor] of a sum distributes over the sum on the left. *) Definition tensor_dist_l {A B : AbGroup} (a : A) (b b' : B) : tensor a (b + b') = tensor a b + tensor a b'. Proof. apply qglue, tr. apply sgt_in. right. by exists a, b, b'. Defined. (** A [tensor] of a sum distributes over the sum on the right. *) Definition tensor_dist_r {A B : AbGroup} (a a' : A) (b : B) : tensor (a + a') b = tensor a b + tensor a' b. Proof. apply qglue, tr. apply sgt_in. left. by exists a, a', b. Defined. (** Tensoring on the left is a group homomorphism. *) Definition grp_homo_tensor_l {A B : AbGroup} (a : A) : B $-> ab_tensor_prod A B. Proof. snrapply Build_GroupHomomorphism. - exact (fun b => tensor a b). - intros b b'. nrapply tensor_dist_l. Defined. (** Tensoring on the right is a group homomorphism. *) Definition grp_homo_tensor_r {A B : AbGroup} (b : B) : A $-> ab_tensor_prod A B. Proof. snrapply Build_GroupHomomorphism. - exact (fun a => tensor a b). - intros a a'. nrapply tensor_dist_r. Defined. (** Tensors preserve negation in the left argument. *) Definition tensor_neg_l {A B : AbGroup} (a : A) (b : B) : tensor (-a) b = - tensor a b := grp_homo_inv (grp_homo_tensor_r b) a. (** Tensors preserve negation in the right argument. *) Definition tensor_neg_r {A B : AbGroup} (a : A) (b : B) : tensor a (-b) = - tensor a b := grp_homo_inv (grp_homo_tensor_l a) b. (** Tensoring by zero on the left is zero. *) Definition tensor_zero_l {A B : AbGroup} (b : B) : tensor (A:=A) 0 b = 0 := grp_homo_unit (grp_homo_tensor_r b). (** Tensoring by zero on the right is zero. *) Definition tensor_zero_r {A B : AbGroup} (a : A) : tensor (B:=B) a 0 = 0 := grp_homo_unit (grp_homo_tensor_l a). (** The [tensor] map is biadditive and therefore can be written in a curried form using the internal abelian group hom. *) Definition grp_homo_tensor `{Funext} {A B : AbGroup} : A $-> ab_hom B (ab_tensor_prod A B). Proof. snrapply Build_GroupHomomorphism. - intros a. snrapply Build_GroupHomomorphism. + exact (tensor a). + nrapply tensor_dist_l. - intros a a'. apply equiv_path_grouphomomorphism. intros b. nrapply tensor_dist_r. Defined. (** ** Induction principles *) (** Here we write down some induction principles to help us prove lemmas about the tensor product. Some of these are quite specialised but are patterns that appear often in practice. *) (** Our main recursion principle states that in order to build a homomorphism out of the tensor product, it is sufficient to provide a map out of the direct product which is biadditive, that is, a map that preserves addition in each argument of the product. *) (** We separate out the proof of this part, so we can make it opaque. *) Definition ab_tensor_prod_rec_helper {A B C : AbGroup} (f : A -> B -> C) (l : forall a b b', f a (b + b') = f a b + f a b') (r : forall a a' b, f (a + a') b = f a b + f a' b) (x : FreeAbGroup (A * B)) (insg : subgroup_biadditive_pairs x) : grp_homo_abel_rec (FreeGroup_rec (uncurry f)) x = mon_unit. Proof. set (abel_rec := grp_homo_abel_rec (FreeGroup_rec (uncurry f))). strip_truncations. induction insg as [ x biad | | g h insg_g IHg insg_h IHh ]. - destruct biad as [ [ a [ a' [ b p ] ] ] | [ a [ b [ b' p ] ] ] ]. all: destruct p; simpl. all: apply grp_moveL_M1^-1%equiv; symmetry. 1: apply r. apply l. - nrapply grp_homo_unit. - rewrite grp_homo_op, grp_homo_inv. apply grp_moveL_1M^-1. exact (IHg @ IHh^). Defined. Opaque ab_tensor_prod_rec_helper. Definition ab_tensor_prod_rec {A B C : AbGroup} (f : A -> B -> C) (l : forall a b b', f a (b + b') = f a b + f a b') (r : forall a a' b, f (a + a') b = f a b + f a' b) : ab_tensor_prod A B $-> C. Proof. unfold ab_tensor_prod. snrapply grp_quotient_rec. - snrapply FreeAbGroup_rec. exact (uncurry f). - unfold normalsubgroup_subgroup. apply ab_tensor_prod_rec_helper; assumption. Defined. (** A special case that arises. *) Definition ab_tensor_prod_rec' {A B C : AbGroup} (f : A -> (B $-> C)) (l : forall a a' b, f (a + a') b = f a b + f a' b) : ab_tensor_prod A B $-> C. Proof. refine (ab_tensor_prod_rec f _ l). intro a; apply grp_homo_op. Defined. (** We give an induction principle for an hprop-valued type family [P]. It may be surprising at first that we only require [P] to hold for the simple tensors [tensor a b] and be closed under addition. It automatically follows that [P 0] holds (since [tensor 0 0 = 0]) and that [P] is closed under negation (since [tensor -a b = - tensor a b]). This induction principle says that the simple tensors generate the tensor product as a semigroup. *) Definition ab_tensor_prod_ind_hprop {A B : AbGroup} (P : ab_tensor_prod A B -> Type) {H : forall x, IsHProp (P x)} (Hin : forall a b, P (tensor a b)) (Hop : forall x y, P x -> P y -> P (x + y)) : forall x, P x. Proof. unfold ab_tensor_prod. srapply grp_quotient_ind_hprop. srapply Abel_ind_hprop; cbn beta. set (tensor_in := grp_quotient_map $o abel_unit : FreeGroup (A * B) $-> ab_tensor_prod A B). change (forall x, P (tensor_in x)). srapply FreeGroup_ind_hprop'; intros w; cbn beta. induction w. - (* The goal here is [P 0], so we use [Hin 0 0 : P (tensor 0 0)]. *) exact (transport P (tensor_zero_l 0) (Hin 0 0)). - change (P (tensor_in (freegroup_eta [a]%list + freegroup_eta w))). (* This [rewrite] is [reflexivity], but the [Defined] is slow if [change] is used instead. *) rewrite grp_homo_op. destruct a as [[a b]|[a b]]. + change (P (tensor_in (freegroup_in (a, b)) + tensor_in (freegroup_eta w))). apply Hop; trivial. apply Hin. + change (P (tensor_in (- freegroup_in (a, b)) + tensor_in (freegroup_eta w))). (* This [rewrite] is reflexivity, but using [change] to achieve this is slow and slows down the Defined line. *) rewrite grp_homo_inv. apply Hop; trivial. rewrite <- tensor_neg_l. apply Hin. Defined. (** As a commonly occuring special case of the above induction principle, we have the case when the predicate in question is showing that two group homomorphisms out of the tensor product are homotopic. In order to do this, it suffices to show it only for simple tensors. The homotopy is closed under addition, so we don't need to hypothesise anything else. *) Definition ab_tensor_prod_ind_homotopy {A B G : AbGroup} {f f' : ab_tensor_prod A B $-> G} (H : forall a b, f (tensor a b) = f' (tensor a b)) : f $== f'. Proof. nrapply ab_tensor_prod_ind_hprop. - exact _. - exact H. - intros x y; apply grp_homo_op_agree. Defined. (** As an even more specialised case, we occasionally have the second homomorphism being a sum of abelian group homomorphisms. In those cases, it is easier to use this specialised lemma. *) Definition ab_tensor_prod_ind_homotopy_plus {A B G : AbGroup} {f f' f'' : ab_tensor_prod A B $-> G} (H : forall a b, f (tensor a b) = f' (tensor a b) + f'' (tensor a b)) : forall x, f x = f' x + f'' x := ab_tensor_prod_ind_homotopy (f':=f' + f'') H. (** Here we give an induction principle for a triple tensor, a.k.a a dependent trilinear function. *) Definition ab_tensor_prod_ind_hprop_triple {A B C : AbGroup} (P : ab_tensor_prod A (ab_tensor_prod B C) -> Type) (H : forall x, IsHProp (P x)) (Hin : forall a b c, P (tensor a (tensor b c))) (Hop : forall x y, P x -> P y -> P (x + y)) : forall x, P x. Proof. rapply (ab_tensor_prod_ind_hprop P). - intros a. rapply (ab_tensor_prod_ind_hprop (fun x => P (tensor _ x))). + nrapply Hin. + intros x y Hx Hy. rewrite tensor_dist_l. by apply Hop. - exact Hop. Defined. (** Similar to before, we specialise the triple tensor induction principle for proving homotopies of trilinear/triadditive functions. *) Definition ab_tensor_prod_ind_homotopy_triple {A B C G : AbGroup} {f f' : ab_tensor_prod A (ab_tensor_prod B C) $-> G} (H : forall a b c, f (tensor a (tensor b c)) = f' (tensor a (tensor b c))) : f $== f'. Proof. nrapply ab_tensor_prod_ind_hprop_triple. - exact _. - exact H. - intros x y; apply grp_homo_op_agree. Defined. (** As explained for the biadditive and triadditive cases, we also derive an induction principle for quadruple tensors giving us dependent quadrilinear maps. *) Definition ab_tensor_prod_ind_hprop_quad {A B C D : AbGroup} (P : ab_tensor_prod A (ab_tensor_prod B (ab_tensor_prod C D)) -> Type) (H : forall x, IsHProp (P x)) (Hin : forall a b c d, P (tensor a (tensor b (tensor c d)))) (Hop : forall x y, P x -> P y -> P (x + y)) : forall x, P x. Proof. rapply (ab_tensor_prod_ind_hprop P). - intros a. nrapply (ab_tensor_prod_ind_hprop_triple (fun x => P (tensor _ x))). + intro x; apply H. + nrapply Hin. + intros x y Hx Hy. rewrite tensor_dist_l. by apply Hop. - exact Hop. Defined. (** To construct a homotopy between quadrilinear maps we need only check equality for the quadruple simple tensors. *) Definition ab_tensor_prod_ind_homotopy_quad {A B C D G : AbGroup} {f f' : ab_tensor_prod A (ab_tensor_prod B (ab_tensor_prod C D)) $-> G} (H : forall a b c d, f (tensor a (tensor b (tensor c d))) = f' (tensor a (tensor b (tensor c d)))) : f $== f'. Proof. nrapply (ab_tensor_prod_ind_hprop_quad (fun _ => _)). - exact _. - exact H. - intros x y; apply grp_homo_op_agree. Defined. (** ** Universal Property of the Tensor Product *) (** A function of two variables is biadditive if it preserves the operation in each variable. *) Class IsBiadditive {A B C : Type} `{SgOp A, SgOp B, SgOp C} (f : A -> B -> C) := { isbiadditive_l :: forall b, IsSemiGroupPreserving (flip f b); isbiadditive_r :: forall a, IsSemiGroupPreserving (f a); }. Definition issig_IsBiadditive {A B C : Type} `{SgOp A, SgOp B, SgOp C} (f : A -> B -> C) : _ <~> IsBiadditive f := ltac:(issig). (** The truncation level of the [IsBiadditive f] predicate is determined by the truncation level of the codomain. This will almost always be a hset. *) Global Instance istrunc_isbiadditive `{Funext} {A B C : Type} `{SgOp A, SgOp B, SgOp C} (f : A -> B -> C) n `{IsTrunc n.+1 C} : IsTrunc n (IsBiadditive f). Proof. nrapply istrunc_equiv_istrunc. 1: rapply issig_IsBiadditive. unfold IsSemiGroupPreserving. exact _. Defined. (** The simple tensor map is biadditive. *) Global Instance isbiadditive_tensor (A B : AbGroup) : IsBiadditive (@tensor A B) := {| isbiadditive_l := fun b a a' => tensor_dist_r a a' b; isbiadditive_r := tensor_dist_l; |}. (** The type of biadditive maps. *) Record Biadditive (A B C : Type) `{SgOp A, SgOp B, SgOp C} := { biadditive_fun :> A -> B -> C; biadditive_isbiadditive :: IsBiadditive biadditive_fun; }. Definition issig_Biadditive {A B C : Type} `{SgOp A, SgOp B, SgOp C} : _ <~> Biadditive A B C := ltac:(issig). Definition biadditive_ab_tensor_prod {A B C : AbGroup} : (ab_tensor_prod A B $-> C) -> Biadditive A B C. Proof. intros f. exists (fun x y => f (tensor x y)). snrapply Build_IsBiadditive. - intros b a a'; simpl. lhs nrapply (ap f). 1: nrapply tensor_dist_r. nrapply grp_homo_op. - intros a a' b; simpl. lhs nrapply (ap f). 1: nrapply tensor_dist_l. nrapply grp_homo_op. Defined. (** The universal property of the tensor product is that biadditive maps between abelian groups are in one-to-one corresondance with maps out of the tensor product. In this sense, the tensor product is the most perfect object describing biadditive maps between two abelian groups. *) Definition equiv_ab_tensor_prod_rec `{Funext} (A B C : AbGroup) : Biadditive A B C <~> (ab_tensor_prod A B $-> C). Proof. snrapply equiv_adjointify. - intros [f [l r]]. exact (ab_tensor_prod_rec f r (fun a a' b => l b a a')). - snrapply biadditive_ab_tensor_prod. - intros f. snrapply equiv_path_grouphomomorphism. snrapply ab_tensor_prod_ind_homotopy. intros a b; simpl. reflexivity. - intros [f [l r]]. snrapply (equiv_ap_inv' issig_Biadditive). rapply path_sigma_hprop; simpl. reflexivity. Defined. (** ** Functoriality of the Tensor Product *) (** The tensor product produces a bifunctor and we will later show that it gives a symmetric monoidal structure on the category of abelian groups. *) (** Given a pair of maps, we can produce a homomorphism between the pairwise tensor products of the domains and codomains. *) Definition functor_ab_tensor_prod {A B A' B' : AbGroup} (f : A $-> A') (g : B $-> B') : ab_tensor_prod A B $-> ab_tensor_prod A' B'. Proof. snrapply ab_tensor_prod_rec'. - intro a. exact (grp_homo_tensor_l (f a) $o g). - intros a a' b; hnf. rewrite grp_homo_op. nrapply tensor_dist_r. Defined. (** 2-functoriality of the tensor product. *) Definition functor2_ab_tensor_prod {A B A' B' : AbGroup} {f f' : A $-> A'} (p : f $== f') {g g' : B $-> B'} (q : g $== g') : functor_ab_tensor_prod f g $== functor_ab_tensor_prod f' g'. Proof. snrapply ab_tensor_prod_ind_homotopy. intros a b; simpl. exact (ap011 tensor (p _) (q _)). Defined. (** The tensor product functor preserves identity morphisms. *) Definition functor_ab_tensor_prod_id (A B : AbGroup) : functor_ab_tensor_prod (Id A) (Id B) $== Id (ab_tensor_prod A B). Proof. snrapply ab_tensor_prod_ind_homotopy. intros a b; simpl. reflexivity. Defined. (** The tensor product functor preserves composition. *) Definition functor_ab_tensor_prod_compose {A B C A' B' C' : AbGroup} (f : A $-> B) (g : B $-> C) (f' : A' $-> B') (g' : B' $-> C') : functor_ab_tensor_prod (g $o f) (g' $o f') $== functor_ab_tensor_prod g g' $o functor_ab_tensor_prod f f'. Proof. snrapply ab_tensor_prod_ind_homotopy. intros a b; simpl. reflexivity. Defined. (** The tensor product functor is a 0-bifunctor. *) Global Instance is0bifunctor_ab_tensor_prod : Is0Bifunctor ab_tensor_prod. Proof. rapply Build_Is0Bifunctor'. snrapply Build_Is0Functor. intros [A B] [A' B'] [f g]. exact (functor_ab_tensor_prod f g). Defined. (** The tensor product functor is a bifunctor. *) Global Instance is1bifunctor_ab_tensor_prod : Is1Bifunctor ab_tensor_prod. Proof. rapply Build_Is1Bifunctor'. snrapply Build_Is1Functor. - intros AB A'B' fg f'g' [p q]. exact (functor2_ab_tensor_prod p q). - intros [A B]. exact (functor_ab_tensor_prod_id A B). - intros AA' BB' CC' [f g] [f' g']. exact (functor_ab_tensor_prod_compose f f' g g'). Defined. (** ** Symmetry of the Tensor Product *) (** The tensor product is symmetric in that the order in which we take the tensor shouldn't matter upto isomorphism. *) (** We can define a swap map which swaps the order of simple tensors. *) Definition ab_tensor_swap {A B} : ab_tensor_prod A B $-> ab_tensor_prod B A. Proof. snrapply ab_tensor_prod_rec. - exact (flip tensor). - intros a b b'. apply tensor_dist_r. - intros a a' b. apply tensor_dist_l. Defined. (** [ab_tensor_swap] is involutive. *) Definition ab_tensor_swap_swap {A B} : ab_tensor_swap $o @ab_tensor_swap A B $== Id _. Proof. snrapply ab_tensor_prod_ind_homotopy. reflexivity. Defined. (** [ab_tensor_swap] is natural in both arguments. This means that it also acts on tensor functors. *) Definition ab_tensor_swap_natural {A B A' B'} (f : A $-> A') (g : B $-> B') : ab_tensor_swap $o functor_ab_tensor_prod f g $== functor_ab_tensor_prod g f $o ab_tensor_swap. Proof. snrapply ab_tensor_prod_ind_homotopy. simpl. (* This speeds up the [reflexivity] and the [Defined]. *) reflexivity. Defined. (** The swap map gives us a symmetric braiding on the category of abelian groups. We will later show it is a full symmetric monoidal category. *) Global Instance symmetricbraiding_ab_tensor_prod : SymmetricBraiding ab_tensor_prod. Proof. snrapply Build_SymmetricBraiding. - snrapply Build_NatTrans. + intro; exact ab_tensor_swap. + snrapply Build_Is1Natural. intros; nrapply ab_tensor_swap_natural. - intros; nrapply ab_tensor_swap_swap. Defined. (** ** Twisting Triple Tensors *) (** In order to construct the symmetric monoidal category, we will use what is termed the "Twist construction" in Monoidal.v. This simplifies the data of a symmetric monoidal category by constructing it from simpler parts. For instance, instead of having to prove full associativity [(A ⊗ B) ⊗ C $-> A ⊗ (B ⊗ C)], we can provide a twist map [A ⊗ (B ⊗ C) $-> B ⊗ (A ⊗ C)] and use the symmetric braiding we have so far to prove associativity. *) (** In order to be more efficient whilst unfolding definitions, we break up the definition of a twist map into its components. *) Local Definition ab_tensor_prod_twist_map {A B C : AbGroup} : A -> (ab_tensor_prod B C $-> ab_tensor_prod B (ab_tensor_prod A C)). Proof. intros a. snrapply ab_tensor_prod_rec'. - intros b. exact (grp_homo_tensor_l b $o grp_homo_tensor_l a). - intros b b' c; hnf. nrapply tensor_dist_r. Defined. Local Definition ab_tensor_prod_twist_map_additive_l {A B C : AbGroup} (a a' : A) (b : ab_tensor_prod B C) : ab_tensor_prod_twist_map (a + a') b = ab_tensor_prod_twist_map a b + ab_tensor_prod_twist_map a' b. Proof. revert b. nrapply ab_tensor_prod_ind_homotopy_plus. intros b c. change (tensor b (tensor (a + a') c) = tensor b (tensor a c) + tensor b (tensor a' c)). rhs_V nrapply tensor_dist_l. nrapply (ap (tensor b)). nrapply tensor_dist_r. Defined. (** Given a triple tensor product, we have a twist map which permutes the first two components. *) Definition ab_tensor_prod_twist {A B C} : ab_tensor_prod A (ab_tensor_prod B C) $-> ab_tensor_prod B (ab_tensor_prod A C). Proof. snrapply ab_tensor_prod_rec'. - exact ab_tensor_prod_twist_map. - exact ab_tensor_prod_twist_map_additive_l. Defined. (** The twist map is involutive. *) Definition ab_tensor_prod_twist_twist {A B C} : ab_tensor_prod_twist $o @ab_tensor_prod_twist A B C $== Id _. Proof. snrapply ab_tensor_prod_ind_homotopy_triple. reflexivity. Defined. (** The twist map is natural in all 3 arguments. This means that the twist map acts on the triple tensor functor in the same way. *) Definition ab_tensor_prod_twist_natural {A B C A' B' C'} (f : A $-> A') (g : B $-> B') (h : C $-> C') : ab_tensor_prod_twist $o fmap11 ab_tensor_prod f (fmap11 ab_tensor_prod g h) $== fmap11 ab_tensor_prod g (fmap11 ab_tensor_prod f h) $o ab_tensor_prod_twist. Proof. snrapply ab_tensor_prod_ind_homotopy_triple. intros a b c. (* This [change] speeds up the [reflexivity]. [simpl] produces a goal that looks the same, but is still slow. *) change (tensor (g b) (tensor (f a) (h c)) = tensor (g b) (tensor (f a) (h c))). reflexivity. Defined. (** ** Unitality of [abgroup_Z] *) (** In the symmetric monoidal structure on abelian groups, [abgroup_Z] is the unit. We show that tensoring with [abgroup_Z] on the right is isomorphic to the original group. *) (** First we characterise the action of integers via [grp_pow] and their interaction on tensors. This is just a generalisation of the distributivity laws for tensors. *) (** Multiplication in the first factor can be factored out. *) Definition tensor_ab_mul_l {A B : AbGroup} (z : Int) (a : A) (b : B) : tensor (ab_mul z a) b = ab_mul z (tensor a b) := ab_mul_natural (grp_homo_tensor_r b) z a. (** Multiplication in the second factor can be factored out. *) Definition tensor_ab_mul_r {A B : AbGroup} (z : Int) (a : A) (b : B) : tensor a (ab_mul z b) = ab_mul z (tensor a b) := ab_mul_natural (grp_homo_tensor_l a) z b. (** Multiplication can be transferred from one factor to the other. The tensor product of [R]-modules will include this as an extra axiom, but here we have [Z]-modules and we can prove it. *) Definition tensor_ab_mul {A B : AbGroup} (z : Int) (a : A) (b : B) : tensor (ab_mul z a) b = tensor a (ab_mul z b). Proof. rhs nrapply tensor_ab_mul_r. nrapply tensor_ab_mul_l. Defined. (** [abgroup_Z] is a right identity for the tensor product. *) Definition ab_tensor_prod_Z_r {A} : ab_tensor_prod A abgroup_Z $<~> A. Proof. (** Checking that the inverse map is a homomorphism is easier. *) symmetry. snrapply Build_GroupIsomorphism. - nrapply grp_homo_tensor_r. exact 1%int. - snrapply isequiv_adjointify. + snrapply ab_tensor_prod_rec'. * exact grp_pow_homo. * intros a a' z; cbn beta. nrapply (grp_homo_op (ab_mul z)). + hnf. change (forall x : ?A, (grp_homo_map ?f) ((grp_homo_map ?g) x) = x) with (f $o g $== Id _). snrapply ab_tensor_prod_ind_homotopy. intros a z. change (tensor (B:=abgroup_Z) (grp_pow a z) 1%int = tensor a z). lhs nrapply tensor_ab_mul. nrapply ap. lhs nrapply abgroup_Z_ab_mul. apply int_mul_1_r. + exact grp_unit_r. Defined. (** We have a right unitor for the tensor product given by unit [abgroup_Z]. Naturality of [ab_tensor_prod_Z_r] is straightforward to prove. *) Global Instance rightunitor_ab_tensor_prod : RightUnitor ab_tensor_prod abgroup_Z. Proof. snrapply Build_NatEquiv. - intros A. apply ab_tensor_prod_Z_r. - snrapply Build_Is1Natural. intros A A' f. snrapply ab_tensor_prod_ind_homotopy. intros a z; symmetry. exact (grp_pow_natural _ _ _). Defined. (** Since we have symmetry of the tensor product, we get left unitality for free. *) Global Instance left_unitor_ab_tensor_prod : LeftUnitor ab_tensor_prod abgroup_Z. Proof. rapply left_unitor_twist. Defined. (** ** Symmetric Monoidal Structure of Tensor Product *) (** Using the twist construction we can derive an associator for the tensor product. In other words, we have associativity of the tensor product of abelian groups natural in each factor. *) Global Instance associator_ab_tensor_prod : Associator ab_tensor_prod. Proof. srapply associator_twist. - exact @ab_tensor_prod_twist. - intros; nrapply ab_tensor_prod_twist_twist. - intros; nrapply ab_tensor_prod_twist_natural. Defined. (** The triangle identity is straightforward to prove using the custom induction principles we proved earlier. *) Global Instance triangle_ab_tensor_prod : TriangleIdentity ab_tensor_prod abgroup_Z. Proof. snrapply triangle_twist. intros A B. snrapply ab_tensor_prod_ind_homotopy_triple. intros a b z; symmetry. exact (tensor_ab_mul z a b). Defined. (** The hexagon identity is also straighforward to prove. We simply have to reduce all the involved functions on the simple tensors using our custom triple tensor induction principle. *) Global Instance hexagon_ab_tensor_prod : HexagonIdentity ab_tensor_prod. Proof. snrapply hexagon_twist. intros A B C. snrapply ab_tensor_prod_ind_homotopy_triple. intros b a c. change (tensor c (tensor a b) = tensor c (tensor a b)). reflexivity. Defined. (** Finally, we can prove the pentagon identity using the quadruple tensor induction principle. As we did before, the work only involves reducing the involved functions on the simple tensor redexes. *) Global Instance pentagon_ab_tensor_prod : PentagonIdentity ab_tensor_prod. Proof. snrapply pentagon_twist. intros A B C D. snrapply ab_tensor_prod_ind_homotopy_quad. intros a b c d. change (tensor c (tensor d (tensor a b)) = tensor c (tensor d (tensor a b))). reflexivity. Defined. (** We therefore have all the data of a monoidal category. *) Global Instance ismonoidal_ab_tensor_prod : IsMonoidal AbGroup ab_tensor_prod abgroup_Z := {}. (** And furthermore, all the data of a symmetric monoidal category. *) Global Instance issymmmetricmonoidal_ab_tensor_prod : IsSymmetricMonoidal AbGroup ab_tensor_prod abgroup_Z := {}. (** ** Preservation of Coequalizers *) (** The tensor product of abelian groups preserves coequalizers, meaning that the coequalizer of two tensored groups is the tensor of the coequalizer. We show this is the case on the left and the right. *) (** Tensor products preserve coequalizers on the right. *) Definition grp_iso_ab_tensor_prod_coeq_l A {B C} (f g : B $-> C) : ab_coeq (fmap01 ab_tensor_prod A f) (fmap01 ab_tensor_prod A g) $<~> ab_tensor_prod A (ab_coeq f g). Proof. snrapply cate_adjointify. - snrapply ab_coeq_rec. + rapply (fmap01 ab_tensor_prod A). nrapply ab_coeq_in. + refine (_^$ $@ fmap02 ab_tensor_prod _ _ $@ _). 1,3: rapply fmap01_comp. nrapply ab_coeq_glue. - snrapply ab_tensor_prod_rec'. + intros a. snrapply functor_ab_coeq. 1,2: snrapply (grp_homo_tensor_l a). 1,2: hnf; reflexivity. + intros a a'; cbn beta. srapply ab_coeq_ind_hprop. intros x. exact (ap (ab_coeq_in (f:=fmap01 ab_tensor_prod A f) (g:=fmap01 ab_tensor_prod A g)) (tensor_dist_r a a' x)). - snrapply ab_tensor_prod_ind_homotopy. intros a. srapply ab_coeq_ind_hprop. intros c. reflexivity. - snrapply ab_coeq_ind_homotopy. snrapply ab_tensor_prod_ind_homotopy. reflexivity. Defined. (** The equivalence respects the natural maps from [ab_tensor_prod A C]. *) Definition ab_tensor_prod_coeq_l_triangle A {B C} (f g : B $-> C) : grp_iso_ab_tensor_prod_coeq_l A f g $o ab_coeq_in $== fmap01 ab_tensor_prod A ab_coeq_in. Proof. snrapply ab_tensor_prod_ind_homotopy. reflexivity. Defined. (** Tensor products preserve coequalizers on the left. *) Definition grp_iso_ab_tensor_prod_coeq_r {A B} (f g : A $-> B) C : ab_coeq (fmap10 ab_tensor_prod f C) (fmap10 ab_tensor_prod g C) $<~> ab_tensor_prod (ab_coeq f g) C. Proof. refine (braide _ _ $oE _). nrefine (grp_iso_ab_tensor_prod_coeq_l _ f g $oE _). snrapply grp_iso_ab_coeq. 1,2: rapply braide. 1,2: symmetry; nrapply ab_tensor_swap_natural. Defined. (** The equivalence respects the natural maps from [ab_tensor_prod B C]. *) Definition ab_tensor_prod_coeq_r_triangle {A B} (f g : A $-> B) C : grp_iso_ab_tensor_prod_coeq_r f g C $o ab_coeq_in $== fmap10 ab_tensor_prod ab_coeq_in C. Proof. snrapply ab_tensor_prod_ind_homotopy. reflexivity. Defined. (** ** Tensor Product of Free Abelian Groups *) Definition equiv_ab_tensor_prod_freeabgroup X Y : FreeAbGroup (X * Y) $<~> ab_tensor_prod (FreeAbGroup X) (FreeAbGroup Y). Proof. srefine (let f:=_ in let g:=_ in cate_adjointify f g _ _). - snrapply FreeAbGroup_rec. intros [x y]. exact (tensor (freeabgroup_in x) (freeabgroup_in y)). - snrapply ab_tensor_prod_rec. + intros x. snrapply FreeAbGroup_rec. intros y; revert x. unfold FreeAbGroup. snrapply FreeAbGroup_rec. intros x. apply abel_unit. apply freegroup_in. exact (x, y). + intros x y y'. snrapply grp_homo_op. + intros x x'. rapply Abel_ind_hprop. snrapply (FreeGroup_ind_homotopy _ (f' := sgop_hom _ _)). intros y. lhs nrapply FreeGroup_rec_beta. lhs nrapply grp_homo_op. snrapply (ap011 (+) _^ _^). 1,2: nrapply FreeGroup_rec_beta. - snrapply ab_tensor_prod_ind_homotopy. intros x. change (f $o g $o grp_homo_tensor_l x $== grp_homo_tensor_l x). rapply Abel_ind_hprop. change (@abel_in ?G) with (grp_homo_map (@abel_unit G)). repeat change (cat_comp (A:=AbGroup) ?f ?g) with (cat_comp (A:=Group) f g). change (forall y, grp_homo_map ?f (abel_unit y) = grp_homo_map ?g (abel_unit y)) with (cat_comp (A:=Group) f abel_unit $== cat_comp (A:=Group) g abel_unit). rapply FreeGroup_ind_homotopy. intros y; revert x. change (f $o g $o grp_homo_tensor_r (freeabgroup_in y) $== grp_homo_tensor_r (freeabgroup_in y)). rapply Abel_ind_hprop. change (@abel_in ?G) with (grp_homo_map (@abel_unit G)). repeat change (cat_comp (A:=AbGroup) ?f ?g) with (cat_comp (A:=Group) f g). change (forall y, grp_homo_map ?f (abel_unit y) = grp_homo_map ?g (abel_unit y)) with (cat_comp (A:=Group) f abel_unit $== cat_comp (A:=Group) g abel_unit). rapply FreeGroup_ind_homotopy. intros x. reflexivity. - rapply Abel_ind_hprop. change (GpdHom (A:=Hom(A:=Group) (FreeGroup (X * Y)) _) (cat_comp (A:=Group) (g $o f) (@abel_unit (FreeGroup (X * Y)))) (@abel_unit (FreeGroup (X * Y)))). snrapply FreeGroup_ind_homotopy. reflexivity. Defined. (** ** Tensor products distribute over direct sums *) Definition ab_tensor_prod_dist_l {A B C : AbGroup} : ab_tensor_prod A (ab_biprod B C) $<~> ab_biprod (ab_tensor_prod A B) (ab_tensor_prod A C). Proof. srapply (let f := _ in let g := _ in cate_adjointify f g _ _). - snrapply ab_tensor_prod_rec. + intros a bc. exact (tensor a (fst bc), tensor a (snd bc)). + intros a bc bc'; cbn beta. snrapply path_prod'; snrapply tensor_dist_l. + intros a a' bc; cbn beta. snrapply path_prod; snrapply tensor_dist_r. - snrapply ab_biprod_rec. + exact (fmap01 ab_tensor_prod A ab_biprod_inl). + exact (fmap01 ab_tensor_prod A ab_biprod_inr). - snrapply ab_biprod_ind_homotopy. + refine (cat_assoc _ _ _ $@ (_ $@L _) $@ _). 1: snrapply ab_biprod_rec_beta_inl. snrapply ab_tensor_prod_ind_homotopy. intros a b. snrapply path_prod; simpl. * reflexivity. * snrapply tensor_zero_r. + refine (cat_assoc _ _ _ $@ (_ $@L _) $@ _). 1: snrapply ab_biprod_rec_beta_inr. snrapply ab_tensor_prod_ind_homotopy. intros a b. snrapply path_prod; simpl. * snrapply tensor_zero_r. * reflexivity. - snrapply ab_tensor_prod_ind_homotopy. intros a [b c]. lhs_V nrapply tensor_dist_l; simpl. snrapply ap. symmetry; apply grp_prod_decompose. Defined. Definition ab_tensor_prod_dist_r {A B C : AbGroup} : ab_tensor_prod (ab_biprod A B) C $<~> ab_biprod (ab_tensor_prod A C) (ab_tensor_prod B C). Proof. refine (emap11 ab_biprod (braide _ _) (braide _ _) $oE _ $oE braide _ _). snrapply ab_tensor_prod_dist_l. Defined. (** TODO: Show that the category of abelian groups is symmetric closed and therefore we have adjoint pair with the tensor and internal hom. This should allow us to prove lemmas such as tensors distributing over coproducts. *) Coq-HoTT-9.0/theories/Algebra/AbGroups/Z.v000066400000000000000000000025301474641544500202370ustar00rootroot00000000000000Require Import Basics. Require Import Spaces.Pos.Core Spaces.Int. Require Import Algebra.AbGroups.AbelianGroup. Local Set Universe Minimization ToSet. Local Open Scope int_scope. Local Open Scope mc_add_scope. (** * The group of integers *) (** See also Cyclic.v for a definition of the integers as the free group on one generator. *) Definition abgroup_Z@{} : AbGroup@{Set}. Proof. snrapply Build_AbGroup'. - exact Int. - exact 0%int. - exact int_neg. - exact int_add. - exact _. - exact int_add_comm. - exact int_add_assoc. - exact int_add_0_l. - exact int_add_neg_l. Defined. (** For every group [G] and element [g : G], the map sending an integer to that power of [g] is a homomorphism. See [ab_mul] for the homomorphism [G -> G] when [G] is abelian. *) Definition grp_pow_homo {G : Group} (g : G) : GroupHomomorphism abgroup_Z G. Proof. snrapply Build_GroupHomomorphism. 1: exact (grp_pow g). intros m n; apply grp_pow_add. Defined. (** [ab_mul] (and [grp_pow]) give multiplication in [abgroup_Z]. *) Definition abgroup_Z_ab_mul (z z' : Int) : ab_mul (A:=abgroup_Z) z z' = z * z'. Proof. induction z. - reflexivity. - cbn. lhs nrapply (grp_pow_succ (G:=abgroup_Z)). rhs nrapply int_mul_succ_l. f_ap. - cbn. lhs nrapply (grp_pow_pred (G:=abgroup_Z)). rhs nrapply int_mul_pred_l. f_ap. Defined. Coq-HoTT-9.0/theories/Algebra/AbSES.v000066400000000000000000000003721474641544500172030ustar00rootroot00000000000000Require Export AbSES.Core. Require Export AbSES.Ext. Require Export AbSES.Pullback. Require Export AbSES.PullbackFiberSequence. Require Export AbSES.Pushout. Require Export AbSES.BaerSum. Require Export AbSES.DirectSum. Require Export AbSES.SixTerm. Coq-HoTT-9.0/theories/Algebra/AbSES/000077500000000000000000000000001474641544500170125ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/AbSES/BaerSum.v000066400000000000000000000332171474641544500205450ustar00rootroot00000000000000Require Import Basics Types. Require Import WildCat Pointed.Core. Require Import AbGroups.AbelianGroup AbGroups.Biproduct AbGroups.AbHom. Require Import AbSES.Core AbSES.Pullback AbSES.Pushout AbSES.DirectSum. Require Import Homotopy.HSpace.Core. Local Open Scope mc_scope. Local Open Scope mc_add_scope. (** * The Baer sum of two short exact sequences, lemmas and consequences. *) (** The Baer sum of two short exact sequences is obtained from the pointwise direct sum by pushing forward along the codiagonal and then pulling back along the diagonal. (Swapping the order of pushing forward and pulling back produces an isomorphic short exact sequence.) *) Definition abses_baer_sum `{Univalence} {B A : AbGroup@{u}} (E F : AbSES B A) : AbSES B A := abses_pullback ab_diagonal (abses_pushout ab_codiagonal (abses_direct_sum E F)). (** ** [AbSES'] is a bifunctor *) (** Given a morphism [f] of short exact sequences, the pushout of the domain along [f_1] equals the pullback of the codomain along [f_3]. *) Lemma abses_pushout_is_pullback' `{Univalence} {A A' B B' : AbGroup@{u}} {E : AbSES B A} {E' : AbSES B' A'} (f : AbSESMorphism E E') : abses_pushout (component1 f) E $== abses_pullback (component3 f) E'. Proof. (* The morphism [f : E -> E'] factors as [E -> f_1 E -> E'], where the first map is the map defining the pushout [f_1 E] and the second map is denoted [abses_pushout_morphism_rec f] below. This second map is the identity on the first component, so it presents its domain as the pullback of [E'] along [f_3]. *) exact (abses_pullback_component1_id' (abses_pushout_morphism_rec f) (fun _ => idpath)). Defined. (** Given a morphism [f] of short exact sequences, the pushout of the domain along [f_1] equals the pullback of the codomain along [f_3]. *) Definition abses_pushout_is_pullback `{Univalence} {A A' B B' : AbGroup} {E : AbSES B A} {E' : AbSES B' A'} (f : AbSESMorphism E E') : abses_pushout (component1 f) E = abses_pullback (component3 f) E' := equiv_path_abses_iso (abses_pushout_is_pullback' f). Definition abses_pushout_pullback_reorder' `{Univalence} {A A' B B' : AbGroup} (E : AbSES B A) (f : A $-> A') (g : B' $-> B) : abses_pushout f (abses_pullback g E) $== abses_pullback g (abses_pushout f E). Proof. (* There are morphisms [Eg -> E] and [E -> fE] by definition of the pullback and pushout. We define [F : Eg -> fE] to be the composite. Its first and third components are [f o id] and [id o g]. *) pose (F := absesmorphism_compose (abses_pushout_morphism E f) (abses_pullback_morphism E g)). (* We change [F] to a morphism that is the same except that the first and third components are [f] and [g]. Then [abses_pushout_is_pullback] shows that the pushout of [Eg] along [f] is equal to the pullback of [fE] along [g]. *) refine (abses_pushout_is_pullback' (Build_AbSESMorphism f (component2 F) g _ _)); apply F. Defined. (** This is the statement that [AbSES'] is a bifunctor, but we state it separately because Coq is slow to unify [IsBifunctor AbSES'] against goals written in this form. *) Definition abses_pushout_pullback_reorder `{Univalence} {A A' B B' : AbGroup} (E : AbSES B A) (f : A $-> A') (g : B' $-> B) : abses_pushout f (abses_pullback g E) = abses_pullback g (abses_pushout f E). Proof. apply equiv_path_abses_iso. apply abses_pushout_pullback_reorder'. Defined. Global Instance is0bifunctor_abses' `{Univalence} : Is0Bifunctor (AbSES' : AbGroup^op -> AbGroup -> Type). Proof. rapply Build_Is0Bifunctor''. Defined. Global Instance is1bifunctor_abses' `{Univalence} : Is1Bifunctor (AbSES' : AbGroup^op -> AbGroup -> Type). Proof. snrapply Build_Is1Bifunctor''. 1,2: exact _. intros ? ? g ? ? f E; cbn. exact (abses_pushout_pullback_reorder E f g). Defined. (** Given a short exact sequence [A -> E -> B] and maps [f : A -> A'], [g : B' -> B], we can change the order of pushing out along [f] and pulling back along [g]. *) Lemma abses_reorder_pullback_pushout `{Univalence} {A A' B B' : AbGroup} (E : AbSES B A) (f : A $-> A') (g : B' $-> B) : abses_pushout f (abses_pullback g E) = abses_pullback g (abses_pushout f E). Proof. (* There are morphisms [Eg -> E] and [E -> fE] by definition of the pullback and pushout. We define [F : Eg -> fE] to be the composite. Its first and third components are [f o id] and [id o g]. *) pose (F := absesmorphism_compose (abses_pushout_morphism E f) (abses_pullback_morphism E g)). (* We change [F] to a morphism that is the same except that the first and third components are [f] and [g]. Then [abses_pushout_is_pullback] shows that the pushout of [Eg] along [f] is equal to the pullback of [fE] along [g]. *) refine (abses_pushout_is_pullback (Build_AbSESMorphism f (component2 F) g _ _)); apply F. Defined. (** The Baer sum distributes over pullbacks. *) Lemma baer_sum_distributive_pullbacks `{Univalence} {A B B' : AbGroup} {E : AbSES B A} (f g : ab_hom B' B) : abses_pullback (f + g) E = abses_baer_sum (abses_pullback f E) (abses_pullback g E). Proof. unfold abses_baer_sum. refine ((abses_pullback_compose (B1:=ab_biprod B B) _ _ E)^ @ _). refine (ap (abses_pullback _) (abses_pushout_is_pullback (abses_codiagonal E))^ @ _). unfold abses_codiagonal, component1. refine (_^ @ _ @ _). 1,3: apply abses_reorder_pullback_pushout. refine (ap (abses_pushout _) _). refine (ap (fun h => abses_pullback h _) (ab_biprod_corec_diagonal _ _) @ _). refine ((abses_pullback_compose _ _ (abses_direct_sum E E))^ @ _). exact (ap (abses_pullback _) (abses_directsum_distributive_pullbacks f g)). Defined. (** The Baer sum is commutative. *) Lemma baer_sum_commutative `{Univalence} {A B : AbGroup} (E F : AbSES B A) : abses_baer_sum E F = abses_baer_sum F E. Proof. unfold abses_baer_sum. (* The next line uses that [direct_sum_swap $o ab_diagonal] is definitionally equal to [ab_diagonal]: *) refine (_ @ abses_pullback_compose ab_diagonal direct_sum_swap _). refine (ap (abses_pullback ab_diagonal) _). refine (ap (fun f => abses_pushout f _) ab_codiagonal_swap^ @ _). refine ((abses_pushout_compose _ _ _) @ _). refine (ap _ (abses_pushout_is_pullback (abses_swap_morphism E F)) @ _). unfold abses_swap_morphism, component3. apply abses_pushout_pullback_reorder. Defined. (** The right unit law for the Baer sum says that for all [E : AbSES B A], [E + E_0 = E], where [E_0] is the split short exact sequence. *) Lemma baer_sum_unit_r `{Univalence} {A B : AbGroup} (E : AbSES B A) : abses_baer_sum E (point (AbSES B A)) = E. Proof. refine (ap (abses_baer_sum E) _ @ _). - exact (abses_pullback_const E). - refine (ap (fun F => abses_baer_sum F (abses_pullback grp_homo_const E)) (abses_pullback_id E)^ @ _). refine ((baer_sum_distributive_pullbacks grp_homo_id grp_homo_const)^ @ _). refine (ap (fun f => abses_pullback f E) (grp_unit_r (G := ab_hom _ _) _) @ _). apply abses_pullback_id. Defined. (** The left unit law for the Baer sum is analogous. *) Definition baer_sum_unit_l `{Univalence} {A B : AbGroup} (E : AbSES B A) : abses_baer_sum (point (AbSES B A)) E = E := baer_sum_commutative _ _ @ baer_sum_unit_r _. (** For any [E : AbSES B A], the pullback of [E] along [-id_B] acts as an additive inverse for [E] with respect to the Baer sum. *) Lemma baer_sum_inverse_l `{Univalence} {A B : AbGroup} (E : AbSES B A) : abses_baer_sum E (abses_pullback (- grp_homo_id) E) = point (AbSES B A). Proof. refine (ap (fun F => abses_baer_sum F (abses_pullback _ E)) (abses_pullback_id E)^ @ _). refine ((baer_sum_distributive_pullbacks grp_homo_id (-grp_homo_id))^ @ _). refine (ap (fun f => abses_pullback f _) (grp_inv_r (G := ab_hom _ _) _) @ _). symmetry; apply abses_pullback_const. Defined. (** The right inverse law follows by commutativity. *) Definition baer_sum_inverse_r `{Univalence} {A B : AbGroup} (E : AbSES B A) : abses_baer_sum (abses_pullback (-grp_homo_id) E) E = point (AbSES B A) := baer_sum_commutative _ _ @ baer_sum_inverse_l _. (** The Baer sum distributes over pushouts. *) Lemma baer_sum_distributive_pushouts `{Univalence} {A A' B : AbGroup} {E : AbSES B A'} (f g : ab_hom A' A) : abses_pushout (f + g) E = abses_baer_sum (abses_pushout f E) (abses_pushout g E). Proof. unfold abses_baer_sum. refine (abses_pushout_compose (A1 := ab_biprod A A) _ _ E @ _). refine (_ @ abses_pushout_pullback_reorder _ _ _). refine (ap (abses_pushout ab_codiagonal) _). refine (ap (fun f => abses_pushout f E) (ab_biprod_corec_diagonal f g) @ _). refine (abses_pushout_compose _ _ E @ _). refine (ap (abses_pushout _) (abses_pushout_is_pullback (abses_diagonal E)) @ _). refine (abses_pushout_pullback_reorder _ _ _ @ _). exact (ap (abses_pullback _) (abses_directsum_distributive_pushouts f g)). Defined. (** Our next goal is to prove that the Baer sum is associative. Rather than showing this directly, we first prove [baer_sum_twist], which says that [abses_baer_sum (abses_baer_sum E F) G = abses_baer_sum (abses_baer_sum G F) E]. The proof of this mimics the proof of commutativity above. Then we prove associativity by combining this with commutativity. *) (** The trinary Baer sum of three short exact sequences. *) Definition abses_trinary_baer_sum `{Univalence} {A B : AbGroup@{u}} (E F G : AbSES B A) : AbSES B A := abses_pullback ab_triagonal (abses_pushout ab_cotriagonal (abses_direct_sum (abses_direct_sum E F) G)). (** For [E, F, G : AbSES B A], the Baer sum of [E], [F] and [G] (associated left) is equal to the trinary Baer sum of [E], [F] and [G]. *) Lemma baer_sum_is_trinary `{Univalence} {A B : AbGroup@{u}} (E F G : AbSES B A) : abses_baer_sum (abses_baer_sum E F) G = abses_trinary_baer_sum E F G. Proof. unfold abses_baer_sum, abses_trinary_baer_sum, ab_triagonal, ab_cotriagonal. refine (ap (abses_pullback _ o abses_pushout _) _^ @ _). - refine (_ @ ap (abses_direct_sum _) (abses_pullback_id G)). refine (_ @ abses_directsum_distributive_pullbacks _ _). refine (ap (abses_pullback _) _). refine (_ @ ap (abses_direct_sum _) (abses_pushout_id G)). apply abses_directsum_distributive_pushouts. - refine (ap (abses_pullback _) (abses_pushout_pullback_reorder _ _ _) @ _). refine (abses_pullback_compose _ _ _ @ _). refine (ap (abses_pullback _) _^). apply abses_pushout_compose. Defined. (** For [E, F, G : AbSES B A], we can "twist" the order of the trinary Baer sum as follows. *) Lemma twist_trinary_baer_sum `{Univalence} {A B : AbGroup@{u}} (E F G : AbSES B A) : abses_trinary_baer_sum E F G = abses_trinary_baer_sum G F E. Proof. unfold abses_trinary_baer_sum. (* The next line uses the fact that [ab_triagonal] is definitionally equal to [ab_biprod_twist $o ab_triagonal]: *) refine (_ @ abses_pullback_compose ab_triagonal ab_biprod_twist _). refine (ap (abses_pullback _) _). refine (ap (fun f => abses_pushout f _) ab_cotriagonal_twist^ @ _). refine (abses_pushout_compose _ _ _ @ _). refine (ap _ (abses_pushout_is_pullback (abses_twist_directsum E F G)) @ _). unfold abses_twist_directsum, component3. exact (abses_pushout_pullback_reorder _ _ _). Defined. (** It now follows that we can twist the order of the summands in the Baer sum. *) Lemma baer_sum_twist `{Univalence} {A B : AbGroup@{u}} (E F G : AbSES B A) : abses_baer_sum (abses_baer_sum E F) G = abses_baer_sum (abses_baer_sum G F) E. Proof. refine ((baer_sum_is_trinary E F G) @ _ @ (baer_sum_is_trinary G F E)^). apply twist_trinary_baer_sum. Defined. (** From these results, it finally follows that the Baer sum is associative. *) Lemma baer_sum_associative `{Univalence} {A B : AbGroup@{u}} (E F G : AbSES B A) : abses_baer_sum (abses_baer_sum E F) G = abses_baer_sum E (abses_baer_sum F G). Proof. refine ((baer_sum_twist _ _ _)^ @ _). refine (baer_sum_commutative _ _ @ _). apply ap. apply baer_sum_commutative. Defined. (** The Baer sum makes [AbSES B A] into an H-space. (In fact, a coherent H-space, but we leave that for now.) *) Global Instance ishspace_abses `{Univalence} {B A : AbGroup} : IsHSpace (AbSES B A). Proof. snrapply Build_IsHSpace. - exact abses_baer_sum. - intro; apply baer_sum_unit_l. - intro; apply baer_sum_unit_r. Defined. Global Instance is0bifunctor_abses `{Univalence} : Is0Bifunctor (AbSES : AbGroup^op -> AbGroup -> pType). Proof. rapply Build_Is0Bifunctor''. Defined. Global Instance is1bifunctor_abses `{Univalence} : Is1Bifunctor (AbSES : AbGroup^op -> AbGroup -> pType). Proof. snrapply Build_Is1Bifunctor''. 1,2: exact _. intros ? ? f ? ? g. rapply hspace_phomotopy_from_homotopy. 1: apply ishspace_abses. intro E; cbn. apply abses_pushout_pullback_reorder. Defined. (** ** Pushouts and pullbacks respect the Baer sum *) Definition baer_sum_pushout `{Univalence} {A A' B : AbGroup} (f : A $-> A') (E F : AbSES B A) : abses_pushout f (abses_baer_sum E F) = abses_baer_sum (abses_pushout f E) (abses_pushout f F). Proof. unfold abses_baer_sum. refine (abses_pushout_pullback_reorder _ _ _ @ ap _ _). refine ((abses_pushout_compose _ _ _)^ @ _). refine (abses_pushout_homotopic _ _ _ _ @ _). 1: apply ab_codiagonal_natural. refine (abses_pushout_compose _ _ _ @ ap _ _). apply abses_directsum_distributive_pushouts. Defined. Definition baer_sum_pullback `{Univalence} {A B B' : AbGroup} (f : B' $-> B) (E F : AbSES B A) : abses_pullback f (abses_baer_sum E F) = abses_baer_sum (abses_pullback f E) (abses_pullback f F). Proof. unfold abses_baer_sum. refine (abses_pullback_compose _ _ _ @ _). refine ((abses_pushout_pullback_reorder _ _ _)^ @ ap _ _ @ abses_pushout_pullback_reorder _ _ _). refine (abses_pullback_homotopic _ (functor_ab_biprod f f $o ab_diagonal) _ _ @ _). 1: reflexivity. refine ((abses_pullback_compose _ _ _)^ @ ap _ _). apply abses_directsum_distributive_pullbacks. Defined. Coq-HoTT-9.0/theories/Algebra/AbSES/Core.v000066400000000000000000000706261474641544500201040ustar00rootroot00000000000000Require Import Basics Types Truncations.Core. Require Import HSet WildCat. Require Import Groups.QuotientGroup Groups.ShortExactSequence. Require Import AbelianGroup AbGroups.Biproduct AbHom. Require Import Homotopy.ExactSequence Pointed. Require Import Modalities.ReflectiveSubuniverse. Local Open Scope pointed_scope. Local Open Scope path_scope. Local Open Scope type_scope. Local Open Scope mc_add_scope. (** * Short exact sequences of abelian groups *) (** A short exact sequence of abelian groups consists of a monomorphism [i : A -> E] and an epimorphism [p : E -> B] such that the image of [i] equals the kernel of [p]. Later we will consider short exact sequences up to isomorphism by 0-truncating the type [AbSES] defined below. An isomorphism class of short exact sequences is called an extension. *) Declare Scope abses_scope. Local Open Scope abses_scope. (** The type of short exact sequences [A -> E -> B] of abelian groups. We decorate it with (') to reserve the undecorated name for the structured version. *) Record AbSES' {B A : AbGroup@{u}} := Build_AbSES { middle : AbGroup@{u}; inclusion : A $-> middle; projection : middle $-> B; isembedding_inclusion : IsEmbedding inclusion; issurjection_projection : IsSurjection projection; isexact_inclusion_projection : IsExact (Tr (-1)) inclusion projection; }. (** Given a short exact sequence [A -> E -> B : AbSES B A], we coerce it to [E]. *) Coercion middle : AbSES' >-> AbGroup. Global Existing Instances isembedding_inclusion issurjection_projection isexact_inclusion_projection. Arguments AbSES' B A : clear implicits. Arguments Build_AbSES {B A}. (** TODO Figure out why printing this term eats memory and seems to never finish. *) Local Definition issig_abses_do_not_print {B A : AbGroup} : _ <~> AbSES' B A := ltac:(issig). (** [make_equiv] is slow if used in the context of the next result, so we give the abstract form of the goal here. *) Local Definition issig_abses_helper {AG : Type} {P : AG -> Type} {Q : AG -> Type} {R : forall E, P E -> Type} {S : forall E, Q E -> Type} {T : forall E, P E -> Q E -> Type} : {X : {E : AG & P E * Q E} & R _ (fst X.2) * S _ (snd X.2) * T _ (fst X.2) (snd X.2)} <~> {E : AG & {H0 : P E & {H1 : Q E & {_ : R _ H0 & {_ : S _ H1 & T _ H0 H1}}}}} := ltac:(make_equiv). (** A more useful organization of [AbSES'] as a sigma-type. *) Definition issig_abses {B A : AbGroup} : {X : {E : AbGroup & (A $-> E) * (E $-> B)} & (IsEmbedding (fst X.2) * IsSurjection (snd X.2) * IsExact (Tr (-1)) (fst X.2) (snd X.2))} <~> AbSES' B A := issig_abses_do_not_print oE issig_abses_helper. Definition iscomplex_abses {A B : AbGroup} (E : AbSES' B A) : IsComplex (inclusion E) (projection E) := cx_isexact. (** [AbSES' B A] is pointed by the split sequence [A -> A+B -> B]. *) Global Instance ispointed_abses {B A : AbGroup@{u}} : IsPointed (AbSES' B A). Proof. rapply (Build_AbSES (ab_biprod A B) ab_biprod_inl ab_biprod_pr2). snrapply Build_IsExact. - srapply phomotopy_homotopy_hset; reflexivity. - intros [[a b] p]; cbn; cbn in p. rapply contr_inhabited_hprop. apply tr. exists a. rapply path_sigma_hprop; cbn. exact (path_prod' idpath p^). Defined. (** The pointed type of short exact sequences. *) Definition AbSES (B A : AbGroup@{u}) : pType := [AbSES' B A, _]. (** ** Paths in [AbSES B A] *) Definition abses_path_data_iso {B A : AbGroup@{u}} (E F : AbSES B A) := {phi : GroupIsomorphism E F & (phi $o inclusion _ == inclusion _) * (projection _ == projection _ $o phi)}. (** Having the path data in a slightly different form is useful for [equiv_path_abses_iso]. *) Local Lemma shuffle_abses_path_data_iso `{Funext} {B A : AbGroup@{u}} (E F : AbSES B A) : (abses_path_data_iso E F) <~> {phi : GroupIsomorphism E F & (phi $o inclusion _ == inclusion _) * (projection _ $o grp_iso_inverse phi == projection _)}. Proof. srapply equiv_functor_sigma_id; intro phi. srapply equiv_functor_prod'. 1: exact equiv_idmap. srapply (equiv_functor_forall' phi^-1); intro e; cbn. apply equiv_concat_r. exact (ap _ (eisretr _ _)). Defined. (** Paths in [AbSES] correspond to isomorphisms between the [middle]s respecting [inclusion] and [projection]. Below we prove the stronger statement [equiv_path_abses], which uses this result. *) Proposition equiv_path_abses_iso `{Univalence} {B A : AbGroup@{u}} {E F : AbSES' B A} : abses_path_data_iso E F <~> E = F. Proof. refine (_ oE shuffle_abses_path_data_iso E F). refine (equiv_ap_inv issig_abses _ _ oE _). refine (equiv_path_sigma_hprop _ _ oE _). refine (equiv_path_sigma _ _ _ oE _). srapply equiv_functor_sigma'. 1: exact equiv_path_abgroup. intro q; lazy beta. snrefine (equiv_concat_l _ _ oE _). 1: exact (q $o inclusion _, projection _ $o grp_iso_inverse q). 2: { refine (equiv_path_prod _ _ oE _). exact (equiv_functor_prod' equiv_path_grouphomomorphism equiv_path_grouphomomorphism). } refine (transport_prod _ _ @ _). apply path_prod'. - apply transport_iso_abgrouphomomorphism_from_const. - apply transport_iso_abgrouphomomorphism_to_const. Defined. (** It follows that [AbSES B A] is 1-truncated. *) Global Instance istrunc_abses `{Univalence} {B A : AbGroup@{u}} : IsTrunc 1 (AbSES B A). Proof. apply istrunc_S. intros E F. refine (istrunc_equiv_istrunc _ equiv_path_abses_iso (n:=0)). rapply istrunc_sigma. apply ishset_groupisomorphism. Defined. Definition path_abses_iso `{Univalence} {B A : AbGroup@{u}} {E F : AbSES B A} (phi : GroupIsomorphism E F) (p : phi $o inclusion _ == inclusion _) (q : projection _ == projection _ $o phi) : E = F := equiv_path_abses_iso (phi; (p,q)). (** Given [p] and [q], the map [phi] just above is automatically an isomorphism. Showing this requires the "short five lemma." *) (** A special case of the "short 5-lemma" where the two outer maps are (definitionally) identities. *) Lemma short_five_lemma {B A : AbGroup@{u}} {E F : AbSES B A} (phi : GroupHomomorphism E F) (p0 : phi $o inclusion E == inclusion F) (p1 : projection E == projection F $o phi) : IsEquiv phi. Proof. apply isequiv_surj_emb. - intro f. rapply contr_inhabited_hprop. (** Since [projection E] is epi, we can pull [projection F f] back to [e0 : E].*) assert (e0 : Tr (-1) (hfiber (projection E) (projection F f))). 1: apply center, issurjection_projection. strip_truncations. (** The difference [f - (phi e0.1)] is sent to [0] by [projection F], hence lies in [A]. *) assert (a : Tr (-1) (hfiber (inclusion F) (f - phi e0.1))). 1: { refine (isexact_preimage (Tr (-1)) (inclusion F) (projection F) _ _). refine (grp_homo_op _ _ _ @ _). refine (ap _ (grp_homo_inv _ _) @ _). apply (grp_moveL_1M)^-1. exact (e0.2^ @ p1 e0.1). } strip_truncations. refine (tr (inclusion E a.1 + e0.1; _)). refine (grp_homo_op _ _ _ @ _). refine (ap (fun x => x + phi e0.1) (p0 a.1 @ a.2) @ _). refine ((grp_assoc _ _ _)^ @ _). refine (ap _ (left_inverse (phi e0.1)) @ _). apply grp_unit_r. - apply isembedding_istrivial_kernel. intros e p. assert (a : Tr (-1) (hfiber (inclusion E) e)). 1: { refine (isexact_preimage _ (inclusion E) (projection E) _ _). exact (p1 e @ ap (projection F) p @ grp_homo_unit _). } strip_truncations. refine (a.2^ @ ap (inclusion E ) _ @ grp_homo_unit (inclusion E)). rapply (isinj_embedding (inclusion F) _ _). refine ((p0 a.1)^ @ (ap phi a.2) @ p @ (grp_homo_unit _)^). Defined. (** Below we prove that homomorphisms respecting [projection] and [inclusion] correspond to paths in [AbSES B A]. We refer to such homomorphisms simply as path data in [AbSES B A]. *) Definition abses_path_data {B A : AbGroup@{u}} (E F : AbSES B A) := {phi : GroupHomomorphism E F & (phi $o inclusion _ == inclusion _) * (projection _ == projection _ $o phi)}. Definition abses_path_data_to_iso {B A : AbGroup@{u}} (E F: AbSES B A) : abses_path_data E F -> abses_path_data_iso E F. Proof. - intros [phi [p q]]. exact ({| grp_iso_homo := phi; isequiv_group_iso := short_five_lemma phi p q |}; (p, q)). Defined. Proposition equiv_path_abses_data `{Funext} {B A : AbGroup@{u}} (E F: AbSES B A) : abses_path_data E F <~> abses_path_data_iso E F. Proof. srapply equiv_adjointify. - apply abses_path_data_to_iso. - srapply (functor_sigma (grp_iso_homo _ _)). exact (fun _ => idmap). - intros [phi [p q]]. apply path_sigma_hprop. by apply equiv_path_groupisomorphism. - reflexivity. Defined. Definition equiv_path_abses `{Univalence} {B A : AbGroup@{u}} {E F : AbSES B A} : abses_path_data E F <~> E = F := equiv_path_abses_iso oE equiv_path_abses_data E F. Definition path_abses `{Univalence} {B A : AbGroup@{u}} {E F : AbSES B A} (phi : middle E $-> F) (p : phi $o inclusion _ == inclusion _) (q : projection _ == projection _ $o phi) : E = F := equiv_path_abses (phi; (p,q)). (** *** The wildcat of short exact sequences *) Global Instance isgraph_abses_path_data {A B : AbGroup@{u}} (E F : AbSES B A) : IsGraph (abses_path_data_iso E F) := isgraph_induced (grp_iso_homo _ _ o pr1). Global Instance is01cat_abses_path_data {A B : AbGroup@{u}} (E F : AbSES B A) : Is01Cat (abses_path_data_iso E F) := is01cat_induced (grp_iso_homo _ _ o pr1). Global Instance is0gpd_abses_path_data {A B : AbGroup@{u}} (E F : AbSES B A) : Is0Gpd (abses_path_data_iso E F) := is0gpd_induced (grp_iso_homo _ _ o pr1). Global Instance isgraph_abses {A B : AbGroup@{u}} : IsGraph (AbSES B A) := Build_IsGraph _ abses_path_data_iso. (** The path data corresponding to [idpath]. *) Definition abses_path_data_1 {B A : AbGroup@{u}} (E : AbSES B A) : E $-> E := (grp_iso_id; (fun _ => idpath, fun _ => idpath)). (** We can compose path data in [AbSES B A]. *) Definition abses_path_data_compose {B A : AbGroup@{u}} {E F G : AbSES B A} (p : E $-> F) (q : F $-> G) : E $-> G := (q.1 $oE p.1; ((fun x => ap q.1 (fst p.2 x) @ fst q.2 x), (fun x => snd p.2 x @ snd q.2 (p.1 x)))). Global Instance is01cat_abses {A B : AbGroup@{u}} : Is01Cat (AbSES B A) := Build_Is01Cat _ _ abses_path_data_1 (fun _ _ _ q p => abses_path_data_compose p q). Definition abses_path_data_inverse {B A : AbGroup@{u}} {E F : AbSES B A} : (E $-> F) -> (F $-> E). Proof. intros [phi [p q]]. srefine (_; (_,_)). - exact (grp_iso_inverse phi). - intro a. exact (ap _ (p a)^ @ eissect _ (inclusion E a)). - intro a; simpl. exact (ap (projection F) (eisretr _ _)^ @ (q _)^). Defined. Global Instance is0gpd_abses {A B : AbGroup@{u}} : Is0Gpd (AbSES B A) := {| gpd_rev := fun _ _ => abses_path_data_inverse |}. Global Instance is2graph_abses {A B : AbGroup@{u}} : Is2Graph (AbSES B A) := fun E F => isgraph_abses_path_data E F. (** [AbSES B A] forms a 1Cat *) Global Instance is1cat_abses {A B : AbGroup@{u}} : Is1Cat (AbSES B A). Proof. snrapply Build_Is1Cat'. 1: intros ? ?; apply is01cat_abses_path_data. 1: intros ? ?; apply is0gpd_abses_path_data. 3-5: cbn; reflexivity. 1,2: intros E F G f; srapply Build_Is0Functor; intros p q h e; cbn. - exact (ap f.1 (h e)). - exact (h (f.1 e)). Defined. Global Instance is1gpd_abses {A B : AbGroup@{u}} : Is1Gpd (AbSES B A). Proof. rapply Build_Is1Gpd; intros E F p e; cbn. - apply eissect. - apply eisretr. Defined. Global Instance hasmorext_abses `{Funext} {A B : AbGroup@{u}} : HasMorExt (AbSES B A). Proof. srapply Build_HasMorExt; intros E F f g. srapply isequiv_homotopic'; cbn. 1: exact (((equiv_path_groupisomorphism _ _)^-1%equiv) oE (equiv_path_sigma_hprop _ _)^-1%equiv). intro p; by induction p. Defined. (** *** Path data lemmas *) (** We need to be able to work with path data as if they're paths. Our preference is to state things in terms of [abses_path_data_iso], since this lets us keep track of isomorphisms whose inverses compute. The "abstract" inverses produced by [short_five_lemma] do not compute well. *) Definition equiv_path_abses_1 `{Univalence} {B A : AbGroup@{u}} {E : AbSES B A} : equiv_path_abses_iso (abses_path_data_1 E) = idpath. Proof. apply (equiv_ap_inv' equiv_path_abses_iso). refine (eissect _ _ @ _). srapply path_sigma_hprop; simpl. srapply equiv_path_groupisomorphism. reflexivity. Defined. Definition equiv_path_absesV_1 `{Univalence} {B A : AbGroup@{u}} {E : AbSES B A} : (@equiv_path_abses_iso _ B A E E)^-1 idpath = Id E. Proof. apply moveR_equiv_M; symmetry. apply equiv_path_abses_1. Defined. Definition abses_path_data_V `{Univalence} {B A : AbGroup@{u}} {E F : AbSES B A} (p : abses_path_data_iso E F) : (equiv_path_abses_iso p)^ = equiv_path_abses_iso (abses_path_data_inverse p). Proof. revert p. equiv_intro (equiv_path_abses_iso (E:=E) (F:=F))^-1 p; induction p. refine (ap _ (eisretr _ _) @ _); symmetry. nrefine (ap (equiv_path_abses_iso o abses_path_data_inverse) equiv_path_absesV_1 @ _). refine (ap equiv_path_abses_iso gpd_strong_rev_1 @ _). exact equiv_path_abses_1. Defined. (** Composition of path data corresponds to composition of paths. *) Definition abses_path_compose_beta `{Univalence} {B A : AbGroup@{u}} {E F G : AbSES B A} (p : E = F) (q : F = G) : p @ q = equiv_path_abses_iso (abses_path_data_compose (equiv_path_abses_iso^-1 p) (equiv_path_abses_iso^-1 q)). Proof. induction p, q. refine (equiv_path_abses_1^ @ _). apply (ap equiv_path_abses_iso). apply path_sigma_hprop. by apply equiv_path_groupisomorphism. Defined. (** A second beta-principle where you start with path data instead of actual paths. *) Definition abses_path_data_compose_beta `{Univalence} {B A : AbGroup@{u}} {E F G : AbSES B A} (p : abses_path_data_iso E F) (q : abses_path_data_iso F G) : equiv_path_abses_iso p @ equiv_path_abses_iso q = equiv_path_abses_iso (abses_path_data_compose p q). Proof. generalize p, q. equiv_intro ((equiv_path_abses_iso (E:=E) (F:=F))^-1) x. equiv_intro ((equiv_path_abses_iso (E:=F) (F:=G))^-1) y. refine ((eisretr _ _ @@ eisretr _ _) @ _). rapply abses_path_compose_beta. Defined. (** *** Homotopies of path data *) Definition equiv_path_data_homotopy `{Univalence} {X : Type} {B A : AbGroup@{u}} (f g : X -> AbSES B A) : (f $=> g) <~> f == g. Proof. srapply equiv_functor_forall_id; intro x; cbn. srapply equiv_path_abses_iso. Defined. Definition pmap_abses_const {B' A' B A : AbGroup@{u}} : AbSES B A -->* AbSES B' A' := Build_BasepointPreservingFunctor (const pt) (Id pt). Definition to_pointed `{Univalence} {B' A' B A : AbGroup@{u}} : (AbSES B A -->* AbSES B' A') -> (AbSES B A ->* AbSES B' A') := fun f => Build_pMap _ _ f (equiv_path_abses_iso (bp_pointed f)). Lemma pmap_abses_const_to_pointed `{Univalence} {B' A' B A : AbGroup@{u}} : pconst ==* to_pointed (@pmap_abses_const B' A' B A). Proof. srapply Build_pHomotopy. 1: reflexivity. apply moveL_pV. refine (concat_1p _ @ _). apply equiv_path_abses_1. Defined. Lemma abses_ap_fmap `{Univalence} {B0 B1 A0 A1 : AbGroup@{u}} (f : AbSES B0 A0 -> AbSES B1 A1) `{!Is0Functor f, !Is1Functor f} {E F : AbSES B0 A0} (p : E $== F) : ap f (equiv_path_abses_iso p) = equiv_path_abses_iso (fmap f p). Proof. revert p. apply (equiv_ind equiv_path_abses_iso^-1%equiv); intro p. induction p. refine (ap (ap f) (eisretr _ _) @ _). nrefine (_ @ ap equiv_path_abses_iso _). 2: { rapply path_hom. srefine (_ $@ fmap2 _ _). 2: exact (Id E). 2: intro x; reflexivity. exact (fmap_id f _)^$. } exact equiv_path_abses_1^. Defined. Definition to_pointed_compose `{Univalence} {B0 B1 B2 A0 A1 A2 : AbGroup@{u}} (f : AbSES B0 A0 -->* AbSES B1 A1) (g : AbSES B1 A1 -->* AbSES B2 A2) `{!Is1Functor f, !Is1Functor g} : to_pointed g o* to_pointed f ==* to_pointed (g $o* f). Proof. srapply Build_pHomotopy. 1: reflexivity. lazy beta. nrapply moveL_pV. nrefine (concat_1p _ @ _). unfold pmap_compose, Build_pMap, pointed_fun, point_eq, dpoint_eq. refine (_ @ ap (fun x => x @ _) _^). 2: apply (abses_ap_fmap g). nrefine (_ @ (abses_path_data_compose_beta _ _)^). nrapply (ap equiv_path_abses_iso). rapply path_hom. reflexivity. Defined. Definition equiv_ptransformation_phomotopy `{Univalence} {B' A' B A : AbGroup@{u}} {f g : AbSES B A -->* AbSES B' A'} : f $=>* g <~> to_pointed f ==* to_pointed g. Proof. refine (issig_pforall _ _ oE _). apply (equiv_functor_sigma' (equiv_path_data_homotopy f g)); intro h. refine (equiv_concat_r _ _ oE _). 1: exact ((abses_path_data_compose_beta _ _)^ @ ap (fun x => _ @ x) (abses_path_data_V _)^). refine (equiv_ap' equiv_path_abses_iso _ _ oE _). refine (equiv_path_sigma_hprop _ _ oE _). apply equiv_path_groupisomorphism. Defined. (** *** Characterisation of loops of short exact sequences *) (** Endomorphisms of the trivial short exact sequence in [AbSES B A] correspond to homomorphisms [B -> A]. *) Lemma abses_endomorphism_trivial `{Funext} {B A : AbGroup@{u}} : {phi : GroupHomomorphism (point (AbSES B A)) (point (AbSES B A)) & (phi o inclusion _ == inclusion _) * (projection _ == projection _ o phi)} <~> (B $-> A). Proof. srapply equiv_adjointify. - intros [phi _]. exact (ab_biprod_pr1 $o phi $o ab_biprod_inr). - intro f. snrefine (_;_). + refine (ab_biprod_rec ab_biprod_inl _). refine (ab_biprod_corec f grp_homo_id). + split; intro x; cbn. * apply path_prod; cbn. -- exact (ap _ (grp_homo_unit f) @ right_identity _). -- exact (right_identity _). * exact (left_identity _)^. - intro f. rapply equiv_path_grouphomomorphism; intro b; cbn. exact (left_identity _). - intros [phi [p q]]. apply path_sigma_hprop; cbn. rapply equiv_path_grouphomomorphism; intros [a b]; cbn. apply path_prod; cbn. + rewrite (grp_prod_decompose a b). refine (_ @ (grp_homo_op (ab_biprod_pr1 $o phi) _ _)^). apply grp_cancelR; symmetry. exact (ap fst (p a)). + rewrite (grp_prod_decompose a b). refine (_ @ (grp_homo_op (ab_biprod_pr2 $o phi) _ _)^); cbn; symmetry. exact (ap011 _ (ap snd (p a)) (q (group_unit, b))^). Defined. (** Consequently, the loop space of [AbSES B A] is [GroupHomomorphism B A]. (In fact, [B $-> A] are the loops of any short exact sequence, but the trivial case is easiest to show.) *) Definition loops_abses `{Univalence} {A B : AbGroup} : (B $-> A) <~> loops (AbSES B A) := equiv_path_abses oE abses_endomorphism_trivial^-1. (** We can transfer a loop of the trivial short exact sequence to any other. *) Definition hom_loops_data_abses {A B : AbGroup} (E : AbSES B A) : (B $-> A) -> abses_path_data E E. Proof. intro phi. srefine (_; (_, _)). - exact (grp_homo_id + (inclusion E $o phi $o projection E)). - intro a; cbn. refine (ap (fun x => _ + inclusion E (phi x)) _ @ _). 1: apply iscomplex_abses. refine (ap (fun x => _ + x) (grp_homo_unit (inclusion E $o phi)) @ _). apply grp_unit_r. - intro e; symmetry. refine (grp_homo_op (projection E) _ _ @ _); cbn. refine (ap (fun x => _ + x) _ @ _). 1: apply iscomplex_abses. apply grp_unit_r. Defined. (** ** Morphisms of short exact sequences *) (** A morphism between short exact sequences is a natural transformation between the underlying diagrams. *) Record AbSESMorphism {A X B Y : AbGroup@{u}} {E : AbSES B A} {F : AbSES Y X} := { component1 : A $-> X; component2 : middle E $-> middle F; component3 : B $-> Y; left_square : (inclusion _) $o component1 == component2 $o (inclusion _); right_square : (projection _) $o component2 == component3 $o (projection _); }. Arguments AbSESMorphism {A X B Y} E F. Arguments Build_AbSESMorphism {_ _ _ _ _ _} _ _ _ _ _. Definition issig_AbSESMorphism {A X B Y : AbGroup@{u}} {E : AbSES B A} {F : AbSES Y X} : { f : (A $-> X) * (middle E $-> middle F) * (B $-> Y) & ((inclusion _) $o (fst (fst f)) == (snd (fst f)) $o (inclusion _)) * ((projection F) $o (snd (fst f)) == (snd f) $o (projection _)) } <~> AbSESMorphism E F := ltac:(make_equiv). (** The identity morphism from [E] to [E]. *) Lemma abses_morphism_id {A B : AbGroup@{u}} (E : AbSES B A) : AbSESMorphism E E. Proof. snrapply (Build_AbSESMorphism grp_homo_id grp_homo_id grp_homo_id). 1,2: reflexivity. Defined. Definition absesmorphism_compose {A0 A1 A2 B0 B1 B2 : AbGroup@{u}} {E : AbSES B0 A0} {F : AbSES B1 A1} {G : AbSES B2 A2} (g : AbSESMorphism F G) (f : AbSESMorphism E F) : AbSESMorphism E G. Proof. rapply (Build_AbSESMorphism (component1 g $o component1 f) (component2 g $o component2 f) (component3 g $o component3 f)). - intro x; cbn. exact (left_square g _ @ ap _ (left_square f _)). - intro x; cbn. exact (right_square g _ @ ap _ (right_square f _)). Defined. (** ** Characterization of split short exact sequences *) (* We characterize trivial short exact sequences in [AbSES] as those for which [projection] splits. *) (** If [projection E] splits, we get an induced map [fun e => e - s (projection E e)] from [E] to [ab_kernel (projection E)]. *) Definition projection_split_to_kernel {B A : AbGroup} (E : AbSES B A) {s : B $-> E} (h : projection _ $o s == idmap) : (middle E) $-> (@ab_kernel E B (projection _)). Proof. snrapply (grp_kernel_corec (G:=E) (A:=E)). - refine (grp_homo_id - (s $o projection _)). - intro x; simpl. refine (grp_homo_op (projection _) x _ @ _). refine (ap (fun y => (projection _) x + y) _ @ right_inverse ((projection _) x)). refine (grp_homo_inv _ _ @ ap (-) _). apply h. Defined. (** The composite [A -> E -> ab_kernel (projection E)] is [grp_cxfib]. *) Lemma projection_split_to_kernel_beta {B A : AbGroup} (E : AbSES B A) {s : B $-> E} (h : (projection _) $o s == idmap) : (projection_split_to_kernel E h) $o (inclusion _) == grp_cxfib cx_isexact. Proof. intro a. apply path_sigma_hprop; cbn. apply grp_cancelL1. refine (ap (fun x => - s x) _ @ _). 1: rapply cx_isexact. exact (ap _ (grp_homo_unit _) @ grp_inv_unit). Defined. (** The induced map [E -> ab_kernel (projection E) + B] is an isomorphism. We suffix it with 1 since it is the first composite in the desired isomorphism [E -> A + B]. *) Definition projection_split_iso1 {B A : AbGroup} (E : AbSES B A) {s : GroupHomomorphism B E} (h : (projection _) $o s == idmap) : GroupIsomorphism E (ab_biprod (@ab_kernel E B (projection _)) B). Proof. srapply Build_GroupIsomorphism. - refine (ab_biprod_corec _ (projection _)). exact (projection_split_to_kernel E h). - srapply isequiv_adjointify. + refine (ab_biprod_rec _ s). rapply subgroup_incl. + intros [a b]; simpl. apply path_prod'. * srapply path_sigma_hprop; cbn. refine ((associativity _ _ _)^ @ _). apply grp_cancelL1. refine (ap _ _ @ right_inverse _). apply (ap negate). apply (ap s). refine (grp_homo_op (projection _) a.1 (s b) @ _). exact (ap (fun y => y + _) a.2 @ left_identity _ @ h b). * refine (grp_homo_op (projection _) a.1 (s b) @ _). exact (ap (fun y => y + _) a.2 @ left_identity _ @ h b). + intro e; simpl. by apply grp_moveR_gM. Defined. (** The full isomorphism [E -> A + B]. *) Definition projection_split_iso {B A : AbGroup@{u}} (E : AbSES B A) {s : GroupHomomorphism B E} (h : (projection _) $o s == idmap) : GroupIsomorphism E (ab_biprod A B). Proof. etransitivity (ab_biprod (ab_kernel _) B). - exact (projection_split_iso1 E h). - srapply (equiv_functor_ab_biprod (grp_iso_inverse _) grp_iso_id). rapply grp_iso_cxfib. Defined. Proposition projection_split_beta {B A : AbGroup} (E : AbSES B A) {s : B $-> E} (h : (projection _) $o s == idmap) : projection_split_iso E h o (inclusion _) == ab_biprod_inl. Proof. intro a. (* The next two lines might help the reader, but both are definitional equalities: lhs nrapply (ap _ (grp_prod_corec_natural _ _ _ _)). lhs nrapply ab_biprod_functor_beta. *) nrapply path_prod'. 2: rapply cx_isexact. (* The LHS of the remaining goal is definitionally equal to (grp_iso_inverse (grp_iso_cxfib (isexact_inclusion_projection E)) $o (projection_split_to_kernel E h $o inclusion E)) a allowing us to do: *) lhs nrapply (ap _ (projection_split_to_kernel_beta E h a)). apply eissect. Defined. (** A short exact sequence [E] in [AbSES B A] is trivial if and only if [projection E] splits. *) Proposition iff_abses_trivial_split `{Univalence} {B A : AbGroup@{u}} (E : AbSES B A) : {s : B $-> E & (projection _) $o s == idmap} <-> (E = point (AbSES B A)). Proof. refine (iff_compose _ (iff_equiv equiv_path_abses_iso)); split. - intros [s h]. exists (projection_split_iso E h). split. + nrapply projection_split_beta. + reflexivity. - intros [phi [g h]]. exists (grp_homo_compose (grp_iso_inverse phi) ab_biprod_inr). intro x; cbn. exact (h _ @ ap snd (eisretr _ _)). Defined. (** ** Constructions of short exact sequences *) (** Any inclusion [i : A $-> E] determines a short exact sequence by quotienting. *) Definition abses_from_inclusion `{Univalence} {A E : AbGroup@{u}} (i : A $-> E) `{IsEmbedding i} : AbSES (QuotientAbGroup E (grp_image_embedding i)) A. Proof. srapply (Build_AbSES E i). 1: exact grp_quotient_map. 1: exact _. srapply Build_IsExact. - srapply phomotopy_homotopy_hset. intro x. apply qglue; cbn. exists (-x). exact (grp_homo_inv _ _ @ (grp_unit_r _)^). - snrapply (conn_map_homotopic (Tr (-1)) (B:=grp_kernel (@grp_quotient_map E _))). + exact (grp_kernel_quotient_iso _ o ab_image_in_embedding i). + intro a. by rapply (isinj_embedding (subgroup_incl _)). + rapply conn_map_isequiv. Defined. (** Conversely, given a short exact sequence [A -> E -> B], [A] is the kernel of [E -> B]. (We don't need exactness at [B], so we drop this assumption.) *) Lemma abses_kernel_iso `{Funext} {A E B : AbGroup} (i : A $-> E) (p : E $-> B) `{IsEmbedding i, IsExact (Tr (-1)) _ _ _ i p} : GroupIsomorphism A (ab_kernel p). Proof. snrapply Build_GroupIsomorphism. - apply (grp_kernel_corec i). rapply cx_isexact. - apply isequiv_surj_emb. 2: rapply (cancelL_mapinO _ (grp_kernel_corec _ _) _). intros [y q]. assert (a : Tr (-1) (hfiber i y)). 1: by rapply isexact_preimage. strip_truncations; destruct a as [a r]. rapply contr_inhabited_hprop. refine (tr (a; _)); cbn. apply path_sigma_hprop; cbn. exact r. Defined. (** A computation rule for the inverse of [abses_kernel_iso i p]. *) Lemma abses_kernel_iso_inv_beta `{Funext} {A E B : AbGroup} (i : A $-> E) (p : E $-> B) `{IsEmbedding i, IsExact (Tr (-1)) _ _ _ i p} : i o (abses_kernel_iso i p)^-1 == subgroup_incl _. Proof. rapply (equiv_ind (abses_kernel_iso i p)); intro a. exact (ap i (eissect (abses_kernel_iso i p) _)). Defined. (* Any surjection [p : E $-> B] induces a short exact sequence by taking the kernel. *) Lemma abses_from_surjection {E B : AbGroup@{u}} (p : E $-> B) `{IsSurjection p} : AbSES B (ab_kernel p). Proof. srapply (Build_AbSES E _ p). 1: exact (subgroup_incl _). 1: exact _. snrapply Build_IsExact. - apply phomotopy_homotopy_hset. intros [e q]; cbn. exact q. - rapply conn_map_isequiv. Defined. (** Conversely, given a short exact sequence [A -> E -> B], [B] is the cokernel of [A -> E]. In fact, we don't need exactness at [A], so we drop this from the statement. *) Lemma abses_cokernel_iso `{Funext} {A E B : AbGroup@{u}} (f : A $-> E) (g : GroupHomomorphism E B) `{IsSurjection g, IsExact (Tr (-1)) _ _ _ f g} : GroupIsomorphism (ab_cokernel f) B. Proof. snrapply Build_GroupIsomorphism. - snrapply (quotient_abgroup_rec _ _ g). intros e; rapply Trunc_rec; intros [a p]. refine (ap _ p^ @ _). rapply cx_isexact. - apply isequiv_surj_emb. 1: rapply cancelR_conn_map. apply isembedding_isinj_hset. srapply Quotient_ind2_hprop; intros x y. intro p. apply qglue; cbn. refine (isexact_preimage (Tr (-1)) _ _ (-x + y) _). refine (grp_homo_op _ _ _ @ _). rewrite grp_homo_inv. apply grp_moveL_M1^-1. exact p^. Defined. Definition abses_cokernel_iso_inv_beta `{Funext} {A E B : AbGroup} (f : A $-> E) (g : GroupHomomorphism E B) `{IsSurjection g, IsExact (Tr (-1)) _ _ _ f g} : (abses_cokernel_iso f g)^-1 o g == grp_quotient_map. Proof. intro x; by apply moveR_equiv_V. Defined. Coq-HoTT-9.0/theories/Algebra/AbSES/DirectSum.v000066400000000000000000000102111474641544500210730ustar00rootroot00000000000000Require Import Basics Types Truncations.Core. Require Import Pointed.Core. Require Import WildCat.Core Homotopy.ExactSequence. Require Import AbGroups.AbelianGroup AbSES.Core AbGroups.Biproduct. Local Open Scope pointed_scope. Local Open Scope type_scope. Local Open Scope mc_add_scope. (** * The direct sum of short exact sequences *) (** Biproducts of abelian groups preserve exactness. *) Lemma ab_biprod_exact {A E B X F Y : AbGroup} (i : A $-> E) (p : E $-> B) `{ex0 : IsExact (Tr (-1)) _ _ _ i p} (j : X $-> F) (q : F $-> Y) `{ex1 : IsExact (Tr (-1)) _ _ _ j q} : IsExact (Tr (-1)) (functor_ab_biprod i j) (functor_ab_biprod p q). Proof. snrapply Build_IsExact. - snrapply phomotopy_homotopy_hset. 1: exact _. intro x; apply path_prod; cbn. + apply ex0. + apply ex1. - intros [[e f] u]; cbn. rapply contr_inhabited_hprop. pose (U := (equiv_path_prod _ _)^-1 u); cbn in U. pose proof (a := isexact_preimage _ i p e (fst U)). pose proof (x := isexact_preimage _ j q f (snd U)). strip_truncations; apply tr. exists (ab_biprod_inl a.1 + ab_biprod_inr x.1); cbn. pose (IS := sg_set (ab_biprod B Y)). (* This hint speeds up the next line. *) apply path_sigma_hprop; cbn. apply path_prod; cbn. + rewrite right_identity. exact a.2. + rewrite left_identity. exact x.2. Defined. (** The pointwise direct sum of two short exact sequences. *) Definition abses_direct_sum `{Funext} {B A B' A' : AbGroup} (E : AbSES B A) (F : AbSES B' A') : AbSES (ab_biprod B B') (ab_biprod A A') := Build_AbSES (ab_biprod E F) (functor_ab_biprod (inclusion E) (inclusion F)) (functor_ab_biprod (projection E) (projection F)) (functor_ab_biprod_embedding _ _) (functor_ab_biprod_surjection _ _) (ab_biprod_exact _ _ _ _). (** For any short exact sequences [E], [E'], [F], [F'], and morphisms [f : E -> E'] and [g : F -> F'] there is a morphism [E + F -> E' + F']. *) Lemma functor_abses_directsum `{Funext} {A A' B B' C C' D D' : AbGroup} {E : AbSES B A} {E' : AbSES B' A'} {F : AbSES D C} {F' : AbSES D' C'} (f : AbSESMorphism E E') (g : AbSESMorphism F F') : AbSESMorphism (abses_direct_sum E F) (abses_direct_sum E' F'). Proof. snrapply Build_AbSESMorphism. + exact (functor_ab_biprod (component1 f) (component1 g)). + exact (functor_ab_biprod (component2 f) (component2 g)). + exact (functor_ab_biprod (component3 f) (component3 g)). + intro x. apply path_prod; apply left_square. + intro x. apply path_prod; apply right_square. Defined. (** For any short exact sequence [E], there is a morphism [E -> abses_direct_sum E E], where each component is ab_diagonal. *) Definition abses_diagonal `{Funext} {A B : AbGroup} (E : AbSES B A) : AbSESMorphism E (abses_direct_sum E E). Proof. snrapply Build_AbSESMorphism. 1,2,3: exact ab_diagonal. all: reflexivity. Defined. (** For any short exact sequence [E], there is dually a morphism [abses_direct_sum E E -> E], with each component being the codiagonal. *) Definition abses_codiagonal `{Funext} {A B : AbGroup} (E : AbSES B A) : AbSESMorphism (abses_direct_sum E E) E. Proof. snrapply Build_AbSESMorphism. 1,2,3: exact ab_codiagonal. all: intro x; cbn; apply grp_homo_op. Defined. (** There is always a morphism [abses_direct_sum E F -> abses_direct_sum F E] of short exact sequences, for any [E : AbSES B A] and [F : AbSES B' A']. *) Definition abses_swap_morphism `{Funext} {A A' B B' : AbGroup} (E : AbSES B A) (F : AbSES B' A') : AbSESMorphism (abses_direct_sum E F) (abses_direct_sum F E). Proof. snrapply Build_AbSESMorphism. 1,2,3: exact direct_sum_swap. all: reflexivity. Defined. (** For [E, F, G : AbSES B A], there is a morphism [(E + F) + G -> (G + F) + E] induced by the above map, where [+] denotes [abses_direct_sum]. *) Lemma abses_twist_directsum `{Funext} {A B : AbGroup} (E F G : AbSES B A) : AbSESMorphism (abses_direct_sum (abses_direct_sum E F) G) (abses_direct_sum (abses_direct_sum G F) E). Proof. snrapply Build_AbSESMorphism. 1,2,3: exact ab_biprod_twist. all: reflexivity. Defined. Coq-HoTT-9.0/theories/Algebra/AbSES/Ext.v000066400000000000000000000133011474641544500177370ustar00rootroot00000000000000Require Import Basics Types Truncations.Core. Require Import Pointed WildCat. Require Import Truncations.SeparatedTrunc. Require Import AbelianGroup AbHom AbProjective. Require Import AbSES.Pullback AbSES.Pushout AbSES.BaerSum AbSES.Core. Local Open Scope mc_scope. Local Open Scope mc_add_scope. (** * The set [Ext B A] of abelian group extensions *) Definition Ext (B A : AbGroup@{u}) := pTr 0 (AbSES B A). Global Instance is0bifunctor_ext `{Univalence} : Is0Bifunctor (Ext : AbGroup^op -> AbGroup -> pType) := is0bifunctor_postcompose _ _ (bf:=is0bifunctor_abses). Global Instance is1bifunctor_ext `{Univalence} : Is1Bifunctor (Ext : AbGroup^op -> AbGroup -> pType) := is1bifunctor_postcompose _ _ (bf:=is1bifunctor_abses). (** An extension [E : AbSES B A] is trivial in [Ext B A] if and only if [E] merely splits. *) Proposition iff_ab_ext_trivial_split `{Univalence} {B A : AbGroup} (E : AbSES B A) : merely {s : GroupHomomorphism B E & (projection _) $o s == idmap} <~> (tr E = point (Ext B A)). Proof. refine (equiv_path_Tr _ _ oE _). srapply equiv_iff_hprop; apply Trunc_functor; apply iff_abses_trivial_split. Defined. Definition Ext' (B A : AbGroup@{u}) := Tr 0 (AbSES' B A). Global Instance is0bifunctor_ext' `{Univalence} : Is0Bifunctor (Ext' : AbGroup^op -> AbGroup -> Type) := is0bifunctor_postcompose _ _ (bf:=is0bifunctor_abses'). Global Instance is1bifunctor_ext' `{Univalence} : Is1Bifunctor (Ext' : AbGroup^op -> AbGroup -> Type) := is1bifunctor_postcompose _ _ (bf:=is1bifunctor_abses'). (** [Ext B A] is an abelian group for any [A B : AbGroup]. The proof of commutativity is a bit faster if we separate out the proof that [Ext B A] is a group. *) Definition grp_ext `{Univalence} (B A : AbGroup@{u}) : Group. Proof. snrapply (Build_Group (Ext B A)). - intros E F. strip_truncations. exact (tr (abses_baer_sum E F)). - exact (point (Ext B A)). - unfold Inverse. exact (Trunc_functor _ (abses_pullback (- grp_homo_id))). - repeat split. 1: apply istrunc_truncation. all: intro E. 1: intros F G. all: strip_truncations; unfold mon_unit, point; apply (ap tr). + symmetry; apply baer_sum_associative. + apply baer_sum_unit_l. + apply baer_sum_unit_r. + apply baer_sum_inverse_r. + apply baer_sum_inverse_l. Defined. (** ** The bifunctor [ab_ext] *) Definition ab_ext@{u v|u < v} `{Univalence} (B : AbGroup@{u}^op) (A : AbGroup@{u}) : AbGroup@{v}. Proof. snrapply (Build_AbGroup (grp_ext@{u v} B A)). intros E F. strip_truncations; cbn. apply ap. apply baer_sum_commutative. Defined. Global Instance is0functor_abext01 `{Univalence} (B : AbGroup^op) : Is0Functor (ab_ext B). Proof. srapply Build_Is0Functor; intros ? ? f. snrapply Build_GroupHomomorphism. 1: exact (fmap (Ext B) f). rapply Trunc_ind; intro E0. rapply Trunc_ind; intro E1. apply (ap tr); cbn. apply baer_sum_pushout. Defined. Global Instance is0functor_abext10 `{Univalence} (A : AbGroup) : Is0Functor (fun B : AbGroup^op => ab_ext B A). Proof. srapply Build_Is0Functor; intros ? ? f; cbn. snrapply Build_GroupHomomorphism. 1: exact (fmap (fun (B : AbGroup^op) => Ext B A) f). rapply Trunc_ind; intro E0. rapply Trunc_ind; intro E1. apply (ap tr); cbn. apply baer_sum_pullback. Defined. Global Instance is1functor_abext01 `{Univalence} (B : AbGroup^op) : Is1Functor (ab_ext B). Proof. snrapply Build_Is1Functor. - intros A C f g. exact (fmap2 (Ext B)). - exact (fmap_id (Ext B)). - intros A C D. exact (fmap_comp (Ext B)). Defined. Global Instance is1functor_abext10 `{Univalence} (A : AbGroup) : Is1Functor (fun B : AbGroup^op => ab_ext B A). Proof. snrapply Build_Is1Functor. - intros B C f g. exact (fmap2 (fun B : AbGroup^op => Ext B A)). - exact (fmap_id (fun B : AbGroup^op => Ext B A)). - intros B C D. exact (fmap_comp (fun B : AbGroup^op => Ext B A)). Defined. Global Instance is0bifunctor_abext `{Univalence} : Is0Bifunctor (A:=AbGroup^op) ab_ext. Proof. rapply Build_Is0Bifunctor''. Defined. Global Instance is1bifunctor_abext `{Univalence} : Is1Bifunctor (A:=AbGroup^op) ab_ext. Proof. snrapply Build_Is1Bifunctor''. 1,2: exact _. intros A B. exact (bifunctor_coh (Ext : AbGroup^op -> AbGroup -> pType)). Defined. (** We can push out a fixed extension while letting the map vary, and this defines a group homomorphism. *) Definition abses_pushout_ext `{Univalence} {B A G : AbGroup@{u}} (E : AbSES B A) : GroupHomomorphism (ab_hom A G) (ab_ext B G). Proof. snrapply Build_GroupHomomorphism. 1: exact (fun f => fmap01 (A:=AbGroup^op) Ext' _ f (tr E)). intros f g; cbn. nrapply (ap tr). exact (baer_sum_distributive_pushouts f g). Defined. (** ** Extensions ending in a projective are trivial *) Proposition abext_trivial_projective `{Univalence} (P : AbGroup) `{IsAbProjective P} : forall A, forall E : AbSES P A, tr E = point (Ext P A). Proof. intros A E. apply iff_ab_ext_trivial_split. exact (fst (iff_isabprojective_surjections_split P) _ _ _ _). Defined. (** It follows that when [P] is projective, [Ext P A] is contractible. *) Global Instance contr_abext_projective `{Univalence} (P : AbGroup) `{IsAbProjective P} {A : AbGroup} : Contr (Ext P A). Proof. apply (Build_Contr _ (point _)); intro E. strip_truncations. symmetry; by apply abext_trivial_projective. Defined. (* Converely, if all extensions ending in [P] are trivial, then [P] is projective. *) Proposition abext_projective_trivial `{Univalence} (P : AbGroup) (ext_triv : forall A, forall E : AbSES P A, tr E = point (Ext P A)) : IsAbProjective P. Proof. apply iff_isabprojective_surjections_split. intros E p issurj_p. apply (iff_ab_ext_trivial_split (abses_from_surjection p))^-1. apply ext_triv. Defined. Coq-HoTT-9.0/theories/Algebra/AbSES/Pullback.v000066400000000000000000000435251474641544500207470ustar00rootroot00000000000000Require Import Basics Types. Require Import HSet Limits.Pullback. Require Import WildCat Pointed.Core Homotopy.ExactSequence. Require Import Modalities.ReflectiveSubuniverse. Require Import AbGroups.AbelianGroup AbGroups.AbPullback AbGroups.Biproduct. Require Import AbSES.Core AbSES.DirectSum. Local Open Scope abses_scope. (** * Pullbacks of short exact sequences *) (** A short exact sequence [A -> E -> B] can be pulled back along a map [B' -> B]. We start by defining the underlying map, then the pointed version. *) Definition abses_pullback {A B B' : AbGroup} (f : B' $-> B) : AbSES B A -> AbSES B' A. Proof. intro E. snrapply (Build_AbSES (ab_pullback (projection E) f) (grp_pullback_corec _ _ (inclusion _) grp_homo_const _) (grp_pullback_pr2 (projection _) f)). - intro x. nrefine (_ @ (grp_homo_unit f)^). apply isexact_inclusion_projection. - exact (cancelL_isembedding (g:= grp_pullback_pr1 _ _)). - rapply conn_map_pullback'. - snrapply Build_IsExact. + snrapply phomotopy_homotopy_hset. * exact _. * reflexivity. + nrefine (cancelL_equiv_conn_map _ _ (hfiber_pullback_along_pointed f (projection _) (grp_homo_unit _))). nrefine (conn_map_homotopic _ _ _ _ (conn_map_isexact (IsExact:=isexact_inclusion_projection _))). intro a. by apply path_sigma_hprop. Defined. (** ** The universal property of [abses_pullback_morphism] *) (** The natural map from the pulled back sequence. *) Definition abses_pullback_morphism {A B B' : AbGroup@{u}} (E : AbSES B A) (f : B' $-> B) : AbSESMorphism (abses_pullback f E) E. Proof. snrapply (Build_AbSESMorphism grp_homo_id _ f). - apply grp_pullback_pr1. - reflexivity. - apply pullback_commsq. Defined. (** Any map [f : E -> F] of short exact sequences factors (uniquely) through [abses_pullback F f3]. *) Definition abses_pullback_morphism_corec {A B X Y : AbGroup@{u}} {E : AbSES B A} {F : AbSES Y X} (f : AbSESMorphism E F) : AbSESMorphism E (abses_pullback (component3 f) F). Proof. snrapply (Build_AbSESMorphism (component1 f) _ grp_homo_id). - apply (grp_pullback_corec (projection F) (component3 f) (component2 f) (projection E)). apply right_square. - intro x; cbn. apply equiv_path_pullback_hset; cbn; split. + apply left_square. + symmetry; apply iscomplex_abses. - reflexivity. Defined. (** The original map factors via the induced map. *) Definition abses_pullback_morphism_corec_beta `{Funext} {A B X Y : AbGroup@{u}} {E : AbSES B A} {F : AbSES Y X} (f : AbSESMorphism E F) : f = absesmorphism_compose (abses_pullback_morphism F (component3 f)) (abses_pullback_morphism_corec f). Proof. apply (equiv_ap issig_AbSESMorphism^-1 _ _). srapply path_sigma_hprop. apply path_prod. 1: apply path_prod. all: by apply equiv_path_grouphomomorphism. Defined. Definition abses_pullback_component1_id' {A B B' : AbGroup@{u}} {E : AbSES B A} {F : AbSES B' A} (f : AbSESMorphism E F) (h : component1 f == grp_homo_id) : E $== abses_pullback (component3 f) F. Proof. pose (g := abses_pullback_morphism_corec f). nrapply abses_path_data_to_iso. exists (component2 g); split. - exact (fun a => (left_square g a)^ @ ap _ (h a)). - reflexivity. Defined. (** In particular, if [component1] of a morphism is the identity, then it exhibits the domain as the pullback of the codomain. *) Definition abses_pullback_component1_id `{Univalence} {A B B' : AbGroup} {E : AbSES B A} {F : AbSES B' A} (f : AbSESMorphism E F) (h : component1 f == grp_homo_id) : E = abses_pullback (component3 f) F := equiv_path_abses_iso (abses_pullback_component1_id' f h). (** For any two [E, F : AbSES B A] and [f, g : B' $-> B], there is a morphism [Ef + Fg -> E + F] induced by the universal properties of the pullbacks of E and F, respectively. *) Definition abses_directsum_pullback_morphism `{Funext} {A B B' C D D' : AbGroup@{u}} {E : AbSES B A} {F : AbSES D C} (f : B' $-> B) (g : D' $-> D) : AbSESMorphism (abses_direct_sum (abses_pullback f E) (abses_pullback g F)) (abses_direct_sum E F) := functor_abses_directsum (abses_pullback_morphism E f) (abses_pullback_morphism F g). (** For any two [E, F : AbSES B A] and [f, g : B' $-> B], we have (E + F)(f + g) = Ef + Eg, where + denotes the direct sum. *) Definition abses_directsum_distributive_pullbacks `{Univalence} {A B B' C D D' : AbGroup@{u}} {E : AbSES B A} {F : AbSES D C} (f : B' $-> B) (g : D' $-> D) : abses_pullback (functor_ab_biprod f g) (abses_direct_sum E F) = abses_direct_sum (abses_pullback f E) (abses_pullback g F) := (abses_pullback_component1_id (abses_directsum_pullback_morphism f g) (fun _ => idpath))^. Definition abses_path_pullback_projection_commsq {A B B' : AbGroup@{u}} (bt : B' $-> B) (E : AbSES B A) (F : AbSES B' A) (p : abses_pullback bt E = F) : exists phi : middle F $-> E, projection E o phi == bt o projection F. Proof. induction p. exists (grp_pullback_pr1 _ _); intro x. nrapply pullback_commsq. Defined. (** ** Functoriality of [abses_pullback f] for [f : B' $-> B] *) (** As any function, [abses_pullback f] acts on paths. By explicitly describing the analogous action on path data we get an action which computes, this turn out to be useful. *) Global Instance is0functor_abses_pullback {A B B' : AbGroup} (f : B' $-> B) : Is0Functor (abses_pullback (A:=A) f). Proof. srapply Build_Is0Functor; intros E F p. snrefine (_; (_,_)). - srapply equiv_functor_grp_pullback. 1,3: exact grp_iso_id. 1: exact p.1. 2: reflexivity. intro x. exact (snd p.2 x)^. - intro x. srapply equiv_path_pullback_hset; split; cbn. 2: reflexivity. exact (fst p.2 x). - reflexivity. Defined. Global Instance is1functor_abses_pullback {A B B' : AbGroup} (f : B' $-> B) : Is1Functor (abses_pullback (A:=A) f). Proof. snrapply Build_Is1Functor. - intros E F p q h x. srapply equiv_path_pullback_hset; split; cbn. 2: reflexivity. exact (h _). - intros E x. by srapply equiv_path_pullback_hset. - intros E F G p q x. by srapply equiv_path_pullback_hset. Defined. Lemma ap_abses_pullback `{Univalence} {A B B' : AbGroup} (f : B' $-> B) {E F : AbSES B A} (p : E = F) : ap (abses_pullback f) p = equiv_path_abses_iso (fmap (abses_pullback f) (equiv_path_abses_iso^-1 p)). Proof. induction p. nrefine (_ @ ap equiv_path_abses_iso _). 2: refine ((fmap_id_strong _ _)^ @ ap _ equiv_path_absesV_1^). exact equiv_path_abses_1^. Defined. Lemma ap_abses_pullback_data `{Univalence} {A B B' : AbGroup} (f : B' $-> B) {E F : AbSES B A} (p : abses_path_data_iso E F) : ap (abses_pullback f) (equiv_path_abses_iso p) = equiv_path_abses_iso (fmap (abses_pullback f) p). Proof. refine (ap_abses_pullback _ _ @ _). apply (ap (equiv_path_abses_iso o _)). apply eissect. Defined. Definition abses_pullback_point' {A B B' : AbGroup} (f : B' $-> B) : (abses_pullback f pt) $== (point (AbSES B' A)). Proof. snrefine (_; (_, _)). - snrapply Build_GroupIsomorphism. + srapply ab_biprod_corec. * refine (ab_biprod_pr1 $o _). apply grp_pullback_pr1. * apply projection. + srapply isequiv_adjointify. * snrapply grp_pullback_corec. -- exact (functor_ab_biprod grp_homo_id f). -- exact ab_biprod_pr2. -- reflexivity. * reflexivity. * intros [[a b] [b' c]]. srapply equiv_path_pullback_hset; split; cbn. 2: reflexivity. exact (path_prod' idpath c^). - reflexivity. - reflexivity. Defined. Definition abses_pullback_point `{Univalence} {A B B' : AbGroup} (f : B' $-> B) : abses_pullback f pt = pt :> AbSES B' A := equiv_path_abses_iso (abses_pullback_point' f). Definition abses_pullback' {A B B' : AbGroup} (f : B' $-> B) : AbSES B A -->* AbSES B' A := Build_BasepointPreservingFunctor (abses_pullback f) (abses_pullback_point' f). (** Pullback of short exact sequences as a pointed map. *) Definition abses_pullback_pmap `{Univalence} {A B B' : AbGroup} (f : B' $-> B) : AbSES B A ->* AbSES B' A := to_pointed (abses_pullback' f). (** ** Functoriality of [abses_pullback] *) (** [abses_pullback] is psuedo-functorial, and we can state this in terms of actual homotopies or "path data homotopies." We decorate the latter with the suffix ('). *) (** For every [E : AbSES B A], the pullback of [E] along [id_B] is [E]. *) Definition abses_pullback_id `{Univalence} {A B : AbGroup} : abses_pullback (A:=A) (@grp_homo_id B) == idmap. Proof. intro E. apply equiv_path_abses_iso; srefine (_; (_, _)). 1: rapply (Build_GroupIsomorphism _ _ (grp_pullback_pr1 _ _)). 1: reflexivity. intros [a [p q]]; cbn. exact q^. Defined. Definition abses_pullback_pmap_id `{Univalence} {A B : AbGroup} : abses_pullback_pmap (A:=A) (@grp_homo_id B) ==* pmap_idmap. Proof. srapply Build_pHomotopy. 1: apply abses_pullback_id. refine (_ @ (concat_p1 _)^). nrapply (ap equiv_path_abses_iso). apply path_sigma_hprop. apply equiv_path_groupisomorphism. intros [[a b] [b' p]]; cbn; cbn in p. by apply path_prod'. Defined. Definition abses_pullback_compose' {A B0 B1 B2 : AbGroup@{u}} (f : B0 $-> B1) (g : B1 $-> B2) : abses_pullback (A:=A) f o abses_pullback g $=> abses_pullback (g $o f). Proof. intro E; srefine (_; (_,_)). - apply equiv_grp_pullback_compose_r. - intro a. by srapply equiv_path_pullback_hset. - reflexivity. Defined. (** The analog of [abses_pullback_compose'] with actual homotopies. *) Definition abses_pullback_compose `{Univalence} {A B0 B1 B2 : AbGroup@{u}} (f : B0 $-> B1) (g : B1 $-> B2) : abses_pullback (A:=A) f o abses_pullback g == abses_pullback (g $o f) := fun x => equiv_path_abses_iso (abses_pullback_compose' f g x). (** We now work towards *pointed* composition of pullback ([abses_pullback_pcompose]). The proof of pointedness will matter when we later prove that pulling back along a short exact sequence is exact (i.e. that the complex [iscomplex_pullback_abses] below is exact). For this reason we carefully construct the proof of pointedness in terms of the analog [abses_pullback_pcompose'] on path data, which computes. *) Definition abses_pullback_pcompose' {B0 B1 B2 A : AbGroup} (f : B0 $-> B1) (g : B1 $-> B2) : abses_pullback' f $o* abses_pullback' g $=>* abses_pullback' (A:=A) (g $o f). Proof. exists (abses_pullback_compose' f g). intros [[[a b2] [b1 c]] [b0 c']]; cbn in c, c'. srapply equiv_path_pullback_hset; split; cbn. 2: reflexivity. exact (path_prod' idpath (c @ ap g c')). Defined. Definition abses_pullback_pcompose `{Univalence} {A B0 B1 B2 : AbGroup} (f : B0 $-> B1) (g : B1 $-> B2) : abses_pullback_pmap (A:=A) f o* abses_pullback_pmap g ==* abses_pullback_pmap (g $o f). Proof. refine (to_pointed_compose _ _ @* _). apply equiv_ptransformation_phomotopy. apply abses_pullback_pcompose'. Defined. (** *** Pulling back along constant maps *) Lemma abses_pullback_const' {A B B' : AbGroup} : const pt $=> (@abses_pullback A B B' grp_homo_const). Proof. intro E. simpl. nrapply abses_path_data_to_iso. srefine (_;(_,_)); cbn. - srapply grp_pullback_corec. + exact (inclusion _ $o ab_biprod_pr1). + exact ab_biprod_pr2. + intro x; cbn. apply iscomplex_abses. - intro a; cbn. by srapply equiv_path_pullback_hset; split. - reflexivity. Defined. Definition abses_pullback_const `{Univalence} {A B B' : AbGroup} : const pt == @abses_pullback A B B' grp_homo_const := fun x => (equiv_path_abses_iso (abses_pullback_const' x)). Lemma abses_pullback_pconst' {A B B' : AbGroup} : @pmap_abses_const B' A B A $=>* abses_pullback' grp_homo_const. Proof. srefine (_; _). 1: rapply abses_pullback_const'. lazy beta. intro x; reflexivity. Defined. Definition abses_pullback_pconst `{Univalence} {A B B' : AbGroup} : pconst ==* @abses_pullback_pmap _ A B B' grp_homo_const. Proof. refine (pmap_abses_const_to_pointed @* _). rapply equiv_ptransformation_phomotopy. exact abses_pullback_pconst'. Defined. (** *** Pulling [E] back along [projection E] is trivial *) Definition abses_pullback_projection_morphism {B A : AbGroup} (E : AbSES B A) : AbSESMorphism (pt : AbSES E A) E. Proof. srapply (Build_AbSESMorphism grp_homo_id _ (projection E)). - cbn. exact (ab_biprod_rec (inclusion E) grp_homo_id). - intro x; cbn. exact (right_identity _)^. - intros [a e]; cbn. refine (grp_homo_op _ _ _ @ _). refine (ap (fun x => sg_op x _) _ @ _). 1: apply isexact_inclusion_projection. apply left_identity. Defined. Definition abses_pullback_projection `{Univalence} {B A : AbGroup} (E : AbSES B A) : pt = abses_pullback (projection E) E := abses_pullback_component1_id (abses_pullback_projection_morphism E) (fun _ => idpath). (** *** Pulling back along homotopic maps *) Lemma abses_pullback_homotopic' {A B B' : AbGroup} (f f' : B $-> B') (h : f == f') : abses_pullback (A:=A) f $=> abses_pullback f'. Proof. intro E. srefine (_; (_, _)). - srapply equiv_functor_grp_pullback. 1-3: exact grp_iso_id. 1: reflexivity. apply h. - intro a; cbn. by srapply equiv_path_pullback_hset; split. - reflexivity. Defined. Lemma abses_pullback_homotopic `{Univalence} {A B B' : AbGroup} (f f' : B $-> B') (h : f == f') : abses_pullback (A:=A) f == abses_pullback f'. Proof. intro E. apply equiv_path_abses_iso. exact (abses_pullback_homotopic' _ _ h _). Defined. Lemma abses_pullback_phomotopic' {A B B' : AbGroup} (f f' : B $-> B') (h : f == f') : abses_pullback' (A:=A) f $=>* abses_pullback' f'. Proof. exists (abses_pullback_homotopic' f f' h); cbn. intros [[a b'] [b c]]; cbn in c. srapply equiv_path_pullback_hset; split; cbn. 2: reflexivity. exact (path_prod' idpath (c @ h b)). Defined. Definition abses_pullback_phomotopic `{Univalence} {A B B' : AbGroup} (f f' : B $-> B') (h : f == f') : abses_pullback_pmap (A:=A) f ==* abses_pullback_pmap f' := equiv_ptransformation_phomotopy (abses_pullback_phomotopic' f f' h). (** *** Pulling back along a complex *) Definition iscomplex_abses_pullback' {A B0 B1 B2 : AbGroup} (f : B0 $-> B1) (g : B1 $-> B2) (h : g $o f == grp_homo_const) : abses_pullback' f $o* abses_pullback' g $=>* @pmap_abses_const _ _ _ A. Proof. refine (abses_pullback_pcompose' _ _ $@* _). refine (abses_pullback_phomotopic' _ _ h $@* _). exact abses_pullback_pconst'^*$. Defined. Definition iscomplex_abses_pullback `{Univalence} {A B0 B1 B2 : AbGroup} (f : B0 $-> B1) (g : B1 $-> B2) (h : g $o f == grp_homo_const) : IsComplex (abses_pullback_pmap (A:=A) g) (abses_pullback_pmap f). Proof. refine (_ @* _). 2: symmetry; exact pmap_abses_const_to_pointed. refine (to_pointed_compose _ _ @* _). apply equiv_ptransformation_phomotopy. by rapply iscomplex_abses_pullback'. Defined. (** A consequence is that pulling back along a short exact sequence forms a complex. *) Definition iscomplex_pullback_abses `{Univalence} {A B C : AbGroup} (E : AbSES C B) : IsComplex (abses_pullback_pmap (A:=A) (projection E)) (abses_pullback_pmap (inclusion E)). Proof. rapply iscomplex_abses_pullback. rapply iscomplex_abses. Defined. (** In fact, pulling back along a short exact sequence is (purely) exact. See [AbSES.PullbackFiberSequence]. *) (** *** Fibers of pullback in terms of path data *) Definition equiv_hfiber_abses `{Univalence} {X : Type} {A B : AbGroup} (f : X -> AbSES B A) (E : AbSES B A) : graph_hfiber f E <~> hfiber f E := equiv_functor_sigma_id (fun _ => equiv_path_abses_iso). Definition hfiber_abses_path {A B B' : AbGroup} {f : B' $-> B} {X : AbSES B' A} (E F : graph_hfiber (abses_pullback f) X) := {p : E.1 $-> F.1 & (fmap (abses_pullback f) p)^$ $@ E.2 $-> F.2}. Definition transport_path_data_hfiber_abses_pullback_l `{Univalence} {A B B' : AbGroup} {f : B' $-> B} {Y : AbSES B' A} {X0 : graph_hfiber (abses_pullback f) Y} {X1 : AbSES B A} (p : X0.1 = X1) : transport (fun x : AbSES B A => abses_pullback f x $== Y) p X0.2 = fmap (abses_pullback f) (equiv_path_abses_iso^-1 p^) $@ X0.2. Proof. induction p. refine (transport_1 _ _ @ _). nrefine (_ @ (ap (fun x => x $@ _)) _). 2: { refine (_ @ ap _ equiv_path_absesV_1^). exact (fmap_id_strong _ _)^. } exact (cat_idr_strong _)^. Defined. Definition equiv_hfiber_abses_pullback `{Univalence} {A B B' : AbGroup} {f : B' $-> B} (Y : AbSES B' A) (U V : graph_hfiber (abses_pullback f) Y) : hfiber_abses_path U V <~> U = V. Proof. refine (equiv_path_sigma _ _ _ oE _). srapply (equiv_functor_sigma' equiv_path_abses_iso); intro p; lazy beta. refine (equiv_concat_l _ _ oE _). { refine (transport_path_data_hfiber_abses_pullback_l _ @ _). refine (ap (fun x => (fmap (abses_pullback f) x) $@ _) _ @ _). { refine (ap _ (abses_path_data_V p) @ _). apply eissect. } refine (ap (fun x => x $@ _) _). rapply gpd_strong_1functor_V. } refine (equiv_path_sigma_hprop _ _ oE _). apply equiv_path_groupisomorphism. Defined. (** *** [AbSES] and [AbSES'] become contravariant functors in the first variable by pulling back *) Global Instance is0functor_abses'10 {A : AbGroup} : Is0Functor (fun B : AbGroup^op => AbSES' B A). Proof. apply Build_Is0Functor. exact (fun _ _ f => abses_pullback f). Defined. Global Instance is1functor_abses'10 `{Univalence} {A : AbGroup} : Is1Functor (fun B : AbGroup^op => AbSES' B A). Proof. apply Build_Is1Functor; intros; cbn. - by apply abses_pullback_homotopic. - apply abses_pullback_id. - symmetry; apply abses_pullback_compose. Defined. Global Instance is0functor_abses10 `{Univalence} {A : AbGroup} : Is0Functor (fun B : AbGroup^op => AbSES B A). Proof. apply Build_Is0Functor. exact (fun _ _ f => abses_pullback_pmap f). Defined. Global Instance is1functor_abses10 `{Univalence} {A : AbGroup} : Is1Functor (fun B : AbGroup^op => AbSES B A). Proof. apply Build_Is1Functor; intros; cbn. - by apply abses_pullback_phomotopic. - apply abses_pullback_pmap_id. - symmetry; apply abses_pullback_pcompose. Defined. Coq-HoTT-9.0/theories/Algebra/AbSES/PullbackFiberSequence.v000066400000000000000000000416051474641544500234050ustar00rootroot00000000000000Require Import Basics Types HSet HFiber Limits.Pullback. Require Import WildCat Pointed.Core Homotopy.ExactSequence. Require Import Groups.QuotientGroup. Require Import AbGroups.AbelianGroup AbGroups.AbPullback AbGroups.Biproduct. Require Import AbSES.Core AbSES.Pullback. Require Import Modalities.Identity Modalities.Modality Truncations.Core. Local Open Scope pointed_scope. Local Open Scope mc_add_scope. (** * The fiber sequence induced by pulling back along a short exact sequence *) (** We show that pulling back along a short exact sequence [E : AbSES C B] produces a fiber sequence [AbSES C A -> AbSES E A -> AbSES B A]. The associated long exact sequence of homotopy groups recovers the usual (contravariant) six-term exact sequence of Ext groups. We will prove the analog of exactness in terms of path data, and deduce the usual notion. *) (** If a short exact sequence [A -> F -> E] becomes trivial after pulling back along an inclusion [i : B -> E], then there is a "transpose" short exact sequence [B -> F -> F/B]. We begin by constructing the the map [B -> F]. *) Definition abses_pullback_inclusion_transpose_map {A B E : AbGroup} (i : B $-> E) `{IsEmbedding i} (F : AbSES E A) (p : abses_pullback i F $== pt) : B $-> F := grp_pullback_pr1 _ _ $o p^$.1 $o ab_biprod_inr. (** The comparison map [A + B $-> F] is an embedding. This comes up twice so we factor it out as a lemma. *) Local Instance abses_pullback_inclusion_lemma {A B E : AbGroup} (i : B $-> E) `{IsEmbedding i} (F : AbSES E A) (p : abses_pullback i F $== pt) : IsEmbedding (grp_pullback_pr1 _ _ $o p^$.1). Proof. nrapply (istruncmap_compose (-1) p^$.1 (grp_pullback_pr1 (projection F) i)). all: rapply istruncmap_mapinO_tr. Defined. (** The map [B -> F] is an inclusion. *) Local Instance abses_pullback_inclusion_transpose_embedding {A B E : AbGroup} (i : B $-> E) `{IsEmbedding i} (F : AbSES E A) (p : abses_pullback i F $== pt) : IsEmbedding (abses_pullback_inclusion_transpose_map i F p). Proof. rapply (istruncmap_compose _ (ab_biprod_inr)). Defined. (** We define the cokernel [F/B], which is what we need below. *) Definition abses_pullback_inclusion_transpose_endpoint' {A B E : AbGroup} (i : B $-> E) `{IsEmbedding i} (F : AbSES E A) (p : abses_pullback i F $== pt) : AbGroup := ab_cokernel_embedding (abses_pullback_inclusion_transpose_map i F p). (** The composite map [B -> F -> E] is homotopic to the original inclusion [i : B -> E]. *) Lemma abses_pullback_inclusion_transpose_beta {A B E : AbGroup} (i : B $-> E) `{IsEmbedding i} (F : AbSES E A) (p : abses_pullback i F $== pt) : projection F $o (abses_pullback_inclusion_transpose_map i F p) == i. Proof. intro b. change b with (ab_biprod_pr2 (A:=A) (mon_unit, b)). refine (pullback_commsq _ _ _ @ ap i _). exact (snd p^$.2 _)^. Defined. (** Short exact sequences in the fiber of [inclusion E] descend along [projection E]. *) Definition abses_pullback_trivial_preimage `{Univalence} {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) : AbSES C A. Proof. snrapply Build_AbSES. - exact (abses_pullback_inclusion_transpose_endpoint' (inclusion E) F p). - exact (grp_quotient_map $o inclusion F). - srapply (ab_cokernel_embedding_rec _ (projection E $o projection F)). intro b. refine (ap (projection E) (abses_pullback_inclusion_transpose_beta (inclusion E) F p b) @ _). apply iscomplex_abses. - apply isembedding_istrivial_kernel. intros a q0. (* Since [inclusion F a] is killed by [grp_quotient_map], its in the image of [B]. *) pose proof (in_coset := related_quotient_paths _ _ _ q0). (* Cleaning up the context facilitates later steps. *) destruct in_coset as [b q1]; rewrite grp_unit_r in q1. (* Since both [inclusion F] and [B -> F] factor through the mono [ab_biprod A B -> F], we can lift [q1] to [ab_biprod A B]. *) assert (q2 : ab_biprod_inr b = ab_biprod_inl (-a)). 1: { apply (isinj_embedding (grp_pullback_pr1 _ _ $o p^$.1)). - apply abses_pullback_inclusion_lemma. exact _. - nrefine (q1 @ _); symmetry. refine (ap (grp_pullback_pr1 _ _) (fst p^$.2 (-a)) @ _). exact (grp_homo_inv _ _). } (* Using [q2], we conclude. *) pose proof (q3 := ap (-) (fst ((equiv_path_prod _ _)^-1 q2))); cbn in q3. exact ((inverse_involutive _)^ @ q3^ @ grp_inv_unit). - apply (cancelR_conn_map (Tr (-1)) grp_quotient_map). 1: exact _. simpl. exact _. - snrapply Build_IsExact. + srapply phomotopy_homotopy_hset. intro a; simpl. refine (ap (projection E) _ @ _). 1: apply iscomplex_abses. apply grp_homo_unit. + intros [y q]. apply (@contr_inhabited_hprop _ _). (* We choose a preimage by [grp_quotient_map]. *) assert (f : merely (hfiber grp_quotient_map y)). 1: apply center, issurj_class_of. revert_opaque f; apply Trunc_rec; intros [f q0]. (* Since [projection F f] is in the kernel of [projection E], we find a preimage in [B]. *) assert (b : merely (hfiber (inclusion E) (projection F f))). 1: { rapply isexact_preimage. exact (ap _ q0 @ q). } revert_opaque b; apply Trunc_rec; intros [b q1]. (* The difference [f - b] in [F] is in the kernel of [projection F], hence lies in [A]. *) assert (a : merely (hfiber (inclusion F) (sg_op f (-(grp_pullback_pr1 _ _ (p^$.1 (ab_biprod_inr b))))))). 1: { rapply isexact_preimage. refine (grp_homo_op _ _ _ @ _). refine (ap (fun x => _ + x) (grp_homo_inv _ _) @ _). refine (ap (fun x => _ - x) (abses_pullback_inclusion_transpose_beta (inclusion E) F p b @ q1) @ _). apply right_inverse. } revert_opaque a; apply Trunc_rec; intros [a q2]. (* It remains to show that [a] is the desired preimage. *) refine (tr (a; _)). let T := type of y in apply (@path_sigma_hprop T). 1: intros ?; apply istrunc_paths; apply group_isgroup. refine (ap grp_quotient_map q2 @ _ @ q0). refine (grp_homo_op _ _ _ @ _). apply grp_moveR_Mg. refine (_ @ (left_inverse _)^). apply qglue. exists b. refine (_ @ (grp_unit_r _)^). exact (inverse_involutive _)^. Defined. (** That [abses_pullback_trivial_preimage E F p] pulls back to [F] is immediate from [abses_pullback_component1_id] and the following map. As such, we've shown that sequences which become trivial after pulling back along [inclusion E] are in the image of pullback along [projection E]. *) Definition abses_pullback_inclusion0_map' `{Univalence} {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) : AbSESMorphism F (abses_pullback_trivial_preimage E F p). Proof. srapply Build_AbSESMorphism. - exact grp_homo_id. - exact grp_quotient_map. - exact (projection E). - reflexivity. - reflexivity. Defined. (** For exactness we need not only a preimage of [F] but a preimage of [(F,p)] along [cxfib]. We now define and prove this in terms of path data. *) (** The analog of [cxfib] induced by pullback in terms of path data. *) Definition cxfib' {A B C : AbGroup} (E : AbSES C B) : AbSES C A -> graph_hfiber (abses_pullback (A:=A) (inclusion E)) pt. Proof. intro Y. exists (abses_pullback (projection E) Y). refine (abses_pullback_compose' _ _ Y $@ _). refine (abses_pullback_homotopic' _ grp_homo_const _ Y $@ _). 1: rapply iscomplex_abses. symmetry; apply abses_pullback_const'. Defined. Definition hfiber_cxfib' {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) := {Y : AbSES C A & hfiber_abses_path (cxfib' E Y) (F; p)}. (* This is just [idpath], but Coq takes too long to see that. *) Local Definition pr2_cxfib' `{Univalence} {A B C : AbGroup} {E : AbSES C B} (U : AbSES C A) : equiv_ptransformation_phomotopy (iscomplex_abses_pullback' _ _ (iscomplex_abses E)) U = equiv_path_abses_iso (cxfib' E U).2. Proof. change (equiv_ptransformation_phomotopy (iscomplex_abses_pullback' _ _ (iscomplex_abses E)) U) with (equiv_path_abses_iso ((iscomplex_abses_pullback' _ _ (iscomplex_abses E)).1 U)). apply (ap equiv_path_abses_iso). rapply path_hom. refine (_ $@R abses_pullback_compose' (inclusion E) (projection E) U); unfold trans_comp. refine (_ $@R abses_pullback_homotopic' (projection E $o inclusion E) grp_homo_const (iscomplex_abses E) U). reflexivity. Defined. (** Making [abses_pullback'] opaque speeds up the following proof. *) Opaque abses_pullback'. Local Definition eq_cxfib_cxfib' `{Univalence} {A B C : AbGroup} {E : AbSES C B} (U : AbSES C A) : cxfib (iscomplex_pullback_abses E) U = equiv_hfiber_abses _ _ (cxfib' E U). Proof. srapply path_sigma. 1: reflexivity. nrefine (concat_p1 _ @ _). nrefine (concat_1p _ @ _). cbn zeta. unfold equiv_hfiber_abses, equiv_functor_sigma_id, equiv_functor_sigma', equiv_functor_sigma, equiv_fun, functor_sigma, ".2". (* The goal looks identical to [pr2_cxfib'], but the implicit argument to [@paths] is expressed differently, which is why the next line isn't faster. *) exact (@pr2_cxfib' _ A B C E U). Defined. Transparent abses_pullback'. Definition equiv_hfiber_cxfib' `{Univalence} {A B C : AbGroup} {E : AbSES C B} (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) : hfiber_cxfib' E F p <~> hfiber (cxfib (iscomplex_pullback_abses E)) (equiv_hfiber_abses _ pt (F;p)). Proof. srapply equiv_functor_sigma_id; intro U; lazy beta. refine (_ oE equiv_hfiber_abses_pullback _ _ _). refine (_ oE equiv_ap' (equiv_hfiber_abses _ pt) _ _). apply equiv_concat_l. apply eq_cxfib_cxfib'. Defined. (** The type of paths in [hfiber_cxfib'] in terms of path data. *) Definition path_hfiber_cxfib' {A B C : AbGroup} {E : AbSES C B} {F : AbSES (middle E) A} {p : abses_pullback (inclusion E) F $== pt} (X Y : hfiber_cxfib' (B:=B) E F p) : Type. Proof. refine (sig (fun q0 : X.1 $== Y.1 => _)). exact ((fmap (abses_pullback (projection E)) q0)^$ $@ X.2.1 $== Y.2.1). Defined. Definition transport_hfiber_abses_path_cxfib'_l `{Univalence} {A B C : AbGroup} {E : AbSES C B} (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) (U V : hfiber_cxfib' E F p) (q : U.1 = V.1) : (transport (fun Y : AbSES C A => hfiber_abses_path (cxfib' E Y) (F; p)) q U.2).1 = fmap (abses_pullback (projection E)) (equiv_path_abses_iso^-1 q^) $@ U.2.1. Proof. induction q. refine (ap pr1 (transport_1 _ _) @ _). refine (_ @ ap (fun x => fmap (abses_pullback (projection E)) x $@ _) equiv_path_absesV_1^). refine (_ @ ap (fun x => x $@ _) (fmap_id_strong _ _)^). exact (cat_idr_strong _)^. Defined. Definition equiv_path_hfiber_cxfib' `{Univalence} {A B C : AbGroup} {E : AbSES C B} (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) (U V : hfiber_cxfib' E F p) : path_hfiber_cxfib' U V <~> U = V. Proof. refine (equiv_path_sigma _ _ _ oE _). srapply (equiv_functor_sigma' equiv_path_abses_iso); intro q; lazy beta. refine (equiv_path_sigma_hprop _ _ oE _). refine (equiv_concat_l _ _ oE _). 1: apply transport_hfiber_abses_path_cxfib'_l. refine (equiv_path_sigma_hprop _ _ oE equiv_concat_l _ _ oE _). 1: { refine (ap (fun x => (fmap (abses_pullback _) x $@ _).1) _). nrefine (ap _ (abses_path_data_V q) @ _). apply eissect. } refine (equiv_concat_l _ _ oE _). 1: { refine (ap (fun x => (x $@ _).1) _). rapply gpd_strong_1functor_V. } apply equiv_path_groupisomorphism. Defined. (** The fibre of [cxfib'] over [(F;p)] is inhabited. *) Definition hfiber_cxfib'_inhabited `{Univalence} {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) : hfiber_cxfib' E F p. Proof. exists (abses_pullback_trivial_preimage E F p). srefine (_^$; _). 1: by rapply (abses_pullback_component1_id' (abses_pullback_inclusion0_map' E F p)). lazy beta; unfold pr2. refine (cat_assoc _ _ _ $@ _). refine (cat_assoc _ _ _ $@ _). apply gpd_moveR_Vh. apply gpd_moveL_hM. apply equiv_ab_biprod_ind_homotopy. split; apply equiv_path_pullback_rec_hset; split; cbn. - intro a. exact (ap (class_of _ o pullback_pr1) (fst p^$.2 a)). - intro a. exact ((snd p^$.2 _)^). - intro b; apply qglue. exists (-b). apply grp_moveL_Vg. refine ((grp_homo_op (grp_pullback_pr1 _ _ $o p^$.1 $o ab_biprod_inr) _ _)^ @ _). exact (ap _ (right_inverse _) @ grp_homo_unit _ @ (grp_homo_unit _)^). - intro b. exact (snd p^$.2 _)^. Defined. (** To conclude exactness in terms of path data, we show that the fibre is a proposition, hence contractible. *) (** Given a point [(Y;Q)] in the fiber of [cxfib'] over [(F;p)] there is an induced map as follows. *) Local Definition hfiber_cxfib'_induced_map {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) (Y : hfiber_cxfib' E F p) : ab_biprod A B $-> abses_pullback (projection E) Y.1. Proof. destruct Y as [Y q]. refine (grp_homo_compose _ (grp_iso_inverse p.1)). refine (_ $o grp_pullback_pr1 _ _). exact (q.1^$.1). Defined. (** There is "another" obvious induced map. *) Definition abses_pullback_splits_induced_map' {A B C : AbGroup} (E : AbSES C B) (Y : AbSES C A) : ab_biprod A B $-> abses_pullback (projection E) Y. Proof. srapply (ab_biprod_rec (inclusion _)). srapply grp_pullback_corec. - exact grp_homo_const. - exact (inclusion E). - intro x. refine (grp_homo_unit _ @ _). symmetry; apply iscomplex_abses. Defined. Lemma fmap_hfiber_abses_lemma `{Univalence} {A B B' : AbGroup} (f : B' $-> B) (X Y : graph_hfiber (abses_pullback (A:=A) f) pt) (Q : hfiber_abses_path X Y) : fmap (abses_pullback f) Q.1^$ $o Y.2^$ $== X.2^$. Proof. generalize Q. equiv_intro (equiv_hfiber_abses_pullback _ X Y)^-1%equiv p; induction p. refine ((_ $@R _) $@ _). { Unshelve. 2: exact (Id _). refine (fmap2 _ _ $@ fmap_id _ _). intro x; reflexivity. } exact (cat_idl _). Defined. Lemma induced_map_eq `{Univalence} {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) (Y : hfiber_cxfib' E F p) : hfiber_cxfib'_induced_map E F p Y == abses_pullback_splits_induced_map' E Y.1. Proof. intros [a b]; cbn. refine (ap pullback_pr1 (fmap_hfiber_abses_lemma _ _ (F;p) Y.2 _) @ _). srapply equiv_path_pullback_hset; split; cbn. - exact (grp_unit_r _)^. - exact (grp_unit_l _)^. Defined. (** Given another point [(Y,Q)] in the fibre of [cxfib'] over [(F;p)], we get path data in [AbSES C A]. *) Lemma hfiber_cxfib'_induced_path'0 `{Univalence} {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) (Y : hfiber_cxfib' E F p) : abses_pullback_trivial_preimage E F p $== Y.1. Proof. destruct Y as [Y Q]. apply abses_path_data_to_iso; srefine (_; (_,_)). - snrapply (ab_cokernel_embedding_rec _ (grp_pullback_pr1 _ _$o (Q.1^$).1)). 1-3: exact _. intro f. nrefine (ap _ (induced_map_eq E F p (Y;Q) _) @ _); cbn. exact (grp_unit_r _ @ grp_homo_unit _). - intro a. refine (_ @ ap (grp_pullback_pr1 _ _) (fst (Q.1^$).2 a)). exact (grp_quotient_rec_beta' _ F _ _ (inclusion F a)). - nrapply (conn_map_elim _ grp_quotient_map). 1: apply issurj_class_of. 1: intros ?; apply istrunc_paths; apply group_isgroup. intro f. refine (ap (projection E) (snd (Q.1^$).2 f) @ _); unfold pr1. exact (pullback_commsq _ _ ((Q.1^$).1 f))^. Defined. Lemma hfiber_cxfib'_induced_path' `{Univalence} {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) (Y : hfiber_cxfib' E F p) : path_hfiber_cxfib' (hfiber_cxfib'_inhabited E F p) Y. Proof. exists (hfiber_cxfib'_induced_path'0 E F p Y). rapply gpd_moveR_Vh. rapply gpd_moveL_hM. rapply gpd_moveR_Vh. intro x. srapply equiv_path_pullback_hset; split. 2: exact (snd Y.2.1^$.2 x)^. reflexivity. Defined. (** It follows that [hfiber_cxfib'] is contractible. *) Lemma contr_hfiber_cxfib' `{Univalence} {A B C : AbGroup} (E : AbSES C B) (F : AbSES (middle E) A) (p : abses_pullback (inclusion E) F $== pt) : Contr (hfiber_cxfib' E F p). Proof. srapply Build_Contr. 1: apply hfiber_cxfib'_inhabited. intros [Y q]. apply equiv_path_hfiber_cxfib'. apply hfiber_cxfib'_induced_path'. Defined. (** From this we deduce exactness. *) Global Instance isexact_abses_pullback `{Univalence} {A B C : AbGroup} {E : AbSES C B} : IsExact purely (abses_pullback_pmap (A:=A) (projection E)) (abses_pullback_pmap (inclusion E)). Proof. srapply Build_IsExact. 1: apply iscomplex_pullback_abses. srapply (equiv_ind (equiv_hfiber_abses (abses_pullback (inclusion E)) (point (AbSES B A)))). intros [F p]. rapply contr_equiv'. 1: apply equiv_hfiber_cxfib'. apply contr_hfiber_cxfib'. Defined. Coq-HoTT-9.0/theories/Algebra/AbSES/Pushout.v000066400000000000000000000425331474641544500206570ustar00rootroot00000000000000Require Import Basics Types Truncations.Core. Require Import WildCat Pointed.Core Homotopy.ExactSequence HIT.epi. Require Import Modalities.ReflectiveSubuniverse. Require Import AbelianGroup AbPushout AbHom AbGroups.Biproduct. Require Import AbSES.Core AbSES.DirectSum. Local Open Scope pointed_scope. Local Open Scope type_scope. Local Open Scope path_scope. Local Open Scope mc_add_scope. (** * Pushouts of short exact sequences *) Definition abses_pushout `{Univalence} {A A' B : AbGroup} (f : A $-> A') : AbSES B A -> AbSES B A'. Proof. intro E. snrapply (Build_AbSES (ab_pushout f (inclusion E)) ab_pushout_inl (ab_pushout_rec grp_homo_const (projection E) _)). - symmetry; rapply iscomplex_abses. - rapply ab_pushout_embedding_inl. - nrapply (cancelR_issurjection ab_pushout_inr _). rapply (conn_map_homotopic _ (projection E)); symmetry. nrapply ab_pushout_rec_beta_right. - snrapply Build_IsExact. + srapply phomotopy_homotopy_hset. nrapply ab_pushout_rec_beta_left. + intros [bc' p]. rapply contr_inhabited_hprop. (** Pick a preimage under the quotient map. *) assert (bc : merely (hfiber grp_quotient_map bc')). 1: apply center, issurj_class_of. strip_truncations. destruct bc as [[b c] q]. (** The E-component of the preimage is in the kernel of [projection E]. *) assert (c_in_kernel : (projection E) c = mon_unit). 1: { refine (_ @ p); symmetry. rewrite <- q; simpl. apply left_identity. } (** By exactness, we get an element in [A]. *) pose proof (a := isexact_preimage _ _ _ c c_in_kernel). strip_truncations. destruct a as [a s]. (** Now the goal is to show that [bc'] lies in the image of [ab_pushout_inl]. *) apply tr. exists (b + - f (- a)); cbn. (* It simplifies the algebra to write [- f(- a)] instead of [f a]. *) apply path_sigma_hprop; cbn. change (ab_pushout_inl (b + - f (- a)) = bc'). (* Just to guide the reader. *) refine (_ @ q). symmetry. apply path_ab_pushout; cbn. refine (tr (-a; _)). apply path_prod; cbn. * apply grp_moveL_Mg. by rewrite involutive. * exact ((preserves_inverse a) @ ap _ s @ (right_identity _)^). Defined. (** ** The universal property of [abses_pushout_morphism] *) Definition abses_pushout_morphism `{Univalence} {A A' B : AbGroup} (E : AbSES B A) (f : A $-> A') : AbSESMorphism E (abses_pushout f E). Proof. snrapply (Build_AbSESMorphism f _ grp_homo_id). - exact ab_pushout_inr. - exact ab_pushout_commsq. - rapply ab_pushout_rec_beta_right. Defined. (** Any map [f : E -> F] of short exact sequences factors (uniquely) through [abses_pushout E f1]. *) Definition abses_pushout_morphism_rec `{Univalence} {A B X Y : AbGroup} {E : AbSES B A} {F : AbSES Y X} (f : AbSESMorphism E F) : AbSESMorphism (abses_pushout (component1 f) E) F. Proof. snrapply (Build_AbSESMorphism grp_homo_id _ (component3 f)). - rapply ab_pushout_rec. apply left_square. - intro x; simpl. rewrite grp_homo_unit. exact (right_identity _)^. - snrapply (issurj_isepi_funext grp_quotient_map). 1: apply issurj_class_of. 2: exact _. intro x; simpl. nrapply grp_homo_op_agree. + refine (_ @ (grp_homo_unit _)^). apply iscomplex_abses. + apply right_square. Defined. (** The original map factors via the induced map. *) Definition abses_pushout_morphism_rec_beta `{Univalence} (A B X Y : AbGroup) (E : AbSES B A) (F : AbSES Y X) (f : AbSESMorphism E F) : f = absesmorphism_compose (abses_pushout_morphism_rec f) (abses_pushout_morphism E (component1 f)). Proof. apply (equiv_ap issig_AbSESMorphism^-1 _ _). srapply path_sigma_hprop. 1: apply path_prod. 1: apply path_prod. all: apply equiv_path_grouphomomorphism; intro x; simpl. 1,3: reflexivity. rewrite grp_homo_unit. exact (left_identity _)^. Defined. (** Given [E : AbSES B A'] and [F : AbSES B A] and a morphism [f : E -> F], the pushout of [E] along [f_1] is [F] if [f_3] is homotopic to [id_B]. *) Lemma abses_pushout_component3_id' `{Univalence} {A A' B : AbGroup} {E : AbSES B A'} {F : AbSES B A} (f : AbSESMorphism E F) (h : component3 f == grp_homo_id) : abses_pushout (component1 f) E $== F. Proof. pose (g := abses_pushout_morphism_rec f). nrapply abses_path_data_to_iso. exists (component2 g); split. + intro x. exact (left_square g _)^. + intro x. exact ((right_square g _) @ h _)^. Defined. (** A version with equality instead of path data. *) Definition abses_pushout_component3_id `{Univalence} {A A' B : AbGroup} {E : AbSES B A'} {F : AbSES B A} (f : AbSESMorphism E F) (h : component3 f == grp_homo_id) : abses_pushout (component1 f) E = F := equiv_path_abses_iso (abses_pushout_component3_id' f h). (** Given short exact sequences [E] and [F] and homomorphisms [f : A' $-> A] and [g : D' $-> D], there is a morphism [E + F -> fE + gF] induced by the universal properties of the pushouts of [E] and [F]. *) Definition abses_directsum_pushout_morphism `{Univalence} {A A' B C D D' : AbGroup} {E : AbSES B A'} {F : AbSES C D'} (f : A' $-> A) (g : D' $-> D) : AbSESMorphism (abses_direct_sum E F) (abses_direct_sum (abses_pushout f E) (abses_pushout g F)) := functor_abses_directsum (abses_pushout_morphism E f) (abses_pushout_morphism F g). (** For [E, F : AbSES B A'] and [f, g : A' $-> A], we have (f+g)(E+F) = fE + gF, where + denotes the direct sum. *) Definition abses_directsum_distributive_pushouts `{Univalence} {A A' B C C' D : AbGroup} {E : AbSES B A'} {F : AbSES D C'} (f : A' $-> A) (g : C' $-> C) : abses_pushout (functor_ab_biprod f g) (abses_direct_sum E F) = abses_direct_sum (abses_pushout f E) (abses_pushout g F) := abses_pushout_component3_id (abses_directsum_pushout_morphism f g) (fun _ => idpath). (** Given an AbSESMorphism whose third component is the identity, we know that it induces a path from the pushout of the domain along the first map to the codomain. Conversely, given a path from a pushout, we can deduce that the following square commutes: *) Definition abses_path_pushout_inclusion_commsq `{Univalence} {A A' B : AbGroup} (alpha : A $-> A') (E : AbSES B A) (F : AbSES B A') (p : abses_pushout alpha E = F) : exists phi : middle E $-> F, inclusion F o alpha == phi o inclusion E. Proof. induction p. exists ab_pushout_inr; intro x. nrapply ab_pushout_commsq. Defined. (** ** Functoriality of [abses_pushout f : AbSES B A -> AbSES B A'] *) (** In this file we will prove various "levels" of functoriality of pushing out. Here we show that the induced map between [AbSES B A] respect the groupoid structure of [is1gpd_abses] from AbSES.Core. *) Global Instance is0functor_abses_pushout `{Univalence} {A A' B : AbGroup} (f : A $-> A') : Is0Functor (abses_pushout (B:=B) f). Proof. srapply Build_Is0Functor; intros E F p. srapply abses_path_data_to_iso. srefine (functor_ab_pushout f f (inclusion _) (inclusion _) grp_homo_id grp_homo_id p.1 _ _; (_, _)). - reflexivity. - symmetry; exact (fst p.2). - nrapply ab_pushout_rec_beta_left. - srapply Quotient_ind_hprop. intro x; simpl. apply grp_cancelL. refine (snd p.2 (snd x) @ ap (projection F) _). exact (left_identity _)^. Defined. Global Instance is1functor_abses_pushout `{Univalence} {A A' B : AbGroup} (f : A $-> A') : Is1Functor (abses_pushout (B:=B) f). Proof. srapply Build_Is1Functor. - intros E F g0 g1 h. rapply Quotient_ind_hprop; intros [a' e]; simpl. by rewrite (h e). - intro E. rapply Quotient_ind_hprop; intros [a' e]; simpl. refine (ap (class_of _) (path_prod' _ _)). + exact (grp_unit_r _). + exact (grp_unit_l _). - intros E F G g0 g1. rapply Quotient_ind_hprop; intros [a' e]; simpl. refine (ap (class_of _) (path_prod' _ _)). + exact (grp_unit_r _)^. + exact (ap (fun x => _ + g1.1 x) (grp_unit_l _)^). Defined. Definition abses_pushout_path_data_1 `{Univalence} {A A' B : AbGroup} (f : A $-> A') {E : AbSES B A} : fmap (abses_pushout f) (Id E) = Id (abses_pushout f E). Proof. srapply path_sigma_hprop. apply equiv_path_groupisomorphism. srapply Quotient_ind_hprop. intros [a' e]; simpl. (* This is true even on the representatives. *) apply qglue. refine (tr (0; _)). apply path_prod'; cbn. - refine (ap _ (grp_homo_unit _) @ _). refine (grp_inv_unit @ _). apply grp_moveL_Vg. exact (right_identity _ @ right_identity _). - refine (grp_homo_unit _ @ _). apply grp_moveL_Vg. exact (right_identity _ @ left_identity _). Defined. Definition ap_abses_pushout `{Univalence} {A A' B : AbGroup} (f : A $-> A') {E F : AbSES B A} (p : E = F) : ap (abses_pushout f) p = equiv_path_abses_iso (fmap (abses_pushout f) (equiv_path_abses_iso^-1 p)). Proof. induction p. refine (_ @ ap _ _). 2: refine ((abses_pushout_path_data_1 f)^ @ ap _ equiv_path_absesV_1^). exact equiv_path_abses_1^. Defined. Definition ap_abses_pushout_data `{Univalence} {A A' B : AbGroup} (f : A $-> A') {E F : AbSES B A} (p : E $== F) : ap (abses_pushout f) (equiv_path_abses_iso p) = equiv_path_abses_iso (fmap (abses_pushout f) p). Proof. refine (ap_abses_pushout _ _ @ _). apply (ap (equiv_path_abses_iso o _)). apply eissect. Defined. Definition abses_pushout_point' `{Univalence} {A A' B : AbGroup} (f : A $-> A') : abses_pushout f (point (AbSES B A)) $== pt. Proof. srapply abses_path_data_to_iso; srefine (_; (_,_)). - snrefine (ab_pushout_rec ab_biprod_inl _ _). + exact (functor_ab_biprod f grp_homo_id). + reflexivity. - intro a'. apply path_prod. + simpl. exact (ap _ (grp_homo_unit f) @ right_identity _). + simpl. exact (right_identity _). - srapply Quotient_ind_hprop. reflexivity. Defined. Definition abses_pushout_point `{Univalence} {A A' B : AbGroup} (f : A $-> A') : abses_pushout f (point (AbSES B A)) = pt := equiv_path_abses_iso (abses_pushout_point' f). Definition abses_pushout' `{Univalence} {A A' B : AbGroup} (f : A $-> A') : AbSES B A -->* AbSES B A' := Build_BasepointPreservingFunctor (abses_pushout f) (abses_pushout_point' f). Definition abses_pushout_pmap `{Univalence} {A A' B : AbGroup} (f : A $-> A') : AbSES B A ->* AbSES B A' := to_pointed (abses_pushout' f). (** The following general lemma lets us show that [abses_pushout f E] is trivial in cases of interest. It says that if you have a map [phi : E -> A'], then if you push out along the restriction [phi $o inclusion E], the result is trivial. Specifically, we get a morphism witnessing this fact. *) Definition abses_pushout_trivial_morphism {B A A' : AbGroup} (E : AbSES B A) (f : A $-> A') (phi : middle E $-> A') (k : f == phi $o inclusion E) : AbSESMorphism E (pt : AbSES B A'). Proof. srapply (Build_AbSESMorphism f _ grp_homo_id). 1: exact (ab_biprod_corec phi (projection E)). { intro a; cbn. refine (path_prod' (k a) _^). apply isexact_inclusion_projection. } reflexivity. Defined. (** The pushout of a short exact sequence along its inclusion map is trivial. *) Definition abses_pushout_inclusion_morphism {B A : AbGroup} (E : AbSES B A) : AbSESMorphism E (pt : AbSES B E) := abses_pushout_trivial_morphism E (inclusion E) grp_homo_id (fun _ => idpath). Definition abses_pushout_inclusion `{Univalence} {B A : AbGroup} (E : AbSES B A) : abses_pushout (inclusion E) E = pt := abses_pushout_component3_id (abses_pushout_inclusion_morphism E) (fun _ => idpath). (** Pushing out along [grp_homo_const] is trivial. *) Definition abses_pushout_const_morphism {B A A' : AbGroup} (E : AbSES B A) : AbSESMorphism E (pt : AbSES B A') := abses_pushout_trivial_morphism E grp_homo_const grp_homo_const (fun _ => idpath). Definition abses_pushout_const `{Univalence} {B A A' : AbGroup} (E : AbSES B A) : abses_pushout grp_homo_const E = pt :> AbSES B A' := abses_pushout_component3_id (abses_pushout_const_morphism E) (fun _ => idpath). (** Pushing out a fixed extension, with the map variable. This is the connecting map in the contravariant six-term exact sequence (see SixTerm.v). *) Definition abses_pushout_abses `{Univalence} {B A G : AbGroup} (E : AbSES B A) : ab_hom A G ->* AbSES B G. Proof. srapply Build_pMap. 1: exact (fun g => abses_pushout g E). apply abses_pushout_const. Defined. (** ** Functoriality of pushing out *) (** For every [E : AbSES B A], the pushout of [E] along [id_A] is [E]. *) Definition abses_pushout_id `{Univalence} {A B : AbGroup} : abses_pushout (B:=B) (@grp_homo_id A) == idmap := fun E => abses_pushout_component3_id (abses_morphism_id E) (fun _ => idpath). Definition abses_pushout_pmap_id `{Univalence} {A B : AbGroup} : abses_pushout_pmap (B:=B) (@grp_homo_id A) ==* @pmap_idmap (AbSES B A). Proof. srapply Build_pHomotopy. 1: apply abses_pushout_id. refine (_ @ (concat_p1 _)^). (* For some reason Coq spends time finding [x] below, so we specify it. *) nrapply (ap equiv_path_abses_iso (x:=abses_pushout_component3_id' (abses_morphism_id pt) _)). apply path_sigma_hprop. apply equiv_path_groupisomorphism. by rapply Quotient_ind_hprop. Defined. (** Pushing out along homotopic maps induces homotopic pushout functors. This statement has a short proof by path induction on the homotopy [h], but we prefer to construct a path using [abses_path_data_iso] with better computational properties. *) Lemma abses_pushout_homotopic' `{Univalence} {A A' B : AbGroup} (f f' : A $-> A') (h : f == f') : abses_pushout (B:=B) f $=> abses_pushout f'. Proof. intro E; cbn. apply abses_path_data_to_iso. snrefine (_; (_, _)). - srapply (ab_pushout_rec (inclusion _)). 1: apply ab_pushout_inr. intro x. refine (ap _ (h x) @ _). apply (ab_pushout_commsq x). - apply ab_pushout_rec_beta_left. - rapply Quotient_ind_hprop; intros [a' e]; simpl. exact (ap (fun x => _ + projection E x) (grp_unit_l _)^). Defined. Definition abses_pushout_homotopic `{Univalence} {A A' B : AbGroup} (f f' : A $-> A') (h : f == f') : abses_pushout (B:=B) f == abses_pushout f' := equiv_path_data_homotopy _ _ (abses_pushout_homotopic' _ _ h). Definition abses_pushout_phomotopic' `{Univalence} {A A' B : AbGroup} (f f' : A $-> A') (h : f == f') : abses_pushout' (B:=B) f $=>* abses_pushout' f'. Proof. exists (abses_pushout_homotopic' _ _ h). apply gpd_moveL_Vh. rapply Quotient_ind_hprop; intros [a' [a b]]; simpl. apply path_prod'. - by rewrite grp_unit_l, grp_unit_r, (h a). - apply grp_unit_l. Defined. Definition abses_pushout_phomotopic `{Univalence} {A A' B : AbGroup} (f f' : A $-> A') (h : f == f') : abses_pushout_pmap (B:=B) f ==* abses_pushout_pmap f' := equiv_ptransformation_phomotopy (abses_pushout_phomotopic' f f' h). Definition abses_pushout_compose' `{Univalence} {A0 A1 A2 B : AbGroup} (f : A0 $-> A1) (g : A1 $-> A2) : abses_pushout (g $o f) $=> abses_pushout (B:=B) g o abses_pushout f. Proof. intro E. srapply abses_path_data_to_iso; srefine (_; (_,_)). - snrapply ab_pushout_rec. + apply inclusion. + exact (component2 (abses_pushout_morphism _ g) $o component2 (abses_pushout_morphism _ f)). + intro a0. refine (left_square (abses_pushout_morphism _ g) _ @ _). exact (ap (component2 (abses_pushout_morphism (abses_pushout f E) g)) (left_square (abses_pushout_morphism _ f) a0)). - apply ab_pushout_rec_beta_left. - srapply Quotient_ind_hprop. intro x; simpl. apply grp_cancelL; symmetry. exact (left_identity _ @ ap (projection E) (left_identity _)). Defined. Definition abses_pushout_compose `{Univalence} {A0 A1 A2 B : AbGroup} (f : A0 $-> A1) (g : A1 $-> A2) : abses_pushout (g $o f) == abses_pushout (B:=B) g o abses_pushout f := equiv_path_data_homotopy _ _ (abses_pushout_compose' f g). Definition abses_pushout_pcompose' `{Univalence} {A0 A1 A2 B : AbGroup} (f : A0 $-> A1) (g : A1 $-> A2) : abses_pushout' (B:=B) (g $o f) $=>* abses_pushout' g $o* abses_pushout' f. Proof. exists (abses_pushout_compose' f g). apply gpd_moveL_Vh. (* it's easiest to construct a path in [pt] *) rapply Quotient_ind_hprop; intros [a2 [a0 b]]; simpl. by rewrite 7 grp_unit_l, 2 grp_unit_r. Defined. Definition abses_pushout_pcompose `{Univalence} {A0 A1 A2 B : AbGroup} (f : A0 $-> A1) (g : A1 $-> A2) : abses_pushout_pmap (B:=B) (g $o f) ==* abses_pushout_pmap g o* abses_pushout_pmap f. Proof. refine (_ @* (to_pointed_compose _ _)^*). apply equiv_ptransformation_phomotopy. apply abses_pushout_pcompose'. Defined. (** [AbSES B : AbGroup -> pType] and [AbSES' B : AbGroup -> Type] are covariant functors, for any [B]. *) Global Instance is0functor_abses'01 `{Univalence} {B : AbGroup^op} : Is0Functor (AbSES' B). Proof. apply Build_Is0Functor. exact (fun _ _ g => abses_pushout g). Defined. Global Instance is1functor_abses'01 `{Univalence} {B : AbGroup^op} : Is1Functor (AbSES' B). Proof. apply Build_Is1Functor; intros; cbn. - by apply abses_pushout_homotopic. - apply abses_pushout_id. - apply abses_pushout_compose. Defined. Global Instance is0functor_abses01 `{Univalence} {B : AbGroup^op} : Is0Functor (AbSES B). Proof. apply Build_Is0Functor. exact (fun _ _ g => abses_pushout_pmap g). Defined. Global Instance is1functor_abses01 `{Univalence} {B : AbGroup^op} : Is1Functor (AbSES B). Proof. apply Build_Is1Functor; intros; cbn. - by apply abses_pushout_phomotopic. - apply abses_pushout_pmap_id. - apply abses_pushout_pcompose. Defined. Coq-HoTT-9.0/theories/Algebra/AbSES/SixTerm.v000066400000000000000000000252171474641544500206030ustar00rootroot00000000000000Require Import Basics Types WildCat HSet Pointed.Core Pointed.pTrunc Pointed.pEquiv Modalities.ReflectiveSubuniverse Truncations.Core Truncations.SeparatedTrunc AbGroups Homotopy.ExactSequence Spaces.Int Spaces.FreeInt AbSES.Core AbSES.Pullback AbSES.Pushout BaerSum Ext PullbackFiberSequence. (** * The contravariant six-term sequence of Ext *) (** We construct the contravariant six-term exact sequence of Ext groups associated to any short exact sequence [A -> E -> B] and coefficient group [G]. The existence of this exact sequence follows from the final result in [PullbackFiberSequence]. However, with that definition it becomes a bit tricky to show that the connecting map is given by pushing out [E]. Instead, we give a direct proof. As an application, we use the six-term exact sequence to show that [Ext Z/n A] is isomorphic to [A/n], for nonzero natural numbers [n]. (See [ext_cyclic_ab].) *) (** Exactness of [0 -> ab_hom B G -> ab_hom E G] follows from the rightmost map being an embedding. *) Definition isexact_abses_sixterm_i `{Funext} {B A G : AbGroup} (E : AbSES B A) : IsExact (Tr (-1)) (pconst : pUnit ->* ab_hom B G) (fmap10 (A:=Group^op) ab_hom (projection E) G). Proof. apply isexact_purely_O. rapply isexact_homotopic_i. 2: apply iff_grp_isexact_isembedding. 1: by apply phomotopy_homotopy_hset. exact _. (* [isembedding_precompose_surjection_ab] *) Defined. (** Exactness of [ab_hom B G -> ab_hom E G -> ab_hom A G]. One can also deduce this from [isexact_abses_pullback]. *) Definition isexact_ext_contra_sixterm_ii `{Funext} {B A G : AbGroup} (E : AbSES B A) : IsExact (Tr (-1)) (fmap10 (A:=Group^op) ab_hom (projection E) G) (fmap10 (A:=Group^op) ab_hom (inclusion E) G). Proof. snrapply Build_IsExact. { apply phomotopy_homotopy_hset; intro f. apply equiv_path_grouphomomorphism; intro b; cbn. refine (ap f _ @ grp_homo_unit f). apply isexact_inclusion_projection. } hnf. intros [f q]; rapply contr_inhabited_hprop. srefine (tr (_; _)). { refine (grp_homo_compose _ (abses_cokernel_iso (inclusion E) (projection E))^-1$). apply (quotient_abgroup_rec _ _ f). intros e; rapply Trunc_ind. intros [b r]. refine (ap f r^ @ _). exact (equiv_path_grouphomomorphism^-1 q _). } lazy beta. apply path_sigma_hprop. apply equiv_path_grouphomomorphism; unfold pr1. intro x. exact (ap (quotient_abgroup_rec _ _ f _) (abses_cokernel_iso_inv_beta _ _ _)). Defined. (** *** Exactness of [ab_hom E G -> ab_hom A G -> Ext B G] *) (** If a pushout [abses_pushout alpha E] is trivial, then [alpha] factors through [inclusion E]. *) Lemma abses_pushout_trivial_factors_inclusion `{Univalence} {B A A' : AbGroup} (alpha : A $-> A') (E : AbSES B A) : abses_pushout alpha E = pt -> exists phi, alpha = phi $o inclusion E. Proof. equiv_intros (equiv_path_abses (E:=abses_pushout alpha E) (F:=pt)) p. destruct p as [phi [p q]]. exists (ab_biprod_pr1 $o phi $o ab_pushout_inr). apply equiv_path_grouphomomorphism; intro a. (* We embed into the biproduct and prove equality there. *) apply (isinj_embedding (@ab_biprod_inl A' B) _). refine ((p (alpha a))^ @ _). refine (ap phi _ @ _). 1: exact (left_square (abses_pushout_morphism E alpha) a). apply (path_prod' idpath). refine ((q _)^ @ _). refine (right_square (abses_pushout_morphism E alpha) _ @ _); cbn. apply isexact_inclusion_projection. Defined. Global Instance isexact_ext_contra_sixterm_iii@{u v +} `{Univalence} {B A G : AbGroup@{u}} (E : AbSES@{u v} B A) : IsExact (Tr (-1)) (fmap10 (A:=Group^op) ab_hom (inclusion E) G) (abses_pushout_ext E). Proof. snrapply Build_IsExact. - apply phomotopy_homotopy_hset; intro g; cbn. (* this equation holds purely *) apply (ap tr@{v}). refine (abses_pushout_compose _ _ _ @ ap _ _ @ _). 1: apply abses_pushout_inclusion. apply abses_pushout_point. - intros [F p]. (* since we are proving a proposition, we may convert [p] to an actual path *) pose proof (p' := (equiv_path_Tr _ _)^-1 p). (* slightly faster than [strip_truncations]: *) revert p'; apply Trunc_rec; intro p'. rapply contr_inhabited_hprop; apply tr. (* now we construct a preimage *) pose (g := abses_pushout_trivial_factors_inclusion _ E p'); destruct g as [g k]. exists g. apply path_sigma_hprop; cbn. exact k^. Defined. (** *** Exactness of [ab_hom A G -> Ext1 B G -> Ext1 E G]. *) (** We construct a morphism which witnesses exactness. *) Definition isexact_ext_contra_sixterm_iv_mor `{Univalence} {B A G : AbGroup} (E : AbSES B A) (F : AbSES B G) (p : abses_pullback (projection E) F = pt) : AbSESMorphism E F. Proof. pose (p' := equiv_path_abses^-1 p^); destruct p' as [p' [pl pr]]. srefine (Build_AbSESMorphism _ _ grp_homo_id _ _). - refine (grp_homo_compose (grp_iso_inverse (abses_kernel_iso (inclusion F) (projection F))) _). (* now it's easy to construct map into the kernel *) snrapply grp_kernel_corec. 1: exact (grp_pullback_pr1 _ _ $o p' $o ab_biprod_inr $o inclusion E). intro x. refine (right_square (abses_pullback_morphism F _) _ @ _). refine (ap (projection E) (pr _)^ @ _); cbn. apply isexact_inclusion_projection. - exact (grp_pullback_pr1 _ _ $o p' $o ab_biprod_inr). - intro a. nrapply abses_kernel_iso_inv_beta. - intro e. refine (right_square (abses_pullback_morphism F _) _ @ ap (projection E) _). exact (pr _)^. Defined. Global Instance isexact_ext_contra_sixterm_iv `{Univalence} {B A G : AbGroup@{u}} (E : AbSES@{u v} B A) : IsExact (Tr (-1)) (abses_pushout_ext E) (fmap (pTr 0) (abses_pullback_pmap (A:=G) (projection E))). Proof. snrapply Build_IsExact. - apply phomotopy_homotopy_hset; intro g; cbn. (* this equation holds purely *) apply (ap tr@{v}). refine ((abses_pushout_pullback_reorder _ _ _)^ @ ap _ _ @ _). 1: exact (abses_pullback_projection _)^. apply abses_pushout_point. (* since we are proving a proposition, we may convert [p] to an actual path *) - intros [F p]. revert dependent F; nrapply (Trunc_ind (n:=0) (A:=AbSES B G)). (* [exact _.] works here, but is slow. *) { intro x; nrapply istrunc_forall. intro y; rapply (istrunc_leq (trunc_index_leq_succ _)). } intro F. equiv_intros (equiv_path_Tr (n:=-1) (abses_pullback (projection E) F) pt) p. strip_truncations. rapply contr_inhabited_hprop; apply tr. pose (g := isexact_ext_contra_sixterm_iv_mor E F p). exists (component1 g). apply path_sigma_hprop, (ap tr). by rapply (abses_pushout_component3_id g). Defined. (** *** Exactness of [Ext B G -> Ext E G -> Ext A G] *) (** This is an immediate consequence of [isexact_abses_pullback]. *) Global Instance isexact_ext_contra_sixterm_v `{Univalence} {B A G : AbGroup} (E : AbSES B A) : IsExact (Tr (-1)) (fmap (pTr 0) (abses_pullback_pmap (A:=G) (projection E))) (fmap (pTr 0) (abses_pullback_pmap (A:=G) (inclusion E))). Proof. rapply isexact_ptr. rapply isexact_purely_O. Defined. (** *** [Ext Z/n A] is isomorphic to [A/n] *) (** An easy consequence of the contravariant six-term exact sequence is that [Ext Z/n A] is isomorphic to the cokernel of the multiplication-by-n endomorphism [A -> A], for any abelian group [A]. This falls out of the six-term exact sequence associated to [Z -> Z -> Z/n] and projectivity of [Z]. A minor point is that the library does not currently contain a proof that multiplication by a nonzero natural number is a self-injection of [Z]. Thus we work directly with the assumption that [Z1_mul_nat n] is an embedding. *) (** We define our own cyclic groups using [ab_cokernel_embedding] under the assumption that [Z1_mul_nat n] is an embedding. *) Definition cyclic' `{Funext} (n : nat) `{IsEmbedding (Z1_mul_nat n)} : AbGroup := ab_cokernel_embedding (Z1_mul_nat n). (** We first show that [ab_hom Z A -> ab_hom Z A -> Ext (cyclic n) A] is exact. We could inline the proof below, but factoring it out is faster. *) Local Definition isexact_ext_cyclic_ab_iii@{u v w | u < v, v < w} `{Univalence} (n : nat) `{IsEmbedding (Z1_mul_nat n)} {A : AbGroup@{u}} : IsExact (Tr (-1)) (fmap10 (A:=Group^op) ab_hom (Z1_mul_nat n) A) (abses_pushout_ext (abses_from_inclusion (Z1_mul_nat n))) := isexact_ext_contra_sixterm_iii (abses_from_inclusion (Z1_mul_nat n)). (** We show exactness of [A -> A -> Ext Z/n A] where the first map is multiplication by [n], but considered in universe [v]. *) Local Definition ext_cyclic_exact@{u v w} `{Univalence} (n : nat) `{IsEmbedding (Z1_mul_nat n)} {A : AbGroup@{u}} : IsExact@{v v v v v} (Tr (-1)) (ab_mul (A:=A) n) (abses_pushout_ext@{u w v} (abses_from_inclusion (Z1_mul_nat n)) o* (pequiv_groupisomorphism (equiv_Z1_hom A))^-1*). Proof. (* we first move [equiv_Z1_hom] across the total space *) apply moveL_isexact_equiv. (* now we change the left map so as to apply exactness at iii from above *) snrapply (isexact_homotopic_i (Tr (-1))). 1: exact (fmap10 (A:=Group^op) ab_hom (Z1_mul_nat n) A o* (pequiv_inverse (pequiv_groupisomorphism (equiv_Z1_hom A)))). - apply phomotopy_homotopy_hset. rapply (equiv_ind (equiv_Z1_hom A)); intro f. refine (_ @ ap _ (eissect _ _)^). apply moveR_equiv_V; symmetry. refine (ap f _ @ _). 1: apply Z1_rec_beta. exact (ab_mul_natural f n Z1_gen). - (* we get rid of [equiv_Z1_hom] *) apply isexact_equiv_fiber. apply isexact_ext_cyclic_ab_iii. Defined. (** The main result of this section. *) Theorem ext_cyclic_ab@{u v w | u < v, v < w} `{Univalence} (n : nat) `{emb : IsEmbedding (Z1_mul_nat n)} {A : AbGroup@{u}} : ab_cokernel@{v w} (ab_mul (A:=A) n) $<~> ab_ext@{u v} (cyclic'@{u v} n) A. (* We take a large cokernel in order to apply [abses_cokernel_iso]. *) Proof. pose (E := abses_from_inclusion (Z1_mul_nat n)). snrefine (abses_cokernel_iso (ab_mul n) _). - exact (grp_homo_compose (abses_pushout_ext E) (grp_iso_inverse (equiv_Z1_hom A))). - apply (conn_map_compose _ (grp_iso_inverse (equiv_Z1_hom A))). 1: rapply conn_map_isequiv. (* Coq knows that [Ext Z1 A] is contractible since [Z1] is projective, so exactness at spot iv gives us this: *) exact (isconnmap_O_isexact_base_contr _ _ (fmap (pTr 0) (abses_pullback_pmap (A:=A) (projection E)))). - (* we change [grp_homo_compose] to [o*] *) srapply isexact_homotopic_f. 1: exact (abses_pushout_ext (abses_from_inclusion (Z1_mul_nat n)) o* (pequiv_groupisomorphism (equiv_Z1_hom A))^-1*). 1: by apply phomotopy_homotopy_hset. apply ext_cyclic_exact. Defined. Coq-HoTT-9.0/theories/Algebra/Aut.v000066400000000000000000000005351474641544500170400ustar00rootroot00000000000000Require Import Basics. Require Import Truncations. Require Import Algebra.ooGroup. Require Import Universes.BAut. Require Import Pointed.Core. Local Open Scope pointed_scope. (** * Automorphism oo-Groups *) (** We define [Aut X] using the pointed, connected type [BAut X]. *) Definition Aut (X : Type) : ooGroup := Build_ooGroup [BAut X, _] _. Coq-HoTT-9.0/theories/Algebra/Categorical/000077500000000000000000000000001474641544500203325ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/Categorical/MonoidObject.v000066400000000000000000000302331474641544500230760ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core WildCat.Equiv WildCat.Monoidal WildCat.Bifunctor WildCat.NatTrans WildCat.Opposite WildCat.Products. Require Import abstract_algebra. (** * Monoids and Comonoids *) (** Here we define a monoid internal to a monoidal category. Note that we don't actually need the full monoidal structure so we assume only the parts we need. This allows us to keep the definitions general between various flavours of monoidal category. Many algebraic theories such as groups and rings may also be internalized, however these specifically require a cartesian monoidal structure. The theory of monoids however has no such requirement and can therefore be developed in much greater generality. This can be used to define a range of objects such as R-algebras, H-spaces, Hopf algebras and more. *) (** * Monoid objects *) Section MonoidObject. Context {A : Type} {tensor : A -> A -> A} {unit : A} `{HasEquivs A, !Is0Bifunctor tensor, !Is1Bifunctor tensor} `{!Associator tensor, !LeftUnitor tensor unit, !RightUnitor tensor unit}. (** An object [x] of [A] is a monoid object if it comes with the following data: *) Class IsMonoidObject (x : A) := { (** A multiplication map from the tensor product of [x] with itself to [x]. *) mo_mult : tensor x x $-> x; (** A unit of the multplication. *) mo_unit : unit $-> x; (** The multiplication map is associative. *) mo_assoc : mo_mult $o fmap10 tensor mo_mult x $o associator x x x $== mo_mult $o fmap01 tensor x mo_mult; (** The multiplication map is left unital. *) mo_left_unit : mo_mult $o fmap10 tensor mo_unit x $== left_unitor x; (** The multiplication map is right unital. *) mo_right_unit : mo_mult $o fmap01 tensor x mo_unit $== right_unitor x; }. Context `{!Braiding tensor}. (** An object [x] of [A] is a commutative monoid object if: *) Class IsCommutativeMonoidObject (x : A) := { (** It is a monoid object. *) cmo_mo :: IsMonoidObject x; (** The multiplication map is commutative. *) cmo_comm : mo_mult $o braid x x $== mo_mult; }. End MonoidObject. Arguments IsMonoidObject {A} tensor unit {_ _ _ _ _ _ _ _ _ _} x. Arguments IsCommutativeMonoidObject {A} tensor unit {_ _ _ _ _ _ _ _ _ _ _} x. Section ComonoidObject. Context {A : Type} (tensor : A -> A -> A) (unit : A) `{HasEquivs A, !Is0Bifunctor tensor, !Is1Bifunctor tensor} `{!Associator tensor, !LeftUnitor tensor unit, !RightUnitor tensor unit}. (** A comonoid object is a monoid object in the opposite category. *) Class IsComonoidObject (x : A) := ismonoid_comonoid_op :: IsMonoidObject (A:=A^op) tensor unit x. (** We can build comonoid objects from the following data: *) Definition Build_IsComonoidObject (x : A) (** A comultplication map. *) (co_comult : x $-> tensor x x) (** A counit. *) (co_counit : x $-> unit) (** The comultiplication is coassociative. *) (co_coassoc : associator x x x $o fmap01 tensor x co_comult $o co_comult $== fmap10 tensor co_comult x $o co_comult) (** The comultiplication is left counital. *) (co_left_counit : left_unitor x $o fmap10 tensor co_counit x $o co_comult $== Id x) (** The comultiplication is right counital. *) (co_right_counit : right_unitor x $o fmap01 tensor x co_counit $o co_comult $== Id x) : IsComonoidObject x. Proof. snrapply Build_IsMonoidObject. - exact co_comult. - exact co_counit. - nrapply cate_moveR_eV. symmetry. nrefine (cat_assoc _ _ _ $@ _). rapply co_coassoc. - simpl; nrefine (_ $@ cat_idr _). nrapply cate_moveL_Ve. nrefine (cat_assoc_opp _ _ _ $@ _). exact co_left_counit. - simpl; nrefine (_ $@ cat_idr _). nrapply cate_moveL_Ve. nrefine (cat_assoc_opp _ _ _ $@ _). exact co_right_counit. Defined. (** Comultiplication *) Definition co_comult {x : A} `{!IsComonoidObject x} : x $-> tensor x x := mo_mult (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x). (** Counit *) Definition co_counit {x : A} `{!IsComonoidObject x} : x $-> unit := mo_unit (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x). (** Coassociativity *) Definition co_coassoc {x : A} `{!IsComonoidObject x} : associator x x x $o fmap01 tensor x co_comult $o co_comult $== fmap10 tensor co_comult x $o co_comult. Proof. refine (cat_assoc _ _ _ $@ _). apply cate_moveR_Me. symmetry. exact (mo_assoc (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x)). Defined. (** Left counitality *) Definition co_left_counit {x : A} `{!IsComonoidObject x} : left_unitor x $o fmap10 tensor co_counit x $o co_comult $== Id x. Proof. refine (cat_assoc _ _ _ $@ _). apply cate_moveR_Me. refine (_ $@ (cat_idr _)^$). exact (mo_left_unit (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x)). Defined. (** Right counitality *) Definition co_right_counit {x : A} `{!IsComonoidObject x} : right_unitor x $o fmap01 tensor x co_counit $o co_comult $== Id x. Proof. refine (cat_assoc _ _ _ $@ _). apply cate_moveR_Me. refine (_ $@ (cat_idr _)^$). exact (mo_right_unit (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x)). Defined. Context `{!Braiding tensor}. (** A cocommutative comonoid objects is a commutative monoid object in the opposite category. *) Class IsCocommutativeComonoidObject (x : A) := iscommuatativemonoid_cocomutativemonoid_op :: IsCommutativeMonoidObject (A:=A^op) tensor unit x. (** We can build cocommutative comonoid objects from the following data: *) Definition Build_IsCocommutativeComonoidObject (x : A) (** A comonoid. *) `{!IsComonoidObject x} (** Together with a proof of cocommutativity. *) (cco_cocomm : braid x x $o co_comult $== co_comult) : IsCocommutativeComonoidObject x. Proof. snrapply Build_IsCommutativeMonoidObject. - exact _. - exact cco_cocomm. Defined. Global Instance co_cco {x : A} `{!IsCocommutativeComonoidObject x} : IsComonoidObject x. Proof. apply cmo_mo. Defined. (** Cocommutativity *) Definition cco_cocomm {x : A} `{!IsCocommutativeComonoidObject x} : braid x x $o co_comult $== co_comult. Proof. exact (cmo_comm (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x)). Defined. End ComonoidObject. (** A comonoid object in [A^op] is a monoid object in [A]. *) Definition mo_co_op {A : Type} {tensor : A -> A -> A} {unit : A} `{HasEquivs A, !Is0Bifunctor tensor, !Is1Bifunctor tensor} `{!Associator tensor, !LeftUnitor tensor unit, !RightUnitor tensor unit} {x : A} `{C : !IsComonoidObject (A:=A^op) tensor unit x} : IsMonoidObject tensor unit x. Proof. snrapply Build_IsMonoidObject. - exact (co_comult (A:=A^op) tensor unit). - exact (co_counit (A:=A^op) tensor unit). - apply cate_moveR_eM. symmetry. exact (cat_assoc _ _ _ $@ co_coassoc (A:=A^op) tensor unit (x:=x)). - simpl; nrefine (_ $@ cat_idl _). apply cate_moveL_eM. refine (cat_assoc _ _ _ $@ _). exact (co_left_counit (A:=A^op) tensor unit (x:=x)). - simpl; nrefine (_ $@ cat_idl _). apply cate_moveL_eM. refine (cat_assoc _ _ _ $@ _). exact (co_right_counit (A:=A^op) tensor unit (x:=x)). Defined. (** A cocommutative cocomonoid object in [A^op] is a commutative monoid object in [A]. *) Definition cmo_coco_op {A : Type} {tensor : A -> A -> A} {unit : A} `{HasEquivs A, !Is0Bifunctor tensor, !Is1Bifunctor tensor} `{!Associator tensor, !LeftUnitor tensor unit, !RightUnitor tensor unit, !Braiding tensor} {x : A} `{C : !IsCocommutativeComonoidObject (A:=A^op) tensor unit x} : IsCommutativeMonoidObject tensor unit x. Proof. snrapply Build_IsCommutativeMonoidObject. - nrapply mo_co_op. rapply co_cco. - exact (cco_cocomm (A:=A^op) tensor unit). Defined. (** ** Monoid enrichment *) (** A hom [x $-> y] in a cartesian category where [y] is a monoid object has the structure of a monoid. Equivalently, a hom [x $-> y] in a cartesian category where [x] is a comonoid object has the structure of a monoid. *) Section MonoidEnriched. Context {A : Type} `{HasEquivs A} `{!HasBinaryProducts A} (unit : A) `{!IsTerminal unit} {x y : A} `{!HasMorExt A} `{forall x y, IsHSet (x $-> y)}. Section Monoid. Context `{!IsMonoidObject _ _ y}. Local Instance sgop_hom : SgOp (x $-> y) := fun f g => mo_mult $o cat_binprod_corec f g. Local Instance monunit_hom : MonUnit (x $-> y) := mo_unit $o mor_terminal _ _. Local Instance associative_hom : Associative sgop_hom. Proof. intros f g h. unfold sgop_hom. rapply path_hom. refine ((_ $@L cat_binprod_fmap01_corec _ _ _)^$ $@ _). nrefine (cat_assoc_opp _ _ _ $@ _). refine ((mo_assoc $@R _)^$ $@ _). nrefine (_ $@ (_ $@L cat_binprod_fmap10_corec _ _ _)). refine (cat_assoc _ _ _ $@ (_ $@L _) $@ cat_assoc _ _ _). nrapply cat_binprod_associator_corec. Defined. Local Instance leftidentity_hom : LeftIdentity sgop_hom mon_unit. Proof. intros f. unfold sgop_hom, mon_unit. rapply path_hom. refine ((_ $@L (cat_binprod_fmap10_corec _ _ _)^$) $@ cat_assoc_opp _ _ _ $@ _). nrefine (((mo_left_unit $@ _) $@R _) $@ _). 1: nrapply cate_buildequiv_fun. unfold trans_nattrans. nrefine ((((_ $@R _) $@ _) $@R _) $@ _). 1: nrapply cate_buildequiv_fun. 1: nrapply cat_binprod_beta_pr1. nrapply cat_binprod_beta_pr2. Defined. Local Instance rightidentity_hom : RightIdentity sgop_hom mon_unit. Proof. intros f. unfold sgop_hom, mon_unit. rapply path_hom. refine ((_ $@L (cat_binprod_fmap01_corec _ _ _)^$) $@ cat_assoc_opp _ _ _ $@ _). nrefine (((mo_right_unit $@ _) $@R _) $@ _). 1: nrapply cate_buildequiv_fun. nrapply cat_binprod_beta_pr1. Defined. Local Instance issemigroup_hom : IsSemiGroup (x $-> y) := {}. Local Instance ismonoid_hom : IsMonoid (x $-> y) := {}. End Monoid. Context `{!IsCommutativeMonoidObject _ _ y}. Local Existing Instances sgop_hom monunit_hom ismonoid_hom. Local Instance commutative_hom : Commutative sgop_hom. Proof. intros f g. unfold sgop_hom. rapply path_hom. refine ((_ $@L _^$) $@ cat_assoc_opp _ _ _ $@ (cmo_comm $@R _)). nrapply cat_binprod_swap_corec. Defined. Local Instance iscommutativemonoid_hom : IsCommutativeMonoid (x $-> y) := {}. End MonoidEnriched. (** ** Preservation of monoid objects by lax monoidal functors *) Definition mo_preserved {A B : Type} {tensorA : A -> A -> A} {tensorB : B -> B -> B} {IA : A} {IB : B} (F : A -> B) `{IsMonoidalFunctor A B tensorA tensorB IA IB F} (x : A) : IsMonoidObject tensorA IA x -> IsMonoidObject tensorB IB (F x). Proof. intros mo_x. snrapply Build_IsMonoidObject. - exact (fmap F mo_mult $o fmap_tensor F (x, x)). - exact (fmap F mo_unit $o fmap_unit). - refine (((_ $@L (fmap10_comp tensorB _ _ _)) $@R _) $@ _ $@ (_ $@L (fmap01_comp tensorB _ _ _)^$)). refine (_ $@ (((_ $@L _^$) $@ cat_assoc_opp _ _ _) $@R _) $@ cat_assoc _ _ _). 2: snrapply fmap_tensor_nat_r. refine (_ $@ ((fmap2 _ mo_assoc $@ fmap_comp _ _ _) $@R _) $@ cat_assoc_opp _ _ _ $@ (cat_assoc _ _ _ $@R _)). refine (_ $@ ((fmap_comp _ _ _ $@ (fmap_comp _ _ _ $@R _))^$ $@R _)). nrefine (cat_assoc _ _ _ $@ cat_assoc _ _ _ $@ (_ $@L _) $@ cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _). refine (_ $@ (_ $@L (_^$ $@ cat_assoc _ _ _))). 2: snrapply fmap_tensor_assoc. nrefine (cat_assoc_opp _ _ _ $@ (cat_assoc_opp _ _ _ $@R _) $@ (((_ $@R _) $@ cat_assoc _ _ _) $@R _) $@ cat_assoc _ _ _). snrapply fmap_tensor_nat_l. - refine ((_ $@L fmap10_comp _ _ _ _) $@ cat_assoc _ _ _ $@ (_ $@L (cat_assoc_opp _ _ _ $@ (_ $@R _))) $@ _). 1: snrapply fmap_tensor_nat_l. refine (cat_assoc_opp _ _ _ $@ ((cat_assoc_opp _ _ _ $@ (((fmap_comp _ _ _)^$ $@ fmap2 _ mo_left_unit) $@R _)) $@R _) $@ _^$). snrapply fmap_tensor_left_unitor. - refine ((_ $@L fmap01_comp _ _ _ _) $@ cat_assoc _ _ _ $@ (_ $@L (cat_assoc_opp _ _ _ $@ (_ $@R _))) $@ _). 1: snrapply fmap_tensor_nat_r. refine (cat_assoc_opp _ _ _ $@ ((cat_assoc_opp _ _ _ $@ (((fmap_comp _ _ _)^$ $@ fmap2 _ mo_right_unit) $@R _)) $@R _) $@ _^$). snrapply fmap_tensor_right_unitor. Defined. Coq-HoTT-9.0/theories/Algebra/Congruence.v000066400000000000000000000006021474641544500203720ustar00rootroot00000000000000Require Import Classes.interfaces.canonical_names. (* We say that a relation is a congruence if it respects the operation. This is technically incorrect since we are not enforcing the relation to be an equivalence relation. *) Local Open Scope mc_mult_scope. Class IsCongruence {G} `{SgOp G} (R : Relation G) := { iscong {x x' y y'} : R x x' -> R y y' -> R (x * y) (x' * y'); }. Coq-HoTT-9.0/theories/Algebra/Groups.v000066400000000000000000000007741474641544500175730ustar00rootroot00000000000000(** Theory *) Require Export HoTT.Algebra.Groups.Group. Require Export HoTT.Algebra.Groups.Subgroup. Require Export HoTT.Algebra.Groups.QuotientGroup. Require Export HoTT.Algebra.Groups.GrpPullback. Require Export HoTT.Algebra.Groups.GroupCoeq. Require Export HoTT.Algebra.Groups.FreeGroup. Require Export HoTT.Algebra.Groups.FreeProduct. Require Export HoTT.Algebra.Groups.Presentation. Require Export HoTT.Algebra.Groups.ShortExactSequence. Require Export HoTT.Algebra.Groups.Finite. (** Examples *) Coq-HoTT-9.0/theories/Algebra/Groups/000077500000000000000000000000001474641544500173745ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/Groups/Commutator.v000066400000000000000000000273251474641544500217260ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Trunc. Require Import Types.Sigma. Require Import Groups.Group AbGroups.Abelianization AbGroups.AbelianGroup Groups.QuotientGroup. Require Import WildCat.Core WildCat.EquivGpd. Require Import Truncations.Core. Local Open Scope mc_scope. Local Open Scope mc_mult_scope. Set Universe Minimization ToSet. (** Commutators in groups *) (** ** Commutators of group elements *) (** Note that this convention is chosen due to the convention we chose for group conjugation elsewhere. *) Definition grp_commutator {G : Group} (x y : G) : G := x * y * x^ * y^. Notation "[ x , y ]" := (grp_commutator x y) : mc_mult_scope. (** ** Easy properties of commutators *) (** Commuting elements of a group have trivial commutator. *) Definition grp_commutator_commutes {G : Group} (x y : G) (p : x * y = y * x) : [x, y] = 1. Proof. unfold grp_commutator. rewrite p, grp_inv_gg_V. apply grp_inv_r. Defined. (** A commutator of an element with itself is the unit. *) Definition grp_commutator_cancel {G : Group} (x y : G) : [x, x] = 1. Proof. by apply grp_commutator_commutes. Defined. (** A commutator of a group element with unit on the left is the unit. *) Definition grp_commutator_unit_l {G : Group} (x : G) : [1, x] = 1. Proof. by apply grp_commutator_commutes, grp_1g_g1. Defined. (** A commutator of a group element with unit on the right is the unit. *) Definition grp_commutator_unit_r {G : Group} (x : G) : [x, 1] = 1. Proof. by apply grp_commutator_commutes, grp_g1_1g. Defined. (** Commutators in abelian groups are trivial. *) Definition ab_commutator (A : AbGroup) (x y : A) : [x, y] = 1. Proof. apply grp_commutator_commutes, commutativity. Defined. (** The commutator can be thought of as the "error" in the commutativity of two elements of a group. *) Definition grp_commutator_swap_op {G : Group} (x y : G) : x * y = [x, y] * y * x. Proof. unfold grp_commutator. by rewrite !grp_inv_gV_g. Defined. (** Inverting a commutator reverses the order. *) Definition grp_commutator_inv {G : Group} (x y : G) : [x, y]^ = [y, x]. Proof. unfold grp_commutator. by rewrite 3 grp_inv_op, 2 grp_inv_inv, 2 grp_assoc. Defined. (** Group homomorphisms commute with commutators. *) Definition grp_homo_commutator {G H : Group} (f : G $-> H) (x y : G) : f [x, y] = [f x, f y]. Proof. unfold grp_commutator. by rewrite !grp_homo_op, !grp_homo_inv. Defined. (** A commutator with a product on the left side can be expanded as the product of a conjugated commutator and another commutator. *) Definition grp_commutator_op_l {G : Group} (x y z : G) : [x * y, z] = grp_conj x [y, z] * [x, z]. Proof. unfold grp_commutator, grp_conj, grp_homo_map. by rewrite grp_inv_op, !grp_assoc, !grp_inv_gV_g. Defined. (** A commutator with a product on the right side can be expanded as the product of a conjugated commutator and another commutator. *) Definition grp_commutator_op_r {G : Group} (x y z : G) : [x, y * z] = [x, y] * grp_conj y [x, z]. Proof. unfold grp_commutator, grp_conj, grp_homo_map. by rewrite grp_inv_op, !grp_assoc, !grp_inv_gV_g. Defined. (** A commutator with the element on the right being multiplied on the right gives a conjugation. *) Definition grp_op_l_commutator {G : Group} (x y : G) : [x, y] * y = grp_conj x y. Proof. unfold grp_commutator, grp_conj, grp_homo_map. by rewrite grp_inv_gV_g. Defined. (** A commutator with the inverse element on the left being multiplied on the left gives a conjugation. *) Definition grp_op_r_commutator {G : Group} (x y : G) : x^ * [x, y] = grp_conj y x^. Proof. unfold grp_commutator, grp_conj, grp_homo_map. by rewrite <- !grp_assoc, grp_inv_V_gg. Defined. (** Commutators with inverted left sides are conjugated commutators. *) Definition grp_commutator_inv_l {G : Group} (x y : G) : [x^, y] = grp_conj x^ [y, x]. Proof. unfold grp_commutator, grp_conj, grp_homo_map. by rewrite !grp_assoc, grp_inv_inv, grp_inv_gV_g. Defined. (** Commutators with inverted right sides are conjugated commutators. *) Definition grp_commutator_inv_r {G : Group} (x y : G) : [x, y^] = grp_conj y^ [y, x]. Proof. unfold grp_commutator, grp_conj, grp_homo_map. by rewrite <- !grp_assoc, grp_inv_inv, grp_inv_V_gg. Defined. Definition grp_conj_commutator_inv_l {G : Group} (x y : G) : grp_conj x [x^, y] = [y, x]. Proof. unfold grp_commutator, grp_conj, grp_homo_map. by rewrite !grp_inv_inv, <- !grp_assoc, grp_inv_g_Vg. Defined. Definition grp_conj_commutator_inv_r {G : Group} (x y : G) : grp_conj y [x, y^] = [y, x]. Proof. unfold grp_commutator, grp_conj, grp_homo_map. by rewrite grp_inv_inv, !grp_assoc, grp_inv_gg_V. Defined. (** ** Hall-Witt identity *) (** The Hall-Witt identity is a Jacobi-like identity for groups. It states that the different commutators of 3 elements (with one conjugated) assemble into an identity. The proof is purely mechanical and simply cancels all the terms. This is a rare instance where a mechanized proof is much shorter than an on-paper proof. *) Definition grp_hall_witt {G : Group} (x y z : G) : [[x, y], grp_conj y z] * [[y, z], grp_conj z x] * [[z, x], grp_conj x y] = 1. Proof. unfold grp_commutator, grp_conj, grp_homo_map. rewrite !grp_inv_op, !grp_inv_inv, !grp_assoc. do 3 rewrite !grp_inv_gV_g, !grp_inv_gg_V. apply grp_inv_r. Defined. (** This variant of the Hall-Witt identity is useful later for proving the three subgroups lemma. *) Definition grp_hall_witt' {G : Group} (x y z : G) : grp_conj x [[x^, y], z] * grp_conj z [[z^, x], y] * grp_conj y [[y^, z], x] = 1. Proof. rewrite 3 (grp_homo_commutator _ [_^, _]). rewrite 3 grp_conj_commutator_inv_l. apply grp_hall_witt. Defined. (** ** Precomposing normal subgroups with commutators *) Global Instance issubgroup_precomp_commutator {G : Group} (H : Subgroup G) `{!IsNormalSubgroup H} (y : G) : IsSubgroup (fun x => H [x, y]). Proof. snrapply Build_IsSubgroup; cbn beta. - exact _. - rewrite grp_commutator_unit_l. apply subgroup_in_unit. - intros x z Hxy Hzy. rewrite grp_commutator_op_l. apply subgroup_in_op. + by rapply isnormal_conj. + assumption. - intros x Hxy. rewrite grp_commutator_inv_l. rapply isnormal_conj. rewrite <- grp_commutator_inv. by apply subgroup_in_inv. Defined. Definition subgroup_precomp_commutator {G : Group} (H : Subgroup G) (y : G) `{!IsNormalSubgroup H} : Subgroup G := Build_Subgroup _ (fun x => H [x, y]) _. (** ** Commutator subgroups *) Definition subgroup_commutator {G : Group@{i}} (H K : Subgroup@{i i} G) : Subgroup@{i i} G := subgroup_generated (fun g => exists (x : H) (y : K), [x.1, y.1] = g). Notation "[ H , K ]" := (subgroup_commutator H K) : group_scope. Local Open Scope group_scope. (** [subgroup_commutator H K] is the smallest subgroup containing the commutators of elements of [H] with elements of [K]. *) Definition subgroup_commutator_rec {G : Group} {H K : Subgroup G} (J : Subgroup G) (i : forall x y, H x -> K y -> J (grp_commutator x y)) : forall x, [H, K] x -> J x. Proof. rapply subgroup_generated_rec; intros x [[y Hy] [[z Kz] p]]; destruct p; simpl. by apply i. Defined. (** Doubly iterated [subgroup_commutator]s of [H], [J] and [K] are the smallest of the normal subgroups containing the doubly iterated commutators of elements of [H], [J] and [K]. *) Definition subgroup_commutator_2_rec {G : Group} {H J K : Subgroup G} (N : Subgroup G) `{!IsNormalSubgroup N} (i : forall x y z, H x -> J y -> K z -> N (grp_commutator (grp_commutator x y) z)) : forall x, [[H, J], K] x -> N x. Proof. snrapply subgroup_commutator_rec. intros x z HJx Kz; revert x HJx. change (N (grp_commutator ?x z)) with (subgroup_precomp_commutator N z x). rapply subgroup_commutator_rec. by intros; apply i. Defined. (** A commutator subgroup of an abelian group is always trivial. *) Definition istrivial_commutator_subgroup_ab {A : AbGroup} (H K : Subgroup A) : IsTrivialGroup [H, K]. Proof. rapply subgroup_commutator_rec; intros. rapply ab_commutator. Defined. (** ** Derived subgroup *) (** The commutator subgroup of the maximal subgroup with itself is called the derived subgroup. It is the subgroup generated by all commutators. *) (** The derived subgroup is a normal subgroup. *) Global Instance isnormal_subgroup_derived {G : Group} : IsNormalSubgroup [G, G]. Proof. snrapply Build_IsNormalSubgroup'. intros x y; revert x. apply (functor_subgroup_generated _ _ (grp_conj y)). intros g. snrapply (functor_sigma (functor_sigma (grp_conj y) (fun _ => idmap))); cbn beta; intros [x []]. snrapply (functor_sigma (functor_sigma (grp_conj y) (fun _ => idmap))); cbn beta; intros [z []]. intros p; simpl. lhs_V nrapply (grp_homo_commutator (grp_conj y)). snrapply (ap (grp_conj y)). exact p. Defined. Definition normalsubgroup_derived G : NormalSubgroup G := Build_NormalSubgroup G [G, G] _. (** We can quotient a group by its derived subgroup. *) Definition grp_derived_quotient (G : Group) : Group := QuotientGroup G (normalsubgroup_derived G). (** We can show that the multiplication then becomes commutative. *) Global Instance commutative_grp_derived_quotient (G : Group) : Commutative (A:=grp_derived_quotient G) (.*.). Proof. intros x. srapply grp_quotient_ind_hprop; intros y; revert x. srapply grp_quotient_ind_hprop; intros x; cbn beta. apply qglue, tr, sgt_in; exists (y^; tt), (x^; tt). unfold grp_commutator; simpl. by rewrite !grp_inv_op, !grp_inv_inv, !grp_assoc. Defined. (** Hence we have a way of producing abelian groups from groups. *) Definition abgroup_derived_quotient (G : Group) : AbGroup := Build_AbGroup (grp_derived_quotient G) _. (** We get a recursion principle into abelian groups. *) Definition abgroup_derived_quotient_rec {G : Group} {A : AbGroup} (f : G $-> A) : abgroup_derived_quotient G $-> A. Proof. snrapply (grp_quotient_rec _ _ f). change (f ?n = 1) with (subgroup_preimage f (trivial_subgroup A) n). snrapply subgroup_commutator_rec. intros x y _ _. lhs nrapply grp_homo_commutator. apply ab_commutator. Defined. (** Furthermore, this construction is an abelianization. *) Definition isabelianization_derived_quotient (G : Group) : IsAbelianization (abgroup_derived_quotient G) grp_quotient_map. Proof. intros A. snrapply Build_IsSurjInj. - intros f. nrefine (abgroup_derived_quotient_rec f; _). hnf; reflexivity. - intros f g p. srapply grp_quotient_ind_hprop; intros x; cbn beta. exact (p x). Defined. (** *** Three subgroups lemma *) Definition three_subgroups_lemma (G : Group) (H J K N : Subgroup G) `{!IsNormalSubgroup N} (T1 : forall x, [[H, J], K] x -> N x) (T2 : forall x, [[J, K], H] x -> N x) : forall x, [[K, H], J] x -> N x. Proof. rapply subgroup_commutator_2_rec. Local Close Scope group_scope. intros z x y Kz Hx Jy. pose proof (grp_hall_witt' x y z^) as p. rewrite grp_inv_inv in p. apply grp_moveL_1V in p. apply grp_moveL_Vg in p. apply (isnormal_conj _ (y:=z^))^-1. change (N (grp_conj z^ [[z, x], y])). rewrite p. apply subgroup_in_op. - apply subgroup_in_inv. rapply isnormal_conj. apply T1. apply tr, sgt_in. unshelve eexists. + exists [x^, y]. apply tr, sgt_in. by exists (x^; subgroup_in_inv _ _ Hx), (y; Jy). + by exists (z^; subgroup_in_inv _ _ Kz). - apply subgroup_in_inv. rapply isnormal_conj. apply T2. apply tr, sgt_in. unshelve eexists. + exists [y^, z^]. apply tr, sgt_in. by exists (y^; subgroup_in_inv _ _ Jy), (z^; subgroup_in_inv _ _ Kz). + by exists (x; Hx). Local Open Scope group_scope. Defined. Definition three_trivial_commutators (G : Group) (H J K : Subgroup G) : IsTrivialGroup [[H, J], K] -> IsTrivialGroup [[J, K], H] -> IsTrivialGroup [[K, H], J]. Proof. rapply three_subgroups_lemma. Defined. Coq-HoTT-9.0/theories/Algebra/Groups/Finite.v000066400000000000000000000041771474641544500210120ustar00rootroot00000000000000Require Import Basics Types. Require Import Algebra.Groups.Group. Require Import Algebra.Groups.Subgroup. Require Import Algebra.Groups.QuotientGroup. Require Import Spaces.Finite.Finite. Require Import Spaces.Nat.Core Spaces.Nat.Division. Require Import Truncations.Core. Local Open Scope nat_scope. Local Open Scope mc_mult_scope. Set Universe Minimization ToSet. (** * Finite Groups *) (** ** Basic Properties *) (** The order of a group is strictly positive. *) Global Instance lt_zero_fcard_grp (G : Group) (fin_G : Finite G) : 0 < fcard G. Proof. pose proof (merely_equiv_fin G) as f. strip_truncations. destruct (fcard G). - contradiction (f mon_unit). - exact _. Defined. (** ** Lagrange's theorem *) (** Lagrange's Theorem - Given a finite group [G] and a finite subgroup [H] of [G], the order of [H] divides the order of [G]. Note that constructively, a subgroup of a finite group cannot be shown to be finite without excluded middle. We therefore have to assume it is. This in turn implies that the subgroup is decidable. *) Definition divides_fcard_subgroup {U : Univalence} (G : Group) (H : Subgroup G) {fin_G : Finite G} {fin_H : Finite H} : (fcard H | fcard G). Proof. exists (subgroup_index G H). symmetry. refine (fcard_quotient (in_cosetL H) @ _). refine (_ @ finadd_const _ _). apply ap, path_forall. srapply Quotient_ind_hprop; simpl. intros x. apply fcard_equiv'. apply equiv_sigma_in_cosetL_subgroup. Defined. (** As a corollary, the index of a subgroup is the order of the group divided by the order of the subgroup. *) Definition subgroup_index_fcard_div {U : Univalence} (G : Group) (H : Subgroup G) (fin_G : Finite G) (fin_H : Finite H) : subgroup_index G H = fcard G / fcard H. Proof. rapply nat_div_moveL_nV. apply divides_fcard_subgroup. Defined. (** Therefore we can show that the order of the quotient group [G / H] is the order of [G] divided by the order of [H]. *) Definition fcard_grp_quotient {U : Univalence} (G : Group) (H : NormalSubgroup G) (fin_G : Finite G) (fin_H : Finite H) : fcard (QuotientGroup G H) = fcard G / fcard H. Proof. rapply subgroup_index_fcard_div. Defined. Coq-HoTT-9.0/theories/Algebra/Groups/FreeGroup.v000066400000000000000000000467351474641544500215000ustar00rootroot00000000000000Require Import Basics Types Group Subgroup WildCat.Core WildCat.Universe Colimits.Coeq Truncations.Core Truncations.SeparatedTrunc Spaces.List.Core Spaces.List.Theory. Local Open Scope mc_scope. Local Open Scope mc_mult_scope. (** [IsFreeGroup] is defined in Group.v. In this file we construct free groups and and prove properties about them. *) (** We construct the free group on a type [A] as a higher inductive type. This construction is due to Kraus-Altenkirch 2018 arXiv:1805.02069. Their construction is actually more general, but we set-truncate it to suit our needs which is the free group as a set. This is a very simple HIT in a similar manner to the abelianization HIT used in Algebra.AbGroup.Abelianization. *) Section Reduction. Universe u. Context (A : Type@{u}). Local Open Scope list_scope. (** We define words (with inverses) on A to be lists of marked elements of A *) Local Definition Words : Type@{u} := list (A + A). (** Given a marked element of A we can change its mark *) Local Definition change_sign : A + A -> A + A := equiv_sum_symm A A. (** We introduce a local notation for [change_sign]. It is only defined in this section however. *) Local Notation "a ^'" := (change_sign a) (at level 1). (** Changing sign is an involution *) Local Definition change_sign_inv a : a^'^' = a. Proof. by destruct a. Defined. (** Now we wish to define the free group on A as the following HIT: HIT N(A) : hSet | eta : Words -> N(A) | tau (x : Words) (a : A + A) (y : Words) : eta (x ++ [a] ++ [a^] ++ y) = eta (x ++ y). Since we cannot write our HITs directly like this (without resorting to private inductive types), we will construct this HIT out of HITs we know. In fact, we can define N(A) as a coequalizer. *) Local Definition map1 : Words * (A + A) * Words -> Words. Proof. intros [[x a] y]. exact (x ++ [a] ++ [a^'] ++ y). Defined. Arguments map1 _ /. Local Definition map2 : Words * (A + A) * Words -> Words. Proof. intros [[x a] y]. exact (x ++ y). Defined. Arguments map2 _ /. (** Now we can define the underlying type of the free group as the 0-truncated coequalizer of these two maps *) Definition freegroup_type : Type := Tr 0 (Coeq map1 map2). (** This is the point constructor *) Definition freegroup_eta : Words -> freegroup_type := tr o coeq. (** This is the path constructor *) Definition freegroup_tau (x : Words) (a : A + A) (y : Words) : freegroup_eta (x ++ [a] ++ [a^'] ++ y) = freegroup_eta (x ++ y). Proof. apply path_Tr, tr. exact ((cglue (x, a, y))). Defined. (** The group operation *) Global Instance sgop_freegroup : SgOp freegroup_type. Proof. intros x y. strip_truncations. revert x; snrapply Coeq_rec. { intros x; revert y. snrapply Coeq_rec. { intros y. exact (freegroup_eta (x ++ y)). } intros [[y a] z]; simpl. change (freegroup_eta (x ++ y ++ ([a] ++ [a^'] ++ z)) = freegroup_eta (x ++ y ++ z)). rhs nrapply ap. 2: nrapply app_assoc. lhs nrapply ap. 1: nrapply app_assoc. nrapply (freegroup_tau _ a). } intros [[c b] d]. revert y. srapply Coeq_ind_hprop. intro a. change (freegroup_eta ((c ++ [b] ++ [b^'] ++ d) ++ a) = freegroup_eta ((c ++ d) ++ a)). lhs_V nrapply ap. 1: nrapply app_assoc. lhs_V nrapply (ap (fun x => freegroup_eta (c ++ x))). 1: nrapply app_assoc. lhs_V nrapply (ap (fun x => freegroup_eta (c ++ _ ++ x))). 1: nrapply app_assoc. rhs_V nrapply ap. 2: nrapply app_assoc. nrapply freegroup_tau. Defined. (** The unit of the free group is the empty word *) Global Instance monunit_freegroup_type : MonUnit freegroup_type := freegroup_eta nil. (** We can change the sign of all the elements in a word and reverse the order. This will be the inversion in the group *) Definition word_change_sign (x : Words) : Words := reverse (list_map change_sign x). (** Changing the sign changes the order of word concatenation *) Definition word_change_sign_ww (x y : Words) : word_change_sign (x ++ y) = word_change_sign y ++ word_change_sign x. Proof. unfold word_change_sign. lhs nrapply (ap reverse). 1: nrapply list_map_app. nrapply reverse_app. Defined. (** This is also involutive *) Lemma word_change_sign_inv x : word_change_sign (word_change_sign x) = x. Proof. unfold word_change_sign. lhs_V nrapply list_map_reverse. lhs nrapply ap. 1: nrapply reverse_reverse. lhs_V nrapply list_map_compose. snrapply list_map_id. intros a ?. apply change_sign_inv. Defined. (** Changing the sign gives us left inverses *) Lemma word_concat_Vw x : freegroup_eta (word_change_sign x ++ x) = mon_unit. Proof. induction x. 1: reflexivity. lhs nrapply (ap (fun x => freegroup_eta (x ++ _))). 1: nrapply reverse_cons. change (freegroup_eta ((word_change_sign x ++ [a^']) ++ [a] ++ x) = mon_unit). lhs_V nrapply ap. 1: nrapply app_assoc. set (a' := a^'). rewrite <- (change_sign_inv a). lhs nrapply freegroup_tau. apply IHx. Defined. (** And since changing the sign is involutive we get right inverses from left inverses *) Lemma word_concat_wV x : freegroup_eta (x ++ word_change_sign x) = mon_unit. Proof. set (x' := word_change_sign x). rewrite <- (word_change_sign_inv x). change (freegroup_eta (word_change_sign x' ++ x') = mon_unit). apply word_concat_Vw. Defined. (** Inverses are defined by changing the order of a word that appears in eta. Most of the work here is checking that it is agreeable with the path constructor. *) Global Instance inverse_freegroup_type : Inverse freegroup_type. Proof. intro x. strip_truncations. revert x; srapply Coeq_rec. { intro x. apply freegroup_eta. exact (word_change_sign x). } intros [[b a] c]. unfold map1, map2. lhs nrapply ap. { lhs nrapply word_change_sign_ww. nrapply (ap (fun x => x ++ _)). lhs nrapply word_change_sign_ww. nrapply (ap (fun x => x ++ _)). lhs nrapply word_change_sign_ww. nrapply (ap (fun x => _ ++ x)). nrapply (word_change_sign_inv [a]). } lhs_V nrapply ap. 1: rhs_V nrapply app_assoc. 1: nrapply app_assoc. rhs nrapply ap. 2: nrapply word_change_sign_ww. nrapply freegroup_tau. Defined. (** Now we can start to prove the group laws. Since these are hprops we can ignore what happens with the path constructor. *) (** Our operation is associative *) Global Instance associative_freegroup_type : Associative sg_op. Proof. intros x y z. strip_truncations. revert x; srapply Coeq_ind_hprop; intro x. revert y; srapply Coeq_ind_hprop; intro y. revert z; srapply Coeq_ind_hprop; intro z. nrapply (ap (tr o coeq)). nrapply app_assoc. Defined. (** Left identity *) Global Instance leftidentity_freegroup_type : LeftIdentity sg_op mon_unit. Proof. rapply Trunc_ind. srapply Coeq_ind_hprop; intros x. reflexivity. Defined. (** Right identity *) Global Instance rightidentity_freegroup_type : RightIdentity sg_op mon_unit. Proof. rapply Trunc_ind. srapply Coeq_ind_hprop; intros x. apply (ap tr), ap. nrapply app_nil. Defined. (** Left inverse *) Global Instance leftinverse_freegroup_type : LeftInverse (.*.) (^) mon_unit. Proof. rapply Trunc_ind. srapply Coeq_ind_hprop; intro x. apply word_concat_Vw. Defined. (** Right inverse *) Global Instance rightinverse_freegroup_type : RightInverse (.*.) (^) mon_unit. Proof. rapply Trunc_ind. srapply Coeq_ind_hprop; intro x. apply word_concat_wV. Defined. (** Finally we have defined the free group on [A] *) Definition FreeGroup : Group. Proof. snrapply (Build_Group freegroup_type); repeat split; exact _. Defined. Definition word_rec (G : Group) (s : A -> G) : A + A -> G. Proof. intros [x|x]. - exact (s x). - exact (s x)^. Defined. (** When we have a list of words we can recursively define a group element. The obvious choice would be to map [nil] to the identity and [x :: xs] to [x * words_rec xs]. This has the disadvantage that a single generating element gets mapped to [x * 1] instead of [x]. To fix this issue, we map [nil] to the identity, the singleton to the element we want, and do the rest recursively. *) Definition words_rec (G : Group) (s : A -> G) : Words -> G. Proof. intro xs. induction xs as [|x [|y xs] IHxs]. - exact mon_unit. - exact (word_rec G s x). - exact (word_rec G s x * IHxs). Defined. Definition words_rec_cons (G : Group) (s : A -> G) (x : A + A) (xs : Words) : words_rec G s (x :: xs)%list = word_rec G s x * words_rec G s xs. Proof. induction xs in x |- *. - symmetry; nrapply grp_unit_r. - reflexivity. Defined. Lemma words_rec_pp (G : Group) (s : A -> G) (x y : Words) : words_rec G s (x ++ y) = words_rec G s x * words_rec G s y. Proof. induction x as [|x xs IHxs] in y |- *. - symmetry; nrapply grp_unit_l. - change ((?x :: ?xs) ++ y) with (x :: xs ++ y). lhs nrapply words_rec_cons. lhs nrapply ap. 1: nrapply IHxs. lhs nrapply grp_assoc. nrapply (ap (.* _)). symmetry. apply words_rec_cons. Defined. Lemma words_rec_coh (G : Group) (s : A -> G) (a : A + A) (b c : Words) : words_rec G s (map1 (b, a, c)) = words_rec G s (map2 (b, a, c)). Proof. unfold map1, map2. rhs nrapply (words_rec_pp G s). lhs nrapply words_rec_pp. nrapply (ap (_ *.)). lhs nrapply words_rec_pp. lhs nrapply ap. 1: nrapply words_rec_pp. lhs nrapply grp_assoc. rhs_V nrapply grp_unit_l. nrapply (ap (.* _)). destruct a; simpl. - nrapply grp_inv_r. - nrapply grp_inv_l. Defined. (** Given a group [G] we can construct a group homomorphism [FreeGroup A $-> G] if we have a map [A -> G]. *) Definition FreeGroup_rec {G : Group} (s : A -> G) : FreeGroup $-> G. Proof. snrapply Build_GroupHomomorphism. { rapply Trunc_rec. srapply Coeq_rec. 1: apply words_rec, s. intros [[b a] c]. apply words_rec_coh. } intros x y; strip_truncations. revert x; srapply Coeq_ind_hprop; intro x. revert y; srapply Coeq_ind_hprop; intro y. simpl. apply words_rec_pp. Defined. Definition freegroup_in : A -> FreeGroup := freegroup_eta o (fun x => [ x ]) o inl. Definition FreeGroup_rec_beta {G : Group} (f : A -> G) : FreeGroup_rec f o freegroup_in == f := fun _ => idpath. Coercion freegroup_in : A >-> group_type. Definition FreeGroup_ind_hprop' (P : FreeGroup -> Type) `{forall x, IsHProp (P x)} (H1 : forall w, P (freegroup_eta w)) : forall x, P x. Proof. rapply Trunc_ind. srapply Coeq_ind_hprop. exact H1. Defined. Definition FreeGroup_ind_hprop (P : FreeGroup -> Type) `{forall x, IsHProp (P x)} (H1 : P mon_unit) (Hin : forall x, P (freegroup_in x)) (Hop : forall x y, P x -> P y -> P (x^ * y)) : forall x, P x. Proof. rapply FreeGroup_ind_hprop'. intros w. induction w as [|a w IHw]. - exact H1. - destruct a as [a|a]. + change (P ((freegroup_in a) * freegroup_eta w)). rewrite <- (grp_inv_inv a). apply Hop. * rewrite <- grp_unit_r. by apply Hop. * assumption. + change (P ((freegroup_in a)^ * freegroup_eta w)). by apply Hop. Defined. Definition FreeGroup_ind_homotopy {G : Group} {f f' : FreeGroup $-> G} (H : forall x, f (freegroup_in x) = f' (freegroup_in x)) : f $== f'. Proof. rapply FreeGroup_ind_hprop. - exact (concat (grp_homo_unit f) (grp_homo_unit f')^). - exact H. - intros x y p q. refine (grp_homo_op_agree f f' _ q). lhs nrapply grp_homo_inv. rhs nrapply grp_homo_inv. exact (ap _ p). Defined. (** Now we need to prove that the free group satisifes the unviersal property of the free group. *) (** TODO: remove funext from here and universal property of free group *) Global Instance isfreegroupon_freegroup `{Funext} : IsFreeGroupOn A FreeGroup freegroup_in. Proof. intros G f. snrapply Build_Contr. { srefine (_;_); simpl. 1: apply FreeGroup_rec, f. intro x; reflexivity. } intros [g h]. nrapply path_sigma_hprop; [ exact _ |]. simpl. apply equiv_path_grouphomomorphism. symmetry. snrapply FreeGroup_ind_homotopy. exact h. Defined. (** Typeclass search can already find this but we leave it here as a definition for reference. *) Definition isfreegroup_freegroup `{Funext} : IsFreeGroup FreeGroup := _. End Reduction. Arguments FreeGroup_rec {A G}. Arguments FreeGroup_ind_homotopy {A G f f'}. Arguments freegroup_eta {A}. Arguments freegroup_in {A}. (** Properties of free groups *) (* Given a function on the generators, there is an induced group homomorphism from the free group. *) Definition isfreegroupon_rec {S : Type} {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i} {G : Group} (f : S -> G) : F_S $-> G := (center (FactorsThroughFreeGroup S F_S i G f)).1. (* The propositional computation rule for the recursor. *) Definition isfreegroupon_rec_beta {S : Type} {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i} {G : Group} (f : S -> G) : isfreegroupon_rec f o i == f := (center (FactorsThroughFreeGroup S F_S i G f)).2. (* Two homomorphisms from a free group are equal if they agree on the generators. *) Definition path_homomorphism_from_free_group {S : Type} {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i} {G : Group} (f g : F_S $-> G) (K : f o i == g o i) : f = g. Proof. (* By assumption, the type [FactorsThroughFreeGroup S F_S i G (g o i)] of factorizations of [g o i] through [i] is contractible. Therefore the two elements we have are equal. Therefore, their first components are equal. *) exact (path_contr (f; K) (g; fun x => idpath))..1. Defined. Global Instance isequiv_isfreegroupon_rec `{Funext} {S : Type} {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i} {G : Group} : IsEquiv (@isfreegroupon_rec S F_S i _ G). Proof. apply (isequiv_adjointify isfreegroupon_rec (fun f => f o i)). - intro f. apply path_homomorphism_from_free_group. apply isfreegroupon_rec_beta. - intro f. (* here we need [Funext]: *) apply path_arrow, isfreegroupon_rec_beta. Defined. (** The universal property of a free group. *) Definition equiv_isfreegroupon_rec `{Funext} {G F : Group} {A : Type} {i : A -> F} `{IsFreeGroupOn A F i} : (A -> G) <~> (F $-> G) := Build_Equiv _ _ isfreegroupon_rec _. (** The above theorem is true regardless of the implementation of free groups. This lets us state the more specific theorem about the canonical free groups. This can be read as [FreeGroup] is left adjoint to the forgetful functor [group_type]. *) Definition equiv_freegroup_rec `{Funext} (G : Group) (A : Type) : (A -> G) <~> (FreeGroup A $-> G) := equiv_isfreegroupon_rec. Global Instance ishprop_isfreegroupon `{Funext} (F : Group) (A : Type) (i : A -> F) : IsHProp (IsFreeGroupOn A F i). Proof. unfold IsFreeGroupOn. apply istrunc_forall. Defined. (** Both ways of stating the universal property are equivalent. *) Definition equiv_isfreegroupon_isequiv_precomp `{Funext} (F : Group) (A : Type) (i : A -> F) : IsFreeGroupOn A F i <~> forall G, IsEquiv (fun f : F $-> G => f o i). Proof. srapply equiv_iff_hprop. 1: intros ? ?; exact (equiv_isequiv (equiv_isfreegroupon_rec)^-1). intros k G g. specialize (k G). snrapply contr_equiv'. 1: exact (hfiber (fun f x => grp_homo_map f (i x)) g). { rapply equiv_functor_sigma_id. intro y; symmetry. apply equiv_path_forall. } exact _. Defined. (** ** Subgroups of free groups *) (* We say that a group [G] is generated by a subtype [X] if the natural map from the subgroup generated by [X] to [G] is a surjection. One could equivalently say [IsEquiv (subgroup_incl (subgroup_generated X))], [forall g, subgroup_generated X g], or [subgroup_generated X = maximal_subgroup], but the definition using surjectivity is convenient later. *) Definition isgeneratedby (G : Group) (X : G -> Type) := IsSurjection (subgroup_incl (subgroup_generated X)). Section FreeGroupGenerated. (* In this Section, we prove that the free group [F_S] on a type [S] is generated in the above sense by the image of [S]. We conclude that the inclusion map is an equivalence, and that the free group is isomorphic as a group to the subgroup. We show that the inclusion is a surjection by showing that it is split epi in the category of groups. *) Context {S : Type} {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i}. (* We define a group homomorphism from [F_S] to the subgroup [G] generated by [S] by sending a generator [s] to "itself". This map will be a section of the inclusion map. *) Local Definition to_subgroup_generated : F_S $-> subgroup_generated (hfiber i). Proof. apply isfreegroupon_rec. intro s. snrapply subgroup_generated_gen_incl. - exact (i s). - exact (s; idpath). Defined. (* We record the computation rule that [to_subgroup_generated] satisfies. *) Local Definition to_subgroup_generated_beta (s : S) : to_subgroup_generated (i s) = subgroup_generated_gen_incl (i s) (s; idpath) := isfreegroupon_rec_beta _ _. (* It follows that [to_subgroup_generated] is a section of the inclusion map from [G] to [F_S]. *) Local Definition is_retraction : (subgroup_incl _) $o to_subgroup_generated = grp_homo_id. Proof. apply path_homomorphism_from_free_group; cbn. intro s. exact (ap pr1 (to_subgroup_generated_beta s)). Defined. (* It follows that the inclusion map is a surjection, i.e., that [F_S] is generated by the image of [S]. *) Definition isgenerated_isfreegroupon : isgeneratedby F_S (hfiber i). Proof. snrapply issurj_retr. - apply to_subgroup_generated. - apply ap10; cbn. exact (ap grp_homo_map is_retraction). Defined. (* Therefore, the inclusion map is an equivalence, since it is known to be an embedding. *) Definition isequiv_subgroup_incl_freegroupon : IsEquiv (subgroup_incl (subgroup_generated (hfiber i))). Proof. apply isequiv_surj_emb. - apply isgenerated_isfreegroupon. - exact _. Defined. (* Therefore, the subgroup is isomorphic to the free group. *) Definition iso_subgroup_incl_freegroupon : GroupIsomorphism (subgroup_generated (hfiber i)) F_S. Proof. nrapply Build_GroupIsomorphism. apply isequiv_subgroup_incl_freegroupon. Defined. End FreeGroupGenerated. (** ** Properties of recursor *) Definition freegroup_rec_in {A : Type} : FreeGroup_rec freegroup_in $== Id (FreeGroup A). Proof. by snrapply FreeGroup_ind_homotopy. Defined. Definition freegroup_rec_compose {A : Type} {G H : Group} (f : A -> G) (k : G $-> H) : FreeGroup_rec (k o f) $== k $o FreeGroup_rec f. Proof. by snrapply FreeGroup_ind_homotopy; intros x. Defined. Definition freegroup_const {A : Type} {G : Group} : FreeGroup_rec (fun _ : A => 1) $== @grp_homo_const _ G. Proof. by snrapply FreeGroup_ind_homotopy. Defined. (** ** Functoriality *) Global Instance is0functor_freegroup : Is0Functor FreeGroup. Proof. snrapply Build_Is0Functor. intros X Y f. snrapply FreeGroup_rec. exact (freegroup_in o f). Defined. Global Instance is1functor_freegroup : Is1Functor FreeGroup. Proof. snrapply Build_Is1Functor. - intros X Y f g p. snrapply FreeGroup_ind_homotopy. intros x. exact (ap freegroup_in (p x)). - intro; nrapply freegroup_rec_in. - intros X Y Z f g. by snrapply FreeGroup_ind_homotopy. Defined. Coq-HoTT-9.0/theories/Algebra/Groups/FreeProduct.v000066400000000000000000000603251474641544500220130ustar00rootroot00000000000000Require Import Basics Types. Require Import Cubical.DPath. Require Import Spaces.List.Core Spaces.List.Theory. Require Import Colimits.Pushout. Require Import Truncations.Core Truncations.SeparatedTrunc. Require Import Algebra.Groups.Group. Require Import WildCat. Local Open Scope list_scope. Local Open Scope mc_scope. Local Open Scope mc_mult_scope. (** In this file we define the amalgamated free product of a span of group homomorphisms as a HIT. *) (** We wish to define the amalgamated free product of a span of group homomorphisms f : G -> H, g : G -> K as the following HIT: HIT M(f,g) | amal_eta : list (H + K) -> M(f,g) | mu_H : forall (x y : list (H + K)) (h1 h2 : H), amal_eta (x ++ [inl h1, inl h2] ++ y) = amal_eta (x ++ [inl (h1 * h2)] ++ y) | mu_K : forall (x y : list (H + K)) (k1 k2 : K), amal_eta (x ++ [inr k1, inr k2] ++ y) = amal_eta (x ++ [inr (k1 * k2)] ++ y) | tau : forall (x y : list (H + K)) (z : G), amal_eta (x ++ [inl (f z)] ++ y) = amal_eta (x ++ [inr (g z)] ++ y) | omega_H : forall (x y : list (H + K)), amal_eta (x ++ [inl mon_unit] ++ y) = amal_eta (x ++ y) | omega_K : forall (x y : list (H + K)), amal_eta (x ++ [inr mon_unit] ++ y) = amal_eta (x ++ y). We will build this HIT up sucessively out of coequalizers. *) (** We will call M [amal_type] and prefix all the constructors with [amal_] (for amalgmated free product). *) Section FreeProduct. Context (G H K : Group) (f : GroupHomomorphism G H) (g : GroupHomomorphism G K). Local Definition Words : Type := list (H + K). Local Fixpoint word_inverse (x : Words) : Words. Proof. destruct x as [|x xs]. 1: exact nil. destruct x as [h|k]. + exact ((word_inverse xs) ++ [inl h^]). + exact ((word_inverse xs) ++ [inr k^]). Defined. (** Inversion changes order of concatenation. *) Local Definition word_inverse_ww (x y : Words) : word_inverse (x ++ y) = word_inverse y ++ word_inverse x. Proof. induction x as [|x xs]. 1: symmetry; apply app_nil. simpl. destruct x; rhs nrapply app_assoc; f_ap. Defined. (** There are five source types for the path constructors. We will construct this HIT as the colimit of five forks going into [Words]. We can bundle up this colimit as a single coequalizer. *) (** Source types of path constructors *) Local Definition pc1 : Type := Words * H * H * Words. Local Definition pc2 : Type := Words * K * K * Words. Local Definition pc3 : Type := Words * G * Words. Local Definition pc4 : Type := Words * Words. Local Definition pc5 : Type := Words * Words. (** End points of the first path constructor *) Local Definition m1 : pc1 -> Words. Proof. intros [[[x h1] h2] y]. exact (x ++ (inl h1 :: [inl h2]) ++ y). Defined. Local Definition m1' : pc1 -> Words. Proof. intros [[[x h1] h2] y]. exact (x ++ [inl (h1 * h2)] ++ y). Defined. (** End points of the second path construct *) Local Definition m2 : pc2 -> Words. Proof. intros [[[x k1] k2] y]. exact (x ++ (inr k1 :: [inr k2]) ++ y). Defined. Local Definition m2' : pc2 -> Words. Proof. intros [[[x k1] k2] y]. exact (x ++ [inr (k1 * k2)] ++ y). Defined. (** End points of the third path constructor *) Local Definition m3 : pc3 -> Words. Proof. intros [[x z] y]. exact (x ++ [inl (f z)] ++ y). Defined. Local Definition m3' : pc3 -> Words. Proof. intros [[x z] y]. exact (x ++ [inr (g z)] ++ y). Defined. (** End points of the fourth path constructor *) Local Definition m4 : pc4 -> Words. Proof. intros [x y]. exact (x ++ [inl mon_unit] ++ y). Defined. Local Definition m4' : pc4 -> Words. Proof. intros [x y]. exact (x ++ y). Defined. (** End points of the fifth path constructor *) Local Definition m5 : pc5 -> Words. Proof. intros [x y]. exact (x ++ [inr mon_unit] ++ y). Defined. Local Definition m5' : pc5 -> Words. Proof. intros [x y]. exact (x ++ y). Defined. (** We can then define maps going into words consisting of the corresponding endpoints of the path constructors. *) Local Definition map1 : pc1 + pc2 + pc3 + pc4 + pc5 -> Words. Proof. intros [[[[x|x]|x]|x]|x]. + exact (m1 x). + exact (m2 x). + exact (m3 x). + exact (m4 x). + exact (m5 x). Defined. Local Definition map2 : pc1 + pc2 + pc3 + pc4 + pc5 -> Words. Proof. intros [[[[x|x]|x]|x]|x]. + exact (m1' x). + exact (m2' x). + exact (m3' x). + exact (m4' x). + exact (m5' x). Defined. (** Finally we can define our type as the 0-truncation of the coequalizer of these maps *) Definition amal_type : Type := Tr 0 (Coeq map1 map2). (** We can define the constructors *) Definition amal_eta : Words -> amal_type := tr o coeq. Definition amal_mu_H (x y : Words) (h1 h2 : H) : amal_eta (x ++ [inl h1, inl h2] ++ y) = amal_eta (x ++ [inl (h1 * h2)] ++ y). Proof. unfold amal_eta. apply path_Tr, tr. exact (cglue (inl (inl (inl (inl (x,h1,h2,y)))))). Defined. Definition amal_mu_K (x y : Words) (k1 k2 : K) : amal_eta (x ++ [inr k1, inr k2] ++ y) = amal_eta (x ++ [inr (k1 * k2)] ++ y). Proof. unfold amal_eta. apply path_Tr, tr. exact (cglue (inl (inl (inl (inr (x,k1,k2,y)))))). Defined. Definition amal_tau (x y : Words) (z : G) : amal_eta (x ++ [inl (f z)] ++ y) = amal_eta (x ++ [inr (g z)] ++ y). Proof. unfold amal_eta. apply path_Tr, tr. exact (cglue (inl (inl (inr (x,z,y))))). Defined. Definition amal_omega_H (x y : Words) : amal_eta (x ++ [inl mon_unit] ++ y) = amal_eta (x ++ y). Proof. unfold amal_eta. apply path_Tr, tr. exact (cglue (inl (inr (x,y)))). Defined. Definition amal_omega_K (x y : Words) : amal_eta (x ++ [inr mon_unit] ++ y) = amal_eta (x ++ y). Proof. unfold amal_eta. apply path_Tr, tr. exact (cglue (inr (x,y))). Defined. (** Now we can derive the dependent eliminator *) Definition amal_type_ind (P : amal_type -> Type) `{forall x, IsHSet (P x)} (e : forall w, P (amal_eta w)) (mh : forall (x y : Words) (h1 h2 : H), DPath P (amal_mu_H x y h1 h2) (e (x ++ [inl h1, inl h2] ++ y)) (e (x ++ [inl (h1 * h2)] ++ y))) (mk : forall (x y : Words) (k1 k2 : K), DPath P (amal_mu_K x y k1 k2) (e (x ++ [inr k1, inr k2] ++ y)) (e (x ++ [inr (k1 * k2)] ++ y))) (t : forall (x y : Words) (z : G), DPath P (amal_tau x y z) (e (x ++ [inl (f z)] ++ y)) (e (x ++ [inr (g z)] ++ y))) (oh : forall (x y : Words), DPath P (amal_omega_H x y) (e (x ++ [inl mon_unit] ++ y)) (e (x ++ y))) (ok : forall (x y : Words), DPath P (amal_omega_K x y) (e (x ++ [inr mon_unit] ++ y)) (e (x ++ y))) : forall x, P x. Proof. snrapply Trunc_ind; [exact _|]. snrapply Coeq_ind. 1: exact e. intro a. destruct a as [ [ [ [a | a ] | a] | a ] | a ]. + destruct a as [[[x h1] h2] y]. apply dp_compose. exact (mh x y h1 h2). + destruct a as [[[x k1] k2] y]. apply dp_compose. exact (mk x y k1 k2). + destruct a as [[x z] y]. apply dp_compose. exact (t x y z). + destruct a as [x y]. apply dp_compose. exact (oh x y). + destruct a as [x y]. apply dp_compose. exact (ok x y). Defined. Definition amal_type_ind_hprop (P : amal_type -> Type) `{forall x, IsHProp (P x)} (e : forall w, P (amal_eta w)) : forall x, P x. Proof. srapply amal_type_ind. 1: exact e. all: intros; apply path_ishprop. Defined. (** From which we can derive the non-dependent eliminator / recursion principle *) Definition amal_type_rec (P : Type) `{IsHSet P} (e : Words -> P) (eh : forall (x y : Words) (h1 h2 : H), e (x ++ [inl h1, inl h2] ++ y) = e (x ++ [inl (h1 * h2)] ++ y)) (ek : forall (x y : Words) (k1 k2 : K), e (x ++ [inr k1, inr k2] ++ y) = e (x ++ [inr (k1 * k2)] ++ y)) (t : forall (x y : Words) (z : G), e (x ++ [inl (f z)] ++ y) = e (x ++ [inr (g z)] ++ y)) (oh : forall (x y : Words), e (x ++ [inl mon_unit] ++ y) = e (x ++ y)) (ok : forall (x y : Words), e (x ++ [inr mon_unit] ++ y) = e (x ++ y)) : amal_type -> P. Proof. snrapply amal_type_ind. 1: exact _. 1: exact e. all: intros; apply dp_const. 1: apply eh. 1: apply ek. 1: apply t. 1: apply oh. apply ok. Defined. (** Now for the group structure *) (** The group operation is concatenation of the underlying list. Most of the work is spent showing that it respects the path constructors. *) Global Instance sgop_amal_type : SgOp amal_type. Proof. intros x y; revert x. srapply amal_type_rec; intros x; revert y. { srapply amal_type_rec; intros y. 1: exact (amal_eta (x ++ y)). { intros z h1 h2. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: apply app_assoc. rapply amal_mu_H. } { intros z k1 k2. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: apply app_assoc. rapply amal_mu_K. } { intros w z. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: apply app_assoc. apply amal_tau. } { intros z. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: apply app_assoc. apply amal_omega_H. } { intros z. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: apply app_assoc. apply amal_omega_K. } } { intros r y h1 h2; revert r. rapply amal_type_ind_hprop. intros z; change (amal_eta ((x ++ [inl h1, inl h2] ++ y) ++ z) = amal_eta ((x ++ [inl (h1 * h2)] ++ y) ++ z)). refine (ap amal_eta _^ @ _ @ ap amal_eta _). 1,3: apply app_assoc. refine (ap amal_eta (ap (app x) _)^ @ _ @ ap amal_eta (ap (app x) _)). 1,3: apply app_assoc. apply amal_mu_H. } { intros r y k1 k2; revert r. rapply amal_type_ind_hprop. intros z; change (amal_eta ((x ++ [inr k1, inr k2] ++ y) ++ z) = amal_eta ((x ++ [inr (k1 * k2)] ++ y) ++ z)). refine (ap amal_eta _^ @ _ @ ap amal_eta _). 1,3: apply app_assoc. refine (ap amal_eta (ap (app x) _)^ @ _ @ ap amal_eta (ap (app x) _)). 1,3: apply app_assoc. apply amal_mu_K. } { intros r y z; revert r. rapply amal_type_ind_hprop. intros w; change (amal_eta ((x ++ [inl (f z)] ++ y) ++ w) = amal_eta ((x ++ [inr (g z)] ++ y) ++ w)). refine (ap amal_eta _^ @ _ @ ap amal_eta _). 1,3: apply app_assoc. refine (ap amal_eta (ap (app x) _)^ @ _ @ ap amal_eta (ap (app x) _)). 1,3: apply app_assoc. apply amal_tau. } { intros r z; revert r. rapply amal_type_ind_hprop. intros w; change (amal_eta ((x ++ [inl mon_unit] ++ z) ++ w) = amal_eta ((x ++ z) ++ w)). refine (ap amal_eta _^ @ _ @ ap amal_eta _). 1,3: apply app_assoc. refine (ap amal_eta (ap (app x) _)^ @ _). 1: apply app_assoc. apply amal_omega_H. } { intros r z; revert r. rapply amal_type_ind_hprop. intros w; change (amal_eta ((x ++ [inr mon_unit] ++ z) ++ w) = amal_eta ((x ++ z) ++ w)). refine (ap amal_eta _^ @ _ @ ap amal_eta _). 1,3: apply app_assoc. refine (ap amal_eta (ap (app x) _)^ @ _). 1: apply app_assoc. apply amal_omega_K. } Defined. (** The identity element is the empty list *) Global Instance monunit_amal_type : MonUnit amal_type. Proof. exact (amal_eta nil). Defined. Global Instance inverse_amal_type : Inverse amal_type. Proof. srapply amal_type_rec. { intros w. exact (amal_eta (word_inverse w)). } { hnf; intros x y h1 h2. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: refine (word_inverse_ww _ _ @ ap (fun s => s ++ _) _). 1: apply word_inverse_ww. { refine (word_inverse_ww _ _ @ _). apply ap; simpl. rapply (ap (fun s => [s])). apply ap. apply inverse_sg_op. } simpl. refine (ap amal_eta _^ @ _ @ ap amal_eta _). 1,3: apply app_assoc. apply amal_mu_H. } { hnf; intros x y k1 k2. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: refine (word_inverse_ww _ _ @ ap (fun s => s ++ _) _). 1: apply word_inverse_ww. { refine (word_inverse_ww _ _ @ _). apply ap; simpl. rapply (ap (fun s => [s])). apply ap. apply inverse_sg_op. } simpl. refine (ap amal_eta _^ @ _ @ ap amal_eta _). 1,3: apply app_assoc. apply amal_mu_K. } { hnf; intros x y z. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: refine (word_inverse_ww _ _ @ ap (fun s => s ++ _) _). 1,2: cbn; refine (ap _ _). 1,2: rapply (ap (fun s => [s])). 1,2: apply ap. 1,2: symmetry; apply grp_homo_inv. refine (ap amal_eta _^ @ _ @ ap amal_eta _). 1,3: apply app_assoc. apply amal_tau. } { hnf; intros x z. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: apply word_inverse_ww. refine (ap amal_eta _ @ _). { refine (ap (fun s => s ++ _) _). apply word_inverse_ww. } refine (ap amal_eta _^ @ _). 1: apply app_assoc. simpl. rewrite inverse_mon_unit. apply amal_omega_H. } { hnf; intros x z. refine (ap amal_eta _ @ _ @ ap amal_eta _^). 1,3: apply word_inverse_ww. refine (ap amal_eta _ @ _). { refine (ap (fun s => s ++ _) _). apply word_inverse_ww. } refine (ap amal_eta _^ @ _). 1: apply app_assoc. simpl. rewrite inverse_mon_unit. apply amal_omega_K. } Defined. Global Instance associative_sgop_m : Associative sg_op. Proof. intros x y. rapply amal_type_ind_hprop; intro z; revert y. rapply amal_type_ind_hprop; intro y; revert x. rapply amal_type_ind_hprop; intro x. nrapply (ap amal_eta). rapply app_assoc. Defined. Global Instance leftidentity_sgop_amal_type : LeftIdentity sg_op mon_unit. Proof. rapply amal_type_ind_hprop; intro x. reflexivity. Defined. Global Instance rightidentity_sgop_amal_type : RightIdentity sg_op mon_unit. Proof. rapply amal_type_ind_hprop; intro x. nrapply (ap amal_eta). nrapply app_nil. Defined. Lemma amal_eta_word_concat_Vw (x : Words) : amal_eta (word_inverse x ++ x) = mon_unit. Proof. induction x as [|x xs]. 1: reflexivity. destruct x as [h|k]. + change (amal_eta (word_inverse ([inl h] ++ xs) ++ [inl h] ++ xs) = mon_unit). rewrite word_inverse_ww. rewrite <- app_assoc. refine (amal_mu_H _ _ _ _ @ _). rewrite left_inverse. rewrite amal_omega_H. apply IHxs. + change (amal_eta (word_inverse ([inr k] ++ xs) ++ [inr k] ++ xs) = mon_unit). rewrite word_inverse_ww. rewrite <- app_assoc. refine (amal_mu_K _ _ _ _ @ _). rewrite left_inverse. rewrite amal_omega_K. apply IHxs. Defined. Lemma amal_eta_word_concat_wV (x : Words) : amal_eta (x ++ word_inverse x) = mon_unit. Proof. induction x as [|x xs]. 1: reflexivity. destruct x as [h|k]. + cbn. rewrite app_assoc. change (amal_eta ([inl h]) * amal_eta ((xs ++ word_inverse xs)) * amal_eta ([inl h^]) = mon_unit). rewrite IHxs. rewrite rightidentity_sgop_amal_type. rewrite <- (app_nil (cons _ _)). change (amal_eta (([inl h] ++ [inl h^]) ++ nil) = mon_unit). rewrite <- app_assoc. change (amal_eta (nil ++ [inl h] ++ [inl h^] ++ nil) = mon_unit). refine (amal_mu_H _ _ _ _ @ _). refine (_ @ _). { apply ap, ap. rapply (ap (fun x => x ++ _)). rapply (ap (fun x => [x])). apply ap. apply right_inverse. } apply amal_omega_H. + cbn. rewrite app_assoc. change (amal_eta ([inr k]) * amal_eta ((xs ++ word_inverse xs)) * amal_eta ([inr k^]) = mon_unit). rewrite IHxs. rewrite rightidentity_sgop_amal_type. rewrite <- (app_nil (cons _ _)). change (amal_eta (([inr k] ++ [inr k^]) ++ nil) = mon_unit). rewrite <- app_assoc. change (amal_eta (nil ++ [inr k] ++ [inr k^] ++ nil) = mon_unit). refine (amal_mu_K _ _ _ _ @ _). refine (_ @ _). { apply ap, ap. rapply (ap (fun x => x ++ _)). rapply (ap (fun x => [x])). apply ap. apply right_inverse. } apply amal_omega_K. Defined. Global Instance leftinverse_sgop_amal_type : LeftInverse (.*.) (^) mon_unit. Proof. rapply amal_type_ind_hprop; intro x. apply amal_eta_word_concat_Vw. Defined. Global Instance rightinverse_sgop_amal_type : RightInverse (.*.) (^) mon_unit. Proof. rapply amal_type_ind_hprop; intro x. apply amal_eta_word_concat_wV. Defined. Definition AmalgamatedFreeProduct : Group. Proof. snrapply (Build_Group amal_type); repeat split; exact _. Defined. (** Using foldr. It's important that we use foldr as foldl is near impossible to reason about. *) Definition AmalgamatedFreeProduct_rec' (X : Group) (h : GroupHomomorphism H X) (k : GroupHomomorphism K X) (p : h o f == k o g) : AmalgamatedFreeProduct -> X. Proof. srapply amal_type_rec. { intro w. refine (fold_right _ _ w). { intros [l|r] x. + exact (h l * x). + exact (k r * x). } exact mon_unit. } { intros x y h1 h2; hnf. rewrite ?fold_right_app. f_ap. simpl. rewrite simple_associativity. f_ap. symmetry. exact (grp_homo_op h h1 h2). } { intros x y k1 k2; hnf. rewrite ?fold_right_app. f_ap. simpl. rewrite simple_associativity. f_ap. symmetry. exact (grp_homo_op k k1 k2). } { intros x y z; hnf. rewrite ?fold_right_app. f_ap; simpl; f_ap. } { intros x y; hnf. rewrite ?fold_right_app. f_ap. simpl. rewrite grp_homo_unit. rapply left_identity. } { intros x y; hnf. rewrite ?fold_right_app. f_ap. simpl. rewrite grp_homo_unit. rapply left_identity. } Defined. Global Instance issemigrouppreserving_AmalgamatedFreeProduct_rec' (X : Group) (h : GroupHomomorphism H X) (k : GroupHomomorphism K X) (p : h o f == k o g) : IsSemiGroupPreserving (AmalgamatedFreeProduct_rec' X h k p). Proof. intros x; srapply amal_type_ind_hprop; intro y; revert x; srapply amal_type_ind_hprop; intro x; simpl. rewrite fold_right_app. set (s := (fold_right (fun X0 : H + K => match X0 with | inl l => fun x0 : X => h l * x0 | inr r => fun x0 : X => k r * x0 end) mon_unit y)). induction x as [|a x]. 1: symmetry; apply left_identity. simpl. rewrite IHx. destruct a; apply simple_associativity. Qed. Definition AmalgamatedFreeProduct_rec (X : Group) (h : H $-> X) (k : K $-> X) (p : h $o f $== k $o g) : AmalgamatedFreeProduct $-> X. Proof. snrapply Build_GroupHomomorphism. 1: srapply (AmalgamatedFreeProduct_rec' X h k p). exact _. Defined. Definition amal_inl : H $-> AmalgamatedFreeProduct. Proof. snrapply Build_GroupHomomorphism. { intro x. exact (amal_eta [inl x]). } intros x y. rewrite <- (app_nil [inl (x * y)]). rewrite <- (amal_mu_H nil nil x y). rewrite app_nil. reflexivity. Defined. Definition amal_inr : K $-> AmalgamatedFreeProduct. Proof. snrapply Build_GroupHomomorphism. { intro x. exact (amal_eta [inr x]). } intros x y. rewrite <- (app_nil [inr (x * y)]). rewrite <- (amal_mu_K nil nil x y). rewrite app_nil. reflexivity. Defined. Definition amal_glue : amal_inl $o f $== amal_inr $o g. Proof. hnf; apply (amal_tau nil nil). Defined. Theorem equiv_amalgamatedfreeproduct_rec `{Funext} (X : Group) : {h : GroupHomomorphism H X & {k : GroupHomomorphism K X & h o f == k o g }} <~> GroupHomomorphism AmalgamatedFreeProduct X. Proof. snrapply equiv_adjointify. 1: intros [h [k p]]; exact (AmalgamatedFreeProduct_rec X h k p). { intros r. exists (grp_homo_compose r amal_inl). exists (grp_homo_compose r amal_inr). intro x. apply (ap r). simpl. rewrite <- (app_nil [inl (f x)]). rewrite <- (app_nil [inr (g x)]). apply (amal_tau nil nil x). } { intros r. apply equiv_path_grouphomomorphism. srapply amal_type_ind_hprop. intro x. induction x as [|a x]. 1: symmetry; apply (grp_homo_unit r). simpl in *. rewrite IHx. destruct a; symmetry; rapply (grp_homo_op r (amal_eta [_]) (amal_eta x)). } intro hkp. simpl. rapply (equiv_ap' (equiv_sigma_prod (fun hk : GroupHomomorphism H X * GroupHomomorphism K X => fst hk o f == snd hk o g)) _ _)^-1%equiv. rapply path_sigma_hprop. destruct hkp as [h [k p]]. apply path_prod; cbn; apply equiv_path_grouphomomorphism; intro; simpl; rapply right_identity. Defined. Definition amalgamatedfreeproduct_ind_hprop (P : AmalgamatedFreeProduct -> Type) `{forall x, IsHProp (P x)} (l : forall a, P (amal_inl a)) (r : forall b, P (amal_inr b)) (Hop : forall x y, P x -> P y -> P (x * y)) : forall x, P x. Proof. rapply amal_type_ind_hprop. intros w. simple_list_induction w a w IH. - rewrite <- (amal_omega_H nil nil). apply l. - destruct a as [a|b]. + change (P (amal_inl a * amal_eta w)). by apply Hop. + change (P (amal_inr b * amal_eta w)). by apply Hop. Defined. Definition amalgamatedfreeproduct_ind_homotopy {k k' : AmalgamatedFreeProduct $-> G} (l : k $o amal_inl $== k' $o amal_inl) (r : k $o amal_inr $== k' $o amal_inr) : k $== k'. Proof. rapply (amalgamatedfreeproduct_ind_hprop _ l r). intros x y p q; by nrapply grp_homo_op_agree. Defined. End FreeProduct. Arguments amal_eta {G H K f g} x. Arguments amal_inl {G H K f g}. Arguments amal_inr {G H K f g}. Arguments AmalgamatedFreeProduct_rec {G H K f g}. Arguments amalgamatedfreeproduct_ind_hprop {G H K f g} _ {_}. Arguments amalgamatedfreeproduct_ind_homotopy {G H K f g _}. Arguments amal_glue {G H K f g}. Definition FreeProduct (G H : Group) : Group := AmalgamatedFreeProduct grp_trivial G H (grp_trivial_rec _) (grp_trivial_rec _). Definition freeproduct_inl {G H : Group} : GroupHomomorphism G (FreeProduct G H) := amal_inl. Definition freeproduct_inr {G H : Group} : GroupHomomorphism H (FreeProduct G H) := amal_inr. Definition FreeProduct_rec {G H K : Group} (f : G $-> K) (g : H $-> K) : FreeProduct G H $-> K. Proof. snrapply (AmalgamatedFreeProduct_rec _ f g). intros []. refine (grp_homo_unit _ @ (grp_homo_unit _)^). Defined. Definition freeproduct_ind_hprop {G H} (P : FreeProduct G H -> Type) `{forall x, IsHProp (P x)} (l : forall g, P (freeproduct_inl g)) (r : forall h, P (freeproduct_inr h)) (Hop : forall x y, P x -> P y -> P (x * y)) : forall x, P x := amalgamatedfreeproduct_ind_hprop P l r Hop. Definition freeproduct_ind_homotopy {G H K : Group} {f f' : FreeProduct G H $-> K} (l : f $o freeproduct_inl $== f' $o freeproduct_inl) (r : f $o freeproduct_inr $== f' $o freeproduct_inr) : f $== f'. Proof. rapply (freeproduct_ind_hprop _ l r). intros x y p q; by nrapply grp_homo_op_agree. Defined. Definition freeproduct_rec_beta_inl {G H K : Group} (f : G $-> K) (g : H $-> K) : FreeProduct_rec f g $o freeproduct_inl $== f := fun x => right_identity (f x). Definition freeproduct_rec_beta_inr {G H K : Group} (f : G $-> K) (g : H $-> K) : FreeProduct_rec f g $o freeproduct_inr $== g := fun x => right_identity (g x). Definition equiv_freeproduct_rec `{funext : Funext} (G H K : Group) : (GroupHomomorphism G K) * (GroupHomomorphism H K) <~> GroupHomomorphism (FreeProduct G H) K. Proof. refine (equiv_amalgamatedfreeproduct_rec _ _ _ _ _ K oE _^-1). refine (equiv_sigma_prod0 _ _ oE equiv_functor_sigma_id (fun _ => equiv_sigma_contr _)). intros f. rapply contr_forall. intros []; apply contr_inhab_prop. apply tr. refine (grp_homo_unit _ @ (grp_homo_unit _)^). Defined. (** The freeproduct is the coproduct in the category of groups. *) Global Instance hasbinarycoproducts : HasBinaryCoproducts Group. Proof. intros G H. snrapply Build_BinaryCoproduct. - exact (FreeProduct G H). - exact freeproduct_inl. - exact freeproduct_inr. - intros Z; exact FreeProduct_rec. - intros; apply freeproduct_rec_beta_inl. - intros; apply freeproduct_rec_beta_inr. - intros Z f g p q. by snrapply freeproduct_ind_homotopy. Defined. Coq-HoTT-9.0/theories/Algebra/Groups/Group.v000066400000000000000000001160111474641544500206570ustar00rootroot00000000000000Require Import Basics Types HProp HFiber HSet. Require Import Homotopy.IdentitySystems. Require Import (notations) Classes.interfaces.canonical_names. Require Export (hints) Classes.interfaces.abstract_algebra. Require Export (hints) Classes.interfaces.canonical_names. (** We only export the parts of these that will be most useful to users of this file. *) Require Export Classes.interfaces.canonical_names (SgOp, sg_op, MonUnit, mon_unit, LeftIdentity, left_identity, RightIdentity, right_identity, Inverse, inv, Associative, simple_associativity, associativity, LeftInverse, left_inverse, RightInverse, right_inverse, Commutative, commutativity). Export canonical_names.BinOpNotations. Require Export Classes.interfaces.abstract_algebra (IsGroup(..), group_monoid, inverse_l, inverse_r, IsSemiGroup(..), sg_set, sg_ass, IsMonoid(..), monoid_left_id, monoid_right_id, monoid_semigroup, IsMonoidPreserving(..), monmor_unitmor, monmor_sgmor, IsSemiGroupPreserving, preserves_sg_op, IsUnitPreserving, preserves_mon_unit). Require Export Classes.theory.groups. Require Import Pointed.Core. Require Import WildCat. Require Import Spaces.Nat.Core Spaces.Int. Require Import Truncations.Core. Local Set Polymorphic Inductive Cumulativity. Generalizable Variables G H A B C f g. Declare Scope group_scope. (** * Groups *) (** A group is an abstraction of several common situations in mathematics. For example, consider the symmetries of an object. Two symmetries can be combined; there is a symmetry that does nothing; and any symmetry can be reversed. Such situations arise in geometry, algebra and, importantly for us, homotopy theory. *) Local Open Scope pointed_scope. Local Open Scope mc_mult_scope. Local Open Scope wc_iso_scope. (** ** Definition of a Group *) (** A group consists of a type, an operation on that type, a unit and an inverse that satisfy the group axioms in [IsGroup]. *) Record Group := { group_type :> Type; group_sgop :: SgOp group_type; group_unit :: MonUnit group_type; group_inverse :: Inverse group_type; group_isgroup :: IsGroup group_type; }. Arguments group_sgop {_}. Arguments group_unit {_}. Arguments group_inverse {_}. Arguments group_isgroup {_}. (** We should never need to unfold the proof that something is a group. *) Global Opaque group_isgroup. Definition issig_group : _ <~> Group := ltac:(issig). (** ** Proof automation *) (** Many times in group theoretic proofs we want some form of automation for obvious identities. Here we implement such a behavior. *) (** We create a database of hints for the group theory library *) Create HintDb group_db. (** Our group laws can be proven easily with tactics such as [rapply associativity]. However this requires a typeclass search on more general algebraic structures. Therefore we explicitly list many groups laws here so that coq can use them. We also create hints for each law in our groups database. *) Section GroupLaws. Context {G : Group} (x y z : G). Definition grp_assoc := associativity x y z. Definition grp_unit_l := left_identity x. Definition grp_unit_r := right_identity x. Definition grp_inv_l := left_inverse x. Definition grp_inv_r := right_inverse x. End GroupLaws. #[export] Hint Immediate grp_assoc : group_db. #[export] Hint Immediate grp_unit_l : group_db. #[export] Hint Immediate grp_unit_r : group_db. #[export] Hint Immediate grp_inv_l : group_db. #[export] Hint Immediate grp_inv_r : group_db. (** Given path types in a product we may want to decompose. *) #[export] Hint Extern 5 (@paths (_ * _) _ _) => (apply path_prod) : group_db. (** Given path types in a sigma type of a hprop family (i.e. a subset) we may want to decompose. *) #[export] Hint Extern 6 (@paths (sig _) _ _) => (rapply path_sigma_hprop) : group_db. (** We also declare a tactic (notation) for automatically solving group laws *) (** TODO: improve this tactic so that it also rewrites and is able to solve basic group lemmas. *) Tactic Notation "grp_auto" := hnf; intros; eauto with group_db. (** ** Some basic properties of groups *) (** Groups are pointed sets with point the identity. *) Global Instance ispointed_group (G : Group) : IsPointed G := @mon_unit G _. Definition ptype_group : Group -> pType := fun G => [G, _]. Coercion ptype_group : Group >-> pType. (** An element acting like the identity is unique. *) Definition identity_unique {A : Type} {Aop : SgOp A} (x y : A) {p : LeftIdentity Aop x} {q : RightIdentity Aop y} : x = y := (q x)^ @ p y. Definition identity_unique' {A : Type} {Aop : SgOp A} (x y : A) {p : LeftIdentity Aop x} {q : RightIdentity Aop y} : y = x := (identity_unique x y)^. (** An element acting like an inverse is unique. *) Definition inverse_unique `{IsMonoid A} (a x y : A) {p : x * a = mon_unit} {q : a * y = mon_unit} : x = y. Proof. refine ((right_identity x)^ @ ap _ q^ @ _). refine (associativity _ _ _ @ _). refine (ap (fun x => x * y) p @ _). apply left_identity. Defined. (** With other assumptions, the right inverse law follows from the left inverse law. *) Definition right_inverse_left_inverse (G : Type) `{IsHSet G} `(SgOp G, MonUnit G, Inverse G, !Associative (.*.), !LeftIdentity (.*.) mon_unit, !LeftInverse (.*.) (^) mon_unit) : RightInverse (.*.) (^) mon_unit. Proof. intros x. lhs_V rapply left_identity. apply (transport (fun x => x * _ = x) (left_inverse x^)). lhs_V rapply simple_associativity. nrapply ap. lhs rapply simple_associativity. lhs nrapply (ap (.* x^)). 1: apply left_inverse. apply left_identity. Defined. Global Opaque right_inverse_left_inverse. (** With other assumptions, the right identity law follows from the left identity law. *) Definition right_identity_left_identity (G : Type) `{IsHSet G} `(SgOp G, MonUnit G, Inverse G, !Associative (.*.), !LeftIdentity (.*.) mon_unit, !LeftInverse (.*.) (^) mon_unit) : RightIdentity (.*.) mon_unit. Proof. intros x. lhs_V rapply left_identity. rhs_V rapply left_identity. apply (transport (fun x => x * _ = x * _) (left_inverse x^)). lhs_V rapply simple_associativity. rhs_V rapply simple_associativity. nrapply ap. lhs rapply simple_associativity. lhs apply (ap (.* mon_unit) (left_inverse x)). lhs apply left_identity. symmetry; apply left_inverse. Defined. Global Opaque right_identity_left_identity. (** When building a group we can choose to omit the right inverse law and right identity law, since they follow from the left ones. *) Definition Build_Group' (G : Type) `{IsHSet G} `(SgOp G, MonUnit G, Inverse G, !Associative (.*.), !LeftIdentity (.*.) mon_unit, !LeftInverse (.*.) (^) mon_unit) : Group. Proof. rapply (Build_Group G). repeat split. 4: nrapply right_identity_left_identity; exact _. 5: nrapply right_inverse_left_inverse; exact _. all: exact _. Defined. (** ** Group homomorphisms *) (** Group homomorphisms are maps between groups that preserve the group operation. They allow us to compare groups and map their structure to one another. This is useful for determining if two groups are really the same, in which case we say they are "isomorphic". *) (** A group homomorphism consists of a map between groups and a proof that the map preserves the group operation. *) Record GroupHomomorphism (G H : Group) := Build_GroupHomomorphism { grp_homo_map :> group_type G -> group_type H; issemigrouppreserving_grp_homo :: IsSemiGroupPreserving grp_homo_map; }. Arguments grp_homo_map {G H}. Arguments Build_GroupHomomorphism {G H} _ _. Arguments issemigrouppreserving_grp_homo {G H} f _ : rename. (** ** Basic properties of group homomorphisms *) (** Group homomorphisms preserve group operations. This is an alias for [issemigrouppreserving_grp_homo] with the identity written explicitly. *) Definition grp_homo_op : forall {G H : Group} (f : GroupHomomorphism G H) (x y : G), f (x * y) = f x * f y := @issemigrouppreserving_grp_homo. #[export] Hint Immediate grp_homo_op : group_db. (** Group homomorphisms are unit preserving. *) Global Instance isunitpreserving_grp_homo {G H : Group} (f : GroupHomomorphism G H) : IsUnitPreserving f. Proof. unfold IsUnitPreserving. apply (group_cancelL (f mon_unit)). rhs nrapply grp_unit_r. rhs_V rapply (ap _ (monoid_left_id _ mon_unit)). symmetry. nrapply issemigrouppreserving_grp_homo. Defined. (** Group homomorphisms preserve identities. This is an alias for the previous statement. *) Definition grp_homo_unit : forall {G H : Group} (f : GroupHomomorphism G H), f mon_unit = mon_unit := @isunitpreserving_grp_homo. #[export] Hint Immediate grp_homo_unit : group_db. (** Therefore, group homomorphisms are monoid homomorphisms. *) Global Instance ismonoidpreserving_grp_homo {G H : Group} (f : GroupHomomorphism G H) : IsMonoidPreserving f := {}. (** Group homomorphisms are pointed maps. *) Definition pmap_GroupHomomorphism {G H : Group} (f : GroupHomomorphism G H) : G ->* H := Build_pMap G H f (isunitpreserving_grp_homo f). Coercion pmap_GroupHomomorphism : GroupHomomorphism >-> pForall. Definition issig_GroupHomomorphism (G H : Group) : _ <~> GroupHomomorphism G H := ltac:(issig). (** Function extensionality for group homomorphisms. *) Definition equiv_path_grouphomomorphism {F : Funext} {G H : Group} {g h : GroupHomomorphism G H} : g == h <~> g = h. Proof. refine ((equiv_ap (issig_GroupHomomorphism G H)^-1 _ _)^-1 oE _). refine (equiv_path_sigma_hprop _ _ oE _). apply equiv_path_forall. Defined. (** Group homomorphisms are sets, in the presence of funext. *) Global Instance ishset_grouphomomorphism {F : Funext} {G H : Group} : IsHSet (GroupHomomorphism G H). Proof. apply istrunc_S. intros f g; apply (istrunc_equiv_istrunc _ equiv_path_grouphomomorphism). Defined. (** Group homomorphisms preserve inverses. *) Definition grp_homo_inv {G H} (f : GroupHomomorphism G H) : forall x, f x^ = (f x)^. Proof. intro x. apply (inverse_unique (f x)). + refine (_ @ grp_homo_unit f). refine ((grp_homo_op f _ x)^ @ _). apply ap. apply grp_inv_l. + apply grp_inv_r. Defined. #[export] Hint Immediate grp_homo_inv : group_db. (** The identity map is a group homomorphism. *) Definition grp_homo_id {G : Group} : GroupHomomorphism G G := Build_GroupHomomorphism idmap _. (** The composition of the underlying functions of two group homomorphisms is also a group homomorphism. *) Definition grp_homo_compose {G H K : Group} : GroupHomomorphism H K -> GroupHomomorphism G H -> GroupHomomorphism G K. Proof. intros f g. srapply (Build_GroupHomomorphism (f o g)). Defined. (** ** Group Isomorphisms *) (** Group isomorphsims are group homomorphisms whose underlying map happens to be an equivalence. They allow us to consider two groups to be the "same". They can be inverted and composed just like equivalences. *) (** An isomorphism of groups is defined as group homomorphism that is an equivalence. *) Record GroupIsomorphism (G H : Group) := Build_GroupIsomorphism { grp_iso_homo :> GroupHomomorphism G H; isequiv_group_iso :: IsEquiv grp_iso_homo; }. (** We can build an isomorphism from an operation-preserving equivalence. *) Definition Build_GroupIsomorphism' {G H : Group} (f : G <~> H) (h : IsSemiGroupPreserving f) : GroupIsomorphism G H. Proof. srapply Build_GroupIsomorphism. 1: srapply Build_GroupHomomorphism. exact _. Defined. Definition issig_GroupIsomorphism (G H : Group) : _ <~> GroupIsomorphism G H := ltac:(issig). (** The underlying equivalence of a group isomorphism. *) Definition equiv_groupisomorphism {G H : Group} : GroupIsomorphism G H -> G <~> H := fun f => Build_Equiv G H f _. Coercion equiv_groupisomorphism : GroupIsomorphism >-> Equiv. (** The underlying pointed equivalence of a group isomorphism. *) Definition pequiv_groupisomorphism {A B : Group} : GroupIsomorphism A B -> (A <~>* B) := fun f => Build_pEquiv _ _ f _. Coercion pequiv_groupisomorphism : GroupIsomorphism >-> pEquiv. (** Funext for group isomorphisms. *) Definition equiv_path_groupisomorphism `{F : Funext} {G H : Group} (f g : GroupIsomorphism G H) : f == g <~> f = g. Proof. refine ((equiv_ap (issig_GroupIsomorphism G H)^-1 _ _)^-1 oE _). refine (equiv_path_sigma_hprop _ _ oE _). apply equiv_path_grouphomomorphism. Defined. (** Group isomorphisms form a set. *) Definition ishset_groupisomorphism `{F : Funext} {G H : Group} : IsHSet (GroupIsomorphism G H). Proof. apply istrunc_S. intros f g; apply (istrunc_equiv_istrunc _ (equiv_path_groupisomorphism _ _)). Defined. (** The identity map is an equivalence and therefore a group isomorphism. *) Definition grp_iso_id {G : Group} : GroupIsomorphism G G := Build_GroupIsomorphism _ _ grp_homo_id _. (** Group isomorphisms can be composed by composing the underlying group homomorphism. *) Definition grp_iso_compose {G H K : Group} (g : GroupIsomorphism H K) (f : GroupIsomorphism G H) : GroupIsomorphism G K := Build_GroupIsomorphism _ _ (grp_homo_compose g f) _. (** Group isomorphisms can be inverted. The inverse map of the underlying equivalence also preserves the group operation and unit. *) Definition grp_iso_inverse {G H : Group} : GroupIsomorphism G H -> GroupIsomorphism H G. Proof. intros [f e]. srapply Build_GroupIsomorphism. - srapply (Build_GroupHomomorphism f^-1). - exact _. Defined. (** Group isomorphism is a reflexive relation. *) Global Instance reflexive_groupisomorphism : Reflexive GroupIsomorphism := fun G => grp_iso_id. (** Group isomorphism is a symmetric relation. *) Global Instance symmetric_groupisomorphism : Symmetric GroupIsomorphism := fun G H => grp_iso_inverse. (** Group isomorphism is a transitive relation. *) Global Instance transitive_groupisomorphism : Transitive GroupIsomorphism := fun G H K f g => grp_iso_compose g f. (** Under univalence, equality of groups is equivalent to isomorphism of groups. This is the structure identity principle for groups. *) Definition equiv_path_group' {U : Univalence} {G H : Group} : GroupIsomorphism G H <~> G = H. Proof. equiv_via {f : G <~> H & IsSemiGroupPreserving f}. 1: make_equiv. revert G H; apply (equiv_path_issig_contr issig_group). - intros [G [? [? [? ?]]]]. exists 1%equiv. exact _. - intros [G [op [unit [neg ax]]]]; cbn. contr_sigsig G (equiv_idmap G). srefine (Build_Contr _ ((_;(_;(_;_)));_) _); cbn. 1: assumption. 1: exact _. intros [[op' [unit' [neg' ax']]] eq]. apply path_sigma_hprop; cbn. refine (@ap _ _ (fun x : { oun : { oo : SgOp G & { u : MonUnit G & Inverse G}} & @IsGroup G oun.1 oun.2.1 oun.2.2} => (x.1.1 ; x.1.2.1 ; x.1.2.2 ; x.2)) ((op;unit;neg);ax) ((op';unit';neg');ax') _). apply path_sigma_hprop; cbn. srefine (path_sigma' _ _ _). 1: funext x y; apply eq. rewrite transport_const. pose (f := Build_GroupHomomorphism (G:=Build_Group G op unit neg ax) (H:=Build_Group G op' unit' neg' ax') idmap eq). srefine (path_sigma' _ _ _). 1: exact (grp_homo_unit f). lhs nrapply transport_const. funext x. exact (grp_homo_inv f x). Defined. (** A version with nicer universe variables. *) Definition equiv_path_group@{u v | u < v} {U : Univalence} {G H : Group@{u}} : GroupIsomorphism G H <~> (paths@{v} G H) := equiv_path_group'. (** ** Simple group equivalences *) (** Left multiplication is an equivalence. *) Global Instance isequiv_group_left_op {G : Group} : forall (x : G), IsEquiv (x *.). Proof. intro x. srapply isequiv_adjointify. 1: exact (x^ *.). all: intro y. all: refine (grp_assoc _ _ _ @ _ @ grp_unit_l y). all: refine (ap (fun x => x * y) _). 1: apply grp_inv_r. apply grp_inv_l. Defined. (** Right multiplication is an equivalence. *) Global Instance isequiv_group_right_op (G : Group) : forall (x : G), IsEquiv (fun y => y * x). Proof. intro x. srapply isequiv_adjointify. 1: exact (fun y => y * x^). all: intro y. all: refine ((grp_assoc _ _ _)^ @ _ @ grp_unit_r y). all: refine (ap (y *.) _). 1: apply grp_inv_l. apply grp_inv_r. Defined. (** The operation inverting group elements is an equivalence. Note that, since the order of the operation will change after inversion, this isn't a group homomorphism. *) Global Instance isequiv_group_inverse {G : Group} : IsEquiv ((^) : G -> G). Proof. srapply isequiv_involution. rapply inverse_involutive. Defined. (** ** Reasoning with equations in groups. *) Section GroupEquations. Context {G : Group} (x y z : G). (** Inverses are involutive. *) Definition grp_inv_inv : x^^ = x := inverse_involutive x. (** Inverses distribute over the group operation. *) Definition grp_inv_op : (x * y)^ = y^ * x^ := inverse_sg_op x y. (** The inverse of the unit is the unit. *) Definition grp_inv_unit : mon_unit^ = mon_unit := inverse_mon_unit (G :=G). Definition grp_inv_V_gg : x^ * (x * y) = y := grp_assoc _ _ _ @ ap (.* y) (grp_inv_l x) @ grp_unit_l y. Definition grp_inv_g_Vg : x * (x^ * y) = y := grp_assoc _ _ _ @ ap (.* y) (grp_inv_r x) @ grp_unit_l y. Definition grp_inv_gg_V : (x * y) * y^ = x := (grp_assoc _ _ _)^ @ ap (x *.) (grp_inv_r y) @ grp_unit_r x. Definition grp_inv_gV_g : (x * y^) * y = x := (grp_assoc _ _ _)^ @ ap (x *.) (grp_inv_l y) @ grp_unit_r x. Definition grp_1g_g1 : x = y <~> 1 * x = y * 1 := equiv_concat_r (grp_unit_r _)^ _ oE equiv_concat_l (grp_unit_l _) _. Definition grp_g1_1g : x = y <~> x * 1 = 1 * y := equiv_concat_r (grp_unit_l _)^ _ oE equiv_concat_l (grp_unit_r _) _. End GroupEquations. (** ** Cancelation lemmas *) (** Group elements can be cancelled both on the left and the right. *) Definition grp_cancelL {G : Group} {x y : G} z : x = y <~> z * x = z * y := equiv_ap (fun x => z * x) _ _. Definition grp_cancelR {G : Group} {x y : G} z : x = y <~> x * z = y * z := equiv_ap (fun x => x * z) _ _. (** ** Group movement lemmas *) Section GroupMovement. (** Since left/right multiplication is an equivalence, we can use lemmas about moving equivalences around to prove group movement lemmas. *) Context {G : Group} {x y z : G}. (** *** Moving group elements *) Definition grp_moveL_gM : x * z^ = y <~> x = y * z := equiv_moveL_equiv_M (f := fun t => t * z) _ _. Definition grp_moveL_Mg : y^ * x = z <~> x = y * z := equiv_moveL_equiv_M (f := fun t => y * t) _ _. Definition grp_moveR_gM : x = z * y^ <~> x * y = z := equiv_moveR_equiv_M (f := fun t => t * y) _ _. Definition grp_moveR_Mg : y = x^ * z <~> x * y = z := equiv_moveR_equiv_M (f := fun t => x * t) _ _. (** *** Moving inverses.*) (** These are the inverses of the previous but are included here for completeness*) Definition grp_moveR_gV : x = y * z <~> x * z^ = y := equiv_moveR_equiv_V (f := fun t => t * z) _ _. Definition grp_moveR_Vg : x = y * z <~> y^ * x = z := equiv_moveR_equiv_V (f := fun t => y * t) _ _. Definition grp_moveL_gV : x * y = z <~> x = z * y^ := equiv_moveL_equiv_V (f := fun t => t * y) _ _. Definition grp_moveL_Vg : x * y = z <~> y = x^ * z := equiv_moveL_equiv_V (f := fun t => x * t) _ _. (** We close the section here so the previous lemmas generalise their assumptions. *) End GroupMovement. Section GroupMovement. Context {G : Group} {x y z : G}. (** *** Moving elements equal to unit. *) Definition grp_moveL_1M : x * y^ = 1 <~> x = y := equiv_concat_r (grp_unit_l _) _ oE grp_moveL_gM. Definition grp_moveL_M1 : y^ * x = 1 <~> x = y := equiv_concat_r (grp_unit_r _) _ oE grp_moveL_Mg. Definition grp_moveL_1V : x * y = 1 <~> x = y^ := equiv_concat_r (grp_unit_l _) _ oE grp_moveL_gV. Definition grp_moveL_V1 : y * x = 1 <~> x = y^ := equiv_concat_r (grp_unit_r _) _ oE grp_moveL_Vg. Definition grp_moveR_1M : 1 = y * x^ <~> x = y := (equiv_concat_l (grp_unit_l _) _)^-1 oE grp_moveR_gM. Definition grp_moveR_M1 : 1 = x^ * y <~> x = y := (equiv_concat_l (grp_unit_r _) _)^-1 oE grp_moveR_Mg. Definition grp_moveR_1V : 1 = y * x <~> x^ = y := (equiv_concat_l (grp_unit_l _) _)^-1 oE grp_moveR_gV. Definition grp_moveR_V1 : mon_unit = x * y <~> x^ = y := (equiv_concat_l (grp_unit_r _) _)^-1 oE grp_moveR_Vg. (** *** Cancelling elements equal to unit. *) Definition grp_cancelL1 : x = mon_unit <~> z * x = z := (equiv_concat_r (grp_unit_r _) _ oE grp_cancelL z). Definition grp_cancelR1 : x = mon_unit <~> x * z = z := (equiv_concat_r (grp_unit_l _) _) oE grp_cancelR z. End GroupMovement. (** ** Commutation *) (** If [g] commutes with [h], then [g] commutes with the inverse [-h]. *) Definition grp_commutes_inv {G : Group} (g h : G) (p : g * h = h * g) : g * h^ = h^ * g. Proof. apply grp_moveR_gV. rhs_V apply simple_associativity. by apply grp_moveL_Vg. Defined. (** If [g] commutes with [h] and [h'], then [g] commutes with their product [h * h']. *) Definition grp_commutes_op {G : Group} (g h h' : G) (p : g * h = h * g) (p' : g * h' = h' * g) : g * (h * h') = (h * h') * g. Proof. lhs apply simple_associativity. lhs nrapply (ap (.* h') p). lhs_V apply simple_associativity. lhs nrapply (ap (h *.) p'). by apply simple_associativity. Defined. (** ** Power operation *) (** For a given [g : G] we can define the function [Int -> G] sending an integer to that power of [g]. *) Definition grp_pow {G : Group} (g : G) (n : Int) : G := int_iter (g *.) n mon_unit. (** Any homomorphism respects [grp_pow]. In other words, [fun g => grp_pow g n] is natural. *) Lemma grp_pow_natural {G H : Group} (f : GroupHomomorphism G H) (n : Int) (g : G) : f (grp_pow g n) = grp_pow (f g) n. Proof. lhs snrapply (int_iter_commute_map _ ((f g) *.)). 1: nrapply grp_homo_op. apply (ap (int_iter _ n)), grp_homo_unit. Defined. (** All powers of the unit are the unit. *) Definition grp_pow_unit {G : Group} (n : Int) : grp_pow (G:=G) mon_unit n = mon_unit. Proof. snrapply (int_iter_invariant n _ (fun g => g = mon_unit)); cbn. 1, 2: apply paths_ind_r. - apply grp_unit_r. - lhs nrapply grp_unit_r. apply grp_inv_unit. - reflexivity. Defined. (** Note that powers don't preserve the group operation as it is not commutative. This does hold in an abelian group so such a result will appear later. *) (** The next two results tell us how [grp_pow] unfolds. *) Definition grp_pow_succ {G : Group} (n : Int) (g : G) : grp_pow g (n.+1)%int = g * grp_pow g n := int_iter_succ_l _ _ _. Definition grp_pow_pred {G : Group} (n : Int) (g : G) : grp_pow g (n.-1)%int = g^ * grp_pow g n := int_iter_pred_l _ _ _. (** [grp_pow] satisfies an additive law of exponents. *) Definition grp_pow_add {G : Group} (m n : Int) (g : G) : grp_pow g (n + m)%int = grp_pow g n * grp_pow g m. Proof. lhs nrapply int_iter_add. induction n; cbn. 1: symmetry; exact (grp_unit_l _). 1: rewrite int_iter_succ_l, grp_pow_succ. 2: rewrite int_iter_pred_l, grp_pow_pred; cbn. 1,2 : rhs_V srapply associativity; apply ap, IHn. Defined. (** [grp_pow] commutes negative exponents to powers of the inverse *) Definition grp_pow_neg {G : Group} (n : Int) (g : G) : grp_pow g (int_neg n) = grp_pow g^ n. Proof. lhs nrapply int_iter_neg. cbn; unfold grp_pow. (* These agree, except for the proofs that [sg_op g^] is an equivalence. *) apply int_iter_agree. Defined. (** Using a negative power in [grp_pow] is the same as first using a positive power and then inverting the result. *) Definition grp_pow_neg_inv {G: Group} (m : Int) (g : G) : grp_pow g (- m)%int = (grp_pow g m)^. Proof. apply grp_moveL_1V. lhs_V nrapply grp_pow_add. by rewrite int_add_neg_l. Defined. (** Combining the two previous results gives that a power of an inverse is the inverse of the power. *) Definition grp_pow_neg_inv' {G: Group} (n: Int) (g : G) : grp_pow g^ n = (grp_pow g n)^. Proof. lhs_V nrapply grp_pow_neg. apply grp_pow_neg_inv. Defined. (** [grp_pow] satisfies a multiplicative law of exponents. *) Definition grp_pow_int_mul {G : Group} (m n : Int) (g : G) : grp_pow g (m * n)%int = grp_pow (grp_pow g m) n. Proof. induction n. - simpl. by rewrite int_mul_0_r. - rewrite int_mul_succ_r. rewrite grp_pow_add. rewrite grp_pow_succ. apply grp_cancelL, IHn. - rewrite int_mul_pred_r. rewrite grp_pow_add. rewrite grp_pow_neg_inv. rewrite grp_pow_pred. apply grp_cancelL, IHn. Defined. (** If [h] commutes with [g], then [h] commutes with [grp_pow g n]. *) Definition grp_pow_commutes {G : Group} (n : Int) (g h : G) (p : h * g = g * h) : h * (grp_pow g n) = (grp_pow g n) * h. Proof. induction n. - by apply grp_g1_1g. - rewrite grp_pow_succ. nrapply grp_commutes_op; assumption. - rewrite grp_pow_pred. nrapply grp_commutes_op. 2: assumption. apply grp_commutes_inv, p. Defined. (** [grp_pow g n] commutes with [g]. *) Definition grp_pow_commutes' {G : Group} (n : Int) (g : G) : g * grp_pow g n = grp_pow g n * g. Proof. by apply grp_pow_commutes. Defined. (** If [g] and [h] commute, then [grp_pow (g * h) n] = (grp_pow g n) * (grp_pow h n)]. *) Definition grp_pow_mul {G : Group} (n : Int) (g h : G) (c : g * h = h * g) : grp_pow (g * h) n = (grp_pow g n) * (grp_pow h n). Proof. induction n. - simpl. symmetry; nrapply grp_unit_r. - rewrite 3 grp_pow_succ. rewrite IHn. rewrite 2 grp_assoc. apply grp_cancelR. rewrite <- 2 grp_assoc. apply grp_cancelL. apply grp_pow_commutes. exact c^%path. - simpl. rewrite 3 grp_pow_pred. rewrite IHn. rewrite 2 grp_assoc. apply grp_cancelR. rewrite c. rewrite grp_inv_op. rewrite <- 2 grp_assoc. apply grp_cancelL. apply grp_pow_commutes. symmetry; apply grp_commutes_inv, c. Defined. (** ** The category of Groups *) (** ** Groups together with homomorphisms form a 1-category whose equivalences are the group isomorphisms. *) Global Instance isgraph_group : IsGraph Group := Build_IsGraph Group GroupHomomorphism. Global Instance is01cat_group : Is01Cat Group := Build_Is01Cat Group _ (@grp_homo_id) (@grp_homo_compose). (** Helper notation so that the wildcat instances can easily be inferred. *) Local Notation grp_homo_map' A B := (@grp_homo_map A B : _ -> (group_type A $-> _)). Global Instance is2graph_group : Is2Graph Group := fun A B => isgraph_induced (grp_homo_map' A B). Global Instance isgraph_grouphomomorphism {A B : Group} : IsGraph (A $-> B) := isgraph_induced (grp_homo_map' A B). Global Instance is01cat_grouphomomorphism {A B : Group} : Is01Cat (A $-> B) := is01cat_induced (grp_homo_map' A B). Global Instance is0gpd_grouphomomorphism {A B : Group}: Is0Gpd (A $-> B) := is0gpd_induced (grp_homo_map' A B). Global Instance is0functor_postcomp_grouphomomorphism {A B C : Group} (h : B $-> C) : Is0Functor (@cat_postcomp Group _ _ A B C h). Proof. apply Build_Is0Functor. intros f g p a ; exact (ap h (p a)). Defined. Global Instance is0functor_precomp_grouphomomorphism {A B C : Group} (h : A $-> B) : Is0Functor (@cat_precomp Group _ _ A B C h). Proof. apply Build_Is0Functor. intros [f ?] [g ?] p a ; exact (p (h a)). Defined. (** Group forms a 1Cat *) Global Instance is1cat_group : Is1Cat Group. Proof. by rapply Build_Is1Cat. Defined. (** Under [Funext], the category of groups has morphism extensionality. *) Global Instance hasmorext_group `{Funext} : HasMorExt Group. Proof. srapply Build_HasMorExt. intros A B f g; cbn in *. snrapply @isequiv_homotopic. 1: exact (equiv_path_grouphomomorphism^-1%equiv). 1: exact _. intros []; reflexivity. Defined. (** Group isomorphisms become equivalences in the category of groups. *) Global Instance hasequivs_group : HasEquivs Group. Proof. unshelve econstructor. + exact GroupIsomorphism. + exact (fun G H f => IsEquiv f). + intros G H f; exact f. + exact Build_GroupIsomorphism. + intros G H; exact grp_iso_inverse. + cbn; exact _. + reflexivity. + intros ????; apply eissect. + intros ????; apply eisretr. + intros G H f g p q. exact (isequiv_adjointify f g p q). Defined. Global Instance is1cat_strong `{Funext} : Is1Cat_Strong Group. Proof. rapply Build_Is1Cat_Strong. all: intros; apply equiv_path_grouphomomorphism; intro; reflexivity. Defined. (** The [group_type] map is a 1-functor. *) Global Instance is0functor_type_group : Is0Functor group_type. Proof. apply Build_Is0Functor. rapply @grp_homo_map. Defined. Global Instance is1functor_type_group : Is1Functor group_type. Proof. by apply Build_Is1Functor. Defined. (** The [ptype_group] map is a 1-functor. *) Global Instance is0functor_ptype_group : Is0Functor ptype_group. Proof. apply Build_Is0Functor. rapply @pmap_GroupHomomorphism. Defined. Global Instance is1functor_ptype_group : Is1Functor ptype_group. Proof. apply Build_Is1Functor; intros; by apply phomotopy_homotopy_hset. Defined. (** Given a group element [a0 : A] over [b : B], multiplication by [a] establishes an equivalence between the kernel and the fiber over [b]. *) Lemma equiv_grp_hfiber {A B : Group} (f : GroupHomomorphism A B) (b : B) : forall (a0 : hfiber f b), hfiber f b <~> hfiber f mon_unit. Proof. intros [a0 p]. refine (equiv_transport (hfiber f) (right_inverse b) oE _). snrapply Build_Equiv. { srapply (functor_hfiber (h := (.* a0^)) (k := (.* b^))). intro a; cbn; symmetry. rhs_V nrapply (ap (fun x => f a * x^) p). exact (grp_homo_op f _ _ @ ap (f a *.) (grp_homo_inv f a0)). } srapply isequiv_functor_hfiber. Defined. (** ** The trivial group *) Definition grp_trivial : Group. Proof. refine (Build_Group Unit (fun _ _ => tt) tt (fun _ => tt) _). repeat split; try exact _; by intros []. Defined. (** Map out of trivial group. *) Definition grp_trivial_rec (G : Group) : GroupHomomorphism grp_trivial G. Proof. snrapply Build_GroupHomomorphism. 1: exact (fun _ => group_unit). intros ??; symmetry; apply grp_unit_l. Defined. (** Map into trivial group. *) Definition grp_trivial_corec (G : Group) : GroupHomomorphism G grp_trivial. Proof. snrapply Build_GroupHomomorphism. 1: exact (fun _ => tt). intros ??; symmetry; exact (grp_unit_l _). Defined. (** Group is a pointed category. *) Global Instance ispointedcat_group : IsPointedCat Group. Proof. snrapply Build_IsPointedCat. - exact grp_trivial. - intro G. exists (grp_trivial_rec G). intros g []; cbn. exact (grp_homo_unit g)^%path. - intro G. exists (grp_trivial_corec G). intros g x; cbn. apply path_unit. Defined. Definition grp_homo_const {G H : Group} : GroupHomomorphism G H := zero_morphism. (** ** The direct product of groups *) (** The cartesian product of the underlying sets of two groups has a natural group structure. We call this the direct product of groups. *) Definition grp_prod : Group -> Group -> Group. Proof. intros G H. srapply (Build_Group (G * H)). (** Operation *) { intros [g1 h1] [g2 h2]. exact (g1 * g2, h1 * h2). } (** Unit *) 1: exact (mon_unit, mon_unit). (** Inverse *) { intros [g h]. exact (g^, h^). } repeat split. 1: exact _. all: grp_auto. Defined. (** Maps into the direct product can be built by mapping separately into each factor. *) Proposition grp_prod_corec {G H K : Group} (f : K $-> G) (g : K $-> H) : K $-> (grp_prod G H). Proof. snrapply Build_GroupHomomorphism. - exact (fun x : K => (f x, g x)). - intros x y. apply path_prod'; apply grp_homo_op. Defined. (** [grp_prod_corec] satisfies a definitional naturality property. *) Definition grp_prod_corec_natural {X Y A B : Group} (f : X $-> Y) (g0 : Y $-> A) (g1 : Y $-> B) : grp_prod_corec g0 g1 $o f $== grp_prod_corec (g0 $o f) (g1 $o f) := fun _ => idpath. (** The left factor injects into the direct product. *) Definition grp_prod_inl {H K : Group} : H $-> grp_prod H K := grp_prod_corec grp_homo_id grp_homo_const. (** The left injection is an embedding. *) Global Instance isembedding_grp_prod_inl {H K : Group} : IsEmbedding (@grp_prod_inl H K). Proof. apply isembedding_isinj_hset. intros h0 h1 p; cbn in p. exact (fst ((equiv_path_prod _ _)^-1 p)). Defined. (** The right factor injects into the direct product. *) Definition grp_prod_inr {H K : Group} : K $-> grp_prod H K := grp_prod_corec grp_homo_const grp_homo_id. (** The right injection is an embedding. *) Global Instance isembedding_grp_prod_inr {H K : Group} : IsEmbedding (@grp_prod_inr H K). Proof. apply isembedding_isinj_hset. intros k0 k1 q; cbn in q. exact (snd ((equiv_path_prod _ _)^-1 q)). Defined. (** Given two pairs of isomorphic groups, their pairwise direct products are isomorphic. *) Definition grp_iso_prod {A B C D : Group} : A ≅ B -> C ≅ D -> (grp_prod A C) ≅ (grp_prod B D). Proof. intros f g. srapply Build_GroupIsomorphism'. 1: srapply (equiv_functor_prod (f:=f) (g:=g)). simpl. unfold functor_prod. intros x y. apply path_prod. 1,2: apply grp_homo_op. Defined. (** The first projection of the direct product. *) Definition grp_prod_pr1 {G H : Group} : GroupHomomorphism (grp_prod G H) G. Proof. snrapply Build_GroupHomomorphism. 1: exact fst. intros ? ?; reflexivity. Defined. (** The first projection is a surjection. *) Global Instance issurj_grp_prod_pr1 {G H : Group} : IsSurjection (@grp_prod_pr1 G H) := issurj_retr grp_prod_inl (fun _ => idpath). (** The second projection of the direct product. *) Definition grp_prod_pr2 {G H : Group} : GroupHomomorphism (grp_prod G H) H. Proof. snrapply Build_GroupHomomorphism. 1: exact snd. intros ? ?; reflexivity. Defined. (** Pairs in direct products can be decomposed *) Definition grp_prod_decompose {G H : Group} (g : G) (h : H) : (g, h) = ((g, 1) : grp_prod G H) * (1, h). Proof. snrapply path_prod; symmetry. - snrapply grp_unit_r. - snrapply grp_unit_l. Defined. (** The second projection is a surjection. *) Global Instance issurj_grp_prod_pr2 {G H : Group} : IsSurjection (@grp_prod_pr2 G H) := issurj_retr grp_prod_inr (fun _ => idpath). (** [Group] is a category with binary products given by the direct product. *) Global Instance hasbinaryproducts_group : HasBinaryProducts Group. Proof. intros G H. snrapply Build_BinaryProduct. - exact (grp_prod G H). - exact grp_prod_pr1. - exact grp_prod_pr2. - intros K. exact grp_prod_corec. - intros K f g. exact (Id _). - intros K f g. exact (Id _). - intros K f g p q a. exact (path_prod' (p a) (q a)). Defined. (** *** Properties of maps to and from the trivial group *) Global Instance isinitial_grp_trivial : IsInitial grp_trivial. Proof. intro G. exists (grp_trivial_rec _). intros g []. apply (grp_homo_unit g)^%path. Defined. Global Instance contr_grp_homo_trivial_source `{Funext} G : Contr (GroupHomomorphism grp_trivial G). Proof. snrapply Build_Contr. 1: exact (grp_trivial_rec _). intros g. rapply equiv_path_grouphomomorphism. intros []. symmetry. rapply grp_homo_unit. Defined. Global Instance isterminal_grp_trivial : IsTerminal grp_trivial. Proof. intro G. exists (grp_trivial_corec _). intros g x. apply path_contr. Defined. Global Instance contr_grp_homo_trivial_target `{Funext} G : Contr (GroupHomomorphism G grp_trivial). Proof. snrapply Build_Contr. 1: exact (pr1 (isterminal_grp_trivial _)). intros g. rapply equiv_path_grouphomomorphism. intros x. apply path_contr. Defined. Global Instance ishprop_grp_iso_trivial `{Funext} (G : Group) : IsHProp (G ≅ grp_trivial). Proof. apply equiv_hprop_allpath. intros f g. apply equiv_path_groupisomorphism; intro; apply path_ishprop. Defined. (** ** Free groups *) Definition FactorsThroughFreeGroup (S : Type) (F_S : Group) (i : S -> F_S) (A : Group) (g : S -> A) : Type := {f : F_S $-> A & f o i == g}. (** Universal property of a free group on a set (type). *) Class IsFreeGroupOn (S : Type) (F_S : Group) (i : S -> F_S) := contr_isfreegroupon : forall (A : Group) (g : S -> A), Contr (FactorsThroughFreeGroup S F_S i A g). Global Existing Instance contr_isfreegroupon. (** A group is free if there exists a generating type on which it is a free group. *) Class IsFreeGroup (F_S : Group) := isfreegroup : {S : _ & {i : _ & IsFreeGroupOn S F_S i}}. Global Instance isfreegroup_isfreegroupon (S : Type) (F_S : Group) (i : S -> F_S) {H : IsFreeGroupOn S F_S i} : IsFreeGroup F_S := (S; i; H). (** ** Further properties of group homomorphisms. *) (** Commutativity can be transferred across isomorphisms. *) Definition commutative_iso_commutative {G H : Group} {C : Commutative (@group_sgop G)} (f : GroupIsomorphism G H) : Commutative (@group_sgop H). Proof. unfold Commutative. rapply (equiv_ind f); intro g1. rapply (equiv_ind f); intro g2. refine ((preserves_sg_op _ _)^ @ _ @ (preserves_sg_op _ _)). refine (ap f _). apply C. Defined. (** If two group homomorphisms agree on two elements, then they agree on their product. *) Definition grp_homo_op_agree {G G' H : Group} (f : G $-> H) (f' : G' $-> H) {x y : G} {x' y' : G'} (p : f x = f' x') (q : f y = f' y') : f (x * y) = f' (x' * y'). Proof. lhs nrapply grp_homo_op. rhs nrapply grp_homo_op. exact (ap011 _ p q). Defined. (** The group movement lemmas can be extended to when there is a homomorphism involved. For now, we only include these two. *) Definition grp_homo_moveL_1V {A B : Group} (f : GroupHomomorphism A B) (x y : A) : f (x * y) = group_unit <~> (f x = - f y) := grp_moveL_1V oE equiv_concat_l (grp_homo_op f x y)^ _. Definition grp_homo_moveL_1M {A B : Group} (f : GroupHomomorphism A B) (x y : A) : f (x * y^) = group_unit <~> (f x = f y). Proof. refine (grp_moveL_1M oE equiv_concat_l _^ _). lhs nrapply grp_homo_op. apply ap, grp_homo_inv. Defined. (** ** Conjugation *) (** Conjugation by a group element is a homomorphism. Often we need to use properties about group homomorphisms in order to prove things about conjugation, so it is helpful to define it directly as a group homomorphism. *) Definition grp_conj {G : Group} (x : G) : G $-> G. Proof. snrapply Build_GroupHomomorphism. - exact (fun y => x * y * x^). - intros y z. rhs nrapply grp_assoc. apply (ap (.* x^)). rhs nrapply grp_assoc. lhs nrapply grp_assoc. apply (ap (.* z)). symmetry; apply grp_inv_gV_g. Defined. (** Conjugation by the unit element is the identity. *) Definition grp_conj_unit {G : Group} : grp_conj (G:=G) 1 $== Id _. Proof. intros x. apply grp_moveR_gV. by nrapply grp_1g_g1. Defined. (** Conjugation commutes with group homomorphisms. *) Definition grp_homo_conj {G H : Group} (f : G $-> H) (x : G) : f $o grp_conj x $== grp_conj (f x) $o f. Proof. intros z; simpl. by rewrite !grp_homo_op, grp_homo_inv. Defined. (** Conjugation respects composition. *) Definition grp_conj_op {G : Group} (x y : G) : grp_conj (x * y) $== grp_conj x $o grp_conj y. Proof. intros z; simpl. by rewrite grp_inv_op, !grp_assoc. Defined. (** Conjugating by an element then its inverse is the identity. *) Definition grp_conj_inv_r {G : Group} (x : G) : grp_conj x $o grp_conj x^ $== Id _. Proof. refine ((grp_conj_op _ _)^$ $@ _ $@ grp_conj_unit). intros y. nrapply (ap (fun x => grp_conj x y)). apply grp_inv_r. Defined. (** Conjugating by an inverse then the element is the identity. *) Definition grp_conj_inv_l {G : Group} (x : G) : grp_conj x^ $o grp_conj x $== Id _. Proof. refine ((grp_conj_op _ _)^$ $@ _ $@ grp_conj_unit). intros y. nrapply (ap (fun x => grp_conj x y)). apply grp_inv_l. Defined. (** Conjugation is a group automorphism. *) Definition grp_iso_conj {G : Group} (x : G) : G $<~> G := cate_adjointify (grp_conj x) (grp_conj x^) (grp_conj_inv_r _) (grp_conj_inv_l _). Coq-HoTT-9.0/theories/Algebra/Groups/GroupCoeq.v000066400000000000000000000031571474641544500214750ustar00rootroot00000000000000Require Import Basics Types. Require Import WildCat.Core. Require Import Truncations.Core. Require Import Algebra.Groups.Group. Require Import Colimits.Coeq. Require Import Algebra.Groups.FreeProduct. (** Coequalizers of group homomorphisms *) Definition GroupCoeq {A B : Group} (f g : A $-> B) : Group. Proof. rapply (AmalgamatedFreeProduct (FreeProduct A A) A B). 1,2: apply FreeProduct_rec. + exact grp_homo_id. + exact grp_homo_id. + exact f. + exact g. Defined. Definition equiv_groupcoeq_rec `{Funext} {A B C : Group} (f g : GroupHomomorphism A B) : {h : B $-> C & h o f == h o g} <~> (GroupCoeq f g $-> C). Proof. refine (equiv_amalgamatedfreeproduct_rec _ _ _ _ _ _ oE _). refine (equiv_sigma_symm _ oE _). apply equiv_functor_sigma_id. intros h. snrapply equiv_adjointify. { intros p. exists (grp_homo_compose h f). hnf; intro x. refine (p _ @ _). revert x. rapply Trunc_ind. srapply Coeq_ind_hprop. intros w. hnf. induction w. 1: apply ap, grp_homo_unit. simpl. destruct a as [a|a]. 1,2: refine (ap _ (grp_homo_op _ _ _) @ _). 1,2: nrapply grp_homo_op_agree; trivial. symmetry. apply p. } { intros [k p] x. assert (q1 := p (freeproduct_inl x)). assert (q2 := p (freeproduct_inr x)). simpl in q1, q2. rewrite 2 right_identity in q1, q2. refine (q1^ @ q2). } { hnf. intros [k p]. apply path_sigma_hprop. simpl. apply equiv_path_grouphomomorphism. intro y. pose (q1 := p (freeproduct_inl y)). simpl in q1. rewrite 2 right_identity in q1. exact q1^. } hnf; intros; apply path_ishprop. Defined. Coq-HoTT-9.0/theories/Algebra/Groups/GrpPullback.v000066400000000000000000000173031474641544500217750ustar00rootroot00000000000000Require Import Basics Types Limits.Pullback Cubical.PathSquare. Require Import Algebra.Groups.Group. Require Import WildCat.Core. (** Pullbacks of groups are formalized by equipping the set-pullback with the desired group structure. The universal property in the category of groups is proved by saying that the corecursion principle (grp_pullback_corec) is an equivalence. *) Local Open Scope mc_scope. Local Open Scope mc_mult_scope. Section GrpPullback. (* Variables are named to correspond with Limits.Pullback. *) Context {A B C : Group} (f : B $-> A) (g : C $-> A). Local Instance grp_pullback_sgop : SgOp (Pullback f g). Proof. intros [b [c p]] [d [e q]]. refine (b * d; c * e; _). exact (grp_homo_op_agree _ _ p q). Defined. Local Instance grp_pullback_sgop_associative : Associative grp_pullback_sgop. Proof. intros [x1 [x2 p]] [y1 [y2 q]] [z1 [z2 u]]. apply equiv_path_pullback; simpl. refine (associativity _ _ _; associativity _ _ _; _). apply equiv_sq_path. apply path_ishprop. Defined. Local Instance grp_pullback_issemigroup : IsSemiGroup (Pullback f g) := {}. Local Instance grp_pullback_mon_unit : MonUnit (Pullback f g) := (1; 1; grp_homo_unit f @ (grp_homo_unit g)^). Local Instance grp_pullback_leftidentity : LeftIdentity grp_pullback_sgop grp_pullback_mon_unit. Proof. intros [b [c p]]; simpl. apply equiv_path_pullback; simpl. refine (left_identity _; left_identity _; _). apply equiv_sq_path. apply path_ishprop. Defined. Local Instance grp_pullback_rightidentity : RightIdentity grp_pullback_sgop grp_pullback_mon_unit. Proof. intros [b [c p]]; simpl. apply equiv_path_pullback; simpl. refine (right_identity _; right_identity _; _). apply equiv_sq_path. apply path_ishprop. Defined. Local Instance ismonoid_grp_pullback : IsMonoid (Pullback f g) := {}. Local Instance grp_pullback_inverse : Inverse (Pullback f g). Proof. intros [b [c p]]. refine (b^; c^; grp_homo_inv f b @ _ @ (grp_homo_inv g c)^). exact (ap (^) p). Defined. Local Instance grp_pullback_leftinverse : LeftInverse (.*.) (^) mon_unit. Proof. unfold LeftInverse. intros [b [c p]]. unfold grp_pullback_sgop; simpl. apply equiv_path_pullback; simpl. refine (left_inverse _; left_inverse _; _). apply equiv_sq_path. apply path_ishprop. Defined. Local Instance grp_pullback_rightinverse : RightInverse (.*.) (^) mon_unit. Proof. intros [b [c p]]. unfold grp_pullback_sgop; simpl. apply equiv_path_pullback; simpl. refine (right_inverse _; right_inverse _; _). apply equiv_sq_path. apply path_ishprop. Defined. Global Instance isgroup_grp_pullback : IsGroup (Pullback f g) := {}. Definition grp_pullback : Group := Build_Group (Pullback f g) _ _ _ _. Definition grp_pullback_pr1 : grp_pullback $-> B. Proof. snrapply Build_GroupHomomorphism. - apply pullback_pr1. - intros x y. reflexivity. Defined. Definition grp_pullback_pr2 : grp_pullback $-> C. Proof. snrapply Build_GroupHomomorphism. - apply pullback_pr2. - intros x y. reflexivity. Defined. Proposition grp_pullback_corec {X : Group} (b : X $-> B) (c : X $-> C) (p : f o b == g o c) : X $-> grp_pullback. Proof. snrapply Build_GroupHomomorphism. - exact (fun x => (b x; c x; p x)). - intros x y. srapply path_sigma. + simpl. apply (grp_homo_op b). + unfold pr2. refine (transport_sigma' _ _ @ _). unfold pr1. apply path_sigma_hprop. simpl. apply (grp_homo_op c). Defined. Corollary grp_pullback_corec' (X : Group) : {b : X $-> B & { c : X $-> C & f o b == g o c}} -> (X $-> grp_pullback). Proof. intros [b [c p]]; exact (grp_pullback_corec b c p). Defined. End GrpPullback. Definition functor_grp_pullback {A A' B B' C C' : Group} (f : B $-> A) (f' : B' $-> A') (g : C $-> A) (g' : C' $-> A') (alpha : A $-> A') (beta : B $-> B') (gamma : C $-> C') (h : f' o beta == alpha o f) (k : alpha o g == g' o gamma) : grp_pullback f g $-> grp_pullback f' g'. Proof. srapply grp_pullback_corec. - exact (beta $o grp_pullback_pr1 f g). - exact (gamma $o grp_pullback_pr2 f g). - intro x; cbn. refine (h _ @ ap alpha _ @ k _). apply pullback_commsq. Defined. Definition equiv_functor_grp_pullback {A A' B B' C C' : Group} (f : B $-> A) (f' : B' $-> A') (g : C $-> A) (g' : C' $-> A') (alpha : GroupIsomorphism A A') (beta : GroupIsomorphism B B') (gamma : GroupIsomorphism C C') (h : f' o beta == alpha o f) (k : alpha o g == g' o gamma) : GroupIsomorphism (grp_pullback f g) (grp_pullback f' g'). Proof. srapply Build_GroupIsomorphism. 1: exact (functor_grp_pullback f f' g g' _ _ _ h k). srapply isequiv_adjointify. { srapply (functor_grp_pullback f' f g' g). 1-3: rapply grp_iso_inverse; assumption. + rapply (equiv_ind beta); intro b. refine (ap f (eissect _ _) @ _). apply (equiv_ap' alpha _ _)^-1. exact ((h b)^ @ (eisretr _ _)^). + rapply (equiv_ind gamma); intro c. refine (_ @ ap g (eissect _ _)^). apply (equiv_ap' alpha _ _)^-1. exact (eisretr _ _ @ (k c)^). } all: intro x; apply equiv_path_pullback_hset; split; cbn. 1-2: apply eisretr. 1-2: apply eissect. Defined. (** Pulling back along some [g : Y $-> Z] and then [g' : Y' $-> Y] is the same as pulling back along [g $o g']. *) Definition equiv_grp_pullback_compose_r {X Z Y Y' : Group} (f : X $-> Z) (g' : Y' $-> Y) (g : Y $-> Z) : GroupIsomorphism (grp_pullback (grp_pullback_pr2 f g) g') (grp_pullback f (g $o g')). Proof. srapply Build_GroupIsomorphism. - srapply grp_pullback_corec. + exact (grp_pullback_pr1 _ _ $o grp_pullback_pr1 _ _). + apply grp_pullback_pr2. + intro x; cbn. exact (pullback_commsq _ _ _ @ ap g (pullback_commsq _ _ _)). - srapply isequiv_adjointify. + srapply grp_pullback_corec. * srapply functor_grp_pullback. 1,2: exact grp_homo_id. 1: exact g'. all: reflexivity. * apply grp_pullback_pr2. * reflexivity. + intro x; cbn. by srapply equiv_path_pullback_hset. + intros [[x [y z0]] [y' z1]]; srapply equiv_path_pullback_hset; split; cbn. 2: reflexivity. srapply equiv_path_pullback_hset; split; cbn. 1: reflexivity. symmetry; exact z1. Defined. Section IsEquivGrpPullbackCorec. (* New section with Funext at the start of the Context. *) Context `{Funext} {A B C : Group} (f : B $-> A) (g : C $-> A). Lemma grp_pullback_corec_pr1 {X : Group} (b : X $-> B) (c : X $-> C) (p : f o b == g o c) : grp_pullback_pr1 f g $o grp_pullback_corec f g b c p = b. Proof. apply equiv_path_grouphomomorphism; reflexivity. Defined. Lemma grp_pullback_corec_pr2 {X : Group} (b : X $-> B) (c : X $-> C) (p : f o b == g o c) : grp_pullback_pr2 f g $o grp_pullback_corec f g b c p = c. Proof. apply equiv_path_grouphomomorphism; reflexivity. Defined. Theorem isequiv_grp_pullback_corec (X : Group) : IsEquiv (grp_pullback_corec' f g X). Proof. snrapply isequiv_adjointify. - intro phi. refine (grp_pullback_pr1 f g $o phi; grp_pullback_pr2 f g $o phi; _). intro x; exact (pullback_commsq f g (phi x)). - intro phi. apply equiv_path_grouphomomorphism; reflexivity. - intro bcp; simpl. srapply path_sigma. + simpl. apply grp_pullback_corec_pr1. + refine (transport_sigma' _ _ @ _). apply path_sigma_hprop; simpl pr1. simpl. apply grp_pullback_corec_pr2. Defined. End IsEquivGrpPullbackCorec. Coq-HoTT-9.0/theories/Algebra/Groups/Presentation.v000066400000000000000000000134221474641544500222400ustar00rootroot00000000000000Require Import Basics Types. Require Import Truncations.Core. Require Import Algebra.Groups.Group. Require Import Algebra.Groups.FreeGroup. Require Import Algebra.Groups.GroupCoeq. Require Import Spaces.Finite Spaces.List.Core. Require Import WildCat. Local Open Scope mc_scope. Local Open Scope mc_mult_scope. (** In this file we develop presentations of groups. *) (** The data of a group presentation *) Record GroupPresentation := { (** We have a type of generators *) gp_generators : Type ; (** An indexing type for relators *) gp_rel_index : Type ; (** The relators are picked out amongst elements of the free group on the generators. *) gp_relators : gp_rel_index -> FreeGroup gp_generators; }. (** Note: A relator is a relation in the form of "w = 1", any relation "w = v" can become a relator "wv^-1 = 1" for words v and w. *) (** Given the data of a group presentation we can construct the group. This is sometimes called the presented group. *) Definition group_gp : GroupPresentation -> Group. Proof. intros [X I R]. exact (GroupCoeq (FreeGroup_rec R) (FreeGroup_rec (fun x => @group_unit (FreeGroup X)))). Defined. (** A group [G] has a presentation if there exists a group presentation whose presented group is isomorphic to [G]. *) Class HasPresentation (G : Group) := { presentation : GroupPresentation; grp_iso_presentation : GroupIsomorphism (group_gp presentation) G; }. Coercion presentation : HasPresentation >-> GroupPresentation. (** Here are a few finiteness properties of group presentations. *) (** A group presentation is finitely generated if its generating set is finite. *) Class FinitelyGeneratedPresentation (P : GroupPresentation) := finite_gp_generators : Finite (gp_generators P). (** A group presentation is finitely related if its relators indexing set is finite. *) Class FinitelyRelatedPresentation (P : GroupPresentation) := finite_gp_relators : Finite (gp_rel_index P). (** A group presentation is a finite presentation if it is finitely generated and related. *) Class FinitePresentation (P : GroupPresentation) := { fp_generators : FinitelyGeneratedPresentation P; fp_relators : FinitelyRelatedPresentation P; }. (** These directly translate into properties of groups. *) (** A group is finitely generated if it has a finitely generated presentation. *) Class IsFinitelyGenerated (G : Group) := { fg_presentation : HasPresentation G; fg_presentation_fg : FinitelyGeneratedPresentation fg_presentation; }. (** A group is finitely related if it has a finitely related presentation. *) Class IsFinitelyRelated (G : Group) := { fr_presentation : HasPresentation G; fr_presentation_fr : FinitelyRelatedPresentation fr_presentation; }. Class IsFinitelyPresented (G : Group) := { fp_presentation : HasPresentation G; fp_presentation_fp : FinitePresentation fp_presentation; }. (** ** Fundamental theorem of presentations of groups *) (** A group homomorphism from a presented group is determined with how the underlying map acts on generators subject to the condition that relators are sent to the unit. *) Theorem grp_pres_rec {funext : Funext} (G : Group) (P : HasPresentation G) (H : Group) : {f : gp_generators P -> H & forall r, FreeGroup_rec f (gp_relators P r) = group_unit} <~> GroupHomomorphism G H. Proof. refine ((equiv_precompose_cat_equiv grp_iso_presentation)^-1 oE _). refine (equiv_groupcoeq_rec _ _ oE _). srefine (equiv_functor_sigma_pb _ oE _). 2: apply equiv_freegroup_rec. apply equiv_functor_sigma_id. intros f. srapply equiv_iff_hprop. { intros p. change (equiv_freegroup_rec H _ f $o FreeGroup_rec (gp_relators P) $== equiv_freegroup_rec _ _ f $o FreeGroup_rec (fun _ => group_unit)). rapply FreeGroup_ind_homotopy. exact p. } intros p r. hnf in p. exact (p (freegroup_in r)). Defined. (** ** Constructors for finite presentations *) Definition Build_Finite_GroupPresentation n m (f : FinSeq m (FreeGroup (Fin n))) : GroupPresentation. Proof. snrapply Build_GroupPresentation. - exact (Fin n). - exact (Fin m). - exact f. Defined. Global Instance FinitelyGeneratedPresentation_Build_Finite_GroupPresentation {n m f} : FinitelyGeneratedPresentation (Build_Finite_GroupPresentation n m f). Proof. unshelve econstructor. 2: simpl; apply tr; reflexivity. Defined. Global Instance FinitelyRelatedPresentation_Build_Finite_GroupPresentation {n m f} : FinitelyRelatedPresentation (Build_Finite_GroupPresentation n m f). Proof. unshelve econstructor. 2: simpl; apply tr; reflexivity. Defined. (** ** Notations for presentations *) (** Convenient abbreviation when defining notations. *) Local Notation ff := (freegroup_in o fin_nat). (** TODO: I haven't worked out how to generalize to any number of binders, so we explicitly list the first few levels. *) Local Open Scope nat_scope. (** One generator *) Notation "⟨ x | F , .. , G ⟩" := (Build_Finite_GroupPresentation 1 _ (fscons ((fun (x : FreeGroup (Fin 1)) => F : FreeGroup (Fin _)) (ff 0%nat)) .. (fscons ((fun (x : FreeGroup (Fin 1)) => G : FreeGroup (Fin _)) (ff 0)) fsnil) ..)) (at level 200, x binder). (** Two generators *) Notation "⟨ x , y | F , .. , G ⟩" := (Build_Finite_GroupPresentation 2 _ (fscons ((fun (x y : FreeGroup (Fin 2)) => F : FreeGroup (Fin _)) (ff 0) (ff 1)) .. (fscons ((fun (x y : FreeGroup (Fin 2)) => G : FreeGroup (Fin _)) (ff 0) (ff 1)) fsnil) ..)) (at level 200, x binder, y binder). (** Three generators *) Notation "⟨ x , y , z | F , .. , G ⟩" := (Build_Finite_GroupPresentation 3 _ (fscons ((fun (x y z : FreeGroup (Fin 3)) => F : FreeGroup (Fin _)) (ff 0) (ff 1) (ff 2)) .. (fscons ((fun (x y z : FreeGroup (Fin 3)) => G : FreeGroup (Fin _)) (ff 0) (ff 1) (ff 2)) fsnil) ..)) (at level 200, x binder, y binder, z binder). Coq-HoTT-9.0/theories/Algebra/Groups/QuotientGroup.v000066400000000000000000000301071474641544500224110ustar00rootroot00000000000000Require Import Basics Types. Require Import Truncations.Core. Require Import Algebra.Congruence. Require Import Algebra.Groups.Group. Require Import Algebra.Groups.Subgroup. Require Export Colimits.Quotient. Require Import HSet. Require Import Spaces.Finite.Finite. Require Import WildCat. Require Import Modalities.Modality. (** * Quotient groups *) Local Open Scope mc_scope. Local Open Scope mc_mult_scope. Local Open Scope wc_iso_scope. (** ** Congruence quotients *) Section GroupCongruenceQuotient. (** A congruence on a group is a relation satisfying [R x x' -> R y y' -> R (x * y) (x' * y')]. Because we also require that [R] is reflexive, we also know that [R y y' -> R (x * y) (x * y')] for any [x], and similarly for multiplication on the right by [x]. We don't need to assume that [R] is symmetric or transitive. *) Context {G : Group} {R : Relation G} `{!IsCongruence R, !Reflexive R}. (** The type underlying the quotient group is [Quotient R]. *) Definition CongruenceQuotient := G / R. Global Instance congquot_sgop : SgOp CongruenceQuotient. Proof. srapply Quotient_rec2. - intros x y. exact (class_of _ (x * y)). - intros x x' y p. apply qglue. by apply iscong. - intros x y y' q. apply qglue. by apply iscong. Defined. Global Instance congquot_mon_unit : MonUnit CongruenceQuotient. Proof. apply class_of, mon_unit. Defined. Global Instance congquot_inverse : Inverse CongruenceQuotient. Proof. srapply Quotient_rec. 1: exact (class_of R o (^)). intros x y p; cbn beta. transitivity (class_of R (y^ * (y * x^))). - rewrite grp_assoc. rewrite grp_inv_l. rewrite grp_unit_l. reflexivity. - transitivity (class_of R (y^ * (x * x^))). + symmetry; apply qglue; repeat apply iscong. 1,3: reflexivity. exact p. + rewrite grp_inv_r. rewrite grp_unit_r. reflexivity. Defined. Global Instance congquot_sgop_associative : Associative congquot_sgop. Proof. srapply Quotient_ind3_hprop; intros x y z. snrapply (ap (class_of R)). rapply associativity. Defined. Global Opaque congquot_sgop_associative. Global Instance issemigroup_congquot : IsSemiGroup CongruenceQuotient := {}. Global Instance congquot_leftidentity : LeftIdentity (.*.) mon_unit. Proof. srapply Quotient_ind_hprop; intro x. snrapply (ap (class_of R)). rapply left_identity. Defined. Global Opaque congquot_leftidentity. Global Instance congquot_rightidentity : RightIdentity (.*.) mon_unit. Proof. srapply Quotient_ind_hprop; intro x. snrapply (ap (class_of R)). rapply right_identity. Defined. Global Opaque congquot_rightidentity. Global Instance ismonoid_quotientgroup : IsMonoid CongruenceQuotient := {}. Global Instance quotientgroup_leftinverse : LeftInverse (.*.) (^) mon_unit. Proof. srapply Quotient_ind_hprop; intro x; cbn beta. snrapply (ap (class_of R)). rapply left_inverse. Defined. Global Opaque quotientgroup_leftinverse. Global Instance quotientgroup_rightinverse : RightInverse (.*.) (^) mon_unit. Proof. srapply Quotient_ind_hprop; intro x; cbn beta. snrapply (ap (class_of R)). rapply right_inverse. Defined. Global Opaque quotientgroup_rightinverse. Global Instance isgroup_quotientgroup : IsGroup CongruenceQuotient := {}. End GroupCongruenceQuotient. (** ** Sets of cosets *) Section Cosets. Context (G : Group) (H : Subgroup G). Definition LeftCoset := G / in_cosetL H. (** TODO: Way too many universes, needs fixing *) (** The set of left cosets of a finite subgroup of a finite group is finite. *) Global Instance finite_leftcoset `{Univalence, Finite G, Finite H} : Finite LeftCoset. Proof. nrapply finite_quotient. 1-5: exact _. intros x y. apply (detachable_finite_subset H). Defined. (** The index of a subgroup is the number of cosets of the subgroup. *) Definition subgroup_index `{Univalence, Finite G, Finite H} : nat := fcard LeftCoset. Definition RightCoset := G / in_cosetR H. (** The set of left cosets is equivalent to the set of right coset. *) Definition equiv_leftcoset_rightcoset : LeftCoset <~> RightCoset. Proof. snrapply equiv_quotient_functor. - exact inv. - exact _. - intros x y; simpl. by rewrite grp_inv_inv. Defined. (** The set of right cosets of a finite subgroup of a finite group is finite since it is equivalent to the set of left cosets. *) Global Instance finite_rightcoset `{Univalence, Finite G, Finite H} : Finite RightCoset. Proof. nrapply finite_equiv'. 1: apply equiv_leftcoset_rightcoset. exact _. Defined. End Cosets. (** ** Quotient groups *) (** Now we can define the quotient group by a normal subgroup. *) Section QuotientGroup. Context (G : Group) (N : NormalSubgroup G). Global Instance iscongruence_in_cosetL : IsCongruence (in_cosetL N). Proof. srapply Build_IsCongruence. intros; by apply in_cosetL_cong. Defined. Global Instance iscongruence_in_cosetR: IsCongruence (in_cosetR N). Proof. srapply Build_IsCongruence. intros; by apply in_cosetR_cong. Defined. (** Now we have to make a choice whether to pick the left or right cosets. Due to existing convention we shall pick left cosets but we note that we could equally have picked right. *) Definition QuotientGroup : Group := Build_Group (LeftCoset G N) _ _ _ _. Definition grp_quotient_map : G $-> QuotientGroup. Proof. snrapply Build_GroupHomomorphism. 1: exact (class_of _). intros ??; reflexivity. Defined. Definition grp_quotient_rec {A : Group} (f : G $-> A) (h : forall n : G, N n -> f n = mon_unit) : QuotientGroup $-> A. Proof. snrapply Build_GroupHomomorphism. - srapply Quotient_rec. + exact f. + cbn; intros x y n. apply grp_moveR_M1. rhs_V nrapply (ap (.* f y) (grp_homo_inv _ _)). rhs_V nrapply grp_homo_op. symmetry; apply h; assumption. - intro x. refine (Quotient_ind_hprop _ _ _). intro y. revert x. refine (Quotient_ind_hprop _ _ _). intro x; simpl. apply grp_homo_op. Defined. Definition grp_quotient_ind_hprop (P : QuotientGroup -> Type) `{forall x, IsHProp (P x)} (H1 : forall x, P (grp_quotient_map x)) : forall x, P x. Proof. srapply Quotient_ind_hprop. exact H1. Defined. End QuotientGroup. Arguments QuotientGroup G N : simpl never. Arguments grp_quotient_map {_ _}. Notation "G / N" := (QuotientGroup G N) : group_scope. (** Rephrasing that lets you specify the normality proof *) Definition QuotientGroup' (G : Group) (N : Subgroup G) (H : IsNormalSubgroup N) := QuotientGroup G (Build_NormalSubgroup G N H). Local Open Scope group_scope. (** Computation rule for grp_quotient_rec. *) Corollary grp_quotient_rec_beta `{F : Funext} {G : Group} (N : NormalSubgroup G) (H : Group) {A : Group} (f : G $-> A) (h : forall n:G, N n -> f n = mon_unit) : (grp_quotient_rec G N f h) $o grp_quotient_map = f. Proof. apply equiv_path_grouphomomorphism; reflexivity. Defined. (** Computation rule for grp_quotient_rec. *) Definition grp_quotient_rec_beta' {G : Group} (N : NormalSubgroup G) (H : Group) {A : Group} (f : G $-> A) (h : forall n:G, N n -> f n = mon_unit) : (grp_quotient_rec G N f h) $o grp_quotient_map == f := fun _ => idpath. (** The proof of normality is irrelevent up to equivalence. This is unfortunate that it doesn't hold definitionally. *) Definition grp_iso_quotient_normal (G : Group) (H : Subgroup G) {k k' : IsNormalSubgroup H} : QuotientGroup' G H k ≅ QuotientGroup' G H k'. Proof. snrapply Build_GroupIsomorphism'. 1: reflexivity. intro x. srapply Quotient_ind_hprop; intro y; revert x. srapply Quotient_ind_hprop; intro x. reflexivity. Defined. (** The universal mapping property for groups *) Theorem equiv_grp_quotient_ump {F : Funext} {G : Group} (N : NormalSubgroup G) (H : Group) : {f : G $-> H & forall (n : G), N n -> f n = mon_unit} <~> (G / N $-> H). Proof. srapply equiv_adjointify. - intros [f p]. exact (grp_quotient_rec _ _ f p). - intro f. exists (f $o grp_quotient_map). intros n h; cbn. refine (_ @ grp_homo_unit f). apply ap. apply qglue; cbn. rewrite right_identity; by apply issubgroup_in_inv. - intros f. rapply equiv_path_grouphomomorphism. by srapply Quotient_ind_hprop. - intros [f p]. srapply path_sigma_hprop; simpl. exact (grp_quotient_rec_beta N H f p). Defined. Section FirstIso. Context `{Funext} {A B : Group} (phi : A $-> B). (** First we define a map from the quotient by the kernel of phi into the image of phi *) Definition grp_image_quotient : A / grp_kernel phi $-> grp_image phi. Proof. srapply grp_quotient_rec. + srapply grp_homo_image_in. + intros n x. by apply path_sigma_hprop. Defined. (** The underlying map of this homomorphism is an equivalence *) Global Instance isequiv_grp_image_quotient : IsEquiv grp_image_quotient. Proof. snrapply isequiv_surj_emb. 1: srapply cancelR_conn_map. srapply isembedding_isinj_hset. srapply Quotient_ind2_hprop. intros x y h; simpl in h. apply qglue; cbn. apply (equiv_path_sigma_hprop _ _)^-1%equiv in h; cbn in h. cbn. rewrite grp_homo_op, grp_homo_inv, h. apply grp_inv_l. Defined. (** First isomorphism theorem for groups *) Theorem grp_first_iso : A / grp_kernel phi ≅ grp_image phi. Proof. exact (Build_GroupIsomorphism _ _ grp_image_quotient _). Defined. End FirstIso. (** Quotient groups are finite. *) (** Note that we cannot constructively conclude that the normal subgroup [H] must be finite since [G] is, therefore we keep it as an assumption. *) Global Instance finite_quotientgroup {U : Univalence} (G : Group) (H : NormalSubgroup G) (fin_G : Finite G) (fin_H : Finite H) : Finite (QuotientGroup G H). Proof. nrapply finite_quotient. 1-5: exact _. intros x y. pose (dec_H := detachable_finite_subset H). apply dec_H. Defined. Definition grp_kernel_quotient_iso `{Univalence} {G : Group} (N : NormalSubgroup G) : GroupIsomorphism N (grp_kernel (@grp_quotient_map G N)). Proof. srapply Build_GroupIsomorphism. - srapply (grp_kernel_corec (subgroup_incl N)). intro x; cbn. apply qglue. apply issubgroup_in_op. + exact (issubgroup_in_inv _ x.2). + exact issubgroup_in_unit. - apply isequiv_surj_emb. 2: apply (cancelL_isembedding (g:=pr1)). intros [g p]. rapply contr_inhabited_hprop. srefine (tr ((g; _); _)). + rewrite <- grp_unit_l, <- inverse_mon_unit. apply (related_quotient_paths (fun x y => N (x^ * y))). exact p^%path. + srapply path_sigma_hprop. reflexivity. Defined. (** When the normal subgroup [N] is trivial, the inclusion map [G $-> G / N] is an isomorphism. *) Global Instance catie_grp_quotient_map_trivial {G : Group} (N : NormalSubgroup G) (triv : IsTrivialGroup N) : CatIsEquiv (@grp_quotient_map G N). Proof. snrapply catie_adjointify. - srapply (grp_quotient_rec _ _ (Id _)). apply triv. - by srapply grp_quotient_ind_hprop. - reflexivity. Defined. (** The group quotient by a trivial group is isomorphic to the original group. *) Definition grp_quotient_trivial (G : Group) (N : NormalSubgroup G) (triv : IsTrivialGroup N) : G $<~> G / N := Build_CatEquiv grp_quotient_map. (** A quotient by a maximal subgroup is trivial. *) Global Instance istrivial_grp_quotient_maximal (G : Group) (N : NormalSubgroup G) : IsMaximalSubgroup N -> IsTrivialGroup (G / N). Proof. intros max x _; revert x. rapply grp_quotient_ind_hprop. intros x. apply qglue, max. Defined. (** Conversely, a trivial quotient means the subgroup is maximal. *) Definition ismaximalsubgroup_istrivial_grp_quotient `{Univalence} (G : Group) (N : NormalSubgroup G) : IsTrivialGroup (G / N) -> IsMaximalSubgroup N. Proof. intros triv x. specialize (triv (grp_quotient_map x) tt). simpl in triv. apply related_quotient_paths in triv. 2-5: exact _. apply equiv_subgroup_inv. nrapply (subgroup_in_op_l _ _ 1 triv) . apply subgroup_in_unit. Defined. Coq-HoTT-9.0/theories/Algebra/Groups/ShortExactSequence.v000066400000000000000000000042271474641544500233450ustar00rootroot00000000000000Require Import Basics Types. Require Import Truncations.Core. Require Import WildCat.Core Pointed. Require Import Groups.Group Groups.Subgroup. Require Import Homotopy.ExactSequence Modalities.Identity. (** * Complexes of groups *) Definition grp_cxfib {A B C : Group} {i : A $-> B} {f : B $-> C} (cx : IsComplex i f) : GroupHomomorphism A (grp_kernel f) := grp_kernel_corec _ cx. Definition grp_iso_cxfib {A B C : Group} {i : A $-> B} {f : B $-> C} `{IsEmbedding i} (ex : IsExact (Tr (-1)) i f) : GroupIsomorphism A (grp_kernel f) := Build_GroupIsomorphism _ _ (grp_cxfib cx_isexact) (isequiv_cxfib ex). (** This is the same proof as for [equiv_cxfib_beta], but giving the proof is easier than specializing the general result. *) Proposition grp_iso_cxfib_beta {A B C : Group} {i : A $-> B} {f : B $-> C} `{IsEmbedding i} (ex : IsExact (Tr (-1)) i f) : i $o (grp_iso_inverse (grp_iso_cxfib ex)) $== subgroup_incl (grp_kernel f). Proof. rapply equiv_ind. 1: exact (isequiv_cxfib ex). intro x. exact (ap (fun y => i y) (eissect _ x)). Defined. Definition grp_iscomplex_trivial {X Y : Group} (f : X $-> Y) : IsComplex (grp_trivial_rec X) f. Proof. srapply phomotopy_homotopy_hset. intro x; cbn. exact (grp_homo_unit f). Defined. (** A complex 0 -> A -> B of groups is purely exact if and only if the map A -> B is an embedding. *) Lemma iff_grp_isexact_isembedding {A B : Group} (f : A $-> B) : IsExact purely (grp_trivial_rec A) f <-> IsEmbedding f. Proof. split. - intros ex b. apply hprop_inhabited_contr; intro a. rapply (contr_equiv' grp_trivial). exact ((equiv_grp_hfiber f b a)^-1 oE pequiv_cxfib). - intro isemb_f. exists (grp_iscomplex_trivial f). intros y; rapply contr_inhabited_hprop. exists tt; apply path_ishprop. Defined. (** A complex 0 -> A -> B is purely exact if and only if the kernel of the map A -> B is trivial. *) Definition equiv_grp_isexact_kernel `{Univalence} {A B : Group} (f : A $-> B) : IsExact purely (grp_trivial_rec A) f <~> IsTrivialGroup (grp_kernel f) := (equiv_istrivial_kernel_isembedding f)^-1%equiv oE equiv_iff_hprop_uncurried (iff_grp_isexact_isembedding f). Coq-HoTT-9.0/theories/Algebra/Groups/Subgroup.v000066400000000000000000001047671474641544500214100ustar00rootroot00000000000000Require Import Basics Types HFiber WildCat.Core WildCat.Equiv. Require Import Truncations.Core Modalities.Modality. Require Export Modalities.Modality (conn_map_factor1_image). Require Import Algebra.Groups.Group Universes.TruncType Universes.HSet. Local Open Scope mc_scope. Local Open Scope mc_mult_scope. Generalizable Variables G H A B C N f g. (** * Subgroups *) (** ** Definition of being a subgroup *) (** A subgroup H of a group G is a predicate (i.e. an hProp-valued type family) on G which is closed under the group operations. The group underlying H is given by the total space { g : G & H g }, defined in [subgroup_group] below. *) Class IsSubgroup {G : Group} (H : G -> Type) := { issubgroup_predicate : forall x, IsHProp (H x) ; issubgroup_in_unit : H mon_unit ; issubgroup_in_op : forall x y, H x -> H y -> H (x * y) ; issubgroup_in_inv : forall x, H x -> H x^ ; }. Global Existing Instance issubgroup_predicate. (** Basic properties of subgroups *) (** Smart constructor for subgroups. *) Definition Build_IsSubgroup' {G : Group} (H : G -> Type) `{forall x, IsHProp (H x)} (unit : H mon_unit) (c : forall x y, H x -> H y -> H (x * y^)) : IsSubgroup H. Proof. refine (Build_IsSubgroup G H _ unit _ _). - intros x y. intros hx hy. pose (c' := c mon_unit y). specialize (c' unit). specialize (c x y^). rewrite (grp_inv_inv y) in c. rewrite left_identity in c'. apply c. 1: assumption. exact (c' hy). - intro g. specialize (c _ g unit). rewrite left_identity in c. assumption. Defined. (** Additional lemmas about being elements in a subgroup *) Section IsSubgroupElements. Context {G : Group} {H : G -> Type} `{IsSubgroup G H}. Definition issubgroup_in_op_inv (x y : G) : H x -> H y -> H (x * y^). Proof. intros p q. apply issubgroup_in_op. 1: assumption. by apply issubgroup_in_inv. Defined. Definition issubgroup_in_inv' (x : G) : H x^ -> H x. Proof. intros p; rewrite <- (inverse_involutive x); revert p. apply issubgroup_in_inv. Defined. Definition issubgroup_in_inv_op (x y : G) : H x -> H y -> H (x^ * y). Proof. intros p q. rewrite <- (inverse_involutive y). apply issubgroup_in_op_inv. 1,2: by apply issubgroup_in_inv. Defined. Definition issubgroup_in_op_l (x y : G) : H (x * y) -> H y -> H x. Proof. intros p q. rewrite <- (grp_unit_r x). revert p q. rewrite <- (grp_inv_r y). rewrite grp_assoc. apply issubgroup_in_op_inv. Defined. Definition issubgroup_in_op_r (x y : G) : H (x * y) -> H x -> H y. Proof. intros p q. rewrite <- (grp_unit_l y). revert q p. rewrite <- (grp_inv_l x). rewrite <- grp_assoc. apply issubgroup_in_inv_op. Defined. End IsSubgroupElements. Definition issig_issubgroup {G : Group} (H : G -> Type) : _ <~> IsSubgroup H := ltac:(issig). (** Given a predicate H on a group G, being a subgroup is a property. *) Global Instance ishprop_issubgroup `{F : Funext} {G : Group} {H : G -> Type} : IsHProp (IsSubgroup H). Proof. exact (istrunc_equiv_istrunc _ (issig_issubgroup H)). Defined. (** ** Definition of subgroup *) (** The type (set) of subgroups of a group G. *) Record Subgroup (G : Group) := { subgroup_pred : G -> Type ; subgroup_issubgroup : IsSubgroup subgroup_pred ; }. Coercion subgroup_pred : Subgroup >-> Funclass. Global Existing Instance subgroup_issubgroup. Definition issig_subgroup {G : Group} : _ <~> Subgroup G := ltac:(issig). (** ** Basics properties of subgroups *) Definition Build_Subgroup' {G : Group} (H : G -> Type) `{forall x, IsHProp (H x)} (unit : H mon_unit) (c : forall x y, H x -> H y -> H (x * y^)) : Subgroup G. Proof. refine (Build_Subgroup G H _). rapply Build_IsSubgroup'; assumption. Defined. Section SubgroupElements. Context {G : Group} (H : Subgroup G) (x y : G). Definition subgroup_in_unit : H 1 := issubgroup_in_unit. Definition subgroup_in_inv : H x -> H x^ := issubgroup_in_inv x. Definition subgroup_in_inv' : H x^ -> H x := issubgroup_in_inv' x. Definition subgroup_in_op : H x -> H y -> H (x * y) := issubgroup_in_op x y. Definition subgroup_in_op_inv : H x -> H y -> H (x * y^) := issubgroup_in_op_inv x y. Definition subgroup_in_inv_op : H x -> H y -> H (x^ * y) := issubgroup_in_inv_op x y. Definition subgroup_in_op_l : H (x * y) -> H y -> H x := issubgroup_in_op_l x y. Definition subgroup_in_op_r : H (x * y) -> H x -> H y := issubgroup_in_op_r x y. End SubgroupElements. Global Instance isequiv_subgroup_in_inv `(H : Subgroup G) (x : G) : IsEquiv (subgroup_in_inv H x). Proof. srapply isequiv_iff_hprop. apply subgroup_in_inv'. Defined. Definition equiv_subgroup_inv {G : Group} (H : Subgroup G) (x : G) : H x <~> H x^ := Build_Equiv _ _ (subgroup_in_inv H x) _. Definition equiv_subgroup_op_inv {G : Group} (H : Subgroup G) (x y : G) : H (x * y^) <~> H (y * x^). Proof. nrefine (_ oE equiv_subgroup_inv _ _). by rewrite grp_inv_op, grp_inv_inv. Defined. (** Paths between subgroups correspond to homotopies between the underlying predicates. *) Proposition equiv_path_subgroup `{F : Funext} {G : Group} (H K : Subgroup G) : (H == K) <~> (H = K). Proof. refine ((equiv_ap' issig_subgroup^-1%equiv _ _)^-1%equiv oE _); cbn. refine (equiv_path_sigma_hprop _ _ oE _); cbn. apply equiv_path_arrow. Defined. Proposition equiv_path_subgroup' `{U : Univalence} {G : Group} (H K : Subgroup G) : (forall g:G, H g <-> K g) <~> (H = K). Proof. refine (equiv_path_subgroup _ _ oE _). apply equiv_functor_forall_id; intro g. exact equiv_path_iff_ishprop. Defined. Global Instance ishset_subgroup `{Univalence} {G : Group} : IsHSet (Subgroup G). Proof. nrefine (istrunc_equiv_istrunc _ issig_subgroup). nrefine (istrunc_equiv_istrunc _ (equiv_functor_sigma_id _)). - intro P; apply issig_issubgroup. - nrefine (istrunc_equiv_istrunc _ (equiv_sigma_assoc' _ _)^-1%equiv). nrapply istrunc_sigma. 2: intros []; apply istrunc_hprop. nrefine (istrunc_equiv_istrunc _ (equiv_sig_coind (fun g:G => Type) (fun g x => IsHProp x))^-1%equiv). apply istrunc_forall. Defined. (** ** Underlying group of a subgroup *) (** The group given by a subgroup *) Definition subgroup_group {G : Group} (H : Subgroup G) : Group. Proof. apply (Build_Group (** The underlying type is the sigma type of the predicate. *) (sig H) (** The operation is the group operation on the first projection with the proof of being in the subgroup given by the subgroup data. *) (fun '(x ; p) '(y ; q) => (x * y ; issubgroup_in_op x y p q)) (** The unit *) (mon_unit ; issubgroup_in_unit) (** Inverse *) (fun '(x ; p) => (- x ; issubgroup_in_inv _ p))). (** Finally we need to prove our group laws. *) repeat split. 1: exact _. all: grp_auto. Defined. Coercion subgroup_group : Subgroup >-> Group. (** The underlying group of a subgroup of [G] has an inclusion map into [G]. *) Definition subgroup_incl {G : Group} (H : Subgroup G) : subgroup_group H $-> G. Proof. snrapply Build_GroupHomomorphism. 1: exact pr1. hnf; reflexivity. Defined. (** The inclusion map is an embedding. *) Global Instance isembedding_subgroup_incl {G : Group} (H : Subgroup G) : IsEmbedding (subgroup_incl H) := fun _ => istrunc_equiv_istrunc _ (hfiber_fibration _ _). (** Restriction of a group homomorphism to a subgroup. *) Definition grp_homo_restr {G H : Group} (f : G $-> H) (K : Subgroup G) : subgroup_group K $-> H := f $o subgroup_incl _. (** Corestriction of a group homomorphism to a subgroup. *) Definition subgroup_corec {G H : Group} {K : Subgroup H} (f : G $-> H) (g : forall x, K (f x)) : G $-> subgroup_group K. Proof. snrapply Build_GroupHomomorphism. - exact (fun x => (f x; g x)). - intros x y. rapply path_sigma_hprop. snrapply grp_homo_op. Defined. (** Corestriction is an equivalence on group homomorphisms. *) Definition equiv_subgroup_corec {F : Funext} (G : Group) {H : Group} (K : Subgroup H) : {f : G $-> H & forall x, K (f x)} <~> (G $-> subgroup_group K). Proof. snrapply equiv_adjointify. - exact (sig_rec subgroup_corec). - intros g. exists (subgroup_incl _ $o g). intros x. exact (g x).2. - intros g. by snrapply equiv_path_grouphomomorphism. - intros [f p]. rapply path_sigma_hprop. by snrapply equiv_path_grouphomomorphism. Defined. (** Functoriality on subgroups. *) Definition functor_subgroup_group {G H : Group} {J : Subgroup G} {K : Subgroup H} (f : G $-> H) (g : forall x, J x -> K (f x)) : subgroup_group J $-> subgroup_group K := subgroup_corec (grp_homo_restr f J) (sig_ind _ g). Definition grp_iso_subgroup_group {G H : Group@{i}} {J : Subgroup@{i i} G} (K : Subgroup@{i i} H) (e : G $<~> H) (f : forall x, J x <-> K (e x)) : subgroup_group J $<~> subgroup_group K. Proof. snrapply cate_adjointify. - exact (functor_subgroup_group e (fun x => fst (f x))). - nrefine (functor_subgroup_group e^-1$ _). equiv_intro e x. intros k. nrefine ((eissect e _)^ # _). exact (snd (f x) k). - intros x. rapply path_sigma_hprop. nrapply eisretr. - intros x. rapply path_sigma_hprop. nrapply eissect. Defined. (** ** Cosets of subgroups *) Section Cosets. (** Left and right cosets give equivalence relations. *) Context {G : Group} (H : Subgroup G). (** The relation of being in a left coset represented by an element. *) Definition in_cosetL : Relation G := fun x y => H (x^ * y). (** The relation of being in a right coset represented by an element. *) Definition in_cosetR : Relation G := fun x y => H (x * y^). Hint Extern 4 => progress unfold in_cosetL : typeclass_instances. Hint Extern 4 => progress unfold in_cosetR : typeclass_instances. Global Arguments in_cosetL /. Global Arguments in_cosetR /. (** These are props *) Global Instance ishprop_in_cosetL : is_mere_relation G in_cosetL := _. Global Instance ishprop_in_cosetR : is_mere_relation G in_cosetR := _. (** In fact, they are both equivalence relations. *) Global Instance reflexive_in_cosetL : Reflexive in_cosetL. Proof. intro x; hnf. rewrite left_inverse. apply issubgroup_in_unit. Defined. Global Instance reflexive_in_cosetR : Reflexive in_cosetR. Proof. intro x; hnf. rewrite right_inverse. apply issubgroup_in_unit. Defined. Global Instance symmetric_in_cosetL : Symmetric in_cosetL. Proof. intros x y h; cbn; cbn in h. rewrite <- (grp_inv_inv x). rewrite <- grp_inv_op. apply issubgroup_in_inv; assumption. Defined. Global Instance symmetric_in_cosetR : Symmetric in_cosetR. Proof. intros x y h; cbn; cbn in h. rewrite <- (grp_inv_inv y). rewrite <- grp_inv_op. apply issubgroup_in_inv; assumption. Defined. Global Instance transitive_in_cosetL : Transitive in_cosetL. Proof. intros x y z h k; cbn; cbn in h; cbn in k. rewrite <- (right_identity x^). rewrite <- (right_inverse y : y * y^ = mon_unit). rewrite (associativity x^ _ _). rewrite <- simple_associativity. apply issubgroup_in_op; assumption. Defined. Global Instance transitive_in_cosetR : Transitive in_cosetR. Proof. intros x y z h k; cbn; cbn in h; cbn in k. rewrite <- (right_identity x). rewrite <- (left_inverse y : y^ * y = mon_unit). rewrite (simple_associativity x). rewrite <- (associativity _ _ z^). apply issubgroup_in_op; assumption. Defined. End Cosets. (** ** Properties of left and right cosets *) Definition in_cosetL_unit {G : Group} {N : Subgroup G} : forall x y, in_cosetL N (x^ * y) mon_unit <~> in_cosetL N x y. Proof. intros x y; cbn. rewrite (right_identity _^). rewrite (inverse_sg_op _). rewrite (inverse_involutive _). apply equiv_iff_hprop; apply symmetric_in_cosetL. Defined. Definition in_cosetR_unit {G : Group} {N : Subgroup G} : forall x y, in_cosetR N (x * y^) mon_unit <~> in_cosetR N x y. Proof. intros x y; cbn. rewrite inverse_mon_unit. rewrite (right_identity (x * y^)). reflexivity. Defined. (** Symmetry is an equivalence. *) Definition equiv_in_cosetL_symm {G : Group} {N : Subgroup G} : forall x y, in_cosetL N x y <~> in_cosetL N y x. Proof. intros x y. srapply equiv_iff_hprop. all: by intro. Defined. Definition equiv_in_cosetR_symm {G : Group} {N : Subgroup G} : forall x y, in_cosetR N x y <~> in_cosetR N y x. Proof. intros x y. srapply equiv_iff_hprop. all: by intro. Defined. (** The sigma type of a left coset is equivalent to the sigma type of the subgroup. *) Definition equiv_sigma_in_cosetL_subgroup (G : Group) (H : Subgroup G) (x : G) : sig (in_cosetL H x) <~> sig H. Proof. snrapply equiv_functor_sigma'. - rapply (Build_Equiv _ _ (x^ *.)). - reflexivity. Defined. (** The sigma type of a right coset is equivalent to the sigma type of the subgroup. *) Definition equiv_sigma_in_cosetR_subgroup (G : Group) (H : Subgroup G) (x : G) : sig (in_cosetR H x) <~> sig H. Proof. snrapply equiv_functor_sigma'. - rapply (Build_Equiv _ _ (.* x ^)). - simpl; intros y. apply equiv_subgroup_op_inv. Defined. (** ** Normal subgroups *) (** A normal subgroup is a subgroup closed under conjugation. *) Class IsNormalSubgroup {G : Group} (N : Subgroup G) := isnormal : forall {x y}, N (x * y) -> N (y * x). Record NormalSubgroup (G : Group) := { normalsubgroup_subgroup : Subgroup G ; normalsubgroup_isnormal : IsNormalSubgroup normalsubgroup_subgroup ; }. Arguments Build_NormalSubgroup G N _ : rename. Coercion normalsubgroup_subgroup : NormalSubgroup >-> Subgroup. Global Existing Instance normalsubgroup_isnormal. Definition equiv_symmetric_in_normalsubgroup {G : Group} (N : Subgroup G) `{!IsNormalSubgroup N} : forall x y, N (x * y) <~> N (y * x). Proof. intros x y. rapply equiv_iff_hprop. all: apply isnormal. Defined. (** Our definiiton of normal subgroup implies the usual definition of invariance under conjugation. *) Definition isnormal_conj {G : Group} (N : Subgroup G) `{!IsNormalSubgroup N} {x y : G} : N x <~> N (y * x * y^). Proof. srefine (equiv_symmetric_in_normalsubgroup N _ _ oE _). by rewrite grp_inv_V_gg. Defined. (** We can show a subgroup is normal if it is invariant under conjugation. *) Definition Build_IsNormalSubgroup' (G : Group) (N : Subgroup G) (isnormal : forall x y, N x -> N (y * x * y^)) : IsNormalSubgroup N. Proof. intros x y n. nrefine (transport N (grp_unit_r _) _). nrefine (transport (fun z => N (_ * z)) (grp_inv_r y) _). nrefine (transport N (grp_assoc _ _ _)^ _). nrefine (transport (fun z => N (z * _)) (grp_assoc _ _ _) _). by apply isnormal. Defined. (** Under funext, being a normal subgroup is a hprop. *) Global Instance ishprop_isnormalsubgroup `{Funext} {G : Group} (N : Subgroup G) : IsHProp (IsNormalSubgroup N). Proof. unfold IsNormalSubgroup; exact _. Defined. (** Our definition of normal subgroup and the usual definition are therefore equivalent. *) Definition equiv_isnormal_conjugate `{Funext} {G : Group} (N : Subgroup G) : IsNormalSubgroup N <~> (forall x y, N x -> N (y * x * y^)). Proof. rapply equiv_iff_hprop. - intros is_normal x y. rapply isnormal_conj. - intros is_normal'. by snrapply Build_IsNormalSubgroup'. Defined. (** Left and right cosets are equivalent in normal subgroups. *) Definition equiv_in_cosetL_in_cosetR_normalsubgroup {G : Group} (N : NormalSubgroup G) (x y : G) : in_cosetL N x y <~> in_cosetR N x y := equiv_in_cosetR_symm _ _ oE equiv_symmetric_in_normalsubgroup _ _ _. (** Inverses are then respected *) Definition in_cosetL_inverse {G : Group} {N : NormalSubgroup G} (x y : G) : in_cosetL N x^ y^ <~> in_cosetL N x y. Proof. refine (_ oE equiv_in_cosetL_in_cosetR_normalsubgroup _ _ _); cbn. by rewrite inverse_involutive. Defined. Definition in_cosetR_inverse {G : Group} {N : NormalSubgroup G} (x y : G) : in_cosetR N x^ y^ <~> in_cosetR N x y. Proof. refine (_ oE equiv_in_cosetL_in_cosetR_normalsubgroup _ _ _); cbn. by rewrite grp_inv_inv. Defined. (** This lets us prove that left and right coset relations are congruences. *) Definition in_cosetL_cong {G : Group} {N : NormalSubgroup G} (x x' y y' : G) : in_cosetL N x y -> in_cosetL N x' y' -> in_cosetL N (x * x') (y * y'). Proof. cbn; intros p q. (** rewrite goal before applying subgroup_op *) rewrite inverse_sg_op, <- simple_associativity. apply isnormal. rewrite simple_associativity, <- simple_associativity. apply subgroup_in_op. 1: exact p. apply isnormal. exact q. Defined. Definition in_cosetR_cong {G : Group} {N : NormalSubgroup G} (x x' y y' : G) : in_cosetR N x y -> in_cosetR N x' y' -> in_cosetR N (x * x') (y * y'). Proof. cbn; intros p q. (** rewrite goal before applying subgroup_op *) rewrite inverse_sg_op, simple_associativity. apply isnormal. rewrite <- simple_associativity, simple_associativity. apply subgroup_in_op. 2: exact q. apply isnormal. exact p. Defined. (** ** Trivial subgroup *) (** The trivial subgroup of a group [G]. *) Definition trivial_subgroup G : Subgroup G. Proof. rapply (Build_Subgroup' (fun x => x = 1)). 1: reflexivity. intros x y p q. rewrite p, q. rewrite left_identity. apply grp_inv_unit. Defined. (** The trivial subgroup is always included in any subgroup. *) Definition trivial_subgroup_rec {G : Group} (H : Subgroup G) : forall x, trivial_subgroup G x -> H x. Proof. snrapply paths_ind_r; cbn beta. apply issubgroup_in_unit. Defined. (** The trivial subgroup is a normal subgroup. *) Global Instance isnormal_trivial_subgroup {G : Group} : IsNormalSubgroup (trivial_subgroup G). Proof. intros x y p; cbn in p |- *. apply grp_moveL_1V in p. by apply grp_moveL_V1. Defined. (** The property of being the trivial subgroup. Note that any group can be automatically coerced to its maximal subgroup, so it makes sense for this predicate to be applied to groups in general. *) Class IsTrivialGroup@{i} {G : Group@{i}} (H : Subgroup@{i i} G) := istrivialgroup : forall x, H x -> trivial_subgroup G x. Global Instance ishprop_istrivialgroup `{F : Funext} {G : Group} (H : Subgroup G) : IsHProp (IsTrivialGroup H) := istrunc_forall. Global Instance istrivial_trivial_subgroup {G : Group} : IsTrivialGroup (trivial_subgroup G) := fun x => idmap. (** Trivial groups are isomorphic to the trivial group. *) Definition istrivial_iff_grp_iso_trivial {G : Group} (H : Subgroup G) : IsTrivialGroup H <-> (subgroup_group H $<~> grp_trivial). Proof. split. - intros triv. snrapply cate_adjointify. 1,2: exact grp_homo_const. + by intros []. + intros [x Hx]; simpl. apply path_sigma_hprop. symmetry. by apply triv. - intros e x Hx. change ((x; Hx).1 = (1; idpath).1). snrapply (pr1_path (u:=(_;_)) (v:=(_;_))). 1: apply subgroup_in_unit. rhs_V nrapply (grp_homo_unit e^-1$). apply moveL_equiv_V. apply path_contr. Defined. (** All trivial subgroups are isomorphic as groups. *) Definition grp_iso_trivial_subgroup (G H : Group) : subgroup_group (trivial_subgroup G) $<~> subgroup_group (trivial_subgroup H). Proof. snrefine (_^-1$ $oE _). 1: exact grp_trivial. 1,2: apply istrivial_iff_grp_iso_trivial; exact _. Defined. Definition istrivial_grp_iso {G H : Group} (J : Subgroup G) (K : Subgroup H) (e : subgroup_group J $<~> subgroup_group K) : IsTrivialGroup J -> IsTrivialGroup K. Proof. intros triv. apply istrivial_iff_grp_iso_trivial in triv. apply istrivial_iff_grp_iso_trivial. exact (triv $oE e^-1$). Defined. (** ** Maximal Subgroups *) (** Every group is a (maximal) subgroup of itself. *) Definition maximal_subgroup G : Subgroup G. Proof. rapply (Build_Subgroup G (fun x => Unit)). split; auto; exact _. Defined. (** We wish to coerce a group to its maximal subgroup. However, if we don't explicitly print [maximal_subgroup] things can get confusing, so we mark it as a coercion to be printed. *) Coercion maximal_subgroup : Group >-> Subgroup. Add Printing Coercion maximal_subgroup. (** The group associated to the maximal subgroup is the original group. Note that this equivalence does not characterize the maximal subgroup, as a proper subgroup can be isomorphic to the whole group. For example, the even integers are isomorphic to the integers. *) Definition grp_iso_subgroup_group_maximal (G : Group) : subgroup_group (maximal_subgroup G) $<~> G. Proof. snrapply Build_GroupIsomorphism'. - rapply equiv_sigma_contr. - hnf; reflexivity. Defined. (** The maximal subgroup (the group itself) is a normal subgroup. *) Global Instance isnormal_maximal_subgroup {G : Group} : IsNormalSubgroup (maximal_subgroup G). Proof. intros x y p; exact tt. Defined. (** The property of being a maximal subgroup of a group [G]. *) Class IsMaximalSubgroup {G : Group} (H : Subgroup G) := ismaximalsubgroup : forall (x : G), H x. Global Instance ishprop_ismaximalsubgroup `{Funext} {G : Group} (H : Subgroup G) : IsHProp (IsMaximalSubgroup H) := istrunc_forall. Global Instance ismaximalsubgroup_maximalsubgroup {G : Group} : IsMaximalSubgroup (maximal_subgroup G) := fun g => tt. (** ** Preimage subgroup *) (** The preimage of a subgroup under a group homomorphism is a subgroup. *) Definition subgroup_preimage {G H : Group} (f : G $-> H) (S : Subgroup H) : Subgroup G. Proof. snrapply Build_Subgroup'. - exact (S o f). - hnf; exact _. - nrefine (transport S (grp_homo_unit f)^ _). apply subgroup_in_unit. - hnf; intros x y Sfx Sfy. nrefine (transport S (grp_homo_op f _ _)^ _). nrapply subgroup_in_op; only 1: assumption. nrefine (transport S (grp_homo_inv f _)^ _). by apply subgroup_in_inv. Defined. (** The preimage of a normal subgroup is again normal. *) Global Instance isnormal_subgroup_preimage {G H : Group} (f : G $-> H) (N : Subgroup H) `{!IsNormalSubgroup N} : IsNormalSubgroup (subgroup_preimage f N). Proof. intros x y Nfxy; simpl. nrefine (transport N (grp_homo_op _ _ _)^ _). apply isnormal. exact (transport N (grp_homo_op _ _ _) Nfxy). Defined. (** ** Subgroup intersection *) (** Intersection of two subgroups *) Definition subgroup_intersection {G : Group} (H K : Subgroup G) : Subgroup G. Proof. snrapply Build_Subgroup'. 1: exact (fun g => H g /\ K g). 1: exact _. 1: split; apply subgroup_in_unit. intros x y [] []. split; by apply subgroup_in_op_inv. Defined. (** ** Simple groups *) Class IsSimpleGroup (G : Group) := is_simple_group : forall (N : Subgroup G) `{IsNormalSubgroup G N}, IsTrivialGroup N + IsMaximalSubgroup N. (** ** The subgroup generated by a subset *) (** Underlying type family of a subgroup generated by subset *) Inductive subgroup_generated_type {G : Group} (X : G -> Type) : G -> Type := (** The subgroup should contain all elements of the original family. *) | sgt_in (g : G) : X g -> subgroup_generated_type X g (** It should contain the unit. *) | sgt_unit : subgroup_generated_type X mon_unit (** Finally, it should be closed under inverses and operation. *) | sgt_op (g h : G) : subgroup_generated_type X g -> subgroup_generated_type X h -> subgroup_generated_type X (g * h^) . Arguments sgt_in {G X g}. Arguments sgt_unit {G X}. Arguments sgt_op {G X g h}. (** Note that [subgroup_generated_type] will not automatically land in [HProp]. For example, if [X] already "contains" the unit of the group, then there are at least two different inhabitants of this family at the unit (given by [sgt_unit] and [sgt_in group_unit _]). Therefore, we propositionally truncate in [subgroup_generated] below. *) (** Subgroups are closed under inverses. *) Definition sgt_inv {G : Group} {X} {g : G} : subgroup_generated_type X g -> subgroup_generated_type X g^. Proof. intros p. rewrite <- left_identity. exact (sgt_op sgt_unit p). Defined. Definition sgt_inv' {G : Group} {X} {g : G} : subgroup_generated_type X g^ -> subgroup_generated_type X g. Proof. intros p. rewrite <- grp_inv_inv. by apply sgt_inv. Defined. Definition sgt_op' {G : Group} {X} {g h : G} : subgroup_generated_type X g -> subgroup_generated_type X h -> subgroup_generated_type X (g * h). Proof. intros p q. rewrite <- (inverse_involutive h). exact (sgt_op p (sgt_inv q)). Defined. (** The subgroup generated by a subset *) Definition subgroup_generated {G : Group} (X : G -> Type) : Subgroup G. Proof. refine (Build_Subgroup' (merely o subgroup_generated_type X) (tr sgt_unit) _). intros x y p q; strip_truncations. exact (tr (sgt_op p q)). Defined. (** The inclusion of generators into the generated subgroup. *) Definition subgroup_generated_gen_incl {G : Group} {X : G -> Type} (g : G) (H : X g) : subgroup_generated X := (g; tr (sgt_in H)). (** The generated subgroup is the smallest subgroup containing the generating set. *) Definition subgroup_generated_rec {G : Group} (X : G -> Type) (S : Subgroup G) (i : forall g, X g -> S g) : forall g, subgroup_generated X g -> S g. Proof. intros g; rapply Trunc_rec; intros p. induction p as [g Xg | | g h p1 IHp1 p2 IHp2]. - by apply i. - apply subgroup_in_unit. - by apply subgroup_in_op_inv. Defined. (** If [f : G $-> H] is a group homomorphism and [X] and [Y] are subsets of [G] and [H] such that [f] maps [X] into [Y], then [f] sends the subgroup generated by [X] into the subgroup generated by [Y]. *) Definition functor_subgroup_generated {G H : Group} (X : G -> Type) (Y : H -> Type) (f : G $-> H) (preserves : forall g, X g -> Y (f g)) : forall g, subgroup_generated X g -> subgroup_generated Y (f g). Proof. change (subgroup_generated Y (f ?g)) with (subgroup_preimage f (subgroup_generated Y) g). apply subgroup_generated_rec. intros g p. apply tr, sgt_in. by apply preserves. Defined. (** The product of two subgroups. *) Definition subgroup_product {G : Group} (H K : Subgroup G) : Subgroup G := subgroup_generated (fun x => (H x + K x)%type). (** The induction principle for the product. *) Definition subgroup_product_ind {G : Group} (H K : Subgroup G) (P : forall x, subgroup_product H K x -> Type) (P_H_in : forall x y, P x (tr (sgt_in (inl y)))) (P_K_in : forall x y, P x (tr (sgt_in (inr y)))) (P_unit : P mon_unit (tr sgt_unit)) (P_op : forall x y h k, P x (tr h) -> P y (tr k) -> P (x * - y) (tr (sgt_op h k))) `{forall x y, IsHProp (P x y)} : forall x (p : subgroup_product H K x), P x p. Proof. intros x p. strip_truncations. induction p as [x s | | x y h IHh k IHk]. + destruct s. - apply P_H_in. - apply P_K_in. + exact P_unit. + by apply P_op. Defined. Definition subgroup_product_incl_l {G : Group} (H K : Subgroup G) : forall x, H x -> subgroup_product H K x := fun x => tr o sgt_in o inl. Definition subgroup_product_incl_r {G : Group} (H K : Subgroup G) : forall x, K x -> subgroup_product H K x := fun x => tr o sgt_in o inr. (** A product of normal subgroups is normal. *) Global Instance isnormal_subgroup_product {G : Group} (H K : Subgroup G) `{!IsNormalSubgroup H, !IsNormalSubgroup K} : IsNormalSubgroup (subgroup_product H K). Proof. snrapply Build_IsNormalSubgroup'. intros x y; revert x. nrapply (functor_subgroup_generated _ _ (grp_conj y)). intros x. apply functor_sum; rapply isnormal_conj. Defined. Definition normalsubgroup_product {G : Group} (H K : NormalSubgroup G) : NormalSubgroup G := Build_NormalSubgroup G (subgroup_product H K) _. (** *** Paths between generated subgroups *) (** This gets used twice in [path_subgroup_generated], so we factor it out here. *) Local Lemma path_subgroup_generated_helper {G : Group} (X Y : G -> Type) (K : forall g, merely (X g) -> merely (Y g)) : forall g, Trunc (-1) (subgroup_generated_type X g) -> Trunc (-1) (subgroup_generated_type Y g). Proof. intro g; apply Trunc_rec; intro ing. induction ing as [g x| |g h Xg IHYg Xh IHYh]. - exact (Trunc_functor (-1) sgt_in (K g (tr x))). - exact (tr sgt_unit). - strip_truncations. by apply tr, sgt_op. Defined. (** If the predicates selecting the generators are merely equivalent, then the generated subgroups are equal. (One could probably prove that the generated subgroup are isomorphic without using univalence.) *) Definition path_subgroup_generated `{Univalence} {G : Group} (X Y : G -> Type) (K : forall g, Trunc (-1) (X g) <-> Trunc (-1) (Y g)) : subgroup_generated X = subgroup_generated Y. Proof. rapply equiv_path_subgroup'. (* Uses Univalence. *) intro g; split. - apply path_subgroup_generated_helper, (fun x => fst (K x)). - apply path_subgroup_generated_helper, (fun x => snd (K x)). Defined. (** Equal subgroups have isomorphic underlying groups. *) Definition equiv_subgroup_group {G : Group} (H1 H2 : Subgroup G) : H1 = H2 -> GroupIsomorphism H1 H2 := ltac:(intros []; exact grp_iso_id). (** ** Image of a group homomorphism *) (** The image of a group homomorphism between groups is a subgroup. *) Definition grp_image {G H : Group} (f : G $-> H) : Subgroup H. Proof. srapply (Build_Subgroup' (fun y => hexists (fun x => f x = y))); cbn beta. - apply tr. exists 1. apply grp_homo_unit. - intros x y p q; strip_truncations; apply tr. destruct p as [a p], q as [b q]. exists (a * b^). lhs nrapply grp_homo_op; f_ap. lhs nrapply grp_homo_inv; f_ap. Defined. Definition grp_image_in {G H : Group} (f : G $-> H) : forall x, grp_image f (f x) := fun x => tr (x; idpath). Definition grp_homo_image_in {G H : Group} (f : G $-> H) : G $-> grp_image f := subgroup_corec f (grp_image_in f). (** ** Image of a group embedding *) (** When the homomorphism is an embedding, we don't need to truncate. *) Definition grp_image_embedding {G H : Group} (f : G $-> H) `{IsEmbedding f} : Subgroup H. Proof. snrapply (Build_Subgroup _ (hfiber f)). repeat split. - exact _. - exact (mon_unit; grp_homo_unit f). - intros x y [a []] [b []]. exists (a * b). apply grp_homo_op. - intros b [a []]. exists a^. apply grp_homo_inv. Defined. Definition grp_image_in_embedding {G H : Group} (f : G $-> H) `{IsEmbedding f} : GroupIsomorphism G (grp_image_embedding f). Proof. snrapply Build_GroupIsomorphism. - snrapply (subgroup_corec f). exact (fun x => (x; idpath)). - apply isequiv_surj_emb. 2: apply (cancelL_isembedding (g:=pr1)). intros [b [a p]]; cbn. rapply contr_inhabited_hprop. refine (tr (a; _)). srapply path_sigma'. 1: exact p. refine (transport_sigma' _ _ @ _). by apply path_sigma_hprop. Defined. (** The image of a surjective group homomorphism is the maximal subgroup. *) Global Instance ismaximal_image_issurj {G H : Group} (f : G $-> H) `{IsSurjection f} : IsMaximalSubgroup (grp_image f). Proof. rapply conn_map_elim. apply grp_image_in. Defined. (** ** Image of a subgroup under a group homomoprhism *) (** The image of a subgroup under group homomorphism. *) Definition subgroup_image {G H : Group} (f : G $-> H) : Subgroup G -> Subgroup H := fun K => grp_image (grp_homo_restr f K). (** By definition, values of [f x] where [x] is in a subgroup [J] are in the image of [J] under [f]. *) Definition subgroup_image_in {G H : Group} (f : G $-> H) (J : Subgroup G) : forall x, J x -> subgroup_image f J (f x) := fun x Jx => tr ((x; Jx); idpath). (** Converting the subgroups to groups, we get the expected surjective (epi) restriction homomorphism. *) Definition grp_homo_subgroup_image_in {G H : Group} (f : G $-> H) (J : Subgroup G) : subgroup_group J $-> subgroup_group (subgroup_image f J) := functor_subgroup_group f (subgroup_image_in _ _). (** The restriction map from the subgroup to the image is surjective as expected, by [conn_map_factor1_image]. *) Definition issurj_grp_homo_subgroup_image_in {G H : Group} (f : G $-> H) (J : Subgroup G) : IsSurjection (grp_homo_subgroup_image_in f J) := _. (** An image of a subgroup [J] is included in a subgroup [K] if (and only if) [J] is included in the preimage of the subgroup [K]. *) Definition subgroup_image_rec {G H : Group} (f : G $-> H) {J : Subgroup G} {K : Subgroup H} (g : forall x, J x -> K (f x)) : forall x, subgroup_image f J x -> K x. Proof. intros x; apply Trunc_rec; intros [[j Jj] p]. destruct p. exact (g j Jj). Defined. (** The image functor is adjoint to the preimage functor. *) Definition iff_subgroup_image_rec {G H : Group} (f : G $-> H) {J : Subgroup G} {K : Subgroup H} : (forall x, subgroup_image f J x -> K x) <-> (forall x, J x -> subgroup_preimage f K x). Proof. split. - intros rec x Jx. apply rec, tr. by exists (x; Jx). - snrapply subgroup_image_rec. Defined. (** [subgroup_image] preserves normal subgroups when the group homomorphism is surjective. *) Global Instance isnormal_subgroup_image {G H : Group} (f : G $-> H) (J : Subgroup G) `{!IsNormalSubgroup J} `{!IsSurjection f} : IsNormalSubgroup (subgroup_image f J). Proof. snrapply Build_IsNormalSubgroup'. intros x y; revert x. change (subgroup_image f J (y * ?x * y^)) with (subgroup_preimage (grp_conj y) (subgroup_image f J) x). snrapply subgroup_image_rec. intros x Jx. change (subgroup_image f J ((grp_conj y $o f) x)). revert y; rapply (conn_map_elim (Tr (-1)) f); intros y. rewrite <- grp_homo_conj. nrapply subgroup_image_in. by rapply isnormal_conj. Defined. (** ** Kernels of group homomorphisms *) Definition grp_kernel {G H : Group} (f : G $-> H) : NormalSubgroup G := Build_NormalSubgroup G (subgroup_preimage f (trivial_subgroup _)) _. (** Corecursion principle for group kernels *) Definition grp_kernel_corec {A B G : Group} {f : A $-> B} (g : G $-> A) (h : f $o g == grp_homo_const) : G $-> grp_kernel f. Proof. snrapply (subgroup_corec g); exact h. Defined. Definition equiv_grp_kernel_corec `{Funext} {A B G : Group} {f : A $-> B} : {g : G $-> A & f $o g == grp_homo_const} <~> (G $-> grp_kernel f) := equiv_subgroup_corec G (grp_kernel f). (** The underlying map of a group homomorphism with a trivial kernel is an embedding. *) Global Instance isembedding_istrivial_kernel {G H : Group} (f : G $-> H) (triv : IsTrivialGroup (grp_kernel f)) : IsEmbedding f. Proof. intros h. apply hprop_allpath. intros [x p] [y q]. srapply path_sigma_hprop; unfold pr1. apply grp_moveL_1M. apply triv; simpl. rhs_V nrapply (grp_inv_r h). lhs nrapply grp_homo_op. nrapply (ap011 (.*.) p). lhs nrapply grp_homo_inv. exact (ap (^) q). Defined. (** If the underlying map of a group homomorphism is an embedding then the kernel is trivial. *) Definition istrivial_kernel_isembedding {G H : Group} (f : G $-> H) (emb : IsEmbedding f) : IsTrivialGroup (grp_kernel f). Proof. intros g p. rapply (isinj_embedding f). exact (p @ (grp_homo_unit f)^). Defined. Global Hint Immediate istrivial_kernel_isembedding : typeclass_instances. (** Characterisation of group embeddings *) Proposition equiv_istrivial_kernel_isembedding `{F : Funext} {G H : Group} (f : G $-> H) : IsTrivialGroup (grp_kernel f) <~> IsEmbedding f. Proof. apply equiv_iff_hprop_uncurried. split; exact _. Defined. Coq-HoTT-9.0/theories/Algebra/Monoids/000077500000000000000000000000001474641544500175255ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/Monoids/Monoid.v000066400000000000000000000176761474641544500211620ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.Equivalences Basics.Trunc. Require Import Types.Sigma Types.Forall Types.Prod. Require Import WildCat.Core WildCat.Induced WildCat.Equiv WildCat.Universe WildCat.Products. Require Import (notations) Classes.interfaces.canonical_names. Require Export (hints) Classes.interfaces.abstract_algebra. Require Export (hints) Classes.interfaces.canonical_names. Require Export Classes.interfaces.canonical_names (SgOp, sg_op, MonUnit, mon_unit, LeftIdentity, left_identity, RightIdentity, right_identity, Associative, simple_associativity, associativity, LeftInverse, left_inverse, RightInverse, right_inverse, Commutative, commutativity). Export canonical_names.BinOpNotations. Require Export Classes.interfaces.abstract_algebra (IsSemiGroup(..), sg_set, sg_ass, IsMonoid(..), monoid_left_id, monoid_right_id, monoid_semigroup, IsMonoidPreserving(..), monmor_unitmor, monmor_sgmor, IsSemiGroupPreserving, preserves_sg_op, IsUnitPreserving, preserves_mon_unit). Local Set Polymorphic Inductive Cumulativity. Local Set Universe Minimization ToSet. Local Open Scope mc_mult_scope. (** * Monoids *) (** ** Definition *) Record Monoid := { monoid_type :> Type; monoid_sgop :: SgOp monoid_type; monoid_unit :: MonUnit monoid_type; monoid_ismonoid :: IsMonoid monoid_type; }. Arguments monoid_sgop {_}. Arguments monoid_unit {_}. Arguments monoid_ismonoid {_}. Global Opaque monoid_ismonoid. Definition issig_monoid : _ <~> Monoid := ltac:(issig). Section MonoidLaws. Context {M : Monoid} (x y z : M). Definition mnd_assoc := associativity x y z. Definition mnd_unit_l := left_identity x. Definition mnd_unit_r := right_identity x. End MonoidLaws. (** ** Monoid homomorphisms *) Record MonoidHomomorphism (M N : Monoid) := { mnd_homo_map :> monoid_type M -> monoid_type N; ismonoidpreserving_mnd_homo :: IsMonoidPreserving mnd_homo_map; }. Arguments mnd_homo_map {M N}. Arguments Build_MonoidHomomorphism {M N} _ _. Arguments ismonoidpreserving_mnd_homo {M N} f : rename. Definition issig_MonoidHomomorphism (M N : Monoid) : _ <~> MonoidHomomorphism M N := ltac:(issig). (** ** Basics properties of monoid homomorphisms *) Definition mnd_homo_op {M N : Monoid} (f : MonoidHomomorphism M N) : forall (x y : M), f (x * y) = f x * f y := monmor_sgmor. Definition mnd_homo_unit {M N : Monoid} (f : MonoidHomomorphism M N) : f mon_unit = mon_unit := monmor_unitmor. Definition equiv_path_monoidhomomorphism `{Funext} {M N : Monoid} {f g : MonoidHomomorphism M N} : f == g <~> f = g. Proof. refine ((equiv_ap (issig_MonoidHomomorphism M N)^-1 _ _)^-1 oE _). refine (equiv_path_sigma_hprop _ _ oE _). apply equiv_path_forall. Defined. Global Instance ishset_monoidhomomorphism `{Funext} {M N : Monoid} : IsHSet (MonoidHomomorphism M N). Proof. apply istrunc_S. intros f g; apply (istrunc_equiv_istrunc _ equiv_path_monoidhomomorphism). Defined. Definition mnd_homo_id {M : Monoid} : MonoidHomomorphism M M := Build_MonoidHomomorphism idmap _. Definition mnd_homo_compose {M N P : Monoid} : MonoidHomomorphism N P -> MonoidHomomorphism M N -> MonoidHomomorphism M P := fun f g => Build_MonoidHomomorphism (f o g) _. (** ** Monoid Isomorphisms *) Record MonoidIsomorphism (M N : Monoid) := { mnd_iso_homo :> MonoidHomomorphism M N; isequiv_mnd_iso :: IsEquiv mnd_iso_homo; }. Definition Build_MonoidIsomorphism' {M N : Monoid} (f : M <~> N) (h : IsMonoidPreserving f) : MonoidHomomorphism M N. Proof. snrapply Build_MonoidIsomorphism. 1: srapply Build_MonoidHomomorphism. exact _. Defined. Definition issig_MonoidIsomorphism (M N : Monoid) : _ <~> MonoidIsomorphism M N := ltac:(issig). Coercion equiv_mnd_iso {M N : Monoid} : MonoidIsomorphism M N -> M <~> N := fun f => Build_Equiv M N f _. Definition mnd_iso_id {M : Monoid} : MonoidIsomorphism M M := Build_MonoidIsomorphism _ _ mnd_homo_id _. Definition mnd_iso_compose {M N P : Monoid} : MonoidIsomorphism N P -> MonoidIsomorphism M N -> MonoidIsomorphism M P := fun g f => Build_MonoidIsomorphism _ _ (mnd_homo_compose g f) _. Definition mnd_iso_inverse {M N : Monoid} : MonoidIsomorphism M N -> MonoidIsomorphism N M := fun f => Build_MonoidIsomorphism _ _ (Build_MonoidHomomorphism f^-1 _) _. Global Instance reflexive_monoidisomorphism : Reflexive MonoidIsomorphism := fun M => mnd_iso_id. Global Instance symmetric_monoidisomorphism : Symmetric MonoidIsomorphism := fun M N => mnd_iso_inverse. Global Instance transitive_monoidisomorphism : Transitive MonoidIsomorphism := fun M N P f g => mnd_iso_compose g f. (** ** The category of monoids *) Global Instance isgraph_monoid : IsGraph Monoid := Build_IsGraph Monoid MonoidHomomorphism. Global Instance is01cat_monoid : Is01Cat Monoid := Build_Is01Cat Monoid _ (@mnd_homo_id) (@mnd_homo_compose). Local Notation mnd_homo_map' M N := (@mnd_homo_map M N : _ -> (monoid_type M $-> _)). Global Instance is2graph_monoid : Is2Graph Monoid := fun M N => isgraph_induced (mnd_homo_map' M N). Global Instance isgraph_monoidhomomorphism {M N : Monoid} : IsGraph (M $-> N) := isgraph_induced (mnd_homo_map' M N). Global Instance is01cat_monoidhomomorphism {M N : Monoid} : Is01Cat (M $-> N) := is01cat_induced (mnd_homo_map' M N). Global Instance is0gpd_monoidhomomorphism {M N : Monoid} : Is0Gpd (M $-> N) := is0gpd_induced (mnd_homo_map' M N). Global Instance is0functor_postcomp_monoidhomomorphism {M N P : Monoid} (h : N $-> P) : Is0Functor (@cat_postcomp Monoid _ _ M N P h). Proof. apply Build_Is0Functor. intros ? ? p a; exact (ap h (p a)). Defined. Global Instance is0functor_precomp_monoidhomomorphism {M N P : Monoid} (h : M $-> N) : Is0Functor (@cat_precomp Monoid _ _ M N P h). Proof. apply Build_Is0Functor. intros ? ? p; exact (p o h). Defined. Global Instance is1cat_monoid : Is1Cat Monoid. Proof. by rapply Build_Is1Cat. Defined. Global Instance hasequivs_monoid : HasEquivs Monoid. Proof. snrapply Build_HasEquivs. - exact MonoidIsomorphism. - exact (fun M N f => IsEquiv f). - intros M N f; exact f. - cbn; exact _. - exact Build_MonoidIsomorphism. - reflexivity. - intros M N; exact mnd_iso_inverse. - intros ????; apply eissect. - intros ????; apply eisretr. - intros M N; exact isequiv_adjointify. Defined. Global Instance is0functor_monoid_type : Is0Functor monoid_type := Build_Is0Functor _ _ _ _ monoid_type (@mnd_homo_map). Global Instance is1functor_monoid_type : Is1Functor monoid_type. Proof. by apply Build_Is1Functor. Defined. (** ** Direct product of monoids *) Definition mnd_prod : Monoid -> Monoid -> Monoid. Proof. intros M N. snrapply (Build_Monoid (M * N)). 3: repeat split. - intros [m1 n1] [m2 n2]. exact (m1 * m2, n1 * n2). - exact (mon_unit, mon_unit). - exact _. - intros x y z; snrapply path_prod; nrapply mnd_assoc. - intros x; snrapply path_prod; nrapply mnd_unit_l. - intros x; snrapply path_prod; nrapply mnd_unit_r. Defined. Definition mnd_prod_pr1 {M N : Monoid} : MonoidHomomorphism (mnd_prod M N) M. Proof. snrapply Build_MonoidHomomorphism. 1: exact fst. split; hnf; reflexivity. Defined. Definition mnd_prod_pr2 {M N : Monoid} : MonoidHomomorphism (mnd_prod M N) N. Proof. snrapply Build_MonoidHomomorphism. 1: exact snd. split; hnf; reflexivity. Defined. Definition mnd_prod_corec {M N P : Monoid} (f : MonoidHomomorphism P M) (g : MonoidHomomorphism P N) : MonoidHomomorphism P (mnd_prod M N). Proof. snrapply Build_MonoidHomomorphism. 2: split. - exact (fun x => (f x, g x)). - intros x y; snrapply path_prod; nrapply mnd_homo_op. - snrapply path_prod; nrapply mnd_homo_unit. Defined. Global Instance hasbinaryproducts_monoid : HasBinaryProducts Monoid. Proof. intros M N. snrapply Build_BinaryProduct. - exact (mnd_prod M N). - exact mnd_prod_pr1. - exact mnd_prod_pr2. - intros P; exact mnd_prod_corec. - intros P f g; exact (Id _). - intros P f g; exact (Id _). - intros P f g p q a; exact (path_prod' (p a) (q a)). Defined. Coq-HoTT-9.0/theories/Algebra/Rings.v000066400000000000000000000004521474641544500173670ustar00rootroot00000000000000(** Basic theory *) Require Export HoTT.Algebra.Rings.Ring. Require Export HoTT.Algebra.Rings.CRing. Require Export HoTT.Algebra.Rings.Ideal. Require Export HoTT.Algebra.Rings.QuotientRing. Require Export HoTT.Algebra.Rings.ChineseRemainder. (** Examples *) Require Export HoTT.Algebra.Rings.Z. Coq-HoTT-9.0/theories/Algebra/Rings/000077500000000000000000000000001474641544500171775ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/Rings/CRing.v000066400000000000000000000221661474641544500203770ustar00rootroot00000000000000Require Import WildCat. (* Some of the material in abstract_algebra and canonical names could be selectively exported to the user, as is done in Groups/Group.v. *) Require Import Classes.interfaces.abstract_algebra. Require Import Algebra.AbGroups. Require Export Algebra.Rings.Ring Algebra.Rings.Ideal Algebra.Rings.QuotientRing. (** * Commutative Rings *) Local Open Scope ring_scope. Local Open Scope wc_iso_scope. (** A commutative ring consists of the following data: *) Record CRing := { (** An underlying ring. *) cring_ring :> Ring; (** Such that they satisfy the axioms of a commutative ring. *) cring_commutative :: Commutative (A:=cring_ring) (.*.); }. Definition issig_CRing : _ <~> CRing := ltac:(issig). Global Instance cring_plus {R : CRing} : Plus R := plus_abgroup R. Global Instance cring_zero {R : CRing} : Zero R := zero_abgroup R. Global Instance cring_negate {R : CRing} : Negate R := negate_abgroup R. Definition Build_CRing' (R : AbGroup) `(!One R, !Mult R) (comm : Commutative (.*.)) (assoc : Associative (.*.)) (dist_l : LeftDistribute (.*.) (+)) (unit_l : LeftIdentity (.*.) 1) : CRing. Proof. snrapply Build_CRing. - rapply (Build_Ring R); only 1,2,4: exact _. + intros x y z. lhs nrapply comm. lhs rapply dist_l. f_ap. + intros x. lhs rapply comm. apply unit_l. - exact _. Defined. (** ** Properties of commutative rings *) Definition rng_mult_comm {R : CRing} (x y : R) : x * y = y * x := commutativity x y. (** Powers commute with multiplication *) Lemma rng_power_mult {R : CRing} (x y : R) (n : nat) : rng_power (R:=R) (x * y) n = rng_power (R:=R) x n * rng_power (R:=R) y n. Proof. induction n. 1: symmetry; rapply rng_mult_one_l. simpl. rewrite (rng_mult_assoc (A:=R)). rewrite <- (rng_mult_assoc (A:=R) x _ y). rewrite (rng_mult_comm (rng_power (R:=R) x n) y). rewrite rng_mult_assoc. rewrite <- (rng_mult_assoc _ (rng_power (R:=R) x n)). f_ap. Defined. Definition rng_mult_permute_2_3 {R : CRing} (x y z : R) : x * y * z = x * z * y. Proof. lhs_V nrapply rng_mult_assoc. rhs_V nrapply rng_mult_assoc. apply ap, rng_mult_comm. Defined. Definition rng_mult_move_left_assoc {R : CRing} (x y z : R) : x * y * z = y * x * z. Proof. f_ap; apply rng_mult_comm. Defined. Definition rng_mult_move_right_assoc {R : CRing} (x y z : R) : x * (y * z) = y * (x * z). Proof. refine (rng_mult_assoc _ _ _ @ _ @ (rng_mult_assoc _ _ _)^). apply rng_mult_move_left_assoc. Defined. Definition isinvertible_cring (R : CRing) (x : R) (inv : R) (inv_l : inv * x = 1) : IsInvertible R x. Proof. snrapply Build_IsInvertible. - exact inv. - exact inv_l. - lhs nrapply rng_mult_comm. exact inv_l. Defined. (** ** Ideals in commutative rings *) Section IdealCRing. Context {R : CRing}. (** The section is meant to complement the IdealLemmas section in Algebra.Rings.Ideal. Since the results here only hold in commutative rings, they have to be kept here. *) (** We import ideal notations as used in Algebra.Rings.Ideal but only for this section. Important to note is that [↔] corresponds to equality of ideals. *) Import Ideal.Notation. Local Open Scope ideal_scope. (** In a commutative ring, the product of two ideals is a subset of the reversed product. *) Lemma ideal_product_subset_product_commutative (I J : Ideal R) : I ⋅ J ⊆ J ⋅ I. Proof. intros r p. strip_truncations. induction p as [r p | |]. 2: apply ideal_in_zero. 2: by apply ideal_in_plus_negate. destruct p as [s t p q]. rewrite rng_mult_comm. apply tr. apply sgt_in. by rapply ipn_in. Defined. (** Ideal products are commutative in commutative rings. Note that we are using ideal notations here and [↔] corresponds to equality of ideals. Essentially a subset in each direction. *) Lemma ideal_product_comm (I J : Ideal R) : I ⋅ J ↔ J ⋅ I. Proof. apply ideal_subset_antisymm; apply ideal_product_subset_product_commutative. Defined. (** Product of intersection and sum is a subset of product. Note that this is a generalization of lcm * gcd = product *) Lemma ideal_product_intersection_sum_subset' (I J : Ideal R) : (I ∩ J) ⋅ (I + J) ⊆ I ⋅ J. Proof. etransitivity. 2: rapply ideal_sum_self. etransitivity. 2: rapply ideal_sum_subset_pres_r. 2: rapply ideal_product_comm. apply ideal_product_intersection_sum_subset. Defined. (** If the sum of ideals is the whole ring then their intersection is a subset of their product. *) Lemma ideal_intersection_subset_product (I J : Ideal R) : ideal_unit R ⊆ (I + J) -> I ∩ J ⊆ I ⋅ J. Proof. intros p. etransitivity. { apply ideal_eq_subset. symmetry. apply ideal_product_unit_r. } etransitivity. 1: rapply (ideal_product_subset_pres_r _ _ _ p). rapply ideal_product_intersection_sum_subset'. Defined. (** This can be combined into a sufficient (but not necessary) condition for equality of intersections and products. *) Lemma ideal_intersection_is_product (I J : Ideal R) : Coprime I J -> I ∩ J ↔ I ⋅ J. Proof. intros p. apply ideal_subset_antisymm. - apply ideal_intersection_subset_product. unfold Coprime in p. apply symmetry in p. rapply p. - apply ideal_product_subset_intersection. Defined. Lemma ideal_quotient_product (I J K : Ideal R) : (I :: J) :: K ↔ (I :: (J ⋅ K)). Proof. apply ideal_subset_antisymm. - intros x [p q]; strip_truncations; split; apply tr; intros r; rapply Trunc_rec; intros jk. + induction jk as [y [z z' j k] | | ? ? ? ? ? ? ]. * rewrite (rng_mult_comm z z'). rewrite rng_mult_assoc. destruct (p z' k) as [p' ?]. revert p'; apply Trunc_rec; intros p'. exact (p' z j). * change (I (x * 0)). rewrite rng_mult_zero_r. apply ideal_in_zero. * change (I (x * (g - h))). rewrite rng_dist_l. rewrite rng_mult_negate_r. by apply ideal_in_plus_negate. + induction jk as [y [z z' j k] | | ? ? ? ? ? ? ]. * change (I (z * z' * x)). rewrite <- rng_mult_assoc. rewrite (rng_mult_comm z). destruct (q z' k) as [q' ?]. revert q'; apply Trunc_rec; intros q'. exact (q' z j). * change (I (0 * x)). rewrite rng_mult_zero_l. apply ideal_in_zero. * change (I ((g - h) * x)). rewrite rng_dist_r. rewrite rng_mult_negate_l. by apply ideal_in_plus_negate. - intros x [p q]; strip_truncations; split; apply tr; intros r k; split; apply tr; intros z j. + rewrite <- rng_mult_assoc. rewrite (rng_mult_comm r z). by apply p, tr, sgt_in, ipn_in. + cbn in z. change (I (z * (x * r))). rewrite (rng_mult_comm x). rewrite rng_mult_assoc. by apply q, tr, sgt_in, ipn_in. + cbn in r. change (I (r * x * z)). rewrite <- rng_mult_assoc. rewrite (rng_mult_comm r). rewrite <- rng_mult_assoc. by apply p, tr, sgt_in, ipn_in. + cbn in r, z. change (I (z * (r * x))). rewrite rng_mult_assoc. rewrite rng_mult_comm. by apply p, tr, sgt_in, ipn_in. Defined. (** The ideal quotient is a right adjoint to the product in the monoidal lattice of ideals. *) Lemma ideal_quotient_subset_prod (I J K : Ideal R) : I ⋅ J ⊆ K <-> I ⊆ (K :: J). Proof. split. - intros p r i; split; apply tr; intros s j; cbn in s, r. + by apply p, tr, sgt_in, ipn_in. + change (K (s * r)). rewrite (rng_mult_comm s r). by apply p, tr, sgt_in; rapply ipn_in. - intros p x. apply Trunc_rec. intros q. induction q as [r x | | ]. { destruct x. specialize (p x s); destruct p as [p q]. revert p; apply Trunc_rec; intros p. by apply p. } 1: apply ideal_in_zero. by apply ideal_in_plus_negate. Defined. (** Ideal quotients partially cancel *) Lemma ideal_quotient_product_left (I J : Ideal R) : (I :: J) ⋅ J ⊆ I. Proof. by apply ideal_quotient_subset_prod. Defined. End IdealCRing. (** ** Category of commutative rings. *) Global Instance isgraph_CRing : IsGraph CRing := isgraph_induced cring_ring. Global Instance is01cat_CRing : Is01Cat CRing := is01cat_induced cring_ring. Global Instance is2graph_CRing : Is2Graph CRing := is2graph_induced cring_ring. Global Instance is1cat_CRing : Is1Cat CRing := is1cat_induced cring_ring. Global Instance hasequiv_CRing : HasEquivs CRing := hasequivs_induced cring_ring. (** ** Quotient rings *) Global Instance commutative_quotientring_mult (R : CRing) (I : Ideal R) : Commutative (A:=QuotientRing R I) (.*.). Proof. intros x; srapply QuotientRing_ind_hprop; intros y; revert x. srapply QuotientRing_ind_hprop; intros x; hnf. lhs_V nrapply rng_homo_mult. rhs_V nrapply rng_homo_mult. snrapply ap. apply commutativity. Defined. Definition cring_quotient (R : CRing) (I : Ideal R) : CRing := Build_CRing (QuotientRing R I) _. Definition cring_quotient_map {R : CRing} (I : Ideal R) : R $-> cring_quotient R I := rng_quotient_map I. Coq-HoTT-9.0/theories/Algebra/Rings/ChineseRemainder.v000066400000000000000000000136401474641544500225770ustar00rootroot00000000000000Require Import Classes.interfaces.canonical_names. Require Import WildCat. Require Import Modalities.ReflectiveSubuniverse. Require Import Algebra.AbGroups. Require Import Algebra.Rings.Ring. Require Import Algebra.Rings.Ideal. Require Import Algebra.Rings.QuotientRing. Require Import Algebra.Rings.CRing. (** * Chinese remainder theorem *) Import Ideal.Notation. Local Open Scope ring_scope. Local Open Scope wc_iso_scope. Section ChineseRemainderTheorem. (** We assume [Univalence] in order to work with quotients. We also need it for [Funext] in a few places.*) Context `{Univalence} (** We need two coprime ideals [I] and [J] to state the theorem. We don't introduce the coprimeness assumption as of yet in order to show something slightly stronger. *) {R : Ring} (I J : Ideal R). (** We begin with the homomorphism which will show to be a surjection. Using the first isomorphism theorem for rings we can improve this to be the isomorphism we want. *) (** This is the corecursion of the two quotient maps *) Definition rng_homo_crt : R $-> (R / I) × (R / J). Proof. apply ring_product_corec. 1,2: apply rng_quotient_map. Defined. (** Since we are working with quotients, we make the following notation to make working with the proof somewhat easier. *) Local Notation "[ x ]" := (rng_quotient_map _ x). (** We then need to prove the following lemma. The hypotheses here can be derived by coprimality of [I] and [J]. But we don't need that here. *) Lemma issurjection_rng_homo_crt' (x y : R) (q1 : rng_homo_crt x = (0, 1)) (q2 : rng_homo_crt y = (1, 0)) : IsSurjection rng_homo_crt. Proof. (** In order to show that [rng_homo_crt] is a surjection, we need to show that its propositional truncation of the fiber at any point is contractible. *) intros [a b]. revert a; srapply QuotientRing_ind_hprop; intro a. revert b; srapply QuotientRing_ind_hprop; intro b. (** We can think of [a] and [b] as the pair [(a mod I, b mod J)]. We need to show that there merely exists some element in [R] that gets mapped by [rng_homo_crt] to the pair. *) snrapply Build_Contr; [|intros z; strip_truncations; apply path_ishprop]. (** We make this choice and show it maps as desired. *) apply tr; exists (b * x + a * y). (** Finally using some simple ring laws we can show it maps to our pair. *) rewrite rng_homo_plus. rewrite 2 rng_homo_mult. rewrite q1, q2. apply path_prod. + change ([b] * 0 + [a] * 1 = [a] :> R / I). by rewrite rng_mult_one_r, rng_mult_zero_r, rng_plus_zero_l. + change ([b] * 1 + [a] * 0 = [b] :> R / J). by rewrite rng_mult_one_r, rng_mult_zero_r, rng_plus_zero_r. Defined. (** Now we show that if [x + y = 1] for [I x] and [J y] then we can satisfy the hypotheses of the previous lemma. *) Section rng_homo_crt_beta. Context (x y : R) (ix : I x) (iy : J y) (p : x + y = 1). Lemma rng_homo_crt_beta_left : rng_homo_crt x = (0, 1). Proof. apply rng_moveR_Mr in p. rewrite rng_plus_comm in p. apply path_prod; apply qglue. - change (I (-x + 0)). apply ideal_in_negate_plus. 1: assumption. apply ideal_in_zero. - change (J (-x + 1)). rewrite rng_plus_comm. by rewrite <- p. Defined. Lemma rng_homo_crt_beta_right : rng_homo_crt y = (1, 0). Proof. apply rng_moveR_rM in p. rewrite rng_plus_comm in p. apply path_prod; apply qglue. - change (I (-y + 1)). by rewrite <- p. - change (J (-y + 0)). apply ideal_in_negate_plus. 1: assumption. apply ideal_in_zero. Defined. End rng_homo_crt_beta. (** We can now show the map is surjective from coprimality of [I] and [J]. *) Global Instance issurjection_rng_homo_crt : Coprime I J -> IsSurjection rng_homo_crt. Proof. intros c. (** First we turn the coprimality assumption into an equivalent assumption about the mere existence of two elements of each ideal which sum to one. *) apply equiv_coprime_sum in c. (** Since the goal is a hprop we may strip the truncations. *) strip_truncations. (** Now we can break apart the data of this witness. *) destruct c as [[[x ix] [y jy]] p]; change (x + y = 1) in p. (** Now we apply all our previous lemmas *) apply (issurjection_rng_homo_crt' x y). 1: exact (rng_homo_crt_beta_left x y ix jy p). exact (rng_homo_crt_beta_right x y ix jy p). Defined. (** Now suppose [I] and [J] are coprime. *) Context (c : Coprime I J). (** The Chinese Remainder Theorem *) Theorem chinese_remainder : R / (I ∩ J)%ideal ≅ (R / I) × (R / J). Proof. (** We use the first isomorphism theorem. Coq can already infer which map we wish to use, so for clarity we tell it not to do so. *) snrapply rng_first_iso'. 1: rapply rng_homo_crt. 1: exact _. (** Finally we must show the ideal of this map is the intersection. *) apply ideal_subset_antisymm. - intros r [i j]. apply path_prod; apply qglue. 1: change (I (- r + 0)). 2: change (J (- r + 0)). 1,2: rewrite rng_plus_comm. 1,2: apply ideal_in_plus_negate. 1,3: apply ideal_in_zero. 1,2: assumption. - intros i p. apply equiv_path_prod in p. destruct p as [p q]. apply ideal_in_negate'. rewrite <- rng_plus_zero_r. (** Here we need to derive the relation from paths in the quotient. This is what requires univalence. *) split. 1: exact (related_quotient_paths _ _ _ p). 1: exact (related_quotient_paths _ _ _ q). Defined. End ChineseRemainderTheorem. (** We also have the same for products of ideals when in a commuatative ring. *) Theorem chinese_remainder_prod `{Univalence} {R : CRing} (I J : Ideal R) (c : Coprime I J) : R / (I ⋅ J)%ideal ≅ (R / I) × (R / J). Proof. etransitivity. { rapply rng_quotient_invar. symmetry. rapply ideal_intersection_is_product. } rapply chinese_remainder. Defined. Coq-HoTT-9.0/theories/Algebra/Rings/Ideal.v000066400000000000000000001257351474641544500204210ustar00rootroot00000000000000Require Import Basics Types. Require Import Spaces.Finite.Fin. Require Import Classes.interfaces.canonical_names. Require Import Algebra.Rings.Ring. Require Import Algebra.Groups.Subgroup. Require Import Algebra.AbGroups.AbelianGroup. Require Import WildCat.Core. Declare Scope ideal_scope. Delimit Scope ideal_scope with ideal. Local Open Scope ideal_scope. (** * Left, Right and Two-sided Ideals *) (** ** Definition of Ideals *) (** An additive subgroup [I] of a ring [R] is a left ideal when it is closed under multiplciation on the left. *) Class IsLeftIdeal {R : Ring} (I : Subgroup R) := isleftideal (r x : R) : I x -> I (r * x). (** An additive subgroup [I] of a ring [R] is a right ideal when it is closed under multiplication on the right. We define this using the opposite ring allowing us to reduce redundancy between left and right ideals. *) Class IsRightIdeal {R : Ring} (I : Subgroup R) := isrightideal_isleftideal_op :: IsLeftIdeal (R := rng_op R) I. Definition isrightideal {R : Ring} (I : Subgroup R) (x r : R) : IsRightIdeal I -> I x -> I (x * r) := fun _ => isleftideal (R := rng_op R) r x. (** An additive subgroup [I] of a ring [R] is a two-sided ideal when it is both a left and right ideal. In this case we just call it an ideal. *) Class IsIdeal {R : Ring} (I : Subgroup R) := { ideal_isleftideal :: IsLeftIdeal I; ideal_isrightideal :: IsRightIdeal I; }. Definition issig_IsIdeal {R : Ring} (I : Subgroup R) : _ <~> IsIdeal I := ltac:(issig). Hint Immediate Build_IsIdeal : typeclass_instances. (** Any two-sided ideal is also a two-sided ideal of the opposite ring. *) Global Instance isideal_op {R : Ring} (I : Subgroup R) : IsIdeal I -> IsIdeal (R := rng_op R) I. Proof. intros [? ?]; exact _. Defined. (** A left ideal of a ring [R] is a subgroup [I] of [R] which is closed under left multiplication. *) Record LeftIdeal (R : Ring) := { leftideal_subgroup :> Subgroup R; leftideal_isleftideal :: IsLeftIdeal leftideal_subgroup; }. Definition issig_LeftIdeal (R : Ring) : _ <~> LeftIdeal R := ltac:(issig). (** A right ideal of a ring [R] is a subgroup [I] of [R] which is closed under right multiplication. *) Definition RightIdeal (R : Ring) := LeftIdeal (rng_op R). Global Instance isrightdeal_rightideal {R} (I : RightIdeal R) : IsRightIdeal (R:=R) I := leftideal_isleftideal _ I. Definition Build_RightIdeal (R : Ring) (I : Subgroup R) (H : IsRightIdeal I) : RightIdeal R := Build_LeftIdeal (rng_op R) I H. Definition issig_RightIdeal (R : Ring) : {I : Subgroup R& IsRightIdeal (R:=R) I} <~> RightIdeal R := ltac:(issig). (** A two-sided ideal of a ring [R], or just an ideal, is a subgroup [I] of [R] which is closed under both left and right multiplication. *) Record Ideal (R : Ring) := { ideal_subgroup :> Subgroup R; ideal_isideal :: IsIdeal ideal_subgroup; }. Definition issig_Ideal (R : Ring) : _ <~> Ideal R := ltac:(issig). Definition ideal_op (R : Ring) : Ideal R -> Ideal (rng_op R) := fun I => Build_Ideal (rng_op R) I _. Coercion ideal_op : Ideal >-> Ideal. (** *** Truncatedness properties *) Section IdealTrunc. (** Assuming [Funext] we can show that the ideal predicates are propositions. *) Context `{Funext}. (** Being a left ideal is a proposition. *) Global Instance ishprop_isleftideal {R : Ring} (I : Subgroup R) : IsHProp (IsLeftIdeal I) := ltac:(unfold IsLeftIdeal; exact _). (** Being a right ideal is a proposition. *) Global Instance ishprop_isrightideal `{Funext} {R : Ring} (I : Subgroup R) : IsHProp (IsRightIdeal I) := ishprop_isleftideal _. (** Being a two-sided ideal is a proposition. *) Global Instance ishprop_isideal {R : Ring} (I : Subgroup R) : IsHProp (IsIdeal I) := istrunc_equiv_istrunc _ (issig_IsIdeal I). (** Assuming [Univalence] we can show that the ideal types are sets. Note that univalence is only used to prove that the type of [Subgroup]s is a set. *) Context `{Univalence}. (** The type of left ideals is a set. *) Global Instance ishset_leftideal {R : Ring} : IsHSet (LeftIdeal R) := istrunc_equiv_istrunc _ (issig_LeftIdeal R). (** The type of right ideals is a set. *) Global Instance ishset_rightideal {R : Ring} : IsHSet (RightIdeal R) := _. (** The type of ideals is a set. *) Global Instance ishset_ideal {R : Ring} : IsHSet (Ideal R) := istrunc_equiv_istrunc _ (issig_Ideal R). End IdealTrunc. (** *** Conversion between Ideals *) (** Every ideal is a left ideal. *) Definition leftideal_of_ideal {R : Ring} : Ideal R -> LeftIdeal R := fun I => Build_LeftIdeal R I _. Coercion leftideal_of_ideal : Ideal >-> LeftIdeal. (** Every ideal is a right ideal. *) Definition rightideal_of_ideal {R : Ring} : Ideal R -> RightIdeal R := fun I => Build_RightIdeal R I _. Coercion rightideal_of_ideal : Ideal >-> RightIdeal. (** *** Easy properties of ideals *) (** Here are some lemmas for proving certain elements are in an ideal. They are just special cases of the underlying subgroup lemmas. We write them out for clarity. Note that [I] isn't actually assumed to be an ideal but only a subgroup. *) Section IdealElements. Context {R : Ring} (I : Subgroup R) (a b : R). Definition ideal_in_zero : I ring_zero := subgroup_in_unit I. Definition ideal_in_plus : I a -> I b -> I (a + b) := subgroup_in_op I a b. Definition ideal_in_negate : I a -> I (- a) := subgroup_in_inv I a. Definition ideal_in_negate' : I (- a) -> I a := subgroup_in_inv' I a. Definition ideal_in_plus_negate : I a -> I b -> I (a - b) := subgroup_in_op_inv I a b. Definition ideal_in_negate_plus : I a -> I b -> I (-a + b) := subgroup_in_inv_op I a b. Definition ideal_in_plus_l : I (a + b) -> I b -> I a := subgroup_in_op_l I a b. Definition ideal_in_plus_r : I (a + b) -> I a -> I b := subgroup_in_op_r I a b. End IdealElements. (** ** Constructions of ideals *) (** *** Zero Ideal *) (** The trivial subgroup is a left ideal. *) Global Instance isleftideal_trivial_subgroup (R : Ring) : IsLeftIdeal (trivial_subgroup R). Proof. intros r x p. rhs_V nrapply (rng_mult_zero_r). f_ap. Defined. (** The trivial subgroup is a right ideal. *) Global Instance isrightideal_trivial_subgroup (R : Ring) : IsRightIdeal (trivial_subgroup R) := isleftideal_trivial_subgroup _. (** The trivial subgroup is an ideal. *) Global Instance isideal_trivial_subgroup (R : Ring) : IsIdeal (trivial_subgroup R) := {}. (** We call the trivial subgroup the "zero ideal". *) Definition ideal_zero (R : Ring) : Ideal R := Build_Ideal R _ _. (** *** The unit ideal *) (** The maximal subgroup is a left ideal. *) Global Instance isleftideal_maximal_subgroup (R : Ring) : IsLeftIdeal (maximal_subgroup R) := ltac:(done). (** The maximal subgroup is a right ideal. *) Global Instance isrightideal_maximal_subgroup (R : Ring) : IsRightIdeal (maximal_subgroup R) := isleftideal_maximal_subgroup _. (** The maximal subgroup is an ideal. *) Global Instance isideal_maximal_subgroup (R : Ring) : IsIdeal (maximal_subgroup R) := {}. (** We call the maximal subgroup the "unit ideal". *) Definition ideal_unit (R : Ring) : Ideal R := Build_Ideal R _ (isideal_maximal_subgroup R). (** *** Intersection of ideals *) (** Intersections of underlying subgroups of left ideals are again left ideals. *) Global Instance isleftideal_subgroup_intersection (R : Ring) (I J : Subgroup R) `{IsLeftIdeal R I, IsLeftIdeal R J} : IsLeftIdeal (subgroup_intersection I J). Proof. intros r x [a b]; split; by apply isleftideal. Defined. (** Intersections of underlying subgroups of right ideals are again right ideals. *) Global Instance isrightideal_subgroup_intersection (R : Ring) (I J : Subgroup R) `{IsRightIdeal R I, IsRightIdeal R J} : IsRightIdeal (subgroup_intersection I J) := isleftideal_subgroup_intersection _ _ _. (** Intersections of underlying subgroups of ideals are again ideals. *) Global Instance isideal_subgroup_intersection (R : Ring) (I J : Subgroup R) `{IsIdeal R I, IsIdeal R J} : IsIdeal (subgroup_intersection I J) := {}. (** Intersection of left ideals. *) Definition leftideal_intersection {R : Ring} : LeftIdeal R -> LeftIdeal R -> LeftIdeal R := fun I J => Build_LeftIdeal R (subgroup_intersection I J) _. (** Intersection of right ideals. *) Definition rightideal_intersection {R : Ring} : RightIdeal R -> RightIdeal R -> RightIdeal R := leftideal_intersection. (** Intersection of ideals. *) Definition ideal_intersection {R : Ring} : Ideal R -> Ideal R -> Ideal R := fun I J => Build_Ideal R (subgroup_intersection I J) _. (** *** Sum of ideals *) (** The subgroup product of left ideals is again an ideal. *) Global Instance isleftideal_subgroup_product (R : Ring) (I J : Subgroup R) `{IsLeftIdeal R I, IsLeftIdeal R J} : IsLeftIdeal (subgroup_product I J). Proof. intros r. nrapply subgroup_product_ind. - intros x p. apply tr, sgt_in. left; by apply isleftideal. - intros x p. apply tr, sgt_in. right; by apply isleftideal. - apply tr, sgt_in. left; apply isleftideal. apply ideal_in_zero. - intros x y p q IHp IHq; cbn beta. rewrite rng_dist_l. rewrite rng_mult_negate_r. by apply subgroup_in_op_inv. - exact _. Defined. (** The subgroup product of right ideals is again an ideal. *) Global Instance isrightideal_subgroup_product (R : Ring) (I J : Subgroup R) `{IsRightIdeal R I, IsRightIdeal R J} : IsRightIdeal (subgroup_product I J) := isleftideal_subgroup_product _ _ _. (** The subgroup product of ideals is again an ideal. *) Global Instance isideal_subgroup_product (R : Ring) (I J : Subgroup R) `{IsIdeal R I, IsIdeal R J} : IsIdeal (subgroup_product I J) := {}. (** Sum of left ideals. *) Definition leftideal_sum {R : Ring} : LeftIdeal R -> LeftIdeal R -> LeftIdeal R := fun I J => Build_LeftIdeal R (subgroup_product I J) _. (** Sum of right ideals. *) Definition rightideal_sum {R : Ring} : RightIdeal R -> RightIdeal R -> RightIdeal R := leftideal_sum. (** Sum of ideals. *) Definition ideal_sum {R : Ring} : Ideal R -> Ideal R -> Ideal R := fun I J => Build_Ideal R (subgroup_product I J) _. Definition ideal_sum_ind {R : Ring} (I J : Ideal R) (P : forall x, ideal_sum I J x -> Type) (P_I_in : forall x y, P x (tr (sgt_in (inl y)))) (P_J_in : forall x y, P x (tr (sgt_in (inr y)))) (P_unit : P mon_unit (tr sgt_unit)) (P_op : forall x y h k, P x (tr h) -> P y (tr k) -> P (x - y) (tr (sgt_op h k))) `{forall x y, IsHProp (P x y)} : forall x (p : ideal_sum I J x), P x p := subgroup_product_ind I J P P_I_in P_J_in P_unit P_op. (** *** Product of ideals *) (** First we form the "naive" product of ideals { a * b | a ∈ I /\ b ∈ J }. Note that this is not an ideal, but we can fix this. *) Inductive ideal_product_naive_type {R : Ring} (I J : Subgroup R) : R -> Type := | ipn_in : forall x y, I x -> J y -> ideal_product_naive_type I J (x * y). (** We instead consider the subgroup generated by this naive product and later prove it happens to be an ideal. Note that the subgroup generated by a set and the ideal generated by a set are not the same in general. *) Definition ideal_product_type {R : Ring} (I J : Subgroup R) : Subgroup R := subgroup_generated (G := R) (ideal_product_naive_type I J). (** The product of left ideals is a left ideal. *) Global Instance isleftideal_ideal_product_type {R : Ring} (I J : Subgroup R) `{IsLeftIdeal R I, IsLeftIdeal R J} : IsLeftIdeal (ideal_product_type I J). Proof. intro r. nrapply (functor_subgroup_generated _ _ (grp_homo_rng_left_mult r)). intros s [s1 s2 p1 p2]; cbn. rewrite simple_associativity. nrefine (ipn_in I J (r * s1) s2 _ p2). by apply isleftideal. Defined. (** The product of right ideals is a right ideal. *) Global Instance isrightideal_ideal_product_type {R : Ring} (I J : Subgroup R) `{IsRightIdeal R I, IsRightIdeal R J} : IsRightIdeal (ideal_product_type I J). Proof. intro r. nrapply (functor_subgroup_generated _ _ (grp_homo_rng_right_mult (R:=R) r)). intros s [s1 s2 p1 p2]; cbn. rewrite <- simple_associativity. nrefine (ipn_in I J s1 (s2 * r) p1 _). by apply isrightideal. Defined. (** The product of ideals is an ideal. *) Global Instance isideal_ideal_product_type {R : Ring} (I J : Subgroup R) `{IsIdeal R I, IsIdeal R J} : IsIdeal (ideal_product_type I J) := {}. (** Product of left ideals. *) Definition leftideal_product {R : Ring} : LeftIdeal R -> LeftIdeal R -> LeftIdeal R := fun I J => Build_LeftIdeal R (ideal_product_type I J) _. (** Product of right ideals. *) Definition rightideal_product {R : Ring} : RightIdeal R -> RightIdeal R -> RightIdeal R := leftideal_product. (** Product of ideals. *) Definition ideal_product {R : Ring} : Ideal R -> Ideal R -> Ideal R := fun I J => Build_Ideal R (ideal_product_type I J) _. (** *** The kernel of a ring homomorphism *) (** The kernel of the underlying group homomorphism of a ring homomorphism is a left ideal. *) Global Instance isleftideal_grp_kernel {R S : Ring} (f : RingHomomorphism R S) : IsLeftIdeal (grp_kernel f). Proof. intros r x p. lhs nrapply rng_homo_mult. rhs_V nrapply (rng_mult_zero_r (f r)). by apply ap. Defined. (** The kernel of the underlying group homomorphism of a ring homomorphism is a right ideal. *) Global Instance isrightideal_grp_kernel {R S : Ring} (f : RingHomomorphism R S) : IsRightIdeal (grp_kernel f) := isleftideal_grp_kernel (fmap rng_op f). (** The kernel of the underlying group homomorphism of a ring homomorphism is an ideal. *) Global Instance isideal_grp_kernel {R S : Ring} (f : RingHomomorphism R S) : IsIdeal (grp_kernel f) := {}. (** The kernel of a ring homomorphism is an ideal. *) Definition ideal_kernel {R S : Ring} (f : RingHomomorphism R S) : Ideal R := Build_Ideal R (grp_kernel f) _. (** *** Ideal generated by a subset *) (** It seems tempting to define ideals generated by a subset in terms of subgroups generated by a subset but this does not work. Left ideals also have to be closed under left multiplciation by ring elements, and similarly for right and two sided ideals. Therefore we will do an analagous construction to the one done in Subgroup.v. *) (** Underlying type family of a left ideal generated by subset. *) Inductive leftideal_generated_type (R : Ring) (X : R -> Type) : R -> Type := (** It should contain all elements of the original family. *) | ligt_in (r : R) : X r -> leftideal_generated_type R X r (** It should contain zero. *) | ligt_zero : leftideal_generated_type R X ring_zero (** It should be closed under negation and addition. *) | ligt_add_neg (r s : R) : leftideal_generated_type R X r -> leftideal_generated_type R X s -> leftideal_generated_type R X (r - s) (** And finally, it should be closed under left multiplication. *) | ligt_mul (r s : R) : leftideal_generated_type R X s -> leftideal_generated_type R X (r * s) . Arguments leftideal_generated_type {R} X r. Arguments ligt_in {R X r}. Arguments ligt_zero {R X}. Arguments ligt_add_neg {R X r s}. Arguments ligt_mul {R X r s}. (** Left ideal generated by a subset. *) Definition leftideal_generated@{u v} {R : Ring@{u}} (X : R -> Type@{v}) : LeftIdeal@{u v} R. Proof. snrapply Build_LeftIdeal. - snrapply Build_Subgroup'. + exact (fun x => merely (leftideal_generated_type X x)). + exact _. + apply tr, ligt_zero. + intros x y p q; strip_truncations. by apply tr, ligt_add_neg. - intros r x; apply Trunc_functor. apply ligt_mul. Defined. (** Right ideal generated by a subset. *) Definition rightideal_generated@{u v} {R : Ring@{u}} (X : R -> Type@{v}) : RightIdeal@{u v} R := Build_RightIdeal R (leftideal_generated (R:=rng_op R) X) _. (** Underlying type family of a two-sided ideal generated by subset. *) Inductive ideal_generated_type (R : Ring) (X : R -> Type) : R -> Type := (** It should contain all elements of the original family. *) | igt_in (r : R) : X r -> ideal_generated_type R X r (** It should contain zero. *) | igt_zero : ideal_generated_type R X ring_zero (** It should be closed under negation and addition. *) | igt_add_neg (r s : R) : ideal_generated_type R X r -> ideal_generated_type R X s -> ideal_generated_type R X (r - s) (** And finally, it should be closed under left and right multiplication. *) | igt_mul_l (r s : R) : ideal_generated_type R X s -> ideal_generated_type R X (r * s) | igt_mul_r (r s : R) : ideal_generated_type R X r -> ideal_generated_type R X (r * s) . Arguments ideal_generated_type {R} X r. Arguments igt_in {R X r}. Arguments igt_zero {R X}. Arguments igt_add_neg {R X r s}. Arguments igt_mul_l {R X r s}. Arguments igt_mul_r {R X r s}. (** Two-sided ideal generated by a subset. *) Definition ideal_generated {R : Ring} (X : R -> Type) : Ideal R. Proof. snrapply Build_Ideal; [|split]. - snrapply Build_Subgroup'. + exact (fun x => merely (ideal_generated_type X x)). + exact _. + apply tr, igt_zero. + intros x y p q; strip_truncations. by apply tr, igt_add_neg. - intros r x; apply Trunc_functor. nrapply igt_mul_l. - intros x r; apply Trunc_functor. nrapply igt_mul_r. Defined. (** *** Finitely generated ideal *) (** Finitely generated ideals *) Definition ideal_generated_finite {R : Ring} {n : nat} (X : Fin n -> R) : Ideal R. Proof. apply ideal_generated. exact (hfiber X). Defined. (** *** Principal ideals *) (** A principal ideal is an ideal generated by a single element. *) Definition ideal_principal {R : Ring} (x : R) : Ideal R := ideal_generated (fun r => x = r). (** *** Ideal equality *) (** Classically, set based equality suffices for ideals. Since we are talking about predicates, we use pointwise iffs. This can of course be shown to be equivalent to the identity type. *) Definition ideal_eq {R : Ring} (I J : Subgroup R) := forall x, I x <-> J x. (** With univalence we can characterize equality of ideals. *) Lemma equiv_path_ideal `{Univalence} {R : Ring} {I J : Ideal R} : ideal_eq I J <~> I = J. Proof. refine ((equiv_ap' (issig_Ideal R)^-1 _ _)^-1 oE _). refine (equiv_path_sigma_hprop _ _ oE _). rapply equiv_path_subgroup'. Defined. (** Under funext, ideal equiality is a proposition. *) Global Instance ishprop_ideal_eq `{Funext} {R : Ring} (I J : Ideal R) : IsHProp (ideal_eq I J) := _. (** Ideal equality is reflexive. *) Global Instance reflexive_ideal_eq {R : Ring} : Reflexive (@ideal_eq R). Proof. intros I x; by split. Defined. (** Ideal equality is symmetric. *) Global Instance symmetric_ideal_eq {R : Ring} : Symmetric (@ideal_eq R). Proof. intros I J p x; specialize (p x); by symmetry. Defined. (** Ideal equality is transitive. *) Global Instance transitive_ideal_eq {R : Ring} : Transitive (@ideal_eq R). Proof. intros I J K p q x; specialize (p x); specialize (q x); by transitivity (J x). Defined. (** *** Subset relation on ideals *) (** We define the subset relation on ideals in the usual way: *) Definition ideal_subset {R : Ring} (I J : Subgroup R) := (forall x, I x -> J x). (** The subset relation is reflexive. *) Global Instance reflexive_ideal_subset {R : Ring} : Reflexive (@ideal_subset R) := fun _ _ => idmap. (** The subset relation is transitive. *) Global Instance transitive_ideal_subset {R : Ring} : Transitive (@ideal_subset R). Proof. intros x y z p q a. exact (q a o p a). Defined. (** We can coerce equality to the subset relation, since equality is defined to be the subset relation in each direction. *) Coercion ideal_eq_subset {R : Ring} {I J : Subgroup R} : ideal_eq I J -> ideal_subset I J. Proof. intros f x; apply f. Defined. (** *** Quotient (a.k.a colon) ideals *) (** The definitions here are not entirely standard, but will become so when considering only commutative rings. For the non-commutative case there isn't a lot written about ideal quotients. *) (** The subgroup corresponding to the left ideal quotient. *) Definition subgroup_leftideal_quotient {R : Ring} (I J : Subgroup R) : Subgroup R. Proof. snrapply Build_Subgroup'. - exact (fun r => merely (forall x, J x -> I (r * x))). - exact _. - apply tr. intros r p. rewrite rng_mult_zero_l. apply ideal_in_zero. - intros x y p q. strip_truncations; apply tr. hnf; intros s j. rewrite rng_dist_r. rewrite rng_mult_negate_l. apply ideal_in_plus_negate. + by apply p. + by apply q. Defined. (** The left ideal quotient of a left ideal is a left ideal. *) Global Instance isleftideal_subgroup_leftideal_quotient {R : Ring} (I J : Subgroup R) `{IsLeftIdeal R I} : IsLeftIdeal (subgroup_leftideal_quotient I J). Proof. intros r x p. strip_truncations; apply tr. intros s j. rewrite <- rng_mult_assoc. apply isleftideal. by nrapply p. Defined. (** The left ideal quotient of a right ideal by a left ideal is a right ideal. *) Global Instance isrightideal_subgroup_leftideal_quotient {R : Ring} (I J : Subgroup R) `{IsRightIdeal R I, IsLeftIdeal R J} : IsRightIdeal (subgroup_leftideal_quotient (R:=R) I J). Proof. intros r x p. strip_truncations; apply tr. intros s j. cbn in *. rewrite <- rng_mult_assoc. apply p. by rapply isleftideal. Defined. (** We define the left ideal quotient as a left ideal. *) Definition leftideal_quotient {R : Ring} : LeftIdeal R -> Subgroup R -> LeftIdeal R := fun I J => Build_LeftIdeal R (subgroup_leftideal_quotient I J) _. Definition subgroup_rightideal_quotient {R : Ring} (I J : Subgroup R) : Subgroup R := subgroup_leftideal_quotient (R:=rng_op R) I J. Global Instance isrightideal_subgroup_rightideal_quotient {R : Ring} (I J : Subgroup R) `{IsRightIdeal R I} : IsRightIdeal (subgroup_rightideal_quotient I J) := isleftideal_subgroup_leftideal_quotient (R:=rng_op R) I J. Global Instance isleftideal_subgroup_rightideal_quotient {R : Ring} (I J : Subgroup R) `{H : IsLeftIdeal R I, IsRightIdeal R J} : IsLeftIdeal (subgroup_rightideal_quotient I J). Proof. snrapply (isrightideal_subgroup_leftideal_quotient (R:=rng_op R) I J). - exact H. - exact _. Defined. (** We define the right ideal quotient as a right ideal. *) Definition rightideal_quotient {R : Ring} : RightIdeal R -> Subgroup R -> RightIdeal R := fun I J => Build_RightIdeal R (subgroup_rightideal_quotient (R:=R) I J) _. (** The ideal quotient is then the intersection of a left and right quotient of both two sided ideals. *) Definition ideal_quotient {R : Ring} : Ideal R -> Ideal R -> Ideal R := fun I J => Build_Ideal R (subgroup_intersection (leftideal_quotient I J) (rightideal_quotient I J)) (Build_IsIdeal _ _ _ _). (** *** Annihilator *) (** The left annihilator of a subset is the set of elements that annihilate the subgroup with left multiplication. *) Definition subgroup_ideal_left_annihilator {R : Ring} (S : R -> Type) : Subgroup R. Proof. snrapply Build_Subgroup'. (** If we assume [Funext], then it isn't necessary to use [merely] here. *) - exact (fun r => merely (forall x, S x -> r * x = ring_zero)). - exact _. - apply tr. intros r p. apply rng_mult_zero_l. - intros x y p q. strip_truncations; apply tr. intros r s. lhs rapply rng_dist_r. rewrite (p r s). rewrite rng_mult_negate_l. rewrite (q r s). rewrite <- rng_mult_negate. rewrite rng_mult_zero_r. apply left_identity. Defined. (** The left annihilator of a subgroup of a ring is a left ideal of the ring. *) Global Instance isleftideal_ideal_left_annihilator {R : Ring} (I : R -> Type) : IsLeftIdeal (subgroup_ideal_left_annihilator I). Proof. intros r x p. strip_truncations; apply tr. intros s i. rewrite <- rng_mult_assoc, (p s i). apply rng_mult_zero_r. Defined. (** The left annihilator of a left ideal also happens to be a right ideal. In fact, left ideal could be weakened to subset closed under multplication, however we don't need this generality currently. *) Global Instance isrightideal_ideal_left_annihilator {R : Ring} (I : Subgroup R) `{IsLeftIdeal R I} : IsRightIdeal (subgroup_ideal_left_annihilator I). Proof. intros r x p. strip_truncations; apply tr. intros s i; cbn. rewrite <- rng_mult_assoc. by apply p, isleftideal. Defined. (** Therefore the annihilator of a left ideal is an ideal. *) Global Instance isideal_ideal_left_annihilator {R : Ring} (I : Subgroup R) `{IsLeftIdeal R I} : IsIdeal (subgroup_ideal_left_annihilator I) := {}. (** The left annihilator of a left ideal. *) Definition ideal_left_annihilator {R : Ring} (I : LeftIdeal R) : Ideal R := Build_Ideal R (subgroup_ideal_left_annihilator I) _. (** The right annihilator of a subset of a ring is the set of elements that annihilate the elements of the subset with right multiplication. *) Definition subgroup_ideal_right_annihilator {R : Ring} (I : R -> Type) : Subgroup R := subgroup_ideal_left_annihilator (R:=rng_op R) I. (** When the subset is a right ideal the right annihilator is a left ideal of the ring. This can be strengthened. See the comment in the left ideal version of this lemma above. *) Global Instance isleftideal_ideal_right_annihilator {R : Ring} (I : Subgroup R) `{IsRightIdeal R I} : IsLeftIdeal (subgroup_ideal_right_annihilator I) := isrightideal_ideal_left_annihilator (R:=rng_op R) I. (** The right annihilator is a right ideal of the ring. *) Global Instance isrightideal_ideal_right_annihilator {R : Ring} (I : R -> Type) : IsRightIdeal (subgroup_ideal_right_annihilator (R:=R) I) := isleftideal_ideal_left_annihilator (R:=rng_op R) I. (** Therefore the annihilator of a right ideal is an ideal. *) Global Instance isideal_ideal_right_annihilator {R : Ring} (I : Subgroup R) `{IsRightIdeal R I} : IsIdeal (subgroup_ideal_right_annihilator (R:=R) I) := {}. (** The right annihilator of a right ideal. *) Definition ideal_right_annihilator {R : Ring} (I : RightIdeal R) : Ideal R := Build_Ideal R (subgroup_ideal_right_annihilator (R:=R) I) (isideal_ideal_right_annihilator (R:=R) I). (** The annihilator of an ideal is the intersection of the left and right annihilators. *) Definition ideal_annihilator {R : Ring} (I : Ideal R) : Ideal R := ideal_intersection (ideal_left_annihilator I) (ideal_right_annihilator I). (** ** Properties of ideals *) (** *** Coprime ideals *) (** Two ideals are coprime if their sum is the unit ideal. *) Definition Coprime {R : Ring} (I J : Ideal R) : Type := ideal_eq (ideal_sum I J) (ideal_unit R). Existing Class Coprime. Global Instance ishprop_coprime `{Funext} {R : Ring} (I J : Ideal R) : IsHProp (Coprime I J). Proof. unfold Coprime. exact _. Defined. Lemma equiv_coprime_sum `{Funext} {R : Ring} (I J : Ideal R) : Coprime I J <~> hexists (fun '(((i ; p) , (j ; q)) : sig I * sig J) => i + j = ring_one). Proof. simpl. srapply equiv_iff_hprop. - intros c. pose (snd (c ring_one) tt) as d; clearbody d; clear c. strip_truncations. apply tr. induction d. + destruct x. * exists ((g ; s), (ring_zero; ideal_in_zero _)). apply rng_plus_zero_r. * exists ((ring_zero; ideal_in_zero _), (g ; s)). apply rng_plus_zero_l. + exists ((ring_zero; ideal_in_zero _), (ring_zero; ideal_in_zero _)). apply rng_plus_zero_l. + destruct IHd1 as [[[x xi] [y yj]] p]. destruct IHd2 as [[[w wi] [z zj]] q]. srefine (((_;_),(_;_));_). * exact (x - w). * by apply ideal_in_plus_negate. * exact (y - z). * by apply ideal_in_plus_negate. * cbn. rhs_V nrapply (ap011 (fun x y => x - y) p q). lhs_V nrapply rng_plus_assoc. rhs_V nrapply rng_plus_assoc. f_ap. rewrite rng_negate_plus. rhs_V nrapply rng_plus_comm. rhs_V nrapply rng_plus_assoc. f_ap. apply commutativity. - intro x. strip_truncations. intros r. split;[intro; exact tt|]. intros _. destruct x as [[[x xi] [y yj]] p]. rewrite <- rng_mult_one_r. change (x + y = 1) in p. rewrite <- p. rewrite rng_dist_l. apply tr. rapply sgt_op'. + apply sgt_in. left. by apply isleftideal. + apply sgt_in. right. by apply isleftideal. Defined. (** *** Ideal notations *) (** We declare and import a module for various (unicode) ideal notations. These exist in their own special case, and can be imported and used in other files when needing to reason about ideals. *) Module Import Notation. Infix "⊆" := ideal_subset : ideal_scope. Infix "↔" := ideal_eq : ideal_scope. Infix "+" := ideal_sum : ideal_scope. Infix "⋅" := ideal_product : ideal_scope. Infix "∩" := ideal_intersection : ideal_scope. Infix "::" := ideal_quotient : ideal_scope. Notation "〈 X 〉" := (ideal_generated X) : ideal_scope. Notation Ann := ideal_annihilator. End Notation. (** *** Ideal lemmas *) Section IdealLemmas. Context {R : Ring}. (** Subset relation is antisymmetric. *) Lemma ideal_subset_antisymm (I J : Subgroup R) : I ⊆ J -> J ⊆ I -> I ↔ J. Proof. intros p q x; split; by revert x. Defined. (** The zero ideal is contained in all ideals. *) Lemma ideal_zero_subset (I : Subgroup R) : ideal_zero R ⊆ I. Proof. intros x p; rewrite p; apply ideal_in_zero. Defined. (** The unit ideal contains all ideals. *) Lemma ideal_unit_subset (I : Subgroup R) : I ⊆ ideal_unit R. Proof. hnf; cbn; trivial. Defined. (** Intersection includes into the left *) Lemma ideal_intersection_subset_l (I J : Ideal R) : I ∩ J ⊆ I. Proof. intro; exact fst. Defined. (** Intersection includes into the right *) Lemma ideal_intersection_subset_r (I J : Ideal R) : I ∩ J ⊆ J. Proof. intro; exact snd. Defined. (** Subsets of intersections *) Lemma ideal_intersection_subset (I J K : Ideal R) : K ⊆ I -> K ⊆ J -> K ⊆ I ∩ J. Proof. intros p q x r; specialize (p x r); specialize (q x r); by split. Defined. (** Ideals include into their sum on the left *) Lemma ideal_sum_subset_l (I J : Ideal R) : I ⊆ (I + J). Proof. intros x p. apply tr, sgt_in. left; exact p. Defined. (** Ideals include into their sum on the right *) Lemma ideal_sum_subset_r (I J : Ideal R) : J ⊆ (I + J). Proof. intros x p. apply tr, sgt_in. right; exact p. Defined. #[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances. (** Products of ideals are included in their left factor *) Lemma ideal_product_subset_l (I J : Ideal R) : I ⋅ J ⊆ I. Proof. intros r p. strip_truncations. induction p as [r i | | r s p1 IHp1 p2 IHp2 ]. + destruct i as [s t]. by rapply isrightideal. + rapply ideal_in_zero. + by rapply ideal_in_plus_negate. Defined. (** Products of ideals are included in their right factor. *) Lemma ideal_product_subset_r (I J : Ideal R) : I ⋅ J ⊆ J. Proof. intros r p. strip_truncations. induction p as [r i | | r s p1 IHp1 p2 IHp2 ]. + destruct i as [s t]. by apply isleftideal. + rapply ideal_in_zero. + by rapply ideal_in_plus_negate. Defined. (** Products of ideals preserve subsets on the left *) Lemma ideal_product_subset_pres_l (I J K : Ideal R) : I ⊆ J -> I ⋅ K ⊆ J ⋅ K. Proof. intros p r q. strip_truncations. induction q as [r i | | r s ]. + destruct i. apply tr, sgt_in, ipn_in. 1: apply p. 1,2: assumption. + apply ideal_in_zero. + by apply ideal_in_plus_negate. Defined. (** Products of ideals preserve subsets on the right *) Lemma ideal_product_subset_pres_r (I J K : Ideal R) : I ⊆ J -> K ⋅ I ⊆ K ⋅ J. Proof. intros p r q. strip_truncations. induction q as [r i | | r s ]. + destruct i. apply tr, sgt_in, ipn_in. 2: apply p. 1,2: assumption. + apply ideal_in_zero. + by apply ideal_in_plus_negate. Defined. (** TODO: *) (** The product of ideals is an associative operation. *) (* Lemma ideal_product_assoc (I J K : Ideal R) : I ⋅ (J ⋅ K) ↔ (I ⋅ J) ⋅ K. Proof. intros r; split; apply Trunc_functor. Abort. *) (** Products of ideals are subsets of their intersection. *) Lemma ideal_product_subset_intersection (I J : Ideal R) : I ⋅ J ⊆ I ∩ J. Proof. apply ideal_intersection_subset. + apply ideal_product_subset_l. + apply ideal_product_subset_r. Defined. (** Sums of ideals are the smallest ideal containing the summands. *) Lemma ideal_sum_smallest (I J K : Ideal R) : I ⊆ K -> J ⊆ K -> (I + J) ⊆ K. Proof. intros p q. refine (ideal_sum_ind I J (fun x _ => K x) p q _ _). 1: apply ideal_in_zero. intros y z s t. rapply ideal_in_plus_negate. Defined. (** Ideals absorb themselves under sum. *) Lemma ideal_sum_self (I : Ideal R) : I + I ↔ I. Proof. apply ideal_subset_antisymm. 1: by rapply ideal_sum_smallest. rapply ideal_sum_subset_l. Defined. (** Sums preserve inclusions in the left summand. *) Lemma ideal_sum_subset_pres_l (I J K : Ideal R) : I ⊆ J -> (I + K) ⊆ (J + K). Proof. intros p. apply ideal_sum_smallest. { transitivity J. 1: exact p. apply ideal_sum_subset_l. } apply ideal_sum_subset_r. Defined. (** Sums preserve inclusions in the right summand. *) Lemma ideal_sum_subset_pres_r (I J K : Ideal R) : I ⊆ J -> (K + I) ⊆ (K + J). Proof. intros p. apply ideal_sum_smallest. 1: apply ideal_sum_subset_l. transitivity J. 1: exact p. apply ideal_sum_subset_r. Defined. (** Products left distribute over sums *) (** Note that this follows from left adjoints preserving colimits. The product of ideals is a functor whose right adjoint is the quotient ideal. *) Lemma ideal_dist_l (I J K : Ideal R) : I ⋅ (J + K) ↔ I ⋅ J + I ⋅ K. Proof. (** We split into two directions. *) apply ideal_subset_antisymm. (** We deal with the difficult inclusion first. The proof comes down to breaking down the definition and reassembling into the right. *) { intros r p. strip_truncations. induction p as [ r i | | r s p1 IHp1 p2 IHp2]. - destruct i as [r s p q]. strip_truncations. induction q as [ t k | | t k p1 IHp1 p2 IHp2 ]. + apply tr, sgt_in. destruct k as [j | k]. * left; by apply tr, sgt_in, ipn_in. * right; by apply tr, sgt_in, ipn_in. + apply tr, sgt_in; left. rewrite rng_mult_zero_r. apply ideal_in_zero. + rewrite rng_dist_l. rewrite rng_mult_negate_r. by apply ideal_in_plus_negate. - apply ideal_in_zero. - by apply ideal_in_plus_negate. } (** This is the easy direction which can use previous lemmas. *) apply ideal_sum_smallest. 1,2: apply ideal_product_subset_pres_r. 1: apply ideal_sum_subset_l. apply ideal_sum_subset_r. Defined. (** Products distribute over sums on the right. *) (** The proof is very similar to the left version *) Lemma ideal_dist_r (I J K : Ideal R) : (I + J) ⋅ K ↔ I ⋅ K + J ⋅ K. Proof. apply ideal_subset_antisymm. { intros r p. strip_truncations. induction p as [ r i | | r s p1 IHp1 p2 IHp2]. - destruct i as [r s p q]. strip_truncations. induction p as [ t k | | t k p1 IHp1 p2 IHp2 ]. + apply tr, sgt_in. destruct k as [j | k]. * left; by apply tr, sgt_in, ipn_in. * right; by apply tr, sgt_in, ipn_in. + apply tr, sgt_in; left. rewrite rng_mult_zero_l. apply ideal_in_zero. + rewrite rng_dist_r. rewrite rng_mult_negate_l. by apply ideal_in_plus_negate. - apply ideal_in_zero. - by apply ideal_in_plus_negate. } apply ideal_sum_smallest. 1,2: apply ideal_product_subset_pres_l. 1: apply ideal_sum_subset_l. apply ideal_sum_subset_r. Defined. (** Ideal sums are commutative *) Lemma ideal_sum_comm (I J : Ideal R) : I + J ↔ J + I. Proof. apply ideal_subset_antisymm; apply ideal_sum_smallest. 1,3: apply ideal_sum_subset_r. 1,2: apply ideal_sum_subset_l. Defined. (** Zero ideal is left additive identity. *) Lemma ideal_sum_zero_l I : ideal_zero R + I ↔ I. Proof. apply ideal_subset_antisymm. 1: apply ideal_sum_smallest. 1: apply ideal_zero_subset. 1: reflexivity. apply ideal_sum_subset_r. Defined. (** Zero ideal is right additive identity. *) Lemma ideal_sum_zero_r I : I + ideal_zero R ↔ I. Proof. apply ideal_subset_antisymm. 1: apply ideal_sum_smallest. 1: reflexivity. 1: apply ideal_zero_subset. apply ideal_sum_subset_l. Defined. (** Unit ideal is left multiplicative identity. *) Lemma ideal_product_unit_l I : ideal_unit R ⋅ I ↔ I. Proof. apply ideal_subset_antisymm. 1: apply ideal_product_subset_r. intros r p. rewrite <- rng_mult_one_l. by apply tr, sgt_in, ipn_in. Defined. (** Unit ideal is right multiplicative identity. *) Lemma ideal_product_unit_r I : I ⋅ ideal_unit R ↔ I. Proof. apply ideal_subset_antisymm. 1: apply ideal_product_subset_l. intros r p. rewrite <- rng_mult_one_r. by apply tr, sgt_in, ipn_in. Defined. (** Intersecting with unit ideal on the left does nothing. *) Lemma ideal_intresection_unit_l I : ideal_unit R ∩ I ↔ I. Proof. apply ideal_subset_antisymm. 1: apply ideal_intersection_subset_r. apply ideal_intersection_subset. 1: apply ideal_unit_subset. reflexivity. Defined. (** Intersecting with unit ideal on right does nothing. *) Lemma ideal_intersection_unit_r I : I ∩ ideal_unit R ↔ I. Proof. apply ideal_subset_antisymm. 1: apply ideal_intersection_subset_l. apply ideal_intersection_subset. 1: reflexivity. apply ideal_unit_subset. Defined. (** Product of intersection and sum is subset of sum of products *) Lemma ideal_product_intersection_sum_subset (I J : Ideal R) : (I ∩ J) ⋅ (I + J) ⊆ (I ⋅ J + J ⋅ I). Proof. etransitivity. 1: rapply ideal_dist_l. etransitivity. 1: rapply ideal_sum_subset_pres_r. 1: rapply ideal_product_subset_pres_l. 1: apply ideal_intersection_subset_l. etransitivity. 1: rapply ideal_sum_subset_pres_l. 1: rapply ideal_product_subset_pres_l. 1: apply ideal_intersection_subset_r. rapply ideal_sum_comm. Defined. (** Ideals are subsets of their ideal quotients *) Lemma ideal_quotient_subset (I J : Ideal R) : I ⊆ (I :: J). Proof. intros x i; split; apply tr; intros r j; cbn. - by rapply isrightideal. - by rapply isleftideal. Defined. (** If J divides I then the ideal quotient of J by I is trivial. *) Lemma ideal_quotient_trivial (I J : Ideal R) : I ⊆ J -> J :: I ↔ ideal_unit R. Proof. intros p. apply ideal_subset_antisymm. 1: cbv; trivial. intros r _; split; apply tr; intros x q; cbn. - by apply isleftideal, p. - rapply isrightideal. by apply p. Defined. (** The ideal quotient of I by unit is I. *) Lemma ideal_quotient_unit_bottom (I : Ideal R) : (I :: ideal_unit R) ↔ I. Proof. apply ideal_subset_antisymm. - intros r [p q]. strip_truncations. rewrite <- rng_mult_one_r. exact (p ring_one tt). - apply ideal_quotient_subset. Defined. (** The ideal quotient of unit by I is unit. *) Lemma ideal_quotient_unit_top (I : Ideal R) : (ideal_unit R :: I) ↔ ideal_unit R. Proof. split. - cbn; trivial. - intros ?; split; apply tr; cbn; split; trivial. Defined. (** The ideal quotient by a sum is an intersection of ideal quotients. *) Lemma ideal_quotient_sum (I J K : Ideal R) : (I :: (J + K)) ↔ (I :: J) ∩ (I :: K). Proof. apply ideal_subset_antisymm. { intros r [p q]; strip_truncations; split; split; apply tr; intros x jk. - by rapply p; rapply ideal_sum_subset_l. - by rapply q; rapply ideal_sum_subset_l. - by rapply p; rapply ideal_sum_subset_r. - by rapply q; rapply ideal_sum_subset_r. } intros r [[p q] [u v]]; strip_truncations; split; apply tr; intros x jk; strip_truncations. - induction jk as [? [] | | ? ? ? ? ? ? ]. + by apply p. + by apply u. + apply u, ideal_in_zero. + rewrite rng_dist_l. rewrite rng_mult_negate_r. by apply ideal_in_plus_negate. - induction jk as [? [] | | ? ? ? ? ? ? ]. + by apply q. + by apply v. + apply v, ideal_in_zero. + change (I ((g - h) * r)). rewrite rng_dist_r. rewrite rng_mult_negate_l. by apply ideal_in_plus_negate. Defined. (** Ideal quotients distribute over intersections. *) Lemma ideal_quotient_intersection (I J K : Ideal R) : (I ∩ J :: K) ↔ (I :: K) ∩ (J :: K). Proof. apply ideal_subset_antisymm. - intros r [p q]; strip_truncations; split; split; apply tr; intros x k. 1,3: by apply p. 1,2: by apply q. - intros r [[p q] [u v]]. strip_truncations; split; apply tr; intros x k; split. + by apply p. + by apply u. + by apply q. + by apply v. Defined. (** Annihilators reverse the order of inclusion. *) Lemma ideal_annihilator_subset (I J : Ideal R) : I ⊆ J -> Ann J ⊆ Ann I. Proof. intros p x [q q']; hnf in q, q'; strip_truncations; split; apply tr; intros y i. - by apply q, p. - by apply q', p. Defined. (** The annihilator of an ideal is equal to a quotient of zero. *) Lemma ideal_annihilator_zero_quotient (I : Ideal R) : Ann I ↔ ideal_zero R :: I. Proof. intros x; split. - intros [p q]; strip_truncations; split; apply tr; intros y i. + exact (p y i). + exact (q y i). - intros [p q]; strip_truncations; split; apply tr; intros y i. + exact (p y i). + exact (q y i). Defined. End IdealLemmas. (** ** Preimage of ideals under ring homomorphisms *) (** The preimage of an ideal under a ring homomorphism is also itself an ideal. This is also known as the contraction of an ideal. *) Global Instance isleftideal_preimage {R S : Ring} (f : R $-> S) (I : Subgroup S) `{IsLeftIdeal S I} : IsLeftIdeal (subgroup_preimage f I). Proof. intros r x Ifx. nrefine (transport I (rng_homo_mult f _ _)^ _). rapply isleftideal. exact Ifx. Defined. Global Instance isrightideal_preimage {R S : Ring} (f : R $-> S) (I : Subgroup S) `{IsRightIdeal S I} : IsRightIdeal (subgroup_preimage f I) := isleftideal_preimage (R:=rng_op R) (S:=rng_op S) (fmap rng_op f) I. Global Instance isideal_preimage {R S : Ring} (f : R $-> S) (I : Subgroup S) `{IsIdeal S I} : IsIdeal (subgroup_preimage f I) := {}. Definition ideal_preimage {R S : Ring} (f : R $-> S) (I : Ideal S) : Ideal R := Build_Ideal R (subgroup_preimage f I) _. (** ** Extensions of ideals *) (** The extension of an ideal under a ring homomorphism is the ideal generated by the image of the ideal. *) Definition ideal_extension {R S : Ring} (f : R $-> S) (I : Ideal R) : Ideal S := ideal_generated (fun s => exists r, I r /\ f r = s). (** The extension of a preimage is always a subset of the original ideal. *) Definition ideal_subset_extension_preimage {R S : Ring} (f : R $-> S) (I : Ideal S) : ideal_extension f (ideal_preimage f I) ⊆ I. Proof. intros x. apply Trunc_rec. intros y. induction y. + destruct x as [s [p q]]. destruct q; exact p. + apply ideal_in_zero. + by apply ideal_in_plus_negate. + by rapply isleftideal. + by rapply isrightideal. Defined. (** TODO: Maximal ideals *) (** TODO: Principal ideal *) (** TODO: Prime ideals *) (** TODO: Radical ideals *) (** TODO: Minimal ideals *) (** TODO: Primary ideals *) Coq-HoTT-9.0/theories/Algebra/Rings/Idempotent.v000066400000000000000000000075221474641544500215040ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids. Require Import Basics.Equivalences Basics.Trunc Types.Sigma WildCat.Core. Require Import Nat.Core Rings.Ring. Local Open Scope mc_scope. (** * Idempotent elements of rings *) (** ** Definition *) Class IsIdempotent (R : Ring) (e : R) := rng_idem : e * e = e. Global Instance ishprop_isidempotent R e : IsHProp (IsIdempotent R e). Proof. unfold IsIdempotent; exact _. Defined. (** *** Examples *) (** Zero is idempotent. *) Global Instance isidempotent_zero (R : Ring) : IsIdempotent R 0 := rng_mult_zero_r 0. (** One is idempotent. *) Global Instance isidempotent_one (R : Ring) : IsIdempotent R 1 := rng_mult_one_r 1. (** If [e] is idempotent, then [1 - e] is idempotent. *) Global Instance isidempotent_complement (R : Ring) (e : R) `{IsIdempotent R e} : IsIdempotent R (1 - e). Proof. unfold IsIdempotent. rewrite rng_dist_l_negate. rewrite 2 rng_dist_r_negate. rewrite 2 rng_mult_one_l. rewrite rng_mult_one_r. rewrite rng_idem. rewrite rng_plus_negate_r. rewrite rng_negate_zero. nrapply rng_plus_zero_r. Defined. (** If [e] is idempotent, then it is also an idempotent element of the opposite ring. *) Global Instance isidempotent_op (R : Ring) (e : R) `{i : IsIdempotent R e} : IsIdempotent (rng_op R) e := i. (** Any positive power of an idempotent element [e] is [e]. *) Definition rng_power_idem {R : Ring} (e : R) `{IsIdempotent R e} (n : nat) : (1 <= n)%nat -> rng_power e n = e. Proof. intros L; induction L. - snrapply rng_mult_one_r. - rhs_V rapply rng_idem. exact (ap (e *.) IHL). Defined. (** Ring homomorphisms preserve idempotent elements. *) Global Instance isidempotent_rng_homo {R S : Ring} (f : R $-> S) (e : R) : IsIdempotent R e -> IsIdempotent S (f e). Proof. intros p. lhs_V nrapply rng_homo_mult. exact (ap f p). Defined. (** ** Orthogonal idempotent elements *) (** Two idempotent elements [e] and [f] are orthogonal if both [e * f = 0] and [f * e = 0]. *) Class IsOrthogonal (R : Ring) (e f : R) `{!IsIdempotent R e, !IsIdempotent R f} := { rng_idem_orth : e * f = 0 ; rng_idem_orth' : f * e = 0 ; }. Definition issig_IsOrthogonal {R : Ring} {e f : R} `{IsIdempotent R e, IsIdempotent R f} : _ <~> IsOrthogonal R e f := ltac:(issig). Global Instance ishprop_isorthogonal R e f `{IsIdempotent R e, IsIdempotent R f} : IsHProp (IsOrthogonal R e f). Proof. exact (istrunc_equiv_istrunc _ issig_IsOrthogonal). Defined. (** *** Properties *) (** Two idempotents being orthogonal is a symmetric relation. *) Definition isorthogonal_swap (R : Ring) (e f : R) `{IsOrthogonal R e f} : IsOrthogonal R f e := {| rng_idem_orth := rng_idem_orth' ; rng_idem_orth' := rng_idem_orth |}. Hint Immediate isorthogonal_swap : typeclass_instances. (** If [e] and [f] are orthogonal idempotents, then they are also orthogonal idempotents in the opposite ring. *) Global Instance isorthogonal_op {R : Ring} (e f : R) `{r : IsOrthogonal R e f} : IsOrthogonal (rng_op R) e f. Proof. snrapply Build_IsOrthogonal. - exact (rng_idem_orth' (R:=R)). - exact (rng_idem_orth (R:=R)). Defined. (** If [e] and [f] are orthogonal idempotents, then [e + f] is idempotent. *) Global Instance isidempotent_plus_orthogonal {R : Ring} (e f : R) `{IsOrthogonal R e f} : IsIdempotent R (e + f). Proof. unfold IsIdempotent. rewrite rng_dist_l. rewrite 2 rng_dist_r. rewrite 2 rng_idem. rewrite 2 rng_idem_orth. by rewrite rng_plus_zero_r, rng_plus_zero_l. Defined. (** An idempotent element [e] is orthogonal to its complement [1 - e]. *) Global Instance isorthogonal_complement {R : Ring} (e : R) `{IsIdempotent R e} : IsOrthogonal R e (1 - e). Proof. snrapply Build_IsOrthogonal. 1: rewrite rng_dist_l_negate,rng_mult_one_r. 2: rewrite rng_dist_r_negate, rng_mult_one_l. 1,2: rewrite rng_idem. 1,2: apply rng_plus_negate_r. Defined. Coq-HoTT-9.0/theories/Algebra/Rings/KroneckerDelta.v000066400000000000000000000123311474641544500222630ustar00rootroot00000000000000Require Import Basics.Overture Basics.Decidable Spaces.Nat. Require Import Algebra.Rings.Ring. Require Import Classes.interfaces.abstract_algebra. Local Set Universe Minimization ToSet. Local Set Polymorphic Inductive Cumulativity. (** ** Kronecker Delta *) Section AssumeDecidable. (** Throughout this section, we assume that we have a type [A] with decidable equality. This will be our indexing type and can be thought of as [nat] for reading purposes. *) Universes u v. Context {A : Type@{u}} `{DecidablePaths@{u} A} {R : Ring@{v}}. (** The Kronecker delta function is a function of elements of [A] that is 1 when the two numbers are equal and 0 otherwise. It is useful for working with finite sums of ring elements. *) Definition kronecker_delta@{} (i j : A) : R := if dec (i = j) then 1 else 0. (** Kronecker delta with the same index is 1. *) Definition kronecker_delta_refl@{} (i : A) : kronecker_delta i i = 1. Proof. unfold kronecker_delta. generalize (dec (i = i)). by rapply decidable_paths_refl. Defined. (** Kronecker delta with differing indices is 0. *) Definition kronecker_delta_neq@{} {i j : A} (p : i <> j) : kronecker_delta i j = 0. Proof. unfold kronecker_delta. by decidable_false (dec (i = j)) p. Defined. (** Kronecker delta is symmetric in its arguments. *) Definition kronecker_delta_symm@{} (i j : A) : kronecker_delta i j = kronecker_delta j i. Proof. unfold kronecker_delta. destruct (dec (i = j)) as [p|q]. - by decidable_true (dec (j = i)) p^. - by decidable_false (dec (j = i)) (symmetric_neq q). Defined. (** An injective endofunction on [A] preserves the Kronecker delta. *) Definition kronecker_delta_map_inj@{} (i j : A) (f : A -> A) `{!IsInjective f} : kronecker_delta (f i) (f j) = kronecker_delta i j. Proof. unfold kronecker_delta. destruct (dec (i = j)) as [p|p]. - by decidable_true (dec (f i = f j)) (ap f p). - destruct (dec (f i = f j)) as [q|q]. + apply (injective f) in q. contradiction. + reflexivity. Defined. (** Kronecker delta commutes with any ring element. *) Definition kronecker_delta_comm@{} (i j : A) (r : R) : r * kronecker_delta i j = kronecker_delta i j * r. Proof. unfold kronecker_delta. destruct (dec (i = j)). - exact (rng_mult_one_r _ @ (rng_mult_one_l _)^). - exact (rng_mult_zero_r _ @ (rng_mult_zero_l _)^). Defined. End AssumeDecidable. (** The following lemmas are specialised to when the indexing type is [nat]. *) (** Kronecker delta where the first index is strictly less than the second is 0. *) Definition kronecker_delta_lt {R : Ring} {i j : nat} (p : (i < j)%nat) : kronecker_delta (R:=R) i j = 0. Proof. apply kronecker_delta_neq. intros q; destruct q. by apply lt_irrefl in p. Defined. (** Kronecker delta where the first index is strictly greater than the second is 0. *) Definition kronecker_delta_gt {R : Ring} {i j : nat} (p : (j < i)%nat) : kronecker_delta (R:=R) i j = 0. Proof. apply kronecker_delta_neq. intros q; destruct q. by apply lt_irrefl in p. Defined. (** Kronecker delta can be used to extract a single term from a finite sum. *) Definition rng_sum_kronecker_delta_l {R : Ring} (n i : nat) (Hi : (i < n)%nat) (f : forall k, (k < n)%nat -> R) : ab_sum n (fun j Hj => kronecker_delta i j * f j Hj) = f i Hi. Proof. revert i Hi f; simple_induction n n IHn; intros i Hi f. 1: destruct (not_lt_zero_r _ Hi). destruct (dec (i = n)) as [p|p]. - destruct p; simpl. rewrite kronecker_delta_refl. rewrite rng_mult_one_l. rewrite <- rng_plus_zero_r. apply ap11. { apply (ap (fun h => plus (f i h))), path_ishprop. } nrapply ab_sum_zero. intros k Hk. rewrite (kronecker_delta_gt Hk). apply rng_mult_zero_l. - simpl; lhs nrapply ap. + nrapply IHn. apply neq_iff_lt_or_gt in p. destruct p; [assumption|]. apply gt_iff_not_leq in Hi. contradiction Hi. + rewrite (kronecker_delta_neq p). rewrite rng_mult_zero_l. rewrite grp_unit_l. apply ap, path_ishprop. Defined. (** Variant of [rng_sum_kronecker_delta_l] where the indexing is swapped. *) Definition rng_sum_kronecker_delta_l' {R : Ring} (n i : nat) (Hi : (i < n)%nat) (f : forall k, (k < n)%nat -> R) : ab_sum n (fun j Hj => kronecker_delta j i * f j Hj) = f i Hi. Proof. lhs nrapply path_ab_sum. 2: nrapply rng_sum_kronecker_delta_l. intros k Hk. cbn; f_ap; apply kronecker_delta_symm. Defined. (** Variant of [rng_sum_kronecker_delta_l] where the Kronecker delta appears on the right. *) Definition rng_sum_kronecker_delta_r {R : Ring} (n i : nat) (Hi : (i < n)%nat) (f : forall k, (k < n)%nat -> R) : ab_sum n (fun j Hj => f j Hj * kronecker_delta i j) = f i Hi. Proof. lhs nrapply path_ab_sum. 2: nrapply rng_sum_kronecker_delta_l. intros k Hk. apply kronecker_delta_comm. Defined. (** Variant of [rng_sum_kronecker_delta_r] where the indexing is swapped. *) Definition rng_sum_kronecker_delta_r' {R : Ring} (n i : nat) (Hi : (i < n)%nat) (f : forall k, (k < n)%nat -> R) : ab_sum n (fun j Hj => f j Hj * kronecker_delta j i) = f i Hi. Proof. lhs nrapply path_ab_sum. 2: nrapply rng_sum_kronecker_delta_l'. intros k Hk. apply kronecker_delta_comm. Defined. Coq-HoTT-9.0/theories/Algebra/Rings/Localization.v000066400000000000000000000426431474641544500220270ustar00rootroot00000000000000Require Import Basics.Overture Basics.Trunc Basics.Tactics Colimits.Quotient abstract_algebra Rings.CRing Truncations.Core Nat.Core Rings.QuotientRing WildCat.Core WildCat.Equiv. Local Open Scope mc_scope. (** * Localization of commutative rings *) (** Localization is a way to make elements in a commutative ring invertible by adding inverses, in the most minimal way possible. It generalizes the familiar operation of a field of fractions. *) (** ** Multiplicative subsets *) (** A multiplicative subset is formally a submonoid of the multiplicative monoid of a ring. Essentially it is a subset closed under finite products. *) (** *** Definition *) (** Multiplicative subsets of a ring [R] consist of: *) Class IsMultiplicativeSubset {R : CRing} (S : R -> Type) : Type := { (** Contains one *) mss_one : S 1 ; (** Closed under multiplication *) mss_mult : forall x y, S x -> S y -> S (x * y) ; }. Arguments mss_one {R _ _}. Arguments mss_mult {R _ _ _ _}. (** *** Examples *) (** The multiplicative subset of powers of a ring element. *) Global Instance ismultiplicative_powers (R : CRing) (x : R) : IsMultiplicativeSubset (fun r => exists n, rng_power x n = r). Proof. srapply Build_IsMultiplicativeSubset; cbn beta. 1: by exists 0%nat. intros a b np mq. destruct np as [n p], mq as [m q]. exists (n + m)%nat. lhs_V nrapply rng_power_mult_law. f_ap. Defined. (** Invertible elements of a ring form a multiplicative subset. *) Global Instance ismultiplicative_isinvertible (R : CRing) : IsMultiplicativeSubset (@IsInvertible R) := {}. (** TODO: Property of being a localization. *) (** ** Construction of localization *) Section Localization. (** We now construct the localization of a ring at a multiplicative subset as the following HIT: << HIT (Quotient fraction_eq) (R : CRing) (S : R -> Type) `{IsMultiplicativeSubset R} := | loc_frac (n d : R) (p : S d) : Localization R S | loc_frac_eq (n1 d1 n2 d2 : R) (p1 : S d1) (p2 : S d2) (x : R) (q : S x) (r : x * (d2 * n1 - n2 * d1) = 0) : loc_frac n1 d1 p1 = loc_frac n2 d2 p2 . >> along with the condition that this HIT be a set. We will implement this HIT by writing it as a set quotient. From now onwards, [loc_frac] will be implemented as [class_of fraction_eq] and [loc_frac_eq] will be implemented as [qglue]. *) Context (R : CRing) (S : R -> Type) `{!IsMultiplicativeSubset S}. (** *** Construction of underlying Localization type *) (** The base type will be the type of fractions with respect to a multiplicative subset. This consists of pairs of elements of a ring [R] where the [denominator] is in the multiplicative subset [S]. *) Record Fraction := { numerator : R ; denominator : R ; in_mult_subset_denominator : S denominator ; }. (** We consider two fractions to be equal if we can rearrange the fractions as products and ask for equality upto some scaling factor from the multiplicative subset [S]. *) Definition fraction_eq : Relation Fraction. Proof. intros [n1 d1 ?] [n2 d2 ?]. refine (exists (x : R), S x /\ _). exact (x * n1 * d2 = x * n2 * d1). Defined. (** It is convenient to produce elements of this relation specalized to when the scaling factor is [1]. *) Definition fraction_eq_simple f1 f2 (p : numerator f1 * denominator f2 = numerator f2 * denominator f1) : fraction_eq f1 f2. Proof. exists 1. refine (mss_one, _). lhs_V nrapply rng_mult_assoc. rhs_V nrapply rng_mult_assoc. exact (ap (1 *.) p). Defined. (** Fraction equality is a reflexive relation. *) Definition fraction_eq_refl f1 : fraction_eq f1 f1. Proof. apply fraction_eq_simple. reflexivity. Defined. (** Elements of [R] can be considered fractions. *) Definition frac_in : R -> Fraction := fun r => Build_Fraction r 1 mss_one. (** Now that we have defined the HIT as above, we can define the ring structure. *) (** *** Addition operation *) (** Fraction addition is the usual addition of fractions. *) Definition frac_add : Fraction -> Fraction -> Fraction := fun '(Build_Fraction n1 d1 p1) '(Build_Fraction n2 d2 p2) => Build_Fraction (n1 * d2 + n2 * d1) (d1 * d2) (mss_mult p1 p2). (** Fraction addition is well-defined upto equality of fractions. *) (** It is easier to prove well-definedness as a function of both arguments at once. *) Definition frac_add_wd (f1 f1' f2 f2' : Fraction) (p : fraction_eq f1 f1') (q : fraction_eq f2 f2') : fraction_eq (frac_add f1 f2) (frac_add f1' f2'). Proof. destruct f1 as [a s ss], f1' as [a' s' ss'], f2 as [b t st], f2' as [b' t' st'], p as [x [sx p]], q as [y [sy q]]. refine (x * y ; (mss_mult sx sy, _)). simpl. rewrite 2 rng_dist_l, 2 rng_dist_r. snrapply (ap011 (+)). - rewrite 4 rng_mult_assoc. rewrite 8 (rng_mult_permute_2_3 _ y). apply (ap (.* y)). rewrite 2 (rng_mult_permute_2_3 _ t). apply (ap (.* t)). rewrite (rng_mult_permute_2_3 _ t'). f_ap. - do 2 lhs_V nrapply rng_mult_assoc. do 2 rhs_V nrapply rng_mult_assoc. f_ap. rewrite 6 rng_mult_assoc. rewrite 2 (rng_mult_permute_2_3 _ _ t'). rewrite 2 (rng_mult_permute_2_3 _ _ t). lhs_V nrapply rng_mult_assoc. rhs_V nrapply rng_mult_assoc. f_ap; apply rng_mult_comm. Defined. Definition frac_add_wd_l (f1 f1' f2 : Fraction) (p : fraction_eq f1 f1') : fraction_eq (frac_add f1 f2) (frac_add f1' f2). Proof. pose (fraction_eq_refl f2). by apply frac_add_wd. Defined. Definition frac_add_wd_r (f1 f2 f2' : Fraction) (p : fraction_eq f2 f2') : fraction_eq (frac_add f1 f2) (frac_add f1 f2'). Proof. pose (fraction_eq_refl f1). by apply frac_add_wd. Defined. (** The addition operation on the localization is induced from the addition operation for fractions. *) Instance plus_rng_localization : Plus (Quotient fraction_eq). Proof. srapply Quotient_rec2. - cbn. intros f1 f2. exact (class_of _ (frac_add f1 f2)). - intros f1 f1' f2 p. by apply qglue, frac_add_wd_l. - intros f1 f2 f2' q. by apply qglue, frac_add_wd_r. Defined. (** *** Multiplication operation *) Definition frac_mult : Fraction -> Fraction -> Fraction := fun '(Build_Fraction n1 d1 p1) '(Build_Fraction n2 d2 p2) => Build_Fraction (n1 * n2) (d1 * d2) (mss_mult p1 p2). Definition frac_mult_wd_l f1 f1' f2 (p : fraction_eq f1 f1') : fraction_eq (frac_mult f1 f2) (frac_mult f1' f2). Proof. destruct p as [x [s p]]. refine (x; (s, _)); simpl. rewrite 4 rng_mult_assoc. rewrite (rng_mult_permute_2_3 _ _ (denominator f1')). rewrite (rng_mult_permute_2_3 _ _ (denominator f1)). lhs_V nrapply rng_mult_assoc. rhs_V nrapply rng_mult_assoc. f_ap. Defined. Definition frac_mult_wd_r f1 f2 f2' (p : fraction_eq f2 f2') : fraction_eq (frac_mult f1 f2) (frac_mult f1 f2'). Proof. destruct p as [x [s p]]. refine (x; (s, _)); simpl. rewrite 4 rng_mult_assoc. rewrite (rng_mult_permute_2_3 _ _ (numerator f2)). rewrite 2 (rng_mult_permute_2_3 _ _ (denominator f2')). rewrite (rng_mult_permute_2_3 _ _ (numerator f2')). rewrite 2 (rng_mult_permute_2_3 _ _ (denominator f2)). lhs_V nrapply rng_mult_assoc. rhs_V nrapply rng_mult_assoc. f_ap. Defined. Instance mult_rng_localization: Mult (Quotient fraction_eq). Proof. srapply Quotient_rec2. - cbn. intros f1 f2. exact (class_of _ (frac_mult f1 f2)). - intros f1 f1' f2 p; cbn beta. by apply qglue, frac_mult_wd_l. - intros f1 f2 f2' q; cbn beta. by apply qglue, frac_mult_wd_r. Defined. (** *** Zero element *) Instance zero_rng_localization : Zero (Quotient fraction_eq) := class_of _ (Build_Fraction 0 1 mss_one). (** *** One element *) Instance one_rng_localization : One (Quotient fraction_eq) := class_of _(Build_Fraction 1 1 mss_one). (** *** Negation operation *) Definition frac_negate : Fraction -> Fraction := fun '(Build_Fraction n d p) => Build_Fraction (- n) d p. Definition frac_negate_wd f1 f2 (p : fraction_eq f1 f2) : fraction_eq (frac_negate f1) (frac_negate f2). Proof. destruct p as [x [s p]]. refine (x; (s,_)); simpl. rewrite 2 rng_mult_negate_r, 2 rng_mult_negate_l. f_ap. Defined. Instance negate_rng_localization : Negate (Quotient fraction_eq). Proof. srapply Quotient_rec. - intros f. apply class_of. exact (frac_negate f). - intros f1 f2 p. by apply qglue, frac_negate_wd. Defined. (** *** Ring laws *) (** Commutativity of addition *) Instance commutative_plus_rng_localization : Commutative plus_rng_localization. Proof. srapply Quotient_ind2_hprop; intros x y. apply qglue, fraction_eq_simple; simpl. rewrite (rng_mult_comm (denominator y) (denominator x)). f_ap; apply rng_plus_comm. Defined. (** Left additive identity *) Instance leftidentity_plus_rng_localization : LeftIdentity plus_rng_localization zero_rng_localization. Proof. srapply Quotient_ind_hprop; intros f. apply qglue, fraction_eq_simple; simpl. f_ap. - rewrite rng_mult_zero_l. rewrite rng_plus_zero_l. apply rng_mult_one_r. - symmetry. apply rng_mult_one_l. Defined. Instance leftinverse_plus_rng_localization : LeftInverse plus_rng_localization negate_rng_localization zero_rng_localization. Proof. srapply Quotient_ind_hprop; intros f. apply qglue, fraction_eq_simple; simpl. refine (rng_mult_one_r _ @ _). refine (_ @ (rng_mult_zero_l _)^). rewrite rng_mult_negate_l. apply rng_plus_negate_l. Defined. Instance associative_plus_rng_localization : Associative plus_rng_localization. Proof. srapply Quotient_ind3_hprop; intros x y z. apply qglue, fraction_eq_simple. simpl. rewrite ? rng_dist_r. rewrite ? rng_mult_assoc. rewrite ? rng_plus_assoc. do 4 f_ap. all: rewrite <- ? rng_mult_assoc. all: f_ap. 2: apply rng_mult_comm. rewrite rng_mult_assoc. apply rng_mult_comm. Defined. Instance leftidentity_mult_rng_localization : LeftIdentity mult_rng_localization one_rng_localization. Proof. srapply Quotient_ind_hprop; intros f. apply qglue, fraction_eq_simple; simpl. f_ap; [|symmetry]; apply rng_mult_one_l. Defined. Instance associative_mult_rng_localization : Associative mult_rng_localization. Proof. srapply Quotient_ind3_hprop; intros x y z. apply qglue, fraction_eq_simple. f_ap; [|symmetry]; apply rng_mult_assoc. Defined. Instance commutative_mult_rng_localization : Commutative mult_rng_localization. Proof. srapply Quotient_ind2_hprop; intros x y. apply qglue, fraction_eq_simple; simpl. f_ap; rapply rng_mult_comm. Defined. Instance leftdistribute_rng_localization : LeftDistribute mult_rng_localization plus_rng_localization. Proof. srapply Quotient_ind3_hprop; intros x y z. apply qglue, fraction_eq_simple. simpl. rewrite ? rng_dist_l, ? rng_dist_r. rewrite ? rng_mult_assoc. do 2 f_ap. all: rewrite <- ? rng_mult_assoc. all: do 2 f_ap. all: rewrite ? rng_mult_assoc. all: rewrite (rng_mult_comm (_ x)). all: rewrite <- ? rng_mult_assoc. all: f_ap. all: rewrite (rng_mult_comm _ (_ y)). all: rewrite <- ? rng_mult_assoc. all: f_ap. Defined. Definition rng_localization : CRing. Proof. snrapply Build_CRing'. (* All of the laws can be found by typeclass search, but it's slightly faster if we fill them in: *) 1: exact (Build_AbGroup' (Quotient fraction_eq) commutative_plus_rng_localization associative_plus_rng_localization leftidentity_plus_rng_localization leftinverse_plus_rng_localization). all: exact _. Defined. Definition loc_in : R $-> rng_localization. Proof. snrapply Build_RingHomomorphism. 1: exact (class_of _ o frac_in). snrapply Build_IsSemiRingPreserving. - snrapply Build_IsMonoidPreserving. + intros x y. snrapply qglue. apply fraction_eq_simple. by simpl; rewrite 5 rng_mult_one_r. + reflexivity. - snrapply Build_IsMonoidPreserving. + intros x y. snrapply qglue. apply fraction_eq_simple. by simpl; rewrite 3 rng_mult_one_r. + reflexivity. Defined. Section Rec. Context (T : CRing) (f : R $-> T) (H : forall x, S x -> IsInvertible T (f x)). Definition rng_localization_rec_map : rng_localization -> T. Proof. srapply Quotient_rec. - intros [n d sd]. refine (f n * inverse_elem (f d)). exact (H d sd). - simpl. intros x y z. apply rng_inv_moveR_rV. rhs_V nrapply rng_mult_move_left_assoc. rhs_V nrapply rng_mult_assoc. apply rng_inv_moveL_Vr. lhs_V nrapply rng_homo_mult. rhs_V nrapply rng_homo_mult. nrapply (equiv_inj (f z.1 *.)). { nrapply isequiv_rng_inv_mult_l. exact (H _ (fst z.2)). } lhs_V nrapply rng_homo_mult. rhs_V nrapply rng_homo_mult. lhs nrapply ap. 1: lhs nrapply rng_mult_assoc. 1: nrapply rng_mult_permute_2_3. rhs nrapply ap. 2: nrapply rng_mult_assoc. exact (ap f (snd z.2)). Defined. Instance issemiringpreserving_rng_localization_rec_map : IsSemiRingPreserving rng_localization_rec_map. Proof. snrapply Build_IsSemiRingPreserving. - snrapply Build_IsMonoidPreserving. + srapply Quotient_ind2_hprop. intros x y; simpl. apply rng_inv_moveR_rV. rhs nrapply rng_dist_r. rewrite rng_homo_plus. rewrite 3 rng_homo_mult. f_ap. 1,2: rhs_V nrapply rng_mult_assoc. 1,2: f_ap. 1,2: lhs_V nrapply rng_mult_one_l. 1,2: rhs nrapply rng_mult_assoc. 2: rhs nrapply rng_mult_comm. 2: rhs nrapply rng_mult_assoc. 1,2: f_ap. 1,2: symmetry. * apply rng_inv_l. * apply rng_inv_r. + hnf; simpl. rewrite rng_homo_zero. nrapply rng_mult_zero_l. - snrapply Build_IsMonoidPreserving. + srapply Quotient_ind2_hprop. intros x y; simpl. apply rng_inv_moveR_rV. lhs nrapply rng_homo_mult. rhs_V nrapply rng_mult_assoc. rhs_V nrapply rng_mult_assoc. apply ap. apply rng_inv_moveL_Vr. lhs nrapply rng_mult_comm. rhs_V nrapply rng_mult_assoc. apply ap. apply rng_inv_moveL_Vr. symmetry. rhs nrapply rng_mult_comm. nrapply rng_homo_mult. + apply rng_inv_moveR_rV; symmetry. apply rng_mult_one_l. Defined. Definition rng_localization_rec : rng_localization $-> T := Build_RingHomomorphism rng_localization_rec_map _. Definition rng_localization_rec_beta : rng_localization_rec $o loc_in $== f. Proof. intros x; simpl. apply rng_inv_moveR_rV. lhs_V nrapply rng_mult_one_r. nrapply ap; symmetry. apply rng_homo_one. Defined. End Rec. (** Elements belonging to the multiplicative subset [S] of [R] become invertible in [rng_localization R S]. *) Global Instance isinvertible_rng_localization (x : R) (Sx : S x) : IsInvertible rng_localization (loc_in x). Proof. snrapply isinvertible_cring. - exact (class_of _ (Build_Fraction 1 x Sx)). - apply qglue, fraction_eq_simple. exact (ring_mult_assoc_opp _ _ _ _). Defined. (** As a special case, any denominator of a fraction must necessarily be invertible. *) Global Instance isinvertible_denominator (f : Fraction) : IsInvertible rng_localization (loc_in (denominator f)). Proof. snrapply isinvertible_rng_localization. exact (in_mult_subset_denominator f). Defined. (** Elements that were invertible in the original ring [R], continue to be invertible in [rng_localization R S]. Since [loc_in] is a ring homomorphism this is automatic. *) Definition isinvertible_rng_localization_preserved (x : R) : IsInvertible R x -> IsInvertible rng_localization (loc_in x) := _. (** We can factor any fraction as the multiplication of the numerator and the inverse of the denominator. *) Definition fraction_decompose (f : Fraction) : class_of fraction_eq f = loc_in (numerator f) * inverse_elem (loc_in (denominator f)). Proof. apply qglue, fraction_eq_simple. nrapply rng_mult_assoc. Defined. Definition rng_localization_ind (P : rng_localization -> Type) (H : forall x, IsHProp (P x)) (Hin : forall x, P (loc_in x)) (Hinv : forall x (H : IsInvertible rng_localization x), P x -> P (inverse_elem x)) (Hmul : forall x y, P x -> P y -> P (x * y)) : forall x, P x. Proof. snrapply Quotient_ind. - exact _. - intros f. refine (transport P (fraction_decompose f)^ _). apply Hmul. + apply Hin. + apply Hinv, Hin. - intros f1 f2 p. apply path_ishprop. Defined. Definition rng_localization_ind_homotopy {T : CRing} {f g : rng_localization $-> T} (p : f $o loc_in $== g $o loc_in) : f $== g. Proof. srapply rng_localization_ind. - exact p. - hnf; intros x H q. change (inverse_elem (f x) = inverse_elem (g x)). apply isinvertible_unique. exact q. - hnf; intros x y q r. lhs nrapply rng_homo_mult. rhs nrapply rng_homo_mult. f_ap. Defined. End Localization. (** TODO: Show construction is a localization. *) Coq-HoTT-9.0/theories/Algebra/Rings/Matrix.v000066400000000000000000001066221474641544500206410ustar00rootroot00000000000000Require Import Basics.Overture Basics.Trunc Basics.Tactics Basics.Decidable. Require Import Types.Sigma. Require Import Spaces.List.Core Spaces.List.Theory Spaces.List.Paths. Require Import Algebra.Rings.Ring Algebra.Rings.Module Algebra.Rings.CRing Algebra.Rings.KroneckerDelta Algebra.Rings.Vector. Require Import abstract_algebra. Require Import WildCat.Core WildCat.Paths. Require Import Modalities.ReflectiveSubuniverse. Set Universe Minimization ToSet. (** * Matrices *) (** ** Definition *) Definition Matrix@{i} (R : Type@{i}) (m n : nat) : Type@{i} := Vector (Vector R n) m. Global Instance istrunc_matrix (R : Type) k `{IsTrunc k.+2 R} m n : IsTrunc k.+2 (Matrix R m n) := _. (** Building a matrix from a function that takes row and column indices. *) Definition Build_Matrix (R : Type) (m n : nat) (M_fun : forall (i : nat) (j : nat), (i < m)%nat -> (j < n)%nat -> R) : Matrix R m n. Proof. snrapply Build_Vector. intros i Hi. snrapply Build_Vector. intros j Hj. exact (M_fun i j Hi Hj). Defined. (** The length conditions here are decidable so can be inferred in proofs. *) Definition Build_Matrix' (R : Type) (m n : nat) (l : list (list R)) (wf_row : length l = m) (wf_col : for_all (fun row => length row = n) l) : Matrix R m n. Proof. snrefine (_; _). - snrapply list_sigma. + exact l. + exact wf_col. - by lhs nrapply length_list_sigma. Defined. Definition entries@{i|} {R : Type@{i}} {m n} (M : Matrix R m n) : list (list R) := list_map@{i i} pr1 (pr1 M). (** The entry at row [i] and column [j] of a matrix [M]. *) Definition entry {R : Type} {m n} (M : Matrix R m n) (i j : nat) {H1 : (i < m)%nat} {H2 : (j < n)%nat} : R := Vector.entry (Vector.entry M i) j. (** Mapping a function on all the entries of a matrix. *) Definition matrix_map {R S : Type} {m n} (f : R -> S) : Matrix R m n -> Matrix S m n := fun M => Build_Matrix S m n (fun i j _ _ => f (entry M i j)). Definition matrix_map2 {R S T : Type} {m n} (f : R -> S -> T) : Matrix R m n -> Matrix S m n -> Matrix T m n := fun M N => Build_Matrix T m n (fun i j _ _ => f (entry M i j) (entry N i j)). (** The [(i, j)]-entry of [Build_Matrix R m n M_fun] is [M_fun i j]. *) Definition entry_Build_Matrix {R : Type} {m n} (M_fun : forall i j, (i < m)%nat -> (j < n)%nat -> R) (i j : nat) (H1 : (i < m)%nat) (H2 : (j < n)%nat) : entry (Build_Matrix R m n M_fun) i j = M_fun i j _ _. Proof. unfold entry. by rewrite 2 entry_Build_Vector. Defined. (** Two matrices are equal if all their entries are equal. *) Definition path_matrix {R : Type} {m n} (M N : Matrix R m n) (H : forall i j (Hi : (i < m)%nat) (Hj : (j < n)%nat), entry M i j = entry N i j) : M = N. Proof. snrapply path_vector. intros i Hi. snrapply path_vector. intros j Hj. exact (H i j Hi Hj). Defined. (** ** Addition and module structure *) (** Here we define the abelian group of (n x m)-matrices over a ring. This follows from the abelian group structure of the underlying vectors. We are also able to derive a left module strucutre when the entries come from a left module. *) Definition abgroup_matrix (A : AbGroup) (m n : nat) : AbGroup := abgroup_vector (abgroup_vector A n) m. Definition matrix_plus {A : AbGroup} {m n} : Matrix A m n -> Matrix A m n -> Matrix A m n := @sg_op (abgroup_matrix A m n) _. Definition matrix_zero (A : AbGroup) m n : Matrix A m n := @mon_unit (abgroup_matrix A m n) _. Definition matrix_negate {A : AbGroup} {m n} : Matrix A m n -> Matrix A m n := @negate (abgroup_matrix A m n) _. Global Instance isleftmodule_isleftmodule_matrix (A : AbGroup) (m n : nat) {R : Ring} `{IsLeftModule R A} : IsLeftModule R (abgroup_matrix A m n). Proof. snrapply isleftmodule_isleftmodule_vector. snrapply isleftmodule_isleftmodule_vector. exact _. Defined. (** As a special case, we get the left module of matrices over a ring. *) Global Instance isleftmodule_abgroup_matrix (R : Ring) (m n : nat) : IsLeftModule R (abgroup_matrix R m n) := _. Definition matrix_lact {R : Ring} {m n : nat} (r : R) (M : Matrix R m n) : Matrix R m n := lact r M. (** ** Multiplication *) (** Matrix multiplication is defined such that the entry at row [i] and column [j] of the resulting matrix is the sum of the products of the corresponding entries from the [i]th row of the first matrix and the [j]th column of the second matrix. Matrices correspond to module homomorphisms between free modules of finite rank (think vector spaces), and matrix multiplication represents the composition of these homomorphisms. **) Definition matrix_mult {R : Ring@{i}} {m n k : nat} (M : Matrix R m n) (N : Matrix R n k) : Matrix R m k. Proof. snrapply Build_Matrix. intros i j Hi Hj. exact (ab_sum n (fun k Hk => entry M i k * entry N k j)). Defined. (** The identity matrix is the matrix with ones on the diagonal and zeros elsewhere. It acts as the multiplicative identity for matrix multiplication. We define it here using the [kronecker_delta] function which will make proving properties about it conceptually easier later. *) Definition identity_matrix (R : Ring@{i}) (n : nat) : Matrix R n n := Build_Matrix R n n (fun i j _ _ => kronecker_delta i j). (** This is the most general statement of associativity for matrix multiplication. *) Definition associative_matrix_mult (R : Ring) (m n p q : nat) : HeteroAssociative (@matrix_mult R m n q) (@matrix_mult R n p q) (@matrix_mult R m p q) (@matrix_mult R m n p). Proof. intros M N P; nrapply path_matrix; intros i j Hi Hj. rewrite 2 entry_Build_Matrix. lhs nrapply path_ab_sum. { intros k Hk. rewrite entry_Build_Matrix. apply rng_sum_dist_l. } lhs nrapply ab_sum_sum. rhs nrapply path_ab_sum. 2: intros k Hk; by rewrite entry_Build_Matrix. nrapply path_ab_sum. intros k Hk. rhs nrapply rng_sum_dist_r. nrapply path_ab_sum. intros l Hl. apply associativity. Defined. (** Matrix multiplication distributes over addition of matrices on the left. *) Definition left_distribute_matrix_mult (R : Ring) (m n p : nat) : LeftHeteroDistribute (@matrix_mult R m n p) matrix_plus matrix_plus. Proof. intros M N P; apply path_matrix; intros i j Hi Hj. rewrite !entry_Build_Matrix, !entry_Build_Vector. change (?x = ?y + ?z) with (x = sg_op y z). rewrite <- ab_sum_plus. nrapply path_ab_sum. intros k Hk. rewrite entry_Build_Matrix. apply rng_dist_l. Defined. (** Matrix multiplication distributes over addition of matrices on the right. *) Definition right_distribute_matrix_mult (R : Ring) (m n p : nat) : RightHeteroDistribute (@matrix_mult R m n p) matrix_plus matrix_plus. Proof. intros M N P; apply path_matrix; intros i j Hi Hj. rewrite !entry_Build_Matrix, !entry_Build_Vector. change (?x = ?y + ?z) with (x = sg_op y z). rewrite <- ab_sum_plus. nrapply path_ab_sum. intros k Hk. rewrite entry_Build_Matrix. apply rng_dist_r. Defined. (** The identity matrix acts as a left identity for matrix multiplication. *) Definition left_identity_matrix_mult (R : Ring) (m n: nat) : LeftIdentity (@matrix_mult R m m n) (identity_matrix R m). Proof. intros M; apply path_matrix; intros i j Hi Hj. rewrite entry_Build_Matrix. lhs nrapply path_ab_sum. 1: intros k Hk; by rewrite entry_Build_Matrix. nrapply rng_sum_kronecker_delta_l. Defined. (** The identity matrix acts as a right identity for matrix multiplication. *) Definition right_identity_matrix_mult (R : Ring) (m n : nat) : RightIdentity (@matrix_mult R m n n) (identity_matrix R n). Proof. intros M; apply path_matrix; intros i j Hi Hj. rewrite entry_Build_Matrix. lhs nrapply path_ab_sum. 1: intros k Hk; by rewrite entry_Build_Matrix. nrapply rng_sum_kronecker_delta_r'. Defined. (** TODO: define this as an R-algebra. What is an R-algebra over a non-commutative right however? (Here we have a bimodule which might be important) *) (** Matrices over a ring form a (generally) non-commutative ring. *) Definition matrix_ring (R : Ring@{i}) (n : nat) : Ring. Proof. snrapply Build_Ring. - exact (abgroup_matrix R n n). - exact matrix_mult. - exact (identity_matrix R n). - exact (associative_matrix_mult R n n n n). - exact (left_distribute_matrix_mult R n n n). - exact (right_distribute_matrix_mult R n n n). - exact (left_identity_matrix_mult R n n). - exact (right_identity_matrix_mult R n n). Defined. (** Matrix multiplication on the right preserves scalar multiplication in the sense that [matrix_lact r (matrix_mult M N) = matrix_mult (matrix_lact r M) N] for [r] a ring element and [M] and [N] matrices of compatible sizes. *) Definition matrix_mult_lact_l {R : Ring} {m n p : nat} : HeteroAssociative (@matrix_lact R m p) (@matrix_mult R m n p) (@matrix_mult R m n p) (@matrix_lact R m n). Proof. intros r M N. snrapply path_matrix. intros i j Hi Hj. rewrite !entry_Build_Matrix, !entry_Build_Vector. lhs nrapply rng_sum_dist_l. snrapply path_ab_sum. intros k Hk; cbn. rewrite !entry_Build_Matrix. snrapply rng_mult_assoc. Defined. (** The same doesn't hold for the right matrix, since the ring is not commutative. However we could say an analagous statement for the right action. We haven't yet stated a definition of right module yet though. *) (** In a commutative ring, matrix multiplication over the ring and the opposite ring agree. *) Definition matrix_mult_rng_op {R : CRing} {m n p} (M : Matrix R m n) (N : Matrix R n p) : matrix_mult (R:=rng_op R) M N = matrix_mult M N. Proof. apply path_matrix; intros i j Hi Hj. rewrite 2 entry_Build_Matrix. apply path_ab_sum; intros k Hk. apply rng_mult_comm. Defined. (** ** Transpose *) (** The transpose of a matrix is the matrix with the rows and columns swapped. *) Definition matrix_transpose {R : Type} {m n} : Matrix R m n -> Matrix R n m := fun M => Build_Matrix R n m (fun i j H1 H2 => entry M j i). (** Tranposing a matrix is involutive. *) Definition matrix_transpose_transpose {R : Type} {m n} (M : Matrix R m n) : matrix_transpose (matrix_transpose M) = M. Proof. apply path_matrix. intros i j Hi Hj. lhs nrapply entry_Build_Matrix. nrapply entry_Build_Matrix. Defined. (** Transpose distributes over addition. *) Definition matrix_transpose_plus {R : Ring} {m n} (M N : Matrix R m n) : matrix_transpose (matrix_plus M N) = matrix_plus (matrix_transpose M) (matrix_transpose N). Proof. apply path_matrix. intros i j Hi Hj. by rewrite !entry_Build_Matrix, !entry_Build_Vector. Defined. (** Transpose commutes with scalar multiplication. *) Definition matrix_transpose_lact {R : Ring} {m n} (r : R) (M : Matrix R m n) : matrix_transpose (matrix_lact r M) = matrix_lact r (matrix_transpose M). Proof. apply path_matrix. intros i j Hi Hj. by rewrite !entry_Build_Matrix, !entry_Build_Vector. Defined. (** The negation of a transposed matrix is the same as the transposed matrix of the negation. *) Definition matrix_transpose_negate {R : Ring} {m n} (M : Matrix R m n) : matrix_transpose (matrix_negate M) = matrix_negate (matrix_transpose M). Proof. apply path_matrix. intros i j Hi Hj. by rewrite !entry_Build_Matrix, !entry_Build_Vector. Defined. (** Transpose distributes over multiplication when you reverse the ring multiplication. *) Definition matrix_transpose_mult {R : Ring} {m n p} (M : Matrix R m n) (N : Matrix R n p) : matrix_transpose (matrix_mult M N) = matrix_mult (R:=rng_op R) (matrix_transpose N) (matrix_transpose M). Proof. apply path_matrix. intros i j Hi Hj. rewrite 3 entry_Build_Matrix. apply path_ab_sum. intros k Hk. rewrite 2 entry_Build_Matrix. reflexivity. Defined. (** When the ring is commutative, there is no need to reverse the multiplication. *) Definition matrix_transpose_mult_comm {R : CRing} {m n p} (M : Matrix R m n) (N : Matrix R n p) : matrix_transpose (matrix_mult M N) = matrix_mult (matrix_transpose N) (matrix_transpose M). Proof. lhs nrapply matrix_transpose_mult. apply matrix_mult_rng_op. Defined. (** The transpose of the zero matrix is the zero matrix. *) Definition matrix_transpose_zero {R : Ring} {m n} : matrix_transpose (matrix_zero R m n) = matrix_zero R n m. Proof. apply path_matrix. intros i j Hi Hj. by rewrite !entry_Build_Matrix. Defined. (** The transpose of the identity matrix is the identity matrix. *) Definition matrix_transpose_identity@{i} {R : Ring@{i}} {n} : matrix_transpose (identity_matrix R n) = identity_matrix R n. Proof. apply path_matrix. intros i j Hi Hj. rewrite 3 entry_Build_Matrix. apply kronecker_delta_symm. Defined. (** ** Diagonal matrices *) (** A diagonal matrix is a matrix with zeros everywhere except on the diagonal. Its entries are given by a vector. *) Definition matrix_diag {R : Ring@{i}} {n : nat} (v : Vector R n) : Matrix R n n. Proof. snrapply Build_Matrix. intros i j H1 H2. exact (kronecker_delta i j * Vector.entry v i). Defined. (** Addition of diagonal matrices is the same as addition of the corresponding vectors. *) Definition matrix_diag_plus {R : Ring@{i}} {n : nat} (v w : Vector R n) : matrix_plus (matrix_diag v) (matrix_diag w) = matrix_diag (vector_plus v w). Proof. symmetry. snrapply path_matrix. intros i j Hi Hj. rewrite 2 entry_Build_Matrix, 5 entry_Build_Vector. nrapply rng_dist_l. Defined. (** Matrix multiplication of diagonal matrices is the same as multiplying the corresponding vectors pointwise. *) Definition matrix_diag_mult {R : Ring} {n : nat} (v w : Vector R n) : matrix_mult (matrix_diag v) (matrix_diag w) = matrix_diag (vector_map2 (.*.) v w). Proof. snrapply path_matrix. intros i j Hi Hj. rewrite 2 entry_Build_Matrix. lhs snrapply path_ab_sum. { intros k Hk. rewrite 2 entry_Build_Matrix. rewrite rng_mult_assoc. rewrite <- (rng_mult_assoc (kronecker_delta _ _)). rewrite kronecker_delta_comm. rewrite <- 2 rng_mult_assoc. reflexivity. } rewrite (rng_sum_kronecker_delta_l _ _ Hi). by rewrite entry_Build_Vector. Defined. (** The transpose of a diagonal matrix is the same diagonal matrix. *) Definition matrix_transpose_diag {R : Ring@{i}} {n : nat} (v : Vector R n) : matrix_transpose (matrix_diag v) = matrix_diag v. Proof. snrapply path_matrix. intros i j Hi Hj. rewrite 3 entry_Build_Matrix. rewrite kronecker_delta_symm. unfold kronecker_delta. destruct (dec (i = j)) as [p|np]. 1: f_ap; symmetry; by apply path_entry_vector. by rewrite !rng_mult_zero_l. Defined. (** The diagonal matrix construction is injective. *) Global Instance isinj_matrix_diag {R : Ring@{i}} {n : nat} : IsInjective (@matrix_diag R n). Proof. intros v1 v2 p. snrapply path_vector. intros i Hi. apply (ap (fun M => entry M i i)) in p. rewrite 2 entry_Build_Matrix in p. rewrite kronecker_delta_refl in p. by rewrite 2 rng_mult_one_l in p. Defined. (** A matrix is diagonal if it is equal to a diagonal matrix. *) Class IsDiagonal@{i} {R : Ring@{i}} {n : nat} (M : Matrix R n n) : Type@{i} := { isdiagonal_diag_vector : Vector R n; isdiagonal_diag : M = matrix_diag isdiagonal_diag_vector; }. Arguments isdiagonal_diag_vector {R n} M {_}. Arguments isdiagonal_diag {R n} M {_}. Definition issig_IsDiagonal {R : Ring@{i}} {n : nat} {M : Matrix R n n} : _ <~> IsDiagonal M := ltac:(issig). (** A matrix is diagonal in a unique way. *) Global Instance ishprop_isdiagonal {R : Ring@{i}} {n : nat} (M : Matrix R n n) : IsHProp (IsDiagonal M). Proof. snrapply hprop_allpath. intros x y. snrapply ((equiv_ap' issig_IsDiagonal^-1%equiv _ _ )^-1%equiv). rapply path_sigma_hprop; cbn. apply isinj_matrix_diag. exact ((isdiagonal_diag M)^ @ isdiagonal_diag M). Defined. (** The zero matrix is diagonal. *) Global Instance isdiagonal_matrix_zero {R : Ring@{i}} {n : nat} : IsDiagonal (matrix_zero R n n). Proof. exists (vector_zero R n). snrapply path_matrix. intros i j Hi Hj. rewrite 2 entry_Build_Matrix, entry_Build_Vector. by rewrite rng_mult_zero_r. Defined. (** The identity matrix is diagonal. *) Global Instance isdiagonal_identity_matrix {R : Ring@{i}} {n : nat} : IsDiagonal (identity_matrix R n). Proof. exists (Build_Vector R n (fun _ _ => 1)). snrapply path_matrix. intros i j Hi Hj. rewrite 2 entry_Build_Matrix, entry_Build_Vector. by rewrite rng_mult_one_r. Defined. (** The sum of two diagonal matrices is diagonal. *) Global Instance isdiagonal_matrix_plus {R : Ring@{i}} {n : nat} (M N : Matrix R n n) `{IsDiagonal R n M} `{IsDiagonal R n N} : IsDiagonal (matrix_plus M N). Proof. exists (vector_plus (isdiagonal_diag_vector M) (isdiagonal_diag_vector N)). rewrite (isdiagonal_diag M), (isdiagonal_diag N). apply matrix_diag_plus. Defined. (** The negative of a diagonal matrix is diagonal. *) Global Instance isdiagonal_matrix_negate {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{IsDiagonal R n M} : IsDiagonal (matrix_negate M). Proof. exists (vector_neg _ _ (isdiagonal_diag_vector M)). rewrite (isdiagonal_diag M). snrapply path_matrix. intros i j Hi Hj. rewrite !entry_Build_Matrix, !entry_Build_Vector. by rewrite rng_mult_negate_r. Defined. (** The product of two diagonal matrices is diagonal. *) Global Instance isdiagonal_matrix_mult {R : Ring@{i}} {n : nat} (M N : Matrix R n n) `{IsDiagonal R n M} `{IsDiagonal R n N} : IsDiagonal (matrix_mult M N). Proof. exists (vector_map2 (.*.) (isdiagonal_diag_vector M) (isdiagonal_diag_vector N)). rewrite (isdiagonal_diag M), (isdiagonal_diag N). apply matrix_diag_mult. Defined. (** The transpose of a diagonal matrix is diagonal. *) Global Instance isdiagonal_matrix_transpose {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{IsDiagonal R n M} : IsDiagonal (matrix_transpose M). Proof. exists (isdiagonal_diag_vector M). rewrite (isdiagonal_diag M). apply matrix_transpose_diag. Defined. (** Given a square matrix, we can extract the diagonal as a vector. *) Definition matrix_diag_vector {R : Ring} {n : nat} (M : Matrix R n n) : Vector R n := Build_Vector R n (fun i _ => entry M i i). (** Diagonal matrices form a subring of the ring of square matrices. *) Definition matrix_diag_ring@{i} (R : Ring@{i}) (n : nat) : Subring@{i i} (matrix_ring R n). Proof. snrapply (Build_Subring' (fun M : matrix_ring R n => IsDiagonal M) _); hnf. - intros; exact _. - intros x y dx dy. nrapply isdiagonal_matrix_plus; trivial. by nrapply isdiagonal_matrix_negate. - nrapply isdiagonal_matrix_mult. - nrapply isdiagonal_identity_matrix. Defined. (** ** Trace *) (** The trace of a square matrix is the sum of the diagonal entries. *) Definition matrix_trace {R : Ring} {n} (M : Matrix R n n) : R := ab_sum n (fun i Hi => entry M i i). (** The trace of a matrix preserves addition. *) Definition matrix_trace_plus {R : Ring} {n} (M N : Matrix R n n) : matrix_trace (matrix_plus M N) = (matrix_trace M) + (matrix_trace N). Proof. unfold matrix_trace. lhs nrapply path_ab_sum. { intros i Hi. by rewrite entry_Build_Matrix. } by rewrite ab_sum_plus. Defined. (** The trace of a matrix preserves scalar multiplication. *) Definition matrix_trace_lact {R : Ring} {n} (r : R) (M : Matrix R n n) : matrix_trace (matrix_lact r M) = r * matrix_trace M. Proof. unfold matrix_trace. rewrite rng_sum_dist_l. apply path_ab_sum. intros i Hi. by rewrite entry_Build_Matrix. Defined. (** The trace of a matrix multiplication is the same as the trace of the reverse multiplication. This holds only in a commutative ring. *) Definition matrix_trace_mult {R : CRing} {m n : nat} (M : Matrix R m n) (N : Matrix R n m) : matrix_trace (matrix_mult M N) = matrix_trace (matrix_mult N M). Proof. lhs nrapply path_ab_sum. { intros i Hi. lhs nrapply entry_Build_Matrix. nrapply path_ab_sum. intros j Hj. apply rng_mult_comm. } lhs nrapply ab_sum_sum. apply path_ab_sum. intros i Hi. rhs nrapply entry_Build_Matrix. reflexivity. Defined. (** The trace of the transpose of a matrix is the same as the trace of the matrix. *) Definition trace_transpose {R : Ring} {n} (M : Matrix R n n) : matrix_trace (matrix_transpose M) = matrix_trace M. Proof. apply path_ab_sum. intros i Hi. nrapply entry_Build_Matrix. Defined. (** ** Matrix minors *) Definition skip (n : nat) : nat -> nat := fun i => if dec (i < n)%nat then i else i.+1%nat. Global Instance isinjective_skip n : IsInjective (skip n). Proof. hnf. intros x y p. unfold skip in p. destruct (dec (x < n)%nat) as [H|H], (dec (y < n)%nat) as [H'|H']. - exact p. - symmetry in p; destruct p. contradiction (H' (leq_trans _ H)). - destruct p. contradiction (H (leq_trans _ H')). - by apply path_nat_succ. Defined. Local Instance lt_n1_skip k i n (H : (i < n.+1)%nat) (H' : (k < n)%nat) : (skip i k < n.+1)%nat. Proof. unfold skip. destruct (dec (k < i))%nat as [H''|H'']; exact _. Defined. Definition matrix_minor {R : Ring@{i}} {n : nat} (i j : nat) {Hi : (i < n.+1)%nat} {Hj : (j < n.+1)%nat} (M : Matrix R n.+1 n.+1) : Matrix R n n := Build_Matrix R n n (fun k l _ _ => entry M (skip i k) (skip j l)). (** A minor of the zero matrix is again the zero matrix. *) Definition matrix_minor_zero {R : Ring@{i}} {n : nat} (i j : nat) (Hi : (i < n.+1)%nat) (Hj : (j < n.+1)%nat) : matrix_minor i j (matrix_zero R n.+1 n.+1) = matrix_zero R n n. Proof. apply path_matrix. intros k l Hk Hl. by rewrite !entry_Build_Matrix. Defined. Definition matrix_minor_identity {R : Ring@{i}} {n : nat} (i : nat) (Hi : (i < n.+1)%nat) : matrix_minor i i (identity_matrix R n.+1) = identity_matrix R n. Proof. apply path_matrix. intros j k Hj Hk. rewrite 3 entry_Build_Matrix. rapply kronecker_delta_map_inj. Defined. Definition matrix_minor_plus {R : Ring@{i}} {n : nat} (i j : nat) (Hi : (i < n.+1)%nat) (Hj : (j < n.+1)%nat) (M N : Matrix R n.+1 n.+1) : matrix_minor i j (matrix_plus M N) = matrix_plus (matrix_minor i j M) (matrix_minor i j N). Proof. apply path_matrix. intros k l Hk Hl. by rewrite !entry_Build_Matrix, !entry_Build_Vector. Defined. Definition matrix_minor_scale {R : Ring@{i}} {n : nat} (i j : nat) (Hi : (i < n.+1)%nat) (Hj : (j < n.+1)%nat) (r : R) (M : Matrix R n.+1 n.+1) : matrix_minor i j (matrix_lact r M) = matrix_lact r (matrix_minor i j M). Proof. apply path_matrix. intros k l Hk Hl. by rewrite !entry_Build_Matrix, !entry_Build_Vector. Defined. Definition matrix_minor_transpose {R : Ring@{i}} {n : nat} (i j : nat) (Hi : (i < n.+1)%nat) (Hj : (j < n.+1)%nat) (M : Matrix R n.+1 n.+1) : matrix_minor j i (matrix_transpose M) = matrix_transpose (matrix_minor i j M). Proof. apply path_matrix. intros k l Hk Hl. by rewrite 4 entry_Build_Matrix. Defined. (** ** Triangular matrices *) (** A matrix is upper triangular if all the entries below the diagonal are zero. *) Class IsUpperTriangular@{i} {R : Ring@{i}} {n : nat} (M : Matrix@{i} R n n) : Type@{i} := upper_triangular : merely@{i} (forall i j (Hi : (i < n)%nat) (Hj : (j < n)%nat), (i < j)%nat -> entry M i j = 0). Global Instance ishprop_isuppertriangular@{i} {R : Ring@{i}} {n : nat} (M : Matrix R n n) : IsHProp (IsUpperTriangular M). Proof. apply istrunc_truncation@{i i}. Defined. (** A matrix is lower triangular if all the entries above the diagonal are zero. We define it as the transpose being upper triangular. *) Class IsLowerTriangular {R : Ring@{i}} {n : nat} (M : Matrix@{i} R n n) : Type@{i} := upper_triangular_transpose :: IsUpperTriangular (matrix_transpose M). Global Instance ishprop_islowertriangular@{i} {R : Ring@{i}} {n : nat} (M : Matrix R n n) : IsHProp (IsLowerTriangular M). Proof. apply istrunc_truncation@{i i}. Defined. (** The transpose of a matrix is lower triangular if and only if the matrix is upper triangular. *) Global Instance lower_triangular_transpose {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{!IsUpperTriangular M} : IsLowerTriangular (matrix_transpose M). Proof. unfold IsLowerTriangular. by rewrite matrix_transpose_transpose. Defined. (** The sum of two upper triangular matrices is upper triangular. *) Global Instance upper_triangular_plus@{i} {R : Ring@{i}} {n : nat} (M N : Matrix R n n) {H1 : IsUpperTriangular M} {H2 : IsUpperTriangular N} : IsUpperTriangular (matrix_plus M N). Proof. unfold IsUpperTriangular. (* We use [strip_reflections] rather than [strip_truncations] here and below because it generates fewer universe variables in some versions of Coq. *) strip_reflections; apply tr. intros i j Hi Hj lt_i_j. specialize (H1 i j Hi Hj lt_i_j). specialize (H2 i j Hi Hj lt_i_j). rewrite entry_Build_Matrix. change (Vector.entry (Vector.entry ?M ?i) ?j) with (entry M i j). rewrite H1, H2. by rewrite rng_plus_zero_l. Defined. (** The sum of two lower triangular matrices is lower triangular. *) Global Instance lower_triangular_plus {R : Ring@{i}} {n : nat} (M N : Matrix R n n) `{!IsLowerTriangular M} `{!IsLowerTriangular N} : IsLowerTriangular (matrix_plus M N). Proof. unfold IsLowerTriangular. rewrite matrix_transpose_plus. by apply upper_triangular_plus. Defined. (** The negation of an upper triangular matrix is upper triangular. *) Global Instance upper_triangular_negate@{i} {R : Ring@{i}} {n : nat} (M : Matrix R n n) {H : IsUpperTriangular M} : IsUpperTriangular (matrix_negate M). Proof. unfold IsUpperTriangular. strip_reflections; apply tr. intros i j Hi Hj lt_i_j. rewrite entry_Build_Matrix. rewrite <- rng_negate_zero; f_ap. by nrapply H. Defined. (** The negation of a lower triangular matrix is lower triangular. *) Global Instance lower_triangular_negate {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{!IsLowerTriangular M} : IsLowerTriangular (matrix_negate M). Proof. unfold IsLowerTriangular. rewrite matrix_transpose_negate. by apply upper_triangular_negate. Defined. (** The product of two upper triangular matrices is upper triangular. *) Global Instance upper_triangular_mult@{i} {R : Ring@{i}} {n : nat} (M N : Matrix R n n) {H1 : IsUpperTriangular M} {H2 : IsUpperTriangular N} : IsUpperTriangular (matrix_mult M N). Proof. unfold IsUpperTriangular. strip_reflections; apply tr. intros i j Hi Hj lt_i_j. rewrite entry_Build_Matrix. apply ab_sum_zero. intros k Hk. destruct (dec (k <= i)%nat) as [leq_k_i|gt_k_i]. { rewrite H2. 1: by rewrite rng_mult_zero_r. rapply lt_leq_lt_trans. } apply gt_iff_not_leq in gt_k_i. rewrite H1. 1: by rewrite rng_mult_zero_l. assumption. Defined. (** The product of two lower triangular matrices is lower triangular. *) Global Instance lower_triangular_mult {R : Ring@{i}} {n : nat} (M N : Matrix R n n) {H1 : IsLowerTriangular M} {H2 : IsLowerTriangular N} : IsLowerTriangular (matrix_mult M N). Proof. unfold IsLowerTriangular. rewrite matrix_transpose_mult. nrapply (upper_triangular_mult (R:=rng_op R)); assumption. Defined. (** The zero matrix is upper triangular. *) Global Instance upper_triangular_zero {R : Ring@{i}} {n : nat} : IsUpperTriangular (matrix_zero R n n). Proof. apply tr. by hnf; intros; rewrite entry_Build_Matrix. Defined. (** The zero matrix is lower triangular. *) Global Instance lower_triangular_zero {R : Ring@{i}} {n : nat} : IsLowerTriangular (matrix_zero R n n). Proof. unfold IsLowerTriangular. rewrite matrix_transpose_zero. exact _. Defined. (** The identity matrix is upper triangular. *) Global Instance upper_triangular_identity@{i} {R : Ring@{i}} {n : nat} : IsUpperTriangular (identity_matrix R n). Proof. unfold IsUpperTriangular. apply tr@{i}. intros i j Hi Hj lt_i_j. rewrite entry_Build_Matrix@{i}. by apply kronecker_delta_lt. Defined. (** The identity matrix is lower triangular. *) Global Instance lower_triangular_identity@{i} {R : Ring@{i}} {n : nat} : IsLowerTriangular (identity_matrix R n). Proof. unfold IsLowerTriangular. rewrite matrix_transpose_identity. exact _. Defined. (** A diagonal matrix is upper triangular. *) Global Instance upper_triangular_diag {R : Ring@{i}} {n : nat} (v : Vector R n) : IsUpperTriangular (matrix_diag v). Proof. unfold IsUpperTriangular. apply tr. intros i j Hi Hj lt_i_j. rewrite entry_Build_Matrix. rewrite kronecker_delta_lt. 1: by rewrite rng_mult_zero_l. exact _. Defined. (** A diagonal matrix is lower triangular. *) Global Instance lower_triangular_diag {R : Ring@{i}} {n : nat} (v : Vector R n) : IsLowerTriangular (matrix_diag v). Proof. unfold IsLowerTriangular. rewrite matrix_transpose_diag. apply upper_triangular_diag. Defined. (** Upper triangular matrices are a subring of the ring of matrices. *) Definition upper_triangular_matrix_ring@{i} (R : Ring@{i}) (n : nat) : Subring@{i i} (matrix_ring@{i} R n). Proof. nrapply (Build_Subring' (fun M : matrix_ring R n => IsUpperTriangular M)). - exact _. (* These can all be found by typeclass search, but being explicit makes this faster. *) - intros x y ? ?; exact (upper_triangular_plus x (-y)). - exact upper_triangular_mult. - exact upper_triangular_identity. Defined. (** Lower triangular matrices are a subring of the ring of matrices. *) Definition lower_triangular_matrix_ring@{i} (R : Ring@{i}) (n : nat) : Subring@{i i} (matrix_ring R n). Proof. nrapply (Build_Subring'@{i i} (fun M : matrix_ring R n => IsLowerTriangular M)). - exact _. (* These can all be found by typeclass search, but being explicit makes this faster. *) - intros x y ? ?; exact (lower_triangular_plus x (-y)). - exact lower_triangular_mult. - exact lower_triangular_identity. Defined. (** ** Symmetric Matrices *) (** A matrix is symmetric when it is equal to its transpose. *) Class IsSymmetric {R : Ring@{i}} {n : nat} (M : Matrix@{i} R n n) : Type@{i} := matrix_transpose_issymmetric : matrix_transpose M = M. Arguments matrix_transpose_issymmetric {R n} M {_}. (** The zero matrix is symmetric. *) Global Instance issymmetric_matrix_zero {R : Ring@{i}} {n : nat} : IsSymmetric (matrix_zero R n n) := matrix_transpose_zero. (** The identity matrix is symmetric. *) Global Instance issymmetric_matrix_identity {R : Ring@{i}} {n : nat} : IsSymmetric (identity_matrix R n) := matrix_transpose_identity. (** The sum of two symmetric matrices is symmetric. *) Global Instance issymmetric_matrix_plus {R : Ring@{i}} {n : nat} (M N : Matrix R n n) `{!IsSymmetric M} `{!IsSymmetric N} : IsSymmetric (matrix_plus M N). Proof. unfold IsSymmetric. rewrite matrix_transpose_plus. f_ap. Defined. (** The negation of a symmetric matrix is symmetric. *) Global Instance issymmetric_matrix_negate {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{!IsSymmetric M} : IsSymmetric (matrix_negate M). Proof. unfold IsSymmetric. rewrite matrix_transpose_negate. f_ap. Defined. (** A scalar multiple of a symmetric matrix is symmetric. *) Global Instance issymmetric_matrix_scale {R : Ring@{i}} {n : nat} (r : R) (M : Matrix R n n) `{!IsSymmetric M} : IsSymmetric (matrix_lact r M). Proof. unfold IsSymmetric. rewrite matrix_transpose_lact. f_ap. Defined. (** The transpose of a symmetric matrix is symmetric. *) Global Instance issymmetric_matrix_transpose {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{!IsSymmetric M} : IsSymmetric (matrix_transpose M). Proof. unfold IsSymmetric. rewrite matrix_transpose_transpose. by symmetry. Defined. (** A symmetric upper triangular matrix is diagonal. *) Global Instance isdiagonal_upper_triangular_issymmetric {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{!IsSymmetric M} {H : IsUpperTriangular M} : IsDiagonal M. Proof. exists (matrix_diag_vector M). snrapply path_matrix. intros i j Hi Hj. rewrite entry_Build_Matrix, entry_Build_Vector. strip_truncations. destruct (dec (i = j)) as [p|np]. { destruct p. rewrite kronecker_delta_refl. rewrite rng_mult_one_l. f_ap; apply path_ishprop. } apply neq_iff_lt_or_gt in np. destruct np as [l | l]. - rewrite (kronecker_delta_lt l). rewrite rng_mult_zero_l. by rewrite H. - rewrite (kronecker_delta_gt l). rewrite rng_mult_zero_l. rewrite <- (matrix_transpose_issymmetric M). rewrite entry_Build_Matrix. by rewrite H. Defined. (** A symmetric lower triangular matrix is diagonal. *) Global Instance isdiagonal_lower_triangular_issymmetric {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{!IsSymmetric M} `{!IsLowerTriangular M} : IsDiagonal M. Proof. rewrite <- (matrix_transpose_issymmetric M). rapply isdiagonal_upper_triangular_issymmetric. Defined. (** Note that symmetric matrices do not form a subring (or subalgebra) but they do form a submodule of the module of matrices. *) (** ** Skew-symmetric Matrices *) (** A matrix is skew-symmetric when it is equal to the negation of its transpose. *) Class IsSkewSymmetric {R : Ring@{i}} {n : nat} (M : Matrix@{i} R n n) : Type@{i} := matrix_transpose_isskewsymmetric : matrix_transpose M = matrix_negate M. Arguments matrix_transpose_isskewsymmetric {R n} M {_}. (** The zero matrix is skew-symmetric. *) Global Instance isskewsymmetric_matrix_zero {R : Ring@{i}} {n : nat} : IsSkewSymmetric (matrix_zero R n n). Proof. unfold IsSkewSymmetric. rewrite matrix_transpose_zero. symmetry. nrapply (rng_negate_zero (A:=matrix_ring R n)). Defined. (** The negation of a skew-symmetric matrix is skew-symmetric. *) Global Instance isskewsymmetric_matrix_negate {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{!IsSkewSymmetric M} : IsSkewSymmetric (matrix_negate M). Proof. unfold IsSkewSymmetric. rewrite matrix_transpose_negate. f_ap. Defined. (** A scalar multiple of a skew-symmetric matrix is skew-symmetric. *) Global Instance isskewsymmetric_matrix_scale {R : Ring@{i}} {n : nat} (r : R) (M : Matrix R n n) `{!IsSkewSymmetric M} : IsSkewSymmetric (matrix_lact r M). Proof. unfold IsSkewSymmetric. rewrite matrix_transpose_lact. rhs_V nrapply (lm_neg (M:=Build_LeftModule _ (abgroup_matrix R n n) _) r M). f_ap. Defined. (** The transpose of a skew-symmetric matrix is skew-symmetric. *) Global Instance isskewsymmetric_matrix_transpose {R : Ring@{i}} {n : nat} (M : Matrix R n n) `{!IsSkewSymmetric M} : IsSkewSymmetric (matrix_transpose M). Proof. unfold IsSkewSymmetric. rewrite <- matrix_transpose_negate. f_ap. Defined. (** The sum of two skew-symmetric matrices is skew-symmetric. *) Global Instance isskewsymmetric_matrix_plus {R : Ring@{i}} {n : nat} (M N : Matrix R n n) `{!IsSkewSymmetric M} `{!IsSkewSymmetric N} : IsSkewSymmetric (matrix_plus M N). Proof. unfold IsSkewSymmetric. rewrite matrix_transpose_plus. rhs nrapply (grp_inv_op (G:=abgroup_matrix R n n)). rhs_V rapply AbelianGroup.abgroup_commutative. f_ap. Defined. (** Skew-symmetric matrices degenerate to symmetric matrices in rings with characteristic 2. In odd characteristic the module of matrices can be decomposed into the direct sum of symmetric and skew-symmetric matrices. *) Section MatrixCat. (** The wild category [MatrixCat R] of [R]-valued matrices. This category has natural numbers as objects and m x n matrices as the arrows between [m] and [n]. *) Definition MatrixCat (R : Ring) := nat. Global Instance isgraph_matrixcat {R : Ring} : IsGraph (MatrixCat R) := {| Hom := Matrix R |}. Global Instance is01cat_matrixcat {R : Ring} : Is01Cat (MatrixCat R). Proof. snrapply Build_Is01Cat. - exact (identity_matrix R). - intros l m n M N. exact (matrix_mult N M). Defined. Global Instance is2graph_matrixcat {R : Ring} : Is2Graph (MatrixCat R) := is2graph_paths _. (** MatrixCat R forms a strong 1-category. *) Global Instance is1catstrong_matrixcat {R : Ring} : Is1Cat_Strong (MatrixCat R). Proof. snrapply Build_Is1Cat_Strong. (* Most of the structure comes from typeclasses in WildCat.Paths. *) 1-4: exact _. - apply (associative_matrix_mult R). - intros k l m n M N P. apply inverse. apply (associative_matrix_mult R). - apply right_identity_matrix_mult. - apply left_identity_matrix_mult. Defined. (** TODO: Define HasEquivs for MatrixCat. *) End MatrixCat. Coq-HoTT-9.0/theories/Algebra/Rings/Module.v000066400000000000000000000556101474641544500206220ustar00rootroot00000000000000Require Import WildCat. Require Import Spaces.Nat.Core. (* Some of the material in abstract_algebra and canonical names could be selectively exported to the user, as is done in Groups/Group.v. *) Require Import Classes.interfaces.canonical_names. Require Import Algebra.Groups.QuotientGroup. Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Biproduct. Require Import Rings.Ring. Declare Scope module_scope. Local Open Scope module_scope. (** * Modules over a ring. *) (** ** Left Modules *) (** An abelian group [M] is a left [R]-module when equipped with the following data: *) Class IsLeftModule (R : Ring) (M : AbGroup) := { (** A function [lact] (left-action) that takes an element [r : R] and an element [m : M] and returns an element [lact r m : M], which we also denote [r *L m]. *) lact : R -> M -> M; (** Actions distribute on the left over addition in the abelian group. That is [r *L (m + n) = r *L m + r *L n]. *) lact_left_dist :: LeftHeteroDistribute lact (+) (+); (** Actions distribute on the right over addition in the ring. That is [(r + s) *L m = r *L m + s *L m]. *) lact_right_dist :: RightHeteroDistribute lact (+) (+); (** Actions are associative. That is [(r * s) *L m = r *L (s *L m)]. *) lact_assoc :: HeteroAssociative lact lact lact (.*.); (** Actions preserve the multiplicative identity. That is [1 *L m = m]. *) lact_unit :: LeftIdentity lact 1; }. Infix "*L" := lact : module_scope. (** A left R-module is an abelian group equipped with a left R-module structure. *) Record LeftModule (R : Ring) := { lm_carrier :> AbGroup; lm_lact :: IsLeftModule R lm_carrier; }. Section LeftModuleAxioms. Context {R : Ring} {M : LeftModule R} (r s : R) (m n : M). (** Here we state the module axioms in a readable form for direct use. *) Definition lm_dist_l : r *L (m + n) = r *L m + r *L n := lact_left_dist r m n. Definition lm_dist_r : (r + s) *L m = r *L m + s *L m := lact_right_dist r s m. Definition lm_assoc : r *L (s *L m) = (r * s) *L m := lact_assoc r s m. Definition lm_unit : 1 *L m = m := lact_unit m. End LeftModuleAxioms. (** ** Facts about left modules *) Section LeftModuleFacts. Context {R : Ring} {M : LeftModule R} (r : R) (m : M). (** Here are some quick facts that hold in modules. *) (** The left action of zero is zero. *) Definition lm_zero_l : 0 *L m = 0. Proof. apply (grp_cancelL1 (z := lact 0 m)). lhs_V nrapply lm_dist_r. f_ap. apply rng_plus_zero_r. Defined. (** The left action on zero is zero. *) Definition lm_zero_r : r *L (0 : M) = 0. Proof. apply (grp_cancelL1 (z := lact r 0)). lhs_V nrapply lm_dist_l. f_ap. apply grp_unit_l. Defined. (** The left action of [-1] is the additive inverse. *) Definition lm_minus_one : -1 *L m = -m. Proof. apply grp_moveL_1V. lhs nrapply (ap (_ +) (lm_unit m)^). lhs_V nrapply lm_dist_r. rhs_V nrapply lm_zero_l. f_ap. apply grp_inv_l. Defined. (** The left action of [r] on the additive inverse of [m] is the additive inverse of the left action of [r] on [m]. *) Definition lm_neg : r *L -m = - (r *L m). Proof. apply grp_moveL_1V. lhs_V nrapply lm_dist_l. rhs_V nrapply lm_zero_r. f_ap. apply grp_inv_l. Defined. End LeftModuleFacts. (** Every ring [R] is a left [R]-module over itself. *) Global Instance isleftmodule_ring (R : Ring) : IsLeftModule R R. Proof. rapply Build_IsLeftModule. Defined. (** ** Right Modules *) (** An abelian group [M] is a right [R]-module when it is a left [R^op]-module. *) Class IsRightModule (R : Ring) (M : AbGroup) := isleftmodule_op_isrightmodule :: IsLeftModule (rng_op R) M. (** [ract] (right-action) that takes an element [m : M] and an element [r : R] and returns an element [ract m r : M] which we also denote [m *R r]. *) Definition ract {R : Ring} {M : AbGroup} `{!IsRightModule R M} : M -> R -> M := fun m r => lact (R:=rng_op R) r m. Infix "*R" := ract. (** A right module is a left module over the opposite ring. *) Definition RightModule (R : Ring) := LeftModule (rng_op R). (** Right modules are right modules. *) Global Instance rm_ract {R : Ring} {M : RightModule R} : IsRightModule R M := lm_lact (rng_op R) M. Section RightModuleAxioms. Context {R : Ring} {M : RightModule R} (m n : M) (r s : R). (** Here we state the module axioms in a readable form for direct use. *) Definition rm_dist_r : (m + n) *R r = m *R r + n *R r := lm_dist_l (R:=rng_op R) r m n. Definition rm_dist_l : m *R (r + s) = m *R r + m *R s := lm_dist_r (R:=rng_op R) r s m. Definition rm_assoc : (m *R r) *R s = m *R (r * s) := lm_assoc (R:=rng_op R) s r m. Definition rm_unit : m *R 1 = m := lm_unit (R:=rng_op R) m. End RightModuleAxioms. (** ** Facts about right modules *) Section RightModuleFacts. Context {R : Ring} {M : RightModule R} (m : M) (r : R). (** The right action on zero is zero. *) Definition rm_zero_l : (0 : M) *R r = 0 := lm_zero_r (R:=rng_op R) r. (** The right adtion of zero is zero. *) Definition rm_zero_r : m *R 0 = 0 := lm_zero_l (R:=rng_op R) m. (** The right action of [-1] is the additive inverse. *) Definition rm_minus_one : m *R -1 = -m := lm_minus_one (R:=rng_op R) m. (** The right action of [r] on the additive inverse of [m] is the additive inverse of the right action of [r] on [m]. *) Definition rm_neg : -m *R r = - (m *R r) := lm_neg (R:=rng_op R) r m. End RightModuleFacts. (** Every ring [R] is a right [R]-module over itself. *) Global Instance isrightmodule_ring (R : Ring) : IsRightModule R R := isleftmodule_ring (rng_op R). (** ** Submodules *) (** A subgroup of a left R-module is a left submodule if it is closed under the action of R. *) Class IsLeftSubmodule {R : Ring} {M : LeftModule R} (N : M -> Type) := { ils_issubgroup :: IsSubgroup N; is_left_submodule : forall r m, N m -> N (r *L m); }. (** A subgroup of a right R-module is a right submodule if it is a left submodule over the opposite ring. *) Class IsRightSubmodule {R : Ring} {M : RightModule R} (N : M -> Type) := isleftsubmodule_op_isrightsubmodule :: IsLeftSubmodule (R:=rng_op R) N. (** A left submodule is a subgroup of the abelian group closed under the left action of R. *) Record LeftSubmodule {R : Ring} (M : LeftModule R) := { lsm_carrier :> M -> Type; lsm_submodule :: IsLeftSubmodule lsm_carrier; }. (** A right submodule is a subgroup of the abelian group closed under the right action of R. *) Definition RightSubmodule {R : Ring} (M : RightModule R) := LeftSubmodule (R:=rng_op R) M. Definition subgroup_leftsubmodule {R : Ring} {M : LeftModule R} : LeftSubmodule M -> Subgroup M := fun N => Build_Subgroup M N _. Coercion subgroup_leftsubmodule : LeftSubmodule >-> Subgroup. Definition subgroup_rightsubmodule {R : Ring} {M : RightModule R} : RightSubmodule M -> Subgroup M := idmap. Coercion subgroup_rightsubmodule : RightSubmodule >-> Subgroup. (** Left submodules inherit the left R-module structure of their parent. *) Global Instance isleftmodule_leftsubmodule {R : Ring} {M : LeftModule R} (N : LeftSubmodule M) : IsLeftModule R N. Proof. snrapply Build_IsLeftModule. - intros r [n n_in_N]. exists (r *L n). by apply lsm_submodule. - intros r [n] [m]; apply path_sigma_hprop. apply lact_left_dist. - intros r s [n]; apply path_sigma_hprop. apply lact_right_dist. - intros r s [n]; apply path_sigma_hprop. apply lact_assoc. - intros [n]; apply path_sigma_hprop. apply lact_unit. Defined. (** Right submodules inherit the right R-module structure of their parent. *) Global Instance isrightmodule_rightsubmodule {R : Ring} {M : RightModule R} (N : RightSubmodule M) : IsRightModule R N := isleftmodule_leftsubmodule (R:=rng_op R) N. (** Any left submodule of a left R-module is a left R-module. *) Definition leftmodule_leftsubmodule {R : Ring} {M : LeftModule R} (N : LeftSubmodule M) : LeftModule R := Build_LeftModule R N _. Coercion leftmodule_leftsubmodule : LeftSubmodule >-> LeftModule. (** Any right submodule of a right R-module is a right R-module. *) Definition rightmodule_rightsubmodule {R : Ring} {M : RightModule R} (N : RightSubmodule M) : RightModule R := N. Coercion rightmodule_rightsubmodule : RightSubmodule >-> RightModule. (** The submodule criterion. This is a convenient way to build submodules. *) Definition Build_IsLeftSubmodule' {R : Ring} {M : LeftModule R} (H : M -> Type) `{forall x, IsHProp (H x)} (z : H zero) (c : forall r n m, H n -> H m -> H (n + r *L m)) : IsLeftSubmodule H. Proof. snrapply Build_IsLeftSubmodule. - snrapply Build_IsSubgroup'. + exact _. + exact z. + intros x y hx hy. change (sg_op ?x ?y) with (x + y). pose proof (p := c (-1) x y hx hy). rewrite lm_minus_one in p. exact p. - intros r m hm. rewrite <- (grp_unit_l). by apply c. Defined. Definition Build_IsRightSubmodule' {R : Ring} {M : RightModule R} (H : M -> Type) `{forall x, IsHProp (H x)} (z : H zero) (c : forall r n m, H n -> H m -> H (n + ract m r)) : IsRightSubmodule H := Build_IsLeftSubmodule' (R:=rng_op R) H z c. Definition Build_LeftSubmodule' {R : Ring} {M : LeftModule R} (H : M -> Type) `{forall x, IsHProp (H x)} (z : H zero) (c : forall r n m, H n -> H m -> H (n + r *L m)) : LeftSubmodule M. Proof. pose (p := Build_IsLeftSubmodule' H z c). snrapply Build_LeftSubmodule. 1: snrapply (Build_Subgroup _ H). 2: exact p. rapply ils_issubgroup. Defined. Definition Build_RightSubmodule {R : Ring} {M : RightModule R} (H : M -> Type) `{forall x, IsHProp (H x)} (z : H zero) (c : forall r n m, H n -> H m -> H (n + m *R r)) : RightSubmodule M := Build_LeftSubmodule' (R:=rng_op R) H z c. (** ** R-module homomorphisms *) (** A left module homomorphism is a group homomorphism that commutes with the left action of R. *) Record LeftModuleHomomorphism {R : Ring} (M N : LeftModule R) := { lm_homo_map :> GroupHomomorphism M N; lm_homo_lact : forall r m, lm_homo_map (r *L m) = r *L lm_homo_map m; }. Definition RightModuleHomomorphism {R : Ring} (M N : RightModule R) := LeftModuleHomomorphism (R:=rng_op R) M N. Definition rm_homo_map {R : Ring} {M N : RightModule R} : RightModuleHomomorphism M N -> GroupHomomorphism M N := lm_homo_map (R:=rng_op R) M N. Coercion rm_homo_map : RightModuleHomomorphism >-> GroupHomomorphism. Definition rm_homo_ract {R : Ring} {M N : RightModule R} (f : RightModuleHomomorphism M N) : forall m r, f (ract m r) = ract (f m) r := fun m r => lm_homo_lact (R:=rng_op R) M N f r m. Definition lm_homo_id {R : Ring} (M : LeftModule R) : LeftModuleHomomorphism M M. Proof. snrapply Build_LeftModuleHomomorphism. - exact grp_homo_id. - reflexivity. Defined. Definition rm_homo_id {R : Ring} (M : RightModule R) : RightModuleHomomorphism M M := lm_homo_id (R:=rng_op R) M. Definition lm_homo_compose {R : Ring} {M N L : LeftModule R} : LeftModuleHomomorphism N L -> LeftModuleHomomorphism M N -> LeftModuleHomomorphism M L. Proof. intros f g. snrapply Build_LeftModuleHomomorphism. - exact (grp_homo_compose f g). - intros r m. rhs_V nrapply lm_homo_lact. apply (ap f). apply lm_homo_lact. Defined. Definition rm_homo_compose {R : Ring} {M N L : RightModule R} : RightModuleHomomorphism N L -> RightModuleHomomorphism M N -> RightModuleHomomorphism M L := lm_homo_compose (R:=rng_op R). (** Smart constructor for building left module homomorphisms from a map. *) Definition Build_LeftModuleHomomorphism' {R : Ring} {M N : LeftModule R} (f : M -> N) (p : forall r x y, f (r *L x + y) = r *L f x + f y) : LeftModuleHomomorphism M N. Proof. snrapply Build_LeftModuleHomomorphism. - snrapply Build_GroupHomomorphism. + exact f. + intros x y. rewrite <- (lm_unit (f x)). set (lact 1 (f x)). rewrite <- (lm_unit x). apply p. - intros r m. simpl. rewrite <- (grp_unit_r (lact r m)). rewrite p. rhs_V nrapply grp_unit_r. apply grp_cancelL. specialize (p 1 0 0). rewrite 2 lm_unit in p. apply (grp_cancelL1 (z := f 0)). lhs_V nrapply p. apply ap. apply grp_unit_l. Defined. Definition Build_RightModuleHomomorphism' {R :Ring} {M N : RightModule R} (f : M -> N) (p : forall r x y, f (x *R r + y) = f x *R r + f y) : RightModuleHomomorphism M N := Build_LeftModuleHomomorphism' (R:=rng_op R) f p. Record LeftModuleIsomorphism {R : Ring} (M N : LeftModule R) := { lm_iso_map :> LeftModuleHomomorphism M N; isequiv_lm_iso_map :: IsEquiv lm_iso_map; }. Definition RightModuleIsomorphism {R : Ring} (M N : RightModule R) := LeftModuleIsomorphism (R:=rng_op R) M N. Definition Build_LeftModuleIsomorphism' {R : Ring} (M N : LeftModule R) (f : GroupIsomorphism M N) (p : forall r x, f (r *L x) = r *L f x) : LeftModuleIsomorphism M N. Proof. snrapply Build_LeftModuleIsomorphism. - snrapply Build_LeftModuleHomomorphism. + exact f. + exact p. - exact _. Defined. Definition Build_RightModuleIsomorphism' {R : Ring} (M N : RightModule R) (f : GroupIsomorphism M N) (p : forall r x, f (ract x r) = ract (f x) r) : RightModuleIsomorphism M N := Build_LeftModuleIsomorphism' (R:=rng_op R) M N f p. Definition lm_iso_inverse {R : Ring} {M N : LeftModule R} : LeftModuleIsomorphism M N -> LeftModuleIsomorphism N M. Proof. intros f. snrapply Build_LeftModuleIsomorphism. - snrapply Build_LeftModuleHomomorphism'. + exact f^-1. + intros r m n. apply moveR_equiv_V. rhs nrapply grp_homo_op. symmetry. f_ap. 2: apply eisretr. lhs nrapply lm_homo_lact. apply ap. apply eisretr. - exact _. Defined. Definition rm_iso_inverse {R : Ring} {M N : RightModule R} : RightModuleIsomorphism M N -> RightModuleIsomorphism N M := lm_iso_inverse (R:=rng_op R). (** ** Category of left and right R-modules *) (** TODO: define as a displayed category over Ring *) (** *** Category of left R-modules *) Global Instance isgraph_leftmodule {R : Ring} : IsGraph (LeftModule R) := Build_IsGraph _ LeftModuleHomomorphism. Global Instance is01cat_leftmodule {R : Ring} : Is01Cat (LeftModule R) := Build_Is01Cat _ _ lm_homo_id (@lm_homo_compose R). Global Instance is2graph_leftmodule {R : Ring} : Is2Graph (LeftModule R) := fun M N => isgraph_induced (@lm_homo_map R M N). Global Instance is1cat_leftmodule {R : Ring} : Is1Cat (LeftModule R). Proof. snrapply Build_Is1Cat'. - intros M N; rapply is01cat_induced. - intros M N; rapply is0gpd_induced. - intros M N L h. snrapply Build_Is0Functor. intros f g p m. exact (ap h (p m)). - intros M N L f. snrapply Build_Is0Functor. intros g h p m. exact (p (f m)). - simpl; reflexivity. - simpl; reflexivity. - simpl; reflexivity. Defined. Global Instance hasequivs_leftmodule {R : Ring} : HasEquivs (LeftModule R). Proof. snrapply Build_HasEquivs. - exact LeftModuleIsomorphism. - intros M N; exact IsEquiv. - intros M N f; exact f. - simpl; exact _. - apply Build_LeftModuleIsomorphism. - reflexivity. - intros M N; apply lm_iso_inverse. - intros M N f; apply eissect. - intros M N f; apply eisretr. - intros M N f g fg gf. exact (isequiv_adjointify f g fg gf). Defined. (** *** Category of right R-modules *) Global Instance isgraph_rightmodule {R : Ring} : IsGraph (RightModule R) := isgraph_leftmodule (R:=rng_op R). Global Instance is01cat_rightmodule {R : Ring} : Is01Cat (RightModule R) := is01cat_leftmodule (R:=rng_op R). Global Instance is2graph_rightmodule {R : Ring} : Is2Graph (RightModule R) := is2graph_leftmodule (R:=rng_op R). Global Instance is1cat_rightmodule {R : Ring} : Is1Cat (RightModule R) := is1cat_leftmodule (R:=rng_op R). Global Instance hasequivs_rightmodule {R : Ring} : HasEquivs (RightModule R) := hasequivs_leftmodule (R:=rng_op R). (** ** Kernel of module homomorphism *) Global Instance isleftsubmodule_grp_kernel {R : Ring} {M N : LeftModule R} (f : M $-> N) : IsLeftSubmodule (grp_kernel f). Proof. srapply Build_IsLeftSubmodule. intros r m n. lhs nrapply lm_homo_lact. rhs_V nrapply (lm_zero_r r). apply ap. exact n. Defined. Global Instance isrightsubmodule_grp_kernel {R : Ring} {M N : RightModule R} (f : M $-> N) : IsRightSubmodule (grp_kernel f) := isleftsubmodule_grp_kernel (R:=rng_op R) f. Definition lm_kernel {R : Ring} {M N : LeftModule R} (f : M $-> N) : LeftSubmodule M := Build_LeftSubmodule _ _ (grp_kernel f) _. Definition rm_kernel {R : Ring} {M N : RightModule R} (f : M $-> N) : RightSubmodule M := lm_kernel (R:=rng_op R) f. (** ** Image of module homomorphism *) Global Instance isleftsubmodule_grp_image {R : Ring} {M N : LeftModule R} (f : M $-> N) : IsLeftSubmodule (grp_image f). Proof. srapply Build_IsLeftSubmodule. intros r m; apply Trunc_functor; intros [n p]. exists (r *L n). lhs nrapply lm_homo_lact. apply ap. exact p. Defined. Global Instance isrightsubmodule_grp_image {R : Ring} {M N : RightModule R} (f : M $-> N) : IsRightSubmodule (grp_image f) := isleftsubmodule_grp_image (R:=rng_op R) f. Definition lm_image {R : Ring} {M N : LeftModule R} (f : M $-> N) : LeftSubmodule N := Build_LeftSubmodule _ _ (grp_image f) _. Definition rm_image {R : Ring} {M N : RightModule R} (f : M $-> N) : RightSubmodule N := lm_image (R:=rng_op R) f. (** ** Quotient Modules *) (** The quotient abelian group of a module and a submodule has a natural ring action. *) Global Instance isleftmodule_quotientabgroup {R : Ring} (M : LeftModule R) (N : LeftSubmodule M) : IsLeftModule R (QuotientAbGroup M N). Proof. snrapply Build_IsLeftModule. - intros r. snrapply quotient_abgroup_rec. + refine (grp_quotient_map $o _). snrapply Build_GroupHomomorphism. * exact (lact r). * intros x y. apply lm_dist_l. + intros n Nn; simpl. apply qglue. apply issubgroup_in_inv_op. 2: apply issubgroup_in_unit. by apply is_left_submodule. - intros r m n; revert m. snrapply Quotient_ind_hprop; [exact _ | intros m; revert n]. snrapply Quotient_ind_hprop; [exact _ | intros n; simpl]. rapply ap. apply lm_dist_l. - intros r s. snrapply Quotient_ind_hprop; [exact _| intros m; simpl]. rapply ap. apply lm_dist_r. - intros r s. snrapply Quotient_ind_hprop; [exact _| intros m; simpl]. rapply ap. apply lm_assoc. - snrapply Quotient_ind_hprop; [exact _| intros m; simpl]. rapply ap. apply lm_unit. Defined. Global Instance isrightmodule_quotientabgroup {R : Ring} (M : RightModule R) (N : RightSubmodule M) : IsRightModule R (QuotientAbGroup M N) := isleftmodule_quotientabgroup (R:=rng_op R) M N. (** We can therefore form the quotient module of a module by its submodule. *) Definition QuotientLeftModule {R : Ring} (M : LeftModule R) (N : LeftSubmodule M) : LeftModule R := Build_LeftModule R (QuotientAbGroup M N) _. Definition QuotientRightModule {R : Ring} (M : RightModule R) (N : RightSubmodule M) : RightModule R := QuotientLeftModule (R:=rng_op R) M N. Infix "/" := QuotientLeftModule : module_scope. (** TODO: Notation for right module quotient? *) (** ** First Isomorphism Theorem *) Local Open Scope module_scope. Local Open Scope wc_iso_scope. Definition lm_first_iso `{Funext} {R : Ring} {M N : LeftModule R} (f : M $-> N) : M / lm_kernel f ≅ lm_image f. Proof. snrapply Build_LeftModuleIsomorphism'. 1: rapply abgroup_first_iso. intros r. srapply Quotient_ind_hprop; intros m. apply path_sigma_hprop; simpl. apply lm_homo_lact. Defined. Definition rm_first_iso `{Funext} {R : Ring} {M N : RightModule R} (f : M $-> N) : QuotientRightModule M (rm_kernel f) ≅ rm_image f := lm_first_iso (R:=rng_op R) f. (** ** Direct products *) (** TODO: generalise to biproducts *) (** The direct product of modules *) Definition lm_prod {R : Ring} : LeftModule R -> LeftModule R -> LeftModule R. Proof. intros M N. snrapply (Build_LeftModule R (ab_biprod M N)). snrapply Build_IsLeftModule. - intros r. apply functor_prod; exact (lact r). - intros r m n. apply path_prod; apply lm_dist_l. - intros r m n. apply path_prod; apply lm_dist_r. - intros r s m. apply path_prod; apply lm_assoc. - intros r. apply path_prod; apply lm_unit. Defined. Definition rm_prod {R : Ring} : RightModule R -> RightModule R -> RightModule R := lm_prod (R:=rng_op R). Definition lm_prod_fst {R : Ring} {M N : LeftModule R} : lm_prod M N $-> M. Proof. snrapply Build_LeftModuleHomomorphism. - apply grp_prod_pr1. - reflexivity. Defined. Definition rm_prod_fst {R : Ring} {M N : RightModule R} : rm_prod M N $-> M := lm_prod_fst (R:=rng_op R). Definition lm_prod_snd {R : Ring} {M N : LeftModule R} : lm_prod M N $-> N. Proof. snrapply Build_LeftModuleHomomorphism. - apply grp_prod_pr2. - reflexivity. Defined. Definition rm_prod_snd {R : Ring} {M N : RightModule R} : rm_prod M N $-> N := lm_prod_snd (R:=rng_op R). Definition lm_prod_corec {R : Ring} {M N : LeftModule R} (L : LeftModule R) (f : L $-> M) (g : L $-> N) : L $-> lm_prod M N. Proof. snrapply Build_LeftModuleHomomorphism. - apply (grp_prod_corec f g). - intros r l. apply path_prod; apply lm_homo_lact. Defined. Definition rm_prod_corec {R : Ring} {M N : RightModule R} (R' : RightModule R) (f : R' $-> M) (g : R' $-> N) : R' $-> rm_prod M N := lm_prod_corec (R:=rng_op R) R' f g. Global Instance hasbinaryproducts_leftmodule {R : Ring} : HasBinaryProducts (LeftModule R). Proof. intros M N. snrapply Build_BinaryProduct. - exact (lm_prod M N). - exact lm_prod_fst. - exact lm_prod_snd. - exact lm_prod_corec. - cbn; reflexivity. - cbn; reflexivity. - intros L f g p q a. exact (path_prod' (p a) (q a)). Defined. Global Instance hasbinaryproducts_rightmodule {R : Ring} : HasBinaryProducts (RightModule R) := hasbinaryproducts_leftmodule (R:=rng_op R). (** ** Finite Sums *) (** Left scalar multplication distributes over finite sums of left module elements. *) Definition lm_sum_dist_l {R : Ring} (M : LeftModule R) (n : nat) (f : forall k, (k < n)%nat -> M) (r : R) : r *L ab_sum n f = ab_sum n (fun k Hk => r *L f k Hk). Proof. induction n as [|n IHn]. 1: apply lm_zero_r. lhs nrapply lm_dist_l; simpl; f_ap. Defined. (** Right scalar multiplication distributes over finite sums of right module elements. *) Definition rm_sum_dist_r {R : Ring} (M : RightModule R) (n : nat) (f : forall k, (k < n)%nat -> M) (r : R) : ab_sum n f *R r = ab_sum n (fun k Hk => f k Hk *R r) := lm_sum_dist_l (R:=rng_op R) M n f r. (** Left module elements distribute over finite sums of scalars. *) Definition lm_sum_dist_r {R : Ring} (M : LeftModule R) (n : nat) (f : forall k, (k < n)%nat -> R) (x : M) : ab_sum n f *L x = ab_sum n (fun k Hk => f k Hk *L x). Proof. induction n as [|n IHn]. 1: apply lm_zero_l. lhs nrapply lm_dist_r; simpl; f_ap. Defined. (** Right module elements distribute over finite sums of scalar. *) Definition rm_sum_dist_l {R : Ring} (M : RightModule R) (n : nat) (f : forall k, (k < n)%nat -> R) (x : M) : x *R ab_sum n f = ab_sum n (fun k Hk => x *R f k Hk) := lm_sum_dist_r (R:=rng_op R) M n f x. Coq-HoTT-9.0/theories/Algebra/Rings/QuotientRing.v000066400000000000000000000131451474641544500220220ustar00rootroot00000000000000Require Import WildCat.Core WildCat.Equiv. Require Import Algebra.Congruence. Require Import Algebra.AbGroups. Require Import Classes.interfaces.abstract_algebra. Require Import Algebra.Rings.Ring. Require Import Algebra.Rings.Ideal. (** * Quotient Rings *) (** In this file we define the quotient of a ring by an ideal. *) Import Ideal.Notation. Local Open Scope ring_scope. Local Open Scope wc_iso_scope. Section QuotientRing. Context (R : Ring) (I : Ideal R). Instance plus_quotient_group : Plus (QuotientAbGroup R I) := group_sgop. Instance iscong_mult_incosetL : @IsCongruence R ring_mult (in_cosetL I). Proof. snrapply Build_IsCongruence. intros x x' y y' p q. change (I ( - (x * y) + (x' * y'))). rewrite <- (rng_plus_zero_l (x' * y')). rewrite <- (rng_plus_negate_r (x' * y)). rewrite 2 rng_plus_assoc. rewrite <- rng_mult_negate_l. rewrite <- rng_dist_r. rewrite <- rng_plus_assoc. rewrite <- rng_mult_negate_r. rewrite <- rng_dist_l. rapply subgroup_in_op. - by rapply isrightideal. - by rapply isleftideal. Defined. Instance mult_quotient_group : Mult (QuotientAbGroup R I). Proof. srapply Quotient_rec2. - exact (fun x y => class_of _ (x * y)). - intros x x' y p. apply qglue. by apply iscong. - intros x y y' q. apply qglue. by apply iscong. Defined. Instance one_quotient_abgroup : One (QuotientAbGroup R I) := class_of _ one. Instance isring_quotient_abgroup : IsRing (QuotientAbGroup R I). Proof. split. 1: exact _. 1: repeat split. 1: exact _. (** Associativity follows from the underlying operation *) { srapply Quotient_ind3_hprop; intros x y z. unfold mult, sg_op; simpl. apply ap. apply associativity. } (* Left and right identity follow from the underlying structure *) 1,2: snrapply Quotient_ind_hprop; [exact _ | intro x]. 1,2: unfold mult, sg_op; simpl. 1-2: apply ap. 1: apply left_identity. 1: apply right_identity. (** Finally distributivity also follows *) { srapply Quotient_ind3_hprop; intros x y z. unfold sg_op, mult_is_sg_op, mult_quotient_group, plus, mult, plus_quotient_group; simpl. nrapply ap. apply simple_distribute_l. } { srapply Quotient_ind3_hprop; intros x y z. unfold sg_op, mult_is_sg_op, mult_quotient_group, plus, mult, plus_quotient_group; simpl. nrapply ap. apply simple_distribute_r. } Defined. Definition QuotientRing : Ring := Build_Ring (QuotientAbGroup R I) _ _ _ _ _ _ _. End QuotientRing. Infix "/" := QuotientRing : ring_scope. (** Quotient map *) Definition rng_quotient_map {R : Ring} (I : Ideal R) : RingHomomorphism R (R / I). Proof. snrapply Build_RingHomomorphism'. 1: rapply grp_quotient_map. repeat split. Defined. Global Instance issurj_rng_quotient_map {R : Ring} (I : Ideal R) : IsSurjection (rng_quotient_map I). Proof. exact _. Defined. (** *** Specialized induction principles *) (** We provide some specialized induction principes for [QuotientRing] that require cleaner hypotheses than the ones given by [Quotient_ind]. *) Definition QuotientRing_ind {R : Ring} {I : Ideal R} (P : R / I -> Type) `{forall x, IsHSet (P x)} (c : forall (x : R), P (rng_quotient_map I x)) (g : forall (x y : R) (h : I (- x + y)), qglue h # c x = c y) : forall (r : R / I), P r := Quotient_ind _ P c g. (** And a version eliminating into hprops. This one is especially useful. *) Definition QuotientRing_ind_hprop {R : Ring} {I : Ideal R} (P : R / I -> Type) `{forall x, IsHProp (P x)} (c : forall (x : R), P (rng_quotient_map I x)) : forall (r : R / I), P r := Quotient_ind_hprop _ P c. Definition QuotientRing_ind2_hprop {R : Ring} {I : Ideal R} (P : R / I -> R / I -> Type) `{forall x y, IsHProp (P x y)} (c : forall (x y : R), P (rng_quotient_map I x) (rng_quotient_map I y)) : forall (r s : R / I), P r s := Quotient_ind2_hprop _ P c. Definition QuotientRing_rec {R : Ring} {I : Ideal R} (S : Ring) (f : R $-> S) (H : forall x, I x -> f x = 0) : R / I $-> S. Proof. snrapply Build_RingHomomorphism'. - snrapply (grp_quotient_rec _ _ f). exact H. - split. + srapply QuotientRing_ind2_hprop. nrapply rng_homo_mult. + nrapply rng_homo_one. Defined. (** ** Quotient theory *) (** First isomorphism theorem for commutative rings *) Definition rng_first_iso `{Funext} {A B : Ring} (f : A $-> B) : A / ideal_kernel f ≅ rng_image f. Proof. snrapply Build_RingIsomorphism''. 1: rapply abgroup_first_iso. split. { srapply QuotientRing_ind2_hprop; intros x y. srapply path_sigma_hprop. exact (rng_homo_mult _ _ _). } srapply path_sigma_hprop. exact (rng_homo_one _). Defined. (** Invariance of equal ideals *) Lemma rng_quotient_invar {R : Ring} {I J : Ideal R} (p : (I ↔ J)%ideal) : R / I ≅ R / J. Proof. snrapply Build_RingIsomorphism'. { srapply equiv_quotient_functor'. 1: exact equiv_idmap. intros x y; cbn. apply p. } repeat split. 1,2: srapply Quotient_ind2_hprop; intros x y; rapply qglue. 1: change (J ( - (x + y) + (x + y))). 2: change (J (- ( x * y) + (x * y))). 1,2: rewrite rng_plus_negate_l. 1,2: apply ideal_in_zero. Defined. (** We phrase the first ring isomorphism theroem in a slightly differnt way so that it is easier to use. This form specifically asks for a surjective map *) Definition rng_first_iso' `{Funext} {A B : Ring} (f : A $-> B) (issurj_f : IsSurjection f) (I : Ideal A) (p : (I ↔ ideal_kernel f)%ideal) : A / I ≅ B. Proof. etransitivity. 1: apply (rng_quotient_invar p). etransitivity. 2: rapply (rng_image_issurj f). apply rng_first_iso. Defined. Coq-HoTT-9.0/theories/Algebra/Rings/Ring.v000066400000000000000000000734651474641544500203040ustar00rootroot00000000000000Require Import WildCat. Require Import Spaces.Nat.Core Spaces.Nat.Arithmetic. (* Some of the material in abstract_algebra and canonical names could be selectively exported to the user, as is done in Groups/Group.v. *) Require Import Classes.interfaces.abstract_algebra. Require Import Algebra.Groups.Group Algebra.Groups.Subgroup. Require Export Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Biproduct Algebra.AbGroups.FiniteSum. Require Export Classes.theory.rings. Require Import Modalities.ReflectiveSubuniverse. (** We make sure to treat [AbGroup] as if it has a [Plus], [Zero], and [Negate] operation from now on. *) Export AbelianGroup.AdditiveInstances. (** * Rings *) Declare Scope ring_scope. Local Open Scope ring_scope. (** We want to print equivalences as [≅]. *) Local Open Scope wc_iso_scope. (** A ring consists of the following data: *) Record Ring := Build_Ring' { (** An underlying abelian group. *) ring_abgroup :> AbGroup; (** A multiplication operation. *) ring_mult :: Mult ring_abgroup; (** A multiplicative identity called [one]. *) ring_one :: One ring_abgroup; (** Such that all they all satisfy the axioms of a ring. *) ring_isring :: IsRing ring_abgroup; (** This field only exists so that opposite rings are definitionally involutive and can safely be ignored. *) ring_mult_assoc_opp : forall z y x, (x * y) * z = x * (y * z); }. Arguments ring_mult {R} : rename. Arguments ring_one {R} : rename. Arguments ring_isring {R} : rename. Definition issig_Ring : _ <~> Ring := ltac:(issig). Global Instance ring_plus {R : Ring} : Plus R := plus_abgroup (ring_abgroup R). Global Instance ring_zero {R : Ring} : Zero R := zero_abgroup (ring_abgroup R). Global Instance ring_negate {R : Ring} : Negate R := negate_abgroup (ring_abgroup R). (** A ring homomorphism between rings is a map of the underlying type and a proof that this map is a ring homomorphism. *) Record RingHomomorphism (A B : Ring) := { rng_homo_map :> A -> B; rng_homo_ishomo :: IsSemiRingPreserving rng_homo_map; }. Arguments Build_RingHomomorphism {_ _} _ _. Definition issig_RingHomomorphism (A B : Ring) : _ <~> RingHomomorphism A B := ltac:(issig). Definition equiv_path_ringhomomorphism `{Funext} {A B : Ring} {f g : RingHomomorphism A B} : f == g <~> f = g. Proof. refine ((equiv_ap (issig_RingHomomorphism A B)^-1 _ _)^-1 oE _). refine (equiv_path_sigma_hprop _ _ oE _). apply equiv_path_forall. Defined. Definition rng_homo_id (A : Ring) : RingHomomorphism A A := Build_RingHomomorphism idmap (Build_IsSemiRingPreserving _ _ _). Definition rng_homo_compose {A B C : Ring} (f : RingHomomorphism B C) (g : RingHomomorphism A B) : RingHomomorphism A C. Proof. snrapply Build_RingHomomorphism. 1: exact (f o g). rapply compose_sr_morphism. Defined. (** ** Ring laws *) Section RingLaws. (** Many of these ring laws have already been proven. But we give them names here so that they are easy to find and use. *) Context {A : Ring} (x y z : A). Definition rng_dist_l : x * (y + z) = x * y + x * z := simple_distribute_l _ _ _. Definition rng_dist_r : (x + y) * z = x * z + y * z := simple_distribute_r _ _ _. Definition rng_plus_zero_l : 0 + x = x := left_identity _. Definition rng_plus_zero_r : x + 0 = x := right_identity _. Definition rng_plus_negate_l : (- x) + x = 0 := left_inverse _. Definition rng_plus_negate_r : x + (- x) = 0 := right_inverse _. Definition rng_plus_comm : x + y = y + x := commutativity x y. Definition rng_plus_assoc : x + (y + z) = (x + y) + z := simple_associativity x y z. Definition rng_mult_assoc : x * (y * z) = (x * y) * z := simple_associativity x y z. Definition rng_negate_negate : - (- x) = x := groups.inverse_involutive _. Definition rng_negate_zero : - (0 : A) = 0 := groups.inverse_mon_unit. Definition rng_negate_plus : - (x + y) = - x - y := negate_plus_distr _ _. Definition rng_mult_one_l : 1 * x = x := left_identity _. Definition rng_mult_one_r : x * 1 = x := right_identity _. Definition rng_mult_zero_l : 0 * x = 0 := left_absorb _. Definition rng_mult_zero_r : x * 0 = 0 := right_absorb _. Definition rng_mult_negate : -1 * x = - x := (negate_mult_l _)^. Definition rng_mult_negate_negate : -x * -y = x * y := negate_mult_negate _ _. Definition rng_mult_negate_l : -x * y = -(x * y) := inverse (negate_mult_distr_l _ _). Definition rng_mult_negate_r : x * -y = -(x * y) := inverse (negate_mult_distr_r _ _). End RingLaws. Definition rng_dist_l_negate {A : Ring} (x y z : A) : x * (y - z) = x * y - x * z. Proof. lhs nrapply rng_dist_l. nrapply ap. nrapply rng_mult_negate_r. Defined. Definition rng_dist_r_negate {A : Ring} (x y z : A) : (x - y) * z = x * z - y * z. Proof. lhs nrapply rng_dist_r. nrapply ap. nrapply rng_mult_negate_l. Defined. Section RingHomoLaws. Context {A B : Ring} (f : RingHomomorphism A B) (x y : A). Definition rng_homo_plus : f (x + y) = f x + f y := preserves_plus x y. Definition rng_homo_mult : f (x * y) = f x * f y := preserves_mult x y. Definition rng_homo_zero : f 0 = 0 := preserves_0. Definition rng_homo_one : f 1 = 1 := preserves_1. Definition rng_homo_negate : f (-x) = -(f x) := preserves_negate x. Definition rng_homo_minus_one : f (-1) = -1 := preserves_negate _ @ ap negate preserves_1. End RingHomoLaws. (** Isomorphisms of commutative rings *) Record RingIsomorphism (A B : Ring) := { rng_iso_homo : RingHomomorphism A B ; isequiv_rng_iso_homo : IsEquiv rng_iso_homo ; }. Arguments rng_iso_homo {_ _ }. Coercion rng_iso_homo : RingIsomorphism >-> RingHomomorphism. Global Existing Instance isequiv_rng_iso_homo. Definition issig_RingIsomorphism {A B : Ring} : _ <~> RingIsomorphism A B := ltac:(issig). (** We can construct a ring isomorphism from an equivalence that preserves addition and multiplication. *) Definition Build_RingIsomorphism' (A B : Ring) (e : A <~> B) `{!IsSemiRingPreserving e} : RingIsomorphism A B := Build_RingIsomorphism A B (Build_RingHomomorphism e _) _. (** The inverse of a Ring isomorphism *) Definition rng_iso_inverse {A B : Ring} : RingIsomorphism A B -> RingIsomorphism B A. Proof. intros [f e]. snrapply Build_RingIsomorphism. { snrapply Build_RingHomomorphism. 1: exact f^-1. exact _. } exact _. Defined. (** Ring isomorphisms are a reflexive relation *) Global Instance reflexive_ringisomorphism : Reflexive RingIsomorphism := fun x => Build_RingIsomorphism _ _ (rng_homo_id x) _. (** Ring isomorphisms are a symmetric relation *) Global Instance symmetry_ringisomorphism : Symmetric RingIsomorphism := fun x y => rng_iso_inverse. (** Ring isomorphisms are a transitive relation *) Global Instance transitive_ringisomorphism : Transitive RingIsomorphism := fun x y z f g => Build_RingIsomorphism _ _ (rng_homo_compose g f) _. (** Underlying group homomorphism of a ring homomorphism *) Definition grp_homo_rng_homo {R S : Ring} : RingHomomorphism R S -> GroupHomomorphism R S := fun f => @Build_GroupHomomorphism R S f _. Coercion grp_homo_rng_homo : RingHomomorphism >-> GroupHomomorphism. (** We can construct a ring homomorphism from a group homomorphism that preserves multiplication *) Definition Build_RingHomomorphism' (A B : Ring) (map : GroupHomomorphism A B) {H : IsMonoidPreserving (Aop:=ring_mult) (Bop:=ring_mult) (Aunit:=one) (Bunit:=one) map} : RingHomomorphism A B := Build_RingHomomorphism map (Build_IsSemiRingPreserving _ (ismonoidpreserving_grp_homo map) H). (** We can construct a ring isomorphism from a group isomorphism that preserves multiplication *) Definition Build_RingIsomorphism'' (A B : Ring) (e : GroupIsomorphism A B) {H : IsMonoidPreserving (Aop:=ring_mult) (Bop:=ring_mult) (Aunit:=one) (Bunit:=one) e} : RingIsomorphism A B := @Build_RingIsomorphism' A B e (Build_IsSemiRingPreserving e _ H). (** Here is an alternative way to build a ring using the underlying abelian group. *) Definition Build_Ring (R : AbGroup) `(Mult R, One R, !Associative (.*.), !LeftDistribute (.*.) (+), !RightDistribute (.*.) (+), !LeftIdentity (.*.) 1, !RightIdentity (.*.) 1) : Ring. Proof. rapply (Build_Ring' R). 2: exact (fun z y x => (associativity x y z)^). split; only 1,3,4: exact _. repeat split; exact _. Defined. (** Scalar multiplication on the left is a group homomorphism. *) Definition grp_homo_rng_left_mult {R : Ring} (r : R) : GroupHomomorphism R R := @Build_GroupHomomorphism R R (fun s => r * s) (rng_dist_l r). (** Scalar multiplication on the right is a group homomorphism. *) Definition grp_homo_rng_right_mult {R : Ring} (r : R) : GroupHomomorphism R R := @Build_GroupHomomorphism R R (fun s => s * r) (fun x y => rng_dist_r x y r). (** ** Ring movement lemmas *) Section RingMovement. (** We adopt a similar naming convention to the [moveR_equiv] style lemmas that can be found in Types.Paths. *) Context {R : Ring} {x y z : R}. Definition rng_moveL_Mr : - y + x = z <~> x = y + z := @grp_moveL_Mg R x y z. Definition rng_moveL_rM : x + - z = y <~> x = y + z := @grp_moveL_gM R x y z. Definition rng_moveR_Mr : y = - x + z <~> x + y = z := @grp_moveR_Mg R x y z. Definition rng_moveR_rM : x = z + - y <~> x + y = z := @grp_moveR_gM R x y z. Definition rng_moveL_Vr : x + y = z <~> y = - x + z := @grp_moveL_Vg R x y z. Definition rng_moveL_rV : x + y = z <~> x = z + - y := @grp_moveL_gV R x y z. Definition rng_moveR_Vr : x = y + z <~> - y + x = z := @grp_moveR_Vg R x y z. Definition rng_moveR_rV : x = y + z <~> x + - z = y := @grp_moveR_gV R x y z. Definition rng_moveL_M0 : - y + x = 0 <~> x = y := @grp_moveL_M1 R x y. Definition rng_moveL_0M : x + - y = 0 <~> x = y := @grp_moveL_1M R x y. Definition rng_moveR_M0 : 0 = - x + y <~> x = y := @grp_moveR_M1 R x y. Definition rng_moveR_0M : 0 = y + - x <~> x = y := @grp_moveR_1M R x y. (** TODO: Movement laws about mult *) End RingMovement. (** ** Wild category of rings *) Global Instance isgraph_ring : IsGraph Ring := Build_IsGraph _ RingHomomorphism. Global Instance is01cat_ring : Is01Cat Ring := Build_Is01Cat _ _ rng_homo_id (@rng_homo_compose). Global Instance is2graph_ring : Is2Graph Ring := fun A B => isgraph_induced (@rng_homo_map A B : _ -> (group_type _ $-> _)). Global Instance is01cat_ringhomomorphism {A B : Ring} : Is01Cat (A $-> B) := is01cat_induced (@rng_homo_map A B). Global Instance is0gpd_ringhomomorphism {A B : Ring} : Is0Gpd (A $-> B) := is0gpd_induced (@rng_homo_map A B). Global Instance is0functor_postcomp_ringhomomorphism {A B C : Ring} (h : B $-> C) : Is0Functor (@cat_postcomp Ring _ _ A B C h). Proof. apply Build_Is0Functor. intros [f ?] [g ?] p a ; exact (ap h (p a)). Defined. Global Instance is0functor_precomp_ringhomomorphism {A B C : Ring} (h : A $-> B) : Is0Functor (@cat_precomp Ring _ _ A B C h). Proof. apply Build_Is0Functor. intros [f ?] [g ?] p a ; exact (p (h a)). Defined. (** Ring forms a 1-category. *) Global Instance is1cat_ring : Is1Cat Ring. Proof. by rapply Build_Is1Cat. Defined. Global Instance hasmorext_ring `{Funext} : HasMorExt Ring. Proof. srapply Build_HasMorExt. intros A B f g; cbn in *. snrapply @isequiv_homotopic. 1: exact (equiv_path_ringhomomorphism^-1%equiv). 1: exact _. intros []; reflexivity. Defined. Global Instance hasequivs_ring : HasEquivs Ring. Proof. unshelve econstructor. + exact RingIsomorphism. + exact (fun G H f => IsEquiv f). + intros G H f; exact f. + exact Build_RingIsomorphism. + intros G H; exact rng_iso_inverse. + cbn; exact _. + reflexivity. + intros ????; apply eissect. + intros ????; apply eisretr. + intros G H f g p q. exact (isequiv_adjointify f g p q). Defined. (** ** Subrings *) (** TODO: factor out this definition as a submonoid *) (** A subring is a subgorup of the underlying abelian group of a ring that is closed under multiplication and contains [1]. *) Class IsSubring {R : Ring} (S : R -> Type) := { issubring_issubgroup :: IsSubgroup S; issubring_mult {x y} : S x -> S y -> S (x * y); issubring_one : S 1; }. Definition issig_IsSubring {R : Ring} (S : R -> Type) : _ <~> IsSubring S := ltac:(issig). Global Instance ishprop_issubring `{Funext} {R : Ring} (S : R -> Type) : IsHProp (IsSubring S). Proof. exact (istrunc_equiv_istrunc _ (issig_IsSubring S)). Defined. (** Subring criterion. *) Definition Build_IsSubring' {R : Ring} (S : R -> Type) (H : forall x, IsHProp (S x)) (H1 : forall x y, S x -> S y -> S (x - y)) (H2 : forall x y, S x -> S y -> S (x * y)) (H3 : S 1) : IsSubring S. Proof. snrapply Build_IsSubring. - snrapply Build_IsSubgroup'. + exact _. + pose (p := H1 1 1 H3 H3). rewrite rng_plus_negate_r in p. exact p. + exact H1. - exact H2. - exact H3. Defined. Record Subring (R : Ring) := { #[reversible=no] subring_pred :> R -> Type; subring_issubring :: IsSubring subring_pred; }. Definition Build_Subring'' {R : Ring} (S : Subgroup R) (H1 : forall x y, S x -> S y -> S (x * y)) (H2 : S 1) : Subring R. Proof. snrapply (Build_Subring _ S). snrapply Build_IsSubring. - exact _. - exact H1. - exact H2. Defined. Definition Build_Subring' {R : Ring} (S : R -> Type) (H : forall x, IsHProp (S x)) (H1 : forall x y, S x -> S y -> S (x - y)) (H2 : forall x y, S x -> S y -> S (x * y)) (H3 : S 1) : Subring R := Build_Subring R S (Build_IsSubring' S H H1 H2 H3). (** The underlying subgroup of a subring. *) Coercion subgroup_subring {R} : Subring R -> Subgroup R := fun S => Build_Subgroup R S _. (** The ring given by a subring. *) Coercion ring_subring {R : Ring} (S : Subring R) : Ring. Proof. snrapply (Build_Ring (subgroup_subring S)). 3-7: hnf; intros; srapply path_sigma_hprop. - intros [r ?] [s ?]; exists (r * s). by apply issubring_mult. - exists 1. apply issubring_one. - snrapply rng_mult_assoc. - snrapply rng_dist_l. - snrapply rng_dist_r. - snrapply rng_mult_one_l. - snrapply rng_mult_one_r. Defined. (** ** Product ring *) Definition ring_product : Ring -> Ring -> Ring. Proof. intros R S. snrapply Build_Ring. - exact (ab_biprod R S). - exact (fun '(r1 , s1) '(r2 , s2) => (r1 * r2 , s1 * s2)). - exact (ring_one , ring_one). - intros [r1 s1] [r2 s2] [r3 s3]. apply path_prod; cbn; apply rng_mult_assoc. - intros [r1 s1] [r2 s2] [r3 s3]. apply path_prod; cbn; apply rng_dist_l. - intros [r1 s1] [r2 s2] [r3 s3]. apply path_prod; cbn; apply rng_dist_r. - intros [r1 s1]; apply path_prod; cbn; apply rng_mult_one_l. - intros [r1 s1]; apply path_prod; cbn; apply rng_mult_one_r. Defined. Infix "×" := ring_product : ring_scope. Definition ring_product_fst {R S : Ring} : R × S $-> R. Proof. snrapply Build_RingHomomorphism. 1: exact fst. repeat split. Defined. Definition ring_product_snd {R S : Ring} : R × S $-> S. Proof. snrapply Build_RingHomomorphism. 1: exact snd. repeat split. Defined. Definition ring_product_corec (R S T : Ring) : (R $-> S) -> (R $-> T) -> (R $-> S × T). Proof. intros f g. srapply Build_RingHomomorphism'. 1: apply (ab_biprod_corec f g). repeat split. 1: cbn; intros x y; apply path_prod; apply rng_homo_mult. cbn; apply path_prod; apply rng_homo_one. Defined. Definition equiv_ring_product_corec `{Funext} (R S T : Ring) : (R $-> S) * (R $-> T) <~> (R $-> S × T). Proof. snrapply equiv_adjointify. 1: exact (uncurry (ring_product_corec _ _ _)). { intros f. exact (ring_product_fst $o f, ring_product_snd $o f). } { hnf; intros f. by apply path_hom. } intros [f g]. apply path_prod. 1,2: by apply path_hom. Defined. Global Instance hasbinaryproducts_ring : HasBinaryProducts Ring. Proof. intros R S. snrapply Build_BinaryProduct. - exact (R × S). - exact ring_product_fst. - exact ring_product_snd. - exact (fun T => ring_product_corec T R S). - cbn; reflexivity. - cbn; reflexivity. - intros T f g p q x. exact (path_prod' (p x) (q x)). Defined. (** ** Image ring *) (** The image of a ring homomorphism *) Definition rng_image {R S : Ring} (f : R $-> S) : Subring S. Proof. snrapply (Build_Subring'' (grp_image f)). - simpl. intros x y p q. strip_truncations; apply tr. destruct p as [a p'], q as [b q']. exists (a * b). refine (rng_homo_mult _ _ _ @ _). f_ap. - apply tr. exists 1. exact (rng_homo_one f). Defined. Lemma rng_homo_image_incl {R S} (f : RingHomomorphism R S) : (rng_image f : Ring) $-> S. Proof. snrapply Build_RingHomomorphism. 1: exact pr1. repeat split. Defined. (** Image of a surjective ring homomorphism *) Lemma rng_image_issurj {R S} (f : RingHomomorphism R S) {issurj : IsSurjection f} : (rng_image f : Ring) ≅ S. Proof. snrapply Build_RingIsomorphism. 1: exact (rng_homo_image_incl f). exact _. Defined. (** ** Opposite Ring *) (** Given a ring [R] we can reverse the order of the multiplication to get another ring [R^op]. *) Definition rng_op : Ring -> Ring. Proof. (** Let's carefully pull apart the ring structure and put it back together. Unfortunately, our definition of ring has some redundant data such as multiple hset assumptions, due to the mixing of algebraic strucutres. This isn't a problem in practice, but it does mean using typeclass inference here will pick up the wrong instance, therefore we carefully put it back together. See test/Algebra/Rings/Ring.v for a test checking this operation is definitionally involutive. *) intros [R mult one [is_abgroup [[monoid_ishset mult_assoc] li ri] ld rd] mult_assoc_opp]. snrapply Build_Ring'. 4: split. 5: split. 5: split. - exact R. - exact (fun x y => mult y x). - exact one. - exact is_abgroup. - exact monoid_ishset. - exact mult_assoc_opp. - exact ri. - exact li. - exact (fun x y z => rd y z x). - exact (fun x y z => ld z x y). - exact mult_assoc. Defined. (** The opposite ring is a functor. *) Global Instance is0functor_rng_op : Is0Functor rng_op. Proof. snrapply Build_Is0Functor. intros R S f. snrapply Build_RingHomomorphism'. - exact f. - split. + exact (fun x y => rng_homo_mult f y x). + exact (rng_homo_one f). Defined. Global Instance is1functor_rng_op : Is1Functor rng_op. Proof. snrapply Build_Is1Functor. - intros R S f g p. exact p. - intros R; cbn; reflexivity. - intros R S T f g; cbn; reflexivity. Defined. (** ** Powers *) (** Powers of ring elements *) Definition rng_power {R : Ring} (x : R) (n : nat) : R := nat_iter n (x *.) ring_one. (** Power laws *) Lemma rng_power_mult_law {R : Ring} (x : R) (n m : nat) : (rng_power x n) * (rng_power x m) = rng_power x (n + m). Proof. induction n as [|n IHn]. 1: apply rng_mult_one_l. refine ((rng_mult_assoc _ _ _)^ @ _). exact (ap (x *.) IHn). Defined. (** ** Finite Sums *) (** Ring multiplication distributes over finite sums on the left. *) Definition rng_sum_dist_l {R : Ring} (n : nat) (f : forall k, (k < n)%nat -> R) (r : R) : r * ab_sum n f = ab_sum n (fun k Hk => r * f k Hk). Proof. induction n as [|n IHn]. 1: apply rng_mult_zero_r. lhs nrapply rng_dist_l; simpl; f_ap. Defined. (** Ring multiplication distributes over finite sums on the right. *) Definition rng_sum_dist_r {R : Ring} (n : nat) (f : forall k, (k < n)%nat -> R) (r : R) : ab_sum n f * r = ab_sum n (fun k Hk => f k Hk * r). Proof. induction n as [|n IHn]. 1: apply rng_mult_zero_l. lhs nrapply rng_dist_r; simpl; f_ap. Defined. (** ** Invertible elements *) (** An element [x] of a ring [R] is left invertible if there exists an element [y] such that [y * x = 1]. *) Class IsLeftInvertible (R : Ring) (x : R) := { left_inverse_elem : R; left_inverse_eq : left_inverse_elem * x = 1; }. Arguments left_inverse_elem {R} x {_}. Arguments left_inverse_eq {R} x {_}. Definition issig_IsLeftInvertible {R : Ring} (x : R) : _ <~> IsLeftInvertible R x := ltac:(issig). (** An element [x] of a ring [R] is right invertible if there exists an element [y] such that [x * y = 1]. We state this as a left invertible element of the opposite ring. *) Class IsRightInvertible (R : Ring) (x : R) := isleftinvertible_rng_op :: IsLeftInvertible (rng_op R) x. Definition right_inverse_elem {R} x `{!IsRightInvertible R x} : R := left_inverse_elem (R:=rng_op R) x. Definition right_inverse_eq {R} x `{!IsRightInvertible R x} : x * right_inverse_elem x = 1 := left_inverse_eq (R:=rng_op R) x. (** An element [x] of a ring [R] is invertible if it is both left and right invertible. *) Class IsInvertible (R : Ring) (x : R) := Build_IsInvertible' { isleftinvertible_isinvertible :: IsLeftInvertible R x; isrightinvertible_isinvertible :: IsRightInvertible R x; }. (** We can show an element is invertible by providing an inverse element which is a left and right inverse similtaneously. We will later show that the two inverses of an invertible element must be equal anyway. *) Definition Build_IsInvertible {R : Ring} (x : R) (inv : R) (inv_l : inv * x = 1) (inv_r : x * inv = 1) : IsInvertible R x. Proof. split. - by exists inv. - unfold IsRightInvertible. by exists (inv : rng_op R). Defined. (** The invertible elements in [R] and [rng_op R] agree, by swapping the proofs of left and right invertibility. *) Definition isinvertible_rng_op (R : Ring) (x : R) `{!IsInvertible R x} : IsInvertible (rng_op R) x. Proof. split. - exact (isrightinvertible_isinvertible). - exact (isleftinvertible_isinvertible). Defined. (** *** Uniqueness of inverses *) (** This general lemma will be used for uniqueness results. *) Definition path_left_right_inverse {R : Ring} (x x' x'' : R) (p : x' * x = 1) (q : x * x'' = 1) : x' = x''. Proof. rhs_V nrapply rng_mult_one_l. rewrite <- p. rewrite <- simple_associativity. rewrite q. symmetry. apply rng_mult_one_r. Defined. (** The left and right inverse of an invertible element are necessarily equal. *) Definition path_left_inverse_elem_right_inverse_elem {R : Ring} x `{!IsInvertible R x} : left_inverse_elem x = right_inverse_elem x. Proof. nrapply (path_left_right_inverse x). - apply left_inverse_eq. - apply right_inverse_eq. Defined. (** It is therefore well-defined to talk about the inverse of an invertible element. *) Definition inverse_elem {R : Ring} (x : R) `{IsInvertible R x} : R := left_inverse_elem x. (** Left cancellation for an invertible element. *) Definition rng_inv_l {R : Ring} (x : R) `{IsInvertible R x} : inverse_elem x * x = 1. Proof. apply left_inverse_eq. Defined. (** Right cancellation for an invertible element. *) Definition rng_inv_r {R : Ring} (x : R) `{IsInvertible R x} : x * inverse_elem x = 1. Proof. rhs_V nrapply (right_inverse_eq x). f_ap. apply path_left_inverse_elem_right_inverse_elem. Defined. (** Equal elements have equal inverses. Note that we don't require that the proofs of invertibility are equal (over [p]). It follows that the inverse of an invertible element [x] depends only on [x]. *) Definition isinvertible_unique {R : Ring} (x y : R) `{IsInvertible R x} `{IsInvertible R y} (p : x = y) : inverse_elem x = inverse_elem y. Proof. destruct p. snrapply (path_left_right_inverse x). - apply rng_inv_l. - apply rng_inv_r. Defined. (** We can show that being invertible is equivalent to having an inverse element that is simultaneously a left and right inverse. *) Definition equiv_isinvertible_left_right_inverse {R : Ring} (x : R) : {inv : R & prod (inv * x = 1) (x * inv = 1)} <~> IsInvertible R x. Proof. equiv_via { i : IsInvertible R x & right_inverse_elem x = left_inverse_elem x }. 1: make_equiv_contr_basedpaths. apply equiv_sigma_contr; intro i. rapply contr_inhabited_hprop. symmetry; apply path_left_inverse_elem_right_inverse_elem. Defined. (** Being invertible is a proposition. *) Global Instance ishprop_isinvertible {R x} : IsHProp (IsInvertible R x). Proof. nrapply (istrunc_equiv_istrunc _ (equiv_isinvertible_left_right_inverse x)). snrapply hprop_allpath; intros [y [p1 p2]] [z [q1 q2]]. rapply path_sigma_hprop; cbn. exact (path_left_right_inverse x y z p1 q2). Defined. (** *** Closure of invertible elements under multiplication *) (** Left invertible elements are closed under multiplication. *) Global Instance isleftinvertible_mult {R : Ring} (x y : R) : IsLeftInvertible R x -> IsLeftInvertible R y -> IsLeftInvertible R (x * y). Proof. intros [x' p] [y' q]. exists (y' * x'). rhs_V nrapply q. lhs nrapply rng_mult_assoc. f_ap. rhs_V nrapply rng_mult_one_r. lhs_V nrapply rng_mult_assoc. f_ap. Defined. (** Right invertible elements are closed under multiplication. *) Global Instance isrightinvertible_mult {R : Ring} (x y : R) : IsRightInvertible R x -> IsRightInvertible R y -> IsRightInvertible R (x * y). Proof. change (x * y) with (ring_mult (R:=rng_op R) y x). unfold IsRightInvertible. exact _. Defined. (** Invertible elements are closed under multiplication. *) Global Instance isinvertible_mult {R : Ring} (x y : R) : IsInvertible R x -> IsInvertible R y -> IsInvertible R (x * y) := {}. (** Left invertible elements are closed under negation. *) Global Instance isleftinvertible_neg {R : Ring} (x : R) : IsLeftInvertible R x -> IsLeftInvertible R (-x). Proof. intros H. exists (- left_inverse_elem x). lhs nrapply rng_mult_negate_negate. apply left_inverse_eq. Defined. (** Right invertible elements are closed under negation. *) Global Instance isrightinvertible_neg {R : Ring} (x : R) : IsRightInvertible R x -> IsRightInvertible R (-x). Proof. intros H. rapply isleftinvertible_neg. Defined. (** Invertible elements are closed under negation. *) Global Instance isinvertible_neg {R : Ring} (x : R) : IsInvertible R x -> IsInvertible R (-x) := {}. (** Inverses of left invertible elements are themselves right invertible. *) Global Instance isrightinvertible_left_inverse_elem {R : Ring} (x : R) `{IsLeftInvertible R x} : IsRightInvertible R (left_inverse_elem x). Proof. exists (x : rng_op R). exact (left_inverse_eq x). Defined. (** Inverses of right invertible elements are themselves left invertible. *) Global Instance isleftinvertible_right_inverse_elem {R : Ring} (x : R) `{IsRightInvertible R x} : IsLeftInvertible R (right_inverse_elem x). Proof. exists x. exact (right_inverse_eq x). Defined. (** Inverses of invertible elements are themselves invertible. We take both inverses of [inverse_elem x] to be [x]. *) Global Instance isinvertible_inverse_elem {R : Ring} (x : R) `{IsInvertible R x} : IsInvertible R (inverse_elem x). Proof. split. - exists x; apply rng_inv_r. - apply isrightinvertible_left_inverse_elem. Defined. (** Since [inverse_elem (inverse_elem x) = x], we get the following equivalence. *) Definition equiv_path_inverse_elem {R : Ring} {x y : R} `{IsInvertible R x, IsInvertible R y} : x = y <~> inverse_elem x = inverse_elem y. Proof. srapply equiv_iff_hprop. - exact (isinvertible_unique x y). - exact (isinvertible_unique (inverse_elem x) (inverse_elem y)). Defined. (** [1] is always invertible, and by the above [-1]. *) Global Instance isinvertible_one {R} : IsInvertible R 1. Proof. snrapply Build_IsInvertible. - exact one. - apply rng_mult_one_l. - apply rng_mult_one_l. Defined. (** Ring homomorphisms preserve invertible elements. *) Global Instance isinvertible_rng_homo {R S} (f : R $-> S) : forall x, IsInvertible R x -> IsInvertible S (f x). Proof. intros x H. snrapply Build_IsInvertible. 1: exact (f (inverse_elem x)). 1,2: lhs_V nrapply rng_homo_mult. 1,2: rhs_V nrapply (rng_homo_one f). 1,2: nrapply (ap f). - exact (rng_inv_l x). - exact (rng_inv_r x). Defined. (** *** Group of units *) (** Invertible elements are typically called "units" in ring theory and the collection of units forms a group under the ring multiplication. *) Definition rng_unit_group (R : Ring) : Group. Proof. (** TODO: Use a generalised version of [Build_Subgroup] that works for subgroups of monoids. *) snrapply Build_Group. - exact {x : R & IsInvertible R x}. - intros [x p] [y q]. exists (x * y). exact _. - exists 1. exact _. - intros [x p]. exists (inverse_elem x). exact _. - repeat split. 1: exact _. 1-5: hnf; intros; apply path_sigma_hprop. + rapply simple_associativity. + rapply left_identity. + rapply right_identity. + apply rng_inv_l. + apply rng_inv_r. Defined. (** *** Multiplication by an invertible element is an equivalence *) Global Instance isequiv_rng_inv_mult_l {R : Ring} {x : R} `{IsInvertible R x} : IsEquiv (x *.). Proof. snrapply isequiv_adjointify. 1: exact (inverse_elem x *.). 1,2: intros y. 1,2: lhs nrapply rng_mult_assoc. 1,2: rhs_V nrapply rng_mult_one_l. 1,2: snrapply (ap (.* y)). - nrapply rng_inv_r. - nrapply rng_inv_l. Defined. (** This can be proved by combining [isequiv_rng_inv_mult_l (R:=rng_op R)] with [isinvertible_rng_op], but then the inverse map is given by multiplying by [right_inverse_elem x] not [inverse_elem x], which complicates calculations. *) Global Instance isequiv_rng_inv_mult_r {R : Ring} {x : R} `{IsInvertible R x} : IsEquiv (.* x). Proof. snrapply isequiv_adjointify. 1: exact (.* inverse_elem x). 1,2: intros y. 1,2: lhs_V nrapply rng_mult_assoc. 1,2: rhs_V nrapply rng_mult_one_r. 1,2: snrapply (ap (y *.)). - nrapply rng_inv_l. - nrapply rng_inv_r. Defined. (** *** Invertible element movement lemmas *) (** These cannot be proven using the corresponding group laws in the group of units since not all elements involved are invertible. *) Definition rng_inv_moveL_Vr {R : Ring} {x y z : R} `{IsInvertible R y} : y * x = z <~> x = inverse_elem y * z := equiv_moveL_equiv_V (f := (y *.)) z x. Definition rng_inv_moveL_rV {R : Ring} {x y z : R} `{IsInvertible R y} : x * y = z <~> x = z * inverse_elem y := equiv_moveL_equiv_V (f := (.* y)) z x. Definition rng_inv_moveR_Vr {R : Ring} {x y z : R} `{IsInvertible R y} : x = y * z <~> inverse_elem y * x = z := equiv_moveR_equiv_V (f := (y *.)) x z. Definition rng_inv_moveR_rV {R : Ring} {x y z : R} `{IsInvertible R y} : x = z * y <~> x * inverse_elem y = z := equiv_moveR_equiv_V (f := (.* y)) x z. (** TODO: The group of units construction is a functor from [Ring -> Group] and is right adjoint to the group ring construction. *) Coq-HoTT-9.0/theories/Algebra/Rings/Vector.v000066400000000000000000000137241474641544500206370ustar00rootroot00000000000000Require Import Basics.Overture Basics.Trunc Basics.Tactics Basics.PathGroupoids. Require Import Types.Sigma. Require Import Algebra.AbGroups.AbelianGroup Algebra.Rings.Ring Algebra.Rings.Module. Require Import Spaces.Nat.Core. Require Import Spaces.List.Core Spaces.List.Theory Spaces.List.Paths. Require Import abstract_algebra. Local Open Scope mc_scope. Local Set Universe Minimization ToSet. Local Set Polymorphic Inductive Cumulativity. (** * Vectors *) (** A vector is simply a list with a specified length. This data structure has many uses, but here we will focus on lists of left module elements. *) (** ** Definition *) Definition Vector@{i|} (A : Type@{i}) (n : nat) : Type@{i} := { l : list A & length l = n }. (** *** Constructors *) Definition Build_Vector (A : Type) (n : nat) (f : forall (i : nat), (i < n)%nat -> A) : Vector A n := (Build_list n f; length_Build_list n f). (** *** Projections *) Definition entry {A : Type} {n : nat} (v : Vector A n) i {Hi : (i < n)%nat} : A := nth' (pr1 v) i ((pr2 v)^ # Hi). (** *** Basic properties *) Definition entry_Build_Vector {A : Type} {n} (f : forall (i : nat), (i < n)%nat -> A) i {Hi : (i < n)%nat} : entry (Build_Vector A n f) i = f i Hi. Proof. snrapply nth'_Build_list. Defined. Global Instance istrunc_vector@{i} (A : Type@{i}) (n : nat) k `{IsTrunc k.+2 A} : IsTrunc k.+2 (Vector A n). Proof. rapply istrunc_sigma@{i i i}. Defined. Definition path_vector@{i} (A : Type@{i}) {n : nat} (v1 v2 : Vector@{i} A n) (H : forall i (H : (i < n)%nat), entry v1 i = entry v2 i) : v1 = v2. Proof. rapply path_sigma_hprop@{i i i}. snrapply path_list_nth'. 1: exact (pr2 v1 @ (pr2 v2)^). intros i Hi. snrefine (_ @ H i (pr2 v1 # Hi) @ _). 1, 2: apply nth'_nth'. Defined. Definition path_entry_vector {A : Type} {n : nat} (v : Vector A n) (i j : nat) (Hi : (i < n)%nat) (Hj : (j < n)%nat) (p : i = j) : entry v i = entry v j. Proof. destruct p. apply nth'_nth'. Defined. (** ** Operations *) Definition vector_map {A B : Type} {n} (f : A -> B) : Vector A n -> Vector B n := fun v => Build_Vector B n (fun i _ => f (entry v i)). Definition vector_map2 {A B C : Type} {n} (f : A -> B -> C) : Vector A n -> Vector B n -> Vector C n := fun v1 v2 => Build_Vector C n (fun i _ => f (entry v1 i) (entry v2 i)). (** ** Abelian group structure *) Section VectorAddition. Context (A : AbGroup) (n : nat). Definition vector_plus : Plus (Vector A n) := vector_map2 (+). Definition vector_zero : Zero (Vector A n) := Build_Vector A n (fun _ _ => 0). Definition vector_neg : Negate (Vector A n) := vector_map (-). Definition associative_vector_plus : Associative vector_plus. Proof. intros v1 v2 v3; apply path_vector; intros i Hi. rewrite 4 entry_Build_Vector. apply associativity. Defined. Definition commutative_vector_plus : Commutative vector_plus. Proof. intros v1 v2; apply path_vector; intros i Hi. rewrite 2 entry_Build_Vector. apply commutativity. Defined. Definition left_identity_vector_plus : LeftIdentity vector_plus vector_zero. Proof. intros v; apply path_vector; intros i Hi. rewrite 2 entry_Build_Vector. apply left_identity. Defined. Definition right_identity_vector_plus : RightIdentity vector_plus vector_zero. Proof. intros v; apply path_vector; intros i Hi. rewrite 2 entry_Build_Vector. apply right_identity. Defined. Definition left_inverse_vector_plus : LeftInverse vector_plus vector_neg vector_zero. Proof. intros v; apply path_vector; intros i Hi. rewrite 3 entry_Build_Vector. apply left_inverse. Defined. Definition right_inverse_vector_plus : RightInverse vector_plus vector_neg vector_zero. Proof. intros v; apply path_vector; intros i Hi. rewrite 3 entry_Build_Vector. apply right_inverse. Defined. Definition abgroup_vector : AbGroup. Proof. snrapply Build_AbGroup. 1: snrapply Build_Group. 5: repeat split. - exact (Vector A n). - exact vector_plus. - exact vector_zero. - exact vector_neg. - exact _. - exact associative_vector_plus. - exact left_identity_vector_plus. - exact right_identity_vector_plus. - exact left_inverse_vector_plus. - exact right_inverse_vector_plus. - exact commutative_vector_plus. Defined. End VectorAddition. Arguments vector_plus {A n} v1 v2. (** ** Module structure *) Section VectorScale. (** A vector of elements of an R-module is itself an R-module. A special case is when the R-module is the ring R itself. *) Context (M : AbGroup) (n : nat) {R : Ring} `{IsLeftModule R M}. Definition vector_lact (r : R) : Vector M n -> Vector M n := vector_map (lact r). Definition left_heterodistribute_vector_lact_plus : LeftHeteroDistribute vector_lact vector_plus vector_plus. Proof. intros r v1 v2; apply path_vector; intros i Hi. rewrite 5 entry_Build_Vector. apply distribute_l. Defined. Definition right_heterodistribute_vector_lact_plus : RightHeteroDistribute vector_lact (+) vector_plus. Proof. intros r1 r2 v; apply path_vector; intros i Hi. rewrite 4 entry_Build_Vector. apply distribute_r. Defined. Definition heteroassociative_vector_lact_plus : HeteroAssociative vector_lact vector_lact vector_lact (.*.). Proof. intros r s v; apply path_vector; intros i Hi. rewrite 3 entry_Build_Vector. apply associativity. Defined. Definition left_identity_vector_lact : LeftIdentity vector_lact 1. Proof. intros v; apply path_vector; intros i Hi. rewrite entry_Build_Vector. apply left_identity. Defined. Definition isleftmodule_isleftmodule_vector : IsLeftModule R (abgroup_vector M n). Proof. snrapply Build_IsLeftModule. - exact vector_lact. - exact left_heterodistribute_vector_lact_plus. - exact right_heterodistribute_vector_lact_plus. - exact heteroassociative_vector_lact_plus. - exact left_identity_vector_lact. Defined. End VectorScale. Arguments vector_lact {M n R _} r v. Coq-HoTT-9.0/theories/Algebra/Rings/Z.v000066400000000000000000000054771474641544500176140ustar00rootroot00000000000000Require Import Classes.interfaces.canonical_names. Require Import Algebra.AbGroups. Require Import Algebra.Rings.CRing. Require Import Spaces.Int Spaces.Pos. Require Import WildCat.Core. (** * In this file we define the ring [cring_Z] of integers with underlying abelian group [abgroup_Z] defined in Algebra.AbGroups.Z. We also define multiplication by an integer in a general ring, and show that [cring_Z] is initial. *) (** The ring of integers *) Definition cring_Z : CRing. Proof. snrapply Build_CRing'. - exact abgroup_Z. - exact 1%int. - exact int_mul. - exact int_mul_comm. - exact int_mul_assoc. - exact int_dist_l. - exact int_mul_1_l. Defined. Local Open Scope mc_scope. (** Given a ring element [r], we get a map [Int -> R] sending an integer to that multiple of [r]. *) Definition rng_int_mult (R : Ring) := grp_pow_homo : R -> Int -> R. (** Multiplying a ring element [r] by an integer [n] is equivalent to first multiplying the unit [1] of the ring by [n], and then multiplying the result by [r]. This is distributivity of right multiplication by [r] over the sum. *) Definition rng_int_mult_dist_r {R : Ring} (r : R) (n : cring_Z) : rng_int_mult R r n = (rng_int_mult R 1 n) * r. Proof. cbn. rhs nrapply (grp_pow_natural (grp_homo_rng_right_mult r)); cbn. by rewrite rng_mult_one_l. Defined. (** Similarly, there is a left-distributive law. *) Definition rng_int_mult_dist_l {R : Ring} (r : R) (n : cring_Z) : rng_int_mult R r n = r * (rng_int_mult R 1 n). Proof. cbn. rhs nrapply (grp_pow_natural (grp_homo_rng_left_mult r)); cbn. by rewrite rng_mult_one_r. Defined. (** [rng_int_mult R 1] preserves multiplication. This requires that the specified ring element is the unit. *) Global Instance issemigrouppreserving_mult_rng_int_mult (R : Ring) : IsSemiGroupPreserving (A:=cring_Z) (Aop:=(.*.)) (Bop:=(.*.)) (rng_int_mult R 1). Proof. intros x y. cbn; unfold sg_op. lhs nrapply grp_pow_int_mul. nrapply rng_int_mult_dist_l. Defined. (** [rng_int_mult R 1] is a ring homomorphism *) Definition rng_homo_int (R : Ring) : (cring_Z : Ring) $-> R. Proof. snrapply Build_RingHomomorphism. 1: exact (rng_int_mult R 1). repeat split. 1,2: exact _. apply rng_plus_zero_r. Defined. (** The integers are the initial commutative ring *) Global Instance isinitial_cring_Z : IsInitial cring_Z. Proof. unfold IsInitial. intro R. exists (rng_homo_int R). intros g x. unfold rng_homo_int, rng_int_mult; cbn. induction x as [|x|x]. - by rhs nrapply (grp_homo_unit g). - rewrite grp_pow_succ. change (x.+1%int) with (1 + x)%int. rewrite (rng_homo_plus g 1 x). rewrite rng_homo_one. f_ap. - rewrite grp_pow_pred. rewrite IHx. clear IHx. change (-1 + g (-x)%int = g (-x).-1%int). rewrite <- (rng_homo_minus_one g). lhs_V nrapply (rng_homo_plus g). f_ap. Defined. Coq-HoTT-9.0/theories/Algebra/Universal/000077500000000000000000000000001474641544500200655ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Algebra/Universal/Algebra.v000066400000000000000000000124421474641544500216140ustar00rootroot00000000000000(** This file defines [Algebra], which is a generalization of group, ring, module, etc. An [Algebra] moreover generalizes structures with infinitary operations, such as infinite complete lattice. *) Local Unset Elimination Schemes. Require Export HoTT.Basics. Require Import HoTT.Types. Declare Scope Algebra_scope. Delimit Scope Algebra_scope with Algebra. (** The below definition [SymbolTypeOf] is used to specify algebra operations. See [SymbolType] and [Operation] below. *) Record SymbolTypeOf {Sort : Type} := Build_SymbolTypeOf { Arity : Type ; sorts_dom : Arity -> Sort ; sort_cod : Sort }. Arguments SymbolTypeOf : clear implicits. Arguments Build_SymbolTypeOf {Sort}. (** A [Signature] is used to specify [Algebra]s. A signature describes which operations (functions) an algebra for the signature is expected to provide. A signature consists of - A type of [Sort]s. An algebra for the signature provides a type for each [Sort] element. - A type of function symbols [Symbol]. For each function symbol [u : Symbol], an algebra for the signature provides a corresponding operation. - The field [symbol_types σ u] indicates which type the operation corresponding to [u] is expected to have. *) Record Signature := Build_Signature { Sort : Type ; Symbol : Type ; symbol_types : Symbol -> SymbolTypeOf Sort ; hset_sort : IsHSet Sort ; hset_symbol : IsHSet Symbol }. Notation SymbolType σ := (SymbolTypeOf (Sort σ)). Global Existing Instance hset_sort. Global Existing Instance hset_symbol. Global Coercion symbol_types : Signature >-> Funclass. (** Each [Algebra] has a collection of carrier types [Carriers σ], indexed by the type of sorts [Sort σ]. *) Notation Carriers σ := (Sort σ -> Type). (** Given [A : Carriers σ] and [w : SymbolType σ], the domain of an algebra operation [DomOperation A w] is a product of carrier types from [A], indexed by [Arity w]. *) Notation DomOperation A w := (forall i : Arity w, A (sorts_dom w i)) (only parsing). (** Given a symbol type [w : SymbolType σ], an algebra with carriers [A : Carriers σ] provides a corresponding operation of type [Operation A w]. See below for definition [Algerba]. Algebra operations are developed further in [HoTT.Algebra.Universal.Operation]. *) Definition Operation {σ} (A : Carriers σ) (w : SymbolType σ) : Type := DomOperation A w -> A (sort_cod w). (** An [Algebra σ] for a signature [σ] consists of a collection of carriers [Carriers σ], and for each symbol [u : Symbol σ], an operation/function of type [Operation carriers (σ u)], where [σ u : SymbolType σ] is the symbol type of [u]. Notice that [Algebra] does not specify equations involving carriers and operations. Equations are defined elsewhere. *) Record Algebra {σ : Signature} : Type := Build_Algebra { carriers : Carriers σ ; operations : forall (u : Symbol σ), Operation carriers (σ u) ; hset_algebra : forall (s : Sort σ), IsHSet (carriers s) }. Arguments Algebra : clear implicits. Arguments Build_Algebra {σ} carriers operations {hset_algebra}. Global Existing Instance hset_algebra. Global Coercion carriers : Algebra >-> Funclass. Bind Scope Algebra_scope with Algebra. Definition SigAlgebra (σ : Signature) : Type := {c : Carriers σ | { _ : forall (u : Symbol σ), Operation c (σ u) | forall (s : Sort σ), IsHSet (c s) } }. Lemma issig_algebra (σ : Signature) : SigAlgebra σ <~> Algebra σ. Proof. issig. Defined. Lemma path_algebra `{Funext} {σ : Signature} (A B : Algebra σ) (p : carriers A = carriers B) (q : transport (fun i => forall u, Operation i (σ u)) p (operations A) = operations B) : A = B. Proof. apply (ap (issig_algebra σ)^-1)^-1; cbn. apply (path_sigma' _ p). refine (transport_sigma p _ @ _). apply path_sigma_hprop. exact q. Defined. Arguments path_algebra {_} {_} (A B)%_Algebra_scope (p q)%_path_scope. Lemma path_ap_carriers_path_algebra `{Funext} {σ} (A B : Algebra σ) (p : carriers A = carriers B) (q : transport (fun i => forall u, Operation i (σ u)) p (operations A) = operations B) : ap carriers (path_algebra A B p q) = p. Proof. destruct A as [A a ha], B as [B b hb]; cbn in p, q. destruct p, q. unfold path_algebra, path_sigma_hprop, path_sigma_uncurried. cbn -[center]. by destruct (center (ha = hb)). Defined. Arguments path_ap_carriers_path_algebra {_} {_} (A B)%_Algebra_scope (p q)%_path_scope. Lemma path_path_algebra_issig {σ : Signature} {A B : Algebra σ} (p q : A = B) (r : ap (issig_algebra σ)^-1 p = ap (issig_algebra σ)^-1 q) : p = q. Proof. set (e := (equiv_ap (issig_algebra σ)^-1 A B)). by apply (@equiv_inv _ _ (ap e) (Equivalences.isequiv_ap _ _)). Defined. Arguments path_path_algebra_issig {_} {A B}%_Algebra_scope (p q r)%_path_scope. Lemma path_path_algebra `{Funext} {σ} {A B : Algebra σ} (p q : A = B) (r : ap carriers p = ap carriers q) : p = q. Proof. apply path_path_algebra_issig. unshelve eapply path_path_sigma. - transitivity (ap carriers p); [by destruct p |]. transitivity (ap carriers q); [exact r | by destruct q]. - apply path_ishprop. Defined. Arguments path_path_algebra {_} {σ} {A B}%_Algebra_scope (p q r)%_path_scope. Global Notation "u .# A" := (operations A u) : Algebra_scope. Coq-HoTT-9.0/theories/Algebra/Universal/Congruence.v000066400000000000000000000053261474641544500223520ustar00rootroot00000000000000(** This file implements algebra congruence relation. It serves as a universal algebra generalization of normal subgroup, ring ideal, etc. Congruence is used to construct quotients, in similarity with how normal subgroup and ring ideal are used to construct quotients. *) Require Export HoTT.Algebra.Universal.Algebra. Require Import HoTT.Universes.HProp HoTT.Classes.interfaces.canonical_names HoTT.Algebra.Universal.Homomorphism. Unset Elimination Schemes. Local Open Scope Algebra_scope. Section congruence. Context {σ : Signature} (A : Algebra σ) (Φ : forall s, Relation (A s)). (** A finitary operation [f : A s1 * A s2 * ... * A sn -> A t] satisfies [OpCompatible f] iff << Φ s1 x1 y1 * Φ s2 x2 y2 * ... * Φ sn xn yn >> implies << Φ t (f (x1, x2, ..., xn)) (f (y1, y2, ..., yn)). >> The below definition generalizes this to infinitary operations. *) Definition OpCompatible {w : SymbolType σ} (f : Operation A w) : Type := forall (a b : DomOperation A w), (forall i : Arity w, Φ (sorts_dom w i) (a i) (b i)) -> Φ (sort_cod w) (f a) (f b). Class OpsCompatible : Type := ops_compatible : forall (u : Symbol σ), OpCompatible u.#A. Global Instance trunc_ops_compatible `{Funext} {n : trunc_index} `{!forall s x y, IsTrunc n (Φ s x y)} : IsTrunc n OpsCompatible. Proof. apply istrunc_forall. Defined. (** A family of relations [Φ] is a congruence iff it is a family of mere equivalence relations and [OpsCompatible A Φ] holds. *) Class IsCongruence : Type := Build_IsCongruence { is_mere_relation_cong : forall (s : Sort σ), is_mere_relation (A s) (Φ s) ; equiv_rel_cong : forall (s : Sort σ), EquivRel (Φ s) ; ops_compatible_cong : OpsCompatible }. Global Arguments Build_IsCongruence {is_mere_relation_cong} {equiv_rel_cong} {ops_compatible_cong}. Global Existing Instance is_mere_relation_cong. Global Existing Instance equiv_rel_cong. Global Existing Instance ops_compatible_cong. Global Instance hprop_is_congruence `{Funext} : IsHProp IsCongruence. Proof. apply (equiv_hprop_allpath _)^-1. intros [C1 C2 C3] [D1 D2 D3]. by destruct (path_ishprop C1 D1), (path_ishprop C2 D2), (path_ishprop C3 D3). Defined. End congruence. (** A homomorphism [f : forall s, A s -> B s] is compatible with a congruence [Φ] iff [Φ s x y] implies [f s x = f s y]. *) Definition HomCompatible {σ : Signature} {A B : Algebra σ} (Φ : forall s, Relation (A s)) `{!IsCongruence A Φ} (f : forall s, A s -> B s) `{!IsHomomorphism f} : Type := forall s (x y : A s), Φ s x y -> f s x = f s y. Coq-HoTT-9.0/theories/Algebra/Universal/Homomorphism.v000066400000000000000000000127521474641544500227440ustar00rootroot00000000000000(** This file implements algebra homomorphism. We show that algebras form a wild category with homomorphisms. The [WildCat] module provides some nice notations that we we use: [A $-> B] for homomorphism, [Id] for the identity homomorphism and [g $o f] for composition. *) Local Unset Elimination Schemes. Require Export HoTT.Algebra.Universal.Algebra HoTT.WildCat.Core. Require Import HoTT.Types. Local Open Scope Algebra_scope. Section is_homomorphism. Context {σ} {A B : Algebra σ} (f : forall (s : Sort σ), A s -> B s). Definition OpPreserving {w : SymbolType σ} (α : Operation A w) (β : Operation B w) : Type := forall a : DomOperation A w, f (sort_cod w) (α a) = β (fun i => f (sorts_dom w i) (a i)). Global Instance hprop_oppreserving `{Funext} {w : SymbolType σ} (α : Operation A w) (β : Operation B w) : IsHProp (OpPreserving α β). Proof. apply istrunc_forall. Qed. Class IsHomomorphism : Type := oppreserving_hom : forall (u : Symbol σ), OpPreserving u.#A u.#B. Global Instance hprop_is_homomorphism `{Funext} : IsHProp IsHomomorphism. Proof. apply istrunc_forall. Qed. End is_homomorphism. Record Homomorphism {σ} {A B : Algebra σ} : Type := Build_Homomorphism { def_homomorphism : forall (s : Sort σ), A s -> B s ; is_homomorphism : IsHomomorphism def_homomorphism }. Arguments Homomorphism {σ}. Arguments Build_Homomorphism {σ A B} def_homomorphism {is_homomorphism}. Global Coercion def_homomorphism : Homomorphism >-> Funclass. Global Existing Instance is_homomorphism. Global Instance isgraph_algebra (σ : Signature) : IsGraph (Algebra σ) := Build_IsGraph (Algebra σ) Homomorphism. Lemma apD10_homomorphism {σ} {A B : Algebra σ} {f g : A $-> B} : f = g -> forall s, f s == g s. Proof. intro p. by destruct p. Defined. Definition SigHomomorphism {σ} (A B : Algebra σ) : Type := { def_hom : forall s, A s -> B s | IsHomomorphism def_hom }. Lemma issig_homomorphism {σ} (A B : Algebra σ) : SigHomomorphism A B <~> (A $-> B). Proof. issig. Defined. Global Instance hset_homomorphism `{Funext} {σ} (A B : Algebra σ) : IsHSet (A $-> B). Proof. apply (istrunc_equiv_istrunc _ (issig_homomorphism A B)). Qed. Lemma path_homomorphism `{Funext} {σ} {A B : Algebra σ} (f g : A $-> B) (p : def_homomorphism f = def_homomorphism g) : f = g. Proof. apply (ap (issig_homomorphism A B)^-1)^-1. unfold issig_homomorphism; cbn. apply path_sigma_hprop. exact p. Defined. (** The identity homomorphism. *) Section homomorphism_id. Context {σ} (A : Algebra σ). Global Instance is_homomorphism_id : IsHomomorphism (fun s (x : A s) => x). Proof. intros u a. reflexivity. Defined. Definition homomorphism_id : A $-> A := Build_Homomorphism (fun s (x : A s) => x). End homomorphism_id. Arguments homomorphism_id {σ} A%_Algebra_scope , {σ} {A}. (** Composition of homomorphisms. *) Section homomorphism_compose. Context {σ} {A B C : Algebra σ}. Global Instance is_homomorphism_compose (g : forall s, B s -> C s) `{!IsHomomorphism g} (f : forall s, A s -> B s) `{!IsHomomorphism f} : IsHomomorphism (fun s => g s o f s). Proof. intros u a. by rewrite <- (oppreserving_hom g), (oppreserving_hom f). Qed. Definition homomorphism_compose (g : B $-> C) (f : A $-> B) : A $-> C := Build_Homomorphism (fun s => g s o f s). End homomorphism_compose. Global Instance is01cat_algebra (σ : Signature) : Is01Cat (Algebra σ) := Build_Is01Cat (Algebra σ) _ (fun _ => homomorphism_id) (fun _ _ _ => homomorphism_compose). Lemma assoc_homomorphism_compose `{Funext} {σ} {A B C D : Algebra σ} (h : C $-> D) (g : B $-> C) (f : A $-> B) : (h $o g) $o f = h $o (g $o f). Proof. by apply path_homomorphism. Defined. Lemma left_id_homomorphism_compose `{Funext} {σ} {A B : Algebra σ} (f : A $-> B) : Id B $o f = f. Proof. by apply path_homomorphism. Defined. Lemma right_id_homomorphism_compose `{Funext} {σ} {A B : Algebra σ} (f : A $-> B) : f $o Id A = f. Proof. by apply path_homomorphism. Defined. Global Instance is2graph_algebra {σ} : Is2Graph (Algebra σ) := fun A B => Build_IsGraph _ (fun (f g : A $-> B) => forall s, f s == g s). Global Instance is01cat_homomorphism {σ} (A B : Algebra σ) : Is01Cat (A $-> B). Proof. apply Build_Is01Cat. - exact (fun f s x => idpath). - exact (fun f g h P Q s x => Q s x @ P s x). Defined. Global Instance is0gpd_homomorphism {σ} {A B : Algebra σ} : Is0Gpd (A $-> B). Proof. apply Build_Is0Gpd. intros f g P s x. exact (P s x)^. Defined. Global Instance is0functor_postcomp_homomorphism {σ} (A : Algebra σ) {B C : Algebra σ} (h : B $-> C) : Is0Functor (@cat_postcomp (Algebra σ) _ _ A B C h). Proof. apply Build_Is0Functor. intros [f ?] [g ?] p s x. exact (ap (h s) (p s x)). Defined. Global Instance is0functor_precomp_homomorphism {σ} {A B : Algebra σ} (h : A $-> B) (C : Algebra σ) : Is0Functor (@cat_precomp (Algebra σ) _ _ A B C h). Proof. apply Build_Is0Functor. intros [f ?] [g ?] p s x. exact (p s (h s x)). Defined. Global Instance is1cat_algebra (σ : Signature) : Is1Cat (Algebra σ). Proof. by rapply Build_Is1Cat. Defined. Global Instance is1cat_strong_algebra `{Funext} (σ : Signature) : Is1Cat_Strong (Algebra σ). Proof. rapply Build_Is1Cat_Strong. - intros. apply assoc_homomorphism_compose. - intros. symmetry; apply assoc_homomorphism_compose. - intros. apply left_id_homomorphism_compose. - intros. apply right_id_homomorphism_compose. Defined. Coq-HoTT-9.0/theories/Algebra/Universal/Operation.v000066400000000000000000000161301474641544500222150ustar00rootroot00000000000000(** This file continues the development of algebra [Operation]. It gives a way to construct operations using (conventional) curried functions, and shows that such curried operations are equivalent to the uncurried operations [Operation]. *) Require Export HoTT.Algebra.Universal.Algebra. Require Import HoTT.Types HoTT.Spaces.Finite HoTT.Spaces.Nat.Core. Local Open Scope Algebra_scope. Local Open Scope nat_scope. (** Functions [head_dom'] and [head_dom] are used to get the first element of a nonempty operation domain [a : forall i, A (ss i)]. *) Monomorphic Definition head_dom' {σ} (A : Carriers σ) (n : nat) : forall (N : n > 0) (ss : FinSeq n (Sort σ)) (a : forall i, A (ss i)), A (fshead' n N ss) := match n with | 0 => fun N ss _ => Empty_rec (lt_irrefl _ N) | n'.+1 => fun N ss a => a fin_zero end. Monomorphic Definition head_dom {σ} (A : Carriers σ) {n : nat} (ss : FinSeq n.+1 (Sort σ)) (a : forall i, A (ss i)) : A (fshead ss) := head_dom' A n.+1 _ ss a. (** Functions [tail_dom'] and [tail_dom] are used to obtain the tail of an operation domain [a : forall i, A (ss i)]. *) Monomorphic Definition tail_dom' {σ} (A : Carriers σ) (n : nat) : forall (ss : FinSeq n (Sort σ)) (a : forall i, A (ss i)) (i : Fin (nat_pred n)), A (fstail' n ss i) := match n with | 0 => fun ss _ i => Empty_rec i | n'.+1 => fun ss a i => a (fsucc i) end. Monomorphic Definition tail_dom {σ} (A : Carriers σ) {n : nat} (ss : FinSeq n.+1 (Sort σ)) (a : forall i, A (ss i)) : forall i, A (fstail ss i) := tail_dom' A n.+1 ss a. (** Functions [cons_dom'] and [cons_dom] to add an element to the front of a given domain [a : forall i, A (ss i)]. *) Monomorphic Definition cons_dom' {σ} (A : Carriers σ) {n : nat} : forall (i : Fin n) (ss : FinSeq n (Sort σ)) (N : n > 0), A (fshead' n N ss) -> (forall i, A (fstail' n ss i)) -> A (ss i) := fin_ind (fun n i => forall (ss : Fin n -> Sort σ) (N : n > 0), A (fshead' n N ss) -> (forall i, A (fstail' n ss i)) -> A (ss i)) (fun n' _ z x _ => x) (fun n' i' _ => fun _ _ _ xs => xs i'). Definition cons_dom {σ} (A : Carriers σ) {n : nat} (ss : FinSeq n.+1 (Sort σ)) (x : A (fshead ss)) (xs : forall i, A (fstail ss i)) : forall i : Fin n.+1, A (ss i) := fun i => cons_dom' A i ss _ x xs. (** The empty domain: *) Definition nil_dom {σ} (A : Carriers σ) (ss : FinSeq 0 (Sort σ)) : forall i : Fin 0, A (ss i) := Empty_ind (A o ss). (** A specialization of [Operation] to finite [Fin n] arity. *) Definition FiniteOperation {σ : Signature} (A : Carriers σ) {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ) : Type := Operation A {| Arity := Fin n; sorts_dom := ss; sort_cod := t |}. (** A type of curried operations << CurriedOperation A [s1, ..., sn] t := A s1 -> ... -> A sn -> A t. >> *) Fixpoint CurriedOperation {σ} (A : Carriers σ) {n : nat} : (FinSeq n (Sort σ)) -> Sort σ -> Type := match n with | 0 => fun ss t => A t | n'.+1 => fun ss t => A (fshead ss) -> CurriedOperation A (fstail ss) t end. (** Function [operation_uncurry] is used to uncurry an operation << operation_uncurry A [s1, ..., sn] t (op : CurriedOperation A [s1, ..., sn] t) : FiniteOperation A [s1, ..., sn] t := fun (x1 : A s1, ..., xn : A xn) => op x1 ... xn >> See [equiv_operation_curry] below. *) Fixpoint operation_uncurry {σ} (A : Carriers σ) {n : nat} : forall (ss : FinSeq n (Sort σ)) (t : Sort σ), CurriedOperation A ss t -> FiniteOperation A ss t := match n with | 0 => fun ss t op _ => op | n'.+1 => fun ss t op a => operation_uncurry A (fstail ss) t (op (a fin_zero)) (a o fsucc) end. Local Example computation_example_operation_uncurry : forall (σ : Signature) (A : Carriers σ) (n : nat) (s1 s2 t : Sort σ) (ss := (fscons s1 (fscons s2 fsnil))) (op : CurriedOperation A ss t) (a : forall i, A (ss i)), operation_uncurry A ss t op = fun a => op (a fin_zero) (a (fsucc fin_zero)). Proof. reflexivity. Qed. (** Function [operation_curry] is used to curry an operation << operation_curry A [s1, ..., sn] t (op : FiniteOperation A [s1, ..., sn] t) : CurriedOperation A [s1, ..., sn] t := fun (x1 : A s1) ... (xn : A xn) => op (x1, ..., xn) >> See [equiv_operation_curry] below. *) Fixpoint operation_curry {σ} (A : Carriers σ) {n : nat} : forall (ss : FinSeq n (Sort σ)) (t : Sort σ), FiniteOperation A ss t -> CurriedOperation A ss t := match n with | 0 => fun ss t op => op (Empty_ind _) | n'.+1 => fun ss t op x => operation_curry A (fstail ss) t (op o cons_dom A ss x) end. Local Example computation_example_operation_curry : forall (σ : Signature) (A : Carriers σ) (n : nat) (s1 s2 t : Sort σ) (ss := (fscons s1 (fscons s2 fsnil))) (op : FiniteOperation A ss t) (x1 : A s1) (x2 : A s2), operation_curry A ss t op = fun x1 x2 => op (cons_dom A ss x1 (cons_dom A _ x2 (nil_dom A _))). Proof. reflexivity. Qed. Lemma expand_cons_dom' {σ} (A : Carriers σ) (n : nat) : forall (i : Fin n) (ss : FinSeq n (Sort σ)) (N : n > 0) (a : forall i, A (ss i)), cons_dom' A i ss N (head_dom' A n N ss a) (tail_dom' A n ss a) = a i. Proof. intro i. induction i using fin_ind; intros ss N a. - unfold cons_dom'. rewrite fin_ind_beta_zero. reflexivity. - unfold cons_dom'. by rewrite fin_ind_beta_fsucc. Qed. Lemma expand_cons_dom `{Funext} {σ} (A : Carriers σ) {n : nat} (ss : FinSeq n.+1 (Sort σ)) (a : forall i, A (ss i)) : cons_dom A ss (head_dom A ss a) (tail_dom A ss a) = a. Proof. funext i. apply expand_cons_dom'. Defined. Lemma path_operation_curry_to_cunurry `{Funext} {σ} (A : Carriers σ) {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ) : operation_uncurry A ss t o operation_curry A ss t == idmap. Proof. intro a. induction n as [| n IHn]. - funext d. refine (ap a _). apply path_contr. - funext a'. refine (ap (fun x => x _) (IHn _ _) @ _). refine (ap a _). apply expand_cons_dom. Qed. Lemma path_operation_uncurry_to_curry `{Funext} {σ} (A : Carriers σ) {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ) : operation_curry A ss t o operation_uncurry A ss t == idmap. Proof. intro a. induction n; [reflexivity|]. funext x. refine (_ @ IHn (fstail ss) (a x)). refine (ap (operation_curry A (fstail ss) t) _). funext a'. simpl. unfold cons_dom, cons_dom'. rewrite fin_ind_beta_zero. refine (ap (operation_uncurry A (fstail ss) t (a x)) _). funext i'. by rewrite fin_ind_beta_fsucc. Qed. Global Instance isequiv_operation_curry `{Funext} {σ} (A : Carriers σ) {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ) : IsEquiv (operation_curry A ss t). Proof. srapply isequiv_adjointify. - apply operation_uncurry. - apply path_operation_uncurry_to_curry. - apply path_operation_curry_to_cunurry. Defined. Definition equiv_operation_curry `{Funext} {σ} (A : Carriers σ) {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ) : FiniteOperation A ss t <~> CurriedOperation A ss t := Build_Equiv _ _ (operation_curry A ss t) _. Coq-HoTT-9.0/theories/Algebra/Universal/TermAlgebra.v000066400000000000000000000322331474641544500224440ustar00rootroot00000000000000(** This file defines the term algebra [TermAlgebra], also referred to as the absolutely free algebra. We show that term algebra forms an adjoint functor from the category of hset carriers << {C : Carrier σ | forall s, IsHSet (C s)} >> to the category of algebras (without equations) [Algebra σ], where [Carriers σ] is notation for [Sort σ -> Type]. See [ump_term_algebra]. There is a similar construction for algebras with equations, the free algebra [FreeAlgebra]. The free algebra is defined in another file. *) Require Export HoTT.Algebra.Universal.Algebra. Require Import HoTT.Universes.HSet HoTT.Classes.interfaces.canonical_names HoTT.Algebra.Universal.Homomorphism HoTT.Algebra.Universal.Congruence. Unset Elimination Schemes. Local Open Scope Algebra_scope. (** The term algebra carriers are generated by [C : Carriers σ], with an element for each element of [C s], and an operation for each operation symbol [u : Symbol σ]. *) Inductive CarriersTermAlgebra {σ} (C : Carriers σ) : Carriers σ := | var_term_algebra : forall s, C s -> CarriersTermAlgebra C s | ops_term_algebra : forall (u : Symbol σ), DomOperation (CarriersTermAlgebra C) (σ u) -> CarriersTermAlgebra C (sort_cod (σ u)). Scheme CarriersTermAlgebra_ind := Induction for CarriersTermAlgebra Sort Type. Arguments CarriersTermAlgebra_ind {σ}. Definition CarriersTermAlgebra_rect {σ} := @CarriersTermAlgebra_ind σ. Definition CarriersTermAlgebra_rec {σ : Signature} (C : Carriers σ) (P : Sort σ -> Type) (vs : forall (s : Sort σ), C s -> P s) (os : forall (u : Symbol σ) (c : DomOperation (CarriersTermAlgebra C) (σ u)), (forall i : Arity (σ u), P (sorts_dom (σ u) i)) -> P (sort_cod (σ u))) (s : Sort σ) (T : CarriersTermAlgebra C s) : P s := CarriersTermAlgebra_ind C (fun s _ => P s) vs os s T. (** A family of relations [R : forall s, Relation (C s)] can be extended to a family of relations on the term algebra carriers, << forall s, Relation (CarriersTermAlgebra C s) >> See [ExtendDRelTermAlgebra] and [ExtendRelTermAlgebra] below. *) Fixpoint ExtendDRelTermAlgebra {σ : Signature} {C : Carriers σ} (R : forall s, Relation (C s)) {s1 s2 : Sort σ} (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2) : Type := match S, T with | var_term_algebra s1 x, var_term_algebra s2 y => {p : s1 = s2 | R s2 (p # x) y} | ops_term_algebra u1 a, ops_term_algebra u2 b => { p : u1 = u2 | forall i : Arity (σ u1), ExtendDRelTermAlgebra R (a i) (b (transport (fun v => Arity (σ v)) p i))} | _, _ => Empty end. Definition ExtendRelTermAlgebra {σ : Signature} {C : Carriers σ} (R : forall s, Relation (C s)) {s : Sort σ} : CarriersTermAlgebra C s -> CarriersTermAlgebra C s -> Type := ExtendDRelTermAlgebra R. (** The next section shows, in particular, the following: If [R : forall s, Relation (C s)] is a family of mere equivalence relations, then [@ExtendRelTermAlgebra σ C R] is a family of mere equivalence eqlations. *) Section extend_rel_term_algebra. Context `{Funext} {σ : Signature} {C : Carriers σ} (R : forall s, Relation (C s)) `{!forall s, is_mere_relation (C s) (R s)}. Global Instance hprop_extend_drel_term_algebra {s1 s2 : Sort σ} (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2) : IsHProp (ExtendDRelTermAlgebra R S T). Proof. generalize dependent s2. induction S; intros s2 T; destruct T; exact _. Qed. Global Instance reflexive_extend_rel_term_algebra `{!forall s, Reflexive (R s)} {s : Sort σ} : Reflexive (@ExtendRelTermAlgebra σ C R s). Proof. intro S. induction S as [| u c h]. - by exists idpath. - exists idpath. intro i. apply h. Qed. Lemma symmetric_extend_drel_term_algebra `{!forall s, Symmetric (R s)} {s1 s2 : Sort σ} (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2) (h : ExtendDRelTermAlgebra R S T) : ExtendDRelTermAlgebra R T S. Proof. generalize dependent s2. induction S as [| u c h]; intros s2 [] p. - destruct p as [p1 p2]. induction p1. exists idpath. by symmetry. - elim p. - elim p. - destruct p as [p f]. induction p. exists idpath. intro i. apply h. apply f. Qed. Global Instance symmetric_extend_rel_term_algebra `{!forall s, Symmetric (R s)} {s : Sort σ} : Symmetric (@ExtendRelTermAlgebra σ C R s). Proof. intros S T. apply symmetric_extend_drel_term_algebra. Defined. Lemma transitive_extend_drel_term_algebra `{!forall s, Transitive (R s)} {s1 s2 s3 : Sort σ} (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2) (U : CarriersTermAlgebra C s3) (h1 : ExtendDRelTermAlgebra R S T) (h2 : ExtendDRelTermAlgebra R T U) : ExtendDRelTermAlgebra R S U. Proof. generalize dependent s3. generalize dependent s2. induction S as [| u c h]; intros s2 [? d | ? d] h2 s3 [] h3; destruct h2 as [p2 P2], h3 as [p3 P3] || by (elim h2 || elim h3). - exists (p2 @ p3). rewrite transport_pp. induction p2, p3. by transitivity d. - exists (p2 @ p3). intro i. induction p2. apply (h i _ (d i)). + apply P2. + rewrite concat_1p. apply P3. Qed. Global Instance transitive_extend_rel_term_algebra `{!forall s, Transitive (R s)} {s : Sort σ} : Transitive (@ExtendRelTermAlgebra σ C R s). Proof. intros S T U. apply transitive_extend_drel_term_algebra. Defined. Global Instance equivrel_extend_rel_term_algebra `{!forall s, EquivRel (R s)} (s : Sort σ) : EquivRel (@ExtendRelTermAlgebra σ C R s). Proof. constructor; exact _. Qed. End extend_rel_term_algebra. (** By using path (propositional equality) as equivalence relation for [ExtendRelTermAlgebra], we obtain an equivalent notion of equality of term algebra carriers, [equiv_path_extend_path_term_algebra]. The reason for introducing [ExtendRelTermAlgebra] is to have a notion of equality which works well together with induction on term algebras. *) Section extend_path_term_algebra. Context `{Funext} {σ} {C : Carriers σ} `{!forall s, IsHSet (C s)}. Definition ExtendPathTermAlgebra {s : Sort σ} (S : CarriersTermAlgebra C s) (T : CarriersTermAlgebra C s) : Type := ExtendRelTermAlgebra (fun s => paths) S T. Global Instance reflexive_extend_path_term_algebra : forall s : Sort σ, Reflexive (@ExtendPathTermAlgebra s). Proof. by apply reflexive_extend_rel_term_algebra. Defined. Lemma reflexive_extend_path_term_algebra_path {s : Sort σ} {S T : CarriersTermAlgebra C s} (p : S = T) : ExtendPathTermAlgebra S T. Proof. induction p. apply reflexive_extend_path_term_algebra. Defined. Global Instance symmetric_extend_path_term_algebra : forall s : Sort σ, Symmetric (@ExtendPathTermAlgebra s). Proof. apply symmetric_extend_rel_term_algebra. intros s x y. apply inverse. Defined. Global Instance transitive_extend_path_term_algebra : forall s : Sort σ, Transitive (@ExtendPathTermAlgebra s). Proof. apply transitive_extend_rel_term_algebra. intros s x y z. apply concat. Defined. Global Instance equivrel_extend_path_term_algebra : forall s : Sort σ, EquivRel (@ExtendPathTermAlgebra s). Proof. constructor; exact _. Qed. Global Instance hprop_extend_path_term_algebra (s : Sort σ) : is_mere_relation (CarriersTermAlgebra C s) ExtendPathTermAlgebra. Proof. intros S T. exact _. Defined. Lemma dependent_path_extend_path_term_algebra {s1 s2 : Sort σ} (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2) (e : ExtendDRelTermAlgebra (fun s => paths) S T) : {p : s1 = s2 | p # S = T}. Proof. generalize dependent s2. induction S as [| u c h]; intros s2 [? d | ? d] e; solve [elim e] || destruct e as [p e]. - exists p. by induction p, e. - induction p. exists idpath. cbn. f_ap. funext a. destruct (h a _ (d a) (e a)) as [p q]. by induction (hset_path2 idpath p). Defined. Lemma path_extend_path_term_algebra {s : Sort σ} (S T : CarriersTermAlgebra C s) (e : ExtendPathTermAlgebra S T) : S = T. Proof. destruct (dependent_path_extend_path_term_algebra S T e) as [p q]. by induction (hset_path2 idpath p). Defined. Global Instance hset_carriers_term_algebra (s : Sort σ) : IsHSet (CarriersTermAlgebra C s). Proof. apply (@ishset_hrel_subpaths _ ExtendPathTermAlgebra). - apply reflexive_extend_path_term_algebra. - apply hprop_extend_path_term_algebra; exact _. - apply path_extend_path_term_algebra. Defined. Definition equiv_path_extend_path_term_algebra {s : Sort σ} (S T : CarriersTermAlgebra C s) : ExtendPathTermAlgebra S T <~> (S = T) := equiv_iff_hprop (path_extend_path_term_algebra S T) reflexive_extend_path_term_algebra_path. End extend_path_term_algebra. (** At this point we can define the term algebra. *) Definition TermAlgebra `{Funext} {σ : Signature} (C : Carriers σ) `{!forall s, IsHSet (C s)} : Algebra σ := Build_Algebra (CarriersTermAlgebra C) (@ops_term_algebra _ C). Lemma isinj_var_term_algebra {σ} (C : Carriers σ) (s : Sort σ) (x y : C s) : var_term_algebra C s x = var_term_algebra C s y -> x = y. Proof. intro p. apply reflexive_extend_path_term_algebra_path in p. destruct p as [p1 p2]. by destruct (hset_path2 p1 idpath)^. Qed. Lemma isinj_ops_term_algebra `{Funext} {σ} (C : Carriers σ) (u : Symbol σ) (a b : DomOperation (CarriersTermAlgebra C) (σ u)) : ops_term_algebra C u a = ops_term_algebra C u b -> a = b. Proof. intro p. apply reflexive_extend_path_term_algebra_path in p. destruct p as [p1 p2]. destruct (hset_path2 p1 idpath)^. funext i. apply path_extend_path_term_algebra. apply p2. Qed. (** The extension [ExtendRelTermAlgebra R], of a family of mere equivalence relations [R], is a congruence. *) Global Instance is_congruence_extend_rel_term_algebra `{Funext} {σ} (C : Carriers σ) `{!forall s, IsHSet (C s)} (R : forall s, Relation (C s)) `{!forall s, EquivRel (R s)} `{!forall s, is_mere_relation (C s) (R s)} : IsCongruence (TermAlgebra C) (@ExtendRelTermAlgebra σ C R). Proof. constructor. - intros. exact _. - intros. exact _. - intros u a b c. exists idpath. intro i. apply c. Defined. (** Given and family of functions [f : forall s, C s -> A s], we can extend it to a [TermAlgebra C $-> A], as shown in the next section. *) Section hom_term_algebra. Context `{Funext} {σ} {C : Carriers σ} `{!forall s, IsHSet (C s)} (A : Algebra σ) (f : forall s, C s -> A s). Definition map_term_algebra {σ} {C : Carriers σ} (A : Algebra σ) (f : forall s, C s -> A s) (s : Sort σ) (T : CarriersTermAlgebra C s) : A s := CarriersTermAlgebra_rec C A f (fun u _ r => u.#A r) s T. Global Instance is_homomorphism_map_term_algebra : @IsHomomorphism σ (TermAlgebra C) A (map_term_algebra A f). Proof. intros u a. by refine (ap u.#A _). Qed. Definition hom_term_algebra : TermAlgebra C $-> A := @Build_Homomorphism σ (TermAlgebra C) A (map_term_algebra A f) _. End hom_term_algebra. (** The next section proves the universal property of the term algebra, that [TermAlgebra] is a left adjoint functor << {C : Carriers σ | forall s, IsHSet (C s)} -> Algebra σ, >> with right adjoint the forgetful functor. This is stated below as an equivalence << Homomorphism (TermAlgebra C) A <~> (forall s, C s -> A s), >> given by precomposition with << var_term_algebra C s : C s -> TermAlgebra C s. >> *) Section ump_term_algebra. Context `{Funext} {σ} (C : Carriers σ) `{forall s, IsHSet (C s)} (A : Algebra σ). (** By precomposing [Homomorphism (TermAlgebra C) A] with [var_term_algebra], we obtain a family [forall s, C s -> A s]. *) Definition precomp_var_term_algebra (f : TermAlgebra C $-> A) : forall s, C s -> A s := fun s x => f s (var_term_algebra C s x). Lemma path_precomp_var_term_algebra_to_hom_term_algebra : forall (f : TermAlgebra C $-> A), hom_term_algebra A (precomp_var_term_algebra f) = f. Proof. intro f. apply path_homomorphism. funext s T. induction T as [|u c h]. - reflexivity. - refine (_ @ (is_homomorphism f u c)^). refine (ap u.#A _). funext i. apply h. Defined. Lemma path_hom_term_algebra_to_precomp_var_term_algebra : forall (f : forall s, C s -> A s), precomp_var_term_algebra (hom_term_algebra A f) = f. Proof. intro f. by funext s a. Defined. (** Precomposition with [var_term_algebra] is an equivalence *) Global Instance isequiv_precomp_var_term_algebra : IsEquiv precomp_var_term_algebra. Proof. srapply isequiv_adjointify. - apply hom_term_algebra. - intro. apply path_hom_term_algebra_to_precomp_var_term_algebra. - intro. apply path_precomp_var_term_algebra_to_hom_term_algebra. Defined. (** The universal property of the term algebra: The [TermAlgebra] is a left adjoint functor. Notice [isequiv_precomp_var_term_algebra] above. *) Theorem ump_term_algebra : (TermAlgebra C $-> A) <~> (forall s, C s -> A s). Proof. exact (Build_Equiv _ _ precomp_var_term_algebra _). Defined. End ump_term_algebra. Coq-HoTT-9.0/theories/Algebra/ooAction.v000066400000000000000000000004671474641544500200660ustar00rootroot00000000000000Require Import Basics. Require Import Algebra.ooGroup. Local Open Scope path_scope. (** * Actions of oo-Groups *) Definition ooAction (G : ooGroup) := classifying_space G -> Type. Definition action_space {G} : ooAction G -> Type := fun X => X (point _). Coercion action_space : ooAction >-> Sortclass. Coq-HoTT-9.0/theories/Algebra/ooGroup.v000066400000000000000000000241201474641544500177350ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed. Require Import Truncations.Core Truncations.Connectedness. Require Import Homotopy.ClassifyingSpace. Require Import Algebra.Groups. Require Import WildCat. Local Open Scope trunc_scope. Local Open Scope path_scope. Local Open Scope pointed_scope. (** Keyed unification makes [rewrite !loops_functor_group] take a really long time. See https://coq.inria.fr/bugs/show_bug.cgi?id=4544 for more discussion. *) Local Unset Keyed Unification. (** * oo-Groups *) (** We want a workable definition of "oo-group" (what a classical homotopy theorist would call a "grouplike Aoo-space"). The classical definitions using operads or Segal spaces involve infinitely much data, which we don't know how to handle in HoTT. But instead, we can invoke the theorem (which is a theorem in classical homotopy theory, and also in any oo-topos) that every oo-group is the loop space of some pointed connected object, and use it instead as a definition: we define an oo-group to be a pointed connected type (its classifying space or delooping). Then we make subsidiary definitions to allow us to treat such an object in the way we would expect, e.g. an oo-group homomorphism is a pointed map between classifying spaces. *) (** ** Definition *) Record ooGroup := { classifying_space : pType ; isconn_classifying_space : IsConnected 0 classifying_space }. Global Existing Instance isconn_classifying_space. Local Notation B := classifying_space. Definition group_type (G : ooGroup) : Type := point (B G) = point (B G). (** The following is fundamental: we declare a coercion from oo-groups to types which takes a pointed connected type not to its underlying type, but to its loop space. Thus, if [G : ooGroup], then [g : G] means that [g] is an element of the oo-group that [G] is intended to denote, which is the loop space of the pointed connected type that is technically the data of which [G : ooGroup] consists. This makes it easier to really think of [G] as "really being" an oo-group rather than its classifying space. This is also convenient because elements of oo-groups are, definitionally, loops in some type. Thus, the oo-group operations like multiplication, inverse, associativity, higher associativity, etc. are simply special cases of the corresponding operations for paths. *) Coercion group_type : ooGroup >-> Sortclass. (** Every pointed type has a loop space that is an oo-group. *) Definition group_loops (X : pType) : ooGroup. Proof. pose (BG := [{ x:X & merely (x = pt) }, exist (fun x:X => merely (x = pt)) pt (tr 1)]). (** Using [cut] prevents Coq from looking for these facts with typeclass search, which is slow and (for some reason) introduces scads of extra universes. *) cut (IsConnected 0 BG). { exact (Build_ooGroup BG). } cut (IsSurjection (unit_name (point BG))). { intros; refine (conn_pointed_type pt). } apply BuildIsSurjection; simpl; intros [x p]. strip_truncations; apply tr; exists tt. apply path_sigma_hprop; simpl. exact (p^). Defined. (** Unfortunately, the underlying type of that oo-group is not *definitionally* the same as the ordinary loop space, but it is equivalent to it. *) Definition loops_group (X : pType) : loops X <~> group_loops X. Proof. unfold loops, group_type. simpl. exact (equiv_path_sigma_hprop (point X ; tr 1) (point X ; tr 1)). Defined. (** ** Homomorphisms *) (** *** Definition *) Definition ooGroupHom (G H : ooGroup) := B G ->* B H. Definition grouphom_fun {G H} (phi : ooGroupHom G H) : G -> H := fmap loops phi. Coercion grouphom_fun : ooGroupHom >-> Funclass. (** The loop group functor takes values in oo-group homomorphisms. *) Definition group_loops_functor {X Y : pType} (f : X ->* Y) : ooGroupHom (group_loops X) (group_loops Y). Proof. simple refine (Build_pMap _ _ _ _); simpl. - intros [x p]. exists (f x). strip_truncations; apply tr. exact (ap f p @ point_eq f). - apply path_sigma_hprop; simpl. apply point_eq. Defined. (** And this functor "is" the same as the ordinary loop space functor. *) Definition loops_functor_group {X Y : pType} (f : X ->* Y) : fmap loops (group_loops_functor f) o loops_group X == loops_group Y o fmap loops f. Proof. intros x. apply (equiv_inj (equiv_path_sigma_hprop _ _)^-1). simpl. unfold pr1_path; rewrite !ap_pp. rewrite ap_V, !ap_pr1_path_sigma_hprop. apply whiskerL, whiskerR. transitivity (ap (fun X0 : {x0 : X & merely (x0 = point X)} => f X0.1) (path_sigma_hprop (point X; tr 1) (point X; tr 1) x)). - match goal with |- ap ?f (ap ?g ?p) = ?z => symmetry; refine (ap_compose g f p) end. - rewrite ap_compose; apply ap. apply ap_pr1_path_sigma_hprop. Qed. Definition grouphom_compose {G H K : ooGroup} (psi : ooGroupHom H K) (phi : ooGroupHom G H) : ooGroupHom G K := pmap_compose psi phi. (** *** Functoriality *) Definition group_loops_functor_compose {X Y Z : pType} (psi : Y ->* Z) (phi : X ->* Y) : grouphom_compose (group_loops_functor psi) (group_loops_functor phi) == group_loops_functor (pmap_compose psi phi). Proof. intros g. unfold grouphom_fun, grouphom_compose. refine (pointed_htpy (fmap_comp loops _ _) g @ _). pose (p := eisretr (loops_group X) g). change (fmap loops (group_loops_functor psi) (fmap loops (group_loops_functor phi) g) = fmap loops (group_loops_functor (pmap_compose psi phi)) g). rewrite <- p. rewrite !loops_functor_group. apply ap. symmetry; rapply (fmap_comp loops). Qed. Definition grouphom_idmap (G : ooGroup) : ooGroupHom G G := pmap_idmap. Definition group_loops_functor_idmap {X : pType} : grouphom_idmap (group_loops X) == group_loops_functor (Id (A:=pType) _). Proof. intros g. refine (fmap_id loops _ g @ _). rewrite <- (eisretr (loops_group X) g). unfold grouphom_fun, grouphom_idmap. rewrite !loops_functor_group. exact (ap (loops_group X) (fmap_id loops _ _)^). Qed. (** *** Homomorphic properties *) (** The following tactic often allows us to "pretend" that phi preserves basepoints strictly. This is basically a simple extension of [pointed_reduce_rewrite] (see Pointed.v). *) Ltac grouphom_reduce := unfold grouphom_fun; cbn; repeat match goal with | [ G : ooGroup |- _ ] => destruct G as [G ?] | [ phi : ooGroupHom ?G ?H |- _ ] => destruct phi as [phi ?] end; pointed_reduce_rewrite. Definition compose_grouphom {G H K : ooGroup} (psi : ooGroupHom H K) (phi : ooGroupHom G H) : grouphom_compose psi phi == psi o phi. Proof. intros g; grouphom_reduce. exact (ap_compose phi psi g). Qed. Definition idmap_grouphom (G : ooGroup) : grouphom_idmap G == idmap. Proof. intros g; grouphom_reduce. exact (ap_idmap g). Qed. Definition grouphom_pp {G H} (phi : ooGroupHom G H) (g1 g2 : G) : phi (g1 @ g2) = phi g1 @ phi g2. Proof. grouphom_reduce. exact (ap_pp phi g1 g2). Qed. Definition grouphom_V {G H} (phi : ooGroupHom G H) (g : G) : phi g^ = (phi g)^. Proof. grouphom_reduce. exact (ap_V phi g). Qed. Definition grouphom_1 {G H} (phi : ooGroupHom G H) : phi 1 = 1. Proof. grouphom_reduce. reflexivity. Qed. Definition grouphom_pp_p {G H} (phi : ooGroupHom G H) (g1 g2 g3 : G) : grouphom_pp phi (g1 @ g2) g3 @ whiskerR (grouphom_pp phi g1 g2) (phi g3) @ concat_pp_p (phi g1) (phi g2) (phi g3) = ap phi (concat_pp_p g1 g2 g3) @ grouphom_pp phi g1 (g2 @ g3) @ whiskerL (phi g1) (grouphom_pp phi g2 g3). Proof. grouphom_reduce. Abort. (** ** Subgroups *) Section Subgroups. Context {G H : ooGroup} (incl : ooGroupHom H G) `{IsEmbedding incl}. (** A subgroup induces an equivalence relation on the ambient group, whose equivalence classes are called "cosets". *) Definition in_coset : G -> G -> Type := fun g1 g2 => hfiber incl (g1 @ g2^). Global Instance ishprop_in_coset : is_mere_relation G in_coset. Proof. exact _. Defined. Global Instance reflexive_coset : Reflexive in_coset. Proof. intros g. exact (1 ; grouphom_1 incl @ (concat_pV g)^). Defined. Global Instance symmetric_coset : Symmetric in_coset. Proof. intros g1 g2 [h p]. exists (h^). refine (grouphom_V incl h @ inverse2 p @ inv_pp _ _ @ whiskerR (inv_V _) _). Defined. Global Instance transitive_coset : Transitive in_coset. Proof. intros g1 g2 g3 [h1 p1] [h2 p2]. exists (h1 @ h2). refine (grouphom_pp incl h1 h2 @ (p1 @@ p2) @ concat_p_pp _ _ _ @ whiskerR (concat_pV_p _ _) _). Defined. (** Every coset is equivalent (as a type) to the subgroup itself. *) Definition equiv_coset_subgroup (g : G) : { g' : G & in_coset g g'} <~> H. Proof. simple refine (equiv_adjointify _ _ _ _). - intros [? [h ?]]; exact h. - intros h; exists (incl h^ @ g); exists h; simpl. abstract (rewrite inv_pp, grouphom_V, inv_V, concat_p_Vp; reflexivity). - intros h; reflexivity. - intros [g' [h p]]. apply path_sigma_hprop; simpl. refine ((grouphom_V incl h @@ 1) @ _). apply moveR_Vp, moveL_pM. exact (p^). Defined. Definition cosets := Quotient in_coset. End Subgroups. (** The wild category of oo-groups is induced by the wild category of pTypes *) Global Instance isgraph_oogroup : IsGraph ooGroup := Build_IsGraph _ ooGroupHom. Global Instance is01cat_oogroup : Is01Cat ooGroup := Build_Is01Cat _ _ grouphom_idmap (@grouphom_compose). Global Instance is2graph_oogroup : Is2Graph ooGroup := is2graph_induced classifying_space. Global Instance is1cat_oogroup : Is1Cat ooGroup := is1cat_induced classifying_space. (** ** 1-groups as oo-groups *) Definition group_to_oogroup : Group -> ooGroup := fun G => Build_ooGroup (pClassifyingSpace G) _. Global Instance is0functor_group_to_oogroup : Is0Functor group_to_oogroup. Proof. snrapply Build_Is0Functor. intros G H f. by rapply (fmap pClassifyingSpace). Defined. Global Instance is1functor_group_to_oogroup : Is1Functor group_to_oogroup. Proof. snrapply Build_Is1Functor; hnf; intros. 1: by rapply (fmap2 pClassifyingSpace). 1: by rapply (fmap_id pClassifyingSpace). by rapply (fmap_comp pClassifyingSpace). Defined. Coq-HoTT-9.0/theories/Analysis/000077500000000000000000000000001474641544500163435ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Analysis/Locator.v000066400000000000000000000646351474641544500201530ustar00rootroot00000000000000Require Import Basics DProp BoundedSearch Spaces.Finite.Fin ExcludedMiddle Classes.interfaces.abstract_algebra Classes.interfaces.orders Classes.interfaces.rationals Classes.interfaces.cauchy Classes.interfaces.archimedean Classes.interfaces.round Classes.interfaces.naturals Classes.implementations.peano_naturals Classes.orders.archimedean Classes.orders.dec_fields Classes.orders.lattices Classes.theory.apartness Classes.theory.rationals Classes.orders.fields Classes.theory.fields Classes.theory.dec_fields. Local Open Scope type_scope. Section locator. Context (Q : Type). Context `{Qrats : Rationals Q}. Context {Qdec_paths : DecidablePaths Q}. Context {Qtriv : TrivialApart Q}. Context `{!Trichotomy (<)}. Context (F : Type). Context `{Forderedfield : OrderedField F}. Context {Fabs : Abs F}. Context {Farchimedean : ArchimedeanProperty Q F}. Context {Fcomplete : IsComplete Q F}. Context {Qroundup : RoundUpStrict Q}. Context `{Funext} `{Univalence}. (* Assume we have enumerations of the rationals, and of pairs of ordered rationals. *) Context (Q_eq : nat <~> Q). Context (QQpos_eq : nat <~> Q * Qpos Q). Instance qinc : Cast Q F := rationals_to_field Q F. (* TODO The following two instances should probably come from the `Rationals` instance. *) Context (cast_pres_ordering : StrictlyOrderPreserving qinc) (qinc_strong_presving : IsSemiRingStrongPreserving qinc). Existing Instance cast_pres_ordering. Existing Instance qinc_strong_presving. (* Definition of a locator for a fixed real number. *) Definition locator (x : F) := forall q r : Q, q < r -> (' q < x) + (x < ' r). (* Alternative definition; see equivalence below *) Record locator' (x : F) := { locates_right : forall q r : Q, q < r -> DHProp ; locates_right_true : forall q r : Q, forall nu : q < r, locates_right q r nu -> ' q < x ; locates_right_false : forall q r : Q, forall nu : q < r, ~ locates_right q r nu -> x < ' r }. Arguments locates_right [x] _ [q] [r] _. Arguments locates_right_true [x] _ [q] [r] _. Arguments locates_right_false [x] _ [q] [r] _. Definition locates_left {x : F} (l : locator' x) {q r : Q} : q < r -> DHProp := fun nu => Build_DHProp (Build_HProp (~ (locates_right l nu))) _. Section classical. Context `{ExcludedMiddle}. Lemma all_reals_locators (x : F) : locator x. Proof. intros q r ltqr. case (LEM (' q < x)). - apply _. - exact inl. - intros notlt. apply inr. assert (ltqr' : ' q < ' r) by auto. exact (nlt_lt_trans notlt ltqr'). Qed. End classical. Section rational. Context (s : Q). Lemma locator_left : locator (' s). Proof. intros q r ltqr. destruct (trichotomy _ q s) as [ltqs|[eqqs|ltsq]]. - apply inl. apply (strictly_order_preserving _); assumption. - rewrite eqqs in ltqr. apply inr, (strictly_order_preserving _); assumption. - apply inr, (strictly_order_preserving _), (transitivity ltsq ltqr); assumption. Qed. Definition locator_second : locator (' s). Proof. intros q r ltqr. destruct (trichotomy _ s r) as [ltsr|[eqsr|ltrs]]. - apply inr, (strictly_order_preserving _); assumption. - rewrite <- eqsr in ltqr. apply inl, (strictly_order_preserving _); assumption. - apply inl, (strictly_order_preserving _), (transitivity ltqr ltrs). Qed. End rational. Section logic. Context {x : F}. Definition locator_locator' : locator x -> locator' x. Proof. intros l. refine (Build_locator' x (fun q r nu => Build_DHProp (Build_HProp (is_inl (l q r nu))) _) _ _). - intros q r nu. simpl. apply un_inl. - intros q r nu. simpl. destruct (l q r nu) as [ltqx|]. + simpl; intros f; destruct (f tt). + intros ?; assumption. Defined. Definition locator'_locator : locator' x -> locator x. Proof. intros l' q r nu. destruct (dec (locates_right l' nu)) as [yes|no]. - apply inl. exact (locates_right_true l' nu yes). - apply inr. exact (locates_right_false l' nu no). Defined. End logic. Section logic2. Context {x : F}. Coercion locator_locator' : locator >-> locator'. Definition locator_locator'_locator (l : locator x) : locator'_locator (locator_locator' l) = l. Proof. apply path_forall; intros q. apply path_forall; intros r. apply path_forall; intros nu. unfold locator'_locator, locator_locator'. simpl. destruct (l q r nu); auto. Qed. Local Definition locsig : _ <~> locator' x := ltac:(issig). Lemma locator'_locator_locator' (l' : locator' x) : locator_locator' (locator'_locator l') = l'. Proof. enough (p : locsig ^-1 (locator_locator' (locator'_locator l')) = locsig ^-1 l'). - refine (equiv_inj (locsig ^-1) p). - unfold locsig; simpl. destruct l'; unfold locator'_locator, locator_locator'; simpl. apply path_sigma_hprop; simpl. apply path_forall; intro q; apply path_forall; intro r; apply path_arrow; intro nu. apply equiv_path_dhprop; simpl. rewrite (path_dec (locates_right0 q r nu)). destruct (dec (locates_right0 q r nu)); auto. Qed. Definition equiv_locator_locator' : locator x <~> locator' x := equiv_adjointify locator_locator' locator'_locator locator'_locator_locator' locator_locator'_locator. Lemma nltqx_locates_left {q r : Q} (l' : locator' x) (ltqr : q < r) : ~ (' q < x) -> locates_left l' ltqr. Proof. assert (f := locates_right_true l' ltqr). exact (not_contrapositive f). Qed. Lemma ltxq_locates_left {q r : Q} (l' : locator' x) (ltqr : q < r) : x < ' q -> locates_left l' ltqr. Proof. intros ltxq. apply nltqx_locates_left. apply lt_flip; assumption. Qed. Lemma nltxr_locates_right {q r : Q} (l' : locator' x) (ltqr : q < r) : ~ (x < ' r) -> locates_right l' ltqr. Proof. intros nltxr. apply stable. assert (f := locates_right_false l' ltqr). exact (not_contrapositive f nltxr). Qed. Lemma ltrx_locates_right {q r : Q} (l' : locator' x) (ltqr : q < r) : 'r < x -> locates_right l' ltqr. Proof. intros ltrx. apply nltxr_locates_right. apply lt_flip; assumption. Qed. End logic2. Local Definition ltQnegQ (q : Q) (eps : Qpos Q) : q - 'eps < q. Proof. apply (pos_minus_lt_compat_r q ('eps)), eps. Qed. Local Open Scope mc_scope. Local Definition ltQposQ (q : Q) (eps : Qpos Q) : q < q + 'eps. Proof. apply (pos_plus_lt_compat_r q ('eps)), eps. Qed. Section bounds. (* Given a real with a locator, we can find (integer) bounds. *) Context {x : F} (l : locator x). Local Definition ltN1 (q : Q) : q - 1 < q := ltQnegQ q 1. Local Definition P_lower (q : Q) : Type := locates_right l (ltN1 q). Definition P_lower_prop {k} : IsHProp (P_lower k). Proof. apply _. Qed. Local Definition ltxN1 : x - 1 < x := (fst (pos_minus_lt_compat_r x 1) lt_0_1). Local Definition P_lower_inhab : hexists (fun q => P_lower q). Proof. assert (hqlt : hexists (fun q => ' q < x)). { assert (hex := archimedean_property Q F (x-1) x ltxN1). refine (Trunc_rec _ hex); intros hex'. apply tr. destruct hex' as [q [ltx1q ltqx]]; exists q; assumption. } refine (Trunc_rec _ hqlt); intros hqlt'. induction hqlt' as [q lt]. apply tr. exists q. unfold P_lower. apply ltrx_locates_right; assumption. Qed. Definition lower_bound : {q : Q | ' q < x}. Proof. assert (qP_lower : {q : Q | P_lower q}) by refine (minimal_n_alt_type Q Q_eq P_lower _ P_lower_inhab). destruct qP_lower as [q Pq]. exists (q - 1). unfold P_lower in Pq. simpl in *. apply (un_inl _ Pq). Qed. Local Definition lt1N (r : Q) : r < r + 1 := ltQposQ r 1. Local Definition P_upper (r : Q) : DHProp := locates_left l (lt1N r). Definition P_upper_prop {k} : IsHProp (P_upper k). Proof. apply _. Qed. Local Definition ltx1N : x < x + 1 := (fst (pos_plus_lt_compat_r x 1) lt_0_1). Local Definition P_upper_inhab : hexists (fun r => P_upper r). Proof. assert (hqlt : hexists (fun r => x < ' r)). { assert (hex := archimedean_property Q F x (x+1) ltx1N). refine (Trunc_rec _ hex); intros hex'. apply tr. destruct hex' as [r [ltxr ltrx1]]; exists r; assumption. } refine (Trunc_rec _ hqlt); intros hqlt'. induction hqlt' as [r lt]. apply tr. exists r. unfold P_upper. apply ltxq_locates_left; assumption. Qed. Definition upper_bound : {r : Q | x < ' r}. Proof. assert (rP_upper : {r : Q | P_upper r}) by refine (minimal_n_alt_type Q Q_eq P_upper _ P_upper_inhab). destruct rP_upper as [r Pr]. exists (r + 1). unfold P_upper in Pr. simpl in *. destruct (l r (r + 1) (lt1N r)). - simpl in Pr. destruct (Pr tt). - assumption. Qed. Instance inc_N_Q : Cast nat Q := naturals_to_semiring nat Q. Instance inc_fin_N {n} : Cast (Fin n) nat := fin_to_nat. Lemma tight_bound (epsilon : Qpos Q) : {u : Q | ' u < x < ' (u + ' epsilon)}. Proof. destruct lower_bound as [q ltqx] , upper_bound as [r ltxr] , (round_up_strict Q ((3/'epsilon)*(r-q))) as [n lt3rqn]. assert (lt0 : 0 < 'epsilon / 3). { apply pos_mult. - apply epsilon. - apply pos_dec_recip_compat, lt_0_3. } assert (lt0' : 0 < 3 / ' epsilon). { apply pos_mult. - apply lt_0_3. - apply pos_dec_recip_compat, epsilon. } assert (ap30 : (3 : Q) <> 0) by apply lt_ne_flip, lt_0_3. clear - l q ltqx r ltxr n lt3rqn lt0' ap30 Qtriv Qdec_paths H cast_pres_ordering. assert (ltn3eps : r < q + ' n * ' epsilon / 3). { rewrite (commutativity q (' n * ' epsilon / 3)). apply flip_lt_minus_l. apply (pos_mult_reflect_r (3 / ' epsilon) lt0'). rewrite (commutativity (r-q) (3 / ' epsilon)). rewrite <- (associativity ('n) ('epsilon) (/3)). rewrite <- (associativity ('n) (' epsilon / 3) (3 / ' epsilon)). rewrite <- (associativity ('epsilon) (/3) (3/'epsilon)). rewrite (associativity (/3) 3 (/'epsilon)). rewrite (commutativity (/3) 3). rewrite (dec_recip_inverse 3 ap30). rewrite mult_1_l. assert (apepsilon0 : 'epsilon <> 0) by apply lt_ne_flip, epsilon. rewrite (dec_recip_inverse ('epsilon) apepsilon0). rewrite mult_1_r. assumption. } set (grid (k : Fin n.+3) := q + (' (' k) - 1)*('epsilon/3) : Q). assert (lt_grid : forall k : Fin _, grid (fin_incl k) < grid (fsucc k)). { intros k. unfold grid. change (' fin_incl k) with (fin_to_nat (fin_incl k)); rewrite path_nat_fin_incl. change (' fsucc k) with (fin_to_nat (fsucc k)); rewrite path_nat_fsucc. assert (' (S (' k)) = (' (' k) + 1)) as ->. { rewrite S_nat_plus_1. rewrite (preserves_plus (' k) 1). rewrite preserves_1. reflexivity. } assert (' (' k) + 1 - 1 = ' (' k) - 1 + 1) as ->. { rewrite <- (associativity _ 1 (-1)). rewrite (commutativity 1 (-1)). rewrite (associativity _ (-1) 1). reflexivity. } assert (lt1 : ' (' k) - 1 < ' (' k) - 1 + 1) by apply pos_plus_lt_compat_r, lt_0_1. assert (lt2 : (' (' k) - 1) * (' epsilon / 3) < (' (' k) - 1 + 1) * (' epsilon / 3)). { nrefine (pos_mult_lt_r ('epsilon/3) _ (' (' k) - 1) (' (' k) - 1 + 1) _); try apply _. apply lt1. } apply pseudo_srorder_plus. exact lt2. } set (P k := locates_right l (lt_grid k)). assert (left_true : P fin_zero). { apply ltrx_locates_right. unfold grid. change (' fsucc fin_zero) with (fin_to_nat (@fsucc (S n) fin_zero)). rewrite path_nat_fsucc, path_nat_fin_zero. rewrite (@preserves_1 nat Q _ _ _ _ _ _ _ _ _ _). rewrite plus_negate_r. rewrite mult_0_l. rewrite plus_0_r. assumption. } assert (right_false : ~ P fin_last). { apply ltxq_locates_left. unfold grid. change (' fin_incl fin_last) with (fin_to_nat (@fin_incl (S (S n)) fin_last)). rewrite path_nat_fin_incl, path_nat_fin_last. rewrite S_nat_plus_1. rewrite (preserves_plus n 1). rewrite (@preserves_1 nat Q _ _ _ _ _ _ _ _ _ _). rewrite <- (associativity (' n) 1 (-1)). rewrite plus_negate_r. rewrite plus_0_r. rewrite (associativity ('n) ('epsilon) (/3)). transitivity ('r). - exact ltxr. - apply strictly_order_preserving; try trivial. } destruct (sperners_lemma_1d P left_true right_false) as [u [Pltux Pltxueps]]. exists (grid (fin_incl (fin_incl u))). unfold P in Pltux, Pltxueps. split. - apply (locates_right_true l (lt_grid (fin_incl u)) Pltux). - clear - Pltxueps Qtriv Qdec_paths ap30 cast_pres_ordering. set (ltxbla := locates_right_false l (lt_grid (fsucc u)) Pltxueps). unfold grid in *. change (' fin_incl (fin_incl u)) with (fin_to_nat (fin_incl (fin_incl u))). rewrite path_nat_fin_incl, path_nat_fin_incl. change (' fsucc (fsucc u)) with (fin_to_nat (fsucc (fsucc u))) in ltxbla. rewrite path_nat_fsucc, path_nat_fsucc in ltxbla. rewrite S_nat_plus_1, S_nat_plus_1 in ltxbla. rewrite (preserves_plus (fin_to_nat u + 1) 1) in ltxbla. rewrite (preserves_plus (fin_to_nat u) 1) in ltxbla. rewrite preserves_1 in ltxbla. rewrite <- (associativity (' fin_to_nat u) 1 1) in ltxbla. rewrite <- (associativity (' fin_to_nat u) 2 (-1)) in ltxbla. rewrite (commutativity 2 (-1)) in ltxbla. rewrite (associativity (' fin_to_nat u) (-1) 2) in ltxbla. rewrite plus_mult_distr_r in ltxbla. rewrite (associativity q ((' fin_to_nat u - 1) * (' epsilon / 3)) (2 * (' epsilon / 3))) in ltxbla. refine (transitivity ltxbla _). apply strictly_order_preserving; try apply _. apply pseudo_srorder_plus. rewrite (associativity 2 ('epsilon) (/3)). rewrite (commutativity 2 ('epsilon)). rewrite <- (mult_1_r ('epsilon)). rewrite <- (associativity ('epsilon) 1 2). rewrite (mult_1_l 2). rewrite <- (associativity ('epsilon) 2 (/3)). apply pos_mult_lt_l. + apply epsilon. + nrefine (pos_mult_reflect_r (3 : Q) lt_0_3 _ _ _); try apply _. rewrite <- (associativity 2 (/3) 3). rewrite (commutativity (/3) 3). rewrite (dec_recip_inverse (3 : Q) ap30). rewrite (mult_1_r 2). rewrite (mult_1_l 3). exact lt_2_3. Qed. End bounds. Section arch_struct. Context {x y : F} (l : locator x) (m : locator y) (ltxy : x < y). Local Definition P (qeps' : Q * Qpos Q) : Type := match qeps' with | (q' , eps') => (prod (locates_left l (ltQnegQ q' eps')) (locates_right m (ltQposQ q' eps'))) end. Local Definition P_isHProp qeps' : IsHProp (P qeps'). Proof. destruct qeps' as [q eps']. apply istrunc_prod. Qed. Local Definition P_dec qeps' : Decidable (P qeps'). Proof. destruct qeps' as [q eps']. unfold P. apply _. Qed. Local Definition P_inhab : hexists P. Proof. assert (hs := (archimedean_property Q F x y ltxy)). refine (Trunc_ind _ _ hs); intros [s [ltxs ltsy]]. assert (ht := (archimedean_property Q F ('s) y ltsy)). refine (Trunc_ind _ _ ht); intros [t [ltst' ltty]]. set (q := (t + s) / 2). assert (ltst : s < t). { Existing Instance full_pseudo_order_reflecting. refine (strictly_order_reflecting _ _ _ ltst'). } set (epsilon := (Qpos_diff s t ltst) / 2). apply tr. exists (q, epsilon). unfold P; split. - apply ltxq_locates_left. assert (q - ' epsilon = s) as ->. { unfold q; cbn. rewrite <- path_avg_split_diff_l. rewrite <- (plus_assoc s ((t-s)/2) (-((t-s)/2))). rewrite plus_negate_r. rewrite plus_0_r. reflexivity. } assumption. - apply ltrx_locates_right. assert (q + ' epsilon = t) as ->. { unfold q; cbn. rewrite <- path_avg_split_diff_r. rewrite <- (plus_assoc t (-((t-s)/2)) ((t-s)/2)). rewrite plus_negate_l. rewrite plus_0_r. reflexivity. } assumption. Qed. Definition archimedean_structure : {q : Q | x < 'q < y}. Proof. assert (R : sig P). { apply minimal_n_alt_type. - apply QQpos_eq. - apply P_dec. - apply P_inhab. } unfold P in R. destruct R as [[q eps] [lleft mright]]. exists q; split. - nrefine (locates_right_false l _ lleft). - nrefine (locates_right_true m _ mright). Qed. End arch_struct. Section unary_ops. Context {x : F} (l : locator x). Definition locator_minus : locator (-x). Proof. intros q r ltqr. assert (ltnrnq := snd (flip_lt_negate q r) ltqr : -r < -q). destruct (l _ _ ltnrnq) as [ltnrx|ltxnq]. - apply inr. apply char_minus_left. rewrite <- preserves_negate. assumption. - apply inl. apply char_minus_right. rewrite <- preserves_negate. assumption. Qed. Section recip_pos. Context (xpos : 0 < x). Local Definition recip_nu := positive_apart_zero x xpos. Definition locator_recip_pos : locator (// (x ; recip_nu)). Proof. assert (recippos : 0 < // (x ; recip_nu)) by apply pos_recip_compat. intros q r ltqr. destruct (trichotomy _ q 0) as [qneg|[qzero|qpos]]. + apply inl. refine (transitivity _ _). * apply (strictly_order_preserving _). exact qneg. * rewrite preserves_0; assumption. + apply inl. rewrite qzero, preserves_0; assumption. + assert (qap0 : q ≶ 0) by apply (pseudo_order_lt_apart_flip _ _ qpos). assert (rap0 : r ≶ 0). { refine (pseudo_order_lt_apart_flip _ _ _). apply (transitivity qpos ltqr). } assert (ltrrrq : / r < / q) by (apply flip_lt_dec_recip; assumption). destruct (l (/r) (/q) ltrrrq) as [ltrrx|ltxrq]. * apply inr. assert (rpos : 0 < r) by (transitivity q; assumption). assert (rpos' : 0 < ' r). { rewrite <- (@preserves_0 Q F _ _ _ _ _ _ _ _ _ _). apply strictly_order_preserving; try apply _; assumption. } rewrite (dec_recip_to_recip r (positive_apart_zero ('r) rpos')) in ltrrx. assert (ltxrr := flip_lt_recip_l x ('r) rpos' ltrrx). cbn in ltxrr. rewrite (recip_irrelevant x (positive_apart_zero x (transitivity (pos_recip_compat (' r) rpos') ltrrx)) recip_nu) in ltxrr. exact ltxrr. * apply inl. assert (qpos' : 0 < ' q). { rewrite <- (@preserves_0 Q F _ _ _ _ _ _ _ _ _ _). apply strictly_order_preserving; try apply _; assumption. } rewrite (dec_recip_to_recip q (positive_apart_zero ('q) qpos')) in ltxrq. assert (ltrqx := flip_lt_recip_r ('q) x qpos' xpos ltxrq). rewrite (recip_irrelevant x (positive_apart_zero x xpos) recip_nu) in ltrqx. exact ltrqx. Qed. End recip_pos. End unary_ops. Section recip_neg. Context {x : F} (l : locator x) (xneg : x < 0). Local Definition recip_neg_nu := negative_apart_zero x xneg. Definition locator_recip_neg : locator (// (x ; recip_neg_nu)). Proof. assert (negxpos : 0 < (-x)) by (apply flip_neg_negate; assumption). assert (l' := locator_minus (locator_recip_pos (locator_minus l) negxpos)). rewrite (recip_negate (-x)) in l'. unfold negate_apart in l'. rewrite (recip_proper_alt (- - x) x (apart_negate (- x) (positive_apart_zero (- x) negxpos)) recip_neg_nu) in l'. - assumption. - apply negate_involutive. Qed. End recip_neg. Section unary_ops2. Context {x : F} (l : locator x) (nu : x ≶ 0). Definition locator_recip : locator (// (x ; nu)). Proof. destruct (fst (apart_iff_total_lt x 0) nu) as [xneg|xpos]. - set (l' := locator_recip_neg l xneg). rewrite (recip_proper_alt x x (negative_apart_zero x xneg) nu) in l'; try reflexivity; exact l'. - set (l' := locator_recip_pos l xpos). rewrite (recip_proper_alt x x (positive_apart_zero x xpos) nu) in l'; try reflexivity; exact l'. Qed. End unary_ops2. Section binary_ops. Context {x y : F} (l : locator x) (m : locator y). (** TODO the following two should be proven in Classes/orders/archimedean.v *) Context (char_plus_left : forall (q : Q) (x y : F), ' q < x + y <-> hexists (fun s : Q => (' s < x) /\ (' (q - s) < y))) (char_plus_right : forall (r : Q) (x y : F), x + y < ' r <-> hexists (fun t : Q => (x < ' t) /\ (y < ' (r - t)))). Definition locator_plus : locator (x + y). Proof. intros q r ltqr. set (epsilon := (Qpos_diff q r ltqr) / 2). assert (q+'epsilon=r-'epsilon) by (rewrite path_avg_split_diff_l, path_avg_split_diff_r; reflexivity). destruct (tight_bound m epsilon) as [u [ltuy ltyuepsilon]]. set (s := q-u). assert (qsltx : 'q-'s. { change ((r - q) / 2) with ('epsilon). rewrite negate_plus_distr. rewrite <- negate_swap_l. rewrite (plus_comm (-q) u). rewrite (plus_assoc r (u-q) (-'epsilon)). rewrite (plus_assoc r u (-q)). rewrite (plus_comm r u). rewrite <- (plus_assoc u r (-q)). rewrite <- (plus_assoc u (r-q) (-'epsilon)). rewrite (plus_comm r (-q)). rewrite <- (plus_assoc (-q) r (-'epsilon)). rewrite path_avg_split_diff_r. rewrite <- path_avg_split_diff_l. rewrite (plus_assoc (-q) q ((r-q)/2)). rewrite (plus_negate_l q). rewrite (plus_0_l _). reflexivity. } assumption. Qed. (* TODO construct locators for multiplications. *) Lemma locator_times : locator (x * y). Proof. Abort. Lemma locator_meet : locator (meet x y). Proof. intros q r ltqr. destruct (l q r ltqr, m q r ltqr) as [[ltqx|ltxr] [ltqy|ltyr]]. - apply inl, meet_lt_l; assumption. - apply inr, meet_lt_r_r; assumption. - apply inr, meet_lt_r_l; assumption. - apply inr, meet_lt_r_r; assumption. Qed. Lemma locator_join : locator (join x y). Proof. intros q r ltqr. destruct (l q r ltqr, m q r ltqr) as [[ltqx|ltxr] [ltqy|ltyr]]. - apply inl, join_lt_l_l; assumption. - apply inl, join_lt_l_l; assumption. - apply inl, join_lt_l_r; assumption. - apply inr, join_lt_r; assumption. Qed. End binary_ops. Section limit. Context {xs : nat -> F}. Context {M} {M_ismod : CauchyModulus Q F xs M}. Context (ls : forall n, locator (xs n)). Lemma locator_limit {l} : IsLimit _ _ xs l -> locator l. Proof. intros islim. intros q r ltqr. set (epsilon := (Qpos_diff q r ltqr) / 3). (* TODO we are doing trisection so we have the inequality: *) assert (ltqepsreps : q + ' epsilon < r - ' epsilon). { apply (strictly_order_reflecting (+'epsilon)). rewrite <- (plus_assoc r (-'epsilon) ('epsilon)). rewrite plus_negate_l. rewrite plus_0_r. rewrite <- (plus_assoc q ('epsilon) ('epsilon)). apply (strictly_order_reflecting ((-q)+)). rewrite (plus_assoc (-q) q _). rewrite plus_negate_l, plus_0_l. rewrite (plus_comm (-q) r). rewrite <- (mult_1_r ('epsilon)). rewrite <- plus_mult_distr_l. unfold epsilon, cast, Qpos_diff; cbn. rewrite <- (mult_assoc (r-q) (/3) 2). pattern (r-q) at 2. rewrite <- (mult_1_r (r-q)). assert (rqpos : 0 < r-q) by apply (Qpos_diff q r ltqr). apply (strictly_order_preserving ((r-q)*.)). apply (strictly_order_reflecting (3*.)). rewrite (mult_assoc 3 (/3) 2). rewrite (dec_recip_inverse 3). - rewrite mult_1_r, mult_1_l. exact lt_2_3. - apply apart_ne, positive_apart_zero, lt_0_3. } destruct (ls (M (epsilon / 2)) (q + ' epsilon) (r - ' epsilon) ltqepsreps) as [ltqepsxs|ltxsreps]. + apply inl. rewrite preserves_plus in ltqepsxs. assert (ltqxseps : ' q < xs (M (epsilon / 2)) - ' (' epsilon)) by (apply flip_lt_minus_r; assumption). refine (transitivity ltqxseps _). apply (modulus_close_limit _ _ _ _ _). + apply inr. rewrite (preserves_plus r (-'epsilon)) in ltxsreps. rewrite (preserves_negate ('epsilon)) in ltxsreps. assert (ltxsepsr : xs (M (epsilon / 2)) + ' (' epsilon) < ' r) by (apply flip_lt_minus_r; assumption). refine (transitivity _ ltxsepsr). apply (modulus_close_limit _ _ _ _ _). Qed. End limit. End locator. Coq-HoTT-9.0/theories/Axioms/000077500000000000000000000000001474641544500160205ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Axioms/Funext.v000066400000000000000000000004501474641544500174570ustar00rootroot00000000000000Require Import Basics.Overture. (** To assume the Funext axiom outright, import this file. (Doing this instead of simply positing Funext directly avoids creating multiple witnesses for the axiom in different developments.) *) Axiom funext_axiom : Funext. Global Existing Instance funext_axiom. Coq-HoTT-9.0/theories/Axioms/PropResizing.v000066400000000000000000000005061474641544500206430ustar00rootroot00000000000000Require Import Basics.Overture. (** To assume the PropResizing axiom outright, import this file. (Doing this instead of simply positing PropResizing directly avoids creating multiple witnesses for the axiom in different developments.) *) Axiom propresizing_axiom : PropResizing. Global Existing Instance propresizing_axiom. Coq-HoTT-9.0/theories/Axioms/Univalence.v000066400000000000000000000004731474641544500203040ustar00rootroot00000000000000Require Import Types.Universe. (** To assume the Univalence axiom outright, import this file. (Doing this instead of simply positing Univalence directly avoids creating multiple witnesses for the axiom in different developments.) *) Axiom univalence_axiom : Univalence. Global Existing Instance univalence_axiom. Coq-HoTT-9.0/theories/Basics.v000066400000000000000000000006341474641544500161560ustar00rootroot00000000000000Require Export Basics.Overture. Require Export Basics.PathGroupoids. Require Export Basics.Contractible. Require Export Basics.Equivalences. Require Export Basics.Trunc. Require Export Basics.Decidable. Require Export Basics.Utf8. Require Export Basics.Notations. Require Export Basics.Tactics. Require Export Basics.Classes. Require Export Basics.Iff. Require Export Basics.Nat. Require Export Basics.Numeral. Coq-HoTT-9.0/theories/Basics/000077500000000000000000000000001474641544500157645ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Basics/Classes.v000066400000000000000000000022321474641544500175470ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. (** * Classes *) (** ** Injective Functions *) Class IsInjective {A B : Type} (f : A -> B) := injective : forall x y, f x = f y -> x = y. Arguments injective {A B} f {_} _ _. Definition neq_isinj {A B : Type} (f : A -> B) `{!IsInjective f} : forall x y, x <> y -> f x <> f y. Proof. intros x y np q. apply np, (injective f). exact q. Defined. Global Instance isinj_idmap A : @IsInjective A A idmap := fun x y => idmap. #[export] Hint Unfold IsInjective : typeclass_instances. Definition isinj_compose {A B C f g} `{IsInjective B C g} `{IsInjective A B f} : IsInjective (g o f). Proof. intros x y p. by apply (injective f), (injective g). Defined. #[export] Hint Immediate isinj_compose : typeclass_instances. Definition isinj_cancelL {A B C : Type} (f : A -> B) (g : B -> C) `{!IsInjective (g o f)} : IsInjective f. Proof. intros x y p. apply (injective (g o f)). exact (ap g p). Defined. (** ** Antisymmetric Relations *) Class AntiSymmetric {A : Type} (R : A -> A -> Type) : Type := antisymmetry : forall x y, R x y -> R y x -> x = y. Arguments antisymmetry {A} R {AntiSymmetric} x y _ _. Coq-HoTT-9.0/theories/Basics/Contractible.v000066400000000000000000000111301474641544500205600ustar00rootroot00000000000000(** * Contractibility *) Require Import Overture PathGroupoids. Local Open Scope path_scope. (** Naming convention: we consistently abbreviate "contractible" as "contr". A theorem about a space [X] being contractible (which will usually be an instance of the typeclass [Contr]) is called [contr_X]. *) (** Allow ourselves to implicitly generalize over types [A] and [B], and a function [f]. *) Generalizable Variables A B f. (** If a space is contractible, then any two points in it are connected by a path in a canonical way. *) Definition path_contr `{Contr A} (x y : A) : x = y := (contr x)^ @ (contr y). (** Any space of paths in a contractible space is contractible. *) Global Instance contr_paths_contr `{Contr A} (x y : A) : Contr (x = y) | 10000. Proof. apply (Build_Contr _ (path_contr x y)). intro r; destruct r; apply concat_Vp. Defined. (** It follows that any two parallel paths in a contractible space are homotopic, which is just the principle UIP. *) Definition path2_contr `{Contr A} {x y : A} (p q : x = y) : p = q := path_contr p q. (** Also, the total space of any based path space is contractible. We define the [contr] fields as separate definitions, so that we can give them [simpl nomatch] annotations. *) Definition path_basedpaths {X : Type} {x y : X} (p : x = y) : (x;1) = (y;p) :> {z:X & x=z}. Proof. destruct p; reflexivity. Defined. Arguments path_basedpaths {X x y} p : simpl nomatch. Global Instance contr_basedpaths {X : Type} (x : X) : Contr {y : X & x = y} | 100. Proof. apply (Build_Contr _ (x;1)). intros [y p]; apply path_basedpaths. Defined. (* Sometimes we end up with a sigma of a one-sided path type that's not eta-expanded, which Coq doesn't seem able to match with the previous instance. *) Global Instance contr_basedpaths_etashort {X : Type} (x : X) : Contr (sig (@paths X x)) | 100 := contr_basedpaths x. (** Based path types with the second variable fixed. *) Definition path_basedpaths' {X : Type} {x y : X} (p : y = x) : (x;1) = (y;p) :> {z:X & z=x}. Proof. destruct p; reflexivity. Defined. Arguments path_basedpaths' {X x y} p : simpl nomatch. Global Instance contr_basedpaths' {X : Type} (x : X) : Contr {y : X & y = x} | 100. Proof. refine (Build_Contr _ (x;1) _). intros [y p]; apply path_basedpaths'. Defined. (** Some useful computation laws for based path spaces *) Definition ap_pr1_path_contr_basedpaths {X : Type} {x y z : X} (p : x = y) (q : x = z) : ap pr1 (path_contr ((y;p) : {y':X & x = y'}) (z;q)) = p^ @ q. Proof. destruct p, q; reflexivity. Defined. Definition ap_pr1_path_contr_basedpaths' {X : Type} {x y z : X} (p : y = x) (q : z = x) : ap pr1 (path_contr ((y;p) : {y':X & y' = x}) (z;q)) = p @ q^. Proof. destruct p, q; reflexivity. Defined. Definition ap_pr1_path_basedpaths {X : Type} {x y : X} (p : x = y) : ap pr1 (path_basedpaths p) = p. Proof. destruct p; reflexivity. Defined. Definition ap_pr1_path_basedpaths' {X : Type} {x y : X} (p : y = x) : ap pr1 (path_basedpaths' p) = p^. Proof. destruct p; reflexivity. Defined. (** If the domain is contractible, the function is propositionally constant. *) Definition contr_dom_equiv {A B} (f : A -> B) `{Contr A} : forall x y : A, f x = f y := fun x y => ap f ((contr x)^ @ contr y). (** Any retract of a contractible type is contractible *) Definition contr_retract {X Y : Type} `{Contr X} (r : X -> Y) (s : Y -> X) (h : forall y, r (s y) = y) : Contr Y := Build_Contr _ (r (center X)) (fun y => (ap r (contr _)) @ h _). (** Sometimes the easiest way to prove that a type is contractible doesn't produce the definitionally-simplest center. (In particular, this can affect performance, as Coq spends a long time tracing through long proofs of contractibility to find the center.) So we give a way to modify the center. *) Definition contr_change_center {A : Type} (a : A) `{Contr A} : Contr A. Proof. apply (Build_Contr _ a). intros; apply path_contr. Defined. (** The automatically generated induction principle for [IsTrunc_internal] produces two goals, so we define a custom induction principle for [Contr] that only produces the expected goal. *) Definition Contr_ind@{u v|} (A : Type@{u}) (P : Contr A -> Type@{v}) (H : forall (center : A) (contr : forall y, center = y), P (Build_Contr A center contr)) (C : Contr A) : P C := match C as C0 in IsTrunc n _ return (match n as n0 return IsTrunc n0 _ -> Type@{v} with | minus_two => fun c0 => P c0 | trunc_S k => fun _ => Unit end C0) with | Build_Contr center contr => H center contr | istrunc_S _ _ => tt end. Coq-HoTT-9.0/theories/Basics/Decidable.v000066400000000000000000000220441474641544500200110ustar00rootroot00000000000000Require Import Basics.Overture Basics.PathGroupoids Basics.Trunc Basics.Tactics Basics.Iff. Local Open Scope trunc_scope. Local Open Scope path_scope. (** * Decidability *) (** ** Definitions *) (* NB: This has to come after our definition of [not] (which is in [Overture]), so that it refers to our [not] rather than the one in [Coq.Logic]. *) Class Decidable (A : Type) := dec : A + (~ A). Arguments dec A {_}. (** The [decide_type] and [decide] tactic allow to automatically prove decidable claims using previously written decision procedures that compute. *) Ltac decide_type A := let K := (eval hnf in (dec A)) in match K with | inl ?Z => exact Z | inr ?Z => exact Z end. Ltac decide := multimatch goal with | [|- ?A] => decide_type A | [|- ~ ?A] => decide_type A end. Definition decidable_true {A : Type} (a : A) (P : forall (p : Decidable A), Type) (p : forall x, P (inl x)) : forall p, P p. Proof. intros [x|n]. - apply p. - contradiction n. Defined. (** Replace a term [p] of the form [Decidable A] with [inl x] if we have a term [a : A] showing that [A] is true. *) Ltac decidable_true p a := generalize p; rapply (decidable_true a); try intro. Definition decidable_false {A : Type} (n : not A) (P : forall (p : Decidable A), Type) (p : forall n', P (inr n')) : forall p, P p. Proof. intros [x|n']. - contradiction n. - apply p. Defined. (** Replace a term [p] of the form [Decidable A] with [inr na] if we have a term [n : not A] showing that [A] is false. *) Ltac decidable_false p n := generalize p; rapply (decidable_false n); try intro. Class DecidablePaths (A : Type) := dec_paths : forall (x y : A), Decidable (x = y). Global Existing Instance dec_paths. Class Stable P := stable : ~~P -> P. (** We always have a map in the other direction. *) Definition not_not_unit {P : Type} : P -> ~~P := fun x np => np x. Global Instance ishprop_stable_hprop `{Funext} P `{IsHProp P} : IsHProp (Stable P) := istrunc_forall. Global Instance stable_decidable P `{Decidable P} : Stable P. Proof. intros dn. (* [dec P] either solves the goal or contradicts [dn]. *) by destruct (dec P). Defined. Global Instance stable_negation P : Stable (~ P). Proof. intros nnnp p. exact (nnnp (not_not_unit p)). Defined. Definition iff_stable P `(Stable P) : ~~P <-> P. Proof. split. - apply stable. - exact not_not_unit. Defined. Definition stable_iff {A B} (f : A <-> B) : Stable A -> Stable B. Proof. intros stableA nnb. destruct f as [f finv]. exact (f (stableA (fun na => nnb (fun b => na (finv b))))). Defined. Definition stable_equiv' {A B} (f : A <~> B) : Stable A -> Stable B := stable_iff f. Definition stable_equiv {A B} (f : A -> B) `{!IsEquiv f} : Stable A -> Stable B := stable_equiv' (Build_Equiv _ _ f _). (** Because [vm_compute] evaluates terms in [PROP] eagerly and does not remove dead code we need the decide_rel hack. Suppose we have [(x = y) =def (f x = f y)], now: bool_decide (x = y) -> bool_decide (f x = f y) -> ... As we see, the dead code [f x] and [f y] is actually evaluated, which is of course an utter waste. Therefore we introduce decide_rel and bool_decide_rel. bool_decide_rel (=) x y -> bool_decide_rel (fun a b => f a = f b) x y -> ... Now the definition of equality remains under a lambda and our problem does not occur anymore! *) Definition decide_rel {A B} (R : A -> B -> Type) {dec : forall x y, Decidable (R x y)} (x : A) (y : B) : Decidable (R x y) := dec x y. (** ** Decidable hprops *) (** Contractible types are decidable. *) Global Instance decidable_contr X `{Contr X} : Decidable X := inl (center X). (** Thus, hprops have decidable equality. *) Global Instance decidablepaths_hprop X `{IsHProp X} : DecidablePaths X := fun x y => dec (x = y). (** Empty types are trivial. *) Global Instance decidable_empty : Decidable Empty := inr idmap. (** ** Transfer along equivalences *) Definition decidable_iff {A B} (f : A <-> B) : Decidable A -> Decidable B. Proof. intros [a|na]. - exact (inl (fst f a)). - exact (inr (fun b => na (snd f b))). Defined. Definition decidable_equiv' (A : Type) {B : Type} (f : A <~> B) : Decidable A -> Decidable B := decidable_iff f. Definition decidable_equiv (A : Type) {B : Type} (f : A -> B) `{!IsEquiv f} : Decidable A -> Decidable B := decidable_equiv' _ (Build_Equiv _ _ f _). Definition decidablepaths_equiv (A : Type) {B : Type} (f : A -> B) `{IsEquiv A B f} : DecidablePaths A -> DecidablePaths B. Proof. intros d x y. destruct (d (f^-1 x) (f^-1 y)) as [e|ne]. - apply inl. exact ((eisretr f x)^ @ ap f e @ eisretr f y). - apply inr; intros p. apply ne, ap, p. Defined. Definition decidablepaths_equiv' (A : Type) {B : Type} (f : A <~> B) : DecidablePaths A -> DecidablePaths B := decidablepaths_equiv A f. (** ** Hedberg's theorem: any type with decidable equality is a set. *) (** A weakly constant function is one all of whose values are equal (in a specified way). *) Class WeaklyConstant {A B} (f : A -> B) := wconst : forall x y, f x = f y. (** Any map that factors through an hprop is weakly constant. *) Definition wconst_through_hprop {A B P} `{IsHProp P} (f : A -> P) (g : P -> B) : WeaklyConstant (g o f). Proof. intros x y; apply (ap g), path_ishprop. Defined. (** A type is collapsible if it admits a weakly constant endomap. *) Class Collapsible (A : Type) := { collapse : A -> A ; wconst_collapse : WeaklyConstant collapse }. Global Existing Instance wconst_collapse. Class PathCollapsible (A : Type) := path_coll : forall (x y : A), Collapsible (x = y). Global Existing Instance path_coll. Global Instance collapsible_decidable (A : Type) `{Decidable A} : Collapsible A. Proof. destruct (dec A) as [a | na]. - exists (const a). intros x y; reflexivity. - exists idmap. intros x y; destruct (na x). Defined. Global Instance pathcoll_decpaths (A : Type) `{DecidablePaths A} : PathCollapsible A. Proof. intros x y; exact _. Defined. (** We give this a relatively high-numbered priority so that in deducing [IsHProp -> IsHSet] Coq doesn't detour via [DecidablePaths]. *) Global Instance hset_pathcoll (A : Type) `{PathCollapsible A} : IsHSet A | 1000. Proof. apply istrunc_S. intros x y. assert (h : forall p:x=y, p = (collapse (idpath x))^ @ collapse p). { intros []; symmetry; by apply concat_Vp. } apply hprop_allpath; intros p q. refine (h p @ _ @ (h q)^). apply whiskerL. apply wconst. Defined. Definition collapsible_hprop (A : Type) `{IsHProp A} : Collapsible A. Proof. exists idmap. intros x y; apply path_ishprop. Defined. Definition pathcoll_hset (A : Type) `{IsHSet A} : PathCollapsible A. Proof. intros x y; apply collapsible_hprop; exact _. Defined. (** Hedberg's Theorem *) Corollary hset_decpaths (A : Type) `{DecidablePaths A} : IsHSet A. Proof. exact _. Defined. (** We can use Hedberg's Theorem to simplify a goal of the form [forall (d : Decidable (x = x :> A)), P d] when [A] has decidable paths. *) Definition decidable_paths_refl (A : Type) `{DecidablePaths A} (x : A) (P : forall (d : Decidable (x = x)), Type) (Px : P (inl idpath)) : forall d, P d. Proof. rapply (decidable_true idpath). intro p. (** We cannot eliminate [p : x = x] with path induction, but we can use Hedberg's theorem to replace this with [idpath]. *) assert (r : (idpath = p)) by apply path_ishprop. by destruct r. Defined. (** ** Truncation *) (** Having decidable equality (which implies being an hset, by Hedberg's theorem above) is itself an hprop. *) Global Instance ishprop_decpaths `{Funext} (A : Type) : IsHProp (DecidablePaths A). Proof. apply hprop_inhabited_contr; intros d. assert (IsHSet A) by exact _. apply (Build_Contr _ d). intros d'. funext x y. generalize (d x y); clear d; intros d. generalize (d' x y); clear d'; intros d'. destruct d as [d|nd]; destruct d' as [d'|nd']. - apply ap, path_ishprop. - elim (nd' d). - elim (nd d'). - apply ap, path_forall; intros p; elim (nd p). Defined. (** ** Logical Laws *) (** Various logical laws don't hold constructively as they do classically due to a required use of excluded middle. For us, this means that some laws require further assumptions on the decidability of propositions. *) (** Here we give the dual De Morgan's Law which complements the one given in Iff.v. One direction requires that one of the two propositions be decidable, while the other direction needs no assumption. We state the latter property first, to avoid duplication in the proof. *) Definition not_prod_sum_not A B : ~ A + ~ B -> ~ (A * B). Proof. intros [na|nb] [a b]. - exact (na a). - exact (nb b). Defined. Definition iff_not_prod A B `{Decidable A} : ~ (A * B) <-> ~ A + ~ B. Proof. split. - intros np. destruct (dec A) as [a|na]. + exact (inr (fun b => np (a, b))). + exact (inl na). - apply not_prod_sum_not. Defined. Definition iff_not_prod' A B `{Decidable B} : ~ (A * B) <-> ~ A + ~ B. Proof. split. - intros np. destruct (dec B) as [b|nb]. + exact (inl (fun a => np (a, b))). + exact (inr nb). - apply not_prod_sum_not. Defined. Coq-HoTT-9.0/theories/Basics/Equivalences.v000066400000000000000000001053041474641544500206020ustar00rootroot00000000000000(** * Equivalences *) Require Import Basics.Overture Basics.PathGroupoids Basics.Contractible Basics.Tactics. Local Open Scope path_scope. (** We now give many ways to construct equivalences. In each case, we define an instance of the typeclass [IsEquiv] named [isequiv_X], followed by an element of the record type [Equiv] named [equiv_X]. Whenever we need to assume, as a hypothesis, that a certain function is an equivalence, we do it by assuming separately a function and a proof of [IsEquiv]. This is more general than assuming an inhabitant of [Equiv], since the latter has an implicit coercion and an existing instance to give us the former automatically. Moreover, implicit generalization makes it easy to assume a function and a proof of [IsEquiv]. *) (** A word on naming: some of the lemmas about equivalences are analogues of those for paths in PathGroupoids. We name them in an analogous way but adding [_equiv] in an appropriate place, e.g. instead of [moveR_M] we have [moveR_equiv_M]. *) Generalizable Variables A B C f g. (** The identity map is an equivalence. *) Global Instance isequiv_idmap (A : Type) : IsEquiv idmap | 0 := Build_IsEquiv A A idmap idmap (fun _ => 1) (fun _ => 1) (fun _ => 1). Definition equiv_idmap (A : Type) : A <~> A := Build_Equiv A A idmap _. Arguments equiv_idmap {A} , A. Notation "1" := equiv_idmap : equiv_scope. Global Instance reflexive_equiv : Reflexive Equiv | 0 := @equiv_idmap. Arguments reflexive_equiv /. (** The composition of equivalences is an equivalence. *) Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (g o f) | 1000 := Build_IsEquiv A C (g o f) (f^-1 o g^-1) (fun c => ap g (eisretr f (g^-1 c)) @ eisretr g c) (fun a => ap (f^-1) (eissect g (f a)) @ eissect f a) (fun a => (whiskerL _ (eisadj g (f a))) @ (ap_pp g _ _)^ @ ap02 g ( (concat_A1p (eisretr f) (eissect g (f a)))^ @ (ap_compose f^-1 f _ @@ eisadj f a) @ (ap_pp f _ _)^ ) @ (ap_compose f g _)^ ). (* An alias of [isequiv_compose], with some arguments explicit; often convenient when type class search fails. *) Definition isequiv_compose' {A B : Type} (f : A -> B) (_ : IsEquiv f) {C : Type} (g : B -> C) (_ : IsEquiv g) : IsEquiv (g o f) := isequiv_compose. Definition equiv_compose {A B C : Type} (g : B -> C) (f : A -> B) `{IsEquiv B C g} `{IsEquiv A B f} : A <~> C := Build_Equiv A C (g o f) _. Definition equiv_compose' {A B C : Type} (g : B <~> C) (f : A <~> B) : A <~> C := equiv_compose g f. (** We put [g] and [f] in [equiv_scope] explicitly. This is a partial work-around for https://github.com/coq/coq/issues/3990, which is that implicitly bound scopes don't nest well. *) Notation "g 'oE' f" := (equiv_compose' g%equiv f%equiv) : equiv_scope. (* The TypeClass [Transitive] has a different order of parameters than [equiv_compose]. Thus in declaring the instance we have to switch the order of arguments. *) Global Instance transitive_equiv : Transitive Equiv | 0 := fun _ _ _ f g => equiv_compose g f. Arguments transitive_equiv /. (** A tactic to simplify "oE". See [ev_equiv] below for a more extensive tactic. *) Ltac change_apply_equiv_compose := match goal with | [ |- context [ equiv_fun (?f oE ?g) ?x ] ] => change ((f oE g) x) with (f (g x)) end. (** Transporting is an equivalence. *) Section EquivTransport. Context {A : Type} (P : A -> Type) {x y : A} (p : x = y). (** The inverse and the homotopies of transport are defined explicitly. This allows us to reason about the inverse when the input is not [idpath]. *) Global Instance isequiv_transport : IsEquiv (transport P p) | 0 := Build_IsEquiv (P x) (P y) (transport P p) (transport P p^) (transport_pV P p) (transport_Vp P p) (transport_pVp P p). Definition equiv_transport : P x <~> P y := Build_Equiv _ _ (transport P p) _. End EquivTransport. (** Doubly dependent transport is an equivalence. *) Section EquivTransportD. Context {A : Type} (P : A -> Type) (Q : forall a : A, P a -> Type) {x y : A} (p : x = y) {px : P x}. (** The inverse of transportD is defined explicitly. This allows us to reason about the inverse when the input is not [idpath]. *) Global Instance isequiv_transportD : IsEquiv (transportD P Q p px). Proof. snrapply Build_IsEquiv. { refine (_ o transportD P Q p^ (transport P p px)). exact (transport (Q x) (transport_Vp _ p px)). } all: by destruct p. Defined. Definition equiv_transportD : Q x px <~> Q y (transport P p px) := Build_Equiv _ _ (transportD P Q p px) _. Definition equiv_transportDD {py : P y} (q : transport P p px = py) : Q x px <~> Q y py := Build_Equiv _ _ (transportDD P Q p q) _. End EquivTransportD. (** In all the above cases, we were able to directly construct all the structure of an equivalence. However, as is evident, sometimes it is quite difficult to prove the adjoint law. The following adjointification theorem allows us to be lazy about this if we wish. It says that if we have all the data of an (adjoint) equivalence except the triangle identity, then we can always obtain the triangle identity by modifying the datum [equiv_is_section] (or [equiv_is_retraction]). The proof is the same as the standard categorical argument that any equivalence can be improved to an adjoint equivalence. As a stylistic matter, we try to avoid using adjointification in the library whenever possible, to preserve the homotopies specified by the user. *) Section Adjointify. Context {A B : Type} (f : A -> B) (g : B -> A). Context (isretr : f o g == idmap) (issect : g o f == idmap). (* This is the modified [eissect]. *) Let issect' := fun x => ap g (ap f (issect x)^) @ ap g (isretr (f x)) @ issect x. Local Definition is_adjoint' (a : A) : isretr (f a) = ap f (issect' a). Proof. unfold issect'. apply moveR_M1. repeat rewrite ap_pp, concat_p_pp; rewrite <- ap_compose. rewrite (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)). repeat rewrite concat_pp_p; rewrite ap_V; apply moveL_Vp; rewrite concat_p1. rewrite concat_p_pp, <- ap_compose. rewrite (concat_pA1 (fun b => (isretr b)^) (isretr (f a))). rewrite concat_pV, concat_1p; reflexivity. Qed. (** We don't make this a typeclass instance, because we want to control when we are applying it. *) Definition isequiv_adjointify : IsEquiv f := Build_IsEquiv A B f g isretr issect' is_adjoint'. Definition equiv_adjointify : A <~> B := Build_Equiv A B f isequiv_adjointify. End Adjointify. Arguments isequiv_adjointify {A B}%_type_scope (f g)%_function_scope isretr issect. Arguments equiv_adjointify {A B}%_type_scope (f g)%_function_scope isretr issect. (** Anything homotopic to an equivalence is an equivalence. This should not be an instance; it can cause the unifier to spin forever searching for functions to be homotopic to. *) Definition isequiv_homotopic {A B : Type} (f : A -> B) {g : A -> B} `{IsEquiv A B f} (h : f == g) : IsEquiv g. Proof. snrapply isequiv_adjointify. - exact f^-1. - intro b. exact ((h _)^ @ eisretr f b). - intro a. exact (ap f^-1 (h a)^ @ eissect f a). Defined. Definition isequiv_homotopic' {A B : Type} (f : A <~> B) {g : A -> B} (h : f == g) : IsEquiv g := isequiv_homotopic f h. Definition equiv_homotopic {A B : Type} (f : A -> B) {g : A -> B} `{IsEquiv A B f} (h : f == g) : A <~> B := Build_Equiv _ _ g (isequiv_homotopic f h). (** If [e] is an equivalence, [f] is homotopic to [e], and [g] is homotopic to [e^-1], then there is an equivalence whose underlying map is [f] and whose inverse is [g], definitionally. *) Definition equiv_homotopic_inverse {A B} (e : A <~> B) {f : A -> B} {g : B -> A} (h : f == e) (k : g == e^-1) : A <~> B. Proof. snrapply equiv_adjointify. - exact f. - exact g. - intro a. exact (ap f (k a) @ h _ @ eisretr e a). - intro b. exact (ap g (h b) @ k _ @ eissect e b). Defined. (** An involution is an endomap that is its own inverse. *) Definition isequiv_involution {X : Type} (f : X -> X) (isinvol : f o f == idmap) : IsEquiv f := isequiv_adjointify f f isinvol isinvol. Definition equiv_involution {X : Type} (f : X -> X) (isinvol : f o f == idmap) : X <~> X := equiv_adjointify f f isinvol isinvol. (** Several lemmas useful for rewriting. *) Definition moveR_equiv_M `{IsEquiv A B f} (x : A) (y : B) (p : x = f^-1 y) : (f x = y) := ap f p @ eisretr f y. Definition moveR_equiv_M' `(f : A <~> B) (x : A) (y : B) (p : x = f^-1 y) : (f x = y) := moveR_equiv_M x y p. Definition moveL_equiv_M `{IsEquiv A B f} (x : A) (y : B) (p : f^-1 y = x) : (y = f x) := (eisretr f y)^ @ ap f p. Definition moveL_equiv_M' `(f : A <~> B) (x : A) (y : B) (p : f^-1 y = x) : (y = f x) := moveL_equiv_M x y p. Definition moveR_equiv_V `{IsEquiv A B f} (x : B) (y : A) (p : x = f y) : (f^-1 x = y) := ap (f^-1) p @ eissect f y. Definition moveR_equiv_V' `(f : A <~> B) (x : B) (y : A) (p : x = f y) : (f^-1 x = y) := moveR_equiv_V x y p. Definition moveL_equiv_V `{IsEquiv A B f} (x : B) (y : A) (p : f y = x) : (y = f^-1 x) := (eissect f y)^ @ ap (f^-1) p. Definition moveL_equiv_V' `(f : A <~> B) (x : B) (y : A) (p : f y = x) : (y = f^-1 x) := moveL_equiv_V x y p. (** Equivalence preserves contractibility (which of course is trivial under univalence). *) Lemma contr_equiv A {B} (f : A -> B) `{IsEquiv A B f} `{Contr A} : Contr B. Proof. apply (Build_Contr _ (f (center A))). intro y. apply moveR_equiv_M. apply contr. Defined. Definition contr_equiv' A {B} `(f : A <~> B) `{Contr A} : Contr B := contr_equiv A f. (** Any two contractible types are equivalent. *) Global Instance isequiv_contr_contr {A B : Type} `{Contr A} `{Contr B} (f : A -> B) : IsEquiv f := Build_IsEquiv _ _ f (fun _ => (center A)) (fun x => path_contr _ _) (fun x => path_contr _ _) (fun x => path_contr _ _). Definition equiv_contr_contr {A B : Type} `{Contr A} `{Contr B} : (A <~> B) := Build_Equiv _ _ (fun _ => center B) _. (** The projection from the sum of a family of contractible types is an equivalence. *) Global Instance isequiv_pr1 {A : Type} (P : A -> Type) `{forall x, Contr (P x)} : IsEquiv (@pr1 A P). Proof. apply (Build_IsEquiv _ _ (@pr1 A P) (fun x => (x ; center (P x))) (fun x => 1) (fun xy => match xy with | exist x y => ap (exist _ x) (contr _) end)). intros [x y]. rewrite <- ap_compose. symmetry; apply ap_const. Defined. Definition equiv_pr1 {A : Type} (P : A -> Type) `{forall x, Contr (P x)} : { x : A & P x } <~> A := Build_Equiv _ _ (@pr1 A P) _. (** Equivalences between path spaces *) (** If [f] is an equivalence, then so is [ap f]. We are lazy and use [adjointify]. *) Global Instance isequiv_ap `{IsEquiv A B f} (x y : A) : IsEquiv (@ap A B f x y) | 1000 := isequiv_adjointify (ap f) (fun q => (eissect f x)^ @ ap f^-1 q @ eissect f y) (fun q => ap_pp f _ _ @ whiskerR (ap_pp f _ _) _ @ ((ap_V f _ @ inverse2 (eisadj f _)^) @@ (ap_compose f^-1 f _)^ @@ (eisadj f _)^) @ concat_pA1_p (eisretr f) _ _ @ whiskerR (concat_Vp _) _ @ concat_1p _) (fun p => whiskerR (whiskerL _ (ap_compose f f^-1 _)^) _ @ concat_pA1_p (eissect f) _ _ @ whiskerR (concat_Vp _) _ @ concat_1p _). Definition equiv_ap `(f : A -> B) `{IsEquiv A B f} (x y : A) : (x = y) <~> (f x = f y) := Build_Equiv _ _ (ap f) _. Global Arguments equiv_ap (A B)%_type_scope f%_function_scope _ _ _. Definition equiv_ap' `(f : A <~> B) (x y : A) : (x = y) <~> (f x = f y) := equiv_ap f x y. Definition equiv_inj `(f : A -> B) `{IsEquiv A B f} {x y : A} : (f x = f y) -> (x = y) := (ap f)^-1. (** Assuming function extensionality, composing with an equivalence is itself an equivalence *) Global Instance isequiv_precompose `{Funext} {A B C : Type} (f : A -> B) `{IsEquiv A B f} : IsEquiv (fun (g:B->C) => g o f) | 1000 := isequiv_adjointify (fun (g:B->C) => g o f) (fun h => h o f^-1) (fun h => path_forall _ _ (fun x => ap h (eissect f x))) (fun g => path_forall _ _ (fun y => ap g (eisretr f y))). Definition equiv_precompose `{Funext} {A B C : Type} (f : A -> B) `{IsEquiv A B f} : (B -> C) <~> (A -> C) := Build_Equiv _ _ (fun (g:B->C) => g o f) _. Definition equiv_precompose' `{Funext} {A B C : Type} (f : A <~> B) : (B -> C) <~> (A -> C) := Build_Equiv _ _ (fun (g:B->C) => g o f) _. Global Instance isequiv_postcompose `{Funext} {A B C : Type} (f : B -> C) `{IsEquiv B C f} : IsEquiv (fun (g:A->B) => f o g) | 1000 := isequiv_adjointify (fun (g:A->B) => f o g) (fun h => f^-1 o h) (fun h => path_forall _ _ (fun x => eisretr f (h x))) (fun g => path_forall _ _ (fun y => eissect f (g y))). Definition equiv_postcompose `{Funext} {A B C : Type} (f : B -> C) `{IsEquiv B C f} : (A -> B) <~> (A -> C) := Build_Equiv _ _ (fun (g:A->B) => f o g) _. Definition equiv_postcompose' `{Funext} {A B C : Type} (f : B <~> C) : (A -> B) <~> (A -> C) := Build_Equiv _ _ (fun (g:A->B) => f o g) _. (** Conversely, if pre- or post-composing with a function is always an equivalence, then that function is also an equivalence. This is a form of the Yoneda lemma. It's convenient to know that we only need to assume the equivalence when the other type is the domain or the codomain. *) Definition isequiv_isequiv_precompose {A B : Type} (f : A -> B) (precomp := (fun (C : Type) (h : B -> C) => h o f)) (Aeq : IsEquiv (precomp A)) (Beq : IsEquiv (precomp B)) : IsEquiv f. Proof. set (g:=(precomp A)^-1 idmap). pose proof (p:=eisretr (precomp A) idmap : g o f = idmap). refine (isequiv_adjointify f g (ap10 _) (ap10 p)). apply (equiv_inj (precomp B)). unfold precomp; cbn. exact (ap (fun k => f o k) p). Defined. Definition isequiv_isequiv_postcompose {A B : Type} (f : A -> B) (postcomp := (fun (C : Type) (h : C -> A) => f o h)) (Aeq : IsEquiv (postcomp A)) (Beq : IsEquiv (postcomp B)) : IsEquiv f. Proof. set (g:=(postcomp B)^-1 idmap). pose proof (p:=eisretr (postcomp B) idmap : f o g = idmap). refine (isequiv_adjointify f g (ap10 p) (ap10 _)). apply (equiv_inj (postcomp A)). unfold postcomp; cbn. exact (ap (fun k => k o f) p). Defined. (** The inverse of an equivalence is an equivalence. *) Global Instance isequiv_inverse {A B : Type} (f : A -> B) {feq : IsEquiv f} : IsEquiv f^-1 | 10000. Proof. refine (Build_IsEquiv B A f^-1 f (eissect f) (eisretr f) _). intro b. apply (equiv_inj (ap f)). (* We will prove the equality as a composite of four paths, working right to left. The LHS remains [ap f (eissect f (f^-1 b))] throughout the process. Both sides of the equation are paths of type [f (f^-1 (f (f^-1 b))) = f (f^-1 b)]. *) refine (_ @ _ @ _ @ _); revgoals. 1: apply ap_compose. 1: symmetry; apply (ap_homotopic_id (eisretr f)). 1: symmetry; apply concat_pp_V. 1: symmetry; apply eisadj. Defined. (** If the goal is [IsEquiv _^-1], then use [isequiv_inverse]; otherwise, don't pretend worry about if the goal is an evar and we want to add a [^-1]. *) #[export] Hint Extern 0 (IsEquiv _^-1) => apply @isequiv_inverse : typeclass_instances. (** [Equiv A B] is a symmetric relation. *) Theorem equiv_inverse {A B : Type} : (A <~> B) -> (B <~> A). Proof. intro e. exists (e^-1). apply isequiv_inverse. Defined. Notation "e ^-1" := (@equiv_inverse _ _ e) : equiv_scope. Global Instance symmetric_equiv : Symmetric Equiv | 0 := @equiv_inverse. Arguments symmetric_equiv /. (** Inversion respects composition *) Definition equiv_inverse_compose {A B C} (f : A <~> B) (g : B <~> C) : (g oE f)^-1 == f^-1 oE g^-1. Proof. intros x; reflexivity. Defined. (** Inversion respects homotopies *) Definition equiv_inverse_homotopy {A B} (f g : A <~> B) (p : f == g) : g^-1 == f^-1. Proof. intros x; refine (_ @ _ @ _). 1:symmetry; apply (eissect f). 1:apply ap, p. apply ap, eisretr. Defined. Definition equiv_ap_inv `(f : A -> B) `{IsEquiv A B f} (x y : B) : (f^-1 x = f^-1 y) <~> (x = y) := (@equiv_ap B A f^-1 _ x y)^-1%equiv. Definition equiv_ap_inv' `(f : A <~> B) (x y : B) : (f^-1 x = f^-1 y) <~> (x = y) := (equiv_ap' f^-1%equiv x y)^-1%equiv. (** If [g \o f] and [f] are equivalences, so is [g]. This is not an Instance because it would require Coq to guess [f]. *) Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C} `{IsEquiv A B f} `{IsEquiv A C (g o f)} : IsEquiv g := isequiv_homotopic ((g o f) o f^-1) (fun b => ap g (eisretr f b)). Definition cancelR_equiv {A B C} (f : A -> B) {g : B -> C} `{IsEquiv A B f} `{IsEquiv A C (g o f)} : B <~> C := Build_Equiv B C g (cancelR_isequiv f). (** If [g \o f] and [g] are equivalences, so is [f]. *) Definition cancelL_isequiv {A B C} (g : B -> C) {f : A -> B} `{IsEquiv B C g} `{IsEquiv A C (g o f)} : IsEquiv f := isequiv_homotopic (g^-1 o (g o f)) (fun a => eissect g (f a)). Definition cancelL_equiv {A B C} (g : B -> C) {f : A -> B} `{IsEquiv B C g} `{IsEquiv A C (g o f)} : A <~> B := Build_Equiv _ _ f (cancelL_isequiv g). (** Combining these with [isequiv_compose], we see that equivalences can be transported across commutative squares. *) Definition isequiv_commsq {A B C D} (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D) (p : k o f == g o h) `{IsEquiv _ _ f} `{IsEquiv _ _ h} `{IsEquiv _ _ k} : IsEquiv g. Proof. refine (@cancelR_isequiv _ _ _ h g _ _). refine (isequiv_homotopic _ p). Defined. Definition isequiv_commsq' {A B C D} (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D) (p : g o h == k o f) `{IsEquiv _ _ g} `{IsEquiv _ _ h} `{IsEquiv _ _ k} : IsEquiv f. Proof. refine (@cancelL_isequiv _ _ _ k f _ _). refine (isequiv_homotopic _ p). Defined. (** Based homotopy spaces *) Global Instance contr_basedhomotopy `{Funext} {A:Type} {B : A -> Type} (f : forall x, B x) : Contr {g : forall x, B x & f == g }. Proof. refine (contr_equiv' { g : forall x, B x & f = g } _). srapply equiv_adjointify; intros [g h]. - exact (g; apD10 h). - exact (g; path_forall _ _ h). - apply ap, eisretr. - apply ap, eissect. Defined. Global Instance contr_basedhomotopy' `{Funext} {A:Type} {B : A -> Type} (f : forall x, B x) : Contr {g : forall x, B x & g == f }. Proof. refine (contr_equiv' { g : forall x, B x & g = f } _). srapply equiv_adjointify; intros [g h]. - exact (g; apD10 h). - exact (g; path_forall _ _ h). - apply ap, eisretr. - apply ap, eissect. Defined. (** The function [equiv_ind] says that given an equivalence [f : A <~> B], and a hypothesis from [B], one may always assume that the hypothesis is in the image of [e]. In fibrational terms, if we have a fibration over [B] which has a section once pulled back along an equivalence [f : A <~> B], then it has a section over all of [B]. *) Definition equiv_ind `{IsEquiv A B f} (P : B -> Type) : (forall x:A, P (f x)) -> forall y:B, P y := fun g y => transport P (eisretr f y) (g (f^-1 y)). Arguments equiv_ind {A B} f {_} P _ _. Definition equiv_ind_comp `{IsEquiv A B f} (P : B -> Type) (df : forall x:A, P (f x)) (x : A) : equiv_ind f P df (f x) = df x. Proof. unfold equiv_ind. rewrite eisadj. rewrite <- transport_compose. exact (apD df (eissect f x)). Defined. (** Using [equiv_ind], we define a handy little tactic which introduces a variable [x] and simultaneously substitutes it along an equivalence [E]. *) Ltac equiv_intro E x := match goal with | |- forall y, @?Q y => refine (equiv_ind E Q _); intros x end. (** The same, but for several variables. *) Tactic Notation "equiv_intros" constr(E) ident(x) := equiv_intro E x. Tactic Notation "equiv_intros" constr(E) ident(x) ident(y) := equiv_intro E x; equiv_intro E y. Tactic Notation "equiv_intros" constr(E) ident(x) ident(y) ident(z) := equiv_intro E x; equiv_intro E y; equiv_intro E z. (** A lemma that combines equivalence induction with path induction. If [e] is an equivalence from [a = b] to [X], then to prove [forall x, P x] it is enough to prove [forall p : a = b, P (e p)], and so by path induction it suffices to prove [P (e 1)]. The idiom for using this is to first [revert b X], which allows Coq to determine the family [P]. After using this, [b] will be replaced by [a] in the goal. This is a more general version of Theorem 5.8.2 (iii) implies (i), see Homotopy/IdentitySystems.v. *) Definition equiv_path_ind {A} {a : A} {X : A -> Type} (e : forall (b : A), a = b <~> X b) (P : forall (b : A), X b -> Type) (r : P a (e a 1)) : forall (b : A) (x : X b), P b x. Proof. intro b. srapply (equiv_ind (e b)). intros []. exact r. Defined. (** [equiv_composeR'], a flipped version of [equiv_compose'], is (like [concatR]) most often useful partially applied, to give the “first half” of an equivalence one is constructing and leave the rest as a subgoal. One could similarly define [equiv_composeR] as a flip of [equiv_compose], but it doesn’t seem so useful since it doesn’t leave the remaining equivalence as a subgoal. *) Definition equiv_composeR' {A B C} (f : A <~> B) (g : B <~> C) := equiv_compose' g f. (* Shouldn't this become transitivity mid ? *) Ltac equiv_via mid := apply @equiv_composeR' with (B := mid). (** It's often convenient when constructing a chain of equivalences to use [equiv_compose'], etc. But when we treat an [Equiv] object constructed in that way as a function, via the coercion [equiv_fun], Coq sometimes needs a little help to realize that the result is the same as ordinary composition. This tactic provides that help. *) Ltac ev_equiv := repeat match goal with | [ |- context[equiv_fun (equiv_inverse (equiv_inverse ?f))] ] => change (equiv_fun (equiv_inverse (equiv_inverse f))) with (equiv_fun f) | [ |- context[(@equiv_inv ?B ?A (equiv_fun (equiv_inverse ?f)) ?iseq)] ] => change (@equiv_inv B A (equiv_fun (equiv_inverse f)) iseq) with (equiv_fun f) | [ |- context[((equiv_fun ?f)^-1)^-1] ] => change ((equiv_fun f)^-1)^-1 with (equiv_fun f) | [ |- context[equiv_fun (equiv_compose' ?g ?f) ?a] ] => change (equiv_fun (equiv_compose' g f) a) with (g (f a)) | [ |- context[equiv_fun (equiv_compose ?g ?f) ?a] ] => change (equiv_fun (equiv_compose g f) a) with (g (f a)) | [ |- context[equiv_fun (equiv_inverse ?f) ?a] ] => change (equiv_fun (equiv_inverse f) a) with (f^-1 a) | [ |- context[equiv_fun (equiv_compose' ?g ?f)] ] => change (equiv_fun (equiv_compose' g f)) with (g o f) | [ |- context[equiv_fun (equiv_compose ?g ?f)] ] => change (equiv_fun (equiv_compose g f)) with (g o f) | [ |- context[equiv_fun (equiv_inverse ?f)] ] => change (equiv_fun (equiv_inverse f)) with (f^-1) end. (** ** Building equivalences between nested sigma and record types *) (** The following tactic [make_equiv] builds an equivalence between two types built out of arbitrarily nested sigma and record types, not necessarily right-associated, as long as they have all the same underyling components. This is more general than [issig] in that it doesn't just prove equivalences between a single record type and a single right-nested tower of sigma types, but less powerful in that it can't deduce the latter nested tower of sigmas automatically: you have to have both sides of the equivalence known. *) (* Perform [intros] repeatedly, recursively destructing all possibly-nested record types. We use a custom induction principle for [Contr], since [elim] produces two goals. The [hnf] is important, for example to unfold [IsUnitPreserving] to an equality, which the [lazymatch] then ignores. *) Ltac decomposing_intros := let x := fresh in intros x; hnf in x; cbn in x; try lazymatch type of x with | ?a = ?b => idtac (** Don't destruct paths *) | forall y:?A, ?B => idtac (** Don't apply functions *) | Contr ?A => revert x; match goal with |- (forall y, ?P y) => snrefine (Contr_ind A P _) end | _ => elim x; clear x end; try decomposing_intros. (* A multi-success version of [assumption]. That is, like [assumption], but if there are multiple hypotheses that match the type of the goal, then after choosing the first one, if a later tactic fails we can backtrack and choose another one. *) Ltac multi_assumption := multimatch goal with (* If we wrote [ H : ?A |- ?A ] here instead, it would prevent Coq from choosing an assumption that would require instantiating evars, which it has to do in the contr_basedpaths case below. *) [ H : ?A |- _ ] => exact H end. (* Build an element of a possibly-nested record type out of hypotheses in the context. *) Ltac build_record := cbn; multi_assumption + (unshelve econstructor; build_record). (* Construct an equivalence between two possibly-nested record/sigma types that differ only by associativity and permutation of their components. We could use [Build_Equiv] and directly construct [eisadj] by decomposing to reflexivity as well, but often with large nested types it seems to be faster to adjointify. *) Ltac make_equiv := snrefine (equiv_adjointify _ _ _ _); [ decomposing_intros; build_record | decomposing_intros; build_record | decomposing_intros; exact idpath | decomposing_intros; exact idpath ]. (** In case anyone ever needs it, here's the version that doesn't adjointify. It's not the default, because it can be slow. *) Ltac make_equiv_without_adjointification := snrefine (Build_Equiv _ _ _ _); [ decomposing_intros; build_record | snrefine (Build_IsEquiv _ _ _ _ _ _ _); [ decomposing_intros; build_record | decomposing_intros; exact idpath | decomposing_intros; exact idpath | decomposing_intros; exact idpath ] ]. (** Here are some examples of the use of this tactic that you can uncomment and explore. *) (** << Goal forall (A : Type) (B : A -> Type) (C : forall a:A, B a -> Type) (D : forall (a:A) (b:B a), C a b -> Type), { ab : {a : A & B a } & { c : C ab.1 ab.2 & D ab.1 ab.2 c } } <~> { a : A & { bc : { b : B a & C a b } & D a bc.1 bc.2 } }. intros A B C D. make_equiv. Undo. (** Here's the eventually successful proof script produced by [make_equiv], extracted from [Info 0 make_equiv] and prettified, so you can step through it and see how the tactic works. *) snrefine (equiv_adjointify _ _ _ _). - (** Here begins [decomposing_intros] *) intros x; cbn in x. elim x; clear x. intros x; cbn in x. elim x; clear x. intros a; cbn in a. intros b; cbn in b. intros x; cbn in x. elim x; clear x. intros c; cbn in c. intros d; cbn in d. (** Here begins [build_record] *) cbn; unshelve econstructor. { cbn; exact a. } { cbn; unshelve econstructor. { cbn; unshelve econstructor. { cbn; exact b. } { cbn; exact c. } } { cbn; exact d. } } - intros x; cbn in x. elim x; clear x. intros a; cbn in a. intros x; cbn in x. elim x; clear x. intros x; cbn in x. elim x; clear x. intros b; cbn in b. intros c; cbn in c. intros d; cbn in d. cbn; unshelve econstructor. { cbn; unshelve econstructor. { cbn; exact a. } { cbn; exact b. } } { cbn; unshelve econstructor. { cbn; exact c. } { cbn; exact d. } } - intros x; cbn in x. elim x; clear x. intros a; cbn in a. intros x; cbn in x. elim x; clear x. intros x; cbn in x. elim x; clear x. intros b; cbn in b. intros c; cbn in c. intros d; cbn in d. cbn; exact idpath. - intros x; cbn in x. elim x; clear x. intros x; cbn in x. elim x; clear x. intros a; cbn in a. intros b; cbn in b. intros x; cbn in x. elim x; clear x. intros c; cbn in c. intros d; cbn in d. cbn; exact idpath. Defined. >> *) (** Here is an example illustrating the need for [multi_assumption] instead of just [assumption]. *) (** << Goal forall (A:Type) (R:A->A->Type), { x : A & { y : A & R x y } } <~> { xy : A * A & R (fst xy) (snd xy) }. intros A R. make_equiv. Undo. snrefine (equiv_adjointify _ _ _ _). - intros x; cbn in x. elim x; clear x. intros a1; cbn in a1. intros x; cbn in x. elim x; clear x. intros a2; cbn in a2. intros r; cbn in r. cbn; unshelve econstructor. { cbn; unshelve econstructor. { (** [build_record] can't guess at this point that it needs to use [a1] instead of [a2], and in fact it tries [a2] first; but later on, [exact r] fails in that case, causing backtracking to this point and a re-try with [a1]. *) cbn; exact a1. } { cbn; exact a2. } } cbn; exact r. - intros x; cbn in x. elim x; clear x. intros x; cbn in x. elim x; clear x. intros a1; cbn in a1. intros a2; cbn in a2. intros r; cbn in r. cbn; unshelve econstructor. { cbn; exact a1. } { cbn; unshelve econstructor. { cbn; exact a2. } { cbn; exact r. } } - intros x; cbn in x. elim x; clear x. intros x; cbn in x. elim x; clear x. intros a1; cbn in a1. intros a2; cbn in a2. intros r; cbn in r. cbn; exact idpath. - intros x; cbn in x. elim x; clear x. intros a1; cbn in a1. intros x; cbn in x. elim x; clear x. intros a2; cbn in a2. intros r; cbn in r. cbn; exact idpath. Defined. >> *) (** Some "real-world" examples where [make_equiv] simplifies things a lot include the associativity/symmetry proofs in [Types/Sigma.v], [issig_pequiv'] in [Pointed/pEquiv.v], and [loop_susp_adjoint] in [Pointed/pSusp.v]. *) (** Now we give a version of [make_equiv] that can also prove equivalences of nested sigma- and record types that involve contracting based path-spaces on either or both sides. The basepoint and the path don't have to appear together, but can be in arbitrarily separated parts of the nested structure. It does this by selectively applying path-induction to based paths appearing on both sides, if needed. *) (** We start with a version of [decomposing_intros] that is willing to destruct paths, though as a second choice. *) Ltac decomposing_intros_with_paths := let x := fresh in intros x; hnf in x; cbn in x; multimatch type of x with | _ => try match type of x with | (** Don't destruct paths at first *) ?a = ?b => fail 1 | (** Don't apply functions at first *) forall y:?A, ?B => fail 1 | _ => elim x; clear x end; try decomposing_intros_with_paths | ?a = ?b => (** Destruct paths as a second choice. But sometimes [destruct] isn't smart enough to generalize the other hypotheses that use the free endpoint, so we manually apply [paths_ind], or its right-handed version, instead. *) ((move x before b; (** Ensure that [b] and [x] come first in the [forall] goal resulting from [generalize dependent], so that [paths_ind] can apply to it. *) revert dependent b; assert_fails (move b at top); (** Check that [b] was actually reverted. (If it's a section variable that the goal depends on, [generalize dependent b] will "succeed", but actually fail to generalize the goal over [b] (since that can't be done within the section) and not clear [b] from the context.) *) refine (paths_ind _ _ _)) + (** Try the other endpoint too. *) (move x before a; revert dependent a; assert_fails (move a at top); refine (paths_ind_r _ _ _))); try decomposing_intros_with_paths end. (** Going the other direction, we have to be willing to insert identity paths to fill in the based path-spaces that got destructed. In fact [econstructor] is already willing to do that, since [idpath] is the constructor of [paths]. However, our previous [build_record] won't manage to get to the point of being able to apply [econstructor] to the necessary paths, since it'll get stuck earlier on trying to find the basepoint. Thus, we give a version of [build_record] that is willing to create existential variables ("evars") for goals that it can't solve, in hopes that a later [idpath] (produced by [econstructor]) will determine them by unification. Note that if there are other fields that depend on the basepoint that occur before the [idpath], the evar will -- and, indeed, must -- get instantiated by them instead. This is why [multi_assumption], above, must be willing to instantiate evars. *) Ltac build_record_with_evars := (cbn; multi_assumption + (unshelve econstructor; build_record_with_evars)) + (** Create a fresh evar to solve this goal *) (match goal with |- ?G => let x := fresh in evar (x : G); exact x end; build_record_with_evars). (** Now here's the improved version of [make_equiv]. *) Ltac make_equiv_contr_basedpaths := snrefine (equiv_adjointify _ _ _ _); (** [solve [ unshelve TAC ]] ensures that [TAC] succeeds without leaving any leftover evars. *) [ decomposing_intros_with_paths; solve [ unshelve build_record_with_evars ] | decomposing_intros_with_paths; solve [ unshelve build_record_with_evars ] | decomposing_intros_with_paths; exact idpath | decomposing_intros_with_paths; exact idpath ]. (** As before, we give some examples. *) (** << Section Examples. Context (A : Type) (B : A -> Type) (a0 : A). Goal { a : A & { b : B a & a = a0 } } <~> B a0. Proof. make_equiv_contr_basedpaths. Undo. snrefine (equiv_adjointify _ _ _ _). - (** Here begins [decomposing_intros_with_paths] *) intros x; cbn in x. elim x; clear x. intros a; cbn in a. intros x; cbn in x. elim x; clear x. intros b; cbn in b. intros p; cbn in p. (** [decomposing_intros] wouldn't be willing to destruct [p] here, because it's a path. But [decomposing_intros_with_paths] will try it when all else fails. *) move p before a. generalize dependent a. not (move a at top). refine (paths_ind_r _ _ _). intros b; cbn in b. (** Here begins [build_record_with_evars] *) exact b. - (** Here begins [decomposing_intros_with_paths] *) intros b; cbn in b. (** Here begins [build_record_with_evars] *) cbn; unshelve econstructor. { let x := fresh in evar (x : A); exact x. } cbn; unshelve econstructor. { (** This instantiates the evar. *) exact b. } { cbn; unshelve econstructor. } - intros b; cbn in b. exact idpath. - intros x; cbn in x. elim x; clear x. intros a; cbn in a. intros x; cbn in x. elim x; clear x. intros b; cbn in b. intros p; cbn in p. move p before a. generalize dependent a. not (move a at top). refine (paths_ind_r _ _ _). intros b; cbn in b. exact idpath. Defined. End Examples. >> *) (** Some "real-world" examples where [make_equiv_contr_basedpaths] simplifies things a lot include [hfiber_compose] in [HFiber.v], [hfiber_pullback_along] in [Limits/Pullback.v], and [equiv_Ocodeleft2plus] in [BlakersMassey.v]. *) Coq-HoTT-9.0/theories/Basics/Iff.v000066400000000000000000000034261474641544500166640ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Local Set Universe Minimization ToSet. (** * If and only if *) (** ** Definition *) (** [iff A B], written [A <-> B], expresses the logical equivalence of [A] and [B] *) Definition iff (A B : Type) := prod (A -> B) (B -> A). Notation "A <-> B" := (iff A B) : type_scope. (** ** Basic Properties *) (** Everything is logically equivlaent to itself. *) Definition iff_refl {A} : A <-> A := (idmap , idmap). (** [iff] is a reflexive relation. *) Global Instance iff_reflexive : Reflexive iff | 1 := @iff_refl. (** Logical equivalences can be inverted. *) Definition iff_inverse {A B} : (A <-> B) -> (B <-> A) := fun f => (snd f , fst f). (** [iff] is a symmetric relation. *) Global Instance symmetric_iff : Symmetric iff | 1 := @iff_inverse. (** Logical equivalences can be composed. *) Definition iff_compose {A B C} (f : A <-> B) (g : B <-> C) : A <-> C := (fst g o fst f , snd f o snd g). (** [iff] is a transitive relation. *) Global Instance transitive_iff : Transitive iff | 1 := @iff_compose. (** Any equivalence can be considered a logical equivalence by discarding everything but the maps. We make this a coercion so that equivalences can be used in place of logical equivalences. *) Coercion iff_equiv {A B : Type} (f : A <~> B) : A <-> B := (equiv_fun f, f^-1). (** ** Logical Laws *) (** One of De Morgan's Laws. The dual statement about negating a product appears in Decidable.v due to decidability requirements. *) Definition iff_not_sum A B : ~ (A + B) <-> ~ A * ~ B. Proof. split. - intros ns. exact (ns o inl, ns o inr). - by intros []; snrapply sum_ind. Defined. Definition iff_contradiction A : A * ~A <-> Empty. Proof. split. - intros [a na]; exact (na a). - intros e; exact (Empty_rec _ e). Defined. Coq-HoTT-9.0/theories/Basics/Nat.v000066400000000000000000000107301474641544500166760ustar00rootroot00000000000000Require Import Basics.Overture Basics.Numeral. Notation "n .+1" := (S n) : nat_scope. Notation "n .+2" := (n.+1.+1)%nat : nat_scope. Notation "n .+3" := (n.+1.+2)%nat : nat_scope. Notation "n .+4" := (n.+1.+3)%nat : nat_scope. Notation "n .+5" := (n.+1.+4)%nat : nat_scope. (** ** Tail-recursive versions of [add] and [mul] *) Fixpoint tail_add n m := match n with | O => m | S n => tail_add n (S m) end. (** [tail_addmul r n m] is [r + n * m]. *) Fixpoint tail_addmul r n m := match n with | O => r | S n => tail_addmul (tail_add m r) n m end. Definition tail_mul n m := tail_addmul O n m. (** ** Conversion with a decimal representation for printing/parsing *) Local Notation ten := (S (S (S (S (S (S (S (S (S (S O)))))))))). Fixpoint of_uint_acc (d:Decimal.uint)(acc:nat) := match d with | Decimal.Nil => acc | Decimal.D0 d => of_uint_acc d (tail_mul ten acc) | Decimal.D1 d => of_uint_acc d (S (tail_mul ten acc)) | Decimal.D2 d => of_uint_acc d (S (S (tail_mul ten acc))) | Decimal.D3 d => of_uint_acc d (S (S (S (tail_mul ten acc)))) | Decimal.D4 d => of_uint_acc d (S (S (S (S (tail_mul ten acc))))) | Decimal.D5 d => of_uint_acc d (S (S (S (S (S (tail_mul ten acc)))))) | Decimal.D6 d => of_uint_acc d (S (S (S (S (S (S (tail_mul ten acc))))))) | Decimal.D7 d => of_uint_acc d (S (S (S (S (S (S (S (tail_mul ten acc)))))))) | Decimal.D8 d => of_uint_acc d (S (S (S (S (S (S (S (S (tail_mul ten acc))))))))) | Decimal.D9 d => of_uint_acc d (S (S (S (S (S (S (S (S (S (tail_mul ten acc)))))))))) end. Definition of_uint (d:Decimal.uint) := of_uint_acc d O. Local Notation sixteen := (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S O)))))))))))))))). Fixpoint of_hex_uint_acc (d:Hexadecimal.uint)(acc:nat) := match d with | Hexadecimal.Nil => acc | Hexadecimal.D0 d => of_hex_uint_acc d (tail_mul sixteen acc) | Hexadecimal.D1 d => of_hex_uint_acc d (S (tail_mul sixteen acc)) | Hexadecimal.D2 d => of_hex_uint_acc d (S (S (tail_mul sixteen acc))) | Hexadecimal.D3 d => of_hex_uint_acc d (S (S (S (tail_mul sixteen acc)))) | Hexadecimal.D4 d => of_hex_uint_acc d (S (S (S (S (tail_mul sixteen acc))))) | Hexadecimal.D5 d => of_hex_uint_acc d (S (S (S (S (S (tail_mul sixteen acc)))))) | Hexadecimal.D6 d => of_hex_uint_acc d (S (S (S (S (S (S (tail_mul sixteen acc))))))) | Hexadecimal.D7 d => of_hex_uint_acc d (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))) | Hexadecimal.D8 d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))) | Hexadecimal.D9 d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))))) | Hexadecimal.Da d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))))) | Hexadecimal.Db d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))))))) | Hexadecimal.Dc d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))))))) | Hexadecimal.Dd d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))))))))) | Hexadecimal.De d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))))))))) | Hexadecimal.Df d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))))))))))) end. Definition of_hex_uint (d:Hexadecimal.uint) := of_hex_uint_acc d O. Definition of_num_uint (d:Numeral.uint) := match d with | Numeral.UIntDec d => of_uint d | Numeral.UIntHex d => of_hex_uint d end. Fixpoint to_little_uint n acc := match n with | O => acc | S n => to_little_uint n (Decimal.Little.succ acc) end. Definition to_uint n := Decimal.rev (to_little_uint n Decimal.zero). Definition to_num_uint n := Numeral.UIntDec (to_uint n). Definition of_int (d:Decimal.int) : option nat := match Decimal.norm d with | Decimal.Pos u => Some (of_uint u) | _ => None end. Definition of_hex_int (d:Hexadecimal.int) : option nat := match Hexadecimal.norm d with | Hexadecimal.Pos u => Some (of_hex_uint u) | _ => None end. Definition of_num_int (d:Numeral.int) : option nat := match d with | Numeral.IntDec d => of_int d | Numeral.IntHex d => of_hex_int d end. Definition to_int n := Decimal.Pos (to_uint n). Definition to_num_int n := Numeral.IntDec (to_int n). Arguments of_uint d%_dec_uint_scope. Arguments of_int d%_dec_int_scope. (* Parsing / printing of [nat] numbers *) Number Notation nat of_num_uint to_num_uint (abstract after 5001) : nat_scope. Coq-HoTT-9.0/theories/Basics/Notations.v000066400000000000000000000305071474641544500201360ustar00rootroot00000000000000(** [type_scope] must be declared and bound early on so that later reserved notations register correctly. *) Declare Scope type_scope. Bind Scope type_scope with Sortclass. (** To reserve this notation, we must first bootstrap, and preserve the underlying [forall] notation *) Notation "'forall' x .. y , P" := (forall x , .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity). Reserved Notation "'exists' x .. y , p" (at level 200, x binder, right associativity, format "'[' 'exists' '/ ' x .. y , '/ ' p ']'"). (** Work around bug 5569, https://coq.inria.fr/bugs/show_bug.cgi?id=5569, Warning skip-spaces-curly,parsing seems bogus *) Local Set Warnings Append "-skip-spaces-curly". (** These are the notations whose level and associativity are imposed by Coq *) (** Notations for propositional connectives *) Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x <-> y" (at level 95, no associativity). Reserved Notation "x /\ y" (at level 80, right associativity). Reserved Notation "x \/ y" (at level 85, right associativity). Reserved Notation "x |_| y" (at level 85, right associativity). Reserved Notation "~ x" (at level 35, right associativity). (** Notations for equality and inequalities *) Reserved Notation "x = y :> T" (at level 70, y at next level, no associativity). Reserved Notation "x = y" (at level 70, no associativity). Reserved Notation "x = y = z" (at level 70, no associativity, y at next level). Reserved Notation "x <> y :> T" (at level 70, y at next level, no associativity). Reserved Notation "x <> y" (at level 70, no associativity). Reserved Notation "x <= y" (at level 70, no associativity). Reserved Notation "x < y" (at level 70, no associativity). Reserved Notation "x >= y" (at level 70, no associativity). Reserved Notation "x > y" (at level 70, no associativity). Reserved Notation "x <= y <= z" (at level 70, y at next level). Reserved Notation "x <= y < z" (at level 70, y at next level). Reserved Notation "x < y < z" (at level 70, y at next level). Reserved Notation "x < y <= z" (at level 70, y at next level). (** Arithmetical notations (also used for type constructors) *) Reserved Notation "x + y" (at level 50, left associativity). Reserved Notation "x - y" (at level 50, left associativity). Reserved Notation "x * y" (at level 40, left associativity). Reserved Notation "x / y" (at level 40, no associativity). Reserved Notation "- x" (at level 35, right associativity). Reserved Notation "/ x" (at level 35, right associativity). (** Notations for booleans *) Reserved Notation "x || y" (at level 50, left associativity). Reserved Notation "x && y" (at level 40, left associativity). (** Notations for pairs *) Reserved Notation "( x , y , .. , z )" (at level 0). (** Notation "{ x }" is reserved and has a special status as component of other notations such as "{ A } + { B }" and "A + { B }" (which are at the same level as "x + y"); "{ x }" is at level 0 to factor with "{ x : A | P }" *) Reserved Notation "{ x }" (at level 0, x at level 99). (** Notations for sigma-types or subsets *) Reserved Notation "{ x | P }" (at level 0, x at level 99). Reserved Notation "{ x | P & Q }" (at level 0, x at level 99). Reserved Notation "{ x : A | P }" (at level 0, x at level 99). Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99). Reserved Notation "{ x : A & P }" (at level 0, x at level 99). Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). (** Numeric *) Reserved Notation "n .+1" (at level 1, left associativity, format "n .+1"). Reserved Notation "n .+2" (at level 1, left associativity, format "n .+2"). Reserved Notation "n .+3" (at level 1, left associativity, format "n .+3"). Reserved Notation "n .+4" (at level 1, left associativity, format "n .+4"). Reserved Notation "n .+5" (at level 1, left associativity, format "n .+5"). Reserved Notation "n '.-1'" (at level 1, left associativity, format "n .-1"). Reserved Notation "n '.-2'" (at level 1, left associativity, format "n .-2"). Reserved Notation "m +2+ n" (at level 50, left associativity). Reserved Infix "mod" (at level 40, no associativity). Reserved Notation "p ~ 1" (at level 1, left associativity, format "p '~' '1'"). Reserved Notation "p ~ 0" (at level 1, left associativity, format "p '~' '0'"). (** Pointed *) Reserved Infix "@*" (at level 30). Reserved Infix "@@*" (at level 30). Reserved Infix "<~>*" (at level 85). Reserved Infix "->*" (at level 99). Reserved Infix "->**" (at level 99). Reserved Infix "o*" (at level 40, left associativity). Reserved Infix "==*" (at level 70, no associativity). Reserved Notation "g ^*'" (at level 1). Reserved Notation "f ^*" (at level 1, format "f '^*'"). Reserved Notation "f ^-1*" (at level 1, format "f '^-1*'"). Reserved Notation "g o*E f" (at level 40, left associativity). Reserved Notation "'ppforall' x .. y , P" (at level 200, x binder, y binder, right associativity). (** Sigma type *) Reserved Notation "x .1" (at level 1, format "x '.1'"). Reserved Notation "x .2" (at level 1, format "x '.2'"). (** Paths *) Reserved Notation "p ^" (at level 1, format "p '^'"). Reserved Notation "p @ q" (at level 20). Reserved Notation "p # x" (right associativity, at level 65). Reserved Notation "p # x" (right associativity, at level 65). Reserved Notation "p @@ q" (at level 20). Reserved Notation "p @' q" (at level 21, left associativity, format "'[v' p '/' '@'' q ']'"). Reserved Notation "f == g" (at level 70, no associativity). (** Equivalences *) Reserved Notation "A <~> B" (at level 85). Reserved Notation "f ^-1" (at level 1, format "f '^-1'"). Reserved Notation "g 'oE' f" (at level 40, left associativity). Reserved Notation "f *E g" (at level 40, left associativity). Reserved Notation "f +E g" (at level 50, left associativity). (** Categories *) Reserved Infix "-|" (at level 60, right associativity). Reserved Infix "<~=~>" (at level 70, no associativity). #[warnings="-postfix-notation-not-level-1"] Reserved Notation "a // 'CAT'" (at level 40, left associativity). #[warnings="-postfix-notation-not-level-1"] Reserved Notation "a \\ 'CAT'" (at level 40, left associativity). Reserved Notation "'CAT' // a" (at level 40, left associativity). Reserved Notation "'CAT' \\ a" (at level 40, left associativity). Reserved Notation "C ^op" (at level 1, format "C '^op'"). (** Universal algebra *) Reserved Notation "u .# A" (at level 3, format "u '.#' A"). (** Natural numbers *) Reserved Infix "=n" (at level 70, no associativity). (** Wild cat *) Reserved Infix "$->" (at level 99). Reserved Infix "$<~>" (at level 85). Reserved Infix "$o" (at level 40, left associativity). Reserved Infix "$oE" (at level 40, left associativity). Reserved Infix "$==" (at level 70). Reserved Infix "$o@" (at level 30). Reserved Infix "$@" (at level 30). Reserved Infix "$@L" (at level 30). Reserved Infix "$@R" (at level 30). Reserved Infix "$@@" (at level 30). Reserved Infix "$=>" (at level 99). Reserved Notation "T ^op" (at level 1, format "T ^op"). Reserved Notation "f ^-1$" (at level 1, format "f '^-1$'"). Reserved Notation "f ^$" (at level 1, format "f '^$'"). Reserved Infix "$@h" (at level 35). Reserved Infix "$@v" (at level 35). Reserved Infix "$@hR" (at level 34). Reserved Infix "$@hL" (at level 34). Reserved Infix "$@vR" (at level 34). Reserved Infix "$@vL" (at level 34). Reserved Notation "s ^h$" (at level 1). Reserved Notation "s ^v$" (at level 1). (** Displayed wild cat *) Reserved Infix "$o'" (at level 40, left associativity). Reserved Infix "$@'" (at level 30). Reserved Infix "$@L'" (at level 30). Reserved Infix "$@R'" (at level 30). Reserved Infix "$@@'" (at level 30). Reserved Infix "$oE'" (at level 40, left associativity). Reserved Notation "f ^$'" (at level 1, format "f '^$''"). Reserved Notation "f ^-1$'" (at level 1, format "f '^-1$''"). (** Cubical *) Reserved Infix "@@h" (at level 30). Reserved Infix "@@v" (at level 30). Reserved Infix "@lr" (at level 30). Reserved Notation "x '@Dp' y" (at level 20). Reserved Notation "x '@Dr' y" (at level 20). Reserved Notation "x '@Dl' y" (at level 20). Reserved Notation "x '^D'" (at level 1). (** Lists *) Reserved Infix "::" (at level 60, right associativity). Reserved Infix "++" (right associativity, at level 60). Reserved Notation "[ u ]" (at level 0). Reserved Notation " [ u , v ] " (at level 0). (** Algebra *) Reserved Infix "*L" (at level 40). Reserved Infix "*R" (at level 40). (** Type Family Extensions *) Reserved Notation "P <| j" (at level 40). Reserved Notation "P |> j" (at level 40). Reserved Notation "P >=> R" (at level 55). (** Other / Not sorted yet *) Reserved Infix "<=>" (at level 70). Reserved Infix "<<" (at level 70). Reserved Infix "<<<" (at level 70). Reserved Infix "oL" (at level 40, left associativity). Reserved Infix "oR" (at level 40, left associativity). Reserved Notation "~~ A" (at level 35, right associativity). Reserved Notation "a \ C" (at level 40, left associativity). Reserved Notation "a <=_{ x } b" (at level 70, no associativity). Reserved Notation "D1 ~d~ D2" (at level 65). Reserved Notation "D '_f' g" (at level 10). Reserved Notation "F '_0' x" (at level 10, no associativity). Reserved Notation "F '_0' x" (at level 10, no associativity). Reserved Notation "F '_1' m" (at level 10, no associativity). Reserved Notation "F ^op" (at level 1, format "F ^op"). Reserved Notation "'forall' x .. y , P" (at level 200, x binder, y binder, right associativity). Reserved Notation "g 'oD' f" (at level 40, left associativity). Reserved Notation "g 'o' f" (at level 40, left associativity). Reserved Notation "m <= n" (at level 70, no associativity). Reserved Notation "n -Type" (at level 1). Reserved Notation "p ..1" (at level 1). Reserved Notation "p ..2" (at level 1). Reserved Notation "!! P" (at level 35, right associativity). Reserved Notation "u ~~ v" (at level 30). Reserved Notation "! x" (at level 3, format "'!' x"). Reserved Notation "x \\ F" (at level 40, left associativity). Reserved Notation "x // F" (at level 40, left associativity). Reserved Notation "{ { xL | xR // xcut } }" (at level 0, xR at level 39, format "{ { xL | xR // xcut } }"). Reserved Notation "x \ F" (at level 40, left associativity). Reserved Notation "x <> y" (at level 70, no associativity). Reserved Notation "x ->> y" (at level 99, right associativity, y at level 200). Reserved Notation "x -|-> y" (at level 99, right associativity, y at level 200). Reserved Notation "x --> y" (at level 55, right associativity, y at level 55). Reserved Notation "x (-> y" (at level 99, right associativity, y at level 200). Reserved Notation "x <> y :> T" (at level 70, y at next level, no associativity). Reserved Notation "Z ** W" (at level 30, right associativity). Reserved Notation "'+N'" (at level 0). Reserved Notation "'+Z'" (at level 0). Reserved Notation "'N3'" (at level 0). Reserved Notation "'Z3'" (at level 0). Reserved Notation "a ^+" (at level 1). Reserved Notation "a ^+ k" (at level 1). Reserved Notation "x ^++" (at level 1). Reserved Notation "x ^++ k" (at level 1). Reserved Notation "b ^+f" (at level 1). (** Mathclasses *) Reserved Notation "' x" (at level 20). Reserved Notation "// x" (at level 40, no associativity). Reserved Infix "?=" (at level 70, no associativity). Reserved Infix "=?" (at level 70, no associativity). Reserved Infix " O | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => S (nb_digits d) end. (** This representation favors simplicity over canonicity. For normalizing numbers, we need to remove head zero digits, and choose our canonical representation of 0 (here [D0 Nil] for unsigned numbers and [Pos (D0 Nil)] for signed numbers). *) (** [nzhead] removes all head zero digits *) Fixpoint nzhead d := match d with | D0 d => nzhead d | _ => d end. (** [unorm] : normalization of unsigned integers *) Definition unorm d := match nzhead d with | Nil => zero | d => d end. (** [norm] : normalization of signed integers *) Definition norm d := match d with | Pos d => Pos (unorm d) | Neg d => match nzhead d with | Nil => Pos zero | d => Neg d end end. (** A few easy operations. For more advanced computations, use the conversions with other Coq numeral datatypes (e.g. Z) and the operations on them. *) Definition opp (d:int) := match d with | Pos d => Neg d | Neg d => Pos d end. (** For conversions with binary numbers, it is easier to operate on little-endian numbers. *) Fixpoint revapp (d d' : uint) := match d with | Nil => d' | D0 d => revapp d (D0 d') | D1 d => revapp d (D1 d') | D2 d => revapp d (D2 d') | D3 d => revapp d (D3 d') | D4 d => revapp d (D4 d') | D5 d => revapp d (D5 d') | D6 d => revapp d (D6 d') | D7 d => revapp d (D7 d') | D8 d => revapp d (D8 d') | D9 d => revapp d (D9 d') end. Definition rev d := revapp d Nil. Definition app d d' := revapp (rev d) d'. Definition app_int d1 d2 := match d1 with Pos d1 => Pos (app d1 d2) | Neg d1 => Neg (app d1 d2) end. (** [nztail] removes all trailing zero digits and return both the result and the number of removed digits. *) Definition nztail d := let fix aux d_rev := match d_rev with | D0 d_rev => let (r, n) := aux d_rev in pair r (S n) | _ => pair d_rev O end in let (r, n) := aux (rev d) in pair (rev r) n. Definition nztail_int d := match d with | Pos d => let (r, n) := nztail d in pair (Pos r) n | Neg d => let (r, n) := nztail d in pair (Neg r) n end. Module Little. (** Successor of little-endian numbers *) Fixpoint succ d := match d with | Nil => D1 Nil | D0 d => D1 d | D1 d => D2 d | D2 d => D3 d | D3 d => D4 d | D4 d => D5 d | D5 d => D6 d | D6 d => D7 d | D7 d => D8 d | D8 d => D9 d | D9 d => D0 (succ d) end. (** Doubling little-endian numbers *) Fixpoint double d := match d with | Nil => Nil | D0 d => D0 (double d) | D1 d => D2 (double d) | D2 d => D4 (double d) | D3 d => D6 (double d) | D4 d => D8 (double d) | D5 d => D0 (succ_double d) | D6 d => D2 (succ_double d) | D7 d => D4 (succ_double d) | D8 d => D6 (succ_double d) | D9 d => D8 (succ_double d) end with succ_double d := match d with | Nil => D1 Nil | D0 d => D1 (double d) | D1 d => D3 (double d) | D2 d => D5 (double d) | D3 d => D7 (double d) | D4 d => D9 (double d) | D5 d => D1 (succ_double d) | D6 d => D3 (succ_double d) | D7 d => D5 (succ_double d) | D8 d => D7 (succ_double d) | D9 d => D9 (succ_double d) end. End Little. (** Pseudo-conversion functions used when declaring Numeral Notations on [uint] and [int]. *) Definition uint_of_uint (i:uint) := i. Definition int_of_int (i:int) := i. Coq-HoTT-9.0/theories/Basics/Numerals/Hexadecimal.v000066400000000000000000000150361474641544500221520ustar00rootroot00000000000000(************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) (* v * Copyright INRIA, CNRS and contributors *) (* O | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d | Da d | Db d | Dc d | Dd d | De d | Df d => S (nb_digits d) end. (** This representation favors simplicity over canonicity. For normalizing numbers, we need to remove head zero digits, and choose our canonical representation of 0 (here [D0 Nil] for unsigned numbers and [Pos (D0 Nil)] for signed numbers). *) (** [nzhead] removes all head zero digits *) Fixpoint nzhead d := match d with | D0 d => nzhead d | _ => d end. (** [unorm] : normalization of unsigned integers *) Definition unorm d := match nzhead d with | Nil => zero | d => d end. (** [norm] : normalization of signed integers *) Definition norm d := match d with | Pos d => Pos (unorm d) | Neg d => match nzhead d with | Nil => Pos zero | d => Neg d end end. (** A few easy operations. For more advanced computations, use the conversions with other Coq numeral datatypes (e.g. Z) and the operations on them. *) Definition opp (d:int) := match d with | Pos d => Neg d | Neg d => Pos d end. (** For conversions with binary numbers, it is easier to operate on little-endian numbers. *) Fixpoint revapp (d d' : uint) := match d with | Nil => d' | D0 d => revapp d (D0 d') | D1 d => revapp d (D1 d') | D2 d => revapp d (D2 d') | D3 d => revapp d (D3 d') | D4 d => revapp d (D4 d') | D5 d => revapp d (D5 d') | D6 d => revapp d (D6 d') | D7 d => revapp d (D7 d') | D8 d => revapp d (D8 d') | D9 d => revapp d (D9 d') | Da d => revapp d (Da d') | Db d => revapp d (Db d') | Dc d => revapp d (Dc d') | Dd d => revapp d (Dd d') | De d => revapp d (De d') | Df d => revapp d (Df d') end. Definition rev d := revapp d Nil. Definition app d d' := revapp (rev d) d'. Definition app_int d1 d2 := match d1 with Pos d1 => Pos (app d1 d2) | Neg d1 => Neg (app d1 d2) end. (** [nztail] removes all trailing zero digits and return both the result and the number of removed digits. *) Definition nztail d := let fix aux d_rev := match d_rev with | D0 d_rev => let (r, n) := aux d_rev in pair r (S n) | _ => pair d_rev O end in let (r, n) := aux (rev d) in pair (rev r) n. Definition nztail_int d := match d with | Pos d => let (r, n) := nztail d in pair (Pos r) n | Neg d => let (r, n) := nztail d in pair (Neg r) n end. Module Little. (** Successor of little-endian numbers *) Fixpoint succ d := match d with | Nil => D1 Nil | D0 d => D1 d | D1 d => D2 d | D2 d => D3 d | D3 d => D4 d | D4 d => D5 d | D5 d => D6 d | D6 d => D7 d | D7 d => D8 d | D8 d => D9 d | D9 d => Da d | Da d => Db d | Db d => Dc d | Dc d => Dd d | Dd d => De d | De d => Df d | Df d => D0 (succ d) end. (** Doubling little-endian numbers *) Fixpoint double d := match d with | Nil => Nil | D0 d => D0 (double d) | D1 d => D2 (double d) | D2 d => D4 (double d) | D3 d => D6 (double d) | D4 d => D8 (double d) | D5 d => Da (double d) | D6 d => Dc (double d) | D7 d => De (double d) | D8 d => D0 (succ_double d) | D9 d => D2 (succ_double d) | Da d => D4 (succ_double d) | Db d => D6 (succ_double d) | Dc d => D8 (succ_double d) | Dd d => Da (succ_double d) | De d => Dc (succ_double d) | Df d => De (succ_double d) end with succ_double d := match d with | Nil => D1 Nil | D0 d => D1 (double d) | D1 d => D3 (double d) | D2 d => D5 (double d) | D3 d => D7 (double d) | D4 d => D9 (double d) | D5 d => Db (double d) | D6 d => Dd (double d) | D7 d => Df (double d) | D8 d => D1 (succ_double d) | D9 d => D3 (succ_double d) | Da d => D5 (succ_double d) | Db d => D7 (succ_double d) | Dc d => D9 (succ_double d) | Dd d => Db (succ_double d) | De d => Dd (succ_double d) | Df d => Df (succ_double d) end. End Little. Coq-HoTT-9.0/theories/Basics/Overture.v000066400000000000000000001123771474641544500200010ustar00rootroot00000000000000(** * Basic definitions of homotopy type theory *) (** This file defines some of the most basic types and type formers, such as sums, products, Sigma types and path types. It defines the action of functions on paths [ap], transport, equivalences, and function extensionality. It also defines truncatedness, and a number of other fundamental definitions used throughout the library. *) (** Import the file of reserved notations so we maintain consistent level notations throughout the library. *) Require Export Basics.Settings Basics.Notations. Local Set Polymorphic Inductive Cumulativity. (** This command prevents Coq from automatically defining the eliminator functions for inductive types. We will define them ourselves to match the naming scheme of the HoTT Book. In principle we ought to make this [Global], but unfortunately the tactics [induction] and [elim] assume that the eliminators are named in Coq's way, e.g. [thing_rect], so making it global could cause unpleasant surprises for people defining new inductive types. However, when you do define your own inductive types you are encouraged to also do [Local Unset Elimination Schemes] and then use [Scheme] to define [thing_ind], [thing_rec], and (for compatibility with [induction] and [elim]) [thing_rect], as we have done below for [paths], [Empty], [Unit], etc. We are hoping that this will be fixed eventually; see https://github.com/coq/coq/issues/3745. *) Local Unset Elimination Schemes. (** ** Datatypes *) (** *** Functions *) (** Notation for non-dependent function types *) Notation "A -> B" := (forall (_ : A), B) : type_scope. (** *** Option type *) (** [option A] is the extension of [A] with an extra element [None] *) Inductive option (A : Type) : Type := | Some : A -> option A | None : option A. Scheme option_rect := Induction for option Sort Type. Arguments Some {A} a. Arguments None {A}. Register option as core.option.type. (** *** Sum type *) (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *) Inductive sum (A B : Type) : Type := | inl : A -> sum A B | inr : B -> sum A B. Scheme sum_rect := Induction for sum Sort Type. Scheme sum_ind := Induction for sum Sort Type. Arguments sum_ind {A B} P f g : rename. Notation "x + y" := (sum x y) : type_scope. Arguments inl {A B} _ , [A] B _. Arguments inr {A B} _ , A [B] _. (* A notation for coproduct that's less overloaded than [+] *) Notation "x |_| y" := (sum x y) (only parsing) : type_scope. (** *** Product type *) (** [prod A B], written [A * B], is the product of [A] and [B]; the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *) Record prod (A B : Type) := pair { fst : A ; snd : B }. Scheme prod_rect := Induction for prod Sort Type. Scheme prod_ind := Induction for prod Sort Type. Arguments prod_ind {A B} P _. Arguments pair {A B} _ _. Arguments fst {A B} _ / . Arguments snd {A B} _ / . Add Printing Let prod. Notation "x * y" := (prod x y) : type_scope. Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. Notation "A /\ B" := (prod A B) (only parsing) : type_scope. Notation and := prod (only parsing). Notation conj := pair (only parsing). #[export] Hint Resolve pair inl inr : core. (** ** Type classes *) (** This command prevents Coq from trying to guess the values of existential variables while doing typeclass resolution. If you don't know what that means, ignore it. *) Local Set Typeclasses Strict Resolution. Definition Relation (A : Type) := A -> A -> Type. Class Reflexive {A} (R : Relation A) := reflexivity : forall x : A, R x x. Class Symmetric {A} (R : Relation A) := symmetry : forall x y, R x y -> R y x. Class Transitive {A} (R : Relation A) := transitivity : forall x y z, R x y -> R y z -> R x z. (** A [PreOrder] is both Reflexive and Transitive. *) Class PreOrder {A} (R : Relation A) := { PreOrder_Reflexive : Reflexive R | 2 ; PreOrder_Transitive : Transitive R | 2 }. Global Existing Instance PreOrder_Reflexive. Global Existing Instance PreOrder_Transitive. Arguments reflexivity {A R _} / _. Arguments symmetry {A R _} / _ _ _. Arguments transitivity {A R _} / {_ _ _} _ _. (** Above, we have made [reflexivity], [symmetry], and [transitivity] reduce under [cbn]/[simpl] to their underlying instances. This allows the tactics to build proof terms referencing, e.g., [concat]. We use [change] after the fact to make sure that we didn't [cbn] away the original form of the relation. If we want to remove the use of [cbn], we can play tricks with [Module Type]s and [Module]s to declare [inverse] directly as an instance of [Symmetric] without changing its type. Then we can simply [unfold symmetry]. See the comments around the definition of [inverse]. *) (** Overwrite [reflexivity] so that we use our version of [Reflexive] rather than having the tactic look for it in the standard library. We make use of the built-in reflexivity to handle, e.g., single-constructor inductives. *) Ltac old_reflexivity := reflexivity. Tactic Notation "reflexivity" := old_reflexivity || (intros; let R := match goal with |- ?R ?x ?y => constr:(R) end in let pre_proof_term_head := constr:(@reflexivity _ R _) in let proof_term_head := (eval cbn in pre_proof_term_head) in apply (proof_term_head : forall x, R x x)). (** Even if we weren't using [cbn], we would have to redefine symmetry, since the built-in Coq version is sometimes too smart for its own good, and will occasionally fail when it should not. *) Tactic Notation "symmetry" := let R := match goal with |- ?R ?x ?y => constr:(R) end in let x := match goal with |- ?R ?x ?y => constr:(x) end in let y := match goal with |- ?R ?x ?y => constr:(y) end in let pre_proof_term_head := constr:(@symmetry _ R _) in let proof_term_head := (eval cbn in pre_proof_term_head) in refine (proof_term_head y x _); change (R y x). Tactic Notation "etransitivity" open_constr(y) := let R := match goal with |- ?R ?x ?z => constr:(R) end in let x := match goal with |- ?R ?x ?z => constr:(x) end in let z := match goal with |- ?R ?x ?z => constr:(z) end in let pre_proof_term_head := constr:(@transitivity _ R _) in let proof_term_head := (eval cbn in pre_proof_term_head) in refine (proof_term_head x y z _ _); [ change (R x y) | change (R y z) ]. Tactic Notation "etransitivity" := etransitivity _. (** We redefine [transitivity] to work without needing to include [Setoid] or be using Leibniz equality, and to give proofs that unfold to [concat]. *) Tactic Notation "transitivity" constr(x) := etransitivity x. (** ** Basic definitions *) (** Define an alias for [Set], which is really [Type₀]. *) Notation Type0 := Set. (** We make the identity map a notation so we do not have to unfold it, or complicate matters with its type. *) Notation idmap := (fun x => x). (** *** Constant functions *) Definition const {A B} (b : B) := fun x : A => b. (** ** Sigma types *) (** [(sig A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. *) Record sig {A} (P : A -> Type) := exist { proj1 : A ; proj2 : P proj1 ; }. Scheme sig_rect := Induction for sig Sort Type. Scheme sig_ind := Induction for sig Sort Type. Scheme sig_rec := Minimality for sig Sort Type. Arguments sig_ind {_ _}. Arguments sig_rec {_ _ _}. (** We make the parameters maximally inserted so that we can pass around [pr1] as a function and have it actually mean "first projection" in, e.g., [ap]. *) Arguments exist {A}%_type P%_type _ _. Arguments proj1 {A P} _ / . Arguments proj2 {A P} _ / . Arguments sig (A P)%_type. Notation "{ x | P }" := (sig (fun x => P)) : type_scope. Notation "{ x : A | P }" := (sig (A := A) (fun x => P)) : type_scope. Notation "'exists' x .. y , p" := (sig (fun x => .. (sig (fun y => p)) ..)) : type_scope. Notation "{ x : A & P }" := (sig (fun x:A => P)) : type_scope. (** This lets us pattern match sigma types in let expressions *) Add Printing Let sig. Register sig as core.sigT.type. Register exist as core.sigT.intro. Register sig_rect as core.sigT.rect. Register proj1 as core.sigT.proj1. Register proj2 as core.sigT.proj2. #[export] Hint Resolve exist : core. (** We define notation for dependent pairs because it is too annoying to write and see [exist P x y] all the time. However, we put it in its own scope, because sometimes it is necessary to give the particular dependent type, so we'd like to be able to turn off this notation selectively. *) Notation "( x ; y )" := (exist _ x y) : fibration_scope. Notation "( x ; .. ; y ; z )" := (exist _ x .. (exist _ y z) ..) : fibration_scope. (** We bind [fibration_scope] with [sig] so that we are automatically in [fibration_scope] when we are passing an argument of type [sig]. *) Bind Scope fibration_scope with sig. Notation pr1 := proj1. Notation pr2 := proj2. (** The following notation is very convenient, although it unfortunately clashes with Proof General's "electric period". We have added [format] specifiers in Notations.v so that it will display without an extra space, as [x.1] rather than as [x .1]. *) Notation "x .1" := (pr1 x) : fibration_scope. Notation "x .2" := (pr2 x) : fibration_scope. Definition uncurry {A B C} (f : A -> B -> C) (p : A * B) : C := f (fst p) (snd p). Arguments uncurry {A B C} f%_function_scope p /. (** Composition of functions. *) Notation compose := (fun g f x => g (f x)). (** We put the following notation in a scope because leaving it unscoped causes it to override identical notations in other scopes. It's convenient to use the same notation for, e.g., function composition, morphism composition in a category, and functor composition, and let Coq automatically infer which one we mean by scopes. We can't do this if this notation isn't scoped. Unfortunately, Coq doesn't have a built-in [function_scope] like [type_scope]; [type_scope] is automatically opened wherever Coq is expecting a [Sort], and it would be nice if [function_scope] were automatically opened whenever Coq expects a thing of type [forall _, _] or [_ -> _]. To work around this, we open [function_scope] globally. *) (** We allow writing [(f o g)%function] to force [function_scope] over, e.g., [morphism_scope]. *) Notation "g 'o' f" := (compose g%function f%function) : function_scope. (** This definition helps guide typeclass inference. *) Definition Compose {A B C : Type} (g : B -> C) (f : A -> B) : A -> C := compose g f. (** Dependent composition of functions. *) Definition composeD {A B C} (g : forall b, C b) (f : A -> B) := fun x : A => g (f x). Global Arguments composeD {A B C}%_type_scope (g f)%_function_scope x. #[export] Hint Unfold composeD : core. Notation "g 'oD' f" := (composeD g f) : function_scope. (** ** The groupoid structure of identity types. *) (** The results in this file are used everywhere else, so we need to be extra careful about how we define and prove things. We prefer hand-written terms, or at least tactics that allow us to retain clear control over the proof-term produced. *) (** We define our own identity type, rather than using the one in the Coq standard library, so as to have more control over transitivity, symmetry and inverse. It seems impossible to change these for the standard eq/identity type (or its Type-valued version) because it breaks various other standard things. Merely changing notations also doesn't seem to quite work. *) Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. Arguments idpath {A a} , [A] a. #[export] Hint Resolve idpath : core. Scheme paths_ind := Induction for paths Sort Type. Arguments paths_ind [A] a P f y p : rename. Scheme paths_rec := Minimality for paths Sort Type. Arguments paths_rec [A] a P f y p : rename. (* See comment above about the tactic [induction]. *) Definition paths_rect := paths_ind. Register paths as core.identity.type. Register idpath as core.identity.refl. Register paths_rect as core.identity.ind. Notation "x = y :> A" := (@paths A x y) : type_scope. Notation "x = y" := (x = y :>_) : type_scope. Global Instance reflexive_paths {A} : Reflexive (@paths A) | 0 := @idpath A. Arguments reflexive_paths / . (** Our identity type is the Paulin-Mohring style. We derive the Martin-Lof eliminator. *) Definition paths_ind' {A : Type} (P : forall (a b : A), (a = b) -> Type) : (forall (a : A), P a a idpath) -> forall (a b : A) (p : a = b), P a b p. Proof. intros H ? ? []. apply H. Defined. (** And here's the "right-sided" Paulin-Mohring eliminator. *) Definition paths_ind_r {A : Type} (a : A) (P : forall b : A, b = a -> Type) (u : P a idpath) : forall (y : A) (p : y = a), P y p. Proof. intros y p. destruct p. exact u. Defined. (** We declare a scope in which we shall place path notations. This way they can be turned on and off by the user. *) (** We bind [path_scope] to [paths] so that when we are constructing arguments to things like [concat], we automatically are in [path_scope]. *) Bind Scope path_scope with paths. Local Open Scope path_scope. (** The inverse of a path. *) Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end. Register inverse as core.identity.sym. (** Declaring this as [simpl nomatch] prevents the tactic [simpl] from expanding it out into [match] statements. We only want [inverse] to simplify when applied to an identity path. *) Arguments inverse {A x y} p : simpl nomatch. Global Instance symmetric_paths {A} : Symmetric (@paths A) | 0 := @inverse A. Arguments symmetric_paths / . (** If we wanted to not have the constant [symmetric_paths] floating around, and wanted to resolve [inverse] directly, instead, we could play this trick, discovered by Georges Gonthier to fool Coq's restriction on [Identity Coercion]s: << Module Export inverse. Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end. End inverse. Module Type inverseT. Parameter inverse : forall {A}, Symmetric (@paths A). End inverseT. Module inverseSymmetric (inverse : inverseT). Global Existing Instance inverse.inverse. End inverseSymmetric. Module Export symmetric_paths := inverseSymmetric inverse. >> *) (** We define equality concatenation by destructing on both its arguments, so that it only computes when both arguments are [idpath]. This makes proofs more robust and symmetrical. Compare with the definition of [identity_trans]. *) Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. (** See above for the meaning of [simpl nomatch]. *) Arguments concat {A x y z} p q : simpl nomatch. Global Instance transitive_paths {A} : Transitive (@paths A) | 0 := @concat A. Arguments transitive_paths / . Register concat as core.identity.trans. (** Note that you can use the Coq tactics [reflexivity], [transitivity], [etransitivity], and [symmetry] when working with paths; we've redefined them above to use typeclasses and to unfold the instances so you get proof terms with [concat] and [inverse]. *) (** The identity path. *) Notation "1" := idpath : path_scope. (** The composition of two paths. *) (** We put [p] and [q] in [path_scope] explicitly. This is a partial work-around for https://coq.inria.fr/bugs/show_bug.cgi?id=3990, which is that implicitly bound scopes don't nest well. *) Notation "p @ q" := (concat p%path q%path) : path_scope. (** The inverse of a path. *) (** See above about explicitly placing [p] in [path_scope]. *) Notation "p ^" := (inverse p%path) : path_scope. (** An alternative notation which puts each path on its own line, via the [format] specification in Notations.v. Useful as a temporary device during proofs of equalities between very long composites; to turn it on inside a section, say [Open Scope long_path_scope]. *) Notation "p @' q" := (concat p q) : long_path_scope. (** An important instance of [paths_ind] is that given any dependent type, one can _transport_ elements of instances of the type along equalities in the base: [transport P p u] transports [u : P x] to [P y] along [p : x = y]. *) Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. (** See above for the meaning of [simpl nomatch]. *) Arguments transport {A}%_type_scope P%_function_scope {x y} p%_path_scope u : simpl nomatch. (** Transport is very common so it is worth introducing a parsing notation for it. However, we do not use the notation for output because it hides the fibration, and so makes it very hard to read involved transport expression. *) Notation "p # u" := (transport _ p u) (only parsing) : path_scope. (** The first time [rewrite] is used in each direction, it creates transport lemmas called [internal_paths_rew] and [internal_paths_rew_r]. See ../Tactics.v for how these compare to [transport]. We use [rewrite] here to trigger the creation of these lemmas. This ensures that they are defined outside of sections, so they are not unnecessarily polymorphic. The lemmas below are not used in the library. *) (** TODO: If Coq PR#18299 is merged (possibly in Coq 8.20), then we can instead register wrappers for [transport] to be used for rewriting. See the comment by Dan Christensen in that PR for how to do this. Then the tactics [internal_paths_rew_to_transport] and [rewrite_to_transport] can be removed from ../Tactics.v. *) Local Lemma define_internal_paths_rew A x y P (u : P x) (H : x = y :> A) : P y. Proof. rewrite <- H. exact u. Defined. Local Lemma define_internal_paths_rew_r A x y P (u : P y) (H : x = y :> A) : P x. Proof. rewrite -> H. exact u. Defined. Arguments internal_paths_rew {A%_type_scope} {a} P%_function_scope f {a0} p. Arguments internal_paths_rew_r {A%_type_scope} {a y} P%_function_scope HC X. (** Having defined transport, we can use it to talk about what a homotopy theorist might see as "paths in a fibration over paths in the base"; and what a type theorist might see as "heterogeneous equality in a dependent type". We will first see this appearing in the type of [apD]. *) (** Functions act on paths: if [f : A -> B] and [p : x = y] is a path in [A], then [ap f p : f x = f y]. We typically pronounce [ap] as a single syllable, short for "application"; but it may also be considered as an acronym, "action on paths". *) Definition ap {A B : Type} (f : A -> B) {x y : A} (p : x = y) : f x = f y := match p with idpath => idpath end. Global Arguments ap {A B}%_type_scope f%_function_scope {x y} p%_path_scope : simpl nomatch. Register ap as core.identity.congr. (** We introduce the convention that [apKN] denotes the application of a K-path between functions to an N-path between elements, where a 0-path is simply a function or an element. Thus, [ap] is a shorthand for [ap01]. *) Notation ap01 := ap (only parsing). (** Similarly, dependent functions act on paths; but the type is a bit more subtle. If [f : forall a:A, B a] and [p : x = y] is a path in [A], then [apD f p] should somehow be a path between [f x : B x] and [f y : B y]. Since these live in different types, we use transport along [p] to make them comparable: [apD f p : p # f x = f y]. The type [p # f x = f y] can profitably be considered as a heterogeneous or dependent equality type, of "paths from [f x] to [f y] over [p]". *) Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y): p # (f x) = f y := match p with idpath => idpath end. (** See above for the meaning of [simpl nomatch]. *) Arguments apD {A%_type_scope B} f%_function_scope {x y} p%_path_scope : simpl nomatch. (** *** Homotopies between functions *) Definition pointwise_paths A (P : A -> Type) (f g : forall x, P x) := forall x, f x = g x. Definition pointwise_paths_concat {A} {P : A -> Type} {f g h : forall x, P x} : pointwise_paths A P f g -> pointwise_paths A P g h -> pointwise_paths A P f h := fun p q x => p x @ q x. Global Instance reflexive_pointwise_paths A P : Reflexive (pointwise_paths A P). Proof. intros ? ?; reflexivity. Defined. Global Instance transitive_pointwise_paths A P : Transitive (pointwise_paths A P). Proof. intros f g h. apply pointwise_paths_concat. Defined. Global Instance symmetric_pointwise_paths A P : Symmetric (pointwise_paths A P). Proof. intros ? ? p ?; symmetry; apply p. Defined. Global Arguments pointwise_paths {A}%_type_scope {P} (f g)%_function_scope. Global Arguments reflexive_pointwise_paths /. Global Arguments transitive_pointwise_paths /. Global Arguments symmetric_pointwise_paths /. #[export] Hint Unfold pointwise_paths : typeclass_instances. Notation "f == g" := (pointwise_paths f g) : type_scope. Definition apD10 {A} {B : A -> Type} {f g : forall x, B x} (h : f = g) : f == g := fun x => match h with idpath => 1 end. Global Arguments apD10 {A%_type_scope B} {f g}%_function_scope h%_path_scope _. Definition ap10 {A B} {f g : A -> B} (h : f = g) : f == g := apD10 h. Global Arguments ap10 {A B}%_type_scope {f g}%_function_scope h%_path_scope _. (** For the benefit of readers of the HoTT Book: *) Notation happly := ap10 (only parsing). Definition ap11 {A B} {f g : A -> B} (h : f = g) {x y : A} (p : x = y) : f x = g y. Proof. case h, p; reflexivity. Defined. Global Arguments ap11 {A B}%_type_scope {f g}%_function_scope h%_path_scope {x y} p%_path_scope. (** ** Equivalences *) (** Homotopy equivalences are a central concept in homotopy type theory. Before we define equivalences, let us consider when two types [A] and [B] should be considered "the same". The first option is to require existence of [f : A -> B] and [g : B -> A] which are inverses of each other, up to homotopy. Homotopically speaking, we should also require a certain condition on these homotopies, which is one of the triangle identities for adjunctions in category theory. Thus, we call this notion an *adjoint equivalence*. The other triangle identity is provable from the first one, along with all the higher coherences, so it is reasonable to only assume one of them. Moreover, as we will see, if we have maps which are inverses up to homotopy, it is always possible to make the triangle identity hold by modifying one of the homotopies. The second option is to use Vladimir Voevodsky's definition of an equivalence as a map whose homotopy fibers are contractible. We call this notion a *homotopy bijection*. An interesting third option was suggested by André Joyal: a map [f] which has separate left and right homotopy inverses. We call this notion a *homotopy isomorphism*. While the second option was the one used originally, and it is the most concise one, it makes more sense to use the first one in a formalized development, since it exposes most directly equivalence as a structure. In particular, it is easier to extract directly from it the data of a homotopy inverse to [f], which is what we care about having most in practice. Thus, adjoint equivalences are what we will refer to merely as *equivalences*. *) (** Naming convention: we use [equiv] and [Equiv] systematically to denote types of equivalences, and [isequiv] and [IsEquiv] systematically to denote the assertion that a given map is an equivalence. *) (** A typeclass that includes the data making [f] into an adjoint equivalence. *) Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : f o equiv_inv == idmap ; eissect : equiv_inv o f == idmap ; eisadj : forall x : A, eisretr (f x) = ap f (eissect x) ; }. Arguments eisretr {A B}%_type_scope f%_function_scope {_} _. Arguments eissect {A B}%_type_scope f%_function_scope {_} _. Arguments eisadj {A B}%_type_scope f%_function_scope {_} _. Arguments IsEquiv {A B}%_type_scope f%_function_scope. (** We mark [eisadj] as Opaque to deter Coq from unfolding it when simplifying. Since proofs of [eisadj] typically have larger proofs than the rest of the equivalence data, we gain some speed up as a result. *) Global Opaque eisadj. (** A record that includes all the data of an adjoint equivalence. *) Record Equiv A B := { equiv_fun : A -> B ; equiv_isequiv : IsEquiv equiv_fun }. Coercion equiv_fun : Equiv >-> Funclass. Global Existing Instance equiv_isequiv. Arguments equiv_fun {A B} _ _. Arguments equiv_isequiv {A B} _. Bind Scope equiv_scope with Equiv. Notation "A <~> B" := (Equiv A B) : type_scope. (** A notation for the inverse of an equivalence. We can apply this to a function as long as there is a typeclass instance asserting it to be an equivalence. We can also apply it to an element of [A <~> B], since there is an implicit coercion to [A -> B] and also an existing instance of [IsEquiv]. *) Notation "f ^-1" := (@equiv_inv _ _ f _) : function_scope. (** A shorthand for applying paths between equivalences like functions. *) Definition ap10_equiv {A B : Type} {f g : A <~> B} (h : f = g) : f == g := ap10 (ap equiv_fun h). (** ** Function extensionality *) (** Function extensionality is stated as the axiom [isequiv_apD10]. In order to track where it is used, we create an empty type [Funext] and require a term of that type in order to apply [isequiv_apD10]. Since there are no terms of that type, any definition that uses function extensionality (directly or indirectly) must have [Funext] as a hypothesis. This is done by adding [`{Funext}] to the argument list. You can also assume it for an entire Section with [Context `{Funext}]. Since [Funext] is a [Class], the provided argument will be found by typeclass search. This approach also has the advantage that it lets us use [isequiv_apD10] at multiple universe levels, with a single assumption. To get rid of unneeded universe variables, we put [Funext] in [Type0] and make it [Monomorphic]. *) Monomorphic Axiom Funext : Type0. Existing Class Funext. Axiom isequiv_apD10 : forall `{Funext} (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g). Global Existing Instance isequiv_apD10. Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : f == g -> f = g := (@apD10 A P f g)^-1. Global Arguments path_forall {_ A%_type_scope P} (f g)%_function_scope _. (** ** Contractibility and truncation levels *) (** Truncation measures how complicated a type is in terms of higher path types. The (-2)-truncated types are the contractible ones, whose homotopy is completely trivial. More precisely, a type [A] is contractible if there is a point [x : A] and a (pointwise) homotopy connecting the identity on [A] to the constant map at [x]. The (n+1)-truncated types are those whose path types are n-truncated. Thus, (-1)-truncated means "the type of paths between any two points is contractible". Such a type is necessarily a sub-singleton: any two points are connected by a path which is unique up to homotopy. In other words, (-1)-truncated types are truth values. We call such types "propositions" or "h-propositions". Next, 0-truncated means "the type of paths between any two points is a sub-singleton". Thus, two points might not have any paths between them, or they have a unique path. Such a type may have many points but it is discrete in the sense that all paths are trivial. We call such types "sets" or "h-sets". In this library, a witness that a type is n-truncated is formalized by the [IsTrunc n] typeclass. In many cases, the typeclass machinery of Coq can automatically infer a witness for a type being n-truncated. Because [IsTrunc n A] itself has no computational content (that is, all witnesses of n-truncation of a type are provably equal), it does not matter much which witness Coq infers. Therefore, the primary concerns in making use of the typeclass machinery are coverage (how many goals can be automatically solved) and speed (how long does it take to solve a goal, and how long does it take to error on a goal we cannot automatically solve). Careful use of typeclass instances and priorities, which determine the order of typeclass resolution, can be used to effectively increase both the coverage and the speed in cases where the goal is solvable. Unfortunately, typeclass resolution tends to spin for a while before failing unless you're very, very, very careful. We currently aim to achieve moderate coverage and fast speed in solvable cases. How long it takes to fail typeclass resolution is not currently considered, though it would be nice someday to be even more careful about things. In order to achieve moderate coverage and speedy resolution, we currently follow the following principles. They set up a kind of directed flow of information, intended to prevent cycles and potentially infinite chains, which are often the ways that typeclass resolution gets stuck. - We prefer to reason about [IsTrunc (S n) A] rather than [IsTrunc n (@paths A a b)]. Whenever we see a statement (or goal) about truncation of paths, we try to turn it into a statement (or goal) about truncation of a (non-[paths]) type. We do not allow typeclass resolution to go in the reverse direction from [IsTrunc (S n) A] to [forall a b : A, IsTrunc n (a = b)]. - We prefer to reason about syntactically smaller types. That is, typeclass instances should turn goals of type [IsTrunc n (forall a : A, P a)] into goals of type [forall a : A, IsTrunc n (P a)]; and goals of type [IsTrunc n (A * B)] into the pair of goals of type [IsTrunc n A] and [IsTrunc n B]; rather than the other way around. Ideally, we would add similar rules to transform hypotheses in the cases where we can do so. This rule is not always the one we want, but it seems to heuristically capture the shape of most cases that we want the typeclass machinery to automatically infer. That is, we often want to infer [IsTrunc n (A * B)] from [IsTrunc n A] and [IsTrunc n B], but we (probably) don't often need to do other simple things with [IsTrunc n (A * B)] which are broken by that reduction. We begin by defining the type that indexes the truncation levels. *) Inductive trunc_index : Type0 := | minus_two : trunc_index | trunc_S : trunc_index -> trunc_index. Scheme trunc_index_ind := Induction for trunc_index Sort Type. Scheme trunc_index_rec := Minimality for trunc_index Sort Type. (* See comment above about the tactic [induction]. *) Definition trunc_index_rect := trunc_index_ind. (** We will use [Notation] for [trunc_index]es, so define a scope for them here. Numeral notation for [trunc_index]es is set up in Basics/Trunc.v. *) Bind Scope trunc_scope with trunc_index. Arguments trunc_S _%_trunc_scope. Notation "n .+1" := (trunc_S n) : trunc_scope. Notation "n .+2" := (n.+1.+1)%trunc : trunc_scope. Notation "n .+3" := (n.+1.+2)%trunc : trunc_scope. Notation "n .+4" := (n.+1.+3)%trunc : trunc_scope. Notation "n .+5" := (n.+1.+4)%trunc : trunc_scope. Local Open Scope trunc_scope. (** We define truncatedness using an inductive type [IsTrunc_internal A n]. We use a notation [IsTrunc n A] simply to swap the orders of arguments, and notations [Contr], [IsHProp] and [IsHSet] which specialize to [n] being [-2], [-1] and [0], respectively. An alternative is to use a [Fixpoint], and that was done in the past. The advantages of the inductive approach are: [IsTrunc_internal] is cumulative; typeclass inherence works smoothly; the library builds faster. Some disadvantages are that we need to manually apply the constructors when proving that something is truncated, and that the induction principle is awkward to work with. *) Inductive IsTrunc_internal (A : Type@{u}) : trunc_index -> Type@{u} := | Build_Contr : forall (center : A) (contr : forall y, center = y), IsTrunc_internal A minus_two | istrunc_S : forall {n:trunc_index}, (forall x y:A, IsTrunc_internal (x = y) n) -> IsTrunc_internal A (trunc_S n). Existing Class IsTrunc_internal. Notation IsTrunc n A := (IsTrunc_internal A n). Scheme IsTrunc_internal_ind := Induction for IsTrunc_internal Sort Type. Scheme IsTrunc_internal_rec := Minimality for IsTrunc_internal Sort Type. Definition IsTrunc_internal_rect := IsTrunc_internal_ind. Definition IsTrunc_unfolded (n : trunc_index) (A : Type) := match n with | minus_two => { center : A & forall y, center = y } | n.+1 => forall x y : A, IsTrunc n (x = y) end. Definition istrunc_unfold (n : trunc_index) (A : Type) : IsTrunc n A -> IsTrunc_unfolded n A. Proof. intros [center contr|k istrunc]. - exact (center; contr). - exact istrunc. Defined. Definition isequiv_istrunc_unfold (n : trunc_index) (A : Type) : IsEquiv (istrunc_unfold n A). Proof. simple refine (Build_IsEquiv _ _ (istrunc_unfold n A) _ _ _ _). - destruct n. + intros [center contr]; exact (Build_Contr _ center contr). + intros H. exact (istrunc_S _ H). - destruct n; reflexivity. - intros [center contr|k istrunc]; reflexivity. - intros [center contr|k istrunc]; reflexivity. Defined. Definition equiv_istrunc_unfold (n : trunc_index) (A : Type) := Build_Equiv _ _ _ (isequiv_istrunc_unfold n A). (** A version of [istrunc_unfold] for successors. *) Global Instance istrunc_paths (A : Type) n `{H : IsTrunc n.+1 A} (x y : A) : IsTrunc n (x = y) := istrunc_unfold n.+1 A H x y. Notation Contr A := (IsTrunc minus_two A). Notation IsHProp A := (IsTrunc minus_two.+1 A). Notation IsHSet A := (IsTrunc minus_two.+2 A). Definition center (A : Type) {H : Contr A} : A := pr1 (istrunc_unfold _ _ H). Definition contr {A : Type} {H : Contr A} (y : A) : center A = y := pr2 (istrunc_unfold _ _ H) y. (** We define a slight variation of [istrunc_unfold], which differs only it what it does for [n = -2]. It will produce a section of the following type family. *) Definition istrunc_codomain_fam {n : trunc_index} {A : Type} (istrunc : IsTrunc n A) : A -> Type. Proof. intro y. destruct n. - exact (center A = y). - exact (forall x : A, IsTrunc n (y = x)). Defined. (** The variant of [istrunc_unfold] lets us treat any proof of truncation as a function. For [n = -2], it produces the contracting homotopy. *) Definition istrunc_fun {n : trunc_index} {A : Type} (istrunc : IsTrunc n A) : forall y : A, istrunc_codomain_fam istrunc y. Proof. destruct n. - exact (@contr A istrunc). - exact (istrunc_unfold _ _ istrunc). Defined. (** We add this as a coercion. *) #[warning="-uniform-inheritance"] Coercion istrunc_fun : IsTrunc >-> Funclass. (** *** Truncated relations *) (** Hprop-valued relations. Making this a [Notation] rather than a [Definition] enables typeclass resolution to pick it up easily. We include the base type [A] in the notation since otherwise e.g. [forall (x y : A) (z : B x y), IsHProp (C x y z)] will get displayed as [forall (x : A), is_mere_relation (C x)]. *) Notation is_mere_relation A R := (forall (x y : A), IsHProp (R x y)). (** ** Natural numbers *) Inductive nat : Type0 := | O : nat | S : nat -> nat. Scheme nat_ind := Induction for nat Sort Type. Scheme nat_rect := Induction for nat Sort Type. Scheme nat_rec := Induction for nat Sort Type. Declare Scope nat_scope. Delimit Scope nat_scope with nat. Bind Scope nat_scope with nat. Arguments S _%_nat. (** ** Misc *) (** We put [Empty] here, instead of in [Empty.v], because [Ltac done] uses it. *) Inductive Empty : Type0 := . Register Empty as core.False.type. Scheme Empty_ind := Induction for Empty Sort Type. Scheme Empty_rec := Minimality for Empty Sort Type. Definition Empty_rect := Empty_ind. Definition not (A : Type) := A -> Empty. Notation "~ x" := (not x) : type_scope. Notation "~~ x" := (~ ~x) : type_scope. #[export] Hint Unfold not: core. Notation "x <> y :> T" := (not (x = y :> T)) : type_scope. Notation "x <> y" := (x <> y :> _) : type_scope. Definition symmetric_neq {A} {x y : A} : x <> y -> y <> x := fun np p => np (p^). Definition complement {A} (R : Relation A) : Relation A := fun x y => ~ (R x y). #[global] Typeclasses Opaque complement. Class Irreflexive {A} (R : Relation A) := irreflexivity : Reflexive (complement R). Class Asymmetric {A} (R : Relation A) := asymmetry : forall {x y}, R x y -> (complement R y x : Type). (** Likewise, we put [Unit] here, instead of in [Unit.v], because [Trunc] uses it. *) Inductive Unit : Type0 := tt : Unit. Scheme Unit_ind := Induction for Unit Sort Type. Scheme Unit_rec := Minimality for Unit Sort Type. Definition Unit_rect := Unit_ind. (** A [Unit] goal should be resolved by [auto] and [trivial]. *) #[export] Hint Resolve tt : core. Register Unit as core.IDProp.type. Register Unit as core.True.type. Register tt as core.IDProp.idProp. Register tt as core.True.I. (** *** Pointed types *) (** A space is pointed if that space has a point. *) Class IsPointed (A : Type) := point : A. #[global] Typeclasses Transparent IsPointed. Arguments point A {_}. Record pType := { pointed_type : Type ; ispointed_type : IsPointed pointed_type }. Coercion pointed_type : pType >-> Sortclass. Global Existing Instance ispointed_type. (** *** Homotopy fibers *) (** Homotopy fibers are homotopical inverse images of points. *) Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. Global Arguments hfiber {A B}%_type_scope f%_function_scope y. (** ** Smallness *) (** We say that [X : Type@{j}] is small (relative to Type@{i}) if it is equivalent to a type in [Type@{i}]. We use a record to avoid an extra universe variable. This version has no constraints on [i] and [j]. It lands in [max(i+1,j)], as expected. We mark the [i] variable as being invariant, so that Coq is better at guessing universe variables when this is used. *) Class IsSmall@{=i j | } (X : Type@{j}) := { smalltype : Type@{i} ; equiv_smalltype : smalltype <~> X ; }. Arguments smalltype X {_}. Arguments equiv_smalltype X {_}. (** *** Propositional resizing *) (** See the note by [Funext] above regarding classes for axioms. *) Monomorphic Axiom PropResizing : Type0. Existing Class PropResizing. (** Propositional resizing says that every (-1)-truncated type is small. *) Axiom issmall_hprop@{i j | } : forall `{PropResizing} (X : Type@{j}) (T : IsHProp X), IsSmall@{i j} X. Existing Instance issmall_hprop. Coq-HoTT-9.0/theories/Basics/PathGroupoids.v000066400000000000000000001344171474641544500207550ustar00rootroot00000000000000(** * The groupid structure of paths *) Require Import Basics.Overture Basics.Tactics. Local Open Scope path_scope. (** ** Naming conventions We need good naming conventions that allow us to name theorems without looking them up. The names should indicate the structure of the theorem, but they may sometimes be ambiguous, in which case you just have to know what is going on. We shall adopt the following principles: - we are not afraid of long names - we are not afraid of short names when they are used frequently - we use underscores - name of theorems and lemmas are lower-case - records and other types may be upper or lower case Theorems about concatenation of paths are called [concat_XXX] where [XXX] tells us what is on the left-hand side of the equation. You have to guess the right-hand side. We use the following symbols in [XXX]: - [1] means the identity path, or sometimes the identity function - [p] means 'the path' - [V] means 'the inverse path' - [A] means '[ap]' - [M] means the thing we are moving across equality - [x] means 'the point' which is not a path, e.g. in [transport p x] - [2] means relating to 2-dimensional paths - [3] means relating to 3-dimensional paths, and so on Associativity is indicated with an underscore. Here are some examples of how the name gives hints about the left-hand side of the equation. - [concat_1p] means [1 @ p] - [concat_Vp] means [p^ @ p] - [concat_p_pp] means [p @ (q @ r)] - [concat_pp_p] means [(p @ q) @ r] - [concat_V_pp] means [p^ @ (p @ q)] - [concat_pV_p] means [(q @ p^) @ p] or [(p @ p^) @ q], but probably the former because for the latter you could just use [concat_pV]. Laws about inverse of something are of the form [inv_XXX], and those about [ap] are of the form [ap_XXX], and so on. For example: - [inv_pp] is about [(p @ q)^] - [inv_V] is about [(p^)^] - [inv_A] is about [(ap f p)^] - [ap_V] is about [ap f (p^)] - [ap_pp] is about [ap f (p @ q)] - [ap_idmap] is about [ap idmap p] - [ap_1] is about [ap f 1] - [ap02_p2p] is about [ap02 f (p @@ q)] Then we have laws which move things around in an equation. The naming scheme here is [moveD_XXX]. The direction [D] indicates where to move to: [L] means that we move something to the left-hand side, whereas [R] means we are moving something to the right-hand side. The part [XXX] describes the shape of the side _from_ which we are moving where the thing that is getting moves is called [M]. The presence of 1 next to an [M] generally indicates an *implied* identity path which is inserted automatically after the movement. Examples: - [moveL_pM] means that we transform [p = q @ r] to [p @ r^ = q] because we are moving something to the left-hand side, and we are moving the right argument of concat. - [moveR_Mp] means that we transform [p @ q = r] to [q = p^ @ r] because we move to the right-hand side, and we are moving the left argument of concat. - [moveR_1M] means that we transform [p = q] (rather than [p = 1 @ q]) to [p @ q^ = 1]. There are also cancellation laws called [cancelR] and [cancelL], which are inverse to the 2-dimensional 'whiskering' operations [whiskerR] and [whiskerL]. *) (** ** The 1-dimensional groupoid structure. *) (** [concat], with arguments flipped. Useful mainly in the idiom [apply (concatR (expression))]. Given as a notation not a definition so that the resultant terms are literally instances of [concat], with no unfolding required. *) Notation concatR := (fun p q => concat q p). (** The identity path is a right unit. *) Definition concat_p1 {A : Type} {x y : A} (p : x = y) : p @ 1 = p := match p with idpath => 1 end. (** The identity is a left unit. *) Definition concat_1p {A : Type} {x y : A} (p : x = y) : 1 @ p = p := match p with idpath => 1 end. (** It's common to need to use both. *) Definition concat_p1_1p {A : Type} {x y : A} (p : x = y) : p @ 1 = 1 @ p := concat_p1 p @ (concat_1p p)^. Definition concat_1p_p1 {A : Type} {x y : A} (p : x = y) : 1 @ p = p @ 1 := concat_1p p @ (concat_p1 p)^. (** Concatenation is associative. *) Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : p @ (q @ r) = (p @ q) @ r := match r with idpath => match q with idpath => match p with idpath => 1 end end end. Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : (p @ q) @ r = p @ (q @ r) := match r with idpath => match q with idpath => match p with idpath => 1 end end end. (** The left inverse law. *) Definition concat_pV {A : Type} {x y : A} (p : x = y) : p @ p^ = 1 := match p with idpath => 1 end. (** The right inverse law. *) Definition concat_Vp {A : Type} {x y : A} (p : x = y) : p^ @ p = 1 := match p with idpath => 1 end. (** Several auxiliary theorems about canceling inverses across associativity. These are somewhat redundant, following from earlier theorems. *) Definition concat_V_pp {A : Type} {x y z : A} (p : x = y) (q : y = z) : p^ @ (p @ q) = q := match q with idpath => match p with idpath => 1 end end. Definition concat_p_Vp {A : Type} {x y z : A} (p : x = y) (q : x = z) : p @ (p^ @ q) = q := match q with idpath => match p with idpath => 1 end end. Definition concat_pp_V {A : Type} {x y z : A} (p : x = y) (q : y = z) : (p @ q) @ q^ = p := match q with idpath => match p with idpath => 1 end end. Definition concat_pV_p {A : Type} {x y z : A} (p : x = z) (q : y = z) : (p @ q^) @ q = p := (match q as i return forall p, (p @ i^) @ i = p with idpath => fun p => match p with idpath => 1 end end) p. (** Inverse distributes over concatenation *) Definition inv_pp {A : Type} {x y z : A} (p : x = y) (q : y = z) : (p @ q)^ = q^ @ p^ := match q with idpath => match p with idpath => 1 end end. Definition inv_Vp {A : Type} {x y z : A} (p : y = x) (q : y = z) : (p^ @ q)^ = q^ @ p := match q with idpath => match p with idpath => 1 end end. Definition inv_pV {A : Type} {x y z : A} (p : x = y) (q : z = y) : (p @ q^)^ = q @ p^. Proof. destruct p. destruct q. reflexivity. Defined. Definition inv_VV {A : Type} {x y z : A} (p : y = x) (q : z = y) : (p^ @ q^)^ = q @ p. Proof. destruct p. destruct q. reflexivity. Defined. (** Inverse is an involution. *) Definition inv_V {A : Type} {x y : A} (p : x = y) : p^^ = p := match p with idpath => 1 end. (** *** Theorems for moving things around in equations. *) Definition moveR_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : p = r^ @ q -> r @ p = q. Proof. destruct r. intro h. exact (concat_1p _ @ h @ concat_1p _). Defined. Definition moveR_pM {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : r = q @ p^ -> r @ p = q. Proof. destruct p. intro h. exact (concat_p1 _ @ h @ concat_p1 _). Defined. Definition moveR_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : p = r @ q -> r^ @ p = q. Proof. destruct r. intro h. exact (concat_1p _ @ h @ concat_1p _). Defined. Definition moveR_pV {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) : r = q @ p -> r @ p^ = q. Proof. destruct p. intro h. exact (concat_p1 _ @ h @ concat_p1 _). Defined. Definition moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : r^ @ q = p -> q = r @ p. Proof. destruct r. intro h. exact ((concat_1p _)^ @ h @ (concat_1p _)^). Defined. Definition moveL_pM {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : q @ p^ = r -> q = r @ p. Proof. destruct p. intro h. exact ((concat_p1 _)^ @ h @ (concat_p1 _)^). Defined. Definition moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : r @ q = p -> q = r^ @ p. Proof. destruct r. intro h. exact ((concat_1p _)^ @ h @ (concat_1p _)^). Defined. Definition moveL_pV {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) : q @ p = r -> q = r @ p^. Proof. destruct p. intro h. exact ((concat_p1 _)^ @ h @ (concat_p1 _)^). Defined. Definition moveL_1M {A : Type} {x y : A} (p q : x = y) : p @ q^ = 1 -> p = q. Proof. destruct q. intro h. exact ((concat_p1 _)^ @ h). Defined. Definition moveL_M1 {A : Type} {x y : A} (p q : x = y) : q^ @ p = 1 -> p = q. Proof. destruct q. intro h. exact ((concat_1p _)^ @ h). Defined. Definition moveL_1V {A : Type} {x y : A} (p : x = y) (q : y = x) : p @ q = 1 -> p = q^. Proof. destruct q. intro h. exact ((concat_p1 _)^ @ h). Defined. Definition moveL_V1 {A : Type} {x y : A} (p : x = y) (q : y = x) : q @ p = 1 -> p = q^. Proof. destruct q. intro h. exact ((concat_1p _)^ @ h). Defined. Definition moveR_M1 {A : Type} {x y : A} (p q : x = y) : 1 = p^ @ q -> p = q. Proof. destruct p. intro h. exact (h @ (concat_1p _)). Defined. Definition moveR_1M {A : Type} {x y : A} (p q : x = y) : 1 = q @ p^ -> p = q. Proof. destruct p. intro h. exact (h @ (concat_p1 _)). Defined. Definition moveR_1V {A : Type} {x y : A} (p : x = y) (q : y = x) : 1 = q @ p -> p^ = q. Proof. destruct p. intro h. exact (h @ (concat_p1 _)). Defined. Definition moveR_V1 {A : Type} {x y : A} (p : x = y) (q : y = x) : 1 = p @ q -> p^ = q. Proof. destruct p. intro h. exact (h @ (concat_1p _)). Defined. (* In general, the path we want to move might be arbitrarily deeply nested at the beginning of a long concatenation. Thus, instead of defining functions such as [moveL_Mp_p], we define a tactical that can repeatedly rewrite with associativity to expose it. *) Ltac with_rassoc tac := repeat rewrite concat_pp_p; tac; (* After moving, we reassociate to the left (the canonical direction for paths). *) repeat rewrite concat_p_pp. Ltac rewrite_moveL_Mp_p := with_rassoc ltac:(apply moveL_Mp). Ltac rewrite_moveL_Vp_p := with_rassoc ltac:(apply moveL_Vp). Ltac rewrite_moveR_Mp_p := with_rassoc ltac:(apply moveR_Mp). Ltac rewrite_moveR_Vp_p := with_rassoc ltac:(apply moveR_Vp). Definition moveR_transport_p {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) : u = p^ # v -> p # u = v. Proof. destruct p. exact idmap. Defined. Definition moveR_transport_V {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) : u = p # v -> p^ # u = v. Proof. destruct p. exact idmap. Defined. Definition moveL_transport_V {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) : p # u = v -> u = p^ # v. Proof. destruct p. exact idmap. Defined. Definition moveL_transport_p {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) : p^ # u = v -> u = p # v. Proof. destruct p. exact idmap. Defined. (* We have some coherences between those proofs. *) Definition moveR_transport_p_V {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) (q : u = p^ # v) : (moveR_transport_p P p u v q)^ = moveL_transport_p P p v u q^. Proof. destruct p; reflexivity. Defined. Definition moveR_transport_V_V {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) (q : u = p # v) : (moveR_transport_V P p u v q)^ = moveL_transport_V P p v u q^. Proof. destruct p; reflexivity. Defined. Definition moveL_transport_V_V {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) (q : p # u = v) : (moveL_transport_V P p u v q)^ = moveR_transport_V P p v u q^. Proof. destruct p; reflexivity. Defined. Definition moveL_transport_p_V {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) (q : p^ # u = v) : (moveL_transport_p P p u v q)^ = moveR_transport_p P p v u q^. Proof. destruct p; reflexivity. Defined. (** *** Functoriality of functions *) (** Here we prove that functions behave like functors between groupoids, and that [ap] itself is functorial. *) (** Functions take identity paths to identity paths. *) Definition ap_1 {A B : Type} (x : A) (f : A -> B) : ap f 1 = 1 :> (f x = f x) := 1. Definition apD_1 {A B} (x : A) (f : forall x : A, B x) : apD f 1 = 1 :> (f x = f x) := 1. (** Functions commute with concatenation. *) Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) : ap f (p @ q) = (ap f p) @ (ap f q) := match q with idpath => match p with idpath => 1 end end. Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A} (r : w = f x) (p : x = y) (q : y = z) : r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q). Proof. destruct p, q. simpl. exact (concat_p_pp r 1 1). Defined. Definition ap_pp_p {A B : Type} (f : A -> B) {x y z : A} {w : B} (p : x = y) (q : y = z) (r : f z = w) : (ap f (p @ q)) @ r = (ap f p) @ (ap f q @ r). Proof. destruct p, q. simpl. exact (concat_pp_p 1 1 r). Defined. (** Functions commute with path inverses. *) Definition inverse_ap {A B : Type} (f : A -> B) {x y : A} (p : x = y) : (ap f p)^ = ap f (p^) := match p with idpath => 1 end. Definition ap_V {A B : Type} (f : A -> B) {x y : A} (p : x = y) : ap f (p^) = (ap f p)^ := match p with idpath => 1 end. (** [ap] itself is functorial in the first argument. *) Definition ap_idmap {A : Type} {x y : A} (p : x = y) : ap idmap p = p := match p with idpath => 1 end. Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : ap (g o f) p = ap g (ap f p) := match p with idpath => 1 end. (* Sometimes we don't have the actual function [compose]. *) Definition ap_compose' {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : ap (fun a => g (f a)) p = ap g (ap f p) := match p with idpath => 1 end. (** The action of constant maps. *) Definition ap_const {A B : Type} {x y : A} (p : x = y) (z : B) : ap (fun _ => z) p = 1 := match p with idpath => idpath end. (** Naturality of [ap]. *) Definition concat_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) : (ap f q) @ (p y) = (p x) @ (ap g q) := match q with | idpath => concat_1p_p1 _ end. (* A useful variant of concat_Ap. *) Definition ap_homotopic {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) : (ap f q) = (p x) @ (ap g q) @ (p y)^. Proof. apply moveL_pV. apply concat_Ap. Defined. (** Naturality of [ap] at identity. *) Definition concat_A1p {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) : (ap f q) @ (p y) = (p x) @ q := match q with | idpath => concat_1p_p1 _ end. (* The corresponding variant of concat_A1p. *) Definition ap_homotopic_id {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) : (ap f q) = (p x) @ q @ (p y)^. Proof. apply moveL_pV. apply concat_A1p. Defined. Definition concat_pA1 {A : Type} {f : A -> A} (p : forall x, x = f x) {x y : A} (q : x = y) : (p x) @ (ap f q) = q @ (p y) := match q as i in (_ = y) return (p x @ ap f i = i @ p y) with | idpath => concat_p1_1p _ end. Definition apD_natural {A : Type} {B : A -> Type} {f g : forall x, B x} (p : forall x, f x = g x) {x y : A} (q : x = y) : apD f q @ p y = ap (transport B q) (p x) @ apD g q. Proof. destruct q. unfold transport. exact (concat_1p _ @ (ap_idmap _)^ @ (concat_p1 _)^). Defined. Definition apD_homotopic {A : Type} {B : A -> Type} {f g : forall x, B x} (p : forall x, f x = g x) {x y : A} (q : x = y) : apD f q = ap (transport B q) (p x) @ apD g q @ (p y)^. Proof. apply moveL_pV, apD_natural. Defined. (** Naturality with other paths hanging around. *) Definition concat_pA_pp {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) {w z : B} (r : w = f x) (s : g y = z) : (r @ ap f q) @ (p y @ s) = (r @ p x) @ (ap g q @ s). Proof. destruct q, s; simpl. induction (p x). reflexivity. Defined. Definition concat_pA_p {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) {w : B} (r : w = f x) : (r @ ap f q) @ p y = (r @ p x) @ ap g q. Proof. destruct q; simpl. induction (p x). reflexivity. Defined. Definition concat_A_pp {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) {z : B} (s : g y = z) : (ap f q) @ (p y @ s) = (p x) @ (ap g q @ s). Proof. destruct q, s; cbn. apply concat_1p. Defined. Definition concat_pA1_pp {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) {w z : A} (r : w = f x) (s : y = z) : (r @ ap f q) @ (p y @ s) = (r @ p x) @ (q @ s). Proof. destruct q, s; simpl. induction (p x). reflexivity. Defined. Definition concat_pp_A1p {A : Type} {g : A -> A} (p : forall x, x = g x) {x y : A} (q : x = y) {w z : A} (r : w = x) (s : g y = z) : (r @ p x) @ (ap g q @ s) = (r @ q) @ (p y @ s). Proof. destruct q, s; simpl. induction (p x). reflexivity. Defined. Definition concat_pA1_p {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) {w : A} (r : w = f x) : (r @ ap f q) @ p y = (r @ p x) @ q. Proof. destruct q; simpl. induction (p x). reflexivity. Defined. Definition concat_A1_pp {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) {z : A} (s : y = z) : (ap f q) @ (p y @ s) = (p x) @ (q @ s). Proof. destruct q, s; cbn. apply concat_1p. Defined. Definition concat_pp_A1 {A : Type} {g : A -> A} (p : forall x, x = g x) {x y : A} (q : x = y) {w : A} (r : w = x) : (r @ p x) @ ap g q = (r @ q) @ p y. Proof. destruct q; simpl. induction (p x). reflexivity. Defined. Definition concat_p_A1p {A : Type} {g : A -> A} (p : forall x, x = g x) {x y : A} (q : x = y) {z : A} (s : g y = z) : p x @ (ap g q @ s) = q @ (p y @ s). Proof. destruct q, s; simpl. symmetry; apply concat_1p. Defined. (** Some coherence lemmas for functoriality *) Lemma concat_1p_1 {A} {x : A} (p : x = x) (q : p = 1) : concat_1p p @ q = ap (fun p' => 1 @ p') q. Proof. rewrite <- (inv_V q). set (r := q^). clearbody r; clear q; destruct r. reflexivity. Defined. Lemma concat_p1_1 {A} {x : A} (p : x = x) (q : p = 1) : concat_p1 p @ q = ap (fun p' => p' @ 1) q. Proof. rewrite <- (inv_V q). set (r := q^). clearbody r; clear q; destruct r. reflexivity. Defined. (** *** Action of [apD10] and [ap10] on paths. *) (** Application of paths between functions preserves the groupoid structure *) Definition apD10_1 {A} {B:A->Type} (f : forall x, B x) (x:A) : apD10 (idpath f) x = 1 := 1. Definition apD10_pp {A} {B:A->Type} {f f' f'' : forall x, B x} (h:f=f') (h':f'=f'') (x:A) : apD10 (h @ h') x = apD10 h x @ apD10 h' x. Proof. case h, h'; reflexivity. Defined. Definition apD10_V {A} {B:A->Type} {f g : forall x, B x} (h:f=g) (x:A) : apD10 (h^) x = (apD10 h x)^ := match h with idpath => 1 end. Definition ap10_1 {A B} {f:A->B} (x:A) : ap10 (idpath f) x = 1 := 1. Definition ap10_pp {A B} {f f' f'':A->B} (h:f=f') (h':f'=f'') (x:A) : ap10 (h @ h') x = ap10 h x @ ap10 h' x := apD10_pp h h' x. Definition ap10_V {A B} {f g : A->B} (h : f = g) (x:A) : ap10 (h^) x = (ap10 h x)^ := apD10_V h x. (** [apD10] and [ap10] also behave nicely on paths produced by [ap] *) Definition apD10_ap_precompose {A B C} (f : A -> B) {g g' : forall x:B, C x} (p : g = g') a : apD10 (ap (fun h : forall x:B, C x => h oD f) p) a = apD10 p (f a). Proof. destruct p; reflexivity. Defined. Definition ap10_ap_precompose {A B C} (f : A -> B) {g g' : B -> C} (p : g = g') a : ap10 (ap (fun h : B -> C => h o f) p) a = ap10 p (f a) := apD10_ap_precompose f p a. Definition apD10_ap_postcompose {A B C} (f : forall x, B x -> C) {g g' : forall x:A, B x} (p : g = g') a : apD10 (ap (fun h : forall x:A, B x => fun x => f x (h x)) p) a = ap (f a) (apD10 p a). Proof. destruct p; reflexivity. Defined. Definition ap10_ap_postcompose {A B C} (f : B -> C) {g g' : A -> B} (p : g = g') a : ap10 (ap (fun h : A -> B => f o h) p) a = ap f (ap10 p a) := apD10_ap_postcompose (fun a => f) p a. Definition ap100 {X Y Z : Type} {f g : X -> Y -> Z} (p : f = g) (x : X) (y : Y) : f x y = g x y := (ap10 (ap10 p x) y). (** *** Transport and the groupoid structure of paths *) Definition transport_1 {A : Type} (P : A -> Type) {x : A} (u : P x) : 1 # u = u := 1. Definition transport_pp {A : Type} (P : A -> Type) {x y z : A} (p : x = y) (q : y = z) (u : P x) : p @ q # u = q # p # u := match q with idpath => match p with idpath => 1 end end. Definition transport_pV {A : Type} (P : A -> Type) {x y : A} (p : x = y) (z : P y) : p # p^ # z = z := (transport_pp P p^ p z)^ @ ap (fun r => transport P r z) (concat_Vp p). Definition transport_Vp {A : Type} (P : A -> Type) {x y : A} (p : x = y) (z : P x) : p^ # p # z = z := (transport_pp P p p^ z)^ @ ap (fun r => transport P r z) (concat_pV p). (** In the future, we may expect to need some higher coherence for transport: for instance, that transport acting on the associator is trivial. *) Definition transport_p_pp {A : Type} (P : A -> Type) {x y z w : A} (p : x = y) (q : y = z) (r : z = w) (u : P x) : ap (fun e => e # u) (concat_p_pp p q r) @ (transport_pp P (p@q) r u) @ ap (transport P r) (transport_pp P p q u) = (transport_pp P p (q@r) u) @ (transport_pp P q r (p#u)) :> ((p @ (q @ r)) # u = r # q # p # u) . Proof. destruct p, q, r. simpl. exact 1. Defined. (* Here are other coherence lemmas for transport. *) Definition transport_pVp {A} (P : A -> Type) {x y:A} (p:x=y) (z:P x) : transport_pV P p (transport P p z) = ap (transport P p) (transport_Vp P p z). Proof. destruct p; reflexivity. Defined. Definition transport_VpV {A} (P : A -> Type) {x y : A} (p : x = y) (z : P y) : transport_Vp P p (transport P p^ z) = ap (transport P p^) (transport_pV P p z). Proof. destruct p; reflexivity. Defined. Definition ap_transport_transport_pV {A} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) (e : transport P p u = v) : ap (transport P p) (moveL_transport_V P p u v e) @ transport_pV P p v = e. Proof. by destruct e, p. Defined. Definition moveL_transport_V_1 {A} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : moveL_transport_V P p u (p # u) 1 = (transport_Vp P p u)^. (* moveL_transport_V P p (transport P p^ v) (transport P p (transport P p^ v)) 1 *) (* = ap (transport P p^) (transport_pV P p v)^. *) Proof. (* pose (u := p^ # v). *) (* assert (moveL_transport_V P p u (p # u) 1 = (transport_Vp P p u)^). *) destruct p; reflexivity. (* subst u. rewrite X. *) Defined. (** Occasionally the induction principles for the identity type show up explicitly; these let us turn them into transport. *) Definition paths_rect_transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : paths_rect A x (fun a _ => P a) u y p = transport P p u := 1. Definition paths_ind_transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : paths_ind x (fun a _ => P a) u y p = transport P p u := 1. Definition paths_ind_r_transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P y) : paths_ind_r y (fun b _ => P b) u x p = transport P p^ u. Proof. by destruct p. Defined. (** ** [ap11] *) Definition ap11_is_ap10_ap01 {A B} {f g:A->B} (h:f=g) {x y:A} (p:x=y) : ap11 h p = ap10 h x @ ap g p. Proof. by path_induction. Defined. (** Dependent transport in doubly dependent types and more. *) (** Singly dependent transport over doubly dependent types. *) Definition transportD {A : Type} (B : A -> Type) (C : forall a:A, B a -> Type) {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1 y) : C x2 (p # y) := match p with idpath => z end. (** Singly dependent transport over doubly dependent types of 2 variables. *) Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a -> Type) {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z) : D x2 (p # y) (p # z) := match p with idpath => w end. (** Doubly dependent transport over doubly dependent types. *) Definition transportDD {A : Type} (B : A -> Type) (C : forall a : A, B a -> Type) {a1 a2 : A} (pA : a1 = a2) {b1 : B a1} {b2 : B a2} (pB : transport B pA b1 = b2) (c1 : C a1 b1) : C a2 b2 := transport (C a2) pB (transportD B C pA b1 c1). (** *** [ap] for curried two variable functions *) Definition ap011 {A B C} (f : A -> B -> C) {x x' y y'} (p : x = x') (q : y = y') : f x y = f x' y'. Proof. destruct p. apply ap. exact q. Defined. Definition ap011_V {A B C} (f : A -> B -> C) {x x' y y'} (p : x = x') (q : y = y') : ap011 f p^ q^ = (ap011 f p q)^. Proof. destruct p. apply ap_V. Defined. Definition ap011_pp {A B C} (f : A -> B -> C) {x x' x'' y y' y''} (p : x = x') (p' : x' = x'') (q : y = y') (q' : y' = y'') : ap011 f (p @ p') (q @ q') = ap011 f p q @ ap011 f p' q'. Proof. destruct p, p'. apply ap_pp. Defined. Definition ap011_compose {A B C D} (f : A -> B -> C) (g : C -> D) {x x' y y'} (p : x = x') (q : y = y') : ap011 (fun x y => g (f x y)) p q = ap g (ap011 f p q). Proof. destruct p; simpl. apply ap_compose. Defined. Definition ap011_compose' {A B C D E} (f : A -> B -> C) (g : D -> A) (h : E -> B) {x x' y y'} (p : x = x') (q : y = y') : ap011 (fun x y => f (g x) (h y)) p q = ap011 f (ap g p) (ap h q). Proof. destruct p; simpl. apply ap_compose. Defined. Definition ap011_is_ap {A B C} (f : A -> B -> C) {x x' : A} {y y' : B} (p : x = x') (q : y = y') : ap011 f p q = ap (fun x => f x y) p @ ap (fun y => f x' y) q. Proof. destruct p. symmetry. apply concat_1p. Defined. (** It would be nice to have a consistent way to name the different ways in which this can be dependent. The following are a sort of half-hearted attempt. *) Definition ap011D {A B C} (f : forall (a:A), B a -> C) {x x'} (p : x = x') {y y'} (q : p # y = y') : f x y = f x' y'. Proof. destruct p, q; reflexivity. Defined. Definition ap01D1 {A B C} (f : forall (a:A), B a -> C a) {x x'} (p : x = x') {y y'} (q : p # y = y') : transport C p (f x y) = f x' y'. Proof. destruct p, q; reflexivity. Defined. Definition apD011 {A B C} (f : forall (a:A) (b:B a), C a b) {x x'} (p : x = x') {y y'} (q : p # y = y') : transport (C x') q (transportD B C p y (f x y)) = f x' y'. Proof. destruct p, q; reflexivity. Defined. (** Transporting along two 1-dimensional paths *) Definition transport011 {A B} (P : A -> B -> Type) {x1 x2 : A} {y1 y2 : B} (p : x1 = x2) (q : y1 = y2) (z : P x1 y1) : P x2 y2 := transport (fun x => P x y2) p (transport (fun y => P x1 y) q z). Definition transport011_pp {A B} (P : A -> B -> Type) {x1 x2 x3 : A} {y1 y2 y3 : B} (p1 : x1 = x2) (p2 : x2 = x3) (q1 : y1 = y2) (q2 : y2 = y3) (z : P x1 y1) : transport011 P (p1 @ p2) (q1 @ q2) z = transport011 P p2 q2 (transport011 P p1 q1 z). Proof. destruct p1, p2, q1, q2; reflexivity. Defined. Definition transport011_compose {A B A' B'} (P : A -> B -> Type) (f : A' -> A) (g : B' -> B) {x1 x2 : A'} {y1 y2 : B'} (p : x1 = x2) (q : y1 = y2) (z : P (f x1) (g y1)) : transport011 (fun x y => P (f x) (g y)) p q z = transport011 P (ap f p) (ap g q) z. Proof. destruct p, q; reflexivity. Defined. (** Naturality of [transport011]. *) Definition ap_transport011{A B} {P Q : A -> B -> Type} {a1 a2 : A} {b1 b2 : B} (p : a1 = a2) (q : b1 = b2) (f : forall {a b}, P a b -> Q a b) (x : P a1 b1) : f (transport011 P p q x) = transport011 Q p q (f x). Proof. destruct p, q; reflexivity. Defined. (** Transporting along higher-dimensional paths *) Definition transport2 {A : Type} (P : A -> Type) {x y : A} {p q : x = y} (r : p = q) (z : P x) : p # z = q # z := ap (fun p' => p' # z) r. (** An alternative definition. *) Definition transport2_is_ap10 {A : Type} (Q : A -> Type) {x y : A} {p q : x = y} (r : p = q) (z : Q x) : transport2 Q r z = ap10 (ap (transport Q) r) z := match r with idpath => 1 end. Definition transport2_p2p {A : Type} (P : A -> Type) {x y : A} {p1 p2 p3 : x = y} (r1 : p1 = p2) (r2 : p2 = p3) (z : P x) : transport2 P (r1 @ r2) z = transport2 P r1 z @ transport2 P r2 z. Proof. destruct r1, r2; reflexivity. Defined. Definition transport2_V {A : Type} (Q : A -> Type) {x y : A} {p q : x = y} (r : p = q) (z : Q x) : transport2 Q (r^) z = (transport2 Q r z)^ := match r with idpath => 1 end. Definition concat_AT {A : Type} (P : A -> Type) {x y : A} {p q : x = y} {z w : P x} (r : p = q) (s : z = w) : ap (transport P p) s @ transport2 P r w = transport2 P r z @ ap (transport P q) s := match r with idpath => (concat_p1_1p _) end. Definition transport_pp_1 {A : Type} (P : A -> Type) {a b : A} (p : a = b) (x : P a) : transport_pp P p 1 x = transport2 P (concat_p1 p) x. Proof. by induction p. Defined. (* TODO: What should this be called? *) Lemma ap_transport {A} {P Q : A -> Type} {x y : A} (p : x = y) (f : forall x, P x -> Q x) (z : P x) : f y (p # z) = (p # (f x z)). Proof. by induction p. Defined. Lemma ap_transportD {A : Type} (B : A -> Type) (C1 C2 : forall a : A, B a -> Type) (f : forall a b, C1 a b -> C2 a b) {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C1 x1 y) : f x2 (p # y) (transportD B C1 p y z) = transportD B C2 p y (f x1 y z). Proof. by induction p. Defined. Lemma ap_transportD2 {A : Type} (B C : A -> Type) (D1 D2 : forall a, B a -> C a -> Type) (f : forall a b c, D1 a b c -> D2 a b c) {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D1 x1 y z) : f x2 (p # y) (p # z) (transportD2 B C D1 p y z w) = transportD2 B C D2 p y z (f x1 y z w). Proof. by induction p. Defined. (* TODO: What should this be called? *) Lemma ap_transport_pV {X} (Y : X -> Type) {x1 x2 : X} (p : x1 = x2) {y1 y2 : Y x2} (q : y1 = y2) : ap (transport Y p) (ap (transport Y p^) q) = transport_pV Y p y1 @ q @ (transport_pV Y p y2)^. Proof. destruct p, q; reflexivity. Defined. (* TODO: And this? *) Definition transport_pV_ap {X} (P : X -> Type) (f : forall x, P x) {x1 x2 : X} (p : x1 = x2) : ap (transport P p) (apD f p^) @ apD f p = transport_pV P p (f x2). Proof. destruct p; reflexivity. Defined. Definition apD_pp {A} {P : A -> Type} (f : forall x, P x) {x y z : A} (p : x = y) (q : y = z) : apD f (p @ q) = transport_pp P p q (f x) @ ap (transport P q) (apD f p) @ apD f q. Proof. destruct p, q; reflexivity. Defined. Definition apD_V {A} {P : A -> Type} (f : forall x, P x) {x y : A} (p : x = y) : apD f p^ = moveR_transport_V _ _ _ _ (apD f p)^. Proof. destruct p; reflexivity. Defined. (** *** Transporting in particular fibrations. *) (** One frequently needs lemmas showing that transport in a certain dependent type is equal to some more explicitly defined operation, defined according to the structure of that dependent type. For most dependent types, we prove these lemmas in the appropriate file in the types/ subdirectory. Here we consider only the most basic cases. *) (** Transporting in a constant fibration. *) Definition transport_const {A B : Type} {x1 x2 : A} (p : x1 = x2) (y : B) : transport (fun x => B) p y = y. Proof. destruct p. exact 1. Defined. Definition transport2_const {A B : Type} {x1 x2 : A} {p q : x1 = x2} (r : p = q) (y : B) : transport_const p y = transport2 (fun _ => B) r y @ transport_const q y := match r with idpath => (concat_1p _)^ end. Definition transportD_const_fiber {A : Type} (B : A -> Type) (C : Type) {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C) : transportD B (fun _ _ => C) p y z = z. Proof. by destruct p. Defined. Definition transportD_const_base {A B : Type} (C : A -> B -> Type) {x1 x2 : A} (p : x1 = x2) {y : B} (z : C x1 y) : transportD (fun x => B) C p y z = transport (fun x => C x (transport (fun _ => B) p y)) p (transport (C x1) (transport_const p y)^ z). Proof. by destruct p. Defined. Definition transportDD_const {A : Type} (B : A -> Type) (C : Type) {a1 a2 : A} (pA : a1 = a2) {b1 : B a1} {b2 : B a2} (pB : transport B pA b1 = b2) (c1 : C) : transportDD B (fun _ _ => C) pA pB c1 = c1. Proof. by destruct pB, pA. Defined. (** Transporting in a pulled back fibration. *) Lemma transport_compose {A B} {x y : A} (P : B -> Type) (f : A -> B) (p : x = y) (z : P (f x)) : transport (fun x => P (f x)) p z = transport P (ap f p) z. Proof. destruct p; reflexivity. Defined. Lemma transportD_compose {A A'} B {x x' : A} (C : forall x : A', B x -> Type) (f : A -> A') (p : x = x') y (z : C (f x) y) : transportD (B o f) (C oD f) p y z = transport (C (f x')) (transport_compose B f p y)^ (transportD B C (ap f p) y z). Proof. destruct p; reflexivity. Defined. (* TODO: Is there a lemma like [transportD_compose], but for [apD], which subsumes this? *) Lemma transport_apD_transportD {A} B (f : forall x : A, B x) (C : forall x, B x -> Type) {x1 x2 : A} (p : x1 = x2) (z : C x1 (f x1)) : apD f p # transportD B C p _ z = transport (fun x => C x (f x)) p z. Proof. destruct p; reflexivity. Defined. Lemma transport_precompose {A B C} (f : A -> B) (g g' : B -> C) (p : g = g') : transport (fun h : B -> C => g o f = h o f) p 1 = ap (fun h => h o f) p. Proof. destruct p; reflexivity. Defined. (** A special case of [transport_compose] which seems to come up a lot. *) Definition transport_idmap_ap {A} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : transport P p u = transport idmap (ap P p) u := match p with idpath => idpath end. (** Sometimes, it's useful to have the goal be in terms of [ap], so we can use lemmas about [ap]. However, we can't just [rewrite !transport_idmap_ap], as that's likely to loop. So, instead, we provide a tactic [transport_to_ap], that replaces all [transport P p u] with [transport idmap (ap P p) u] for non-[idmap] [P]. *) Ltac transport_to_ap := repeat match goal with | [ |- context[transport ?P ?p ?u] ] => match P with | idmap => fail 1 (* we don't want to turn [transport idmap (ap _ _)] into [transport idmap (ap idmap (ap _ _))] *) | _ => idtac end; progress rewrite (transport_idmap_ap P p u) end. (** Transporting in a fibration dependent on two independent types commutes. *) Definition transport_transport {A B} (C : A -> B -> Type) {x1 x2 : A} (p : x1 = x2) {y1 y2 : B} (q : y1 = y2) (c : C x1 y1) : transport (C x2) q (transport (fun x => C x y1) p c) = transport (fun x => C x y2) p (transport (C x1) q c). Proof. destruct p, q; reflexivity. Defined. (** *** The behavior of [ap] and [apD]. *) (** In a constant fibration, [apD] reduces to [ap], modulo [transport_const]. *) Lemma apD_const {A B} {x y : A} (f : A -> B) (p: x = y) : apD f p = transport_const p (f x) @ ap f p. Proof. destruct p; reflexivity. Defined. Definition apD_compose {A A' : Type} {B : A' -> Type} (g : A -> A') (f : forall a, B a) {x y : A} (p : x = y) : apD (f o g) p = (transport_compose _ _ _ _) @ apD f (ap g p). Proof. by destruct p. Defined. Definition apD_compose' {A A' : Type} {B : A' -> Type} (g : A -> A') (f : forall a, B a) {x y : A} (p : x = y) : apD f (ap g p) = (transport_compose B _ _ _)^ @ apD (f o g) p. Proof. by destruct p. Defined. (** ** The 2-dimensional groupoid structure *) (** Horizontal composition of 2-dimensional paths. *) Definition concat2 {A} {x y z : A} {p p' : x = y} {q q' : y = z} (h : p = p') (h' : q = q') : p @ q = p' @ q' := match h, h' with idpath, idpath => 1 end. Notation "p @@ q" := (concat2 p q)%path : path_scope. Arguments concat2 : simpl nomatch. Lemma concat2_ap_ap {A B : Type} {x' y' z' : B} (f : A -> (x' = y')) (g : A -> (y' = z')) {x y : A} (p : x = y) : (ap f p) @@ (ap g p) = ap (fun u => f u @ g u) p. Proof. by path_induction. Defined. (** 2-dimensional path inversion *) Definition inverse2 {A : Type} {x y : A} {p q : x = y} (h : p = q) : p^ = q^ := ap inverse h. (** Some higher coherences *) Lemma ap_pp_concat_p1 {A B} (f : A -> B) {a b : A} (p : a = b) : ap_pp f p 1 @ concat_p1 (ap f p) = ap (ap f) (concat_p1 p). Proof. destruct p; reflexivity. Defined. Lemma ap_pp_concat_1p {A B} (f : A -> B) {a b : A} (p : a = b) : ap_pp f 1 p @ concat_1p (ap f p) = ap (ap f) (concat_1p p). Proof. destruct p; reflexivity. Defined. Lemma ap_pp_concat_pV {A B} (f : A -> B) {x y : A} (p : x = y) : ap_pp f p p^ @ ((1 @@ ap_V f p) @ concat_pV (ap f p)) = ap (ap f) (concat_pV p). Proof. destruct p; reflexivity. Defined. Lemma ap_pp_concat_Vp {A B} (f : A -> B) {x y : A} (p : x = y) : ap_pp f p^ p @ ((ap_V f p @@ 1) @ concat_Vp (ap f p)) = ap (ap f) (concat_Vp p). Proof. destruct p; reflexivity. Defined. Lemma concat_pV_inverse2 {A} {x y : A} (p q : x = y) (r : p = q) : (r @@ inverse2 r) @ concat_pV q = concat_pV p. Proof. destruct r, p; reflexivity. Defined. Lemma concat_Vp_inverse2 {A} {x y : A} (p q : x = y) (r : p = q) : (inverse2 r @@ r) @ concat_Vp q = concat_Vp p. Proof. destruct r, p; reflexivity. Defined. (** *** Whiskering *) Definition whiskerL {A : Type} {x y z : A} (p : x = y) {q r : y = z} (h : q = r) : p @ q = p @ r := 1 @@ h. Definition whiskerR {A : Type} {x y z : A} {p q : x = y} (h : p = q) (r : y = z) : p @ r = q @ r := h @@ 1. (** *** Unwhiskering, a.k.a. cancelling. *) Definition cancelL {A} {x y z : A} (p : x = y) (q r : y = z) : (p @ q = p @ r) -> (q = r) := fun h => (concat_V_pp p q)^ @ whiskerL p^ h @ (concat_V_pp p r). Definition cancelR {A} {x y z : A} (p q : x = y) (r : y = z) : (p @ r = q @ r) -> (p = q) := fun h => (concat_pp_V p r)^ @ whiskerR h r^ @ (concat_pp_V q r). (** Whiskering and identity paths. *) Definition whiskerR_p1 {A : Type} {x y : A} {p q : x = y} (h : p = q) : (concat_p1 p)^ @ whiskerR h 1 @ concat_p1 q = h := match h with idpath => match p with idpath => 1 end end. Definition whiskerR_1p {A : Type} {x y z : A} (p : x = y) (q : y = z) : whiskerR 1 q = 1 :> (p @ q = p @ q) := match q with idpath => 1 end. Definition whiskerL_p1 {A : Type} {x y z : A} (p : x = y) (q : y = z) : whiskerL p 1 = 1 :> (p @ q = p @ q) := match q with idpath => 1 end. Definition whiskerL_1p {A : Type} {x y : A} {p q : x = y} (h : p = q) : (concat_1p p) ^ @ whiskerL 1 h @ concat_1p q = h := match h with idpath => match p with idpath => 1 end end. Definition whiskerR_p1_1 {A} {x : A} (h : idpath x = idpath x) : whiskerR h 1 = h. Proof. refine (_ @ whiskerR_p1 h); simpl. symmetry; refine (concat_p1 _ @ concat_1p _). Defined. Definition whiskerL_1p_1 {A} {x : A} (h : idpath x = idpath x) : whiskerL 1 h = h. Proof. refine (_ @ whiskerL_1p h); simpl. symmetry; refine (concat_p1 _ @ concat_1p _). Defined. Definition cancel2L {A : Type} {x y z : A} {p p' : x = y} {q q' : y = z} (g : p = p') (h k : q = q') : (g @@ h = g @@ k) -> (h = k). Proof. intro r. induction g, p, q. refine ((whiskerL_1p h)^ @ _). refine (_ @ (whiskerL_1p k)). refine (whiskerR _ _). refine (whiskerL _ _). apply r. Defined. Definition cancel2R {A : Type} {x y z : A} {p p' : x = y} {q q' : y = z} (g h : p = p') (k : q = q') : (g @@ k = h @@ k) -> (g = h). Proof. intro r. induction k, p, q. refine ((whiskerR_p1 g)^ @ _). refine (_ @ (whiskerR_p1 h)). refine (whiskerR _ _). refine (whiskerL _ _). apply r. Defined. (** Whiskering and composition *) (* The naming scheme for these is a little unclear; should [pp] refer to concatenation of the 2-paths being whiskered or of the paths we are whiskering by? *) Definition whiskerL_pp {A} {x y z : A} (p : x = y) {q q' q'' : y = z} (r : q = q') (s : q' = q'') : whiskerL p (r @ s) = whiskerL p r @ whiskerL p s. Proof. destruct p, r, s; reflexivity. Defined. Definition whiskerR_pp {A} {x y z : A} {p p' p'' : x = y} (q : y = z) (r : p = p') (s : p' = p'') : whiskerR (r @ s) q = whiskerR r q @ whiskerR s q. Proof. destruct q, r, s; reflexivity. Defined. (* For now, I've put an [L] or [R] to mark when we're referring to the whiskering paths. *) Definition whiskerL_VpL {A} {x y z : A} (p : x = y) {q q' : y = z} (r : q = q') : (concat_V_pp p q)^ @ whiskerL p^ (whiskerL p r) @ concat_V_pp p q' = r. Proof. destruct p, r, q. reflexivity. Defined. Definition whiskerL_pVL {A} {x y z : A} (p : y = x) {q q' : y = z} (r : q = q') : (concat_p_Vp p q)^ @ whiskerL p (whiskerL p^ r) @ concat_p_Vp p q' = r. Proof. destruct p, r, q. reflexivity. Defined. Definition whiskerR_pVR {A} {x y z : A} {p p' : x = y} (r : p = p') (q : y = z) : (concat_pp_V p q)^ @ whiskerR (whiskerR r q) q^ @ concat_pp_V p' q = r. Proof. destruct p, r, q. reflexivity. Defined. Definition whiskerR_VpR {A} {x y z : A} {p p' : x = y} (r : p = p') (q : z = y) : (concat_pV_p p q)^ @ whiskerR (whiskerR r q^) q @ concat_pV_p p' q = r. Proof. destruct p, r, q. reflexivity. Defined. (** Naturality of [concat_p_pp] in left-most argument. *) Definition concat_p_pp_nat_l {A} {w x y z : A} {p p' : w = x} (h : p = p') (q : x = y) (r : y = z) : whiskerR h (q @ r) @ concat_p_pp p' q r = concat_p_pp p q r @ whiskerR (whiskerR h q) r. Proof. by destruct h, p, q, r. Defined. (** Naturality of [concat_p_pp] in middle argument. *) Definition concat_p_pp_nat_m {A} {w x y z : A} (p : w = x) {q q' : x = y} (h : q = q') (r : y = z) : whiskerL p (whiskerR h r) @ concat_p_pp p q' r = concat_p_pp p q r @ whiskerR (whiskerL p h) r. Proof. by destruct h, p, q, r. Defined. (** Naturality of [concat_p_pp] in right-most argument. *) Definition concat_p_pp_nat_r {A} {w x y z : A} (p : w = x) (q : x = y) {r r' : y = z} (h : r = r') : whiskerL p (whiskerL q h) @ concat_p_pp p q r' = concat_p_pp p q r @ whiskerL (p @ q) h. Proof. by destruct h, p, q, r. Defined. (** The interchange law for concatenation. *) Definition concat_concat2 {A : Type} {x y z : A} {p p' p'' : x = y} {q q' q'' : y = z} (a : p = p') (b : p' = p'') (c : q = q') (d : q' = q'') : (a @@ c) @ (b @@ d) = (a @ b) @@ (c @ d). Proof. case d. case c. case b. case a. reflexivity. Defined. (** The interchange law for whiskering. Special case of [concat_concat2]. *) Definition concat_whisker {A} {x y z : A} (p p' : x = y) (q q' : y = z) (a : p = p') (b : q = q') : (whiskerR a q) @ (whiskerL p' b) = (whiskerL p b) @ (whiskerR a q') := match b with idpath => match a with idpath => (concat_1p _)^ end end. (** Structure corresponding to the coherence equations of a bicategory. *) (** The "pentagonator": the 3-cell witnessing the associativity pentagon. *) Definition pentagon {A : Type} {v w x y z : A} (p : v = w) (q : w = x) (r : x = y) (s : y = z) : whiskerL p (concat_p_pp q r s) @ concat_p_pp p (q@r) s @ whiskerR (concat_p_pp p q r) s = concat_p_pp p q (r@s) @ concat_p_pp (p@q) r s. Proof. case p, q, r, s. reflexivity. Defined. (** The 3-cell witnessing the left unit triangle. *) Definition triangulator {A : Type} {x y z : A} (p : x = y) (q : y = z) : concat_p_pp p 1 q @ whiskerR (concat_p1 p) q = whiskerL p (concat_1p q). Proof. case p, q. reflexivity. Defined. (** The Eckmann-Hilton argument *) Definition eckmann_hilton {A : Type} {x:A} (p q : 1 = 1 :> (x = x)) : p @ q = q @ p := (whiskerR_p1 p @@ whiskerL_1p q)^ @ (concat_p1 _ @@ concat_p1 _) @ (concat_1p _ @@ concat_1p _) @ (concat_whisker _ _ _ _ p q) @ (concat_1p _ @@ concat_1p _)^ @ (concat_p1 _ @@ concat_p1 _)^ @ (whiskerL_1p q @@ whiskerR_p1 p). (** The action of functions on 2-dimensional paths *) Definition ap02 {A B : Type} (f:A->B) {x y:A} {p q:x=y} (r:p=q) : ap f p = ap f q := ap (ap f) r. Definition ap02_pp {A B} (f:A->B) {x y:A} {p p' p'':x=y} (r:p=p') (r':p'=p'') : ap02 f (r @ r') = ap02 f r @ ap02 f r' := ap_pp (ap f) r r'. Definition ap02_p2p {A B} (f:A->B) {x y z:A} {p p':x=y} {q q':y=z} (r:p=p') (s:q=q') : ap02 f (r @@ s) = ap_pp f p q @ (ap02 f r @@ ap02 f s) @ (ap_pp f p' q')^. Proof. case r, s, p, q. reflexivity. Defined. Definition apD02 {A : Type} {B : A -> Type} {x y : A} {p q : x = y} (f : forall x, B x) (r : p = q) : apD f p = transport2 B r (f x) @ apD f q := match r with idpath => (concat_1p _)^ end. Definition apD02_const {A B : Type} (f : A -> B) {x y : A} {p q : x = y} (r : p = q) : apD02 f r = (apD_const f p) @ (transport2_const r (f x) @@ ap02 f r) @ (concat_p_pp _ _ _)^ @ (whiskerL (transport2 _ r (f x)) (apD_const f q)^) := match r with idpath => match p with idpath => 1 end end. (* And now for a lemma whose statement is much longer than its proof. *) Definition apD02_pp {A} (B : A -> Type) (f : forall x:A, B x) {x y : A} {p1 p2 p3 : x = y} (r1 : p1 = p2) (r2 : p2 = p3) : apD02 f (r1 @ r2) = apD02 f r1 @ whiskerL (transport2 B r1 (f x)) (apD02 f r2) @ concat_p_pp _ _ _ @ (whiskerR (transport2_p2p B r1 r2 (f x))^ (apD f p3)). Proof. destruct r1, r2. destruct p1. reflexivity. Defined. Definition ap022 {A B C} (f : A -> B -> C) {x x' y y'} {p p' : x = x'} (r : p = p') {q q' : y = y'} (s : q = q') : ap011 f p q = ap011 f p' q'. Proof. destruct r, p. apply ap02. exact s. Defined. (** These lemmas need better names. *) Definition ap_transport_Vp_idmap {A B} (p q : A = B) (r : q = p) (z : A) : ap (transport idmap q^) (ap (fun s => transport idmap s z) r) @ ap (fun s => transport idmap s (p # z)) (inverse2 r) @ transport_Vp idmap p z = transport_Vp idmap q z. Proof. by path_induction. Defined. Definition ap_transport_pV_idmap {A B} (p q : A = B) (r : q = p) (z : B) : ap (transport idmap q) (ap (fun s => transport idmap s^ z) r) @ ap (fun s => transport idmap s (p^ # z)) r @ transport_pV idmap p z = transport_pV idmap q z. Proof. by path_induction. Defined. (** ** Hints *) (** We declare some more [Hint Resolve] hints, now in the "hint database" [path_hints]. In general various hints (resolve, rewrite, unfold hints) can be grouped into "databases". This is necessary as sometimes different kinds of hints cannot be mixed, for example because they would cause a combinatorial explosion or rewriting cycles. A specific [Hint Resolve] database [db] can be used with [auto with db]. The hints in [path_hints] are designed to push concatenation *outwards*, eliminate identities and inverses, and associate to the left as far as possible. *) #[export] Hint Resolve inverse concat_1p concat_p1 concat_p_pp inv_pp inv_V : path_hints. (* First try at a paths db. We want the RHS of the equation to become strictly simpler. *) #[export] Hint Rewrite @concat_p1 @concat_1p @concat_p_pp (* there is a choice here !*) @concat_pV @concat_Vp @concat_V_pp @concat_p_Vp @concat_pp_V @concat_pV_p (*@inv_pp*) (* I am not sure about this one *) @inv_V @moveR_Mp @moveR_pM @moveL_Mp @moveL_pM @moveL_1M @moveL_M1 @moveR_M1 @moveR_1M @ap_1 (* @ap_pp @ap_p_pp ?*) @inverse_ap @ap_idmap (* @ap_compose @ap_compose'*) @ap_const (* Unsure about naturality of [ap], was absent in the old implementation. *) @apD10_1 : paths. Ltac hott_simpl := autorewrite with paths in * |- * ; auto with path_hints. Coq-HoTT-9.0/theories/Basics/Settings.v000066400000000000000000000100371474641544500177540ustar00rootroot00000000000000(** * General Settings *) (** This file contains all the tweaks and settings we make to Coq. *) (** ** Warnings *) (** ** Plugins *) (** Load the Ltac plugin. This is the tactic language we use for proofs. *) Declare ML Module "ltac_plugin:coq-core.plugins.ltac". (** Load the number string notation plugin. Allowing us to write numbers like [1234]. *) Declare ML Module "number_string_notation_plugin:coq-core.plugins.number_string_notation". (** ** Proofs *) (** Activate the Ltac tactics language for proofs. *) Global Set Default Proof Mode "Classic". (** Force use of bullets in proofs. *) Global Set Default Goal Selector "!". (** ** Universes *) (** Activate universe polymorphism everywhere. This means that whenever you see a [Type], it's actually a [Type@{i}] for some universe level [i]. This allows us to reuse definitions for each universe level without having to redefine them. *) Global Set Universe Polymorphism. (** This command makes it so that you don't have to declare universes explicitly when mentioning them in the type. (Without this command, if you want to say [Definition foo := Type@{i}.], you must instead say [Definition foo@{i} := Type@{i}.]. *) Global Unset Strict Universe Declaration. (** This command makes it so that when we say something like [IsHSet nat] we get [IsHSet@{i} nat] instead of [IsHSet@{Set} nat]. *) Global Unset Universe Minimization ToSet. (** ** Primitive Projections *) Global Set Primitive Projections. Global Set Nonrecursive Elimination Schemes. (** Currently Coq doesn't print equivalences correctly (8.6). This fixes that. See https://github.com/HoTT/HoTT/issues/1000 *) Global Set Printing Primitive Projection Parameters. (** ** Pattern Matching *) (** This flag revoves parameters from constructors in patterns that appear in a match statement. *) Global Set Asymmetric Patterns. (** ** Unification *) (** This command changes Coq's subterm selection to always use full conversion after finding a subterm whose head/key matches the key of the term we're looking for. This applies to [rewrite] and higher-order unification in [apply]/[elim]/[destruct]. Again, if you don't know what that means, ignore it. *) Global Set Keyed Unification. (** ** Typeclasses and Hint settings *) (** This tells Coq that when we [Require] a module without [Import]ing it, typeclass instances defined in that module should also not be imported. In other words, the only effect of [Require] without [Import] is to make qualified names available. *) Global Set Loose Hint Behavior "Strict". Create HintDb rewrite discriminated. #[export] Hint Variables Opaque : rewrite. Create HintDb typeclass_instances discriminated. (** ** Reversible Coercions *) (** Coercions in Coq since 8.16 have the ability to be reversible. These are coercions that are not regular functions but rely on some meta-procedure like typeclass resolution to fill in missing pieces. Examples include marking fields of a record with [:>] which allows Coq to elaborate the projected term to the original term. This behaviour can have some surprising effects in some places, where you might not expect a term to be elaborated. When inspecting proofs with [Set Printing All] you will not be able to see the reverisble coercion. In order to help with inspecting such situations, Coq exposes a register for a dummy term called [reverse_coercion] which gets inserted during an application of a reversible coercion. This way you can see the application clearly in a proof term. We register this here. This is standard from the Coq stdlib prelude.*) #[universes(polymorphic=yes)] Definition ReverseCoercionSource (T : Type) := T. #[universes(polymorphic=yes)] Definition ReverseCoercionTarget (T : Type) := T. #[warning="-uniform-inheritance", reversible=no, universes(polymorphic=yes)] Coercion reverse_coercion {T' T} (x' : T') (x : ReverseCoercionSource T) : ReverseCoercionTarget T' := x'. Register reverse_coercion as core.coercion.reverse_coercion. (** ** Search Settings *) (** Keywords for blacklisting from search function *) Add Search Blacklist "_admitted" "_subproof" "Private_". Coq-HoTT-9.0/theories/Basics/Tactics.v000066400000000000000000000706711474641544500175600ustar00rootroot00000000000000Require Import Basics.Overture. (** TODO: Clean up *) (** * Basic tactics *) (** This module implements various tactics used in the library. *) (** If the goal is [x = z], [path_via y] will replace this with two goals, [x = y] and [y = z]. *) Ltac path_via mid := apply @concat with (y := mid); auto with path_hints. (** The following tactic is designed to be more or less interchangeable with [induction n as [ | n' IH ]] whenever [n] is a [nat] or a [trunc_index]. The difference is that it produces proof terms involving [fix] explicitly rather than [nat_ind] or [trunc_index_ind], and therefore does not introduce higher universe parameters. It works if [n] is in the context or in the goal. *) Ltac simple_induction n n' IH := try generalize dependent n; fix IH 1; intros [| n']; [ clear IH | specialize (IH n') ]. Ltac simple_induction' n := let IH := fresh "IH" in simple_induction n n IH. (** Debugging tactics to show the goal during evaluation. *) Ltac show_goal := match goal with [ |- ?T ] => idtac T end. Ltac show_hyp id := match goal with | [ H := ?b : ?T |- _ ] => match H with | id => idtac id ":=" b ":" T end | [ H : ?T |- _ ] => match H with | id => idtac id ":" T end end. Ltac show_hyps := try match reverse goal with | [ H : ?T |- _ ] => show_hyp H ; fail end. (** Do something on the last hypothesis, or fail *) Ltac on_last_hyp tac := match goal with [ H : _ |- _ ] => first [ tac H | fail 1 ] end. (** Revert the last hypothesis. *) Ltac revert_last := match goal with [ H : _ |- _ ] => revert H end. (** Repeatedly reverse the last hypothesis, putting everything in the goal. *) Ltac reverse := repeat revert_last. (** Reverse everything up to hypothesis id (not included). *) Ltac revert_until id := on_last_hyp ltac:(fun id' => match id' with | id => idtac | _ => revert id' ; revert_until id end). (** Clear duplicated hypotheses *) Ltac clear_dup := match goal with | [ H : ?X |- _ ] => match goal with | [ H' : ?Y |- _ ] => match H with | H' => fail 2 | _ => unify X Y ; (clear H' || clear H) end end end. Ltac clear_dups := repeat clear_dup. (** Try to clear everything except some hyp *) Ltac clear_except hyp := repeat match goal with [ H : _ |- _ ] => match H with | hyp => fail 1 | _ => clear H end end. Ltac on_application f tac T := match T with | context [f ?x ?y ?z ?w ?v ?u ?a ?b ?c] => tac (f x y z w v u a b c) | context [f ?x ?y ?z ?w ?v ?u ?a ?b] => tac (f x y z w v u a b) | context [f ?x ?y ?z ?w ?v ?u ?a] => tac (f x y z w v u a) | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u) | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) | context [f ?x ?y ?z ?w] => tac (f x y z w) | context [f ?x ?y ?z] => tac (f x y z) | context [f ?x ?y] => tac (f x y) | context [f ?x] => tac (f x) end. (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) Ltac on_call f tac := match goal with | |- ?T => on_application f tac T | H : ?T |- _ => on_application f tac T end. (* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object. *) Ltac destruct_call f := let tac t := (destruct t) in on_call f tac. Ltac destruct_calls f := repeat destruct_call f. Ltac destruct_call_in f H := let tac t := (destruct t) in let T := type of H in on_application f tac T. Ltac destruct_call_as f l := let tac t := (destruct t as l) in on_call f tac. Ltac destruct_call_as_in f l H := let tac t := (destruct t as l) in let T := type of H in on_application f tac T. Tactic Notation "destruct_call" constr(f) := destruct_call f. (** Permit to name the results of destructing the call to [f]. *) Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := destruct_call_as f l. (** Specify the hypothesis in which the call occurs as well. *) Tactic Notation "destruct_call" constr(f) "in" hyp(id) := destruct_call_in f id. Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) := destruct_call_as_in f l id. (** A marker for prototypes to destruct. *) Definition fix_proto {A : Type} (a : A) := a. Ltac destruct_rec_calls := match goal with | [ H : fix_proto _ |- _ ] => destruct_calls H ; clear H end. Ltac destruct_all_rec_calls := repeat destruct_rec_calls ; unfold fix_proto in *. (** Try to inject any potential constructor equality hypothesis. *) Ltac inject H := progress (inversion H ; clear_dups) ; clear H. Ltac autoinjections := repeat (clear_dups ; ltac:(inject)). (** Destruct an hypothesis by first copying it to avoid dependencies. *) Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0. (** A tactic to show contradiction by first asserting an automatically provable hypothesis. *) Tactic Notation "contradiction" "by" constr(t) := let H := fresh in assert t as H by auto with * ; contradiction. (** A tactic that adds [H:=p:typeof(p)] to the context if no hypothesis of the same type appears in the goal. Useful to do saturation using tactics. *) Ltac add_hypothesis H' p := match type of p with ?X => match goal with | [ H : X |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' end end. (** A tactic to replace an hypothesis by another term. *) Ltac replace_hyp H c := let H' := fresh "H" in assert(H' := c) ; clear H ; rename H' into H. (** A tactic to refine an hypothesis by supplying some of its arguments. *) Ltac refine_hyp c := let tac H := replace_hyp H c in match c with | ?H _ => tac H | ?H _ _ => tac H | ?H _ _ _ => tac H | ?H _ _ _ _ => tac H | ?H _ _ _ _ _ => tac H | ?H _ _ _ _ _ _ => tac H | ?H _ _ _ _ _ _ _ => tac H | ?H _ _ _ _ _ _ _ _ => tac H end. (** TODO: From here comes from Overture.v *) (** Clear a hypothesis and also its dependencies. Taken from Coq stdlib, with the performance-enhancing change to [lazymatch] suggested at [https://github.com/coq/coq/issues/11689]. *) Tactic Notation "clear" "dependent" hyp(h) := let rec depclear h := clear h || lazymatch goal with | H : context [ h ] |- _ => depclear H; depclear h end || fail "hypothesis to clear is used in the conclusion (maybe indirectly)" in depclear h. (** A version of [generalize dependent] that applies only to a hypothesis. Taken from Coq stdlib. *) Tactic Notation "revert" "dependent" hyp(h) := generalize dependent h. (** Applying a tactic to a term with increasingly many arguments *) Tactic Notation "do_with_holes" tactic3(x) uconstr(p) := x uconstr:(p) || x uconstr:(p _) || x uconstr:(p _ _) || x uconstr:(p _ _ _) || x uconstr:(p _ _ _ _) || x uconstr:(p _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _). (** Same thing but starting with many holes first *) Tactic Notation "do_with_holes'" tactic3(x) uconstr(p) := x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _ _) || x uconstr:(p _ _ _ _ _) || x uconstr:(p _ _ _ _) || x uconstr:(p _ _ _) || x uconstr:(p _ _) || x uconstr:(p _) || x uconstr:(p). (** We keep a list of global axioms that we will solve automatically, even when not using typeclass search. *) Unset Primitive Projections. Class IsGlobalAxiom (A : Type) : Type0 := {}. Set Primitive Projections. Global Hint Mode IsGlobalAxiom + : typeclass_instances. (** We add [Funext] to the list here, and will later add [Univalence]. *) Global Instance is_global_axiom_funext : IsGlobalAxiom Funext := {}. (** Add [PropResizing] to the list of global axioms. *) Global Instance is_global_axiom_propresizing : IsGlobalAxiom PropResizing := {}. Ltac is_global_axiom A := let _ := constr:(_ : IsGlobalAxiom A) in idtac. Ltac global_axiom := try match goal with | |- ?G => is_global_axiom G; exact _ end. (** A shorter name for [simple refine]. *) Tactic Notation "srefine" uconstr(term) := simple refine term. (** A shorter name for [notypeclasses refine]; also handles global axioms. *) Tactic Notation "nrefine" uconstr(term) := notypeclasses refine term; global_axiom. (** A shorter name for [simple notypeclasses refine]; also handles global axioms. *) Tactic Notation "snrefine" uconstr(term) := simple notypeclasses refine term; global_axiom. (** Note that the Coq standard library has a [rapply], but it is like our [rapply'] with many-holes first. We prefer fewer-holes first, for instance so that a theorem producing an equivalence will by preference be used to produce an equivalence rather than to apply the coercion of that equivalence to a function. *) Tactic Notation "rapply" uconstr(term) := do_with_holes ltac:(fun x => refine x) term. Tactic Notation "rapply'" uconstr(term) := do_with_holes' ltac:(fun x => refine x) term. Tactic Notation "srapply" uconstr(term) := do_with_holes ltac:(fun x => srefine x) term. Tactic Notation "srapply'" uconstr(term) := do_with_holes' ltac:(fun x => srefine x) term. Tactic Notation "nrapply" uconstr(term) := do_with_holes ltac:(fun x => nrefine x) term. Tactic Notation "nrapply'" uconstr(term) := do_with_holes' ltac:(fun x => nrefine x) term. Tactic Notation "snrapply" uconstr(term) := do_with_holes ltac:(fun x => snrefine x) term. Tactic Notation "snrapply'" uconstr(term) := do_with_holes' ltac:(fun x => snrefine x) term. (** Apply a tactic to one side of an equation. For example, [lhs rapply lemma]. [tac] should produce a path. *) Tactic Notation "lhs" tactic3(tac) := nrefine (ltac:(tac) @ _). Tactic Notation "lhs_V" tactic3(tac) := nrefine (ltac:(tac)^ @ _). Tactic Notation "rhs" tactic3(tac) := nrefine (_ @ ltac:(tac)^). Tactic Notation "rhs_V" tactic3(tac) := nrefine (_ @ ltac:(tac)). (** Ssreflect tactics, adapted by Robbert Krebbers *) Ltac done := trivial; intros; solve [ repeat first [ solve [trivial] | solve [symmetry; trivial] | reflexivity (* Discriminate should be here, but it doesn't work yet *) (* | discriminate *) | contradiction | split ] | match goal with H : ~ _ |- _ => solve [destruct H; trivial] end ]. Tactic Notation "by" tactic(tac) := tac; done. (** Apply using the same opacity information as typeclass proof search. *) Ltac class_apply c := autoapply c with typeclass_instances. (** A convenient tactic for using function extensionality. *) Ltac by_extensionality x := intros; match goal with | [ |- ?f = ?g ] => eapply path_forall; intro x; match goal with | [ |- forall (_ : prod _ _), _ ] => intros [? ?] | [ |- forall (_ : sig _ _), _ ] => intros [? ?] | _ => intros end; simpl; auto with path_hints end. (** [funext] apply functional extensionality ([path_forall]) to the goal and the introduce the arguments in the context. *) (** For instance, if you have to prove [f = g] where [f] and [g] take two arguments, you can use [funext x y], and the goal become [f x y = g x y]. *) Tactic Notation "funext" simple_intropattern(a) := apply path_forall; intros a. Tactic Notation "funext" simple_intropattern(a) simple_intropattern(b) := funext a; funext b. Tactic Notation "funext" simple_intropattern(a) simple_intropattern(b) simple_intropattern(c) := funext a; funext b; funext c. Tactic Notation "funext" simple_intropattern(a) simple_intropattern(b) simple_intropattern(c) simple_intropattern(d) := funext a; funext b; funext c; funext d. Tactic Notation "funext" simple_intropattern(a) simple_intropattern(b) simple_intropattern(c) simple_intropattern(d) simple_intropattern(e) := funext a; funext b; funext c; funext d; funext e. Tactic Notation "funext" simple_intropattern(a) simple_intropattern(b) simple_intropattern(c) simple_intropattern(d) simple_intropattern(e) simple_intropattern(f) := funext a; funext b; funext c; funext d; funext e; funext f. (* Test whether a tactic fails or succeeds, without actually doing anything. Taken from Coq stdlib. *) Ltac assert_fails tac := tryif (once tac) then gfail 0 tac "succeeds" else idtac. Tactic Notation "assert_succeeds" tactic3(tac) := tryif (assert_fails tac) then gfail 0 tac "fails" else idtac. Tactic Notation "assert_succeeds" tactic3(tac) := assert_succeeds tac. Tactic Notation "assert_fails" tactic3(tac) := assert_fails tac. (** This tactic doesn't end with [auto], but you can always write "by (path_induction;auto with path_hints)" if you want.*) Ltac path_induction := intros; repeat progress ( match goal with | [ p : ?x = ?y |- _ ] => assert_fails constr_eq x y; induction p end ). (** The tactic [f_ap] is a replacement for the previously existing standard library tactic [f_equal]. This tactic works by repeatedly applying the fact that [f = g -> x = y -> f x = g y] to turn, e.g., [f x y = f z w] first into [f x = f z] and [y = w], and then turns the first of these into [f = f] and [x = z]. The [done] tactic is used to detect the [f = f] case and finish, and the [trivial] is used to solve, e.g., [x = x] when using [f_ap] on [f y x = f z x]. This tactic only works for non-dependently-typed functions; we cannot express [y = w] in the first example if [y] and [w] have different types. If and when Arnaud's new-tacticals branch lands, and we can have a goal which depends on the term used to discharge another goal, then this tactic should probably be generalized to deal with dependent functions. *) Ltac f_ap := idtac; lazymatch goal with | [ |- ?f ?x = ?g ?x ] => apply (@apD10 _ _ f g); try (done || f_ap) | _ => apply ap11; [ done || f_ap | trivial ] end. (** [expand] replaces both terms of an equality (either [paths] or [pointwise_paths] in the goal with their head normal forms *) Ltac expand := idtac; match goal with | [ |- ?X = ?Y ] => let X' := eval hnf in X in let Y' := eval hnf in Y in change (X' = Y') | [ |- ?X == ?Y ] => let X' := eval hnf in X in let Y' := eval hnf in Y in change (X' == Y') end; simpl. (** [atomic x] is the same as [idtac] if [x] is a variable or hypothesis, but is [fail 0] if [x] has internal structure. This is useful, for example, to easily destruct all variables that show up as the discriminees of [match] statements, without destructing more complicated terms whose structures might matter. *) Ltac atomic x := idtac; match x with | _ => is_evar x; fail 1 x "is not atomic (evar)" | ?f _ => fail 1 x "is not atomic (application)" | (fun _ => _) => fail 1 x "is not atomic (fun)" | forall _, _ => fail 1 x "is not atomic (forall)" | let x := _ in _ => fail 1 x "is not atomic (let in)" | match _ with _ => _ end => fail 1 x "is not atomic (match)" | _ => is_fix x; fail 1 x "is not atomic (fix)" | _ => is_cofix x; fail 1 x "is not atomic (cofix)" | context[?E] => (* catch-all *) (assert_fails constr_eq E x); fail 1 x "is not atomic (has subterm" E ")" | _ => idtac end. (** Find the head of the given expression. *) Ltac head expr := match expr with | ?f _ => head f | _ => expr end. (** This tactic gets the constructor of any one-constructor inductive type. *) Ltac get_constructor_head T := let x := fresh in let x' := fresh in let h := open_constr:(_) in let __ := constr:(fun (x : T) => let x' := x in ltac:(destruct x; let x' := (eval cbv delta [x'] in x') in let x' := head x' in unify h x'; exact tt)) in h. (* A version of econstructor that doesn't resolve typeclasses. *) Ltac ntc_constructor := lazymatch goal with | [ |- ?G ] => let build := get_constructor_head G in nrapply build end. (** [case_path] is a HoTT replacement for [case_eq]; [case_path x] is like [destruct x], but it remembers the original value of [x] in an equation to be introduced. *) Ltac case_path x := let x' := fresh "x" in set (x' := x); generalize (idpath : x' = x); clearbody x'; destruct x'. (** [revert_opaque x] is like [revert x], except that it fails if [x] is not an opaque variable (i.e. if it has a [:=] definition rather than just a type). *) Ltac revert_opaque x := revert x; match goal with | [ |- forall _, _ ] => idtac | _ => fail 1 "Reverted constant is not an opaque variable" end. (** [transparent assert (H : T)] is like [assert (H : T)], but leaves the body transparent. *) (** Since binders don't respect [fresh], we use a name unlikely to be reused. *) Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" := simple refine (let __transparent_assert_hypothesis := (_ : type) in _); [ | ((* We cannot use the name [__transparent_assert_hypothesis], due to some infelicities in the naming of bound variables. So instead we pull the bottommost hypothesis. *) let H := match goal with H := _ |- _ => constr:(H) end in rename H into name) ]. (** [transparent eassert] is like [transparent assert], but allows holes in the type, which will be turned into evars. *) Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" "by" tactic3(tac) := let name := fresh "H" in transparent assert (name : type); [ solve [ tac ] | ]. Tactic Notation "transparent" "eassert" "(" ident(name) ":" open_constr(type) ")" := transparent assert (name : type). Tactic Notation "transparent" "eassert" "(" ident(name) ":" open_constr(type) ")" "by" tactic3(tac) := transparent assert (name : type) by tac. (** A version of Coq's [remember] that uses our equality. *) Ltac remember_as term name eqname := set (name := term) in *; pose (eqname := idpath : term = name); clearbody eqname name. Tactic Notation "remember" constr(term) "as" ident(name) "eqn:" ident(eqname) := remember_as term name eqname. (** A variant that doesn't substitute in the goal and hypotheses. *) Ltac recall_as term name eqname := pose (name := term); pose (eqname := idpath : term = name); clearbody eqname name. Tactic Notation "recall" constr(term) "as" ident(name) "eqn:" ident(eqname) := recall_as term name eqname. (** [rel_hnf], when given a goal of the form [R x y] for any relation [R], puts [x] and [y] in head normal form. *) Ltac rel_hnf := idtac; match goal with | [ |- ?R ?x ?y ] => let x' := (eval hnf in x) in let y' := (eval hnf in y) in change (R x' y') end. (** This tactic is a version of [tryif require () then if_yes () else if_no ()] which is suitable for use in constructing constrs by virtue of being evaluated during the Ltac expression evaluation phase rather than during the tactic running phase. All three arguments are expected to be tactic thunks which will be passed a dummy unit argument.*) Ltac tryif_cps require if_yes if_no := let res := match constr:(Set) with | _ => let __ := match constr:(Set) with _ => require () end in ltac:(if_yes) | _ => ltac:(if_no) end in res (). (** The following tactic [issig] proves automatically that a record type is equivalent to a nested Sigma-type. Specifically, it proves a goal that looks like << { x : A & B x } <~> Some_Record >> In fact you don't even have to write down the sigma type. Though it is good practice to write it out anyway, this tactic can work out the sigma type and tell you what it should look like. The following should generate the desired equivalence. You can check the definition to see what type it has and therefore what the sigma type should be. << Definition issig_myrecord : _ <~> MyRecord := ltac:(issig). Check issig_myrecord. >> In order to define this tactic we have many helper tactics. *) Local Ltac peel_evars term := lazymatch term with | ?f ?x => tryif_cps ltac:(fun _ => has_evar x) ltac:(fun _ => peel_evars f) ltac:(fun _ => term) | _ => term end. Local Ltac pi_to_sig ty := lazymatch (eval cbv beta in ty) with | forall (x : ?T) (y : @?A x), @?P x y => let x' := fresh in constr:(@sig T (fun x' : T => ltac:(let res := pi_to_sig (forall y : A x', P x' y) in exact res))) | ?T -> _ => T end. Local Ltac ctor_to_sig ctor := let ctor := peel_evars ctor in let t := type of ctor in pi_to_sig t. Local Ltac unify_first_evar_with term u := lazymatch term with | ?f ?x => tryif has_evar f then unify_first_evar_with f u else unify x u end. Local Ltac unify_with_projections term u := (unify_first_evar_with term u.1; unify_with_projections term u.2) + (unify_first_evar_with term u; tryif has_evar term then fail 0 term "has evars remaining" else idtac). (* Completely destroys v into its pieces and trys to put pieces in sigma. *) Local Ltac refine_with_exist_as_much_as_needed_then_destruct v := ((destruct v; shelve) + (snrefine (_ ; _); [ destruct v; shelve | refine_with_exist_as_much_as_needed_then_destruct v ])). (* Finally we can define our issig tactic: *) Ltac issig := hnf; (* First we make sure things are normalised. *) (* We get the types either side of the equivalence. *) let A := match goal with |- ?sigma <~> ?record => constr:(sigma) end in let B := match goal with |- ?sigma <~> ?record => constr:(record) end in let u := fresh "u" in let v := fresh "v" in (** We build an equivalence with 5 holes. *) snrefine (* We don't want typeclass search running. *) (Build_Equiv A B _ (Build_IsEquiv A B (fun u => _) (fun v => _) (fun v => _) (fun u => _) (fun _ => _))); (** Going from a sigma type to a record *) [ (* let built be the constructor of T *) let T := match goal with |- ?T => T end in (* We want to get the constructor of the record. Note that we use [ntc_constructor] instead of [econstructor] since we don't want to resolve typeclasses. If we used [econstructor] then the constructor would be wrong for many records whose fields are classes. [ntc_constructor] is defined in Overture.v. *) let built := open_constr:(ltac:(ntc_constructor) : T) in let A' := ctor_to_sig built in unify A A'; unify_with_projections built u; refine built (** Going from a record to a sigma type *) | refine_with_exist_as_much_as_needed_then_destruct v (** Proving eissect *) | destruct v; cbn [pr1 pr2]; reflexivity (** Proving eisretr *) | reflexivity (** Proving eisadj *) | reflexivity ]. (** We show how the tactic works in a couple of examples. *) Definition issig_equiv (A B : Type) : {f : A -> B & IsEquiv f} <~> Equiv A B. Proof. issig. Defined. Definition issig_isequiv {A B : Type} (f : A -> B) : {g : B -> A & {r : f o g == idmap & { s : g o f == idmap & forall x : A, r (f x) = ap f (s x)}}} <~> IsEquiv f. Proof. issig. Defined. (** The general reasoning behind the issig tactic is: if we know the type of the record, econstructor will give us the constructor applied to evars for each field. If we assume that there are no evars in the type, we can unify the first evar with u.1, the next evar with u.2.1, the next with u.2.2.1, etc, and if we run out of evars or projections, we backtrack and instead fill the final evar with u.2.2....2. (Note that if we strip the trailing evars from the constructor before unifying them, we get a term with a Pi type, and if we drop the final codomain and turn the Pi type into a Sigma, this lets us autogenerate the Sigma type we should be using; this is how the versions that don't need a hand-crafted Sigma type work: they unify the generated type with the term in the goal that should be the Sigma type.) Generating the function the other way is a bit trickier, because there's no easy way to get our hands on all the projections of the record, and moreover we don't even know how many pairings we'll need. The thing we want to do is introduce the right number of pairings, destruct the variable of record type in the goal for each component, and then magically use the right projection. I'll get back to the magic in a moment; first we need to take care of the "right number" of pairings. We could pull a trick where we infer the number by looking at the term we get from econstructor in a goal whose type is the record. Instead, I chose the more concise route of coding a tactic that introduces the minimum number of pairings needed to make the magic work. How does it know the minimum number? It doesn't need to! The wonder of (recursive) multisuccess tactics is that you can say "try no pairings, and if that makes any future tactic fail, backtrack and try one pairing, and if that doesn't work, backtrack and try two pairings, etc". (The downside is that the error messages you get when you set things up wrong are truly incomprehensible, because if you make a typo in any of the fields of the Sigma type the error message you end up getting is something like "(_; _) is a Sigma type but it was expected to have the type of the final field" (and it's always about the final field, regardless of which field you made a typo in). So plausibly it's worth it to still do the small issig tactics by hand, and only use this tactic for >= 5 fields or something.) Okay, now onto the magic. How do we know which field is the right one? Well, there's only one answer that lets us prove the section and retraction by destruct+reflexivity, so we can let unification solve this problem for us. It's important to have destructed the record variable in each of the pair-component evars, because unification is not (yet) smart enough to invert records for us; this is what the destruct before shelve in the inverse function generation tactic is. We cbn pr1 and pr2 to make the unification problem be completely syntactic (no need to unfold anything during unification). This is probably not strictly necessary, but seems like good form to me. Finally, we can prove the other one of the section/retraction pair (I can never recall which is which), and the adjoint, by reflexivity. (Perhaps it would be better to use exact idpath, if we want to not have to unfold reflexivity when using equivalences generated by these tactics.) *) Coq-HoTT-9.0/theories/Basics/Trunc.v000066400000000000000000000400261474641544500172500ustar00rootroot00000000000000(** * Truncatedness *) Require Import Basics.Overture Basics.Contractible Basics.Equivalences Basics.Tactics Basics.Nat Basics.Iff. Local Set Universe Minimization ToSet. Local Open Scope trunc_scope. Local Open Scope path_scope. Generalizable Variables A B m n f. (** ** Notation for truncation-levels *) Open Scope trunc_scope. (** Increase a truncation index by a natural number. *) Fixpoint trunc_index_inc@{} (k : trunc_index) (n : nat) : trunc_index := match n with | O => k | S m => (trunc_index_inc k m).+1 end. (** This is a variation that inserts the successor operations in the other order. This is sometimes convenient. *) Fixpoint trunc_index_inc'@{} (k : trunc_index) (n : nat) : trunc_index := match n with | O => k | S m => (trunc_index_inc' k.+1 m) end. Definition trunc_index_inc'_succ@{} (n : nat) (k : trunc_index) : trunc_index_inc' k.+1 n = (trunc_index_inc' k n).+1. Proof. revert k; simple_induction n n IHn; intro k. - reflexivity. - apply (IHn k.+1). Defined. Definition trunc_index_inc_agree@{} (k : trunc_index) (n : nat) : trunc_index_inc k n = trunc_index_inc' k n. Proof. simple_induction n n IHn. - reflexivity. - simpl. refine (ap _ IHn @ _). symmetry; apply trunc_index_inc'_succ. Defined. Definition nat_to_trunc_index@{} (n : nat) : trunc_index := (trunc_index_inc minus_two n).+2. Coercion nat_to_trunc_index : nat >-> trunc_index. Definition trunc_index_inc'_0n (n : nat) : trunc_index_inc' 0%nat n = n. Proof. induction n as [|n p]. 1: reflexivity. refine (trunc_index_inc'_succ _ _ @ _). exact (ap _ p). Defined. Definition int_to_trunc_index@{} (v : Decimal.int) : option trunc_index := match v with | Decimal.Pos d => Some (nat_to_trunc_index (Nat.of_uint d)) | Decimal.Neg d => match Nat.of_uint d with | 2%nat => Some minus_two | 1%nat => Some (minus_two.+1) | 0%nat => Some (minus_two.+2) | _ => None end end. Definition num_int_to_trunc_index@{} (v : Numeral.int) : option trunc_index := match v with | Numeral.IntDec v => int_to_trunc_index v | Numeral.IntHex _ => None end. Fixpoint trunc_index_to_little_uint@{} n acc := match n with | minus_two => acc | minus_two.+1 => acc | minus_two.+2 => acc | trunc_S n => trunc_index_to_little_uint n (Decimal.Little.succ acc) end. Definition trunc_index_to_int@{} n := match n with | minus_two => Decimal.Neg (Nat.to_uint 2) | minus_two.+1 => Decimal.Neg (Nat.to_uint 1) | n => Decimal.Pos (Decimal.rev (trunc_index_to_little_uint n Decimal.zero)) end. Definition trunc_index_to_num_int@{} n := Numeral.IntDec (trunc_index_to_int n). (** This allows us to use notation like (-2) and 42 for a [trunc_index]. *) Number Notation trunc_index num_int_to_trunc_index trunc_index_to_num_int : trunc_scope. (** Sends a trunc_index [n] to the natural number [n+2]. *) Fixpoint trunc_index_to_nat (n : trunc_index) : nat := match n with | minus_two => 0%nat | n'.+1 => (trunc_index_to_nat n').+1 end. (** ** Arithmetic on truncation-levels. *) Fixpoint trunc_index_add@{} (m n : trunc_index) : trunc_index := match m with | -2 => n | m'.+1 => (trunc_index_add m' n).+1 end. Notation "m +2+ n" := (trunc_index_add m n) : trunc_scope. Definition trunc_index_add_minus_two@{} m : m +2+ -2 = m. Proof. simple_induction m m IHm. 1: reflexivity. cbn; apply ap. assumption. Defined. Definition trunc_index_add_succ@{} m n : m +2+ n.+1 = (m +2+ n).+1. Proof. revert m; simple_induction n n IHn; intro m; simple_induction m m IHm. 1,3: reflexivity. all: cbn; apply ap. all: assumption. Defined. Definition trunc_index_add_comm@{} m n : m +2+ n = n +2+ m. Proof. simple_induction n n IHn. - apply trunc_index_add_minus_two. - exact (trunc_index_add_succ _ _ @ ap trunc_S IHn). Defined. Fixpoint trunc_index_leq@{} (m n : trunc_index) : Type0 := match m, n with | -2, _ => Unit | m'.+1, -2 => Empty | m'.+1, n'.+1 => trunc_index_leq m' n' end. Existing Class trunc_index_leq. Notation "m <= n" := (trunc_index_leq m n) : trunc_scope. Global Instance trunc_index_leq_minus_two_n@{} n : -2 <= n := tt. Global Instance trunc_index_leq_succ@{} n : n <= n.+1. Proof. by induction n as [|n IHn] using trunc_index_ind. Defined. Definition trunc_index_pred@{} : trunc_index -> trunc_index. Proof. intros [|m]. 1: exact (-2). exact m. Defined. Notation "n '.-1'" := (trunc_index_pred n) : trunc_scope. Notation "n '.-2'" := (n.-1.-1) : trunc_scope. Definition trunc_index_succ_pred@{} (n : nat) : (n.-1).+1 = n. Proof. simple_induction n n IHn. 1: reflexivity. unfold nat_to_trunc_index in *; cbn in *. refine (ap trunc_S IHn). Defined. Definition trunc_index_leq_minus_two@{} {n} : n <= -2 -> n = -2. Proof. destruct n. 1: reflexivity. contradiction. Defined. Definition trunc_index_leq_succ'@{} n m : n <= m -> n <= m.+1. Proof. revert m. induction n as [|n IHn] using trunc_index_ind. 1: exact _. intros m p; cbn. induction m as [|m IHm] using trunc_index_ind. 1: destruct p. apply IHn, p. Defined. Global Instance trunc_index_leq_refl@{} : Reflexive trunc_index_leq. Proof. intro n. by induction n as [|n IHn] using trunc_index_ind. Defined. Global Instance trunc_index_leq_transitive@{} : Transitive trunc_index_leq. Proof. intros a b c p q. revert b a c p q. induction b as [|b IHb] using trunc_index_ind. { intros a c p. by destruct (trunc_index_leq_minus_two p). } induction a as [|a IHa] using trunc_index_ind; induction c as [|c IHc] using trunc_index_ind. all: intros. 1,2: exact tt. 1: contradiction. cbn in p, q; cbn. by apply IHb. Defined. Definition trunc_index_leq_add@{} n m : n <= m +2+ n. Proof. simple_induction m m IHm. - reflexivity. - rapply trunc_index_leq_transitive. Defined. Definition trunc_index_leq_add'@{} n m : n <= n +2+ m. Proof. rewrite trunc_index_add_comm. apply trunc_index_leq_add. Defined. Fixpoint trunc_index_min@{} (n m : trunc_index) : trunc_index. Proof. destruct n. 1: exact (-2). destruct m. 1: exact (-2). exact (trunc_index_min n m).+1. Defined. Definition trunc_index_min_minus_two@{} n : trunc_index_min n (-2) = -2. Proof. by destruct n. Defined. Definition trunc_index_min_swap@{} n m : trunc_index_min n m = trunc_index_min m n. Proof. revert m. simple_induction n n IHn; intro m. { symmetry. apply trunc_index_min_minus_two. } simple_induction m m IHm. 1: reflexivity. cbn; apply ap, IHn. Defined. Definition trunc_index_min_path@{} n m : (trunc_index_min n m = n) + (trunc_index_min n m = m). Proof. revert m; simple_induction n n IHn; intro m. 1: by apply inl. simple_induction m m IHm. 1: by apply inr. destruct (IHn m). 1: apply inl. 2: apply inr. 1,2: cbn; by apply ap. Defined. Definition trunc_index_min_leq_left@{} (n m : trunc_index) : trunc_index_min n m <= n. Proof. revert n m. refine (trunc_index_ind _ _ _); [ | intros n IHn ]. all: refine (trunc_index_ind _ _ _); [ | intros m IHm ]. all: try exact tt. exact (IHn m). Defined. Definition trunc_index_min_leq_right@{} (n m : trunc_index) : trunc_index_min n m <= m. Proof. revert n m. refine (trunc_index_ind _ _ _); [ | intros n IHn ]. all: refine (trunc_index_ind _ _ _); [ | intros m IHm ]. all: try exact tt. exact (IHn m). Defined. (** ** Truncatedness proper. *) (** A contractible space is (-2)-truncated, by definition. This function is the identity, so there is never any need to actually use it, but it exists to be found in searches. *) Definition contr_istrunc_minus_two `{H : IsTrunc (-2) A} : Contr A := H. (** Truncation levels are cumulative. *) Global Instance istrunc_paths' {n : trunc_index} {A : Type} `{IsTrunc n A} : forall x y : A, IsTrunc n (x = y) | 1000. Proof. generalize dependent A. simple_induction n n IH; simpl; intros A H x y. - apply contr_paths_contr. - apply istrunc_S. rapply IH. Defined. Global Instance istrunc_succ {n : trunc_index} {A : Type} `{IsTrunc n A} : IsTrunc n.+1 A | 1000. Proof. apply istrunc_S. apply istrunc_paths'. Defined. (** This could be an [Instance] (with very high priority, so it doesn't get applied trivially). However, we haven't given typeclass search any hints allowing it to solve goals like [m <= n], so it would only ever be used trivially. *) Definition istrunc_leq {m n} (Hmn : m <= n) `{IsTrunc m A} : IsTrunc n A. Proof. generalize dependent A; generalize dependent m. simple_induction n n' IH; intros [ | m'] Hmn A ? . - (* -2, -2 *) assumption. - (* S m', -2 *) destruct Hmn. - (* -2, S n' *) apply @istrunc_succ, (IH (-2)); auto. - (* S m', S n' *) apply istrunc_S. intros x y; apply (IH m'); auto with typeclass_instances. Defined. (** In particular, a contractible type, hprop, or hset is truncated at all higher levels. We don't allow these to be used as idmaps, since there would be no point to it. *) Definition istrunc_contr {n} {A} `{Contr A} : IsTrunc n.+1 A := (@istrunc_leq (-2) n.+1 tt _ _). Definition istrunc_hprop {n} {A} `{IsHProp A} : IsTrunc n.+2 A := (@istrunc_leq (-1) n.+2 tt _ _). Definition istrunc_hset {n} {A} `{IsHSet A} : IsTrunc n.+3 A := (@istrunc_leq 0 n.+3 tt _ _). (** Consider the preceding definitions as instances for typeclass search, but only if the requisite hypothesis is already a known assumption; otherwise they result in long or interminable searches. *) #[export] Hint Immediate istrunc_contr : typeclass_instances. #[export] Hint Immediate istrunc_hprop : typeclass_instances. #[export] Hint Immediate istrunc_hset : typeclass_instances. (** Equivalence preserves truncation (this is, of course, trivial with univalence). This is not an [Instance] because it causes infinite loops. *) Definition istrunc_isequiv_istrunc A {B} (f : A -> B) `{IsTrunc n A} `{IsEquiv A B f} : IsTrunc n B. Proof. generalize dependent B; generalize dependent A. simple_induction n n IH; simpl; intros A ? B f ?. - exact (contr_equiv _ f). - apply istrunc_S. intros x y. refine (IH _ _ _ (ap (f^-1))^-1 _). Defined. Definition istrunc_equiv_istrunc A {B} (f : A <~> B) `{IsTrunc n A} : IsTrunc n B := istrunc_isequiv_istrunc A f. (** ** Truncated morphisms *) Class IsTruncMap (n : trunc_index) {X Y : Type} (f : X -> Y) := istruncmap_fiber : forall y:Y, IsTrunc n (hfiber f y). Global Existing Instance istruncmap_fiber. Notation IsEmbedding := (IsTruncMap (-1)). (** ** Universes of truncated types *) (** It is convenient for some purposes to consider the universe of all n-truncated types (within a given universe of types). In particular, this allows us to state the important fact that each such universe is itself (n+1)-truncated. *) Record TruncType (n : trunc_index) := { trunctype_type : Type ; trunctype_istrunc : IsTrunc n trunctype_type }. Arguments Build_TruncType _ _ {_}. Arguments trunctype_type {_} _. Arguments trunctype_istrunc [_] _. Coercion trunctype_type : TruncType >-> Sortclass. Global Existing Instance trunctype_istrunc. Notation "n -Type" := (TruncType n) : type_scope. Notation HProp := (-1)-Type. Notation HSet := 0-Type. Notation Build_HProp := (Build_TruncType (-1)). Notation Build_HSet := (Build_TruncType 0). (** This is (as of October 2014) the only [Canonical Structure] in the library. It would be nice to do without it, in the interests of minimizing the number of fancy Coq features that the reader needs to know about. *) Canonical Structure default_TruncType := fun n T P => (@Build_TruncType n T P). (** Version of [smalltype] for n-Types. *) Definition smallntype@{i j} (n : trunc_index) (P : TruncType@{j} n) {smallP : IsSmall@{i j} P} : TruncType@{i} n. Proof. nrapply (Build_TruncType n (smalltype P)). apply (@istrunc_equiv_istrunc _ _ (equiv_smalltype P)^-1 n _). Defined. Notation smallhprop := (smallntype (-1)). (** ** Facts about hprops *) (** An inhabited proposition is contractible. This is not an [Instance] because it causes infinite loops. *) Lemma contr_inhabited_hprop (A : Type) `{H : IsHProp A} (x : A) : Contr A. Proof. apply (Build_Contr _ x). intro y. rapply center. Defined. (** If inhabitation implies contractibility, then we have an h-proposition. We probably won't often have a hypothesis of the form [A -> Contr A], so we make sure we give priority to other instances. *) Global Instance hprop_inhabited_contr (A : Type) : (A -> Contr A) -> IsHProp A | 10000. Proof. intros H; apply istrunc_S; intros x y. pose (C := H x). apply contr_paths_contr. Defined. (** Any two points in an hprop are connected by a path. *) Theorem path_ishprop `{H : IsHProp A} : forall x y : A, x = y. Proof. intros x y. rapply center. Defined. (** Conversely, this property characterizes hprops. *) Theorem hprop_allpath (A : Type) : (forall (x y : A), x = y) -> IsHProp A. Proof. intros H; apply istrunc_S; intros x y. nrapply contr_paths_contr. exact (Build_Contr _ x (H x)). Defined. (** Two propositions are equivalent as soon as there are maps in both directions. *) Definition isequiv_iff_hprop `{IsHProp A} `{IsHProp B} (f : A -> B) (g : B -> A) : IsEquiv f. Proof. apply (isequiv_adjointify f g); intros ?; apply path_ishprop. Defined. Definition equiv_iff_hprop_uncurried `{IsHProp A} `{IsHProp B} : (A <-> B) -> (A <~> B). Proof. intro fg. apply (equiv_adjointify (fst fg) (snd fg)); intros ?; apply path_ishprop. Defined. Definition equiv_iff_hprop `{IsHProp A} `{IsHProp B} : (A -> B) -> (B -> A) -> (A <~> B) := fun f g => equiv_iff_hprop_uncurried (f, g). Corollary iff_contr_hprop (A : Type) `{IsHProp A} : Contr A <-> A. Proof. split. - apply center. - rapply contr_inhabited_hprop. Defined. (** ** Truncatedness: any dependent product of n-types is an n-type *) Definition contr_forall `{Funext} `{P : A -> Type} `{forall a, Contr (P a)} : Contr (forall a, P a). Proof. apply (Build_Contr _ (fun a => center (P a))). intro f. apply path_forall. intro a. apply contr. Defined. Global Instance istrunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)} : IsTrunc n (forall a, P a) | 100. Proof. generalize dependent P. simple_induction n n IH; simpl; intros P ?. (* case [n = -2], i.e. contractibility *) - apply contr_forall. (* case n = n'.+1 *) - apply istrunc_S. intros f g; apply (istrunc_isequiv_istrunc@{u1 u1} _ (apD10@{_ _ u1} ^-1)). Defined. (** Truncatedness is an hprop. *) Global Instance ishprop_istrunc `{Funext} (n : trunc_index) (A : Type) : IsHProp (IsTrunc n A) | 0. Proof. revert A; simple_induction n n IH; cbn; intro A. - nrapply (istrunc_equiv_istrunc _ (equiv_istrunc_unfold (-2) A)^-1%equiv). apply hprop_allpath. intros [a1 c1] [a2 c2]. destruct (c1 a2). apply (ap (exist _ a1)). funext x. pose (Build_Contr _ a1 c1); apply path2_contr. - rapply (istrunc_equiv_istrunc _ (equiv_istrunc_unfold n.+1 A)^-1%equiv). (* This case follows from [istrunc_forall]. *) Defined. (** By [trunc_hprop], it follows that [IsTrunc n A] is also [m]-truncated for any [m >= -1]. *) (** Similarly, a map being truncated is also a proposition. *) Global Instance ishprop_istruncmap `{Funext} (n : trunc_index) {X Y : Type} (f : X -> Y) : IsHProp (IsTruncMap n f). Proof. apply hprop_allpath; intros s t. apply path_forall; intros x. apply path_ishprop. Defined. (** If a type [A] is [n]-truncated, then [IsTrunc n A] is contractible. *) Global Instance contr_istrunc `{Funext} (n : trunc_index) (A : Type) `{istruncA : IsTrunc n A} : Contr (IsTrunc n A) | 100 := contr_inhabited_hprop _ _. Corollary equiv_contr_hprop (A : Type) `{Funext} `{IsHProp A} : Contr A <~> A. Proof. exact (equiv_iff_hprop_uncurried (iff_contr_hprop A)). Defined. (** If a type [A] implies that it is [n.+1]-truncated, then it is [n.+1]-truncated. **) Definition istrunc_inhabited_istrunc {n : trunc_index} {A : Type} (H : A -> IsTrunc n.+1 A) : IsTrunc n.+1 A := istrunc_S _ (fun a b => H a a b). (** If you are looking for a theorem about truncation, you may want to read the note "Finding Theorems" in "STYLE.md". *) Coq-HoTT-9.0/theories/Basics/Utf8.v000066400000000000000000000075021474641544500170050ustar00rootroot00000000000000Reserved Notation "'∀' x .. y , P" (at level 200, x binder, y binder, right associativity). Reserved Notation "'∃' x .. y , P" (at level 200, x binder, y binder, right associativity). Reserved Notation "'λ' x .. y , t" (at level 200, x binder, y binder, right associativity). Reserved Notation "x ∧ y" (at level 80, right associativity). Reserved Notation "x → y" (at level 99, y at level 200, right associativity). Reserved Notation "x ↔ y" (at level 95, no associativity). (*Notation "¬ x" (at level 75, right associativity).*) (*Notation "x ≠ y" (at level 70).*) Reserved Infix "∩" (at level 20). Reserved Infix "⋅" (at level 20). Reserved Infix "∙" (at level 20). Reserved Infix "∘" (at level 40, left associativity). Reserved Infix "∘ˡ" (at level 40, left associativity). Reserved Infix "∘ʳ" (at level 40, left associativity). Reserved Infix "⊣" (at level 60, right associativity). Reserved Infix "≅" (at level 70, no associativity). Reserved Notation "A 'ᵒᵖ'" (at level 1). Reserved Notation "A × B" (at level 40, left associativity). Reserved Notation "a ≤ b" (at level 70, no associativity). Reserved Notation "A ≃ B" (at level 85). #[warnings="-postfix-notation-not-level-1"] Reserved Notation "a ⇓ 'CAT'" (at level 40, left associativity). #[warnings="-postfix-notation-not-level-1"] Reserved Notation "a ⇑ 'CAT'" (at level 40, left associativity). Reserved Notation "a ≤_{ x } b" (at level 70, no associativity). Reserved Notation "C ↓ a" (at level 70, no associativity). Reserved Notation "'CAT' ⇓ a" (at level 40, left associativity). Reserved Notation "'CAT' ⇑ a" (at level 40, left associativity). Reserved Notation "C → D" (at level 99, D at level 200, right associativity). Reserved Notation "f '⁻¹'" (at level 1, format "f '⁻¹'"). (* Reserved Notation "f ×ᴱ g" (at level 40, no associativity). *) (* Reserved Notation "f *ᴱ g" (at level 40, no associativity). *) Reserved Notation "f +ᴱ g" (at level 50, left associativity). Reserved Notation "F ₁ m" (at level 10, no associativity). Reserved Notation "F ₀ x" (at level 10, no associativity). Reserved Notation "g ∘ f" (at level 40, left associativity). Reserved Notation "g ∘ᴱ f" (at level 40, left associativity). Reserved Notation "m ≤ n" (at level 70, no associativity). Reserved Notation "p • q" (at level 20). Reserved Notation "p •' q" (at level 21, left associativity, format "'[v' p '/' '•'' q ']'"). #[warnings="-postfix-notation-not-level-1"] Reserved Notation "x ₁" (at level 10). Reserved Notation "x ₂" (at level 1). Reserved Notation "¬ x" (at level 35, right associativity). Reserved Notation "x ⇓ F" (at level 40, left associativity). Reserved Notation "x ⇑ F" (at level 40, left associativity). Reserved Notation "x ∈ v" (at level 30). Reserved Notation "x ⊆ y" (at level 30). Reserved Notation "x ≠ y" (at level 70). Reserved Notation "x ⇸ y" (at level 99, right associativity, y at level 200). Reserved Notation "x ↠ y" (at level 99, right associativity, y at level 200). Reserved Notation "x ↪ y" (at level 99, right associativity, y at level 200). Reserved Notation "A ⊗ B" (at level 45, left associativity). (* Reserved Notation "∀ x .. y , P" (at level 200, x binder, y binder, right associativity). *) Reserved Notation "x ∨ y" (at level 85, right associativity). (* Reserved Notation "x ⊔ y" (at level 85, right associativity). *) Reserved Infix "≶" (at level 70, no associativity). Reserved Infix "⊓" (at level 50, no associativity). Reserved Infix "⊔" (at level 50, no associativity). Reserved Infix "∸" (at level 50, left associativity). Reserved Notation "x ≤ y ≤ z" (at level 70, y at next level). Reserved Notation "x ≤ y < z" (at level 70, y at next level). Reserved Notation "x < y ≤ z" (at level 70, y at next level). Reserved Notation "'π'" (at level 0). Coq-HoTT-9.0/theories/BoundedSearch.v000066400000000000000000000104361474641544500174610ustar00rootroot00000000000000(** * Bounded Search *) (** The main result of this file is [minimal_n], which say that if [P : nat -> Type] is a family such that each [P n] is decidable and [{n & P n}] is merely inhabited, then [{n & P n}] is inhabited. Since [P n] is decidable, it is sufficient to prove [{n & merely (P n)}], and to do this, we prove the stronger claim that there is a *minimal* [n] satisfying [merely (P n)]. This stronger claim is a proposition, which is what makes the argument work. Along the way, we also prove that [{ l : nat & (l <= n) * P l }] is decidable for each [n]. *) Require Import Basics.Overture Basics.Decidable Basics.Trunc Basics.Tactics. Require Import Types.Sigma Types.Prod. Require Import Truncations.Core. Require Import Spaces.Nat.Core. Section bounded_search. Context (P : nat -> Type) (P_dec : forall n, Decidable (P n)). (** We open type_scope again after nat_scope in order to use the product type notation. *) Local Open Scope nat_scope. Local Open Scope type_scope. Local Definition minimal (n : nat) : Type := forall m : nat, P m -> n <= m. (** If we assume [Funext], then [minimal n] is a proposition. But to avoid needing [Funext], we propositionally truncate it. *) Local Definition min_n_Type : Type := { n : nat & merely (P n) * merely (minimal n) }. Local Instance ishpropmin_n : IsHProp min_n_Type. Proof. apply ishprop_sigma_disjoint. intros n n' [p m] [p' m']. strip_truncations. apply leq_antisym. - exact (m n' p'). - exact (m' n p). Defined. Local Definition smaller (n : nat) := { l : nat & P l * minimal l * (l <= n) }. Local Definition smaller_S (n : nat) (k : smaller n) : smaller (S n). Proof. destruct k as [l [[p m] z]]. exists l. repeat split. 1,2: assumption. exact _. Defined. Local Definition bounded_search (n : nat) : smaller n + forall l : nat, (l <= n) -> not (P l). Proof. induction n as [|n IHn]. - destruct (dec (P 0)) as [h|n]. + left. exact (0; (h, fun _ _ => _, _)). + right. intros l lleq0. by rewrite (leq_antisym lleq0 _ : l = 0). - destruct IHn as [s|n0]. + left; by apply smaller_S. + destruct (dec (P n.+1)) as [h|nP]. * left. refine (n.+1; (h, _, _)). intros m pm. apply leq_iff_not_gt. unfold gt, lt; intro leq_Sm_Sn. apply leq_pred' in leq_Sm_Sn. destruct (n0 m leq_Sm_Sn pm). * right. by apply leq_ind_l. Defined. Local Definition n_to_min_n (n : nat) (Pn : P n) : min_n_Type. Proof. destruct (bounded_search n) as [[l [[Pl ml] _]] | none]. - exact (l; (tr Pl, tr ml)). - destruct (none n (leq_refl n) Pn). Defined. Local Definition prop_n_to_min_n (P_inhab : hexists P) : min_n_Type. Proof. strip_truncations. exact (n_to_min_n (P_inhab.1) (P_inhab.2)). Defined. Definition minimal_n (P_inhab : hexists P) : { n : nat & P n }. Proof. destruct (prop_n_to_min_n P_inhab) as [n [p _]]. exact (n; fst merely_inhabited_iff_inhabited_stable p). Defined. (** As a consequence of [bounded_search] we deduce that bounded existence is decidable. See also [decidable_exists_bounded_nat] in Spaces/Lists/Theory.v for a similar result with different dependencies. *) Definition decidable_search (n : nat) : Decidable { l : nat & (l <= n) * P l }. Proof. destruct (bounded_search n) as [s | no_l]. - destruct s as [l [[Pl min] l_leq_n]]. exact (inl (l; (l_leq_n, Pl))). - right. intros [l [l_leq_n Pl]]. exact (no_l l l_leq_n Pl). Defined. End bounded_search. Section bounded_search_alt_type. Context (X : Type) (e : nat <~> X) (P : X -> Type) (P_dec : forall x, Decidable (P x)) (P_inhab : hexists P). (** Bounded search works for types equivalent to the naturals even without full univalence. *) Definition minimal_n_alt_type : {x : X & P x}. Proof. pose (P' n := P (e n)). pose (P'_dec n := P_dec (e n) : Decidable (P' n)). assert (P'_inhab : hexists P'). { strip_truncations. apply tr. destruct P_inhab as [x p]. exists (e ^-1 x). unfold P'. rewrite (eisretr e). exact p. } destruct (minimal_n P' P'_dec P'_inhab) as [n p']. exact ((e n); p'). Defined. End bounded_search_alt_type. Coq-HoTT-9.0/theories/Categories.v000066400000000000000000000116061474641544500170400ustar00rootroot00000000000000(** * Category Theory *) (** To get all of the category theory library in scope with the proper qualified names, you should [Require Import Categories.] or [Require Import HoTT.Categories.] *) (** First we give modules to all of the kinds of category theory constructions (corresponding to directories), so that we can refer to them as [Category.foo] or [Functor.foo] after [Require Import Categories.] *) (** ** Categories *) Require HoTT.Categories.Category. (** ** Functors *) Require HoTT.Categories.Functor. (** ** Natural Transformations *) Require HoTT.Categories.NaturalTransformation. (** ** Functor Categories *) Require HoTT.Categories.FunctorCategory. (** ** Groupoids *) Require HoTT.Categories.GroupoidCategory. (** ** Precategory of Groupoids *) Require HoTT.Categories.CategoryOfGroupoids. (** ** Discrete Categories *) Require HoTT.Categories.DiscreteCategory. (** ** Indiscrete Categories *) Require HoTT.Categories.IndiscreteCategory. (** ** Finite Discrete Categories (natural numbers as categories) *) Require HoTT.Categories.NatCategory. (** ** Chain Categories [[n]] *) Require HoTT.Categories.ChainCategory. (** ** Initial and Terminal Categories *) Require HoTT.Categories.InitialTerminalCategory. (** ** The Category of Sets *) Require HoTT.Categories.SetCategory. (** ** The Category of Simplicial Sets *) Require HoTT.Categories.SimplicialSets. (** ** The Category of Semi-Simplicial Sets *) Require HoTT.Categories.SemiSimplicialSets. (** ** The Hom Functor *) Require HoTT.Categories.HomFunctor. (** ** Profunctors *) Require HoTT.Categories.Profunctor. (** ** The Category of Categories *) Require HoTT.Categories.Cat. (** ** Laws about Functor Categories *) Require HoTT.Categories.ExponentialLaws. (** ** Laws about Product Categories *) Require HoTT.Categories.ProductLaws. (** ** Comma Categories *) Require HoTT.Categories.Comma. (** ** Universal Properties and Universal Morphisms *) Require HoTT.Categories.UniversalProperties. (** ** Kan Extensions *) Require HoTT.Categories.KanExtensions. (** ** Adjunctions *) Require HoTT.Categories.Adjoint. (** ** Limits *) Require HoTT.Categories.Limits. (** ** Pseudofunctors *) Require HoTT.Categories.Pseudofunctor. (** ** Pseudonatural Transformations *) Require HoTT.Categories.PseudonaturalTransformation. (** ** Lax Comma Categories *) Require HoTT.Categories.LaxComma. (** ** Duality as a Functor *) Require HoTT.Categories.DualFunctor. (** ** The Grothendieck Construction *) Require HoTT.Categories.Grothendieck. (** ** The Category of Sections of a Functor *) Require HoTT.Categories.CategoryOfSections. (** ** The Dependent Product *) Require HoTT.Categories.DependentProduct. (** ** The Yoneda Lemma *) Require HoTT.Categories.Yoneda. (** ** The Structure Identity Principle *) Require HoTT.Categories.Structure. (** ** Fundamental Pregroupoids *) Require HoTT.Categories.FundamentalPreGroupoidCategory. (** ** Homotopy PreCategory *) Require HoTT.Categories.HomotopyPreCategory. (* We bind the record structures for [PreCategory], [IsCategory], [IsStrictCategory], [Functor], and eventually [NaturalTransformation] at top level. *) Local Set Warnings Append "-notation-overridden". Include HoTT.Categories.Category.Core. Include HoTT.Categories.Category.Strict. Include HoTT.Categories.Category.Univalent. Include HoTT.Categories.Functor.Core. Include HoTT.Categories.NaturalTransformation.Core. Include HoTT.Categories.FunctorCategory.Core. Include HoTT.Categories.GroupoidCategory.Core. Include HoTT.Categories.CategoryOfGroupoids. Include HoTT.Categories.DiscreteCategory.Core. Include HoTT.Categories.IndiscreteCategory.Core. Include HoTT.Categories.NatCategory.Core. Include HoTT.Categories.ChainCategory.Core. Include HoTT.Categories.InitialTerminalCategory.Core. Include HoTT.Categories.SetCategory.Core. Include HoTT.Categories.SimplicialSets.Core. Include HoTT.Categories.SemiSimplicialSets.Core. Include HoTT.Categories.HomFunctor. Include HoTT.Categories.Profunctor.Core. Include HoTT.Categories.Cat.Core. Include HoTT.Categories.Comma.Core. Include HoTT.Categories.UniversalProperties. Include HoTT.Categories.KanExtensions.Core. Include HoTT.Categories.Adjoint.Core. Include HoTT.Categories.Limits.Core. Include HoTT.Categories.Pseudofunctor.Core. Include HoTT.Categories.PseudonaturalTransformation.Core. Include HoTT.Categories.LaxComma.Core. Include HoTT.Categories.DualFunctor. Include HoTT.Categories.CategoryOfSections.Core. Include HoTT.Categories.DependentProduct. Include HoTT.Categories.Yoneda. Include HoTT.Categories.Structure.Core. Include HoTT.Categories.FundamentalPreGroupoidCategory. Include HoTT.Categories.HomotopyPreCategory. Require Export HoTT.Categories.Notations. (** Some checks that should pass, if all of the importing went correctly. *) (*Check PreCategory. Check IsStrictCategory _. Check Category.compose. Check Category.sum. Check Category.Sum.sum_compose. Check Functor.sum. Check Functor.Prod.Core.unique. Check (_ o _)%morphism. Check (_ o _)%functor.*) Coq-HoTT-9.0/theories/Categories/000077500000000000000000000000001474641544500166455ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Adjoint.v000066400000000000000000000020341474641544500204230ustar00rootroot00000000000000(** * Adjunctions *) (** ** Definitions *) Require Adjoint.Core. (** *** unit+UMP *) (** *** counit+UMP *) (** *** unit+counit+zig+zag *) Require Adjoint.UnitCounit. (** *** universal morphisms *) Require Adjoint.UniversalMorphisms. (** *** hom-set isomorphism *) Require Adjoint.Hom. (** ** Coercions between various definitions *) Require Adjoint.UnitCounitCoercions. Require Adjoint.HomCoercions. (** ** Opposite adjunctions *) Require Adjoint.Dual. (** ** Path spaces of adjunctions *) Require Adjoint.Paths. (** ** Composition *) Require Adjoint.Composition. (** ** Pointwise adjunctions *) Require Adjoint.Pointwise. (** ** Functoriality of any adjoint construction *) Require Adjoint.Functorial. Include Adjoint.Core. Include Adjoint.UnitCounit. Include Adjoint.UniversalMorphisms.Core. Include Adjoint.Hom. Include Adjoint.UnitCounitCoercions. Include Adjoint.HomCoercions. Include Adjoint.Dual. Include Adjoint.Paths. Include Adjoint.Composition. Include Adjoint.Pointwise. Include Adjoint.Functorial.Core. Require Export Adjoint.Notations. Coq-HoTT-9.0/theories/Categories/Adjoint/000077500000000000000000000000001474641544500202355ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Adjoint/Composition.v000066400000000000000000000007401474641544500227300ustar00rootroot00000000000000(** * Adjunction composition *) (** ** Definition *) Require Adjoint.Composition.Core. (** ** Associativity *) Require Adjoint.Composition.AssociativityLaw. (** * Left and right identity laws *) Require Adjoint.Composition.IdentityLaws. Include Adjoint.Composition.Core. Include Adjoint.Composition.AssociativityLaw. Include Adjoint.Composition.IdentityLaws. Module Export AdjointCompositionNotations. Include AdjointCompositionCoreNotations. End AdjointCompositionNotations. Coq-HoTT-9.0/theories/Categories/Adjoint/Composition/000077500000000000000000000000001474641544500225405ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Adjoint/Composition/AssociativityLaw.v000066400000000000000000000024711474641544500262320ustar00rootroot00000000000000(** * Associativity of adjunction composition *) Require Import Category.Core Functor.Core. Require Import Adjoint.Composition.Core Adjoint.Core. Require Adjoint.Composition.LawsTactic. Require Import Types.Sigma Types.Prod. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope adjunction_scope. Local Open Scope morphism_scope. Section composition_lemmas. Local Notation AdjunctionWithFunctors C D := { fg : Functor C D * Functor D C | fst fg -| snd fg }. Context `{H0 : Funext}. Variables B C D E : PreCategory. Variable F : Functor B C. Variable F' : Functor C B. Variable G : Functor C D. Variable G' : Functor D C. Variable H : Functor D E. Variable H' : Functor E D. Variable AF : F -| F'. Variable AG : G -| G'. Variable AH : H -| H'. Local Open Scope adjunction_scope. Lemma associativity : ((_, _); (AH o AG) o AF) = ((_, _); AH o (AG o AF)) :> AdjunctionWithFunctors B E. Proof. apply path_sigma_uncurried; simpl. (exists (path_prod' (Functor.Composition.Laws.associativity _ _ _) (symmetry _ _ (Functor.Composition.Laws.associativity _ _ _)))); Adjoint.Composition.LawsTactic.law_t. Qed. End composition_lemmas. #[export] Hint Resolve associativity : category. Coq-HoTT-9.0/theories/Categories/Adjoint/Composition/Core.v000066400000000000000000000062521474641544500236240ustar00rootroot00000000000000(** * Composition of adjunctions [F' ⊣ G' → F ⊣ G → (F' ∘ F) ⊣ (G ∘ G')] *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Core NaturalTransformation.Composition.Core. Require Import Functor.Identity. Require NaturalTransformation.Composition.Laws. Require Import Adjoint.UnitCounit Adjoint.Core. Require Import HoTT.Tactics. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. (** ** via the unit+counit+zig+zag definition *) Section compose. Variables C D E : PreCategory. Variable F : Functor C D. Variable F' : Functor D E. Variable G : Functor D C. Variable G' : Functor E D. Variable A' : F' -| G'. Variable A : F -| G. Definition compose_unit : NaturalTransformation 1 ((G o G') o (F' o F)). Proof. pose (unit A) as eta. pose (unit A') as eta'. refine ((fun (T : NaturalTransformation _ _) (U : NaturalTransformation _ _) => T o (G oL eta' oR F) o U o eta) _ _); NaturalTransformation.Composition.Laws.nt_solve_associator. Defined. Definition compose_counit : NaturalTransformation ((F' o F) o (G o G')) 1. Proof. pose (counit A) as eps. pose (counit A') as eps'. refine ((fun (T : NaturalTransformation _ _) (U : NaturalTransformation _ _) => eps' o U o (F' oL eps oR G') o T) _ _); NaturalTransformation.Composition.Laws.nt_solve_associator. Defined. Definition compose : F' o F -| G o G'. Proof. exists compose_unit compose_counit; simpl; abstract ( repeat match goal with | _ => intro | _ => reflexivity | _ => progress rewrite ?identity_of, ?left_identity, ?right_identity | _ => rewrite <- ?composition_of, unit_counit_equation_1 | _ => rewrite <- ?composition_of, unit_counit_equation_2 | [ A : _ -| _ |- _ = 1%morphism ] => (etransitivity; [ | apply (unit_counit_equation_1 A) ]; try_associativity_quick f_ap) | [ A : _ -| _ |- _ = 1%morphism ] => (etransitivity; [ | apply (unit_counit_equation_2 A) ]; try_associativity_quick f_ap) | _ => repeat (try_associativity_quick rewrite <- !composition_of); progress repeat apply ap; rewrite ?composition_of | [ |- context[components_of ?T] ] => (try_associativity_quick simpl rewrite <- (commutes T)); try_associativity_quick (apply concat_right_identity || apply concat_left_identity) | [ |- context[components_of ?T] ] => (try_associativity_quick simpl rewrite (commutes T)); try_associativity_quick (apply concat_right_identity || apply concat_left_identity) end ). Defined. End compose. Module Export AdjointCompositionCoreNotations. Infix "o" := compose : adjunction_scope. End AdjointCompositionCoreNotations. Coq-HoTT-9.0/theories/Categories/Adjoint/Composition/IdentityLaws.v000066400000000000000000000030221474641544500253440ustar00rootroot00000000000000(** * Left and right identity laws of adjunction composition *) Require Import Category.Core Functor.Core. Require Import Adjoint.Composition.Core Adjoint.Core Adjoint.Identity. Require Adjoint.Composition.LawsTactic. Require Import Types.Sigma Types.Prod. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope adjunction_scope. Local Open Scope morphism_scope. Section identity_lemmas. Local Notation AdjunctionWithFunctors C D := { fg : Functor C D * Functor D C | fst fg -| snd fg }. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Variable A : F -| G. Local Open Scope adjunction_scope. Lemma left_identity : ((_, _); 1 o A) = ((_, _); A) :> AdjunctionWithFunctors C D. Proof. apply path_sigma_uncurried; simpl. (exists (path_prod' (Functor.Composition.Laws.left_identity _) (Functor.Composition.Laws.right_identity _))). Adjoint.Composition.LawsTactic.law_t. Qed. Lemma right_identity : ((_, _); A o 1) = ((_, _); A) :> AdjunctionWithFunctors C D. Proof. apply path_sigma_uncurried; simpl. (exists (path_prod' (Functor.Composition.Laws.right_identity _) (Functor.Composition.Laws.left_identity _))). Adjoint.Composition.LawsTactic.law_t. Qed. End identity_lemmas. #[export] Hint Rewrite @left_identity @right_identity : category. #[export] Hint Immediate left_identity right_identity : category. Coq-HoTT-9.0/theories/Categories/Adjoint/Composition/LawsTactic.v000066400000000000000000000047321474641544500247730ustar00rootroot00000000000000(** * Tactic for proving laws about adjoint composition *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Laws. Require Import Adjoint.UnitCounit Adjoint.Paths. Require Import PathGroupoids HoTT.Tactics Types.Prod Types.Forall. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Ltac law_t := rewrite !transport_path_prod'; simpl; path_adjunction; simpl; repeat match goal with | [ |- context[unit (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => @unit _ _ _ _) z) | [ |- context[counit (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => @counit _ _ _ _) z) | [ |- context[components_of (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => @components_of _ _ _ _) z) end; rewrite !transport_forall_constant; repeat match goal with | [ |- context[transport (fun y : Functor ?C ?D => ?f (y _0 ?x)%object)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (y' x)) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (?g (y _0 ?x)%object))] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (g (y' x))) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (?g (?h (?i (y _0 ?x)%object))))] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (g (h (i (y' x))))) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (y _0 ?x)%object ?z)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (y' x) z) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (?g (y _0 ?x)%object) ?z)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (g (y' x)) z) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (?g (?h (?i (y _0 ?x)%object))) ?z)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (g (h (i (y' x)))) z) (@object_of C D)) end; unfold symmetry, symmetric_paths; rewrite ?ap_V; rewrite ?left_identity_fst, ?right_identity_fst, ?associativity_fst; simpl; repeat ( rewrite ?identity_of, ?composition_of, ?Category.Core.left_identity, ?Category.Core.right_identity, ?Category.Core.associativity ); try reflexivity. Coq-HoTT-9.0/theories/Categories/Adjoint/Core.v000066400000000000000000000003571474641544500213210ustar00rootroot00000000000000(** * Adjunctions *) Require Import Adjoint.UnitCounit. Require Import Basics.Notations. Notation Adjunction := AdjunctionUnitCounit. Module Export AdjointCoreNotations. Infix "-|" := Adjunction : type_scope. End AdjointCoreNotations. Coq-HoTT-9.0/theories/Categories/Adjoint/Dual.v000066400000000000000000000020461474641544500213130ustar00rootroot00000000000000(** * Opposite adjunction [F ⊣ G → Gᵒᵖ ⊣ Fᵒᵖ] *) Require Import Category.Core Functor.Core. Require Import Functor.Dual NaturalTransformation.Dual. Require Import Adjoint.UnitCounit Adjoint.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. (** ** Definition of [Aᵒᵖ] *) Definition opposite C D (F : Functor C D) (G : Functor D C) (A : F -| G) : G^op -| F^op := @Build_AdjunctionUnitCounit _ _ (G^op) (F^op) ((counit A)^op) ((unit A)^op) (unit_counit_equation_2 A) (unit_counit_equation_1 A). Local Notation "A ^op" := (opposite A) : adjunction_scope. Local Open Scope adjunction_scope. (** ** [ᵒᵖ] is judgmentally involutive *) Definition opposite_involutive C D (F : Functor C D) (G : Functor D C) (A : F -| G) : (A^op)^op = A := idpath. Module Export AdjointDualNotations. Notation "A ^op" := (opposite A) : adjunction_scope. End AdjointDualNotations. Coq-HoTT-9.0/theories/Categories/Adjoint/Functorial.v000066400000000000000000000003651474641544500225360ustar00rootroot00000000000000(** * Functoriality of the construction of adjunctions *) (** ** Computational components *) Require Adjoint.Functorial.Parts. (** ** Functor laws *) Require Adjoint.Functorial.Laws. (** ** Adjunction functor *) Require Adjoint.Functorial.Core. Coq-HoTT-9.0/theories/Categories/Adjoint/Functorial/000077500000000000000000000000001474641544500223435ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Adjoint/Functorial/Core.v000066400000000000000000000047711474641544500234330ustar00rootroot00000000000000(** * Functoriality of the construction of adjunctions *) Require Import Category.Core Functor.Core. Require Import Category.Dual. Require Import FunctorCategory.Core. Require Import Category.Sigma.OnObjects Category.Prod. Require Import Adjoint.Core. Require Import Adjoint.Functorial.Parts Adjoint.Functorial.Laws. Require Import HoTT.Types.Prod. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. Local Open Scope morphism_scope. Local Open Scope category_scope. Section left. (** ** Non-dependent functor for left adjoints *) (** We'd need Π types (dependent functors) to include functoriality on the categories. *) Section nondep. Context `{Funext}. Variables C D : PreCategory. Definition left_functor_nondep : Functor (sig_obj (D -> C) (fun G => { F : Functor C D & F -| G })) (sig_obj ((C -> D)^op * (D -> C)) (fun FG => fst FG -| snd FG)) := Build_Functor (sig_obj (D -> C) (fun G => { F : Functor C D & F -| G })) (sig_obj ((C -> D)^op * (D -> C)) (fun FG => fst FG -| snd FG)) (fun GFA => ((GFA.2.1, GFA.1); GFA.2.2)) (fun GFA G'F'A' m => (left_morphism_of_nondep GFA.2.2 G'F'A'.2.2 m, m)) (fun s d d' m1 m2 => path_prod' (left_composition_of_nondep _ _ _ _ _) 1) (fun x => path_prod' (left_identity_of_nondep _) 1). End nondep. End left. Section right. (** ** Non-dependent functor for right adjoints *) (** We'd need Π types (dependent functors) to include functoriality on the categories. *) Section nondep. Context `{Funext}. Variables C D : PreCategory. (** TODO: Is there a nice way to write this functor as a composition of the above with some dualization functors? (I suspect there is.) *) Definition right_functor_nondep : Functor (sig_obj (C -> D) (fun F => { G : Functor D C & F -| G })) (sig_obj ((C -> D) * (D -> C)^op) (fun FG => fst FG -| snd FG)) := Build_Functor (sig_obj (C -> D) (fun F => { G : Functor D C & F -| G })) (sig_obj ((C -> D) * (D -> C)^op) (fun FG => fst FG -| snd FG)) (fun GFA => ((GFA.1, GFA.2.1); GFA.2.2)) (fun GFA G'F'A' m => (m, right_morphism_of_nondep G'F'A'.2.2 GFA.2.2 m)) (fun s d d' m1 m2 => path_prod' 1 (right_composition_of_nondep _ _ _ _ _)) (fun x => path_prod' 1 (right_identity_of_nondep _)). End nondep. End right. Coq-HoTT-9.0/theories/Categories/Adjoint/Functorial/Laws.v000066400000000000000000000203311474641544500234370ustar00rootroot00000000000000(** * Functoriality of the construction of adjunctions *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Identity Functor.Composition.Core. Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws. Require Import NaturalTransformation.Identity. Require Import NaturalTransformation.Paths. Require Import Functor.Dual NaturalTransformation.Dual. Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.Dual. Require Import Adjoint.Functorial.Parts. Require Import HoTT.Tactics. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. Local Open Scope morphism_scope. Section laws. (** Some tactics to handle all the proofs. The tactics deal with the "obvious" commutativity requirements by writing back and forth with associativity and respectfulness of composition, trying to find applications of the adjunction laws. *) Local Ltac try_various_ways tac := progress repeat first [ progress tac | rewrite <- ?Functor.Core.composition_of; progress try_associativity_quick tac | rewrite -> ?Functor.Core.composition_of; progress try_associativity_quick tac ]. (** This is suboptimal, because we keep rewriting back and forth with associativity and [composition_of]. But it only takes 0.74 seconds total, so it's probably not worth optimizing. *) Local Ltac handle_laws' := idtac; match goal with | _ => reflexivity | _ => progress rewrite ?identity_of, ?Category.Core.left_identity, ?Category.Core.right_identity | _ => try_various_ways ltac:(f_ap) | [ |- context[components_of ?T ?x] ] => try_various_ways ltac:(simpl rewrite <- (commutes T)) | [ |- context[unit ?A] ] => try_various_ways ltac:(rewrite (unit_counit_equation_1 A)) | [ |- context[unit ?A] ] => try_various_ways ltac:(rewrite (unit_counit_equation_2 A)) end. Local Ltac t := apply path_natural_transformation; intro; cbn; repeat handle_laws'. Section left. Local Arguments unit : simpl never. Local Arguments counit : simpl never. Section identity_of. Context `{Funext}. Variables C D : PreCategory. Variable G : Functor D C. Variable F : Functor C D. Variable A : F -| G. Definition left_identity_of : @left_morphism_of C C 1 D D 1 G F A G F A 1 = ((left_identity_natural_transformation_2 _) o (right_identity_natural_transformation_1 _))%natural_transformation. Proof. t. Qed. Definition left_identity_of_nondep : @left_morphism_of_nondep C D G F A G F A 1 = 1%natural_transformation. Proof. t. Qed. End identity_of. Section composition_of_dep. Context `{Funext}. Variables C C' C'' : PreCategory. Variable CF : Functor C C'. Variable CF' : Functor C' C''. Variables D D' D'' : PreCategory. Variable DF : Functor D D'. Variable DF' : Functor D' D''. Variable G : Functor D C. Variable F : Functor C D. Variable A : F -| G. Variable G' : Functor D' C'. Variable F' : Functor C' D'. Variable A' : F' -| G'. Variable G'' : Functor D'' C''. Variable F'' : Functor C'' D''. Variable A'' : F'' -| G''. Variable T : NaturalTransformation (CF o G) (G' o DF). Variable T' : NaturalTransformation (CF' o G') (G'' o DF'). Local Open Scope natural_transformation_scope. Definition left_composition_of : (@left_morphism_of _ _ _ _ _ _ _ _ A _ _ A'' ((associator_1 _ _ _) o (T' oR DF) o (associator_2 _ _ _) o (CF' oL T) o (associator_1 _ _ _))) = (associator_2 _ _ _) o (DF' oL left_morphism_of A A' T) o (associator_1 _ _ _) o (left_morphism_of A' A'' T' oR CF) o (associator_2 _ _ _). Proof. t. Qed. End composition_of_dep. Section composition_of. Context `{Funext}. Variables C D : PreCategory. Variable G : Functor D C. Variable F : Functor C D. Variable A : F -| G. Variable G' : Functor D C. Variable F' : Functor C D. Variable A' : F' -| G'. Variable G'' : Functor D C. Variable F'' : Functor C D. Variable A'' : F'' -| G''. Variable T : NaturalTransformation G G'. Variable T' : NaturalTransformation G' G''. Local Open Scope natural_transformation_scope. Definition left_composition_of_nondep : (@left_morphism_of_nondep _ _ _ _ A _ _ A'' (T' o T)) = ((left_morphism_of_nondep A A' T) o (left_morphism_of_nondep A' A'' T')). Proof. t. Qed. End composition_of. End left. Section right. Section identity_of. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Variable A : F -| G. Definition right_identity_of : @right_morphism_of C C 1 D D 1 F G A F G A 1 = ((right_identity_natural_transformation_2 _) o (left_identity_natural_transformation_1 _))%natural_transformation := ap (@NaturalTransformation.Dual.opposite _ _ _ _) (@left_identity_of _ _ _ F^op G^op A^op). Definition right_identity_of_nondep : @right_morphism_of_nondep C D F G A F G A 1 = 1%natural_transformation := ap (@NaturalTransformation.Dual.opposite _ _ _ _) (@left_identity_of_nondep _ _ _ F^op G^op A^op). End identity_of. Section composition_of_dep. Context `{Funext}. Variables C C' C'' : PreCategory. Variable CF : Functor C C'. Variable CF' : Functor C' C''. Variables D D' D'' : PreCategory. Variable DF : Functor D D'. Variable DF' : Functor D' D''. Variable F : Functor C D. Variable G : Functor D C. Variable A : F -| G. Variable F' : Functor C' D'. Variable G' : Functor D' C'. Variable A' : F' -| G'. Variable F'' : Functor C'' D''. Variable G'' : Functor D'' C''. Variable A'' : F'' -| G''. Variable T : NaturalTransformation (F' o CF) (DF o F). Variable T' : NaturalTransformation (F'' o CF') (DF' o F'). Local Open Scope natural_transformation_scope. (** This is slow, at about 3.8 s. It also requires the opposite association to unify. *) Definition right_composition_of : right_morphism_of A A'' ((associator_2 DF' DF F) o ((DF' oL T) o ((associator_1 DF' F' CF) o ((T' oR CF) o (associator_2 F'' CF' CF))))) = (associator_1 G'' DF' DF) o ((right_morphism_of A' A'' T' oR DF) o ((associator_2 CF' G' DF) o ((CF' oL right_morphism_of A A' T) o (associator_1 CF' CF G)))) := ap (@NaturalTransformation.Dual.opposite _ _ _ _) (@left_composition_of _ _ _ _ (DF^op) (DF'^op) _ _ _ (CF^op) (CF'^op) _ _ A^op _ _ A'^op _ _ A''^op T^op T'^op). End composition_of_dep. Section composition_of. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Variable A : F -| G. Variable F' : Functor C D. Variable G' : Functor D C. Variable A' : F' -| G'. Variable F'' : Functor C D. Variable G'' : Functor D C. Variable A'' : F'' -| G''. Variable T : NaturalTransformation F F'. Variable T' : NaturalTransformation F' F''. Local Open Scope natural_transformation_scope. Definition right_composition_of_nondep : (@right_morphism_of_nondep _ _ _ _ A'' _ _ A (T' o T)) = ((right_morphism_of_nondep A' A T) o (right_morphism_of_nondep A'' A' T')) := ap (@NaturalTransformation.Dual.opposite _ _ _ _) (@left_composition_of_nondep _ _ _ _ _ A''^op _ _ A'^op _ _ A^op T'^op T^op). End composition_of. End right. End laws. Coq-HoTT-9.0/theories/Categories/Adjoint/Functorial/Parts.v000066400000000000000000000056601474641544500236320ustar00rootroot00000000000000(** * Functoriality of the construction of adjunctions from universal morphisms *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Identity Functor.Composition.Core. Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws. Require Import Functor.Dual NaturalTransformation.Dual. Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.Dual. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. Local Open Scope morphism_scope. Section left. (** ** action on morphisms of the construction of a left adjoint to [G] *) (** *** functoriality on [C], [D], and [G] *) Section also_categories. Variables C C' : PreCategory. Variable CF : Functor C C'. Variables D D' : PreCategory. Variable DF : Functor D D'. Variable G : Functor D C. Variable F : Functor C D. Variable A : F -| G. Variable G' : Functor D' C'. Variable F' : Functor C' D'. Variable A' : F' -| G'. Variable T : NaturalTransformation (CF o G) (G' o DF). Definition left_morphism_of : NaturalTransformation (F' o CF) (DF o F). Proof. refine ((_) o (counit A' oR (DF o F)) o _ o (F' oL ((T oR F) o _ o (CF oL unit A) o _)))%natural_transformation; nt_solve_associator. Defined. End also_categories. (** *** functoriality in [G] *) Section only_functor. Variables C D : PreCategory. Variable G : Functor D C. Variable F : Functor C D. Variable A : F -| G. Variable G' : Functor D C. Variable F' : Functor C D. Variable A' : F' -| G'. Variable T : NaturalTransformation G G'. Definition left_morphism_of_nondep : NaturalTransformation F' F. Proof. refine (_ o (@left_morphism_of C C 1 D D 1 G F A G' F' A' (_ o T o _)) o _)%natural_transformation; nt_solve_associator. Defined. End only_functor. End left. Section right. (** ** action on morphisms of the construction of a right adjoint to [F] *) Definition right_morphism_of C C' CF D D' DF (F : Functor C D) (G : Functor D C) (A : F -| G) (F' : Functor C' D') (G' : Functor D' C') (A' : F' -| G') (T : NaturalTransformation (F' o CF) (DF o F)) : NaturalTransformation (CF o G) (G' o DF) := (@left_morphism_of _ _ DF^op _ _ CF^op F^op G^op A^op F'^op G'^op A'^op T^op)^op. Definition right_morphism_of_nondep C D (F : Functor C D) (G : Functor D C) (A : F -| G) (F' : Functor C D) (G' : Functor D C) (A' : F' -| G') (T : NaturalTransformation F' F) : NaturalTransformation G G' := (@left_morphism_of_nondep _ _ F^op G^op A^op F'^op G'^op A'^op T^op)^op. End right. Coq-HoTT-9.0/theories/Categories/Adjoint/Hom.v000066400000000000000000000057561474641544500211640ustar00rootroot00000000000000(** * Hom-Set Adjunctions *) Require Import Category.Core Functor.Core. Require Import Adjoint.UnitCounit. Require Import Functor.Dual. Require Import Functor.Prod.Core. Require Import HomFunctor. Require Import Functor.Composition.Core. Require Import FunctorCategory.Morphisms. Require Import Functor.Identity. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. Local Open Scope functor_scope. Local Open Scope natural_transformation_scope. Section Adjunction. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. (** Quoting the MIT 18.705 Lecture Notes: Let [C] and [D] be categories, [F : C → D] and [G : D → C] functors. We call [(F, G)] an adjoint pair, [F] the left adjoint of [G], and [G] the right adjoint of [F] if, for each object [A : C] and object [A' : D], there is a natural bijection [Hom_D (F A) A' ≅ Hom_C A (G A')] Here natural means that maps [B → A] and [A' → B'] induce a commutative diagram: << Hom_D (F A) A' ≅ Hom_C A (G A') | | | | | | | | V V Hom_D (F B) B' ≅ Hom_C B (G B') >> *) (** We want to [simpl] out the notation machinery *) Local Opaque NaturalIsomorphism. Let Adjunction_Type := Eval simpl in hom_functor D o (F^op, 1) <~=~> hom_functor C o (1, G). (*Let Adjunction_Type := Eval simpl in HomFunctor D ⟨ F ⟨ 1 ⟩ , 1 ⟩ ≅ HomFunctor C ⟨ 1 , G ⟨ 1 ⟩ ⟩.*) (*Set Printing All. Print Adjunction_Type.*) (** Just putting in [Adjunction_Type] breaks [AMateOf] *) Record AdjunctionHom := { mate_of : @NaturalIsomorphism H (Category.Prod.prod (Category.Dual.opposite C) D) (@Core.set_cat H) (@compose (Category.Prod.prod (Category.Dual.opposite C) D) (Category.Prod.prod (Category.Dual.opposite D) D) (@Core.set_cat H) (@hom_functor H D) (@pair (Category.Dual.opposite C) (Category.Dual.opposite D) D D (@opposite C D F) (identity D))) (@compose (Category.Prod.prod (Category.Dual.opposite C) D) (Category.Prod.prod (Category.Dual.opposite C) C) (@Core.set_cat H) (@hom_functor H C) (@pair (Category.Dual.opposite C) (Category.Dual.opposite C) D C (identity (Category.Dual.opposite C)) G)) }. End Adjunction. Coercion mate_of : AdjunctionHom >-> NaturalIsomorphism. Bind Scope adjunction_scope with AdjunctionHom. Arguments mate_of {_} [C%_category D%_category F%_functor G%_functor] _%_adjunction. Coq-HoTT-9.0/theories/Categories/Adjoint/HomCoercions.v000066400000000000000000000173351474641544500230250ustar00rootroot00000000000000(** * Coercions between hom-set adjunctions and unit+counit adjunctions *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Adjoint.UnitCounit Adjoint.UnitCounitCoercions Adjoint.Hom. Require Import Category.Morphisms. Require Import Functor.Composition.Core. Require Import FunctorCategory.Morphisms. Require Import Functor.Identity. Require Import SetCategory.Morphisms. Require Import Basics.Trunc Types.Sigma HoTT.Tactics Equivalences. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope morphism_scope. Local Open Scope category_scope. Local Open Scope functor_scope. Local Open Scope natural_transformation_scope. (** ** unit+UMP from hom-set adjunction *) Section AdjunctionEquivalences. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Local Open Scope morphism_scope. (** We need to jump through some hoops with [simpl] for speed *) Section adjunction_naturality. Variable A : AdjunctionHom F G. Section nat1. Context c d d' (f : morphism D (F c) d) (g : morphism D d d'). Let adjunction_naturalityT := Eval simpl in G _1 g o A (c, d) f = A (c, d') (g o f). Lemma adjunction_naturality : adjunction_naturalityT. Proof. pose proof (ap10 (commutes A (c, d) (c, d') (1%morphism, g))^ f) as H'; simpl in *. rewrite ?identity_of, ?left_identity, ?right_identity in H'. exact H'. Qed. End nat1. Section nat2. Context c c' d (f : morphism D (F c') d) (g : morphism C c c'). Let adjunction_naturalityT' := Eval simpl in A (c', d) f o g = A (c, d) (f o F _1 g). Lemma adjunction_naturality' : adjunction_naturalityT'. Proof. pose proof (ap10 (commutes A (c', d) (c, d) (g, 1%morphism))^ f) as H'; simpl in *. rewrite ?identity_of, ?left_identity, ?right_identity in H'. exact H'. Qed. End nat2. End adjunction_naturality. (** Quoting from Awodey's "Category Theory": Proposition 9.4. Given categories and functors, [F : C ↔ D : G] the following conditions are equivalent: 1. [F] is left adjoint to [G]; that is, there is a natural transformation [η : 1_C → G ∘ F] that has the UMP of the unit: For any [c : C], [d : D] and [f : c -> G d] there exists a unique [g : F c → d] such that [f = G g ∘ η c]. 2. For any [c : C] and [d : D] there is an isomorphism, [ϕ : Hom_D (F c, d) ≅ Hom_C (c, G d)] that is natural in both [c] and [d]. Moreover, the two conditions are related by the formulas [ϕ g = G g ∘ η c] [η c = ϕ(1_{F c})] *) Lemma adjunction_unit__of__adjunction_hom_helper (A : AdjunctionHom F G) (c : C) (d : D) (f : morphism C c (G d)) : IsHProp {g : morphism D (F c) d & G _1 g o A (c, F c) 1 = f}. Proof. apply hprop_allpath. intros [g0 H0] [g1 H1]; apply path_sigma_hprop; simpl. destruct H1. rewrite !adjunction_naturality in H0. rewrite !right_identity in H0. change (idmap g0 = idmap g1). rewrite <- (ap10 (@left_inverse _ _ _ (A (c, d)) _)). simpl rewrite H0. let k := constr:(ap10 (@left_inverse _ _ _ (A (c, d)) _)) in simpl rewrite k. (* https://coq.inria.fr/bugs/show_bug.cgi?id=3773 and https://coq.inria.fr/bugs/show_bug.cgi?id=3772 (probably) *) reflexivity. Qed. Lemma adjunction_unit__of__adjunction_hom__mate_of__commutes (A : AdjunctionHom F G) (s d : C) (m : morphism C s d) : A (d, F d) 1 o m = G _1 (F _1 m) o A (s, F s) 1. Proof. simpl; rewrite adjunction_naturality', adjunction_naturality. rewrite ?left_identity, ?right_identity. reflexivity. Qed. Definition adjunction_unit__of__adjunction_hom (A : AdjunctionHom F G) : AdjunctionUnit F G. Proof. exists (Build_NaturalTransformation 1 (G o F) (fun c => A (c, F c) 1) (adjunction_unit__of__adjunction_hom__mate_of__commutes A)). simpl in *. intros c d f. apply contr_inhabited_hprop. - apply adjunction_unit__of__adjunction_hom_helper. - exact ((A (c, d))^-1%morphism f; ((adjunction_naturality A _ _ _ _ _) @ (ap (A (c, d)) (right_identity _ _ _ _)) @ (ap10 (@right_inverse _ _ _ (A (c, d)) _) f))%path). Defined. End AdjunctionEquivalences. Section isequiv. (** We want to be able to use this without needing [Funext]. So, first, we prove that the types of hom-sets are equivalent. *) Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Local Open Scope morphism_scope. Variable T : AdjunctionUnit F G. Lemma equiv_hom_set_adjunction (c : C) (d : D) : morphism C c (G d) <~> morphism D (F c) d. Proof. refine (equiv_adjointify (fun f => (@center _ (T.2 _ _ f)).1) (fun g => G _1 g o T.1 c) _ _); intro. - match goal with | [ |- @pr1 ?A ?P ?x = ?y ] => change (x.1 = (exist P y idpath).1) end. apply (ap pr1). apply contr. - match goal with | [ |- context[?x.1] ] => apply x.2 end. Defined. End isequiv. (** ** hom-set adjunction from unit+ump adjunction *) Section AdjunctionEquivalences'. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Local Open Scope morphism_scope. Lemma adjunction_hom__of__adjunction_unit__commutes (T : AdjunctionUnit F G) sc sd dc dd (mc : morphism C dc sc) (md : morphism D sd dd) : (fun x : morphism D (F sc) sd => G _1 (md o x o F _1 mc) o T .1 dc) = (fun x : morphism D (F sc) sd => G _1 md o (G _1 x o T .1 sc) o mc). Proof. apply path_forall; intro. rewrite !composition_of, !associativity. simpl rewrite (commutes T.1). reflexivity. Qed. Definition adjunction_hom__of__adjunction_unit (T : AdjunctionUnit F G) : AdjunctionHom F G. Proof. constructor. (eexists (Build_NaturalTransformation _ _ _ _)). apply (@isisomorphism_natural_transformation _); simpl. exact (fun cd => @isiso_isequiv _ _ _ _ (equiv_isequiv (equiv_hom_set_adjunction T (fst cd) (snd cd))^-1)). Unshelve. simpl. intros. exact (adjunction_hom__of__adjunction_unit__commutes T _ _ _ _ _ _). Defined. End AdjunctionEquivalences'. Definition AdjunctionUnitWithFunext `{Funext} C D F G := @AdjunctionUnit C D F G. Definition AdjunctionCounitWithFunext `{Funext} C D F G := @AdjunctionCounit C D F G. Definition AdjunctionUnitCounitWithFunext `{Funext} C D F G := @AdjunctionUnitCounit C D F G. Identity Coercion AdjunctionUnit_Funext : AdjunctionUnitWithFunext >-> AdjunctionUnit. Identity Coercion AdjunctionCounit_Funext : AdjunctionCounitWithFunext >-> AdjunctionCounit. Identity Coercion AdjunctionUnitCounit_Funext : AdjunctionUnitCounitWithFunext >-> AdjunctionUnitCounit. Definition adjunction_hom__of__adjunction_unit_Funext `{Funext} C D F G (A : AdjunctionUnitWithFunext _ _) : AdjunctionHom _ _ := @adjunction_hom__of__adjunction_unit _ C D F G A. Definition AdjunctionHomOfAdjunctionCounit_Funext `{Funext} C D F G (A : AdjunctionCounitWithFunext _ _) : AdjunctionHom _ _ := @adjunction_hom__of__adjunction_unit _ C D F G (adjunction_unit_counit__of__adjunction_counit A). Definition adjunction_hom__of__adjunction_unitCounit_Funext `{Funext} C D F G (A : AdjunctionUnitCounitWithFunext _ _) : AdjunctionHom _ _ := @adjunction_hom__of__adjunction_unit _ C D F G A. Coq-HoTT-9.0/theories/Categories/Adjoint/Identity.v000066400000000000000000000013161474641544500222160ustar00rootroot00000000000000(** * Identity adjunction [1 ⊣ 1] *) Require Import Category.Core. Require Import Functor.Identity NaturalTransformation.Identity. Require Import Adjoint.UnitCounit Adjoint.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section identity. (** There is an identity adjunction. It does the obvious thing. *) Definition identity C : @Adjunction C C 1 1 := @Build_AdjunctionUnitCounit C C 1 1 1 1 (fun _ => identity_identity _ _) (fun _ => identity_identity _ _). End identity. Module Export AdjointIdentityNotations. Notation "1" := (identity _) : adjunction_scope. End AdjointIdentityNotations. Coq-HoTT-9.0/theories/Categories/Adjoint/Notations.v000066400000000000000000000004461474641544500224060ustar00rootroot00000000000000Require Adjoint.Composition. Require Adjoint.Core. Require Adjoint.Dual. Require Adjoint.Identity. Include Adjoint.Composition.AdjointCompositionNotations. Include Adjoint.Core.AdjointCoreNotations. Include Adjoint.Dual.AdjointDualNotations. Include Adjoint.Identity.AdjointIdentityNotations. Coq-HoTT-9.0/theories/Categories/Adjoint/Paths.v000066400000000000000000000046721474641544500215140ustar00rootroot00000000000000(** * Classify the path space of adjunctions *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Core Functor.Identity. Require Import Adjoint.UnitCounit Adjoint.Core NaturalTransformation.Paths. Require Import Types Trunc. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope natural_transformation_scope. Section path_adjunction. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Notation adjunction_sig := { eta : NaturalTransformation 1 (G o F) | { eps : NaturalTransformation (F o G) 1 | { equ1 : forall Y : C, (eps (F Y) o F _1 (eta Y))%morphism = 1%morphism | forall X : D, (G _1 (eps X) o eta (G X))%morphism = 1%morphism }}}. (** ** Equivalence between record and nested sigma for unit+counit adjunctions *) Lemma equiv_sig_adjunction : adjunction_sig <~> (F -| G). Proof. issig. Defined. (** ** Adjunctions are an hSet *) Global Instance trunc_adjunction : IsHSet (F -| G). Proof. eapply istrunc_equiv_istrunc; [ exact equiv_sig_adjunction | ]. typeclasses eauto. Qed. (** ** Equality of adjunctions follows from equality of unit+counit *) Lemma path_adjunction' (A A' : F -| G) : unit A = unit A' -> counit A = counit A' -> A = A'. Proof. intros. destruct A, A'; simpl in *. path_induction. f_ap; exact (center _). Qed. (** ** Equality of adjunctions follows from equality of action of unit+counit on objects *) Lemma path_adjunction (A A' : F -| G) : components_of (unit A) == components_of (unit A') -> components_of (counit A) == components_of (counit A') -> A = A'. Proof. intros. apply path_adjunction'; apply path_natural_transformation; assumption. Qed. (** In fact, it suffices to show that either the units are equal, or the counits are equal, by the UMP of the (co)unit. And if we are working in a [Category], rather than a [PreCategory], then [Adjunction] is, in fact, an hProp, because the (co)unit is unique up to unique isomorphism. TODO: Formalize this. *) End path_adjunction. Ltac path_adjunction := repeat match goal with | _ => intro | _ => reflexivity | _ => apply path_adjunction; simpl end. Coq-HoTT-9.0/theories/Categories/Adjoint/Pointwise.v000066400000000000000000000176631474641544500224220ustar00rootroot00000000000000(** * Pointwise Adjunctions *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Identity. Require Import Functor.Composition.Core NaturalTransformation.Composition.Core. Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.UnitCounitCoercions. Require Import Functor.Pointwise.Core. Require NaturalTransformation.Pointwise. Require Functor.Pointwise.Properties. Require Import Category.Morphisms FunctorCategory.Morphisms. Require Import FunctorCategory.Core. Import NaturalTransformation.Identity.NaturalTransformationIdentityNotations. Require Import NaturalTransformation.Paths Functor.Paths. Require Import Basics.PathGroupoids HoTT.Tactics Types.Arrow. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope functor_scope. Local Open Scope natural_transformation_scope. Section AdjointPointwise. Context `{Funext}. Variables C D : PreCategory. (** ** [F ⊣ G] → [E^F ⊣ E^G] *) Section l. Variable E : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Variable A : F -| G. Definition unit_l : NaturalTransformation (identity (E -> C)) ((pointwise (identity E) G) o (pointwise (identity E) F)). Proof. pose proof (A : AdjunctionUnit _ _) as A''. refine (_ o (((idtoiso (C := (_ -> _)) (Functor.Pointwise.Properties.identity_of _ _))^-1)%morphism : morphism _ _ _)). refine (_ o NaturalTransformation.Pointwise.pointwise_r (Functor.Identity.identity E) (proj1 A'')). refine (((idtoiso (C := (_ -> _)) (Functor.Pointwise.Properties.composition_of (Functor.Identity.identity E) F (Functor.Identity.identity E) G)) : morphism _ _ _) o _). refine (NaturalTransformation.Pointwise.pointwise_l _ _). exact (NaturalTransformation.Composition.Laws.left_identity_natural_transformation_2 _). Defined. Definition counit_l : NaturalTransformation (pointwise (identity E) F o pointwise (identity E) G) (identity (E -> D)). Proof. pose proof (A : AdjunctionCounit _ _) as A''. refine ((((idtoiso (C := (_ -> _)) (Functor.Pointwise.Properties.identity_of _ _)))%morphism : morphism _ _ _) o _). refine (NaturalTransformation.Pointwise.pointwise_r (Functor.Identity.identity E) (proj1 A'') o _). refine (_ o (((idtoiso (C := (_ -> _)) (Functor.Pointwise.Properties.composition_of (Functor.Identity.identity E) G (Functor.Identity.identity E) F))^-1)%morphism : morphism _ _ _)). refine (NaturalTransformation.Pointwise.pointwise_l _ _). exact (NaturalTransformation.Composition.Laws.left_identity_natural_transformation_1 _). Defined. Create HintDb adjoint_pointwise discriminated. Hint Rewrite identity_of left_identity right_identity eta_idtoiso composition_of idtoiso_functor @ap_V @ap10_V @ap10_path_forall path_functor_uncurried_fst : adjoint_pointwise. Definition pointwise_l : pointwise (identity E) F -| pointwise (identity E) G. Proof. exists unit_l counit_l; abstract ( path_natural_transformation; intros; destruct A; simpl in *; repeat match goal with | _ => progress simpl | _ => progress autorewrite with adjoint_pointwise | [ |- context[ap object_of (path_functor_uncurried ?F ?G (?HO; ?HM))] ] => rewrite (@path_functor_uncurried_fst _ _ _ F G HO HM) | _ => progress unfold Functor.Pointwise.Properties.identity_of | _ => progress unfold Functor.Pointwise.Properties.composition_of | _ => progress unfold Functor.Pointwise.Properties.identity_of_helper | _ => progress unfold Functor.Pointwise.Properties.composition_of_helper | _ => progress unfold Functor.Pointwise.Properties.identity_of_helper_helper | _ => progress unfold Functor.Pointwise.Properties.composition_of_helper_helper | [ H : _ |- _ ] => apply H end ). (* 23.345 s *) Defined. End l. (** ** [F ⊣ G] → [Gᴱ ⊣ Fᴱ] *) Section r. Variable F : Functor C D. Variable G : Functor D C. Variable A : F -| G. Variable E : PreCategory. Definition unit_r : NaturalTransformation (identity (C -> E)) ((pointwise F (identity E)) o (pointwise G (identity E))). Proof. pose proof (A : AdjunctionUnit _ _) as A''. refine (_ o (((idtoiso (C := (_ -> _)) (Functor.Pointwise.Properties.identity_of _ _))^-1)%morphism : morphism _ _ _)). refine (_ o NaturalTransformation.Pointwise.pointwise_l (proj1 A'') (Functor.Identity.identity E)). refine (((idtoiso (C := (_ -> _)) (Functor.Pointwise.Properties.composition_of G (Functor.Identity.identity E) F (Functor.Identity.identity E))) : morphism _ _ _) o _). refine (NaturalTransformation.Pointwise.pointwise_r _ _). exact (NaturalTransformation.Composition.Laws.left_identity_natural_transformation_2 _). Defined. Definition counit_r : NaturalTransformation (pointwise G (identity E) o pointwise F (identity E)) (identity (D -> E)). Proof. pose proof (A : AdjunctionCounit _ _) as A''. refine ((((idtoiso (C := (_ -> _)) (Functor.Pointwise.Properties.identity_of _ _)))%morphism : morphism _ _ _) o _). refine (NaturalTransformation.Pointwise.pointwise_l (proj1 A'') (Functor.Identity.identity E) o _). refine (_ o (((idtoiso (C := (_ -> _)) (Functor.Pointwise.Properties.composition_of F (Functor.Identity.identity E) G (Functor.Identity.identity E)))^-1)%morphism : morphism _ _ _)). refine (NaturalTransformation.Pointwise.pointwise_r _ _). exact (NaturalTransformation.Composition.Laws.left_identity_natural_transformation_1 _). Defined. Create HintDb adjoint_pointwise discriminated. Hint Rewrite identity_of left_identity right_identity eta_idtoiso composition_of idtoiso_functor @ap_V @ap10_V @ap10_path_forall path_functor_uncurried_fst : adjoint_pointwise. Definition pointwise_r : pointwise G (identity E) -| pointwise F (identity E). Proof. exists unit_r counit_r; abstract ( path_natural_transformation; intros; destruct A; simpl in *; repeat match goal with | _ => reflexivity | _ => progress simpl | _ => progress autorewrite with adjoint_pointwise | [ |- context[ap object_of (path_functor_uncurried ?F ?G (?HO; ?HM))] ] => rewrite (@path_functor_uncurried_fst _ _ _ F G HO HM) | _ => progress unfold Functor.Pointwise.Properties.identity_of | _ => progress unfold Functor.Pointwise.Properties.composition_of | _ => progress unfold Functor.Pointwise.Properties.identity_of_helper | _ => progress unfold Functor.Pointwise.Properties.composition_of_helper | _ => progress unfold Functor.Pointwise.Properties.identity_of_helper_helper | _ => progress unfold Functor.Pointwise.Properties.composition_of_helper_helper | _ => rewrite <- composition_of; progress rewrite_hyp end ). (* 19.097 *) Defined. End r. End AdjointPointwise. Coq-HoTT-9.0/theories/Categories/Adjoint/UnitCounit.v000066400000000000000000000227571474641544500225420ustar00rootroot00000000000000(** * Adjunctions by units and counits *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Category.Dual Functor.Dual NaturalTransformation.Dual. Require Import Functor.Composition.Core Functor.Identity. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope morphism_scope. Section Adjunction. (** ** Unit + UMP definition of adjunction *) (** Quoting from Awodey's "Category Theory": An adjunction between categories [C] and [D] consists of functors [F : C <-> D : G] and a natural transformation [T : 1_C -> G ∘ F] with the property: (o) For any [c : C], [d : D], and [f : c -> G d], there exists a unique [g : F c -> d] such that [f = (G g) ∘ (T c)] as indicated in << g F c ..................> d G g G (F c) --------------> G d ^ _ | /| | / | / | / | T c / | / f | / | / | / | / c >> Terminology and notation: - [F] is called the left adjoint, [G] is called the right adjoint, and [T] is called the unit of the adjunction. - One sometimes writes [F -| G] for ``[F] is left and [G] right adjoint.'' - The statement (o) is the UMP of the unit [T]. Note that the situation [F ⊣ G] is a generalization of equivalence of categories, in that a pseudo-inverse is an adjoint. In that case, however, it is the relation between categories that one is interested in. Here, one is concerned with the relation between special functors. That is to say, it is not the relation on categories ``there exists an adjunction,'' but rather ``this functor has an adjoint'' that we are concerned with. *) Section unit. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Definition AdjunctionUnit := { T : NaturalTransformation 1 (G o F) | forall (c : C) (d : D) (f : morphism C c (G d)), Contr { g : morphism D (F c) d | G _1 g o T c = f } }. End unit. (** ** Counit + UMP definition of adjunction *) (** Paraphrasing and quoting from Awody's "Category Theory": An adjunction between categories [C] and [D] consists of functors [F : C <-> D : G] and a natural transformation [U : F ∘ G -> 1_D] with the property: (o) For any [c : C], [d : D], and [g : F c -> d], there exists a unique [f : c -> G d] such that [g = (U d) ∘ (F f)] as indicated in the diagram << f c ..................> G d F f F c --------------> F (G d) \ | \ | \ | \ | \ | U d g \ | \ | \ | \ | _\| V d >> Terminology and notation: - The statement (o) is the UMP of the counit [U]. *) Section counit. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Definition AdjunctionCounit := { U : NaturalTransformation (F o G) 1 | forall (c : C) (d : D) (g : morphism D (F c) d), Contr { f : morphism C c (G d) | U d o F _1 f = g } }. End counit. (** The counit is just the dual of the unit. We formalize this here so that we can use it to make coercions easier. *) Section unit_counit_op. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Definition adjunction_counit__op__adjunction_unit (A : AdjunctionUnit G^op F^op) : AdjunctionCounit F G := exist (fun U : NaturalTransformation (F o G) 1 => forall (c : C) (d : D) (g : morphism D (F c) d), Contr {f : morphism C c (G d) | U d o F _1 f = g }) (A.1^op)%natural_transformation (fun c d g => A.2 d c g). Definition adjunction_counit__op__adjunction_unit__inv (A : AdjunctionUnit G F) : AdjunctionCounit F^op G^op := exist (fun U : NaturalTransformation (F^op o G^op) 1 => forall (c : C^op) (d : D^op) (g : morphism D^op ((F^op)%functor c) d), Contr {f : morphism C^op c ((G^op)%functor d) | U d o F^op _1 f = g }) (A.1^op)%natural_transformation (fun c d g => A.2 d c g). Definition adjunction_unit__op__adjunction_counit (A : AdjunctionCounit G^op F^op) : AdjunctionUnit F G := exist (fun T : NaturalTransformation 1 (G o F) => forall (c : C) (d : D) (f : morphism C c (G d)), Contr { g : morphism D (F c) d | G _1 g o T c = f }) (A.1^op)%natural_transformation (fun c d g => A.2 d c g). Definition adjunction_unit__op__adjunction_counit__inv (A : AdjunctionCounit G F) : AdjunctionUnit F^op G^op := exist (fun T : NaturalTransformation 1 (G^op o F^op) => forall (c : C^op) (d : D^op) (f : morphism C^op c ((G^op)%functor d)), Contr {g : morphism D^op ((F^op)%functor c) d | G^op _1 g o T c = f }) (A.1^op)%natural_transformation (fun c d g => A.2 d c g). End unit_counit_op. (** ** Unit + Counit + Zig + Zag definition of adjunction *) (** Quoting Wikipedia on Adjoint Functors: A counit-unit adjunction between two categories [C] and [D] consists of two functors [F : C ← D] and [G : C → D] and two natural transformations << ε : FG → 1_C η : 1_D → GF >> respectively called the counit and the unit of the adjunction (terminology from universal algebra), such that the compositions << F η ε F F -------> F G F -------> F η G G ε G -------> G F G -------> G >> are the identity transformations [1_F] and [1_G] on [F] and [G] respectively. In this situation we say that ``[F] is left adjoint to [G]'' and ''[G] is right adjoint to [F]'', and may indicate this relationship by writing [(ε, η) : F ⊣ G], or simply [F ⊣ G]. In equation form, the above conditions on (ε, η) are the counit-unit equations << 1_F = ε F ∘ F η 1_G = G ε ∘ η G >> which mean that for each [X] in [C] and each [Y] in [D], << 1_{FY} = ε_{FY} ∘ F(η_Y) 1_{GX} = G(ε_X) ∘ η_{GX} >> These equations are useful in reducing proofs about adjoint functors to algebraic manipulations. They are sometimes called the ``zig-zag equations'' because of the appearance of the corresponding string diagrams. A way to remember them is to first write down the nonsensical equation [1 = ε ∘ η] and then fill in either [F] or [G] in one of the two simple ways which make the compositions defined. Note: The use of the prefix ``co'' in counit here is not consistent with the terminology of limits and colimits, because a colimit satisfies an initial property whereas the counit morphisms will satisfy terminal properties, and dually. The term unit here is borrowed from the theory of monads where it looks like the insertion of the identity 1 into a monoid. *) Section unit_counit. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. (*Local Reserved Notation "'ε'". Local Reserved Notation "'η'".*) (** Use the per-object version of the equations, so that we don't need the associator in the middle. Also, explicitly simplify some of the types so that [rewrite] works better. *) Record AdjunctionUnitCounit := { unit : NaturalTransformation (identity C) (G o F) (*where "'η'" := unit*); counit : NaturalTransformation (F o G) (identity D) (*where "'ε'" := counit*); unit_counit_equation_1 : forall Y : C, (*ε (F Y) ∘ F ₁ (η Y) = identity (F Y);*) Category.Core.compose (C := D) (s := F Y) (d := F (G (F Y))) (d' := F Y) (counit (F Y)) (F _1 (unit Y : morphism _ Y (G (F Y)))) = 1; unit_counit_equation_2 : forall X : D, (* G ₁ (ε X) ∘ η (G X) = identity (G X) *) Category.Core.compose (C := C) (s := G X) (d := G (F (G X))) (d' := G X) (G _1 (counit X : morphism _ (F (G X)) X)) (unit (G X)) = 1 }. End unit_counit. End Adjunction. Declare Scope adjunction_scope. Delimit Scope adjunction_scope with adjunction. Bind Scope adjunction_scope with AdjunctionUnit. Bind Scope adjunction_scope with AdjunctionCounit. Bind Scope adjunction_scope with AdjunctionUnitCounit. Arguments unit [C D]%_category [F G]%_functor _%_adjunction / . Arguments counit [C D]%_category [F G]%_functor _%_adjunction / . Arguments AdjunctionUnitCounit [C D]%_category (F G)%_functor. Arguments unit_counit_equation_1 [C D]%_category [F G]%_functor _%_adjunction _%_object. Arguments unit_counit_equation_2 [C D]%_category [F G]%_functor _%_adjunction _%_object. Coq-HoTT-9.0/theories/Categories/Adjoint/UnitCounitCoercions.v000066400000000000000000000145771474641544500244100ustar00rootroot00000000000000(** * Coercions between the various (co)unit definitions *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Adjoint.UnitCounit Adjoint.Dual. Require Import Functor.Composition.Core Functor.Identity. Require Import HoTT.Tactics Basics.Trunc Types.Sigma. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. Local Open Scope category_scope. Local Open Scope morphism_scope. Section equivalences. Section from_unit_counit. Local Ltac unit_counit_of_t := repeat match goal with | _ => split | _ => intro | _ => progress auto with morphism | _ => progress simpl | _ => rewrite !composition_of | [ |- context[components_of ?T] ] => (try_associativity_quick simpl rewrite <- (commutes T)); try_associativity_quick progress rewrite ?unit_counit_equation_1, ?unit_counit_equation_2 | [ |- context[components_of ?T] ] => (try_associativity_quick simpl rewrite (commutes T)); try_associativity_quick progress rewrite ?unit_counit_equation_1, ?unit_counit_equation_2 | _ => progress path_induction end. (** ** unit+counit+zig+zag → unit+UMP *) Definition adjunction_unit__of__adjunction_unit_counit C D F G (A : @AdjunctionUnitCounit C D F G) : AdjunctionUnit F G. Proof. exists (unit A). intros c d f. apply contr_inhabited_hprop; [ apply hprop_allpath | (exists (counit A d o F _1 f)); abstract unit_counit_of_t ]. intros [? ?] [? ?]. apply path_sigma_uncurried. let A := match goal with |- @sig ?A ?P => constr:(A) end in let H := fresh in assert (H : A); [ | exists H; exact (center _) ]. simpl. let x := match goal with |- ?x = ?y => constr:(x) end in let y := match goal with |- ?x = ?y => constr:(y) end in rewrite <- (right_identity _ _ _ x), <- (right_identity _ _ _ y), <- !(unit_counit_equation_1 A), <- ?associativity; repeat simpl rewrite <- (commutes (counit A)); (try_associativity_quick rewrite <- !composition_of); repeat apply ap; etransitivity; [ | symmetry ]; eassumption. Defined. (** ** unit+counit+zig+zag → counit+UMP *) Definition adjunction_counit__of__adjunction_unit_counit C D F G (A : @AdjunctionUnitCounit C D F G) : AdjunctionCounit F G := adjunction_counit__op__adjunction_unit (adjunction_unit__of__adjunction_unit_counit A^op). End from_unit_counit. Section to_unit_counit. Ltac to_unit_counit_nt helper commutes_tac := simpl; intros; apply helper; repeat match goal with | _ => reflexivity | _ => rewrite !composition_of | _ => progress rewrite ?identity_of, ?left_identity, ?right_identity | [ |- context[?x.1] ] => try_associativity_quick simpl rewrite x.2 | [ |- context[components_of ?T] ] => simpl_do_clear commutes_tac (commutes T) end. (** ** unit+UMP → unit+counit+zig+zag *) Section from_unit. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Lemma counit_natural_transformation__of__adjunction_unit_helper (A : AdjunctionUnit F G) s d (m : morphism D s d) (eta := A.1) (eps := fun X => (@center _ (A.2 (G X) X 1)).1) : G _1 (eps d o F _1 (G _1 m)) o eta (G s) = G _1 m -> G _1 (m o eps s) o eta (G s) = G _1 m -> eps d o F _1 (G _1 m) = m o eps s. Proof. intros. transitivity (@center _ (A.2 _ _ (G _1 m))).1; [ symmetry | ]; let x := match goal with |- _ = ?x => constr:(x) end in refine ((fun H => ap pr1 (@contr _ (A.2 _ _ (G _1 m)) (x; H))) _); assumption. Qed. Definition counit_natural_transformation__of__adjunction_unit (A : AdjunctionUnit F G) : NaturalTransformation (F o G) 1. Proof. refine (Build_NaturalTransformation (F o G) 1 (fun d => (@center _ (A.2 (G d) d 1)).1) _). abstract ( to_unit_counit_nt counit_natural_transformation__of__adjunction_unit_helper ltac:(fun H => try_associativity_quick rewrite <- H) ). Defined. Definition zig__of__adjunction_unit (A : AdjunctionUnit F G) (Y : C) (eta := A.1) (eps := fun X => (@center _ (A.2 (G X) X 1)).1) : G _1 (eps (F Y) o F _1 (eta Y)) o eta Y = eta Y -> eps (F Y) o F _1 (eta Y) = 1. Proof. intros. etransitivity; [ symmetry | ]; simpl_do_clear ltac:(fun H => apply H) (fun y H => (@contr _ (A.2 _ _ (A.1 Y)) (y; H))..1); try assumption. simpl. rewrite ?identity_of, ?left_identity, ?right_identity; reflexivity. Qed. Definition adjunction_unit_counit__of__adjunction_unit (A : AdjunctionUnit F G) : AdjunctionUnitCounit F G. Proof. exists A.1 (counit_natural_transformation__of__adjunction_unit A); simpl; intros; try match goal with | [ |- context[?x.1] ] => exact x.2 end; []. abstract (to_unit_counit_nt zig__of__adjunction_unit ltac:(fun H => try_associativity_quick rewrite <- H)). Defined. End from_unit. (** ** counit+UMP → unit+counit+zig+zag *) Definition adjunction_unit_counit__of__adjunction_counit C D F G (A : @AdjunctionCounit C D F G) : AdjunctionUnitCounit F G := ((adjunction_unit_counit__of__adjunction_unit (adjunction_unit__op__adjunction_counit__inv A))^op)%adjunction. End to_unit_counit. End equivalences. Coercion adjunction_unit__of__adjunction_unit_counit : AdjunctionUnitCounit >-> AdjunctionUnit. Coercion adjunction_counit__of__adjunction_unit_counit : AdjunctionUnitCounit >-> AdjunctionCounit. Coq-HoTT-9.0/theories/Categories/Adjoint/UniversalMorphisms.v000066400000000000000000000002251474641544500242750ustar00rootroot00000000000000(** * Adjunctions as universal morphisms *) (** ** Definitions *) Require Adjoint.UniversalMorphisms.Core. Include Adjoint.UniversalMorphisms.Core. Coq-HoTT-9.0/theories/Categories/Adjoint/UniversalMorphisms/000077500000000000000000000000001474641544500241075ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Adjoint/UniversalMorphisms/Core.v000066400000000000000000000121461474641544500251720ustar00rootroot00000000000000(** * Adjunctions as universal morphisms *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Identity Functor.Composition.Core. Require Import Functor.Dual Category.Dual. Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.UnitCounitCoercions Adjoint.Dual. Require Comma.Core. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Import Comma.Core. Local Set Warnings Append "notation-overridden". Require Import UniversalProperties Comma.Dual InitialTerminalCategory.Core InitialTerminalCategory.Functors. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section adjunction_universal. (** ** [F ⊣ G] gives an initial object of [(Y / G)] for all [Y : C] *) Section initial. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Variable A : F -| G. Variable Y : C. Definition initial_morphism__of__adjunction : object (Y / G) := @CommaCategory.Build_object _ D C (! Y) G (center _) (F Y) ((unit A) Y). Definition is_initial_morphism__of__adjunction : IsInitialMorphism initial_morphism__of__adjunction := Build_IsInitialMorphism _ _ _ _ ((A : AdjunctionUnit _ _).2 _). End initial. Global Arguments initial_morphism__of__adjunction [C D F G] A Y. Global Arguments is_initial_morphism__of__adjunction [C D F G] A Y _. (** ** [F ⊣ G] gives a terminal object of [(F / X)] for all [X : D] *) Section terminal. Variables C D : PreCategory. Variable F : Functor C D. Variable G : Functor D C. Variable A : F -| G. Variable X : D. Definition terminal_morphism__of__adjunction : object (F / X) := Eval simpl in dual_functor (! X)^op F^op (initial_morphism__of__adjunction A^op X). Definition is_terminal_morphism__of__adjunction : IsTerminalMorphism terminal_morphism__of__adjunction := is_initial_morphism__of__adjunction A^op X. End terminal. Global Arguments terminal_morphism__of__adjunction [C D F G] A X. Global Arguments is_terminal_morphism__of__adjunction [C D F G] A X _. End adjunction_universal. Section adjunction_from_universal. (** ** an initial object of [(Y / G)] for all [Y : C] gives a left adjoint to [G] *) Section initial. Variables C D : PreCategory. Variable G : Functor D C. Context `(HM : forall Y, @IsInitialMorphism _ _ Y G (M Y)). Local Notation obj_of Y := (IsInitialMorphism_object (@HM Y)) (only parsing). Local Notation mor_of Y0 Y1 f := (let etaY1 := IsInitialMorphism_morphism (@HM Y1) in IsInitialMorphism_property_morphism (@HM Y0) _ (etaY1 o f)) (only parsing). Lemma identity_of Y : mor_of Y Y 1 = 1. Proof. simpl. erewrite IsInitialMorphism_property_morphism_unique; [ reflexivity | ]. rewrite ?identity_of, ?left_identity, ?right_identity. reflexivity. Qed. Lemma composition_of x y z g f : mor_of _ _ (f o g) = mor_of y z f o mor_of x y g. Proof. simpl. erewrite IsInitialMorphism_property_morphism_unique; [ reflexivity | ]. rewrite ?composition_of. repeat try_associativity_quick rewrite IsInitialMorphism_property_morphism_property. reflexivity. Qed. Definition functor__of__initial_morphism : Functor C D := Build_Functor C D (fun x => obj_of x) (fun s d m => mor_of s d m) composition_of identity_of. Definition adjunction__of__initial_morphism : functor__of__initial_morphism -| G. Proof. refine (adjunction_unit_counit__of__adjunction_unit _). eexists (Build_NaturalTransformation 1 (G o functor__of__initial_morphism) (fun x => IsInitialMorphism_morphism (@HM x)) (fun s d m => symmetry _ _ (IsInitialMorphism_property_morphism_property (@HM s) _ _))). simpl. exact (fun c => @IsInitialMorphism_property _ _ c G (M c) (@HM c)). Defined. End initial. (** ** a terminal object of [(F / X)] for all [X : D] gives a right adjoint to [F] *) Section terminal. Variables C D : PreCategory. Variable F : Functor C D. Context `(HM : forall X, @IsTerminalMorphism _ _ F X (M X)). Definition functor__of__terminal_morphism : Functor D C := (@functor__of__initial_morphism (D^op) (C^op) (F^op) (fun x : D => dual_functor F !x (M x)) HM)^op. Definition adjunction__of__terminal_morphism : F -| functor__of__terminal_morphism := ((@adjunction__of__initial_morphism (D^op) (C^op) (F^op) (fun x : D => dual_functor F !x (M x)) HM)^op)%adjunction. End terminal. End adjunction_from_universal. Coq-HoTT-9.0/theories/Categories/Adjoint/Utf8.v000066400000000000000000000006011474641544500212470ustar00rootroot00000000000000Require Import Adjoint.Core Adjoint.Dual Adjoint.Composition.Core. Require Export Adjoint.Notations. Require Import Basics.Utf8. Infix "⊣" := Adjunction : type_scope. Infix "∘" := compose : adjunction_scope. (** It would be nice to put [, format "A 'ᵒᵖ'"] here, but that would make this notation unparseable. *) Notation "A 'ᵒᵖ'" := (opposite A) : adjunction_scope. Coq-HoTT-9.0/theories/Categories/Cat.v000066400000000000000000000002611474641544500175420ustar00rootroot00000000000000(** * Cat, precategories of precategories *) (** ** Definitions *) Require Cat.Core. (** ** Morphisms in cat *) Require Cat.Morphisms. Include Cat.Core. Include Cat.Morphisms. Coq-HoTT-9.0/theories/Categories/Cat/000077500000000000000000000000001474641544500173545ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Cat/Core.v000066400000000000000000000044401474641544500204350ustar00rootroot00000000000000(** * Cat, the precategory of strict categories *) Require Import Category.Objects InitialTerminalCategory.Core InitialTerminalCategory.Functors Functor.Core Category.Strict Functor.Paths. Require Import Functor.Identity Functor.Composition.Core Functor.Composition.Laws. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Section sub_pre_cat. Context `{Funext}. (** We use a slight generalization; we look at a full 1-precategory of the 2-precategory Cat, such that all types of functors are hSets. It might be possible to prove that this doesn't buy you anything, because it's probably the case that [IsHSet (Functor C C) → IsStrictCategory C]. *) Variable P : PreCategory -> Type. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. (** There is a precategory of precategories which satisfy the proposition P *) Definition sub_pre_cat : PreCategory := @Build_PreCategory { C : PreCategory | P C } (fun C D => Functor C.1 D.1) (fun C => identity C.1) (fun _ _ _ F G => F o G) (fun _ _ _ _ _ _ _ => associativity _ _ _) (fun _ _ _ => left_identity _) (fun _ _ _ => right_identity _) (fun s d => HF s.2 d.2). End sub_pre_cat. Arguments sub_pre_cat {_} P {_}, {_} P _. #[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances. Definition strict_cat `{Funext} : PreCategory := sub_pre_cat (fun C => IsStrictCategory C). (*Definition Cat `{Funext} : PreCategory. refine (@sub_pre_cat _ (fun C => IsCategory C) _). *) (** ** The initial and terminal categories are initial and terminal objects in cat *) Section objects. Context `{Funext}. Variable P : PreCategory -> Type. Context `{forall C, IsHProp (P C)}. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Lemma is_terminal_object__is_terminal_category `(IsTerminalCategory one) (HT : P one) : IsTerminalObject (sub_pre_cat P HF) (one; HT). Proof. typeclasses eauto. Defined. Lemma is_initial_object__is_initial_category `(IsInitialCategory zero) (HI : P zero) : IsInitialObject (sub_pre_cat P HF) (zero; HI). Proof. typeclasses eauto. Defined. End objects. Coq-HoTT-9.0/theories/Categories/Cat/Morphisms.v000066400000000000000000000023441474641544500215270ustar00rootroot00000000000000(** * Morphisms in cat *) Require Import Category.Core Functor.Core FunctorCategory.Core NaturalTransformation.Core. Require Import Category.Morphisms. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope morphism_scope. (** ** Lemmas relationship between transporting the action of functors on objects, and [idtoiso] *) Section iso_lemmas. Context `{Funext}. Variable C : PreCategory. Variables s d : C. Variables m1 m2 : morphism C s d. Variable p : m1 = m2. Variables Fs Fd : PreCategory. Variable Fm : morphism C s d -> Functor Fs Fd. Lemma transport_Fc_to_idtoiso s' d' u : @transport _ (fun m => morphism _ (Fm m s') d') _ _ p u = u o components_of (Category.Morphisms.idtoiso (_ -> _) (ap Fm p) : morphism _ _ _)^-1 s'. Proof. case p; clear p; simpl; autorewrite with morphism; reflexivity. Qed. Lemma transport_cF_to_idtoiso s' d' u : @transport _ (fun m => morphism _ s' (Fm m d')) _ _ p u = components_of (Category.Morphisms.idtoiso (_ -> _) (ap Fm p) : morphism _ _ _) d' o u. Proof. case p; clear p; simpl; autorewrite with morphism; reflexivity. Qed. End iso_lemmas. Coq-HoTT-9.0/theories/Categories/Category.v000066400000000000000000000033261474641544500206150ustar00rootroot00000000000000(** * Categories *) (** We collect here all of the files about categories. *) (** Since there are only notations in [Category.Notations], we can just export those. *) Require Export Category.Notations. (** ** Definition of precategories *) Require Category.Core. (** ** Opposite precategories *) Require Category.Dual. (** ** Morphisms in precategories *) Require Category.Morphisms. (** ** Classification of path space *) Require Category.Paths. (** ** Universal objects *) Require Category.Objects. (** ** Product precategories *) Require Category.Prod. (** ** Dependent product precategories *) Require Category.Pi. (** ** ∑-precategories *) Require Category.Sigma. (** ** Strict categories *) Require Category.Strict. (** ** Coproduct precategories *) Require Category.Sum. (** ** Categories (univalent or saturated) *) Require Category.Univalent. Local Set Warnings Append "-notation-overridden". Include Category.Core. Include Category.Dual. Include Category.Morphisms. Include Category.Paths. Include Category.Objects. Include Category.Prod. Include Category.Pi. (** We use the [Sigma] folder only to allow us to split up the various files and group conceptually similar lemmas, but not for namespacing. So we include the main file in it. *) Include Category.Sigma. Include Category.Strict. Include Category.Sum. Include Category.Univalent. (** We don't want to make utf-8 notations the default, so we don't export them. *) (** ** Subcategories *) (** For the subfolders, we need to re-create the module structure. Alas, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *) Require Category.Subcategory. Coq-HoTT-9.0/theories/Categories/Category/000077500000000000000000000000001474641544500204225ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Category/Core.v000066400000000000000000000141761474641544500215120ustar00rootroot00000000000000(** * Definition of a [PreCategory] *) Require Export Overture Basics.Notations. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Declare Scope morphism_scope. Declare Scope category_scope. Declare Scope object_scope. Delimit Scope morphism_scope with morphism. Delimit Scope category_scope with category. Delimit Scope object_scope with object. Local Open Scope morphism_scope. (** Quoting the HoTT Book: *) (** Definition 9.1.1. A precategory [A] consists of the following. (i) A type [A₀] of objects. We write [a : A] for [a : A₀]. (ii) For each [a, b : A], a set [hom_A(a, b)] of arrows or morphisms. (iii) For each [a : A], a morphism [1ₐ : hom_A(a, a)]. (iv) For each [a, b, c : A], a function [hom_A(b, c) → hom_A(a, b) → hom_A(a, c)] denoted infix by [g ↦ f ↦ g ∘ f] , or sometimes simply by [g f]. (v) For each [a, b : A] and [f : hom_A(a, b)], we have [f = 1_b ∘ f] and [f = f ∘ 1ₐ]. (vi) For each [a, b, c, d : A] and [f : hom_A(a, b)], [g : hom_A(b, c)], [h : hom_A(c,d)], we have [h ∘ (g ∘ f) = (h ∘ g) ∘ f]. *) (** In addition to these laws, we ask for a few redundant laws to give us more judgmental equalities. For example, since [(p^)^ ≢ p] for paths [p], we ask for the symmetrized version of the associativity law, so we can swap them when we take the dual. *) Record PreCategory := Build_PreCategory' { object :> Type; morphism : object -> object -> Type; identity : forall x, morphism x x; compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' where "f 'o' g" := (compose f g); associativity : forall x1 x2 x3 x4 (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4), (m3 o m2) o m1 = m3 o (m2 o m1); (** Ask for the symmetrized version of [associativity], so that [(Cᵒᵖ)ᵒᵖ] and [C] are equal without [Funext] *) associativity_sym : forall x1 x2 x3 x4 (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4), m3 o (m2 o m1) = (m3 o m2) o m1; left_identity : forall a b (f : morphism a b), identity b o f = f; right_identity : forall a b (f : morphism a b), f o identity a = f; (** Ask for the double-identity version so that [InitialTerminalCategory.Functors.from_terminal Cᵒᵖ X] and [(InitialTerminalCategory.Functors.from_terminal C X)ᵒᵖ] are convertible. *) identity_identity : forall x, identity x o identity x = identity x; trunc_morphism : forall s d, IsHSet (morphism s d) }. Bind Scope category_scope with PreCategory. Bind Scope object_scope with object. Bind Scope morphism_scope with morphism. (** We want eta-expanded primitive projections to [simpl] away. *) Arguments object !C%_category / : rename. Arguments morphism !C%_category / s d : rename. Arguments identity {!C%_category} / x%_object : rename. Arguments compose {!C%_category} / {s d d'}%_object (m1 m2)%_morphism : rename. Local Infix "o" := compose : morphism_scope. (** Perhaps we should consider making this notation more global. *) (** Perhaps we should pre-reserve all of the notations. *) Local Notation "x --> y" := (morphism _ x y) : type_scope. Local Notation "1" := (identity _) : morphism_scope. (** Define a convenience wrapper for building a precategory without specifying the redundant proofs. *) Definition Build_PreCategory object morphism identity compose associativity left_identity right_identity := @Build_PreCategory' object morphism identity compose associativity (fun _ _ _ _ _ _ _ => symmetry _ _ (associativity _ _ _ _ _ _ _)) left_identity right_identity (fun _ => left_identity _ _ _). Global Existing Instance trunc_morphism. (** create a hint db for all category theory things *) Create HintDb category discriminated. (** create a hint db for morphisms in categories *) Create HintDb morphism discriminated. #[export] Hint Resolve left_identity right_identity associativity : category morphism. #[export] Hint Rewrite left_identity right_identity : category. #[export] Hint Rewrite left_identity right_identity : morphism. (** ** Simple laws about the identity morphism *) Section identity_unique. Variable C : PreCategory. (** The identity morphism is unique. *) Lemma identity_unique (id0 id1 : forall x, morphism C x x) (id1_left : forall s d (m : morphism C s d), id1 _ o m = m) (id0_right : forall s d (m : morphism C s d), m o id0 _ = m) : id0 == id1. Proof. intro. etransitivity; [ symmetry; apply id1_left | apply id0_right ]. Qed. (** Anything equal to the identity acts like it. This is obvious, but useful as a helper lemma for automation. *) Definition concat_left_identity s d (m : morphism C s d) i : i = 1 -> i o m = m := fun H => (ap10 (ap _ H) _ @ left_identity _ _ _ m)%path. Definition concat_right_identity s d (m : morphism C s d) i : i = 1 -> m o i = m := fun H => (ap _ H @ right_identity _ _ _ m)%path. End identity_unique. (** Make a separate module for Notations, which can be exported/imported separately. *) Module Export CategoryCoreNotations. Infix "o" := compose : morphism_scope. (** Perhaps we should consider making this notation more global. *) (** Perhaps we should pre-reserve all of the notations. *) Local Notation "x --> y" := (@morphism _ x y) : type_scope. Local Notation "x --> y" := (morphism _ x y) : type_scope. Notation "1" := (identity _) : morphism_scope. End CategoryCoreNotations. (** We have a tactic for trying to run a tactic after associating morphisms either all the way to the left, or all the way to the right *) Tactic Notation "try_associativity_quick" tactic(tac) := first [ rewrite <- ?associativity; tac | rewrite -> ?associativity; tac ]. Coq-HoTT-9.0/theories/Categories/Category/Dual.v000066400000000000000000000026141474641544500215010ustar00rootroot00000000000000(** * Opposite Category *) Require Import Category.Core Category.Objects. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. (** ** Definition of [Cᵒᵖ] *) Definition opposite (C : PreCategory) : PreCategory := @Build_PreCategory' C (fun s d => morphism C d s) (identity (C := C)) (fun _ _ _ m1 m2 => m2 o m1) (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _) (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _) (fun _ _ => @right_identity _ _ _) (fun _ _ => @left_identity _ _ _) (@identity_identity C) _. Local Notation "C ^op" := (opposite C) : category_scope. (** ** [ᵒᵖ] is judgmentally involutive *) Definition opposite_involutive C : (C^op)^op = C := idpath. (** ** Initial objects are opposite terminal objects, and vice versa *) Section DualObjects. Variable C : PreCategory. Definition terminal_opposite_initial (x : C) `(H : IsTerminalObject C x) : IsInitialObject (C^op) x := fun x' => H x'. Definition initial_opposite_terminal (x : C) `(H : IsInitialObject C x) : IsTerminalObject (C^op) x := fun x' => H x'. End DualObjects. Module Export CategoryDualNotations. Notation "C ^op" := (opposite C) : category_scope. End CategoryDualNotations. Coq-HoTT-9.0/theories/Categories/Category/Morphisms.v000066400000000000000000000563101474641544500225770ustar00rootroot00000000000000(** * Definitions and theorems about {iso,epi,mono,}morphisms in a precategory *) Require Import Category.Core Functor.Core. Require Import HoTT.Tactics Basics.Trunc Basics.Tactics Types.Sigma Equivalences. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope morphism_scope. (** ** Definition of isomorphism *) Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s; left_inverse : morphism_inverse o m = identity _; right_inverse : m o morphism_inverse = identity _ }. Arguments morphism_inverse {C s d} m {_}. Local Notation "m ^-1" := (morphism_inverse m) : morphism_scope. #[export] Hint Resolve left_inverse right_inverse : category morphism. #[export] Hint Rewrite @left_inverse @right_inverse : category. #[export] Hint Rewrite @left_inverse @right_inverse : morphism. Class Isomorphic {C : PreCategory} s d := { morphism_isomorphic : morphism C s d; isisomorphism_isomorphic : IsIsomorphism morphism_isomorphic }. (*Coercion Build_Isomorphic : IsIsomorphism >-> Isomorphic.*) Coercion morphism_isomorphic : Isomorphic >-> morphism. (* Use :> and remove the two following lines, once Coq 8.16 is the minimum required version. *) #[export] Existing Instance isisomorphism_isomorphic. Coercion isisomorphism_isomorphic : Isomorphic >-> IsIsomorphism. Local Infix "<~=~>" := Isomorphic : category_scope. Global Existing Instance isisomorphism_isomorphic. (** ** Theorems about isomorphisms *) Section iso_contr. Variable C : PreCategory. Variables s d : C. Local Notation IsIsomorphism_sig_T m := { inverse : morphism C d s | { _ : inverse o m = identity _ | m o inverse = identity _ } } (only parsing). Section IsIsomorphism. Variable m : morphism C s d. (** *** The inverse of a morphism is unique *) Lemma inverse_unique (m_inv0 m_inv1 : morphism C d s) (left_inverse_0 : m_inv0 o m = identity _) (right_inverse_1 : m o m_inv1 = identity _) : m_inv0 = m_inv1. Proof. transitivity (m_inv0 o m o m_inv1); try solve [ by (rewrite -> ?associativity; rewrite_hyp; autorewrite with morphism) | by (rewrite <- ?associativity; rewrite_hyp; autorewrite with morphism) ]. Qed. (** *** Equivalence between the record and sigma versions of [IsIsomorphism] *) Lemma issig_isisomorphism : IsIsomorphism_sig_T m <~> IsIsomorphism m. Proof. issig. Defined. (** *** Being an isomorphism is a mere proposition *) Global Instance istrunc_isisomorphism : IsHProp (IsIsomorphism m). Proof. eapply istrunc_equiv_istrunc; [ exact issig_isisomorphism | ]. apply hprop_allpath. intros [x [? ?]] [y [? ?]]. let H := fresh in assert (H : x = y) by (apply inverse_unique; assumption); destruct H. repeat match goal with | _ => progress simpl | _ => exact (center _) | _ => (exists idpath) | _ => apply path_sigma_uncurried end. Qed. End IsIsomorphism. Local Notation Isomorphic_sig_T := { m : morphism C s d | IsIsomorphism m } (only parsing). (** *** Equivalence between record and sigma versions of [Isomorphic] *) Lemma issig_isomorphic : Isomorphic_sig_T <~> Isomorphic s d. Proof. issig. Defined. Local Notation Isomorphic_full_sig_T := { m : morphism C s d | IsIsomorphism_sig_T m } (only parsing). (** *** Equivalence between record and fully sigma versions of [Isomorphic] *) Definition issig_full_isomorphic : Isomorphic_full_sig_T <~> Isomorphic s d := (issig_isomorphic oE equiv_functor_sigma_id issig_isisomorphism). (** *** Isomorphisms form an hSet *) Global Instance trunc_Isomorphic : IsHSet (Isomorphic s d). Proof. eapply istrunc_equiv_istrunc; [ exact issig_isomorphic | ]. typeclasses eauto. Qed. (** *** Equality between isomorphisms is determined by equality between their forward components *) Definition path_isomorphic (i j : Isomorphic s d) : @morphism_isomorphic _ _ _ i = @morphism_isomorphic _ _ _ j -> i = j. Proof. destruct i, j; simpl. intro; path_induction. f_ap. exact (center _). Defined. (** *** Relations between [path_isomorphic], [ap morphism_inverse], and [ap morphism_isomorphic] *) Definition ap_morphism_isomorphic_path_isomorphic (i j : Isomorphic s d) p : ap (@morphism_isomorphic _ _ _) (path_isomorphic i j p) = p. Proof. unfold path_isomorphic. destruct i, j. path_induction_hammer. Qed. Definition ap_morphism_inverse_path_isomorphic (i j : Isomorphic s d) p q : ap (fun e : Isomorphic s d => e^-1)%morphism (path_isomorphic i j p) = q. Proof. apply path_ishprop. Qed. (** *** Equality between isomorphisms is equivalent to by equality between their forward components *) Global Instance isequiv_path_isomorphic {i j} : IsEquiv (path_isomorphic i j). Proof. intros. apply (isequiv_adjointify (path_isomorphic i j) (ap (@morphism_isomorphic _ _ _))); intro; [ destruct i | destruct i, j ]; path_induction_hammer. Defined. End iso_contr. Section iso_equiv_relation. Variable C : PreCategory. (** *** The identity is an isomorphism *) Global Instance isisomorphism_identity (x : C) : IsIsomorphism (identity x) := {| morphism_inverse := identity x; left_inverse := left_identity C x x (identity x); right_inverse := right_identity C x x (identity x) |}. (** *** Inverses of isomorphisms are isomorphisms *) Definition isisomorphism_inverse `(@IsIsomorphism C x y m) : IsIsomorphism m^-1 := {| morphism_inverse := m; left_inverse := right_inverse; right_inverse := left_inverse |}. Local Ltac iso_comp_t inv_lemma := etransitivity; [ | apply inv_lemma ]; first [ rewrite -> ?associativity; apply ap | rewrite <- ?associativity; apply ap ]; first [ rewrite -> ?associativity; rewrite inv_lemma | rewrite <- ?associativity; rewrite inv_lemma ]; auto with morphism. (** *** Composition of isomorphisms gives an isomorphism *) Global Instance isisomorphism_compose `(@IsIsomorphism C y z m0) `(@IsIsomorphism C x y m1) : IsIsomorphism (m0 o m1). Proof. exists (m1^-1 o m0^-1); [ abstract iso_comp_t @left_inverse | abstract iso_comp_t @right_inverse ]. Defined. #[local] Hint Immediate isisomorphism_inverse : typeclass_instances. (** *** Being isomorphic is a reflexive relation *) Global Instance isomorphic_refl : Reflexive (@Isomorphic C) := fun x : C => {| morphism_isomorphic := identity x |}. (** *** Being isomorphic is a symmetric relation *) Global Instance isomorphic_sym : Symmetric (@Isomorphic C) := fun x y X => {| morphism_isomorphic := X^-1 |}. (** *** Being isomorphic is a transitive relation *) Global Instance isomorphic_trans : Transitive (@Isomorphic C) := fun x y z X Y => {| morphism_isomorphic := @morphism_isomorphic _ _ _ Y o @morphism_isomorphic _ _ _ X |}. (** *** Equality gives rise to isomorphism *) Definition idtoiso (x y : C) (H : x = y) : Isomorphic x y := match H in (_ = y0) return (x <~=~> y0) with | 1%path => reflexivity x end. End iso_equiv_relation. #[export] Hint Immediate isisomorphism_inverse : typeclass_instances. (** ** Epimorphisms and Monomorphisms *) (** Quoting Wikipedia: In category theory, an epimorphism (also called an epic morphism or, colloquially, an epi) is a morphism [f : X → Y] which is right-cancellative in the sense that, for all morphisms [g, g' : Y → Z], [g ∘ f = g' ∘ f → g = g'] Epimorphisms are analogues of surjective functions, but they are not exactly the same. The dual of an epimorphism is a monomorphism (i.e. an epimorphism in a category [C] is a monomorphism in the dual category [Cᵒᵖ]). *) Class IsEpimorphism {C} {x y} (m : morphism C x y) := is_epimorphism : forall z (m1 m2 : morphism C y z), m1 o m = m2 o m -> m1 = m2. Class IsMonomorphism {C} {x y} (m : morphism C x y) := is_monomorphism : forall z (m1 m2 : morphism C z x), m o m1 = m o m2 -> m1 = m2. (** We make [IsEpimorphism] and [IsMonomorphism] transparent to typeclass search so that we can infer things like [IsHProp] automatically. *) #[global] Typeclasses Transparent IsEpimorphism IsMonomorphism. Record Epimorphism {C} x y := { Epimorphism_morphism :> morphism C x y; Epimorphism_IsEpimorphism :> IsEpimorphism Epimorphism_morphism }. Record Monomorphism {C} x y := { Monomorphism_morphism :> morphism C x y; Monomorphism_IsMonomorphism :> IsMonomorphism Monomorphism_morphism }. Global Existing Instances Epimorphism_IsEpimorphism Monomorphism_IsMonomorphism. Local Notation "x ->> y" := (Epimorphism x y). Local Notation "x (-> y" := (Monomorphism x y). Class IsSectionOf C x y (s : morphism C x y) (r : morphism C y x) := is_sect_morphism : r o s = identity _. Arguments IsSectionOf [C x y] s r. Section EpiMono. Variable C : PreCategory. Section properties. (** *** The identity is an epimorphism *) Global Instance isepimorphism_identity (x : C) : IsEpimorphism (identity x). Proof. repeat intro; autorewrite with morphism in *; trivial. Qed. (** *** The identity is a monomorphism *) Global Instance ismonomorphism_identity (x : C) : IsMonomorphism (identity x). Proof. repeat intro; autorewrite with morphism in *; trivial. Qed. (** *** Composition of epimorphisms gives an epimorphism *) Global Instance isepimorphism_compose s d d' m0 m1 : IsEpimorphism m0 -> IsEpimorphism m1 -> IsEpimorphism (@compose C s d d' m0 m1). Proof. repeat intro. rewrite <- !associativity in *. apply_hyp. Qed. (** *** Composition of monomorphisms gives a monomorphism *) Global Instance ismonomorphism_compose s d d' m0 m1 : IsMonomorphism m0 -> IsMonomorphism m1 -> IsMonomorphism (@compose C s d d' m0 m1). Proof. repeat intro. rewrite !associativity in *. apply_hyp. Qed. End properties. (** *** Existence of {epi,mono}morphisms are a preorder *) Section equiv. Global Instance reflexive_epimorphism : Reflexive (@Epimorphism C) := fun x => Build_Epimorphism (isepimorphism_identity x). Global Instance reflexive_monomorphism : Reflexive (@Monomorphism C) := fun x => Build_Monomorphism (ismonomorphism_identity x). Global Instance transitive_epimorphism : Transitive (@Epimorphism C) := fun _ _ _ m0 m1 => Build_Epimorphism (isepimorphism_compose m1 m0). Global Instance transitive_monomorphism : Transitive (@Monomorphism C) := fun _ _ _ m0 m1 => Build_Monomorphism (ismonomorphism_compose m1 m0). End equiv. Section sect. Local Ltac epi_mono_sect_t := let t := (solve [ autorewrite with morphism; reflexivity | rewrite_hyp; autorewrite with morphism; reflexivity ]) in first [ rewrite -> ?associativity; t | rewrite <- ?associativity; t]. (** *** Retractions are epimorphisms *) Global Instance isepimorphism_retr `(@IsSectionOf C x y s r) : IsEpimorphism r | 1000. Proof. (intros ? m1 m2 ?). unfold IsSectionOf in *. transitivity ((m1 o r) o s); [ | transitivity ((m2 o r) o s) ]; epi_mono_sect_t. Qed. (** *** Sections are monomorphisms *) Global Instance ismonomorphism_sect `(@IsSectionOf C x y s r) : IsMonomorphism s | 1000. Proof. (intros ? m1 m2 ?). transitivity (r o (s o m1)); [ | transitivity (r o (s o m2)) ]; epi_mono_sect_t. Qed. (** *** Isomorphisms are both sections and retractions *) Global Instance issect_isisomorphism `(@IsIsomorphism C x y m) : IsSectionOf m m^-1 | 1000 := left_inverse. Global Instance isretr_isisomorphism `(@IsIsomorphism C x y m) : IsSectionOf m^-1 m | 1000 := right_inverse. End sect. (** *** Isomorphisms are therefore epimorphisms and monomorphisms *) Section iso. Global Instance isepimorphism_isisomorphism `(@IsIsomorphism C s d m) : IsEpimorphism m | 1000 := _. Global Instance ismonomorphism_isisomorphism `(@IsIsomorphism C s d m) : IsMonomorphism m | 1000 := _. End iso. End EpiMono. #[export] Hint Immediate isisomorphism_inverse : typeclass_instances. #[export] Hint Immediate isepimorphism_identity ismonomorphism_identity ismonomorphism_compose isepimorphism_compose : category morphism. (** ** Lemmas about [idtoiso] *) Section iso_lemmas. Local Ltac idtoiso_t := path_induction; simpl; autorewrite with morphism; reflexivity. (** *** [transport]ing across an equality of morphisms is the same as conjugating with [idtoiso] *) Lemma idtoiso_of_transport (C D : PreCategory) s d (m1 m2 : morphism C s d) (p : m1 = m2) (s' d' : morphism C s d -> D) u : @transport _ (fun m => morphism D (s' m) (d' m)) _ _ p u = idtoiso _ (ap d' p) o u o (idtoiso _ (ap s' p))^-1. Proof. idtoiso_t. Qed. (** *** [idtoiso] respects inverse *) Lemma idtoiso_inv (C : PreCategory) (s d : C) (p : s = d) : (idtoiso _ p)^-1 = idtoiso _ (p^)%path. Proof. path_induction; reflexivity. Defined. (** *** [idtoiso] respects composition *) Lemma idtoiso_comp (C : PreCategory) (s d d' : C) (m1 : d = d') (m2 : s = d) : idtoiso _ m1 o idtoiso _ m2 = idtoiso _ (m2 @ m1)%path. Proof. idtoiso_t. Qed. (** These are useful when tactics are too slow and [rewrite] doesn't work. *) Lemma idtoiso_comp3 (C : PreCategory) (s d d' d'' : C) (m0 : d' = d'') (m1 : d = d') (m2 : s = d) : idtoiso _ m0 o (idtoiso _ m1 o idtoiso _ m2) = idtoiso _ ((m2 @ m1) @ m0)%path. Proof. idtoiso_t. Qed. Lemma idtoiso_comp3' (C : PreCategory) (s d d' d'' : C) (m0 : d' = d'') (m1 : d = d') (m2 : s = d) : (idtoiso _ m0 o idtoiso _ m1) o idtoiso _ m2 = idtoiso _ (m2 @ (m1 @ m0))%path. Proof. idtoiso_t. Qed. Lemma idtoiso_comp4 (C : PreCategory) (s d d' d'' d''' : C) (m0 : d'' = d''') (m1 : d' = d'') (m2 : d = d') (m3 : s = d) : idtoiso _ m0 o (idtoiso _ m1 o (idtoiso _ m2 o idtoiso _ m3)) = idtoiso _ (((m3 @ m2) @ m1) @ m0)%path. Proof. idtoiso_t. Qed. Lemma idtoiso_comp4' (C : PreCategory) (s d d' d'' d''' : C) (m0 : d'' = d''') (m1 : d' = d'') (m2 : d = d') (m3 : s = d) : ((idtoiso _ m0 o idtoiso _ m1) o idtoiso _ m2) o idtoiso _ m3 = idtoiso _ (m3 @ (m2 @ (m1 @ m0)))%path. Proof. idtoiso_t. Qed. Lemma idtoiso_comp5 (C : PreCategory) (s d d' d'' d''' d'''' : C) (m0 : d''' = d'''') (m1 : d'' = d''') (m2 : d' = d'') (m3 : d = d') (m4 : s = d) : idtoiso _ m0 o (idtoiso _ m1 o (idtoiso _ m2 o (idtoiso _ m3 o idtoiso _ m4))) = idtoiso _ ((((m4 @ m3) @ m2) @ m1) @ m0)%path. Proof. idtoiso_t. Qed. Lemma idtoiso_comp5' (C : PreCategory) (s d d' d'' d''' d'''' : C) (m0 : d''' = d'''') (m1 : d'' = d''') (m2 : d' = d'') (m3 : d = d') (m4 : s = d) : (((idtoiso _ m0 o idtoiso _ m1) o idtoiso _ m2) o idtoiso _ m3) o idtoiso _ m4 = idtoiso _ (m4 @ (m3 @ (m2 @ (m1 @ m0))))%path. Proof. idtoiso_t. Qed. (** *** [idtoiso] respects application of functors on morphisms and objects *) Lemma idtoiso_functor (C D : PreCategory) (s d : C) (m : s = d) (F : Functor C D) : F _1 (idtoiso _ m) = idtoiso _ (ap (object_of F) m). Proof. path_induction; simpl; apply identity_of. Defined. (** *** Functors preserve isomorphisms *) Global Instance iso_functor C D (F : Functor C D) `(@IsIsomorphism C s d m) : IsIsomorphism (F _1 m). Proof. refine ({| morphism_inverse := F _1 m^-1 |}). - abstract (rewrite <- composition_of, ?left_inverse, ?right_inverse, identity_of; reflexivity). - abstract (rewrite <- composition_of, ?left_inverse, ?right_inverse, identity_of; reflexivity). Defined. End iso_lemmas. #[export] Hint Extern 1 (@IsIsomorphism _ _ _ (@morphism_of ?C ?D ?F ?s ?d ?m)) => apply (@iso_functor C D F s d m) : typeclass_instances. #[export] Hint Rewrite idtoiso_of_transport idtoiso_inv idtoiso_comp idtoiso_functor. (** ** Lemmas about how to move isomorphisms around equalities, following [HoTT.PathGroupoids] *) Section iso_concat_lemmas. Variable C : PreCategory. Local Ltac iso_concat_t' := intros; repeat match goal with | [ H : ?x = ?y |- _ ] => atomic y; induction H | [ H : ?x = ?y |- _ ] => atomic x; symmetry in H; induction H end; repeat first [ done | rewrite -> ?associativity; progress rewrite ?left_identity, ?right_identity, ?left_inverse, ?right_inverse | rewrite <- ?associativity; progress rewrite ?left_identity, ?right_identity, ?left_inverse, ?right_inverse | rewrite -> ?associativity; progress f_ap; [] | rewrite <- ?associativity; progress f_ap; [] ]. Local Ltac iso_concat_t_id_fin := match goal with | [ |- context[@identity ?C ?x] ] => generalize dependent (identity x) end; iso_concat_t'. Local Ltac iso_concat_t_id lem := first [ solve [ etransitivity; [ | eapply lem ]; iso_concat_t_id_fin ] | solve [ etransitivity; [ symmetry; eapply lem | ]; iso_concat_t_id_fin ] ]. Local Ltac iso_concat_t := iso_concat_t'; try first [ solve [ iso_concat_t_id @left_identity ] | solve [ iso_concat_t_id @right_identity ] ]. Definition iso_compose_pV `(@IsIsomorphism C x y p) : p o p^-1 = identity _ := right_inverse. Definition iso_compose_Vp `(@IsIsomorphism C x y p) : p^-1 o p = identity _ := left_inverse. Definition iso_compose_V_pp `(@IsIsomorphism C y z p) `(q : morphism C x y) : p^-1 o (p o q) = q. Proof. iso_concat_t. Qed. Definition iso_compose_p_Vp `(@IsIsomorphism C x z p) `(q : morphism C y z) : p o (p^-1 o q) = q. Proof. iso_concat_t. Qed. Definition iso_compose_pp_V `(p : morphism C y z) `(@IsIsomorphism C x y q) : (p o q) o q^-1 = p. Proof. iso_concat_t. Qed. Definition iso_compose_pV_p `(p : morphism C x z) `(@IsIsomorphism C x y q) : (p o q^-1) o q = p. Proof. iso_concat_t. Qed. Definition iso_inv_pp `(@IsIsomorphism C y z p) `(@IsIsomorphism C x y q) : (p o q)^-1 = q^-1 o p^-1. Proof. iso_concat_t. Qed. Definition iso_inv_Vp `(@IsIsomorphism C y z p) `(@IsIsomorphism C x z q) : (p^-1 o q)^-1 = q^-1 o p. Proof. iso_concat_t. Qed. Definition iso_inv_pV `(@IsIsomorphism C x y p) `(@IsIsomorphism C x z q) : (p o q^-1)^-1 = q o p^-1. Proof. iso_concat_t. Qed. Definition iso_inv_VV `(@IsIsomorphism C x y p) `(@IsIsomorphism C y z q) : (p^-1 o q^-1)^-1 = q o p. Proof. iso_concat_t. Qed. Definition iso_moveR_Mp `(p : morphism C x y) `(q : morphism C x z) `(@IsIsomorphism C y z r) : p = (r^-1 o q) -> (r o p) = q. Proof. iso_concat_t. Qed. Definition iso_moveR_pM `(@IsIsomorphism C x y p) `(q : morphism C x z) `(r : morphism C y z) : r = (q o p^-1) -> (r o p) = q. Proof. iso_concat_t. Qed. Definition iso_moveR_Vp `(p : morphism C x y) `(q : morphism C x z) `(@IsIsomorphism C z y r) : p = (r o q) -> (r^-1 o p) = q. Proof. iso_concat_t. Qed. Definition iso_moveR_pV `(@IsIsomorphism C x y p) `(q : morphism C y z) `(r : morphism C x z) : r = (q o p) -> (r o p^-1) = q. Proof. iso_concat_t. Qed. Definition iso_moveL_Mp `(p : morphism C x y) `(q : morphism C x z) `(@IsIsomorphism C y z r) : (r^-1 o q) = p -> q = (r o p). Proof. iso_concat_t. Qed. Definition iso_moveL_pM `(@IsIsomorphism C x y p) `(q : morphism C x z) `(r : morphism C y z) : (q o p^-1) = r -> q = (r o p). Proof. iso_concat_t. Qed. Definition iso_moveL_Vp `(p : morphism C x y) `(q : morphism C x z) `(@IsIsomorphism C _ _ r) : (r o q) = p -> q = (r^-1 o p). Proof. iso_concat_t. Qed. Definition iso_moveL_pV `(@IsIsomorphism C x y p) `(q : morphism C y z) r : (q o p) = r -> q = (r o p^-1). Proof. iso_concat_t. Qed. Definition iso_moveL_1M `(p : morphism C x y) `(@IsIsomorphism C x y q) : p o q^-1 = identity _ -> p = q. Proof. iso_concat_t. Qed. Definition iso_moveL_M1 `(p : morphism C x y) `(@IsIsomorphism C x y q) : q^-1 o p = identity _ -> p = q. Proof. iso_concat_t. Qed. Definition iso_moveL_1V `(p : morphism C x y) `(@IsIsomorphism C y x q) : p o q = identity _ -> p = q^-1. Proof. iso_concat_t. Qed. Definition iso_moveL_V1 `(p : morphism C x y) `(@IsIsomorphism C y x q) : q o p = identity _ -> p = q^-1. Proof. iso_concat_t. Qed. Definition iso_moveR_M1 `(@IsIsomorphism C x y p) q : identity _ = p^-1 o q -> p = q. Proof. iso_concat_t. Qed. Definition iso_moveR_1M `(@IsIsomorphism C x y p) q : identity _ = q o p^-1 -> p = q. Proof. iso_concat_t. Qed. Definition iso_moveR_1V `(@IsIsomorphism C x y p) q : identity _ = q o p -> p^-1 = q. Proof. iso_concat_t. Qed. Definition iso_moveR_V1 `(@IsIsomorphism C x y p) q : identity _ = p o q -> p^-1 = q. Proof. iso_concat_t. Qed. End iso_concat_lemmas. (** ** Tactics for moving inverses around *) Ltac iso_move_inverse' := match goal with | [ |- _^-1 o _ = _ ] => apply iso_moveR_Vp | [ |- _ = _^-1 o _ ] => apply iso_moveL_Vp | [ |- _ o _^-1 = _ ] => apply iso_moveR_pV | [ |- _ = _ o _^-1 ] => apply iso_moveL_pV | [ |- _ o (_ o _^-1) = _ ] => rewrite <- associativity | [ |- _ = _ o (_ o _^-1) ] => rewrite <- associativity | [ |- (_^-1 o _) o _ = _ ] => rewrite -> associativity | [ |- _ = (_^-1 o _) o _ ] => rewrite -> associativity end. Ltac iso_move_inverse := progress repeat iso_move_inverse'. (** ** Tactics for collapsing [p ∘ p⁻¹] and [p⁻¹ ∘ p] *) (** Now the tactics for collapsing [p ∘ p⁻¹] (and [p⁻¹ ∘ p]) in the middle of a chain of compositions of isomorphisms. *) Ltac iso_collapse_inverse_left' := first [ apply ap | progress rewrite ?iso_compose_p_Vp, ?iso_compose_V_pp ]. Ltac iso_collapse_inverse_left := rewrite -> ?Category.Core.associativity; progress repeat iso_collapse_inverse_left'. Ltac iso_collapse_inverse_right' := first [ apply ap10; apply ap | progress rewrite ?iso_compose_pV_p, ?iso_compose_pp_V ]. Ltac iso_collapse_inverse_right := rewrite <- ?Category.Core.associativity; progress repeat iso_collapse_inverse_right'. Ltac iso_collapse_inverse := progress repeat first [ iso_collapse_inverse_left | iso_collapse_inverse_right ]. Section associativity_composition. Variable C : PreCategory. Variables x0 x1 x2 x3 x4 : C. (** This lemma is helpful for backwards reasoning. *) Lemma compose4associativity_helper (a : morphism C x3 x4) (b : morphism C x2 x3) (c : morphism C x1 x2) (d : morphism C x0 x1) : a o b o c o d = (a o ((b o c) o d)). Proof. rewrite !associativity; reflexivity. Qed. End associativity_composition. Module Export CategoryMorphismsNotations. Notation "m ^-1" := (morphism_inverse m) : morphism_scope. Infix "<~=~>" := Isomorphic : category_scope. Notation "x ->> y" := (Epimorphism x y). Notation "x (-> y" := (Monomorphism x y). End CategoryMorphismsNotations. Coq-HoTT-9.0/theories/Categories/Category/Notations.v000066400000000000000000000010101474641544500225570ustar00rootroot00000000000000(** * Notations for categories *) Require Category.Core. Require Category.Dual. Require Category.Morphisms. Require Category.Pi. Require Category.Prod. Require Category.Sum. Require Category.Sigma. Include Category.Core.CategoryCoreNotations. Include Category.Dual.CategoryDualNotations. Include Category.Morphisms.CategoryMorphismsNotations. Include Category.Pi.CategoryPiNotations. Include Category.Prod.CategoryProdNotations. Include Category.Sum.CategorySumNotations. Include Category.Sigma.CategorySigmaNotations. Coq-HoTT-9.0/theories/Categories/Category/Objects.v000066400000000000000000000040721474641544500222050ustar00rootroot00000000000000(** * Universal objects *) Require Import Category.Core Category.Morphisms. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope morphism_scope. (** ** Definition of "unique up to unique isomorphism" *) Definition unique_up_to_unique_isomorphism (C : PreCategory) (P : C -> Type) := forall x (_ : P x) x' (_ : P x'), { c : Contr (morphism C x x') | IsIsomorphism (center (morphism C x x')) }. (** ** Terminal objects *) (** A terminal object is an object with a unique morphism from every other object. *) Notation IsTerminalObject C x := (forall x' : object C, Contr (morphism C x' x)). Record TerminalObject (C : PreCategory) := { object_terminal :> C; isterminal_object_terminal :> IsTerminalObject C object_terminal }. Global Existing Instance isterminal_object_terminal. (** ** Initial objects *) (** An initial object is an object with a unique morphism from every other object. *) Notation IsInitialObject C x := (forall x' : object C, Contr (morphism C x x')). Record InitialObject (C : PreCategory) := { object_initial :> C; isinitial_object_initial :> IsInitialObject C object_initial }. Global Existing Instance isinitial_object_initial. Arguments unique_up_to_unique_isomorphism [C] P. (** ** Initial and terminal objects are unique up to unique isomorphism *) Section CategoryObjectsTheorems. Variable C : PreCategory. Local Ltac unique := repeat first [ intro | exists _ | exists (center (morphism C _ _)) | etransitivity; [ symmetry | ]; apply contr ]. (** The terminal object is unique up to unique isomorphism. *) Theorem terminal_object_unique : unique_up_to_unique_isomorphism (fun x => IsTerminalObject C x). Proof. unique. Qed. (** The initial object is unique up to unique isomorphism. *) Theorem initial_object_unique : unique_up_to_unique_isomorphism (fun x => IsInitialObject C x). Proof. unique. Qed. End CategoryObjectsTheorems. Coq-HoTT-9.0/theories/Categories/Category/Paths.v000066400000000000000000000250341474641544500216740ustar00rootroot00000000000000(** * Classification of path spaces of precategories *) Require Import Category.Core. Require Import HoTT.Basics.Equivalences HoTT.Basics.PathGroupoids HoTT.Basics.Trunc HoTT.Basics.Tactics. Require Import HoTT.Types.Sigma HoTT.Types.Arrow HoTT.Types.Forall. Require Import HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. Section path_category. Local Open Scope path_scope. (** We add a prime ([']) as an arbitrary convention to denote that we are talking about equality of functions (less convenient for use) rather than pointwise equality of functions (more convenient for use, but more annoying for proofs). We add two primes to denote the even less convenient version, which requires an identity equality proof. *) Local Notation path_precategory''_T C D := { Hobj : object C = object D | { Hmor : transport (fun obj => obj -> obj -> Type) Hobj (morphism C) = morphism D | transport _ Hmor (transportD (fun obj => obj -> obj -> Type) (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d') Hobj (morphism C) (@compose C)) = @compose D /\ transport _ Hmor (transportD (fun obj => obj -> obj -> Type) (fun obj mor => forall x, mor x x) Hobj (morphism C) (@identity C)) = @identity D }}. Local Notation path_precategory'_T C D := { Hobj : object C = object D | { Hmor : transport (fun obj => obj -> obj -> Type) Hobj (morphism C) = morphism D | transport _ Hmor (transportD (fun obj => obj -> obj -> Type) (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d') Hobj (morphism C) (@compose C)) = @compose D }}. (** ** Classify sufficient conditions to prove precategories equal *) Lemma path_precategory_uncurried__identity_helper `{Funext} (C D : PreCategory) (Heq : path_precategory'_T C D) : transport _ Heq.2.1 (transportD (fun obj => obj -> obj -> Type) (fun obj mor => forall x, mor x x) Heq.1 (morphism C) (@identity C)) = @identity D. Proof. destruct Heq as [? [? ?]]; cbn in *. repeat (intro || apply path_forall). apply identity_unique; cbn in *; auto with morphism. destruct C, D; cbn in *. path_induction; cbn in *. auto. Qed. Definition path_precategory''_T__of__path_precategory'_T `{Funext} C D : path_precategory'_T C D -> path_precategory''_T C D := fun H => (H.1; (H.2.1; (H.2.2, path_precategory_uncurried__identity_helper C D H))). Lemma eta2_sigma_helper A B P Q `{forall a b, IsHProp (Q a b)} (x : { a : A & { b : B a & P a b /\ Q a b }}) q' : (x.1; (x.2.1; (fst x.2.2, q'))) = x. Proof. destruct x as [? [? [? ?]]]; cbn in *. repeat f_ap; apply path_ishprop. Defined. Global Instance isequiv__path_precategory''_T__of__path_precategory'_T `{fs : Funext} C D : IsEquiv (@path_precategory''_T__of__path_precategory'_T fs C D) := isequiv_adjointify (@path_precategory''_T__of__path_precategory'_T fs C D) (fun H => (H.1; (H.2.1; fst H.2.2))) (fun x => eta2_sigma_helper _ _ _ x _) eta2_sigma. Definition path_precategory_uncurried' `{fs : Funext} (C D : PreCategory) : path_precategory''_T C D -> C = D. Proof. intros [? [? [? ?]]]. destruct C, D; cbn in *. path_induction; cbn in *. f_ap; eapply @center; abstract exact _. Defined. (** *** Said proof respects [object] *) Lemma path_precategory_uncurried'_fst `{Funext} C D HO HM HC HI : ap object (@path_precategory_uncurried' _ C D (HO; (HM; (HC, HI)))) = HO. Proof. destruct C, D; cbn in *. path_induction_hammer. Qed. (** *** Said proof respects [idpath] *) Lemma path_precategory_uncurried'_idpath `{Funext} C : @path_precategory_uncurried' _ C C (idpath; (idpath; (idpath, idpath))) = idpath. Proof. destruct C; cbn in *. rewrite !(contr idpath). reflexivity. Qed. (** ** Equality of precategorys gives rise to an inhabitant of the path-classifying-type *) Definition path_precategory_uncurried'_inv (C D : PreCategory) : C = D -> path_precategory''_T C D. Proof. intro H'. exists (ap object H'). exists ((transport_compose _ object _ _) ^ @ apD (@morphism) H'). split. - refine (_ @ apD (@compose) H'); cbn. refine (transport_pp _ _ _ _ @ _). refine ((ap _ (transportD_compose (fun obj => obj -> obj -> Type) (fun obj mor => forall s d d' : obj, mor d d' -> mor s d -> mor s d') object H' (morphism C) (@compose C))^) @ (transport_apD_transportD _ morphism (fun x mor => forall s d d' : x, mor d d' -> mor s d -> mor s d') H' (@compose C))). - refine (_ @ apD (@identity) H'); cbn. refine (transport_pp _ _ _ _ @ _). refine ((ap _ (transportD_compose (fun obj => obj -> obj -> Type) (fun obj mor => forall x : obj, mor x x) object H' (morphism C) (@identity C))^) @ (transport_apD_transportD _ morphism (fun x mor => forall s : x, mor s s) H' (@identity C))). Defined. (** ** Classify equality of precategorys up to equivalence *) Lemma equiv_path_precategory_uncurried'__eissect `{Funext} (C D : PreCategory) : forall x : path_precategory''_T C D, path_precategory_uncurried'_inv (path_precategory_uncurried' C D x) = x. Proof. destruct C, D; cbn in *. intros [H0' [H1' [H2' H3']]]. path_induction. cbn. repeat (edestruct (center (_ = _)); try reflexivity). Qed. Lemma equiv_path_precategory_uncurried' `{Funext} (C D : PreCategory) : path_precategory''_T C D <~> C = D. Proof. apply (equiv_adjointify (@path_precategory_uncurried' _ C D) (@path_precategory_uncurried'_inv C D)). - hnf. intros []. apply path_precategory_uncurried'_idpath. - hnf. apply equiv_path_precategory_uncurried'__eissect. Defined. Definition equiv_path_precategory_uncurried `{Funext} (C D : PreCategory) : path_precategory'_T C D <~> C = D := ((equiv_path_precategory_uncurried' C D) oE (Build_Equiv _ _ _ (isequiv__path_precategory''_T__of__path_precategory'_T C D))). Definition path_precategory_uncurried `{Funext} C D : _ -> _ := equiv_path_precategory_uncurried C D. (** ** Curried version of path classifying lemma *) Lemma path_precategory' `{fs : Funext} (C D : PreCategory) : forall (Hobj : object C = object D) (Hmor : transport (fun obj => obj -> obj -> Type) Hobj (morphism C) = morphism D), transport _ Hmor (transportD (fun obj => obj -> obj -> Type) (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d') Hobj (morphism C) (@compose C)) = @compose D -> C = D. Proof. intros. apply path_precategory_uncurried. repeat esplit; eassumption. Defined. (** ** Curried version of path classifying lemma, using [forall] in place of equality of functions *) Lemma path_precategory `{fs : Funext} (C D : PreCategory) : forall (Hobj : object C = object D) (Hmor : forall s d, morphism C (transport idmap Hobj^ s) (transport idmap Hobj^ d) = morphism D s d), (forall s d d' m m', transport idmap (Hmor _ _) (@compose C _ _ _ (transport idmap (Hmor _ _)^ m) (transport idmap (Hmor _ _)^ m')) = @compose D s d d' m m') -> C = D. Proof. intros Hobj Hmor Hcomp. pose (path_forall _ _ (fun s => path_forall _ _ (fun d => (ap10 (@transport_arrow Type idmap (fun x => x -> Type) _ _ Hobj (@morphism C) _) _) @ (@transport_arrow Type idmap _ _ _ Hobj (@morphism C _) _) @ (transport_const _ _) @ Hmor s d))) as Hmor'. eapply (path_precategory' C D Hobj Hmor'). repeat (apply path_forall; intro). refine (_ @ Hcomp _ _ _ _ _); clear Hcomp. subst Hmor'. cbn. abstract ( destruct C, D; cbn in *; destruct Hobj; cbn in *; repeat match goal with | _ => reflexivity | _ => rewrite !concat_1p | _ => rewrite !transport_forall_constant, !transport_arrow | _ => progress transport_path_forall_hammer | [ |- transport ?P ?p^ ?u = ?v ] => (apply (@moveR_transport_V _ P _ _ p u v); progress transport_path_forall_hammer) | [ |- ?u = transport ?P ?p^ ?v ] => (apply (@moveL_transport_V _ P _ _ p u v); progress transport_path_forall_hammer) | [ |- context[?H ?x ?y] ] => (destruct (H x y); clear H) | _ => progress f_ap end ). Defined. End path_category. (** ** Tactic for proving equality of precategories *) (** We move the funext inference outside the loop. *) Ltac path_category := idtac; let lem := constr:(@path_precategory _) in repeat match goal with | _ => intro | _ => reflexivity | _ => simple refine (lem _ _ _ _ _); cbn end. Coq-HoTT-9.0/theories/Categories/Category/Pi.v000066400000000000000000000030451474641544500211630ustar00rootroot00000000000000(** * Dependent Product Category *) Require Import Category.Strict. Require Import Basics.Trunc. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope morphism_scope. (** ** Definition of [∀], or [∏], for categories *) Section pi. Context `{Funext}. Variable A : Type. Variable P : A -> PreCategory. Definition pi : PreCategory. refine (@Build_PreCategory (forall a : A, P a) (fun s d => forall a : A, morphism (P a) (s a) (d a)) (fun x => fun a => identity (x a)) (fun s d d' m2 m1 => fun a => m2 a o m1 a) _ _ _ _); abstract ( repeat (intro || apply path_forall); auto with morphism ). Defined. End pi. Local Notation "'forall' x .. y , P" := (forall x, .. (forall y, P) ..) : type_scope. Local Notation "'forall' x .. y , P" := (pi (fun x => .. (pi (fun y => P)) .. )) : category_scope. (** ** The product of strict categories is strict *) Global Instance isstrict_category_pi `{Funext} `{forall a : A, IsStrictCategory (P a)} : IsStrictCategory (forall a, P a). Proof. typeclasses eauto. Qed. Local Set Warnings Append "-notation-overridden". Module Export CategoryPiNotations. Notation "'forall' x .. y , P" := (forall x, .. (forall y, P) ..)%type : type_scope. Notation "'forall' x .. y , P" := (pi (fun x => .. (pi (fun y => P)) .. )) : category_scope. End CategoryPiNotations. Coq-HoTT-9.0/theories/Categories/Category/Prod.v000066400000000000000000000023451474641544500215210ustar00rootroot00000000000000(** * Product Category *) Require Import Basics.Tactics. Require Import Category.Strict. Require Import Types.Prod. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope morphism_scope. (** ** Definition of [*] for categories *) Section prod. Variables C D : PreCategory. Definition prod : PreCategory. refine (@Build_PreCategory (C * D) (fun s d => morphism C (fst s) (fst d) * morphism D (snd s) (snd d)) (fun x => (identity (fst x), identity (snd x))) (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) _ _ _ _); abstract ( repeat (simpl || intros [] || intro); try f_ap; auto with morphism ). Defined. End prod. Local Infix "*" := prod : category_scope. (** ** The product of strict categories is strict *) Global Instance isstrict_category_product `{IsStrictCategory C, IsStrictCategory D} : IsStrictCategory (C * D). Proof. typeclasses eauto. Qed. Module Export CategoryProdNotations. Infix "*" := prod : category_scope. End CategoryProdNotations. Coq-HoTT-9.0/theories/Categories/Category/Sigma.v000066400000000000000000000010131474641544500216440ustar00rootroot00000000000000(** * ∑-precategories *) (** These are a generalization of subcategories in the direction of the Grothendieck construction *) Require Category.Sigma.Core. Require Category.Sigma.OnMorphisms. Require Category.Sigma.OnObjects. Require Category.Sigma.Univalent. Include Category.Sigma.Core. Include Category.Sigma.OnMorphisms. Include Category.Sigma.OnObjects. Include Category.Sigma.Univalent. Module CategorySigmaNotations. Include Category.Sigma.OnObjects.CategorySigmaOnObjectsNotations. End CategorySigmaNotations. Coq-HoTT-9.0/theories/Categories/Category/Sigma/000077500000000000000000000000001474641544500214625ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Category/Sigma/Core.v000066400000000000000000000103311474641544500225370ustar00rootroot00000000000000(** * ∑-categories - exploded Grothendieck constructions, or generalizations of subcategories *) Require Import Category.Core Functor.Core. Require Import Basics.Trunc Types.Sigma. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Notation sig_type := sig. (** We can generalize the notion of [sig] to categories. This is, essentially, a type-theoretic perspecitive on the Grothendieck construction. *) Section sig_obj_mor. Variable A : PreCategory. Variable Pobj : A -> Type. Local Notation obj := (sig Pobj). Variable Pmor : forall s d : obj, morphism A s.1 d.1 -> Type. Local Notation mor s d := (sig (Pmor s d)). Context `(HPmor : forall s d, IsHSet (mor s d)). Variable Pidentity : forall x, @Pmor x x (@identity A _). Variable Pcompose : forall s d d' m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (m1 o m2). Local Notation identity x := (@identity A x.1; @Pidentity x). Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism. Hypothesis P_associativity : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4), compose (compose m3 m2) m1 = compose m3 (compose m2 m1). Hypothesis P_left_identity : forall a b (f : mor a b), compose (identity b) f = f. Hypothesis P_right_identity : forall a b (f : mor a b), compose f (identity a) = f. (** ** Definition of a [sig]-precategory *) Definition sig' : PreCategory. Proof. refine (@Build_PreCategory obj (fun s d => mor s d) (fun x => identity x) (fun s d d' m1 m2 => compose m1 m2) _ _ _ _); assumption. Defined. (** ** First projection functor *) Definition pr1' : Functor sig' A := Build_Functor sig' A (@pr1 _ _) (fun _ _ => @pr1 _ _) (fun _ _ _ _ _ => idpath) (fun _ => idpath). End sig_obj_mor. Arguments pr1' {A Pobj Pmor HPmor Pidentity Pcompose P_associativity P_left_identity P_right_identity}. (** ** Variant of [sig']-precategory when we are taking a subset of morphisms *) Section sig_obj_mor_hProp. Variable A : PreCategory. Variable Pobj : A -> Type. Local Notation obj := (sig_type Pobj). Variable Pmor : forall s d : obj, morphism A s.1 d.1 -> Type. Local Notation mor s d := (sig_type (Pmor s d)). Context `(HPmor : forall s d m, IsHProp (Pmor s d m)). Variable Pidentity : forall x, @Pmor x x (@identity A _). Variable Pcompose : forall s d d' m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (m1 o m2). Local Notation identity x := (@identity A x.1; @Pidentity x). Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism. Local Ltac t ex_tac := intros; simpl; apply path_sigma_uncurried; simpl; ex_tac; apply path_ishprop. Let P_associativity : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4), compose (compose m3 m2) m1 = compose m3 (compose m2 m1). Proof. abstract t ltac:(exists (associativity _ _ _ _ _ _ _ _)) using P_associativity_core_subproof. Defined. Let P_left_identity : forall a b (f : mor a b), compose (identity b) f = f. Proof. clear P_associativity. abstract t ltac:(exists (left_identity _ _ _ _)) using P_left_identity_core_subproof. Defined. Let P_right_identity : forall a b (f : mor a b), compose f (identity a) = f. Proof. clear P_associativity P_left_identity. abstract t ltac:(exists (right_identity _ _ _ _)) using P_right_identity_core_subproof. Defined. (** *** Definition of [sig]-precategory *) Definition sig : PreCategory := Eval cbv delta [P_associativity P_left_identity P_right_identity] in @sig' A Pobj Pmor _ Pidentity Pcompose P_associativity P_left_identity P_right_identity. (** *** First projection functor *) Definition proj1_sig : Functor sig A := pr1'. End sig_obj_mor_hProp. Arguments proj1_sig {A Pobj Pmor HPmor Pidentity Pcompose}. Notation subcategory := sig. Coq-HoTT-9.0/theories/Categories/Category/Sigma/OnMorphisms.v000066400000000000000000000132101474641544500241240ustar00rootroot00000000000000(** * ∑-categories on morphisms - a category with the same objects, but a ∑ type for morphisms *) Require Import HoTT.Tactics Types.Forall Types.Sigma Basics.Trunc. Require Import Category.Core Functor.Core Category.Sigma.Core. Require Functor.Composition.Core Functor.Identity. Require Import Functor.Paths. Import Functor.Identity.FunctorIdentityNotations. Import Functor.Composition.Core.FunctorCompositionCoreNotations. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Notation sig_type := Overture.sig. Local Notation pr1_type := Overture.pr1. Local Open Scope morphism_scope. Local Open Scope functor_scope. Section sig_mor. Variable A : PreCategory. Variable Pmor : forall s d, morphism A s d -> Type. Local Notation mor s d := (sig_type (Pmor s d)). Context `(HPmor : forall s d, IsHSet (mor s d)). Variable Pidentity : forall x, @Pmor x x (@identity A _). Variable Pcompose : forall s d d' m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (m1 o m2). Local Notation identity x := (@identity A x; @Pidentity x). Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism. Hypothesis P_associativity : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4), compose (compose m3 m2) m1 = compose m3 (compose m2 m1). Hypothesis P_left_identity : forall a b (f : mor a b), compose (identity b) f = f. Hypothesis P_right_identity : forall a b (f : mor a b), compose f (identity a) = f. (** ** Definition of [sig_mor]-precategory *) Definition sig_mor' : PreCategory. Proof. refine (@Build_PreCategory (object A) (fun s d => mor s d) (fun x => identity x) (fun s d d' m1 m2 => compose m1 m2) _ _ _ _); assumption. Defined. (** ** First projection functor *) Definition pr1_mor : Functor sig_mor' A := Build_Functor sig_mor' A idmap (fun _ _ => @pr1_type _ _) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition sig_mor_as_sig : PreCategory. Proof. refine (@sig' A (fun _ => Unit) (fun s d => @Pmor (pr1_type s) (pr1_type d)) _ (fun _ => Pidentity _) (fun _ _ _ _ _ m1 m2 => Pcompose m1 m2) _ _ _); intros; trivial. Defined. Definition sig_functor_mor : Functor sig_mor_as_sig sig_mor' := Build_Functor sig_mor_as_sig sig_mor' (@pr1_type _ _) (fun _ _ => idmap) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition sig_functor_mor_inv : Functor sig_mor' sig_mor_as_sig := Build_Functor sig_mor' sig_mor_as_sig (fun x => exist _ x tt) (fun _ _ => idmap) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Local Open Scope functor_scope. Lemma sig_mor_eq `{Funext} : sig_functor_mor o sig_functor_mor_inv = 1 /\ sig_functor_mor_inv o sig_functor_mor = 1. Proof. split; path_functor; simpl; trivial. refine (exist _ (path_forall _ _ (fun x => match x as x return (x.1; tt) = x with | (_; tt) => idpath end)) _). repeat (apply path_forall; intro). destruct_head @sig_type. destruct_head Unit. rewrite !transport_forall_constant. transport_path_forall_hammer. reflexivity. Qed. Definition sig_mor_compat : pr1_mor o sig_functor_mor = pr1' := idpath. End sig_mor. Arguments pr1_mor {A Pmor _ Pidentity Pcompose P_associativity P_left_identity P_right_identity}. Section sig_mor_hProp. Variable A : PreCategory. Variable Pmor : forall s d, morphism A s d -> Type. Local Notation mor s d := (sig_type (Pmor s d)). Context `(HPmor : forall s d m, IsHProp (Pmor s d m)). Variable Pidentity : forall x, @Pmor x x (@identity A _). Variable Pcompose : forall s d d' m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (m1 o m2). Local Notation identity x := (@identity A x; @Pidentity x). Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism. Local Ltac t ex_tac := intros; simpl; apply path_sigma_uncurried; simpl; ex_tac; apply path_ishprop. Let P_associativity : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4), compose (compose m3 m2) m1 = compose m3 (compose m2 m1). Proof. abstract t ltac:(exists (associativity _ _ _ _ _ _ _ _)) using P_associativity_on_morphisms_subproof. Defined. Let P_left_identity : forall a b (f : mor a b), compose (identity b) f = f. Proof. clear P_associativity. abstract t ltac:(exists (left_identity _ _ _ _)) using P_left_identity_on_morphisms_subproof. Defined. Let P_right_identity : forall a b (f : mor a b), compose f (identity a) = f. Proof. clear P_associativity P_left_identity. abstract t ltac:(exists (right_identity _ _ _ _)) using P_right_identity_on_morphisms_subproof. Defined. (** ** Definition of [sig_mor]-precategory *) Definition sig_mor : PreCategory := Eval cbv delta [P_associativity P_left_identity P_right_identity] in @sig_mor' A Pmor _ Pidentity Pcompose P_associativity P_left_identity P_right_identity. (** ** First projection functor *) Definition proj1_sig_mor : Functor sig_mor A := pr1_mor. End sig_mor_hProp. Arguments proj1_sig_mor {A Pmor HPmor Pidentity Pcompose}. Coq-HoTT-9.0/theories/Categories/Category/Sigma/OnObjects.v000066400000000000000000000051451474641544500235440ustar00rootroot00000000000000(** * ∑-categories on objects - a generalization of subcategories *) Require Import HoTT.Basics HoTT.Types. Require Import Category.Core Functor.Core Category.Sigma.Core. Require Functor.Composition.Core Functor.Identity. Require Import Functor.Paths. Import Functor.Identity.FunctorIdentityNotations. Import Functor.Composition.Core.FunctorCompositionCoreNotations. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Notation sig_type := Overture.sig. Local Notation pr1_type := Overture.pr1. Local Open Scope morphism_scope. Local Open Scope functor_scope. Section sig_obj. Variable A : PreCategory. Variable Pobj : A -> Type. (** ** Definition of [sig_obj]-precategory *) Definition sig_obj : PreCategory := @Build_PreCategory (sig_type Pobj) (fun s d => morphism A (pr1_type s) (pr1_type d)) (fun x => @identity A (pr1_type x)) (fun s d d' m1 m2 => m1 o m2)%morphism (fun _ _ _ _ => associativity A _ _ _ _) (fun _ _ => left_identity A _ _) (fun _ _ => right_identity A _ _) _. (** ** First projection functor *) Definition pr1_obj : Functor sig_obj A := Build_Functor sig_obj A (@pr1_type _ _) (fun s d m => m) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition sig_obj_as_sig : PreCategory := @sig A Pobj (fun _ _ _ => Unit) _ (fun _ => tt) (fun _ _ _ _ _ _ _ => tt). Definition sig_functor_obj : Functor sig_obj_as_sig sig_obj := Build_Functor sig_obj_as_sig sig_obj (fun x => x) (fun _ _ => @pr1_type _ _) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition sig_functor_obj_inv : Functor sig_obj sig_obj_as_sig := Build_Functor sig_obj sig_obj_as_sig (fun x => x) (fun _ _ m => exist _ m tt) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Local Open Scope functor_scope. Lemma sig_obj_eq `{Funext} : sig_functor_obj o sig_functor_obj_inv = 1 /\ sig_functor_obj_inv o sig_functor_obj = 1. Proof. split; path_functor; trivial. apply path_forall; intros []. apply path_forall; intros []. apply path_forall; intros [? []]. reflexivity. Qed. Definition sig_obj_compat : pr1_obj o sig_functor_obj = pr1' := idpath. End sig_obj. Arguments pr1_obj {A Pobj}. Module Export CategorySigmaOnObjectsNotations. Notation "{ x : A | P }" := (sig_obj A (fun x => P)) : category_scope. End CategorySigmaOnObjectsNotations. Coq-HoTT-9.0/theories/Categories/Category/Sigma/Univalent.v000066400000000000000000000330351474641544500236220ustar00rootroot00000000000000(** * Lifting saturation from categories to sigma/subcategories *) Require Import Category.Core Category.Morphisms. Require Import Category.Univalent. Require Import Category.Sigma.Core Category.Sigma.OnObjects Category.Sigma.OnMorphisms. Require Import HoTT.Types HoTT.Basics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Notation pr1_type := Overture.pr1 (only parsing). Local Open Scope path_scope. Local Open Scope morphism_scope. Local Open Scope function_scope. (** TODO: Following a comment from Mike Shulman (https://github.com/HoTT/HoTT/pull/670##issuecomment-68907833), much of this can probably be subsumed by a general theorem proving that univalence lifts along suitable pseudomonic functors (http://ncatlab.org/nlab/show/pseudomonic+functor). *) (** ** Lift saturation to sigma on objects whenever the property is an hProp *) Section onobjects. Variable A : PreCategory. Variable Pobj : A -> Type. Global Instance iscategory_sig_obj `{forall a, IsHProp (Pobj a), A_cat : IsCategory A} : IsCategory (sig_obj A Pobj). Proof. intros s d. (* This makes typeclass search go faster. *) pose @isequiv_compose. refine (isequiv_homotopic ((issig_full_isomorphic (sig_obj A Pobj) _ _ o (issig_full_isomorphic A _ _)^-1) o (@idtoiso A s.1 d.1) o pr1_path) _). intro x; destruct x. reflexivity. Defined. (** The converse is not true; consider [Pobj := fun _ => Empty]. *) End onobjects. (** ** Lift saturation to sigma on objects whenever the property is automatically and uniquely true of isomorphisms *) Section onmorphisms. Variable A : PreCategory. Variable Pmor : forall s d, morphism A s d -> Type. Local Notation mor s d := { m : _ | Pmor s d m }. Context `(HPmor : forall s d, IsHSet (mor s d)). Variable Pidentity : forall x, @Pmor x x (@identity A _). Variable Pcompose : forall s d d' m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (m1 o m2). Local Notation identity x := (@identity A x; @Pidentity x). Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism. Hypothesis P_associativity : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4), compose (compose m3 m2) m1 = compose m3 (compose m2 m1). Hypothesis P_left_identity : forall a b (f : mor a b), compose (identity b) f = f. Hypothesis P_right_identity : forall a b (f : mor a b), compose f (identity a) = f. Local Notation A' := (@sig_mor' A Pmor HPmor Pidentity Pcompose P_associativity P_left_identity P_right_identity). (** To have any hope of relating [IsCategory A] with [IsCategory A'], we assume that [Pmor] is automatically and uniquely true on isomorphisms. *) Context `{forall s d m, IsIsomorphism m -> Contr (Pmor s d m)}. Definition iscategory_sig_mor_helper {s d} : @Isomorphic A' s d -> @Isomorphic A s d. Proof. refine ((issig_full_isomorphic A _ _) o _ o (issig_full_isomorphic A' _ _)^-1). exact (functor_sigma pr1_type (fun _ => functor_sigma pr1_type (fun _ => functor_sigma pr1_path (fun _ => pr1_path)))). Defined. Local Instance isequiv_iscategory_sig_mor_helper s d : IsEquiv (@iscategory_sig_mor_helper s d). Proof. simple refine (isequiv_adjointify _ _ _ _). { intro e. exists (e : morphism _ _ _; center _). exists (e^-1%morphism; center _); simple refine (path_sigma _ _ _ _ _); first [ apply left_inverse | apply right_inverse | by apply path_ishprop ]. } { intro; by apply path_isomorphic. } { intros x; apply path_isomorphic. exact (path_sigma' _ 1 (contr _)). } Defined. Global Instance iscategory_sig_mor `{A_cat : IsCategory A} : IsCategory A'. Proof. intros s d. (* Use [equiv_compose] rather than "o" to speed up typeclass search. *) refine (isequiv_homotopic (equiv_compose iscategory_sig_mor_helper^-1 (@idtoiso _ _ _)) _). intro x; apply path_isomorphic; cbn. destruct x; refine (path_sigma' _ 1 (contr _)). Defined. Definition iscategory_from_sig_mor `{A'_cat : IsCategory A'} : IsCategory A. Proof. intros s d. refine (isequiv_homotopic (iscategory_sig_mor_helper o (@idtoiso A' _ _)) _). intro x; apply path_isomorphic; cbn. destruct x; reflexivity. Defined. Global Instance isequiv_iscategory_sig_mor `{Funext} : IsEquiv (@iscategory_sig_mor). Proof. refine (isequiv_iff_hprop _ (@iscategory_from_sig_mor)). Defined. End onmorphisms. (** ** Lift saturation to sigma on both objects and morphisms *) Section on_both. Variable A : PreCategory. Variable Pobj : A -> Type. Local Notation obj := { x : _ | Pobj x } (only parsing). Variable Pmor : forall s d : obj, morphism A s.1 d.1 -> Type. Local Notation mor s d := { m : _ | Pmor s d m } (only parsing). Context `(HPmor : forall s d, IsHSet (mor s d)). Variable Pidentity : forall x, @Pmor x x (@identity A _). Variable Pcompose : forall s d d' m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (m1 o m2). Local Notation identity x := (@identity A x.1; @Pidentity x). Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism. Hypothesis P_associativity : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4), compose (compose m3 m2) m1 = compose m3 (compose m2 m1). Hypothesis P_left_identity : forall a b (f : mor a b), compose (identity b) f = f. Hypothesis P_right_identity : forall a b (f : mor a b), compose f (identity a) = f. Local Notation A' := (@sig' A Pobj Pmor HPmor Pidentity Pcompose P_associativity P_left_identity P_right_identity). (** We must assume some relation on the properties; we assume that the path space of the extra data on objects is classified by isomorphisms of the extra data on objects. *) Local Definition Pmor_iso_T s d m m' left right := ({ e : Pmor s d m | { e' : Pmor d s m' | { _ : transport (Pmor _ _) ((left : m' o m = 1)%morphism) (Pcompose e' e) = Pidentity _ | transport (Pmor _ _) ((right : m o m' = 1)%morphism) (Pcompose e e') = Pidentity _ } } }). Global Arguments Pmor_iso_T / . Local Definition Pmor_iso_T' x (xp xp' : Pobj x) := { e : Pmor (x; xp) (x; xp') 1 | { e' : Pmor (x; xp') (x; xp) 1 | { _ : Pcompose e' e = Pcompose (Pidentity _) (Pidentity _) | Pcompose e e' = Pcompose (Pidentity _) (Pidentity _) } } }. Global Arguments Pmor_iso_T' / . Local Definition Pidtoiso x (xp xp' : Pobj x) (H : xp = xp') : Pmor_iso_T' xp xp'. Proof. destruct H. exists (Pidentity _). exists (Pidentity _). split; reflexivity. Defined. Global Arguments Pidtoiso / . (** TODO: generalize this to a theorem [forall A P, IsHSet A -> IsHSet { x : A | P x } -> forall x, IsHSet (P x)], [inO_unsigma] of ##672 *) Local Instance ishset_pmor {s d m} : IsHSet (Pmor s d m). Proof. apply istrunc_S. intros p q. apply hprop_allpath. let H := constr:(_ : forall x y : mor s d, IsHProp (x = y)) in pose proof (@path_ishprop _ (H (m; p) (m; q))) as H'. intros x y. specialize (H' (path_sigma' _ 1 x) (path_sigma' _ 1 y)). unfold path_sigma', path_sigma in H'. apply (ap (path_sigma_uncurried (Pmor s d) (m; p) (m; q)))^-1 in H'. assert (H'' : H'..1 = idpath) by apply path_ishprop. exact (transport (fun H'1 => transport _ H'1 _ = _) H'' H'..2). Defined. Local Definition Pmor_iso_adjust x xp xp' : (Pmor_iso_T (x; xp) (x; xp') 1 1 (left_identity _ _ _ _) (right_identity _ _ _ _)) <~> Pmor_iso_T' xp xp'. Proof. refine (equiv_functor_sigma_id _); intro. refine (equiv_functor_sigma_id _); intro. refine (equiv_functor_sigma' (equiv_iff_hprop _ _) (fun _ => equiv_iff_hprop _ _)); cbn; intro H'; first [ apply moveL_transport_V in H' | apply moveR_transport_p ]; refine (H' @ _); first [ refine (_ @ ((P_left_identity (identity (x; _)))^)..2) | refine ((((P_left_identity (identity (x; _)))^)..2)^ @ _) ]; refine (ap (fun p => transport _ p _) (path_ishprop _ _)). Defined. Global Arguments Pmor_iso_adjust / . Local Definition iso_A'_code {s d} : (@Isomorphic A' s d) -> { e : @Isomorphic A s.1 d.1 | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }. Proof. intro e. simple refine (_; _). { exists (e : morphism _ _ _).1. exists (e^-1%morphism).1. - exact (@left_inverse _ _ _ e e)..1. - exact (@right_inverse _ _ _ e e)..1. } { exists (e : morphism _ _ _).2. exists (e^-1%morphism).2; cbn. exists (((@left_inverse _ _ _ e e))..2). exact (@right_inverse _ _ _ e e)..2. } Defined. Local Definition iso_A'_decode_helper {s d} (e : { e : @Isomorphic A s.1 d.1 | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }) : @IsIsomorphism A' _ _ (e.1:morphism A s.1 d.1; (e.2).1). Proof. eexists. Unshelve. 3:exact (e.1^-1%morphism; e.2.2.1). { refine (path_sigma' _ left_inverse e.2.2.2.1). } { refine (path_sigma' _ right_inverse e.2.2.2.2). } Defined. Local Definition iso_A'_decode {s d} : { e : @Isomorphic A s.1 d.1 | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse } -> (@Isomorphic A' s d). Proof. intro e. eexists. Unshelve. 2:exact (e.1 : morphism _ _ _; e.2.1). apply iso_A'_decode_helper. Defined. Local Definition equiv_iso_A'_eisretr_helper {s d} (x : {e : @Isomorphic A s.1 d.1 | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }) : transport (fun e : @Isomorphic A s.1 d.1 => Pmor_iso_T s d e e^-1 left_inverse right_inverse) (path_isomorphic (iso_A'_code (iso_A'_decode x)).1 x.1 1) (iso_A'_code (iso_A'_decode x)).2 = x.2. Proof. simple refine (path_sigma _ _ _ _ _); cycle 1. (* Speed up typeclass search: *) 1:pose @istrunc_sigma; pose @istrunc_paths; simple refine (path_sigma _ _ _ _ (path_ishprop _ _)). all:repeat match goal with | [ |- (transport ?P ?p ?z).1 = _ ] => rewrite (@ap_transport _ P _ _ _ p (fun _ x => x.1)) | [ |- (transport ?P ?p ?z).2.1 = _ ] => rewrite (@ap_transport _ P _ _ _ p (fun _ x => x.2.1)) | [ |- transport (fun _ => ?x) _ _ = _ ] => rewrite transport_const | [ |- transport (fun x => ?f (@morphism_inverse _ _ _ (@morphism_isomorphic _ _ _ x) _)) _ _ = _ ] => rewrite (@transport_compose _ _ _ _ f (fun x => (@morphism_inverse _ _ _ (@morphism_isomorphic _ _ _ x) (@isisomorphism_isomorphic _ _ _ x)))) | [ |- transport (?f o ?g) _ _ = _ ] => rewrite (@transport_compose _ _ _ _ f g) | [ |- transport (fun x => ?f (?g x)) _ _ = _ ] => rewrite (@transport_compose _ _ _ _ f g) | [ |- context[ap (@morphism_isomorphic ?a ?b ?c) (path_isomorphic ?i ?j ?x)] ] => change (ap (@morphism_isomorphic a b c)) with ((path_isomorphic i j)^-1%function); rewrite (@eissect _ _ (path_isomorphic i j) _ x) | [ |- context[ap (fun e : Isomorphic _ _ => @morphism_inverse ?C ?s ?d _ _) (path_isomorphic ?i ?j ?x)] ] => rewrite (@ap_morphism_inverse_path_isomorphic C s d i j x 1) | [ |- transport ?P 1 ?x = ?y ] => change (x = y) | [ |- (((iso_A'_code (iso_A'_decode ?x)).2).2).1 = ((?x.2).2).1 ] => reflexivity | [ |- (((iso_A'_code (iso_A'_decode ?x)).2).1) = ((?x.2).1) ] => reflexivity end. Qed. Local Definition equiv_iso_A' {s d} : (@Isomorphic A' s d) <~> { e : @Isomorphic A s.1 d.1 | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }. Proof. refine (equiv_adjointify iso_A'_code iso_A'_decode _ _). { intro. simple refine (path_sigma _ _ _ _ _). { apply path_isomorphic; reflexivity. } { apply equiv_iso_A'_eisretr_helper. } } { intro. apply path_isomorphic. reflexivity. } Defined. Context `{Pisotoid : forall x xp xp', IsEquiv (@Pidtoiso x xp xp')}. Local Arguments Pmor_iso_T : simpl never. Global Instance iscategory_sig `{A_cat : IsCategory A} : IsCategory A'. Proof. intros s d. snrefine (isequiv_homotopic ((equiv_iso_A'^-1) o (functor_sigma _ _) o (path_sigma_uncurried _ _ _)^-1) _); [exact _ | | | exact _ | |]. (* [try exact _] leaves the third remaining goal unchanged, but takes ~9s to do so. *) { exact (@idtoiso A _ _). } { destruct s as [s0 s1], d as [d0 d1]; cbn. intro p; destruct p; cbn. refine ((@Pmor_iso_adjust s0 s1 d1)^-1 o _). refine (@Pidtoiso _ _ _). } { (* Do this in small steps to make it fast. *) nrefine isequiv_compose. 1:apply isequiv_inverse. nrefine isequiv_compose. 2:apply isequiv_inverse. nrefine isequiv_functor_sigma. 1:apply A_cat. destruct s, d. simpl Overture.pr1. intro p; destruct p. eapply @isequiv_compose. - exact _. - eapply @isequiv_inverse. } { intro p; apply path_isomorphic; destruct p. reflexivity. } Defined. End on_both. Coq-HoTT-9.0/theories/Categories/Category/Strict.v000066400000000000000000000011031474641544500220540ustar00rootroot00000000000000(** * Definition of a strict category *) Require Export Category.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. (** Quoting the HoTT Book: *) (** Definition. A _strict category_ is a precategory whose type of objects is a set. *) Notation IsStrictCategory C := (IsHSet (object C)). Record StrictCategory := { precategory_strict :> PreCategory; isstrict_StrictCategory :> IsStrictCategory precategory_strict }. Global Existing Instance isstrict_StrictCategory. Coq-HoTT-9.0/theories/Categories/Category/Subcategory.v000066400000000000000000000002361474641544500231010ustar00rootroot00000000000000(** * Subcategories *) (** ** Full *) Require Subcategory.Full. (** ** Wide *) Require Subcategory.Wide. Include Subcategory.Full. Include Subcategory.Wide. Coq-HoTT-9.0/theories/Categories/Category/Subcategory/000077500000000000000000000000001474641544500227115ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Category/Subcategory/Full.v000066400000000000000000000004261474641544500240040ustar00rootroot00000000000000(** * Full Subcategories *) (** We reuse the generalizion given by ∑-precategories; a full subcategory has a sigma type as its objects. *) Require Import Category.Sigma.OnObjects. Notation full := sig_obj. Notation "{ x : A | P }" := (full A (fun x => P)) : category_scope. Coq-HoTT-9.0/theories/Categories/Category/Subcategory/Wide.v000066400000000000000000000004631474641544500237730ustar00rootroot00000000000000(** * Wide subcategories *) (** We reuse ∑-precategories; a wide subcategory has the same objects, and a ∑ type as its morphisms. We make use of the fact that the extra component should be an hProp to not require as many proofs. *) Require Import Category.Sigma.OnMorphisms. Notation wide := sig_mor. Coq-HoTT-9.0/theories/Categories/Category/Sum.v000066400000000000000000000027531474641544500213640ustar00rootroot00000000000000(** * The coproduct of categories *) Require Export Category.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** ** Definition of [+] for categories *) Section internals. Variables C D : PreCategory. Definition sum_morphism (s d : C + D) : Type := match s, d with | inl s, inl d => morphism C s d | inr s, inr d => morphism D s d | _, _ => Empty end. Global Arguments sum_morphism _ _ / . Definition sum_identity (x : C + D) : sum_morphism x x := match x with | inl x => identity x | inr x => identity x end. Global Arguments sum_identity _ / . Definition sum_compose (s d d' : C + D) (m1 : sum_morphism d d') (m2 : sum_morphism s d) : sum_morphism s d'. Proof. case s, d, d'; simpl in *; solve [ case m1 | case m2 | eapply compose; eassumption ]. Defined. Global Arguments sum_compose [_ _ _] _ _ / . End internals. Definition sum (C D : PreCategory) : PreCategory. Proof. refine (@Build_PreCategory (C + D) (sum_morphism C D) (sum_identity C D) (sum_compose C D) _ _ _ _); abstract ( repeat (simpl || apply istrunc_S || intros [] || intro); auto with morphism; typeclasses eauto ). Defined. Module Export CategorySumNotations. Infix "+" := sum : category_scope. End CategorySumNotations. Coq-HoTT-9.0/theories/Categories/Category/Univalent.v000066400000000000000000000017521474641544500225630ustar00rootroot00000000000000(** * Definition of a univalent/saturated precategory, or just "category" *) Require Import Category.Core Category.Morphisms. Require Import HoTT.Basics HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. (** A category is a precategory for which [idtoiso] is an equivalence. *) Notation IsCategory C := (forall s d : object C, IsEquiv (@idtoiso C s d)). Notation isotoid C s d := (@equiv_inv _ _ (@idtoiso C s d) _). (** *** The objects of a category are a 1-type *) Global Instance trunc_category `{IsCategory C} : IsTrunc 1 C | 10000. Proof. apply istrunc_S. intros ? ?. eapply istrunc_equiv_istrunc; [ symmetry; esplit; apply_hyp | ]. typeclasses eauto. Qed. Record Category := { precategory_of_category :> PreCategory; iscategory_precategory_of_category :> IsCategory precategory_of_category }. Global Existing Instance iscategory_precategory_of_category. Coq-HoTT-9.0/theories/Categories/Category/Utf8.v000066400000000000000000000016051474641544500214410ustar00rootroot00000000000000(** * Unicode notations for categories *) Require Import Category.Morphisms Category.Dual Category.Sum Category.Pi. Local Set Warnings Append "-notation-overridden". Require Export Category.Notations. Local Set Warnings Append "notation-overridden". Require Import Basics.Utf8. Infix "∘" := compose : morphism_scope. Notation "m ⁻¹" := (morphism_inverse m) : morphism_scope. Infix "≅" := Isomorphic : category_scope. Notation "x ↠ y" := (Epimorphism x y). Notation "x ↪ y" := (Monomorphism x y). (** It would be nice to put [, format "C 'ᵒᵖ'"] here, but that makes this notation unparseable. *) Notation "C 'ᵒᵖ'" := (opposite C) : category_scope. Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..). Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) : type_scope. Notation "∀ x .. y , P" := (pi (fun x => .. (pi (fun y => P)) .. )) : category_scope. Coq-HoTT-9.0/theories/Categories/CategoryOfGroupoids.v000066400000000000000000000013731474641544500227760ustar00rootroot00000000000000(** * Groupoid, the precategory of strict groupoid categories *) Require Import Functor.Core Category.Strict. Require Import Cat.Core. Require Import GroupoidCategory.Core. Require Import Functor.Paths. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Section groupoid_cat. Context `{Funext}. Let P : PreCategory -> Type := fun C => IsGroupoid C /\ IsStrictCategory C. Let HF : forall C D, P C -> P D -> IsHSet (Functor C D) := fun C D HC HD => @trunc_functor _ C D _ (snd HD) _. (** There is a full precategory of [cat] which is the strict groupoid precategories *) Definition groupoid_cat : PreCategory := @sub_pre_cat _ P HF. End groupoid_cat. Coq-HoTT-9.0/theories/Categories/CategoryOfSections.v000066400000000000000000000001561474641544500226100ustar00rootroot00000000000000(** * Category of sections of a functor *) Require CategoryOfSections.Core. Include CategoryOfSections.Core. Coq-HoTT-9.0/theories/Categories/CategoryOfSections/000077500000000000000000000000001474641544500224175ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/CategoryOfSections/Core.v000066400000000000000000000035501474641544500235010ustar00rootroot00000000000000(** * Category of sections *) Require Import Functor.Core NaturalTransformation.Core. Require Import Category.Strict. Require Import Functor.Identity NaturalTransformation.Identity. Require Import NaturalTransformation.Paths NaturalTransformation.Composition.Core. Require Import Functor.Paths. Require Import HoTT.Basics HoTT.Types. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Section FunctorSectionCategory. Context `{Funext}. Variables C D : PreCategory. Variable R : Functor C D. (** There is a category [Sect(R)] of sections of [R]. *) (** ** Section of a functor *) Record SectionOfFunctor := { section_of_functor_morphism :> Functor D C; section_of_functor_issect : R o section_of_functor_morphism = 1 }. Local Notation section_of_functor_sig := { section_of_functor_morphism : Functor D C | R o section_of_functor_morphism = 1 }. Lemma section_of_functor_sig' : section_of_functor_sig <~> SectionOfFunctor. Proof. issig. Defined. Local Open Scope natural_transformation_scope. (** ** Definition of category of sections of a functor *) Definition category_of_sections : PreCategory. Proof. refine (@Build_PreCategory SectionOfFunctor (fun F G => NaturalTransformation F G) (fun F => 1) (fun _ _ _ T U => T o U) _ _ _ _); abstract (path_natural_transformation; auto with morphism). Defined. End FunctorSectionCategory. Global Instance isstrict_category_of_sections `{Funext} `{IsStrictCategory C, IsStrictCategory D} (F : Functor C D) : IsStrictCategory (category_of_sections F) | 20. Proof. eapply istrunc_isequiv_istrunc; [ | apply section_of_functor_sig' ]. typeclasses eauto. Qed. Coq-HoTT-9.0/theories/Categories/ChainCategory.v000066400000000000000000000055071474641544500215630ustar00rootroot00000000000000(** * The category ω of (ℕ, ≤), and the chain categories [[n]] *) Require Import Category.Subcategory.Full. Require Import Category.Sigma.Univalent. Require Import Category.Morphisms Category.Univalent Category.Strict. Require Import HoTT.Basics HoTT.Types HoTT.Spaces.Nat.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope nat_scope. (** ** Definitions *) (** Quoting Wikipedia (http://en.wikipedia.org/wiki/Total_order##Chains): While chain is sometimes merely a synonym for totally ordered set, it can also refer to a totally ordered subset of some partially ordered set. The latter definition has a crucial role in Zorn's lemma. *) (** We take the convention that a "chain" is a totally ordered or linearly ordered set; the corresponding category on that set has, as morphisms, the order relation. *) (* N.B. The notation here (including that [[n]] have as objects the set [{0, 1, ..., n}]) was originally suggested by David Spivak. It's possible that we should pick a different or more common terminology. *) Module Export Core. (** *** [[ω]], the linear order on ℕ *) Definition omega : PreCategory := @Build_PreCategory nat leq leq_refl (fun x y z p q => leq_trans q p) (fun _ _ _ _ _ _ _ => path_ishprop _ _) (fun _ _ _ => path_ishprop _ _) (fun _ _ _ => path_ishprop _ _) _. (** *** [[n]], a linear order on a finite set with [n + 1] elements *) (** Using [n + 1] elements allows us to agree with the common definition of an [n]-simplex, where a 0-simplex is a point, and a 1-simplex has two end-points, etc. *) Definition chain (n : nat) : PreCategory := { m : omega | m <= n }%category. (** TODO: Possibly generalize this to arbitrary sets with arbitrary (total?) orders on them? *) Module Export ChainCategoryCoreNotations. Notation "[ n ]" := (chain n) : category_scope. End ChainCategoryCoreNotations. End Core. Module Export Notations. Include ChainCategoryCoreNotations. End Notations. Module Utf8. Export Notations. Notation "[ ∞ ]" := omega : category_scope. Notation "[ 'ω' ]" := omega : category_scope. End Utf8. Module Export Strict. Definition isstrict_omega : IsStrictCategory omega. Proof. exact _. Defined. Definition isstrict_chain {n} : IsStrictCategory [n]. Proof. exact _. Defined. End Strict. Module Export Univalent. Global Instance iscategory_omega : IsCategory omega. Proof. intros s d. refine (isequiv_iff_hprop _ _). { refine (istrunc_equiv_istrunc _ (issig_isomorphic _ _ _)); simpl; refine _. } { intro m; apply leq_antisym; apply m. } Defined. Definition iscategory_chain {n} : IsCategory [n]. Proof. exact _. Defined. End Univalent. Coq-HoTT-9.0/theories/Categories/Comma.v000066400000000000000000000013161474641544500200710ustar00rootroot00000000000000(** * Comma Categories *) (** Since there are only notations in [Comma.Notations], we can just export those. *) Local Set Warnings Append "-notation-overridden". Require Import Basics.Notations. Require Export Comma.Notations. (** ** Definitions *) Require Comma.Core. (** ** Duals *) Require Comma.Dual. (** ** Projection functors *) Require Comma.Projection. Require Comma.InducedFunctors. (** ** Functoriality *) Require Comma.ProjectionFunctors. Require Comma.Functorial. Include Comma.Core. Include Comma.Dual. Include Comma.Projection. Include Comma.InducedFunctors. Include Comma.ProjectionFunctors. Include Comma.Functorial. (** We don't want to make utf-8 notations the default, so we don't export them. *) Coq-HoTT-9.0/theories/Categories/Comma/000077500000000000000000000000001474641544500177015ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Comma/Core.v000066400000000000000000000264551474641544500207740ustar00rootroot00000000000000(** * Comma categories *) Require Import HoTT.Basics HoTT.Types. Require Import Functor.Core. Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors. Require Functor.Identity. Require Import Category.Strict. Import Functor.Identity.FunctorIdentityNotations. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. (** Quoting Wikipedia: Suppose that [A], [B], and [C] are categories, and [S] and [T] are functors [S : A → C ← B : T] We can form the comma category [(S ↓ T)] as follows: - The objects are all triples [(α, β, f)] with [α] an object in [A], [β] an object in [B], and [f : S α -> T β] a morphism in [C]. - The morphisms from [(α, β, f)] to [(α', β', f')] are all pairs [(g, h)] where [g : α → α'] and [h : β → β'] are morphisms in [A] and [B] respectively, such that the following diagram commutes: << S g S α -----> S α' | | f | | f' | | ↓ ↓ T β -----> T β' T h >> Morphisms are composed by taking [(g, h) ∘ (g', h')] to be [(g ∘ g', h ∘ h')], whenever the latter expression is defined. The identity morphism on an object [(α, β, f)] is [(1_α, 1_β)]. *) (** ** Comma category [(S / T)] *) Module Import CommaCategory. Section comma_category_parts. Variables A B C : PreCategory. Variable S : Functor A C. Variable T : Functor B C. Record object := { a : A; b : B; f : morphism C (S a) (T b) }. Global Arguments a _ / . Global Arguments b _ / . Global Arguments f _ / . Local Notation object_sig_T := ({ a : A | { b : B | morphism C (S a) (T b) }}). Lemma issig_object : object_sig_T <~> object. Proof. issig. Defined. Global Instance trunc_object `{IsTrunc n A, IsTrunc n B} `{forall s d, IsTrunc n (morphism C s d)} : IsTrunc n object. Proof. eapply istrunc_equiv_istrunc; [ exact issig_object | ]. typeclasses eauto. Qed. Lemma path_object' (x y : object) : forall (Ha : x.(a) = y.(a)) (Hb : x.(b) = y.(b)), transport (fun X => morphism C (S X) _) Ha (transport (fun Y => morphism C _ (T Y)) Hb x.(f)) = y.(f) -> x = y. Proof. destruct x, y; simpl. intros; path_induction; reflexivity. Defined. Lemma ap_a_path_object' x y Ha Hb Hf : ap (@a) (@path_object' x y Ha Hb Hf) = Ha. Proof. destruct x, y; simpl in *. destruct Ha, Hb, Hf; simpl in *. reflexivity. Qed. Lemma ap_b_path_object' x y Ha Hb Hf : ap (@b) (@path_object' x y Ha Hb Hf) = Hb. Proof. destruct x, y; simpl in *. destruct Ha, Hb, Hf; simpl in *. reflexivity. Qed. Global Arguments path_object' : simpl never. Record morphism (abf a'b'f' : object) := Build_morphism' { g : Category.Core.morphism A (abf.(a)) (a'b'f'.(a)); h : Category.Core.morphism B (abf.(b)) (a'b'f'.(b)); p : T _1 h o abf.(f) = a'b'f'.(f) o S _1 g; p_sym : a'b'f'.(f) o S _1 g = T _1 h o abf.(f) }. Definition Build_morphism abf a'b'f' g h p : morphism abf a'b'f' := @Build_morphism' abf a'b'f' g h p p^. Global Arguments Build_morphism / . Global Arguments g _ _ _ / . Global Arguments h _ _ _ / . Global Arguments p _ _ _ / . Global Arguments p_sym _ _ _ / . Local Notation morphism_sig_T abf a'b'f' := ({ g : Category.Core.morphism A (abf.(a)) (a'b'f'.(a)) | { h : Category.Core.morphism B (abf.(b)) (a'b'f'.(b)) | T _1 h o abf.(f) = a'b'f'.(f) o S _1 g }}). Local Notation morphism_sig_T' abf a'b'f' := ({ g : Category.Core.morphism A (abf.(a)) (a'b'f'.(a)) | { h : Category.Core.morphism B (abf.(b)) (a'b'f'.(b)) | { _ : T _1 h o abf.(f) = a'b'f'.(f) o S _1 g | a'b'f'.(f) o S _1 g = T _1 h o abf.(f) }}}). Lemma issig_morphism' abf a'b'f' : (morphism_sig_T' abf a'b'f') <~> morphism abf a'b'f'. Proof. issig. Defined. Lemma issig_morphism_helper {T0} `{IsHSet T0} (a b : T0) (pf : a = b) : Contr (b = a). Proof. destruct pf. apply contr_inhabited_hprop; try reflexivity. typeclasses eauto. Qed. Lemma issig_morphism abf a'b'f' : (morphism_sig_T abf a'b'f') <~> morphism abf a'b'f'. Proof. etransitivity; [ | exact (issig_morphism' abf a'b'f') ]. repeat (apply equiv_functor_sigma_id; intro). symmetry; apply equiv_sigma_contr; intro. apply issig_morphism_helper; assumption. Defined. Global Instance trunc_morphism abf a'b'f' `{IsTrunc n (Category.Core.morphism A (abf.(a)) (a'b'f'.(a)))} `{IsTrunc n (Category.Core.morphism B (abf.(b)) (a'b'f'.(b)))} `{forall m1 m2, IsTrunc n (T _1 m2 o abf.(f) = a'b'f'.(f) o S _1 m1)} : IsTrunc n (morphism abf a'b'f'). Proof. assert (forall m1 m2, IsTrunc n (a'b'f'.(f) o S _1 m1 = T _1 m2 o abf.(f))) by (intros; apply (istrunc_isequiv_istrunc _ inverse)). eapply istrunc_equiv_istrunc; [ exact (issig_morphism _ _) | ]. typeclasses eauto. Qed. Lemma path_morphism abf a'b'f' (gh g'h' : morphism abf a'b'f') : gh.(g) = g'h'.(g) -> gh.(h) = g'h'.(h) -> gh = g'h'. Proof. destruct gh, g'h'; simpl. intros; path_induction. f_ap. all:exact (center _). Qed. Definition compose s d d' (gh : morphism d d') (g'h' : morphism s d) : morphism s d' := Build_morphism' s d' (gh.(g) o g'h'.(g)) (gh.(h) o g'h'.(h)) ((ap (fun m => m o s.(f)) (composition_of T _ _ _ _ _)) @ (associativity _ _ _ _ _ _ _ _) @ (ap (fun m => _ o m) g'h'.(p)) @ (associativity_sym _ _ _ _ _ _ _ _) @ (ap (fun m => m o _) gh.(p)) @ (associativity _ _ _ _ _ _ _ _) @ (ap (fun m => d'.(f) o m) (composition_of S _ _ _ _ _)^))%path ((ap (fun m => d'.(f) o m) (composition_of S _ _ _ _ _)) @ (associativity_sym _ _ _ _ _ _ _ _) @ (ap (fun m => m o _) gh.(p_sym)) @ (associativity _ _ _ _ _ _ _ _) @ (ap (fun m => _ o m) g'h'.(p_sym)) @ (associativity_sym _ _ _ _ _ _ _ _) @ (ap (fun m => m o s.(f)) (composition_of T _ _ _ _ _)^))%path. Global Arguments compose _ _ _ _ _ / . Definition identity x : morphism x x := Build_morphism' x x (identity (x.(a))) (identity (x.(b))) ((ap (fun m => m o x.(f)) (identity_of T _)) @ (left_identity _ _ _ _) @ ((right_identity _ _ _ _)^) @ (ap (fun m => x.(f) o m) (identity_of S _)^)) ((ap (fun m => x.(f) o m) (identity_of S _)) @ (right_identity _ _ _ _) @ ((left_identity _ _ _ _)^) @ (ap (fun m => m o x.(f)) (identity_of T _)^)). Global Arguments identity _ / . End comma_category_parts. End CommaCategory. Global Arguments CommaCategory.path_object' : simpl never. Local Ltac path_comma_t := intros; apply path_morphism; simpl; auto with morphism. Definition comma_category A B C (S : Functor A C) (T : Functor B C) : PreCategory. Proof. refine (@Build_PreCategory (@object _ _ _ S T) (@morphism _ _ _ S T) (@identity _ _ _ S T) (@compose _ _ _ S T) _ _ _ _ ); abstract path_comma_t. Defined. Global Instance isstrict_comma_category A B C S T `{IsStrictCategory A, IsStrictCategory B} : IsStrictCategory (@comma_category A B C S T). Proof. typeclasses eauto. Qed. (* Section category. Context `{IsCategory A, IsCategory B}. (*Context `{Funext}. *) Definition comma_category_isotoid (x y : comma_category) : x ≅ y -> x = y. Proof. intro i. destruct i as [i [i' ? ?]]. hnf in *. destruct i, i'. simpl in *. Global Instance comma_category_IsCategory `{IsCategory A, IsCategory B} : IsCategory comma_category. Proof. hnf. unfold IsStrictCategory in *. typeclasses eauto. Qed. End category. *) #[export] Hint Unfold compose identity : category. #[export] Hint Constructors morphism object : category. (** ** (co)slice category [(a / F)], [(F / a)] *) Section slice_category. Variables A C : PreCategory. Variable a : C. Variable S : Functor A C. Definition slice_category := comma_category S (!a). Definition coslice_category := comma_category (!a) S. (** [x ↓ F] is a coslice category; [F ↓ x] is a slice category; [x ↓ F] deals with morphisms [x -> F y]; [F ↓ x] has morphisms [F y -> x] *) End slice_category. (** ** (co)slice category over [(a / C)], [(C / a)] *) Section slice_category_over. Variable C : PreCategory. Variable a : C. Definition slice_category_over := slice_category a (Functor.Identity.identity C). Definition coslice_category_over := coslice_category a (Functor.Identity.identity C). End slice_category_over. (** ** category of arrows *) Section arrow_category. Variable C : PreCategory. Definition arrow_category := comma_category (Functor.Identity.identity C) (Functor.Identity.identity C). End arrow_category. Definition CC_Functor' (C : PreCategory) (D : PreCategory) := Functor C D. Coercion cc_functor_from_terminal' (C : PreCategory) (x : C) : CC_Functor' _ C := (!x)%functor. Coercion cc_identity_functor' (C : PreCategory) : CC_Functor' C C := 1%functor. Global Arguments CC_Functor' / . Global Arguments cc_functor_from_terminal' / . Global Arguments cc_identity_functor' / . Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Module Export CommaCoreNotations. (** We really want to use infix [↓] for comma categories, but that's unicode. Infix [,] might also be reasonable, but I can't seem to get it to work without destroying the [(_, _)] notation for ordered pairs. So I settle for the ugly ASCII rendition [/] of [↓]. *) (** Set some notations for printing *) Notation "C / a" := (@slice_category_over C a) (only printing) : category_scope. Notation "a \ C" := (@coslice_category_over C a) : category_scope. Notation "a / C" := (@coslice_category_over C a) (only printing) : category_scope. Notation "x / F" := (coslice_category x F) (only printing) : category_scope. Notation "F / x" := (slice_category x F) (only printing) : category_scope. Notation "S / T" := (comma_category S T) (only printing) : category_scope. (** Set the notation for parsing; coercions will automatically decide which of the arguments are functors and which are objects, i.e., functors from the terminal category. *) Notation "S / T" := (comma_category (S : CC_Functor' _ _) (T : CC_Functor' _ _)) : category_scope. End CommaCoreNotations. Coq-HoTT-9.0/theories/Categories/Comma/Dual.v000066400000000000000000000035501474641544500207600ustar00rootroot00000000000000(** * Opposite comma categories *) Require Import Category.Core Functor.Core. Require Import Category.Dual Functor.Dual. Require Import Functor.Composition.Core Functor.Identity. Require Comma.Core. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Import Comma.Core. Local Set Warnings Append "notation-overridden". Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope morphism_scope. Local Open Scope category_scope. Local Open Scope functor_scope. (** ** The dual functors [(S / T) ↔ ((Tᵒᵖ / Sᵒᵖ)ᵒᵖ)] *) Section opposite. Section op. Variables A B C : PreCategory. Variable S : Functor A C. Variable T : Functor B C. Local Notation obj_of x := (CommaCategory.Build_object (T^op) (S^op) _ _ (CommaCategory.f x) : object ((T^op / S^op)^op)). Local Notation mor_of s d m := (CommaCategory.Build_morphism' (obj_of d) (obj_of s) (CommaCategory.h m%morphism) (CommaCategory.g m%morphism) (CommaCategory.p_sym m%morphism) (CommaCategory.p m%morphism) : morphism ((T^op / S^op)^op) (obj_of s) (obj_of d)). Definition dual_functor : Functor (S / T) ((T^op / S^op)^op) := Build_Functor (S / T) ((T^op / S^op)^op) (fun x => obj_of x) (fun s d m => mor_of s d m) (fun _ _ _ _ _ => 1%path) (fun _ => 1%path). End op. Definition dual_functor_involutive A B C (S : Functor A C) (T : Functor B C) : dual_functor S T o (dual_functor T^op S^op)^op = 1 /\ (dual_functor T^op S^op)^op o dual_functor S T = 1 := (idpath, idpath)%core. End opposite. Coq-HoTT-9.0/theories/Categories/Comma/Functorial.v000066400000000000000000000176221474641544500222060ustar00rootroot00000000000000(** * Functoriality of the comma category construction *) Require Import Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Core NaturalTransformation.Composition.Core. Require Import NaturalTransformation.Composition.Laws. Require Import Functor.Paths. Require Import Category.Strict. Require Comma.Core. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Import Comma.Core. Local Set Warnings Append "notation-overridden". Import Functor.Identity.FunctorIdentityNotations NaturalTransformation.Identity.NaturalTransformationIdentityNotations. Require Import HoTT.Tactics PathGroupoids Types.Forall. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. (** The comma category construction is functorial in its category arguments. We really should be using ∏ (dependent product) here, but I'm lazy, and will instead expand it out. *) Local Ltac helper_t fwd_tac bak_tac fin := repeat first [ fin | rewrite <- ?Category.Core.associativity; progress repeat first [ bak_tac | apply ap10; apply ap ] | rewrite -> ?Category.Core.associativity; progress repeat first [ fwd_tac | apply ap ] | rewrite <- !composition_of ]. Local Tactic Notation "helper" tactic(fin) constr(hyp_fwd) constr(hyp_bak) := let H := fresh in let H' := fresh in pose proof hyp_fwd as H; pose proof hyp_bak as H'; simpl in *; helper_t ltac:(rewrite -> H) ltac:(rewrite <- H') fin. Local Ltac functorial_helper_t unfold_lem := repeat (apply path_forall || intro); simpl; rewrite !transport_forall_constant; simpl; transport_path_forall_hammer; simpl; apply CommaCategory.path_morphism; simpl; unfold unfold_lem; simpl; repeat match goal with | _ => exact idpath | [ |- context[CommaCategory.g (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => @CommaCategory.g _ _ _ _ _ _ _) z) | [ |- context[CommaCategory.h (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => @CommaCategory.h _ _ _ _ _ _ _) z) | [ |- context[transport (fun y => ?f (?g y) ?z)] ] => simpl rewrite (fun a b => @transport_compose _ _ a b (fun y => f y z) g) | [ |- context[transport (fun y => ?f (?g y))] ] => simpl rewrite (fun a b => @transport_compose _ _ a b (fun y => f y) g) | _ => rewrite !CommaCategory.ap_a_path_object'; simpl | _ => rewrite !CommaCategory.ap_b_path_object'; simpl end. Section functorial. Section single_source. Variables A B C : PreCategory. Variable S : Functor A C. Variable T : Functor B C. Section morphism_of. Variables A' B' C' : PreCategory. Variable S' : Functor A' C'. Variable T' : Functor B' C'. Variable AF : Functor A A'. Variable BF : Functor B B'. Variable CF : Functor C C'. Variable TA : NaturalTransformation (S' o AF) (CF o S). Variable TB : NaturalTransformation (CF o T) (T' o BF). Definition functorial_morphism_of_object_of : (S / T) -> (S' / T') := fun x => CommaCategory.Build_object S' T' (AF (CommaCategory.a x)) (BF (CommaCategory.b x)) (TB (CommaCategory.b x) o CF _1 (CommaCategory.f x) o TA (CommaCategory.a x)). Definition functorial_morphism_of_morphism_of s d (m : morphism (S / T) s d) : morphism (S' / T') (functorial_morphism_of_object_of s) (functorial_morphism_of_object_of d). Proof. simpl in *. refine (CommaCategory.Build_morphism (functorial_morphism_of_object_of s) (functorial_morphism_of_object_of d) (AF _1 (CommaCategory.g m)) (BF _1 (CommaCategory.h m)) _). unfold functorial_morphism_of_object_of; simpl. clear. abstract helper (exact (CommaCategory.p m)) (commutes TA) (commutes TB). Defined. Definition functorial_morphism_of : Functor (S / T) (S' / T'). Proof. refine (Build_Functor (S / T) (S' / T') functorial_morphism_of_object_of functorial_morphism_of_morphism_of _ _); abstract ( intros; apply CommaCategory.path_morphism; simpl; auto with functor ). Defined. End morphism_of. Section identity_of. Definition functorial_identity_of_helper x : @functorial_morphism_of_object_of _ _ _ S T 1 1 1 1 1 x = x. Proof. let A := match goal with |- ?A = ?B => constr:(A) end in let B := match goal with |- ?A = ?B => constr:(B) end in refine (@CommaCategory.path_object' _ _ _ _ _ A B 1%path 1%path _). exact (Category.Core.right_identity _ _ _ _ @ Category.Core.left_identity _ _ _ _)%path. Defined. Definition functorial_identity_of `{Funext} : @functorial_morphism_of _ _ _ S T 1 1 1 1 1 = 1%functor. Proof. path_functor; simpl. exists (path_forall _ _ functorial_identity_of_helper). simpl. functorial_helper_t functorial_identity_of_helper. Qed. End identity_of. End single_source. Section composition_of. Variables A B C : PreCategory. Variable S : Functor A C. Variable T : Functor B C. Variables A' B' C' : PreCategory. Variable S' : Functor A' C'. Variable T' : Functor B' C'. Variables A'' B'' C'' : PreCategory. Variable S'' : Functor A'' C''. Variable T'' : Functor B'' C''. Variable AF : Functor A A'. Variable BF : Functor B B'. Variable CF : Functor C C'. Variable TA : NaturalTransformation (S' o AF) (CF o S). Variable TB : NaturalTransformation (CF o T) (T' o BF). Variable AF' : Functor A' A''. Variable BF' : Functor B' B''. Variable CF' : Functor C' C''. Variable TA' : NaturalTransformation (S'' o AF') (CF' o S'). Variable TB' : NaturalTransformation (CF' o T') (T'' o BF'). Let AF'' := (AF' o AF)%functor. Let BF'' := (BF' o BF)%functor. Let CF'' := (CF' o CF)%functor. Let TA'' : NaturalTransformation (S'' o AF'') (CF'' o S) := ((associator_2 _ _ _) o (CF' oL TA) o (associator_1 _ _ _) o (TA' oR AF) o associator_2 _ _ _)%natural_transformation. Let TB'' : NaturalTransformation (CF'' o T) (T'' o BF'') := ((associator_1 _ _ _) o (TB' oR BF) o (associator_2 _ _ _) o (CF' oL TB) o associator_1 _ _ _)%natural_transformation. Definition functorial_composition_of_helper x : (functorial_morphism_of TA' TB' o functorial_morphism_of TA TB)%functor x = functorial_morphism_of TA'' TB'' x. Proof. let A := match goal with |- ?A = ?B => constr:(A) end in let B := match goal with |- ?A = ?B => constr:(B) end in refine (@CommaCategory.path_object' _ _ _ _ _ A B 1%path 1%path _). subst AF'' BF'' CF'' TA'' TB''. simpl in *. abstract ( autorewrite with morphism; simpl; helper (exact idpath) (commutes TA') (commutes TB') ). Defined. Definition functorial_composition_of `{Funext} : (functorial_morphism_of TA' TB' o functorial_morphism_of TA TB)%functor = functorial_morphism_of TA'' TB''. Proof. path_functor; simpl. exists (path_forall _ _ functorial_composition_of_helper). functorial_helper_t functorial_composition_of_helper. Qed. End composition_of. End functorial. Coq-HoTT-9.0/theories/Categories/Comma/InducedFunctors.v000066400000000000000000000156771474641544500232070ustar00rootroot00000000000000(** * Induced functors between comma categories *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Category.Dual. Require Import Category.Prod. Require Import NaturalTransformation.Identity. Require Import FunctorCategory.Core Cat.Core. Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors. Require Comma.Core. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Import Comma.Core. Local Set Warnings Append "notation-overridden". Require Import HoTT.Tactics. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Local Open Scope category_scope. (** ** Morphisms in [(A → C)ᵒᵖ × (B → C)] from [(s₀, s₁)] to [(d₀, d₁)] induce functors [(s₀ / s₁) → (d₀ / d₁)] *) Section comma_category_induced_functor. Context `{Funext}. Variables A B C : PreCategory. Definition comma_category_induced_functor_object_of s d (m : morphism ((A -> C)^op * (B -> C)) s d) (x : fst s / snd s) : (fst d / snd d) := CommaCategory.Build_object (fst d) (snd d) (CommaCategory.a x) (CommaCategory.b x) ((snd m) (CommaCategory.b x) o CommaCategory.f x o (fst m) (CommaCategory.a x)). Lemma comma_category_induced_functor_object_of_identity s x : comma_category_induced_functor_object_of (Category.Core.identity s) x = x. Proof. let x1 := match goal with |- ?x1 = ?x2 => constr:(x1) end in let x2 := match goal with |- ?x1 = ?x2 => constr:(x2) end in apply (CommaCategory.path_object' x1 x2 idpath idpath). simpl. abstract (rewrite ?left_identity, ?right_identity; reflexivity). Defined. Definition comma_category_induced_functor_object_of_compose s d d' (m : morphism ((A -> C)^op * (B -> C)) d d') (m' : morphism ((A -> C)^op * (B -> C)) s d) x : comma_category_induced_functor_object_of (m o m') x = comma_category_induced_functor_object_of m (comma_category_induced_functor_object_of m' x). Proof. let x1 := match goal with |- ?x1 = ?x2 => constr:(x1) end in let x2 := match goal with |- ?x1 = ?x2 => constr:(x2) end in apply (CommaCategory.path_object' x1 x2 idpath idpath). abstract ( destruct m', m, x; simpl in *; rewrite !associativity; reflexivity ). Defined. Definition comma_category_induced_functor_morphism_of s d m s0 d0 (m0 : morphism (fst s / snd s) s0 d0) : morphism (fst d / snd d) (@comma_category_induced_functor_object_of s d m s0) (@comma_category_induced_functor_object_of s d m d0). Proof. simpl. let s := match goal with |- CommaCategory.morphism ?s ?d => constr:(s) end in let d := match goal with |- CommaCategory.morphism ?s ?d => constr:(d) end in refine (CommaCategory.Build_morphism s d (CommaCategory.g m0) (CommaCategory.h m0) _); simpl in *; clear. abstract ( destruct_head prod; destruct_head CommaCategory.morphism; destruct_head CommaCategory.object; simpl in *; repeat (try_associativity_quick (rewrite <- !commutes || (progress f_ap))); repeat (try_associativity_quick (rewrite !commutes || (progress f_ap))); assumption ). (* 3.495 s *) Defined. Definition comma_category_induced_functor s d (m : morphism ((A -> C)^op * (B -> C)) s d) : Functor (fst s / snd s) (fst d / snd d). Proof. refine (Build_Functor (fst s / snd s) (fst d / snd d) (@comma_category_induced_functor_object_of s d m) (@comma_category_induced_functor_morphism_of s d m) _ _ ); abstract ( intros; apply CommaCategory.path_morphism; reflexivity ). Defined. End comma_category_induced_functor. (** ** Morphisms in [C] from [a] to [a'] induce functors [(C / a) → (C / a')] *) Section slice_category_induced_functor. Context `{Funext}. Variable C : PreCategory. Section slice_coslice. Variable D : PreCategory. (** TODO(JasonGross): See if this can be recast as an exponential law functor about how [1 → Cat] is isomorphic to [Cat], or something *) Definition slice_category_induced_functor_nt s d (m : morphism D s d) : NaturalTransformation !s !d. Proof. exists (fun _ : Unit => m); simpl; intros; clear; abstract (autorewrite with category; reflexivity). Defined. Variable F : Functor C D. Variable a : D. Section slice. Definition slice_category_induced_functor F' a' (m : morphism D a a') (T : NaturalTransformation F' F) : Functor (F / a) (F' / a') := comma_category_induced_functor (s := (F, !a)) (d := (F', !a')) (T, @slice_category_induced_functor_nt a a' m). Definition slice_category_nt_induced_functor F' T := @slice_category_induced_functor F' a 1 T. Definition slice_category_morphism_induced_functor a' m := @slice_category_induced_functor F a' m 1. End slice. Section coslice. Definition coslice_category_induced_functor F' a' (m : morphism D a' a) (T : NaturalTransformation F F') : Functor (a / F) (a' / F') := comma_category_induced_functor (s := (!a, F)) (d := (!a', F')) (@slice_category_induced_functor_nt a' a m, T). Definition coslice_category_nt_induced_functor F' T := @coslice_category_induced_functor F' a 1 T. Definition coslice_category_morphism_induced_functor a' m := @coslice_category_induced_functor F a' m 1. End coslice. End slice_coslice. Definition slice_category_over_induced_functor a a' (m : morphism C a a') : Functor (C / a) (C / a') := Eval hnf in slice_category_morphism_induced_functor _ _ _ m. Definition coslice_category_over_induced_functor a a' (m : morphism C a' a) : Functor (a \ C) (a' \ C) := Eval hnf in coslice_category_morphism_induced_functor _ _ _ m. End slice_category_induced_functor. (** ** Functors [A → A'] functors [(cat / A) → (cat / A')] *) Section cat_over_induced_functor. Local Open Scope type_scope. Context `{Funext}. Variable P : PreCategory -> Type. Context `{H0 : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation cat := (@sub_pre_cat _ P H0). Definition cat_over_induced_functor a a' (m : morphism cat a a') : Functor (cat / a) (cat / a') := slice_category_over_induced_functor cat a a' m. Definition over_cat_induced_functor a a' (m : morphism cat a' a) : Functor (a \ cat) (a' \ cat) := coslice_category_over_induced_functor cat a a' m. End cat_over_induced_functor. Coq-HoTT-9.0/theories/Categories/Comma/Notations.v000066400000000000000000000005171474641544500220510ustar00rootroot00000000000000(** * Notations for comma categories *) Require Import Basics.Notations. Require Comma.Core. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Include Comma.Core.CommaCoreNotations. Coq-HoTT-9.0/theories/Categories/Comma/Projection.v000066400000000000000000000050741474641544500222120ustar00rootroot00000000000000(** * Projection functors from comma categories *) Require Import Category.Core Functor.Core. Require Import Category.Prod Functor.Prod.Core. Require Import Functor.Composition.Core Functor.Identity. Require Import InitialTerminalCategory.Functors. Require Comma.Core. Require Import Types.Prod. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Import Comma.Core. Local Set Warnings Append "notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Local Open Scope category_scope. (** ** First projection [(S / T) → A × B] (for [S : A → C ← B : T]) *) Section comma_category. Variables A B C : PreCategory. Variable S : Functor A C. Variable T : Functor B C. Definition comma_category_projection : Functor (S / T) (A * B) := Build_Functor (S / T) (A * B) (fun abf => (CommaCategory.a abf, CommaCategory.b abf)%core) (fun _ _ m => (CommaCategory.g m, CommaCategory.h m)%core) (fun _ _ _ _ _ => idpath) (fun _ => idpath). End comma_category. (** ** First projections [(S / a) → A] and [(a / S) → A] *) Section slice_category. Variable A : PreCategory. Local Arguments Functor.Composition.Core.compose / . Local Arguments Functor.Composition.Core.compose_composition_of / . Local Arguments Functor.Composition.Core.compose_identity_of / . Local Arguments path_prod / . Local Arguments path_prod' / . Local Arguments path_prod_uncurried / . Definition arrow_category_projection : Functor (arrow_category A) A := Eval simpl in fst o comma_category_projection _ 1. Definition slice_category_over_projection (a : A) : Functor (A / a) A := Eval simpl in fst o comma_category_projection 1 _. Definition coslice_category_over_projection (a : A) : Functor (a \ A) A := Eval simpl in snd o comma_category_projection _ 1. Section slice_coslice. Variable C : PreCategory. Variable a : C. Variable S : Functor A C. Definition slice_category_projection : Functor (S / a) A := Eval simpl in fst o comma_category_projection S !a. Definition coslice_category_projection : Functor (a / S) A := Eval simpl in snd o comma_category_projection !a S. End slice_coslice. End slice_category. Coq-HoTT-9.0/theories/Categories/Comma/ProjectionFunctors.v000066400000000000000000000173401474641544500237350ustar00rootroot00000000000000(** * Functoriality of the comma category construction with projection functors *) Require Import Category.Core Functor.Core. Require Import Category.Prod Functor.Prod.Core. Require Import Category.Dual Functor.Dual. Require Import Functor.Composition.Core. Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors NatCategory. Require Import FunctorCategory.Core. Require Import Cat.Core. Require Import Functor.Paths. Require Comma.Core. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Import Comma.Core. Local Set Warnings Append "notation-overridden". Require Import Comma.InducedFunctors Comma.Projection. Require ProductLaws ExponentialLaws.Law1.Functors ExponentialLaws.Law4.Functors. Require Import Types.Forall PathGroupoids HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. (** ** Functor from [(A → C)ᵒᵖ × (B → C)] to [cat / (A × B)] *) (** It sends [S : A → C ← B : T] to the category [(S / T)] and its projection functor to [A × B]. *) Section comma. Local Open Scope type_scope. Context `{Funext}. Variable P : PreCategory -> Type. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation Cat := (@sub_pre_cat _ P HF). Variables A B C : PreCategory. Hypothesis PAB : P (A * B). Hypothesis P_comma : forall (S : Functor A C) (T : Functor B C), P (S / T). Local Open Scope category_scope. Local Open Scope morphism_scope. Definition comma_category_projection_functor_object_of (ST : object ((A -> C)^op * (B -> C))) : Cat / !((A * B; PAB) : Cat). Proof. exists (Basics.Overture.fst ST / Basics.Overture.snd ST; P_comma _ _) (center _). exact (comma_category_projection (Basics.Overture.fst ST) (Basics.Overture.snd ST)). Defined. Definition comma_category_projection_functor_morphism_of s d (m : morphism ((A -> C)^op * (B -> C)) s d) : morphism (Cat / !((A * B; PAB) : Cat)) (comma_category_projection_functor_object_of s) (comma_category_projection_functor_object_of d). Proof. hnf. refine (CommaCategory.Build_morphism (comma_category_projection_functor_object_of s) (comma_category_projection_functor_object_of d) (comma_category_induced_functor m) (center _) _). simpl. destruct_head_hnf Basics.Overture.prod. path_functor. Defined. Local Ltac comma_laws_t := repeat (apply path_forall || intro); simpl; rewrite !transport_forall_constant; transport_path_forall_hammer; simpl; destruct_head Basics.Overture.prod; simpl in *; apply CommaCategory.path_morphism; simpl; repeat match goal with | [ |- context[?f _ _ _ _ _ _ _ (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => f _ _ _ _ _ _ _) z) | [ |- context[transport (fun y => ?f (?fa _ _ _ _ _ y) ?x)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y => f y x) (fa _ _ _ _ _)) | [ |- context[transport (fun y => ?f ?x (?fa _ _ _ _ _ y))] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y => f x y) (fa _ _ _ _ _)) end; unfold comma_category_induced_functor_object_of_identity; unfold comma_category_induced_functor_object_of_compose; simpl; rewrite ?CommaCategory.ap_a_path_object', ?CommaCategory.ap_b_path_object'; try reflexivity. Lemma comma_category_projection_functor_identity_of x : comma_category_projection_functor_morphism_of (Category.Core.identity x) = 1. Proof. apply CommaCategory.path_morphism; simpl; [ | reflexivity ]. path_functor. exists (path_forall _ _ (comma_category_induced_functor_object_of_identity _)). comma_laws_t. Qed. Lemma comma_category_projection_functor_composition_of s d d' m m' : comma_category_projection_functor_morphism_of (@Category.Core.compose _ s d d' m' m) = (comma_category_projection_functor_morphism_of m') o (comma_category_projection_functor_morphism_of m). Proof. apply CommaCategory.path_morphism; simpl; [ | reflexivity ]. path_functor. simpl. exists (path_forall _ _ (comma_category_induced_functor_object_of_compose m' m)). comma_laws_t. Qed. Definition comma_category_projection_functor : Functor ((A -> C)^op * (B -> C)) (Cat / !((A * B; PAB) : Cat)) := Build_Functor ((A -> C)^op * (B -> C)) (Cat / !((A * B; PAB) : Cat)) comma_category_projection_functor_object_of comma_category_projection_functor_morphism_of comma_category_projection_functor_composition_of comma_category_projection_functor_identity_of. End comma. Section slice_category_projection_functor. Local Open Scope type_scope. Context `{Funext}. Variable P : PreCategory -> Type. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation Cat := (@sub_pre_cat _ P HF). Variables C D : PreCategory. Hypothesis P1C : P (1 * C). Hypothesis PC1 : P (C * 1). Hypothesis PC : P C. Hypothesis P_comma : forall (S : Functor C D) (T : Functor 1 D), P (S / T). Hypothesis P_comma' : forall (S : Functor 1 D) (T : Functor C D), P (S / T). Local Open Scope functor_scope. Local Open Scope category_scope. Local Notation inv D := (@ExponentialLaws.Law1.Functors.inverse _ terminal_category _ _ _ D). (** ** Functor [(C → D)ᵒᵖ → D → (cat / C)] *) Definition slice_category_projection_functor : object (((C -> D)^op) -> (D -> (Cat / ((C; PC) : Cat)))). Proof. refine ((ExponentialLaws.Law4.Functors.inverse _ _ _) _). refine (_ o (Functor.Identity.identity (C -> D)^op, inv D)). refine (_ o @comma_category_projection_functor _ P HF C 1 D PC1 P_comma). refine (cat_over_induced_functor _). hnf. exact (ProductLaws.Law1.functor _). Defined. Definition coslice_category_projection_functor : object ((C -> D)^op -> (D -> (Cat / ((C; PC) : Cat)))). Proof. refine ((ExponentialLaws.Law4.Functors.inverse _ _ _) _). refine (_ o (Functor.Identity.identity (C -> D)^op, inv D)). refine (_ o @comma_category_projection_functor _ P HF C 1 D PC1 P_comma). refine (cat_over_induced_functor _). hnf. exact (ProductLaws.Law1.functor _). Defined. (** ** Functor [(C → D) → Dᵒᵖ → (cat / C)] *) Definition slice_category_projection_functor' : object ((C -> D) -> (D^op -> (Cat / ((C; PC) : Cat)))). Proof. refine ((ExponentialLaws.Law4.Functors.inverse _ _ _) _). refine (_ o (Functor.Identity.identity (C -> D), (inv D)^op)). refine (_ o ProductLaws.Swap.functor _ _). refine (_ o @comma_category_projection_functor _ P HF 1 C D P1C P_comma'). refine (cat_over_induced_functor _). hnf. exact (ProductLaws.Law1.functor' _). Defined. Definition coslice_category_projection_functor' : object ((C -> D) -> (D^op -> (Cat / ((C; PC) : Cat)))). Proof. refine ((ExponentialLaws.Law4.Functors.inverse _ _ _) _). refine (_ o (Functor.Identity.identity (C -> D), (inv D)^op)). refine (_ o ProductLaws.Swap.functor _ _). refine (_ o @comma_category_projection_functor _ P HF 1 C D P1C P_comma'). refine (cat_over_induced_functor _). hnf. exact (ProductLaws.Law1.functor' _). Defined. End slice_category_projection_functor. Coq-HoTT-9.0/theories/Categories/Comma/Utf8.v000066400000000000000000000024311474641544500207160ustar00rootroot00000000000000(** * Unicode notations for comma categories *) Local Set Warnings Append "-notation-overridden". Require Import Basics.Notations. Require Import Comma.Core. Require Export Comma.Notations. Require Import Basics.Utf8. (** Set some notations for printing *) Notation "C ↓ a" := (@slice_category_over C a) (only printing) : category_scope. Notation "a ↓ C" := (@coslice_category_over C a) (only printing) : category_scope. Notation "x ↓ F" := (coslice_category x F) (only printing) : category_scope. Notation "F ↓ x" := (slice_category x F) (only printing) : category_scope. Notation "S ↓ T" := (comma_category S T) (only printing) : category_scope. (** Set the notation for parsing; coercions will automatically decide which of the arguments are functors and which are objects, i.e., functors from the terminal category. *) Notation "S ↓ T" := (comma_category (S : CC_Functor' _ _) (T : CC_Functor' _ _)) : category_scope. (*Set Printing All. Check (fun (C : PreCategory)(D : PreCategory)(E : PreCategory)(S : Functor C D) (T : Functor E D) => (S ↓ T)%category). Check (fun (D : PreCategory)(E : PreCategory)(S : Functor E D) (x : D) => (x ↓ S)%category). Check (fun (D : PreCategory)(E : PreCategory)(S : Functor E D) (x : D) => (S ↓ x)%category).*) Coq-HoTT-9.0/theories/Categories/DependentProduct.v000066400000000000000000000031301474641544500223000ustar00rootroot00000000000000(** * Dependent Product; oplax limit of a functor to Cat *) Require Import Category.Core Functor.Core. Require Import Cat.Core. Require Grothendieck.ToCat. Require Import CategoryOfSections.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Section dependent_product. Context `{Funext}. Variable C : PreCategory. Variable P : PreCategory -> Type. (*Context `{forall C, IsHProp (P C)}.*) Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation cat := (@sub_pre_cat _ P HF). Variable F : Functor C cat. (** Quoting http://mathoverflow.net/questions/137689/explicit-description-of-the-oplax-limit-of-a-functor-to-cat: The oplax limit is the category of sections for the functor from the Grothendieck construction to the base category. The strong limit is the category of cartesian sections (every arrow in the base category gets mapped to a cartesian one). Notice how this goes along very well with the interpretation as dependent product and as ∀: The set theoretic product is just the set of sections into the disjoint union. Given a strong functor [F : X → Cat] we denote the Grothendieck construction by [Gr F]. There is a canonical functor [π : Gr F → X]. Sections of this functor are functors [s : X → Gr F] such that [s ∘ π = id]. *) Definition dependent_product : PreCategory := category_of_sections (Grothendieck.ToCat.pr1 F). End dependent_product. Notation Pi := dependent_product. Coq-HoTT-9.0/theories/Categories/DiscreteCategory.v000066400000000000000000000005771474641544500223050ustar00rootroot00000000000000(** * Discrete category *) Require Import HoTT.Basics GroupoidCategory.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** A discrete category is a groupoid which is a 0-type *) Module Export Core. Definition discrete_category X `{IsHSet X} := groupoid_category X. Arguments discrete_category X {_} / . End Core. Coq-HoTT-9.0/theories/Categories/DualFunctor.v000066400000000000000000000043451474641544500212700ustar00rootroot00000000000000(** * The functor [ᵒᵖ : cat → cat] *) Require Import Category.Core Functor.Core. Require Import Category.Dual Functor.Dual. Require Import Functor.Composition.Core Functor.Identity. Require Import Cat.Core Functor.Paths. Require Import Basics.Trunc Types.Sigma HoTT.Tactics Types.Forall. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Section opposite. Context `{Funext}. Variable P : PreCategory -> Type. Context `{forall C, IsHProp (P C)}. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Let cat := (@sub_pre_cat _ P HF). Hypothesis has_op : forall C : cat, P C.1^op. Definition opposite_functor : Functor cat cat := Build_Functor cat cat (fun C => (C.1^op; has_op _)) (fun _ _ F => F^op)%functor (fun _ _ _ _ _ => idpath) (fun _ => idpath). Let opposite_functor_involutive_helper (x : cat) : (x.1^op^op; has_op (_; has_op _)) = x := path_sigma_uncurried P (((x.1^op)^op)%category; has_op ((x.1^op)%category; has_op x)) x (Category.Dual.opposite_involutive x.1; path_ishprop _ _). Local Open Scope functor_scope. Local Arguments path_sigma_uncurried : simpl never. Definition opposite_functor_involutive : opposite_functor o opposite_functor = 1. Proof. path_functor. refine (path_forall _ _ opposite_functor_involutive_helper; _). repeat (apply path_forall; intro). rewrite !transport_forall_constant. transport_path_forall_hammer. unfold opposite_functor_involutive_helper. rewrite !transport_pr1_path_sigma_uncurried. simpl in *. repeat progress change (fun x => ?f x) with f in *. match goal with | [ |- context[transport (fun x' => ?f x'.1 ?y) (@path_sigma_uncurried ?A ?P ?u ?v ?pq)] ] => rewrite (@transport_pr1_path_sigma_uncurried A P u v pq (fun x => f x y)) end. simpl in *. hnf in *. subst_body. destruct_head @sig. destruct_head @Functor. destruct_head @PreCategory. reflexivity. Qed. End opposite. Coq-HoTT-9.0/theories/Categories/ExponentialLaws.v000066400000000000000000000017201474641544500221510ustar00rootroot00000000000000(** * Exponential Laws *) (** We want to have the following as subdirectories/modules, not at top level. Unfortunately, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *) (** ** Laws about the initial category *) (** *** [x⁰ ≅ 1] *) (** *** [0ˣ ≅ 0] if [x ≠ 0] *) Require ExponentialLaws.Law0. (** ** Laws about the terminal category *) (** *** [x¹ ≅ x] *) (** *** [1ˣ ≅ 1] *) Require ExponentialLaws.Law1. (** ** The law that a sum in an exponent is a product *) (** *** [yⁿ⁺ᵐ ≅ yⁿ × yᵐ] *) Require ExponentialLaws.Law2. (** ** The law that exponentiation distributes over product *) (** *** [(y × z)ⁿ ≅ yⁿ × zⁿ] *) Require ExponentialLaws.Law3. (** ** Currying *) (** *** [(yⁿ)ᵐ ≅ yⁿᵐ] *) Require ExponentialLaws.Law4. Require ExponentialLaws.Tactics. Include ExponentialLaws.Tactics. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/000077500000000000000000000000001474641544500217625ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law0.v000066400000000000000000000060321474641544500227550ustar00rootroot00000000000000(** * Exponential laws about the initial category *) Require Import Category.Core Functor.Core FunctorCategory.Core Functor.Identity. Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors InitialTerminalCategory.NaturalTransformations. Require Import HoTT.Basics HoTT.Types. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. (** In this file, we prove that - [x⁰ ≅ 1] - [0ˣ ≅ 0] if [x ≠ 0] - [0⁰ ≅ 1] *) (** ** x⁰ ≅ 1 *) Section law0. Context `{Funext}. Context `{IsInitialCategory zero}. Context `{IsTerminalCategory one}. Local Notation "0" := zero : category_scope. Local Notation "1" := one : category_scope. Variable C : PreCategory. Global Instance IsTerminalCategory_functors_from_initial : IsTerminalCategory (0 -> C) := {}. (** There is only one functor to the terminal category [1]. *) Definition functor : Functor (0 -> C) 1 := center _. (** We have already proven in [InitialTerminalCategory.v] that [0 -> C] is a terminal category, so there is only one functor to it. *) Definition inverse : Functor 1 (0 -> C) := center _. (** Since the objects and morphisms in terminal categories are contractible, functors to a terminal category are also contractible, by [trunc_functor]. *) Definition law : functor o inverse = 1 /\ inverse o functor = 1 := center _. End law0. (** ** [0ˣ ≅ 0] if [x ≠ 0] *) Section law0'. Context `{Funext}. Context `{IsInitialCategory zero}. Context `{IsTerminalCategory one}. Local Notation "0" := zero : category_scope. Local Notation "1" := one : category_scope. Variable C : PreCategory. Variable c : C. Local Instance IsInitialCategory_functors_to_initial_from_inhabited : IsInitialCategory (C -> 0) := fun P F => @Functors.to_initial_category_empty C _ _ F P c. (** There is exactly one functor from an initial category, and we proved above that if [C] is inhabited, then [C -> 0] is initial. *) Definition functor' : Functor (C -> 0) 0 := center _. (** There is exactly one functor from the initial category [0]. *) Definition inverse' : Functor 0 (C -> 0) := center _. (** Since objects and morphisms in an initial category are -1-truncated, so are functors to an initial category. *) Definition law' : functor' o inverse' = 1 /\ inverse' o functor' = 1 := center _. End law0'. (** ** [0⁰ ≅ 1] *) Section law00. Context `{Funext}. Context `{IsInitialCategory zero}. Context `{IsInitialCategory zero'}. Context `{IsTerminalCategory one}. Local Notation "0" := zero : category_scope. Local Notation "00" := zero' : category_scope. Local Notation "1" := one : category_scope. (** This is just a special case of the first law above. *) Definition functor00 : Functor (0 -> 0) 1 := functor _. Definition inverse00 : Functor 1 (0 -> 0) := inverse _. Definition law00 : functor00 o inverse00 = 1 /\ inverse00 o functor00 = 1 := law _. End law00. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law1.v000066400000000000000000000003511474641544500227540ustar00rootroot00000000000000(** * Laws about the terminal category *) (** ** [x¹ ≅ x] *) (** ** [1ˣ ≅ 1] *) Require ExponentialLaws.Law1.Functors. Require ExponentialLaws.Law1.Law. Include ExponentialLaws.Law1.Functors. Include ExponentialLaws.Law1.Law. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law1/000077500000000000000000000000001474641544500225665ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law1/Functors.v000066400000000000000000000047111474641544500245630ustar00rootroot00000000000000(** * Functors involving functor categories involving the terminal category *) Require Import Category.Core Functor.Core FunctorCategory.Core Functor.Identity NaturalTransformation.Core NaturalTransformation.Paths. Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors InitialTerminalCategory.NaturalTransformations. Require Import HoTT.Basics HoTT.Types. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Section law1. Context `{Funext}. Context `{IsInitialCategory zero}. Context `{IsTerminalCategory one}. Local Notation "0" := zero : category_scope. Local Notation "1" := one : category_scope. Variable C : PreCategory. (** ** [C¹ → C] *) Definition functor : Functor (1 -> C) C := Build_Functor (1 -> C) C (fun F => F (center _)) (fun s d m => m (center _)) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition inverse_morphism_of s d (m : morphism C s d) : morphism (1 -> C) (Functors.from_terminal _ s) (Functors.from_terminal _ d). Proof. refine (Build_NaturalTransformation (Functors.from_terminal _ s) (Functors.from_terminal _ d) (fun _ => m) _). simpl; intros. etransitivity; [ apply right_identity | symmetry; apply left_identity ]. Defined. Global Arguments inverse_morphism_of / _ _ _. (** ** [C → C¹] *) Definition inverse : Functor C (1 -> C). Proof. refine (Build_Functor C (1 -> C) (@Functors.from_terminal _ _ _ _ _) inverse_morphism_of _ _ ); abstract (path_natural_transformation; trivial). Defined. End law1. Section law1'. Context `{Funext}. Context `{IsInitialCategory zero}. Context `{IsTerminalCategory one}. Local Notation "0" := zero : category_scope. Local Notation "1" := one : category_scope. Variable C : PreCategory. Global Instance: IsTerminalCategory (C -> 1) := {}. (** ** [1ˣ → 1] *) Definition functor' : Functor (C -> 1) 1 := Functors.to_terminal _. (** ** [1 → 1ˣ] *) Definition inverse' : Functor 1 (C -> 1) := Functors.to_terminal _. (** ** [1ˣ ≅ 1] *) Definition law' : functor' o inverse' = 1 /\ inverse' o functor' = 1 := center _. End law1'. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law1/Law.v000066400000000000000000000023601474641544500235010ustar00rootroot00000000000000(** * Exponential laws about the terminal category *) Require Import Category.Core Functor.Core Functor.Identity Functor.Paths ExponentialLaws.Law1.Functors Functor.Composition.Core. Require Import InitialTerminalCategory.Core. Require Import Basics.Trunc ExponentialLaws.Tactics. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. (** ** [C¹ ≅ C] *) Section law1. Context `{Funext}. Context `{IsInitialCategory zero}. Context `{IsTerminalCategory one}. Local Notation "0" := zero : category_scope. Local Notation "1" := one : category_scope. Variable C : PreCategory. Definition helper (c : Functor 1 C) : Functors.from_terminal C (c (center _)) = c. Proof. path_functor. exists (path_forall _ _ (fun x => ap (object_of c) (contr _))). abstract ( exp_laws_t; simpl; rewrite <- identity_of; f_ap; symmetry; apply contr ). Defined. Lemma law : @functor _ one _ C o inverse C = 1 /\ inverse C o @functor _ one _ C = 1. Proof. split; path_functor. exists (path_forall _ _ helper). unfold helper. exp_laws_t. Qed. End law1. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law2.v000066400000000000000000000003631474641544500227600ustar00rootroot00000000000000(** * The law that a sum in an exponent is a product *) (** ** [yⁿ⁺ᵐ ≅ yⁿ × yᵐ] *) Require ExponentialLaws.Law2.Functors. Require ExponentialLaws.Law2.Law. Include ExponentialLaws.Law2.Functors. Include ExponentialLaws.Law2.Law. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law2/000077500000000000000000000000001474641544500225675ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law2/Functors.v000066400000000000000000000025751474641544500245720ustar00rootroot00000000000000(** * Exponential functors between products and sums in exponents *) Require Import Functor.Core FunctorCategory.Core Functor.Identity NaturalTransformation.Core Category.Sum Category.Prod Functor.Sum Functor.Prod.Core NaturalTransformation.Sum Functor.Pointwise.Core NaturalTransformation.Paths. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Local Notation fst_type := Basics.Overture.fst. Local Notation snd_type := Basics.Overture.snd. Local Notation pair_type := Basics.Overture.pair. Section law2. Context `{Funext}. Variables D C1 C2 : PreCategory. (** ** [yⁿ⁺ᵐ → yⁿ × yᵐ] *) Definition functor : Functor (C1 + C2 -> D) ((C1 -> D) * (C2 -> D)) := pointwise (inl C1 C2) 1 * pointwise (inr C1 C2) 1. (** ** [yⁿ × yᵐ → yⁿ⁺ᵐ] *) Definition inverse : Functor ((C1 -> D) * (C2 -> D)) (C1 + C2 -> D). Proof. refine (Build_Functor ((C1 -> D) * (C2 -> D)) (C1 + C2 -> D) (fun FG => fst FG + snd FG)%functor (fun _ _ m => fst_type m + snd_type m)%natural_transformation _ _); simpl in *; abstract ( repeat (intros [?|?] || intros [? ?]); simpl in *; apply path_natural_transformation; intros [?|?]; reflexivity ). Defined. End law2. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law2/Law.v000066400000000000000000000027561474641544500235130ustar00rootroot00000000000000(** * Exponential laws about products and sums in exponents *) Require Import Functor.Core. Require Import Category.Sum Functor.Sum. Require Import Functor.Paths. Require Import Functor.Identity Functor.Composition.Core. Require Import Types.Prod ExponentialLaws.Tactics. Require Import ExponentialLaws.Law2.Functors. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. (** ** [yⁿ⁺ᵐ ≅ yⁿ × yᵐ] *) Section Law2. Context `{Funext}. Variables D C1 C2 : PreCategory. Lemma helper1 (c : Functor C1 D * Functor C2 D) : ((1 o (Basics.Overture.fst c + Basics.Overture.snd c) o inl C1 C2)%functor, (1 o (Basics.Overture.fst c + Basics.Overture.snd c) o inr C1 C2)%functor)%core = c. Proof. apply path_prod; simpl; path_functor. Defined. Lemma helper2_helper (c : Functor (C1 + C2) D) x : (1 o c o inl C1 C2 + 1 o c o inr C1 C2) x = c x. Proof. destruct x; reflexivity. Defined. Lemma helper2 (c : Functor (C1 + C2) D) : 1 o c o inl C1 C2 + 1 o c o inr C1 C2 = c. Proof. path_functor. (exists (path_forall _ _ (@helper2_helper c))). abstract exp_laws_t. Defined. Lemma law : functor D C1 C2 o inverse D C1 C2 = 1 /\ inverse D C1 C2 o functor D C1 C2 = 1. Proof. split; path_functor; [ (exists (path_forall _ _ helper1)) | (exists (path_forall _ _ helper2)) ]; exp_laws_t; unfold helper1, helper2; exp_laws_t. Qed. End Law2. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law3.v000066400000000000000000000003721474641544500227610ustar00rootroot00000000000000(** * The law that exponentiation distributes over product *) (** ** [(y × z)ⁿ ≅ yⁿ × zⁿ] *) Require ExponentialLaws.Law3.Functors. Require ExponentialLaws.Law3.Law. Include ExponentialLaws.Law3.Functors. Include ExponentialLaws.Law3.Law. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law3/000077500000000000000000000000001474641544500225705ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law3/Functors.v000066400000000000000000000030011474641544500245540ustar00rootroot00000000000000(** * Functors between an exponential of a product and a product of exponentials *) Require Import Category.Core Functor.Core FunctorCategory.Core Category.Prod. Require Import Functor.Prod Functor.Composition.Core NaturalTransformation.Composition.Laws NaturalTransformation.Composition.Core. Require Import Types.Prod. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. Local Open Scope functor_scope. Local Notation fst_type := Basics.Overture.fst. Local Notation snd_type := Basics.Overture.snd. Local Notation pair_type := Basics.Overture.pair. Section law3. Context `{Funext}. Variables C1 C2 D : PreCategory. (** ** [(y × z)ⁿ → yⁿ × zⁿ] *) Definition functor : Functor (D -> C1 * C2) ((D -> C1) * (D -> C2)) := Build_Functor (D -> C1 * C2) ((D -> C1) * (D -> C2)) (fun H => (fst o H, snd o H)%core) (fun s d m => (fst oL m, snd oL m)%core) (fun _ _ _ _ _ => path_prod' (composition_of_whisker_l _ _ _) (composition_of_whisker_l _ _ _)) (fun _ => path_prod' (whisker_l_right_identity _ _) (whisker_l_right_identity _ _)). (** ** [yⁿ × zⁿ → (y × z)ⁿ] *) (** If we had [Require Functor.Functor.], we could just say [Functor.Prod.functor] here. *) Definition inverse : Functor ((D -> C1) * (D -> C2)) (D -> C1 * C2) := Functor.Prod.Functorial.functor _ _ _. End law3. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law3/Law.v000066400000000000000000000024571474641544500235120ustar00rootroot00000000000000(** * Laws about an exponential of a product and a product of exponentials *) Require Import Category.Core Functor.Core. Require Import Functor.Prod. Require Import Functor.Paths. Require Import Functor.Identity Functor.Composition.Core. Require Import ExponentialLaws.Law3.Functors. Require Import Types.Prod ExponentialLaws.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. (** ** [(y × z)ⁿ ≅ yⁿ × zⁿ] *) Section Law3. Context `{Funext}. Variables C1 C2 D : PreCategory. Lemma helper (c : Functor D C1 * Functor D C2) : ((fst o (Basics.Overture.fst c * Basics.Overture.snd c))%functor, (snd o (Basics.Overture.fst c * Basics.Overture.snd c))%functor)%core = c. Proof. apply path_prod; [ apply compose_fst_prod | apply compose_snd_prod ]. Defined. Lemma Law : functor C1 C2 D o inverse C1 C2 D = 1 /\ inverse C1 C2 D o functor C1 C2 D = 1. Proof. split; path_functor; [ (exists (path_forall _ _ helper)) | (exists (path_forall _ _ (fun _ => Functor.Prod.Universal.unique idpath idpath))) ]; exp_laws_t; unfold helper, compose_fst_prod, compose_snd_prod, Functor.Prod.Universal.unique, Functor.Prod.Universal.unique_helper; exp_laws_t. Qed. End Law3. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law4.v000066400000000000000000000003071474641544500227600ustar00rootroot00000000000000(** * Currying *) (** ** [(yⁿ)ᵐ ≅ yⁿᵐ] *) Require ExponentialLaws.Law4.Functors. Require ExponentialLaws.Law4.Law. Include ExponentialLaws.Law4.Functors. Include ExponentialLaws.Law4.Law. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law4/000077500000000000000000000000001474641544500225715ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law4/Functors.v000066400000000000000000000133521474641544500245670ustar00rootroot00000000000000(** * Functors about currying, between [C₁ × C₂ → D] and [C₁ → (C₂ → D)] *) Require Import Category.Core Category.Prod FunctorCategory.Core Functor.Core NaturalTransformation.Core NaturalTransformation.Paths. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Section law4. Context `{Funext}. Variables C1 C2 D : PreCategory. Local Open Scope morphism_scope. Local Ltac do_exponential4_helper rew_comp := intros; simpl; repeat (simpl; match goal with | _ => reflexivity | _ => progress rew_comp | _ => rewrite !identity_of | _ => rewrite !left_identity | _ => rewrite !right_identity | _ => rewrite ?associativity; progress f_ap | _ => rewrite <- ?associativity; progress f_ap | _ => rewrite !commutes | _ => rewrite ?associativity, !commutes | _ => rewrite <- ?associativity, !commutes end). (** ** [(yⁿ)ᵐ → yⁿᵐ] *) Section functor. Local Ltac do_exponential4 := do_exponential4_helper ltac:(rewrite !composition_of). Definition functor_object_of : (C1 -> (C2 -> D))%category -> (C1 * C2 -> D)%category. Proof. intro F; hnf in F |- *. refine (Build_Functor (C1 * C2) D (fun c1c2 => F (fst c1c2) (snd c1c2)) (fun s d m => F (fst d) _1 (snd m) o (F _1 (fst m)) (snd s)) _ _); abstract do_exponential4. Defined. Definition functor_morphism_of s d (m : morphism (C1 -> (C2 -> D)) s d) : morphism (C1 * C2 -> D) (functor_object_of s) (functor_object_of d). Proof. simpl. refine (Build_NaturalTransformation (functor_object_of s) (functor_object_of d) (fun c => m (fst c) (snd c)) _); abstract ( repeat match goal with | [ |- context[components_of ?T ?x o components_of ?U ?x] ] => change (T x o U x) with ((compose (C := (_ -> _)) T U) x) | _ => f_ap | _ => rewrite !commutes | _ => do_exponential4 end ). Defined. Definition functor : Functor (C1 -> (C2 -> D)) (C1 * C2 -> D). Proof. refine (Build_Functor (C1 -> (C2 -> D)) (C1 * C2 -> D) functor_object_of functor_morphism_of _ _); abstract by path_natural_transformation. Defined. End functor. (** ** [yⁿᵐ → (yⁿ)ᵐ] *) Section inverse. Local Ltac do_exponential4_inverse := do_exponential4_helper ltac:(rewrite <- !composition_of). Section object_of. Variable F : Functor (C1 * C2) D. Definition inverse_object_of_object_of : C1 -> (C2 -> D)%category. Proof. intro c1. refine (Build_Functor C2 D (fun c2 => F (c1, c2)) (fun s2 d2 m2 => F _1 ((identity c1, m2) : morphism (_ * _) (c1, s2) (c1, d2))) _ _); abstract do_exponential4_inverse. Defined. Definition inverse_object_of_morphism_of s d (m : morphism C1 s d) : morphism (C2 -> D) (inverse_object_of_object_of s) (inverse_object_of_object_of d). Proof. refine (Build_NaturalTransformation (inverse_object_of_object_of s) (inverse_object_of_object_of d) (fun c => F _1 ((m, identity c) : morphism (_ * _) (s, c) (d, c))) _); abstract do_exponential4_inverse. Defined. Definition inverse_object_of : (C1 -> (C2 -> D))%category. Proof. refine (Build_Functor C1 (C2 -> D) inverse_object_of_object_of inverse_object_of_morphism_of _ _); abstract (path_natural_transformation; do_exponential4_inverse). Defined. End object_of. Section morphism_of. Definition inverse_morphism_of_components_of s d (m : morphism (C1 * C2 -> D) s d) : forall c, morphism (C2 -> D) ((inverse_object_of s) c) ((inverse_object_of d) c). Proof. intro c. refine (Build_NaturalTransformation ((inverse_object_of s) c) ((inverse_object_of d) c) (fun c' => m (c, c')) _). abstract do_exponential4_inverse. Defined. Definition inverse_morphism_of s d (m : morphism (C1 * C2 -> D) s d) : morphism (C1 -> (C2 -> D)) (inverse_object_of s) (inverse_object_of d). Proof. refine (Build_NaturalTransformation (inverse_object_of s) (inverse_object_of d) (inverse_morphism_of_components_of m) _). abstract (path_natural_transformation; do_exponential4_inverse). Defined. End morphism_of. Arguments inverse_morphism_of_components_of / _ _ _ _ . Definition inverse : Functor (C1 * C2 -> D) (C1 -> (C2 -> D)). Proof. refine (Build_Functor (C1 * C2 -> D) (C1 -> (C2 -> D)) inverse_object_of inverse_morphism_of _ _); abstract by path_natural_transformation. Defined. End inverse. End law4. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Law4/Law.v000066400000000000000000000025171474641544500235100ustar00rootroot00000000000000(** * Law about currying *) Require Import Category.Core Functor.Core. Require Import Functor.Paths. Require Import Functor.Identity Functor.Composition.Core. Require Import ExponentialLaws.Law4.Functors. Require Import ExponentialLaws.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. (** ** [(C₁ × C₂ → D) ≅ (C₁ → (C₂ → D))] *) Section Law4. Context `{Funext}. Variables C1 C2 D : PreCategory. Lemma helper1 c : functor C1 C2 D (inverse C1 C2 D c) = c. Proof. path_functor. abstract ( exp_laws_t; rewrite <- composition_of; exp_laws_t ). Defined. Lemma helper2_helper c x : inverse C1 C2 D (functor C1 C2 D c) x = c x. Proof. path_functor. abstract exp_laws_t. Defined. Lemma helper2 c : inverse C1 C2 D (functor C1 C2 D c) = c. Proof. path_functor. exists (path_forall _ _ (helper2_helper c)). abstract (unfold helper2_helper; exp_laws_t). Defined. Lemma law : functor C1 C2 D o inverse C1 C2 D = 1 /\ inverse C1 C2 D o functor C1 C2 D = 1. Proof. split; path_functor; [ (exists (path_forall _ _ helper1)) | (exists (path_forall _ _ helper2)) ]; unfold helper1, helper2, helper2_helper; exp_laws_t. Qed. End Law4. Coq-HoTT-9.0/theories/Categories/ExponentialLaws/Tactics.v000066400000000000000000000076721474641544500235570ustar00rootroot00000000000000(** * Miscellaneous helper tactics for proving exponential laws *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Paths NaturalTransformation.Paths. Require Import HoTT.Tactics Basics.PathGroupoids Types.Forall Types.Prod. (** These are probably more general than just exponential laws, but I haven't tried them more widely, yet. *) (** Miscellaneous tactics to try *) Ltac exp_laws_misc_t' := idtac; match goal with | _ => reflexivity | _ => progress intros | _ => progress simpl in * | _ => apply (@path_forall _); intro | _ => rewrite !identity_of | _ => progress autorewrite with morphism end. (** Safe transformations to simplify complex types in the hypotheses or goal *) Ltac exp_laws_simplify_types' := idtac; match goal with | [ H : (_ + _) |- _ ] => destruct H | [ H : Unit |- _ ] => destruct H | [ H : Empty |- _ ] => destruct H | [ H : (_ * _) |- _ ] => destruct H | [ |- _ = _ :> Functor _ _ ] => progress path_functor | [ |- _ = _ :> NaturalTransformation _ _ ] => progress path_natural_transformation | [ |- _ = _ :> prod _ _ ] => apply path_prod end. (** Do some simplifications of contractible types *) Ltac exp_laws_handle_contr' := idtac; match goal with | [ H : Contr ?T, x : ?T |- _ ] => progress destruct (contr x) | [ H : forall a, Contr (?T a), x : ?T _ |- _ ] => progress destruct (contr x) | [ H : forall a b, Contr (?T a b), x : ?T _ _ |- _ ] => progress destruct (contr x) | [ |- context[contr (center ?x)] ] => progress let H := fresh in assert (H : idpath = contr (center x)) by exact (center _); destruct H end. (** Try to simplify [transport] with some heuristics *) Ltac exp_laws_handle_transport' := idtac; match goal with | _ => progress rewrite ?transport_forall_constant, ?path_forall_2_beta, ?transport_const, ?transport_path_prod | [ |- context [path_functor_uncurried ?F ?G (?x; ?y)] ] (* https://coq.inria.fr/bugs/show_bug.cgi?id=3768 *) => rewrite (@path_functor_uncurried_fst _ _ _ F G x y) | [ |- context[transport (fun y : Functor ?C ?D => ?f (y _0 ?x)%object)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (y' x)) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (y _0 ?x)%object ?z)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (y' x) z) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (y _0 ?x)%object ?z)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (y' x) z) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (?g (y _0 ?x)%object))] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (g (y' x))) (@object_of C D)) | [ |- context[transport (fun y : Functor ?C ?D => ?f (?g (y _0 ?x)%object) ?z)] ] => rewrite (fun a b => @transport_compose _ _ a b (fun y' => f (g (y' x)) z) (@object_of C D)) | _ => progress transport_path_forall_hammer | [ |- context[components_of (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => components_of) z) | [ |- context[object_of (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => object_of) z) | [ |- context[morphism_of (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => morphism_of) z) | [ |- context[fst (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => fst) z) | [ |- context[snd (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => snd) z) | [ |- context[pr1 (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => pr1) z) end. Ltac exp_laws_t' := first [ exp_laws_misc_t' | exp_laws_simplify_types' | exp_laws_handle_contr' | exp_laws_handle_transport' ]. Ltac exp_laws_t := repeat exp_laws_t'. Coq-HoTT-9.0/theories/Categories/Functor.v000066400000000000000000000024201474641544500204520ustar00rootroot00000000000000(** * Functors *) (** Since there are only notations in [Functor.Notations], we can just export those. *) Require Export Functor.Notations. (** ** Definition *) Require Functor.Core. (** ** Composition *) Require Functor.Composition.Core. (** ** Duals *) Require Functor.Dual. (** ** Identity *) Require Functor.Identity. (** ** Classification of path space *) Require Functor.Paths. (** ** Product functors *) Require Functor.Prod.Core. (** ** Coproduct functors *) Require Functor.Sum. (** ** Full, Faithful, Fully Faithful *) Require Functor.Attributes. (** ** Pointwise functors (functoriality of functor category construction) *) Require Functor.Pointwise.Core. Include Functor.Composition.Core. Include Functor.Core. Include Functor.Dual. Include Functor.Identity. Include Functor.Paths. Include Functor.Prod.Core. Include Functor.Sum. Include Functor.Attributes. Include Functor.Pointwise.Core. (** We want to have the following as subdirectories/modules, not at top level. Unfortunately, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *) Require Functor.Pointwise. (** We don't want to make utf-8 notations the default, so we don't export them. *) Coq-HoTT-9.0/theories/Categories/Functor/000077500000000000000000000000001474641544500202655ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Functor/Attributes.v000066400000000000000000000116741474641544500226130ustar00rootroot00000000000000(** * Attributes of functors (full, faithful, split essentially surjective) *) Require Import Category.Core Functor.Core HomFunctor Category.Morphisms Category.Dual Functor.Dual Category.Prod Functor.Prod NaturalTransformation.Core SetCategory.Core Functor.Composition.Core. Require Import Basics.Trunc Types.Universe HIT.iso HoTT.Truncations.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Section full_faithful. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor C D. (** ** Natural transformation [hom_C(─, ─) → hom_D(Fᵒᵖ(─), F(─))] *) (** TODO(JasonGross): Come up with a better name and location for this. *) Definition induced_hom_natural_transformation : NaturalTransformation (hom_functor C) (hom_functor D o (F^op, F)). Proof. refine (Build_NaturalTransformation (hom_functor C) (hom_functor D o (F^op, F)) (fun (sd : object (C^op * C)) m => (F _1 m)%morphism) _ ). abstract ( repeat (intros [] || intro); simpl in *; repeat (apply path_forall; intro); simpl; rewrite !composition_of; reflexivity ). Defined. (** ** Full *) Class IsFull := is_full : forall x y : C, IsEpimorphism (induced_hom_natural_transformation (x, y)). (** ** Faithful *) Class IsFaithful := is_faithful : forall x y : C, IsMonomorphism (induced_hom_natural_transformation (x, y)). (** ** Fully Faithful *) Class IsFullyFaithful := is_fully_faithful : forall x y : C, IsIsomorphism (induced_hom_natural_transformation (x, y)). (** ** Fully Faithful → Full *) Global Instance isfull_isfullyfaithful `{IsFullyFaithful} : IsFull. Proof. intros ? ?; hnf in * |- . typeclasses eauto. Qed. (** ** Fully Faithful → Faithful *) Global Instance isfaithful_isfullyfaithful `{IsFullyFaithful} : IsFaithful. Proof. intros ? ?; hnf in * |- . typeclasses eauto. Qed. (** ** Full * Faithful → Fully Faithful *) (** We start with a helper method, which assumes that epi * mono → iso, and ten prove this assumption *) Lemma isfullyfaithful_isfull_isfaithful_helper `{IsFull} `{IsFaithful} (H' : forall x y (m : morphism set_cat x y), IsEpimorphism m -> IsMonomorphism m -> IsIsomorphism m) : IsFullyFaithful. Proof. intros ? ?; hnf in * |- . apply H'; eauto. Qed. End full_faithful. Section fully_faithful_helpers. Context `{ua : Univalence}. Variables x y : HSet. Variable m : x -> y. Lemma isisomorphism_isequiv_set_cat `{H' : IsEquiv _ _ m} : IsIsomorphism (m : morphism set_cat x y). Proof. exists (m^-1)%core; apply path_forall; intro; destruct H'; simpl in *; eauto. Qed. Definition isequiv_isepimorphism_ismonomorphism (Hepi : IsEpimorphism (m : morphism set_cat x y)) (Hmono : IsMonomorphism (m : morphism set_cat x y)) : @IsEquiv _ _ m (* NB: This depends on the (arguably accidental) fact that `ismono` and `isepi` from HoTT core are *definitionally* identical to the specialization of `IsMonomorphism` and `IsEpimorphism` to the category of sets. *) := @isequiv_isepi_ismono _ x y m Hepi Hmono. End fully_faithful_helpers. Global Instance isfullyfaithful_isfull_isfaithful `{Univalence} `{Hfull : @IsFull _ C D F} `{Hfaithful : @IsFaithful _ C D F} : @IsFullyFaithful _ C D F := fun x y => @isisomorphism_isequiv_set_cat _ _ _ _ (@isequiv_isepimorphism_ismonomorphism _ _ _ _ (Hfull x y) (Hfaithful x y)). (** ** Split Essentially Surjective *) (** Quoting the HoTT Book: We say a functor [F : A → B] is _split essentially surjective_ if for all [b : B] there exists an [a : A] such that [F a ≅ b]. *) Class IsSplitEssentiallySurjective A B (F : Functor A B) := is_split_essentially_surjective : forall b : B, exists a : A, F a <~=~> b. (** ** Essentially Surjective *) (** Quoting the HoTT Book: A functor [F : A → B] is _split essentially surjective_ if for all [b : B] there _merely_ exists an [a : A] such that [F a ≅ b]. *) Class IsEssentiallySurjective A B (F : Functor A B) := is_essentially_surjective : forall b : B, hexists (fun a : A => F a <~=~> b). (** ** Weak Equivalence *) (** Quoting the HoTT Book: We say [F] is a _weak equivalence_ if it is fully faithful and essentially surjective. *) Class IsWeakEquivalence `{Funext} A B (F : Functor A B) := { is_fully_faithful__is_weak_equivalence : IsFullyFaithful F; is_essentially_surjective__is_weak_equivalence : IsEssentiallySurjective F }. #[export] Existing Instances is_fully_faithful__is_weak_equivalence is_essentially_surjective__is_weak_equivalence. Coq-HoTT-9.0/theories/Categories/Functor/Composition.v000066400000000000000000000007771474641544500227720ustar00rootroot00000000000000(** * Composition of functors *) (** ** Definition of composition *) Require Functor.Composition.Core. (** ** Functoriality of composition *) Require Functor.Composition.Functorial. (** ** Laws about functor composition *) Require Functor.Composition.Laws. Include Functor.Composition.Core. Include Functor.Composition.Functorial. Include Functor.Composition.Laws. Module Export FunctorCompositionNotations. Include Functor.Composition.Core.FunctorCompositionCoreNotations. End FunctorCompositionNotations. Coq-HoTT-9.0/theories/Categories/Functor/Composition/000077500000000000000000000000001474641544500225705ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Functor/Composition/Core.v000066400000000000000000000035671474641544500236620ustar00rootroot00000000000000(** * Composition of functors *) Require Import Category.Core Functor.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section composition. Variables B C D E : PreCategory. Variable G : Functor D E. Variable F : Functor C D. (** We usually don't want to see the proofs of composition in functors, because the proofs are hProps, and so we don't care about them. But occasionally, we want to be able to reduce the proofs. Having the proofs transparent allows the composition of the identity functor with itself to be judgementally the identity. Since the only way to hide something from within a proof is [abstract], and that makes the definitions opaque, we need to define the laws separately. *) Local Notation c_object_of c := (G (F c)) (only parsing). Local Notation c_morphism_of m := (G _1 (F _1 m)) (only parsing). Definition compose_composition_of s d d' (m1 : morphism C s d) (m2 : morphism C d d') : c_morphism_of (m2 o m1) = c_morphism_of m2 o c_morphism_of m1 := transport (@paths _ (c_morphism_of (m2 o m1))) (composition_of G _ _ _ _ _) (ap (fun m => G _1 m) (composition_of F _ _ _ m1 m2)). Definition compose_identity_of x : c_morphism_of (identity x) = identity (c_object_of x) := transport (@paths _ _) (identity_of G _) (ap (fun m => G _1 m) (identity_of F x)). Definition compose : Functor C E := Build_Functor C E (fun c => G (F c)) (fun _ _ m => G _1 (F _1 m)) compose_composition_of compose_identity_of. End composition. Global Arguments compose_composition_of / . Global Arguments compose_identity_of / . Module Export FunctorCompositionCoreNotations. Infix "o" := compose : functor_scope. End FunctorCompositionCoreNotations. Coq-HoTT-9.0/theories/Categories/Functor/Composition/Functorial.v000066400000000000000000000003011474641544500250570ustar00rootroot00000000000000Require Functor.Composition.Functorial.Core. Require Functor.Composition.Functorial.Attributes. Include Functor.Composition.Functorial.Core. Include Functor.Composition.Functorial.Attributes. Coq-HoTT-9.0/theories/Categories/Functor/Composition/Functorial/000077500000000000000000000000001474641544500246765ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Functor/Composition/Functorial/Attributes.v000066400000000000000000000045311474641544500272160ustar00rootroot00000000000000(** * Attributes of Functoriality of functor composition *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Functorial.Core. Require Import NaturalTransformation.Composition.Core. Require Import NaturalTransformation.Isomorphisms. Require Import Functor.Attributes. Require Import FunctorCategory.Core. Require Import Category.Morphisms. Require Import NaturalTransformation.Paths. Require Import HoTT.Truncations.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope natural_transformation_scope. Local Open Scope morphism_scope. (** ** Precomposition with an essentially surjective functor is faithful *) Section faithfull_precomposition_essential_surjective. (** Quoting the HoTT Book: Lemma. If [A], [B], [C] are precategories and [H : A → B] is an essentially surjective functor, then [(– ∘ H) : (B → C) → (A → C)] is faithful. *) Context `{fs : Funext}. Variables A B C : PreCategory. Variable H : Functor A B. Context `{H_is_essentially_surjective : IsEssentiallySurjective A B H}. Lemma isfaithful_precomposition_essentially_surjective_helper (F G : Functor B C) (T U : NaturalTransformation F G) (a : A) (b : B) (f : H a <~=~> b) (H' : T oR H = U oR H) : T b = U b. Proof. apply (ap components_of) in H'. apply apD10 in H'; hnf in H'; simpl in H'. rewrite <- !(path_components_of_isomorphic' f). rewrite H'. reflexivity. Qed. Global Instance isfaithful_precomposition_essentially_surjective : @IsFaithful _ (B -> C) (A -> C) (compose_functor _ _ _ H). Proof. repeat match goal with | _ => eapply isfaithful_precomposition_essentially_surjective_helper; eassumption | _ => intro | _ => progress hnf in * | _ => progress simpl in * | _ => apply path_forall | _ => progress strip_truncations | [ H : _ |- _ ] => apply ap10 in H | _ => progress path_natural_transformation | [ H : sig _ |- _ ] => destruct H | [ H : _, t : _ |- _ ] => generalize dependent (H t); clear H end. Qed. End faithfull_precomposition_essential_surjective. Coq-HoTT-9.0/theories/Categories/Functor/Composition/Functorial/Core.v000066400000000000000000000036271474641544500257650ustar00rootroot00000000000000(** * Functoriality of functor composition *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Core NaturalTransformation.Composition.Core. Require Import Category.Prod FunctorCategory.Core NaturalTransformation.Composition.Functorial NaturalTransformation.Composition.Laws ExponentialLaws.Law4.Functors. Require Import NaturalTransformation.Paths. Require ProductLaws. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** Construction of the functor [_∘_ : (C → D) × (D → E) → (C → E)] and its curried variant *) Section functorial_composition. Context `{Funext}. Variables C D E : PreCategory. Local Open Scope natural_transformation_scope. Definition compose_functor_morphism_of s d (m : morphism (C -> D) s d) : morphism ((D -> E) -> (C -> E)) (whiskerR_functor _ s) (whiskerR_functor _ d) := Build_NaturalTransformation (whiskerR_functor E s) (whiskerR_functor E d) (fun x => x oL m) (fun _ _ _ => exchange_whisker _ _). Definition compose_functor : object ((C -> D) -> ((D -> E) -> (C -> E))). Proof. refine (Build_Functor (C -> D) ((D -> E) -> (C -> E)) (@whiskerR_functor _ _ _ _) compose_functor_morphism_of _ _); abstract ( path_natural_transformation; rewrite ?composition_of, ?identity_of; reflexivity ). Defined. Definition compose_functor_uncurried : object ((C -> D) * (D -> E) -> (C -> E)) := ExponentialLaws.Law4.Functors.functor _ _ _ compose_functor. Definition compose_functor' : object ((D -> E) -> ((C -> D) -> (C -> E))) := ExponentialLaws.Law4.Functors.inverse _ _ _ (compose_functor_uncurried o ProductLaws.Swap.functor _ _)%functor. End functorial_composition. Coq-HoTT-9.0/theories/Categories/Functor/Composition/Laws.v000066400000000000000000000102151474641544500236640ustar00rootroot00000000000000(** * Laws about composition of functors *) Require Import Category.Core Functor.Core Functor.Composition.Core Functor.Identity. Require Import Functor.Paths. Require Import Basics.PathGroupoids Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section identity_lemmas. Context `{Funext}. Variables C D : PreCategory. Local Open Scope functor_scope. (** ** left identity : [1 ∘ F = F] *) (** If we had that [match (p : a = b) in (_ = y) return (a = y) with idpath => idpath end ≡ p] (a form of eta for paths), this would be judgemental. *) Lemma left_identity (F : Functor C D) : 1 o F = F. Proof. by path_functor. Defined. (** ** right identity : [F ∘ 1 = F] *) Lemma right_identity (F : Functor C D) : F o 1 = F. Proof. by path_functor. Defined. (** ** Action of left and right identity laws on objects *) Definition left_identity_fst F : ap object_of (left_identity F) = idpath := @path_functor_uncurried_fst _ _ _ (1 o F) F 1 1. Definition right_identity_fst F : ap object_of (right_identity F) = idpath := @path_functor_uncurried_fst _ _ _ (F o 1) F 1 1. End identity_lemmas. #[export] Hint Rewrite @left_identity @right_identity : category. #[export] Hint Rewrite @left_identity @right_identity : functor. #[export] Hint Immediate left_identity right_identity : category functor. Section composition_lemmas. Context `{fs : Funext}. Variables B C D E : PreCategory. Local Open Scope functor_scope. (** ** associativity : [(H ∘ G) ∘ F = H ∘ (G ∘ F)] *) Lemma associativity (F : Functor B C) (G : Functor C D) (H : Functor D E) : (H o G) o F = H o (G o F). Proof. by path_functor. Defined. (** ** Action of associativity on objects *) Definition associativity_fst F G H : ap object_of (associativity F G H) = idpath := @path_functor_uncurried_fst _ _ _ ((H o G) o F) (H o (G o F)) 1%path 1%path. End composition_lemmas. #[export] Hint Resolve associativity : category functor. Section coherence. Context `{fs : Funext}. Local Open Scope path_scope. Local Open Scope functor_scope. Local Ltac coherence_t := repeat match goal with | [ |- _ = _ :> (_ = _ :> Functor _ _) ] => apply path_path_functor_uncurried | _ => reflexivity | _ => progress rewrite ?ap_pp, ?concat_1p, ?concat_p1 | _ => progress rewrite ?associativity_fst, ?left_identity_fst, ?right_identity_fst | _ => progress push_ap_object_of end. (** ** coherence triangle *) (** The following triangle is coherent << G ∘ (1 ∘ F) === (G ∘ 1) ∘ F \\ // \\ // \\ // \\ // \\ // \\ // G ∘ F >> *) Lemma triangle C D E (F : Functor C D) (G : Functor D E) : (associativity F 1 G @ ap (compose G) (left_identity F)) = (ap (fun G' : Functor D E => G' o F) (right_identity G)). Proof. coherence_t. Qed. (** ** coherence pentagon *) (** The following pentagon is coherent << K ∘ (H ∘ (G ∘ F)) // \\ // \\ // \\ // \\ // \\ (K ∘ H) ∘ (G ∘ F) K ∘ ((H ∘ G) ∘ F) || || || || || || || || || || ((K ∘ H) ∘ G) ∘ F ====== (K ∘ (H ∘ G)) ∘ F >> *) Lemma pentagon A B C D E (F : Functor A B) (G : Functor B C) (H : Functor C D) (K : Functor D E) : (associativity F G (K o H) @ associativity (G o F) H K) = (ap (fun KHG => KHG o F) (associativity G H K) @ associativity F (H o G) K @ ap (compose K) (associativity F G H)). Proof. coherence_t. Qed. End coherence. Arguments associativity : simpl never. Arguments left_identity : simpl never. Arguments right_identity : simpl never. Coq-HoTT-9.0/theories/Categories/Functor/Core.v000066400000000000000000000045251474641544500213520ustar00rootroot00000000000000(** * Definition of a functor *) Require Import Category.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Declare Scope functor_scope. Delimit Scope functor_scope with functor. Local Open Scope morphism_scope. Section Functor. Variables C D : PreCategory. (** Quoting from the lecture notes for MIT's 18.705, Commutative Algebra: A map of categories is known as a functor. Namely, given categories [C] and [C'], a (covariant) functor [F : C -> C'] is a rule that assigns to each object [A] of [C] an object [F A] of [C'] and to each map [m : A -> B] of [C] a map [F m : F A -> F B] of [C'] preserving composition and identity; that is, (1) [F (m' ∘ m) = (F m') ∘ (F m)] for maps [m : A -> B] and [m' : B -> C] of [C], and (2) [F (id A) = id (F A)] for any object [A] of [C], where [id A] is the identity morphism of [A]. **) Record Functor := { object_of :> C -> D; morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); composition_of : forall s d d' (m1 : morphism C s d) (m2: morphism C d d'), morphism_of _ _ (m2 o m1) = (morphism_of _ _ m2) o (morphism_of _ _ m1); identity_of : forall x, morphism_of _ _ (identity x) = identity (object_of x) }. End Functor. Bind Scope functor_scope with Functor. Create HintDb functor discriminated. Arguments Functor C D : assert. Arguments object_of {C%_category D%_category} F%_functor c%_object : rename, simpl nomatch. Arguments morphism_of [C%_category] [D%_category] F%_functor [s%_object d%_object] m%_morphism : rename, simpl nomatch. Arguments composition_of [C D] F _ _ _ _ _ : rename. Arguments identity_of [C D] F _ : rename. Module Export FunctorCoreNotations. (** Perhaps we should consider making this more global? *) Local Notation "C --> D" := (Functor C D) : type_scope. Notation "F '_0' x" := (object_of F x) : object_scope. Notation "F '_1' m" := (morphism_of F m) : morphism_scope. End FunctorCoreNotations. #[export] Hint Resolve composition_of identity_of : category functor. #[export] Hint Rewrite identity_of : category. #[export] Hint Rewrite identity_of : functor. Coq-HoTT-9.0/theories/Categories/Functor/Dual.v000066400000000000000000000016731474641544500213500ustar00rootroot00000000000000(** * Opposite functors *) Require Category.Dual. Import Category.Dual.CategoryDualNotations. Require Import Category.Core Functor.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. (** ** Definition of [Fᵒᵖ] *) Definition opposite C D (F : Functor C D) : Functor C^op D^op := Build_Functor (C^op) (D^op) (object_of F) (fun s d (m : morphism C^op s d) => (F _1 m)%morphism) (fun d' d s m1 m2 => composition_of F s d d' m2 m1) (identity_of F). Local Notation "F ^op" := (opposite F) : functor_scope. Local Open Scope functor_scope. (** ** [ᵒᵖ] is judgmentally involutive *) Definition opposite_involutive C D (F : Functor C D) : (F^op)^op = F := idpath. Module Export FunctorDualNotations. Notation "F ^op" := (opposite F) : functor_scope. End FunctorDualNotations. Coq-HoTT-9.0/theories/Categories/Functor/Identity.v000066400000000000000000000011501474641544500222420ustar00rootroot00000000000000(** * Identity functor *) Require Import Category.Core Functor.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section identity. (** There is an identity functor. It does the obvious thing. *) Definition identity C : Functor C C := Build_Functor C C (fun x => x) (fun _ _ x => x) (fun _ _ _ _ _ => idpath) (fun _ => idpath). End identity. Module Export FunctorIdentityNotations. Notation "1" := (identity _) : functor_scope. End FunctorIdentityNotations. Coq-HoTT-9.0/theories/Categories/Functor/Notations.v000066400000000000000000000007461474641544500224410ustar00rootroot00000000000000(** * Notations for functors *) Require Import Basics.Notations. Require Functor.Composition. Require Functor.Core. Require Functor.Dual. Require Functor.Identity. Require Functor.Prod. Require Functor.Sum. Include Functor.Composition.FunctorCompositionNotations. Include Functor.Core.FunctorCoreNotations. Include Functor.Dual.FunctorDualNotations. Include Functor.Identity.FunctorIdentityNotations. Include Functor.Prod.FunctorProdNotations. Include Functor.Sum.FunctorSumNotations. Coq-HoTT-9.0/theories/Categories/Functor/Paths.v000066400000000000000000000161761474641544500215460ustar00rootroot00000000000000(** * Classification of path spaces of functors *) Require Import Category.Core Functor.Core. Require Import HoTT.Basics HoTT.Types HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope morphism_scope. Local Open Scope functor_scope. Section path_functor. Context `{Funext}. Variables C D : PreCategory. Local Notation functor_sig_T := { OO : C -> D | { MO : forall s d, morphism C s d -> morphism D (OO s) (OO d) | { FCO : forall s d d' (m1 : morphism C s d) (m2 : morphism C d d'), MO _ _ (m2 o m1) = MO d d' m2 o MO s d m1 | forall x, MO x x (identity x) = identity (OO x) } } } (only parsing). (** ** Equivalence between the record and sigma-type versions of a functor *) Lemma equiv_sig_functor : functor_sig_T <~> Functor C D. Proof. issig. Defined. (** We could leave it at that and be done with it, but we want a more convenient form for actually constructing paths between functors. For this, we write a trimmed down version of something equivalent to the type of paths between functors. *) Local Notation path_functor'_T F G := { HO : object_of F = object_of G | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) HO (morphism_of F) = morphism_of G } (only parsing). (** We could just go prove that the path space of [functor_sig_T] is equivalent to [path_functor'_T], but unification is far too slow to do this effectively. So instead we explicitly classify [path_functor'_T], and provide an equivalence between it and the path space of [Functor C D]. *) (** << Definition equiv_path_functor_uncurried_sig (F G : Functor C D) : path_functor'_T F G <~> (@equiv_inv _ _ _ equiv_sig_functor F = @equiv_inv _ _ _ equiv_sig_functor G). Proof. etransitivity; [ | by apply equiv_path_sigma ]. eapply @equiv_functor_sigma. repeat match goal with | [ |- context[(@equiv_inv ?A ?B ?f ?H ?F).1] ] => change ((@equiv_inv A B f H F).1) with (object_of F) end. Time exact (isequiv_idmap (object_of F = object_of G)). (* 13.411 secs *) Abort. >> *) (** ** Classify sufficient conditions to prove functors equal *) Definition path_functor_uncurried (F G : Functor C D) : path_functor'_T F G -> F = G. Proof. intros [? ?]. destruct F, G; simpl in *. path_induction; simpl. f_ap; eapply @center; abstract exact _. Defined. (** *** Said proof respects [object_of] *) Lemma path_functor_uncurried_fst F G HO HM : ap object_of (@path_functor_uncurried F G (HO; HM)) = HO. Proof. destruct F, G; simpl in *. path_induction_hammer. Qed. (** *** Said proof respects [idpath] *) Lemma path_functor_uncurried_idpath F : @path_functor_uncurried F F (idpath; idpath) = idpath. Proof. destruct F; simpl in *. rewrite !(contr idpath). reflexivity. Qed. (** ** Equality of functors gives rise to an inhabitant of the path-classifying-type *) Definition path_functor_uncurried_inv (F G : Functor C D) : F = G -> path_functor'_T F G := fun H' => (ap object_of H'; (transport_compose _ object_of _ _) ^ @ apD (@morphism_of _ _) H')%path. (** ** Curried version of path classifying lemma *) Definition path_functor (F G : Functor C D) (HO : object_of F = object_of G) (HM : transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) HO (morphism_of F) = morphism_of G) : F = G := path_functor_uncurried F G (HO; HM). (** ** Curried version of path classifying lemma, using [forall] in place of equality of functions *) Definition path_functor_pointwise (F G : Functor C D) (HO : object_of F == object_of G) (HM : forall s d m, transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) (path_forall _ _ HO) (morphism_of F) s d m = G _1 m) : F = G. Proof. refine (path_functor F G (path_forall _ _ HO) _). repeat (apply path_forall; intro); apply HM. Defined. (** ** Classify equality of functors up to equivalence *) Global Instance isequiv_path_functor_uncurried (F G : Functor C D) : IsEquiv (@path_functor_uncurried F G). Proof. apply (isequiv_adjointify (@path_functor_uncurried F G) (@path_functor_uncurried_inv F G)). - hnf. intros []. apply path_functor_uncurried_idpath. - hnf. intros [? ?]. apply path_sigma_uncurried. exists (path_functor_uncurried_fst _ _ _). exact (center _). Defined. Definition equiv_path_functor_uncurried (F G : Functor C D) : path_functor'_T F G <~> F = G := Build_Equiv _ _ (@path_functor_uncurried F G) _. Local Open Scope function_scope. Definition path_path_functor_uncurried (F G : Functor C D) (p q : F = G) : ap object_of p = ap object_of q -> p = q. Proof. refine ((ap (@path_functor_uncurried F G)^-1)^-1 o _). refine ((path_sigma_uncurried _ _ _) o _); simpl. refine (pr1^-1). Defined. Global Instance isequiv_path_path_functor_uncurried F G p q : IsEquiv (@path_path_functor_uncurried F G p q). Proof. unfold path_path_functor_uncurried. (** N.B. [exact _] is super-slow here. Not sure why. *) repeat match goal with | [ |- IsEquiv (_ o _) ] => eapply @isequiv_compose | [ |- IsEquiv (_^-1) ] => eapply @isequiv_inverse | [ |- IsEquiv (path_sigma_uncurried _ _ _) ] => eapply @isequiv_path_sigma | _ => apply @isequiv_compose end. Defined. (** ** If the objects in [D] are n-truncated, then so is the type of functors [C → D] *) Global Instance trunc_functor `{IsTrunc n D} `{forall s d, IsTrunc n (morphism D s d)} : IsTrunc n (Functor C D). Proof. eapply istrunc_equiv_istrunc; [ exact equiv_sig_functor | ]. induction n; simpl; intros; typeclasses eauto. Qed. End path_functor. (** ** Tactic for proving equality of functors *) Ltac path_functor := repeat match goal with | _ => intro | _ => reflexivity | _ => apply path_functor_uncurried; simpl | _ => (exists idpath) end. Global Arguments path_functor_uncurried : simpl never. (** ** Tactic for pushing [ap object_of] through other [ap]s. This allows lemmas like [path_functor_uncurried_fst] to apply more easily. *) Ltac push_ap_object_of' := idtac; match goal with | [ |- context[ap object_of (ap ?f ?p)] ] => rewrite <- (ap_compose' f object_of p); simpl | [ |- context G[ap (fun F' x => object_of F' (@?f x)) ?p] ] => let P := context_to_lambda G in refine (transport P (ap_compose' object_of (fun F' x => F' (f x)) p)^ _) | [ |- context G[ap (fun F' x => ?f (object_of F' x)) ?p] ] => let P := context_to_lambda G in refine (transport P (ap_compose' object_of (fun F' x => f (F' x)) p)^ _) end. Ltac push_ap_object_of := repeat push_ap_object_of'. Coq-HoTT-9.0/theories/Categories/Functor/Pointwise.v000066400000000000000000000003361474641544500224370ustar00rootroot00000000000000(** * Pointwise functors (functoriality of the functor category construction) *) Require Functor.Pointwise.Core. Require Functor.Pointwise.Properties. Include Functor.Pointwise.Core. Include Functor.Pointwise.Properties. Coq-HoTT-9.0/theories/Categories/Functor/Pointwise/000077500000000000000000000000001474641544500222465ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Functor/Pointwise/Core.v000066400000000000000000000061351474641544500233320ustar00rootroot00000000000000(** * Functors between functor categories constructed pointwise *) Require Import Category.Core Functor.Core FunctorCategory.Core NaturalTransformation.Paths Functor.Composition.Core NaturalTransformation.Composition.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. Local Open Scope morphism_scope. Local Open Scope category_scope. Local Open Scope functor_scope. (** This is the on-objects part of the functor-category construction as a functor. *) Section pointwise. Context `{Funext}. Variables C C' : PreCategory. Variable F : Functor C' C. Variables D D' : PreCategory. Variable G : Functor D D'. Local Notation pointwise_object_of H := (G o H o F : object (C' -> D')). Local Notation pointwise_whiskerL_object_of H := (G o H : object (C -> D')). Local Notation pointwise_whiskerR_object_of H := (H o F : object (C' -> D)). (* Definition pointwise_object_of : (C -> D) -> (C' -> D') := fun H => G o H o F.*) Definition pointwise_morphism_of s d (m : morphism (C -> D) s d) : morphism (C' -> D') (pointwise_object_of s) (pointwise_object_of d) := Eval simpl in G oL m oR F. Definition pointwise_whiskerL_morphism_of s d (m : morphism (C -> D) s d) : morphism (C -> D') (pointwise_whiskerL_object_of s) (pointwise_whiskerL_object_of d) := Eval simpl in G oL m. Definition pointwise_whiskerR_morphism_of s d (m : morphism (C -> D) s d) : morphism (C' -> D) (pointwise_whiskerR_object_of s) (pointwise_whiskerR_object_of d) := Eval simpl in m oR F. Global Arguments pointwise_morphism_of _ _ _ / . Global Arguments pointwise_whiskerL_morphism_of _ _ _ / . Global Arguments pointwise_whiskerR_morphism_of _ _ _ / . (** ** Construction of [pointwise : (C → D) → (C' → D')] from [C' → C] and [D → D'] *) Definition pointwise : Functor (C -> D) (C' -> D'). Proof. refine (Build_Functor (C -> D) (C' -> D') (fun x => pointwise_object_of x) pointwise_morphism_of _ _); abstract (intros; simpl; path_natural_transformation; auto with functor). Defined. (** ** Construction of [(C → D) → (C → D')] from [D → D'] *) Definition pointwise_whiskerL : Functor (C -> D) (C -> D'). Proof. refine (Build_Functor (C -> D) (C -> D') (fun x => pointwise_whiskerL_object_of x) pointwise_whiskerL_morphism_of _ _); abstract (intros; simpl; path_natural_transformation; auto with functor). Defined. (** ** Construction of [(C → D) → (C' → D)] from [C' → C] *) Definition pointwise_whiskerR : Functor (C -> D) (C' -> D). Proof. refine (Build_Functor (C -> D) (C' -> D) (fun x => pointwise_whiskerR_object_of x) pointwise_whiskerR_morphism_of _ _); abstract (intros; simpl; path_natural_transformation; auto with functor). Defined. End pointwise. Coq-HoTT-9.0/theories/Categories/Functor/Pointwise/Properties.v000066400000000000000000000073551474641544500246030ustar00rootroot00000000000000(** * Properties of pointwise functors *) Require Import Category.Core Functor.Core Functor.Pointwise.Core NaturalTransformation.Core NaturalTransformation.Paths Functor.Composition.Core Functor.Identity Functor.Paths. Require Import PathGroupoids Types.Forall HoTT.Tactics. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope functor_scope. Section parts. Context `{Funext}. (** We could do this all in a big [repeat match], but we split it up, to shave off about two seconds per proof. *) Local Ltac functor_pointwise_t helper_lem_match helper_lem := repeat (apply path_forall; intro); rewrite !transport_forall_constant, !path_forall_2_beta; path_natural_transformation; repeat match goal with | [ |- context[components_of (transport ?P ?p ?z)] ] => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => components_of) z) end; rewrite !transport_forall_constant; transport_to_ap; repeat match goal with | [ x : _ |- context[ap (fun x3 : ?T => ?f (object_of x3 ?z))] ] => rewrite (@ap_compose' _ _ _ (fun x3' : T => object_of x3') (fun Ox3 => f (Ox3 x))) | [ x : _ |- context[ap (fun x3 : ?T => ?f (object_of x3 ?z) ?w)] ] => rewrite (@ap_compose' _ _ _ (fun x3' : T => object_of x3') (fun Ox3 => f (Ox3 x) w)) end; repeat match goal with | _ => done | [ |- context[fun F => @object_of ?C ?D F] ] => progress change (fun F' => @object_of C D F') with (@object_of C D) | [ |- context[helper_lem_match ?x] ] => rewrite (helper_lem x) end. (** ** respects identity *) Section identity_of. Variables C D : PreCategory. Lemma identity_of_helper_helper (x : Functor C D) : 1 o x o 1 = x. Proof. path_functor. Defined. Definition identity_of_helper_helper_object_of x : ap object_of (identity_of_helper_helper x) = idpath := path_functor_uncurried_fst _ _ _. Lemma identity_of_helper : (fun x : Functor C D => 1 o x o 1) = idmap. Proof. apply path_forall; intro x. apply identity_of_helper_helper. Defined. Lemma identity_of : pointwise (identity C) (identity D) = identity _. Proof. path_functor. exists identity_of_helper. unfold identity_of_helper. abstract functor_pointwise_t identity_of_helper_helper identity_of_helper_helper_object_of. Defined. End identity_of. (** ** respects composition *) Section composition_of. Variables C D C' D' C'' D'' : PreCategory. Variable F' : Functor C' C''. Variable G : Functor D D'. Variable F : Functor C C'. Variable G' : Functor D' D''. Lemma composition_of_helper_helper (x : Functor C'' D) : G' o G o x o (F' o F) = G' o (G o x o F') o F. Proof. path_functor. Defined. Definition composition_of_helper_helper_object_of x : ap object_of (composition_of_helper_helper x) = idpath := path_functor_uncurried_fst _ _ _. Lemma composition_of_helper : (fun x => G' o G o x o (F' o F)) = (fun x => G' o (G o x o F') o F). Proof. apply path_forall; intro x. apply composition_of_helper_helper. Defined. Lemma composition_of : pointwise (F' o F) (G' o G) = pointwise F G' o pointwise F' G. Proof. path_functor. exists composition_of_helper. unfold composition_of_helper. abstract functor_pointwise_t composition_of_helper_helper composition_of_helper_helper_object_of. Defined. End composition_of. End parts. Coq-HoTT-9.0/theories/Categories/Functor/Prod.v000066400000000000000000000007221474641544500213610ustar00rootroot00000000000000(** * Functors involving product categories, and their properties *) (** ** Definitions of various functors *) Require Functor.Prod.Core. (** ** Universal property *) Require Functor.Prod.Universal. (** ** Functoriality *) Require Functor.Prod.Functorial. Include Functor.Prod.Core. Include Functor.Prod.Universal. Include Functor.Prod.Functorial. Module Export FunctorProdNotations. Include Functor.Prod.Core.FunctorProdCoreNotations. End FunctorProdNotations. Coq-HoTT-9.0/theories/Categories/Functor/Prod/000077500000000000000000000000001474641544500211715ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Functor/Prod/Core.v000066400000000000000000000061631474641544500222560ustar00rootroot00000000000000(** * Functors involving product categories *) Require Import Category.Core Functor.Core Category.Prod Functor.Composition.Core. Require Import Types.Prod. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Notation fst_type := fst. Local Notation snd_type := snd. Local Notation pair_type := pair. Local Open Scope morphism_scope. Local Open Scope functor_scope. (** ** First and second projections from a product precategory *) Section proj. Context {C : PreCategory}. Context {D : PreCategory}. Definition fst : Functor (C * D) C := Build_Functor (C * D) C (@fst _ _) (fun _ _ => @fst _ _) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition snd : Functor (C * D) D := Build_Functor (C * D) D (@snd _ _) (fun _ _ => @snd _ _) (fun _ _ _ _ _ => idpath) (fun _ => idpath). End proj. (** ** Product of two functors from the same domain *) Section prod. Variables C D D' : PreCategory. Definition prod (F : Functor C D) (F' : Functor C D') : Functor C (D * D') := Build_Functor C (D * D') (fun c => (F c, F' c)) (fun s d m => (F _1 m, F' _1 m)) (fun _ _ _ _ _ => path_prod' (composition_of F _ _ _ _ _) (composition_of F' _ _ _ _ _)) (fun _ => path_prod' (identity_of F _) (identity_of F' _)). End prod. Local Infix "*" := prod : functor_scope. (** ** Pairing of two functors *) Section pair. Variables C D C' D' : PreCategory. Variable F : Functor C D. Variable F' : Functor C' D'. Local Open Scope functor_scope. Definition pair : Functor (C * C') (D * D') := (F o fst) * (F' o snd). End pair. Local Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : functor_scope. (** ** Partially applied functors out of a product precategory *) Section induced. Variables C D E : PreCategory. Variable F : Functor (C * D) E. Local Open Scope core_scope. Local Ltac t := simpl; intros; repeat (rewrite <- ?composition_of, <- ?identity_of, ?left_identity, ?right_identity; simpl); trivial. (** Note: This is just the currying exponential law. *) (** TODO: Come up with a better name for this? *) Definition induced_fst (d : D) : Functor C E. Proof. refine (Build_Functor C E (fun c => F (c, d)) (fun _ _ m => @morphism_of _ _ F (_, _) (_, _) (m, identity d)) _ _); abstract t. Defined. Definition induced_snd (c : C) : Functor D E. Proof. refine (Build_Functor D E (fun d => F (c, d)) (fun _ _ m => @morphism_of _ _ F (_, _) (_, _) (identity c, m)) _ _); abstract t. Defined. End induced. Local Set Warnings Append "-notation-overridden". Module Export FunctorProdCoreNotations. Infix "*" := prod : functor_scope. Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : functor_scope. End FunctorProdCoreNotations. Coq-HoTT-9.0/theories/Categories/Functor/Prod/Functorial.v000066400000000000000000000033041474641544500234660ustar00rootroot00000000000000(** * Functoriality of product of functors *) Require Import Category.Core Functor.Core Functor.Prod.Core FunctorCategory.Core Category.Prod NaturalTransformation.Prod NaturalTransformation.Composition.Core. Require Import NaturalTransformation.Paths. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. Local Notation fst_type := Basics.Overture.fst. Local Notation snd_type := Basics.Overture.snd. Local Notation pair_type := Basics.Overture.pair. (** ** Construction of product of functors as a functor - [_×_ : (C → D) × (C → D') → (C → D × D')] *) Section functorial. Context `{Funext}. Variables C D D' : PreCategory. Definition functor_morphism_of s d (m : morphism ((C -> D) * (C -> D')) s d) : morphism (_ -> _) (fst s * snd s)%functor (fst d * snd d)%functor := fst_type m * snd_type m. Definition functor_composition_of s d d' (m1 : morphism ((C -> D) * (C -> D')) s d) (m2 : morphism ((C -> D) * (C -> D')) d d') : functor_morphism_of (m2 o m1) = functor_morphism_of m2 o functor_morphism_of m1. Proof. path_natural_transformation; reflexivity. Qed. Definition functor_identity_of (x : object ((C -> D) * (C -> D'))) : functor_morphism_of (identity x) = identity _. Proof. path_natural_transformation; reflexivity. Qed. Definition functor : object ((C -> D) * (C -> D') -> (C -> D * D')) := Build_Functor ((C -> D) * (C -> D')) (C -> D * D') _ functor_morphism_of functor_composition_of functor_identity_of. End functorial. Coq-HoTT-9.0/theories/Categories/Functor/Prod/Universal.v000066400000000000000000000073001474641544500233300ustar00rootroot00000000000000(** * Universal properties of product categories *) Require Import Category.Core Functor.Core Category.Prod Functor.Composition.Core Functor.Prod.Core. Require Import Functor.Paths. Require Import Types.Prod HoTT.Tactics Types.Forall Types.Sigma. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Notation fst_type := Basics.Overture.fst. Local Notation snd_type := Basics.Overture.snd. Local Notation pair_type := Basics.Overture.pair. Local Notation prod_type := Basics.Overture.prod. Local Open Scope morphism_scope. Local Open Scope functor_scope. Section universal. Context `{Funext}. Variables A B C : PreCategory. Local Open Scope functor_scope. Section universal. Variable a : Functor C A. Variable b : Functor C B. (** ** [fst ∘ (a * b) = a] *) Lemma compose_fst_prod : fst o (a * b) = a. Proof. path_functor; trivial. Defined. (** ** [snd ∘ (a * b) = b] *) Lemma compose_snd_prod : snd o (a * b) = b. Proof. path_functor; trivial. Defined. Section unique. Variable F : Functor C (A * B). Hypothesis H1 : fst o F = a. Hypothesis H2 : snd o F = b. Lemma unique_helper c : (a * b) c = F c. Proof. pose proof (ap (fun F => object_of F c) H1). pose proof (ap (fun F => object_of F c) H2). simpl in *. path_induction. apply eta_prod. Defined. Lemma unique_helper2 : transport (fun GO : C -> prod_type A B => forall s d : C, morphism C s d -> prod_type (morphism A (fst_type (GO s)) (fst_type (GO d))) (morphism B (snd_type (GO s)) (snd_type (GO d)))) (path_forall (a * b) F unique_helper) (fun (s d : C) (m : morphism C s d) => pair_type (a _1 m) (b _1 m)) = morphism_of F. Proof. repeat (apply path_forall; intro). repeat match goal with | _ => reflexivity | _ => progress simpl | _ => rewrite !transport_forall_constant end. transport_path_forall_hammer. unfold unique_helper. repeat match goal with | [ H : _ = _ |- _ ] => case H; simpl; clear H end. repeat match goal with | [ |- context[@morphism_of ?C ?D ?F ?s ?d ?m] ] => destruct (@morphism_of C D F s d m); clear m | [ |- context[@object_of ?C ?D ?F ?x] ] => destruct (@object_of C D F x); clear x end. reflexivity. Qed. Lemma unique : a * b = F. Proof. path_functor. exists (path_forall _ _ unique_helper). apply unique_helper2. Defined. End unique. Local Open Scope core_scope. (** ** Universal property characterizing unique product of functors *) Global Instance contr_prod_type `{IsHSet (Functor C A), IsHSet (Functor C B)} : Contr { F : Functor C (A * B) | fst o F = a /\ snd o F = b }. Proof. refine (Build_Contr _ (a * b; (compose_fst_prod, compose_snd_prod)) _). intro y. apply path_sigma_uncurried. simpl. exists (unique (fst_type y.2) (snd_type y.2)). exact (center _). Qed. End universal. (** ** Classification of path space of functors to a product precategory *) Definition path_prod (F G : Functor C (A * B)) (H1 : fst o F = fst o G) (H2 : snd o F = snd o G) : F = G. Proof. etransitivity; [ symmetry | ]; apply unique; try eassumption; reflexivity. Defined. End universal. Coq-HoTT-9.0/theories/Categories/Functor/Sum.v000066400000000000000000000066111474641544500212240ustar00rootroot00000000000000(** * Functors involving coproduct categories *) Require Import Category.Sum Functor.Core Functor.Composition.Core Functor.Identity. Require Import Functor.Paths HoTT.Tactics Types.Forall. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** We save [inl] and [inr] so we can use them to refer to the functors, too. Outside of the [Categories/] directory, they should always be referred to as [Functor.inl] and [Functor.inr], after a [Require Functor]. Outside of this file, but in the [Categories/] directory, if you do not want to depend on all of [Functor] (for e.g., speed reasons), they should be referred to as [Functor.Sum.inl] and [Functor.Sum.inr] after a [Require Functor.Sum]. *) Local Notation type_inl := inl. Local Notation type_inr := inr. (** ** Injections [inl : C → C + D] and [inr : D → C + D] *) Section sum_functors. Variables C D : PreCategory. Definition inl : Functor C (C + D) := Build_Functor C (C + D) (@inl _ _) (fun _ _ m => m) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition inr : Functor D (C + D) := Build_Functor D (C + D) (@inr _ _) (fun _ _ m => m) (fun _ _ _ _ _ => idpath) (fun _ => idpath). End sum_functors. (** ** Coproduct of functors [F + F' : C + C' → D] *) Section sum. Variables C C' D : PreCategory. Definition sum (F : Functor C D) (F' : Functor C' D) : Functor (C + C') D. Proof. refine (Build_Functor (C + C') D (fun cc' => match cc' with | type_inl c => F c | type_inr c' => F' c' end) (fun s d => match s, d with | type_inl cs, type_inl cd => fun m : morphism _ cs cd => F _1 m | type_inr c's, type_inr c'd => fun m : morphism _ c's c'd => F' _1 m | _, _ => fun m => match m with end end%morphism) _ _); abstract ( repeat (intros [] || intro); simpl in *; auto with functor ). Defined. End sum. (** ** swap : [C + D → D + C] *) Section swap_functor. Definition swap C D : Functor (C + D) (D + C) := sum (inr _ _) (inl _ _). Local Open Scope functor_scope. Definition swap_involutive_helper {C D} c : (swap C D) ((swap D C) c) = c := match c with type_inl _ => idpath | type_inr _ => idpath end. Lemma swap_involutive `{Funext} C D : swap C D o swap D C = 1. Proof. path_functor. exists (path_forall _ _ swap_involutive_helper). repeat (apply (@path_forall _); intro). repeat match goal with | [ |- context[transport (fun x' => forall y, @?C x' y) ?p ?f ?x] ] => simpl rewrite (@transport_forall_constant _ _ C _ _ p f x) end. transport_path_forall_hammer. by repeat match goal with | [ H : Empty |- _ ] => destruct H | [ H : (_ + _) |- _ ] => destruct H | _ => progress hnf in * end. Qed. End swap_functor. Module Export FunctorSumNotations. Notation "F + G" := (sum F G) : functor_scope. End FunctorSumNotations. Coq-HoTT-9.0/theories/Categories/Functor/Utf8.v000066400000000000000000000006331474641544500213040ustar00rootroot00000000000000(** * Unicode notations for functors *) Require Export Category.Notations Category.Utf8 Functor.Notations. Require Import Functor.Core Functor.Composition.Core Functor.Dual. Require Import Basics.Utf8. Infix "∘" := compose : functor_scope. Notation "F ₀ x" := (object_of F x) : object_scope. Notation "F ₁ m" := (morphism_of F m) : morphism_scope. Notation "F 'ᵒᵖ'" := (opposite F) : functor_scope. Coq-HoTT-9.0/theories/Categories/FunctorCategory.v000066400000000000000000000012541474641544500221540ustar00rootroot00000000000000(** * Functor category *) (** Since there are only notations in [FunctorCategory.Notations], we can just export those. *) Require Export FunctorCategory.Notations. (** ** Definition *) Require FunctorCategory.Core. (** ** Morphisms in a functor category *) Require FunctorCategory.Morphisms. (** ** Functoriality of [(_ → _)] *) Require FunctorCategory.Functorial. (** ** Opposite functor [(C → D) → (Cᵒᵖ → Dᵒᵖ)ᵒᵖ] *) Require FunctorCategory.Dual. Include FunctorCategory.Core. Include FunctorCategory.Morphisms. Include FunctorCategory.Functorial. Include FunctorCategory.Dual. (** We don't want to make utf-8 notations the default, so we don't export them. *) Coq-HoTT-9.0/theories/Categories/FunctorCategory/000077500000000000000000000000001474641544500217635ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/FunctorCategory/Core.v000066400000000000000000000031531474641544500230440ustar00rootroot00000000000000(** * Functor category [D → C] (also [Cᴰ] and [[D, C]]) *) Require Import Category.Strict Functor.Core NaturalTransformation.Core Functor.Paths. (** These must come last, so that [identity], [compose], etc., refer to natural transformations. *) Require Import NaturalTransformation.Composition.Core NaturalTransformation.Identity NaturalTransformation.Composition.Laws NaturalTransformation.Paths. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** ** Definition of [C → D] *) Section functor_category. Context `{Funext}. Variables C D : PreCategory. (** There is a category Fun(C, D) of functors from [C] to [D]. *) Definition functor_category : PreCategory := @Build_PreCategory (Functor C D) (@NaturalTransformation C D) (@identity C D) (@compose C D) (@associativity _ C D) (@left_identity _ C D) (@right_identity _ C D) _. End functor_category. Local Notation "C -> D" := (functor_category C D) : category_scope. (** ** [C → D] is a strict category if [D] is *) Lemma isstrict_functor_category `{Funext} C `{IsStrictCategory D} : IsStrictCategory (C -> D). Proof. typeclasses eauto. Defined. Module Export FunctorCategoryCoreNotations. (*Notation "C ^ D" := (functor_category D C) : category_scope. Notation "[ C , D ]" := (functor_category C D) : category_scope.*) Notation "C -> D" := (functor_category C D) : category_scope. End FunctorCategoryCoreNotations. Coq-HoTT-9.0/theories/Categories/FunctorCategory/Dual.v000066400000000000000000000023621474641544500230420ustar00rootroot00000000000000(** * Dual functor categories *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Category.Dual Functor.Dual NaturalTransformation.Dual. Require Import Functor.Identity. Require Import FunctorCategory.Core. Require Import Functor.Paths. Require Import HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Section opposite. Context `{Funext}. (** ** Functors [(C → D) ↔ (Cᵒᵖ → Dᵒᵖ)ᵒᵖ] *) Definition opposite_functor (C D : PreCategory) : Functor (C -> D) (C^op -> D^op)^op := Build_Functor (C -> D) ((C^op -> D^op)^op) (fun F => F^op)%functor (fun _ _ T => T^op)%natural_transformation (fun _ _ _ _ _ => idpath) (fun _ => idpath). Local Ltac op_t C D := split; path_functor; repeat (apply path_forall; intro); simpl; destruct_head NaturalTransformation; exact idpath. (** ** The above functors are isomorphisms *) Definition opposite_functor_law C D : opposite_functor C D o (opposite_functor C^op D^op)^op = 1 /\ (opposite_functor C^op D^op)^op o opposite_functor C D = 1. Proof. op_t C D. Qed. End opposite. Coq-HoTT-9.0/theories/Categories/FunctorCategory/Functorial.v000066400000000000000000000027021474641544500242610ustar00rootroot00000000000000(** * Functoriality of functor category construction *) Require Import Category.Core Functor.Core FunctorCategory.Core Functor.Pointwise.Core Functor.Pointwise.Properties Category.Dual Category.Prod Cat.Core ExponentialLaws.Law4.Functors. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope type_scope. (** ** [(_ → _)] is a functor [catᵒᵖ × cat → cat] *) Section functor. Context `{Funext}. Variable P : PreCategory -> Type. Context `{forall C, IsHProp (P C)}. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation cat := (sub_pre_cat P HF). Hypothesis has_functor_categories : forall C D : cat, P (C.1 -> D.1). Local Open Scope category_scope. Definition functor_uncurried : object ((cat^op * cat) -> cat) := Eval cbv zeta in let object_of := (fun CD => (((fst CD).1 -> (snd CD).1); has_functor_categories (fst CD) (snd CD))) in Build_Functor (cat^op * cat) cat object_of (fun CD C'D' FG => pointwise (fst FG) (snd FG)) (fun _ _ _ _ _ => Functor.Pointwise.Properties.composition_of _ _ _ _) (fun _ => Functor.Pointwise.Properties.identity_of _ _). Definition functor : object (cat^op -> (cat -> cat)) := ExponentialLaws.Law4.Functors.inverse _ _ _ functor_uncurried. End functor. Coq-HoTT-9.0/theories/Categories/FunctorCategory/Morphisms.v000066400000000000000000000073261474641544500241430ustar00rootroot00000000000000(** * Morphisms in a functor category *) Require Import Category.Core Functor.Core NaturalTransformation.Paths FunctorCategory.Core Category.Morphisms NaturalTransformation.Core. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope category_scope. Local Open Scope morphism_scope. (** ** Natural Isomorphisms - isomorphisms in a functor category *) Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G := @Isomorphic (C -> D) F G. Arguments NaturalIsomorphism {_} [C D] F G / . Global Instance reflexive_natural_isomorphism `{Funext} C D : Reflexive (@NaturalIsomorphism _ C D) | 0 := _. Coercion natural_transformation_of_natural_isomorphism `{Funext} C D F G (T : @NaturalIsomorphism _ C D F G) : NaturalTransformation F G := T : morphism _ _ _. Local Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope. (** ** If [T] is an isomorphism, then so is [T x] for any [x] *) Definition isisomorphism_components_of `{Funext} `{@IsIsomorphism (C -> D) F G T} x : IsIsomorphism (T x). Proof. exists (T^-1 x). - exact (apD10 (ap components_of left_inverse) x). - exact (apD10 (ap components_of right_inverse) x). Defined. #[export] Hint Immediate isisomorphism_components_of : typeclass_instances. (** When one of the functors is the identity functor, we fail to match correctly, because [apply] is stupid. So we do its work for it. *) #[export] Hint Extern 10 (@IsIsomorphism _ _ _ (@components_of ?C ?D ?F ?G ?T ?x)) => apply (fun H' => @isisomorphism_components_of _ C D F G T H' x) : typeclass_instances. Definition inverse C D (F G : Functor C D) (T : NaturalTransformation F G) `{forall x, IsIsomorphism (T x)} : NaturalTransformation G F. Proof. exists (fun x => (T x)^-1); abstract ( intros; iso_move_inverse; first [ apply commutes | symmetry; apply commutes ] ). Defined. (** ** If [T x] is an isomorphism for all [x], then so is [T] *) Definition isisomorphism_natural_transformation `{Funext} C D F G (T : NaturalTransformation F G) `{forall x, IsIsomorphism (T x)} : @IsIsomorphism (C -> D) F G T. Proof. exists (inverse _); abstract ( path_natural_transformation; first [ apply left_inverse | apply right_inverse ] ). Defined. #[export] Hint Immediate isisomorphism_natural_transformation : typeclass_instances. (** ** Variant of [idtoiso] for natural transformations *) Section idtoiso. Context `{Funext}. Variables C D : PreCategory. Definition idtoiso_natural_transformation (F G : object (C -> D)) (T : F = G) : NaturalTransformation F G. Proof. refine (Build_NaturalTransformation' F G (fun x => idtoiso _ (ap10 (ap object_of T) x)) _ _); intros; case T; simpl; [ exact (left_identity _ _ _ _ @ (right_identity _ _ _ _)^) | exact (right_identity _ _ _ _ @ (left_identity _ _ _ _)^) ]. Defined. Definition idtoiso (F G : object (C -> D)) (T : F = G) : F <~=~> G. Proof. exists (idtoiso_natural_transformation T). exists (idtoiso_natural_transformation (T^)%path); abstract (path_natural_transformation; case T; simpl; auto with morphism). Defined. Lemma eta_idtoiso (F G : object (C -> D)) (T : F = G) : Category.Morphisms.idtoiso _ T = idtoiso T. Proof. case T. expand; f_ap. exact (center _). Qed. End idtoiso. Module Export FunctorCategoryMorphismsNotations. Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope. End FunctorCategoryMorphismsNotations. Coq-HoTT-9.0/theories/Categories/FunctorCategory/Notations.v000066400000000000000000000003541474641544500241320ustar00rootroot00000000000000(** * Notations for functor categories *) Require FunctorCategory.Core. Require FunctorCategory.Morphisms. Include FunctorCategory.Core.FunctorCategoryCoreNotations. Include FunctorCategory.Morphisms.FunctorCategoryMorphismsNotations. Coq-HoTT-9.0/theories/Categories/FunctorCategory/Utf8.v000066400000000000000000000005251474641544500230020ustar00rootroot00000000000000(** * Unicode notations for functor categories *) Require Export Category.Utf8 Functor.Utf8 NaturalTransformation.Utf8. Require Import FunctorCategory.Core FunctorCategory.Morphisms. Require Import Basics.Utf8. Notation "C → D" := (functor_category C D) : category_scope. Infix "≅" := NaturalIsomorphism : natural_transformation_scope. Coq-HoTT-9.0/theories/Categories/FundamentalPreGroupoidCategory.v000066400000000000000000000050021474641544500251450ustar00rootroot00000000000000(** * Fundamental Pregroupoids *) Require Import Category.Core. Require Import HoTT.Truncations.Core. Require Import HoTT.Basics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope category_scope. (** Quoting the HoTT Book: Example. For _any_ type [X], there is a precategory with [X] as its type of objects and with [hom(x,y) : ∥x = y∥₀]. The composition operation [∥y = z∥₀ → ∥x = y∥₀ → ∥x = z∥₀] is defined by induction on truncation from concatenation [(y = z) → (x = y) → (x = z)]. We call this the fundamental pregroupoid of [X]. *) (** We don't want access to all of the internals of a groupoid category at top level. *) Module FundamentalPreGroupoidCategoryInternals. Section fundamental_pregroupoid_category. Variable X : Type. Local Notation object := X (only parsing). Local Notation morphism s d := (Trunc 0 (s = d :> X)) (only parsing). Definition compose s d d' (m : morphism d d') (m' : morphism s d) : morphism s d'. Proof. revert m'; apply Trunc_rec; intro m'. revert m; apply Trunc_rec; intro m. apply tr. exact (m' @ m). Defined. Definition identity x : morphism x x := tr (reflexivity _). Global Arguments compose [s d d'] m m' / . Global Arguments identity x / . End fundamental_pregroupoid_category. End FundamentalPreGroupoidCategoryInternals. (** ** Categorification of the fundamental pregroupoid of a type *) Definition fundamental_pregroupoid_category (X : Type) : PreCategory. Proof. refine (@Build_PreCategory X _ (@FundamentalPreGroupoidCategoryInternals.identity X) (@FundamentalPreGroupoidCategoryInternals.compose X) _ _ _ _); simpl; intros; abstract ( repeat match goal with | [ m : Trunc _ _ |- _ ] => revert m; apply Trunc_ind; [ intro; match goal with | [ |- IsHSet (?a = ?b :> ?T) ] => generalize a b; intros; let H := fresh in assert (H : forall x y : T, IsHProp (x = y)) end; typeclasses eauto | intro ] end; simpl; apply ap; first [ apply concat_p_pp | apply concat_1p | apply concat_p1 ] ). Defined. Coq-HoTT-9.0/theories/Categories/Grothendieck.v000066400000000000000000000007761474641544500214540ustar00rootroot00000000000000(** * Grothendieck Construction *) (** We want to have the following as subdirectories/modules, not at top level. Unfortunately, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *) (** ** of a functor to Set *) Require Grothendieck.ToSet. (** ** of a pseudofunctor to Cat *) Require Grothendieck.PseudofunctorToCat. (** ** of a functor to Cat *) Require Grothendieck.ToCat. Coq-HoTT-9.0/theories/Categories/Grothendieck/000077500000000000000000000000001474641544500212535ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Grothendieck/PseudofunctorToCat.v000066400000000000000000000255021474641544500252410ustar00rootroot00000000000000(** * Grothendieck Construction of a pseudofunctor to Cat *) Require Import FunctorCategory.Morphisms. Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Pseudofunctor.Core Pseudofunctor.RewriteLaws. Require Import Category.Morphisms Cat.Morphisms. Require Import Functor.Composition.Core. Require Import Functor.Identity. Require Import FunctorCategory.Core. Require Import Basics Types HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section Grothendieck. Context `{Funext}. Variable C : PreCategory. Variable F : Pseudofunctor C. Record Pair := { c : C; x : object (F c) }. Local Notation morphism s d := { f : morphism C s.(c) d.(c) | morphism _ (p_morphism_of F f s.(x)) d.(x) }. Definition compose s d d' (m1 : morphism d d') (m2 : morphism s d) : morphism s d'. Proof. exists (m1.1 o m2.1). refine (m1.2 o ((p_morphism_of F m1.1) _1 m2.2 o _)). apply (p_composition_of F). Defined. Definition identity s : morphism s s. Proof. exists 1. apply (p_identity_of F). Defined. Global Arguments identity _ / . Global Arguments compose _ _ _ _ _ / . Local Ltac try_associativity_f_ap := first [ f_ap; [] | repeat (etransitivity; [ apply Category.Core.associativity | ]); repeat (etransitivity; [ | symmetry; apply Category.Core.associativity ]); f_ap; [] | repeat (etransitivity; [ symmetry; apply Category.Core.associativity | ]); repeat (etransitivity; [ | apply Category.Core.associativity ]); f_ap; [] ]. Local Ltac assoc_before_commutes_tac := rewrite !composition_of; rewrite <- !Category.Core.associativity; etransitivity; [ | symmetry; apply compose4associativity_helper ]. Local Ltac assoc_fin_tac := repeat match goal with | _ => reflexivity | _ => progress rewrite ?Category.Core.left_identity, ?Category.Core.right_identity | [ |- context[components_of ?T ?x o components_of ?T^-1 ?x] ] => let k := constr:(@iso_compose_pV _ _ _ (T x) _) in simpl rewrite k (* https://coq.inria.fr/bugs/show_bug.cgi?id=3773 and https://coq.inria.fr/bugs/show_bug.cgi?id=3772 (probably) *) | _ => try_associativity_quick first [ f_ap; [] | apply concat_left_identity | apply concat_right_identity ] | _ => rewrite <- ?identity_of, <- ?composition_of; progress repeat (f_ap; []); rewrite ?identity_of, ?composition_of | _ => try_associativity_quick rewrite compose4associativity_helper end. Local Ltac helper_t before_commutes_tac := repeat intro; symmetry; apply path_sigma_uncurried; simpl in *; let ex_hyp := match goal with | [ H : ?A = ?B |- @sig (?B = ?A) _ ] => constr:(H) end in (exists (inverse ex_hyp)); simpl; rewrite ?transport_Fc_to_idtoiso, ?transport_cF_to_idtoiso; rewrite ?idtoiso_inv, ?ap_V, ?inv_V; simpl; let rew_hyp := match goal with | [ H' : context[ex_hyp] |- _ ] => constr:(H') end in rewrite rew_hyp; clear rew_hyp ex_hyp; before_commutes_tac; repeat first [ reflexivity | progress rewrite ?Category.Core.left_identity, ?Category.Core.right_identity | try_associativity_quick (f_ap; []) ]; match goal with | _ => reflexivity | [ |- context[?F _1 ?m o components_of ?T ?x] ] => simpl rewrite <- (commutes T _ _ m); try reflexivity | [ |- context[components_of ?T ?x o ?F _1 ?m] ] => simpl rewrite (commutes T _ _ m); try reflexivity end. (* The goal for, e.g., the following associativity helper was made with the following code: << intros a b c d [f f'] [g g'] [h h']; simpl. pose proof (apD10 (ap components_of (p_composition_ofCoherent_for_rewrite F _ _ _ _ f g h))) as rew_hyp. revert rew_hyp. generalize dependent (Category.Core.associativity C _ _ _ _ f g h). intros fst_hyp ?. simpl in *. hnf in rew_hyp. simpl in *. Local Ltac gen_x x := generalize dependent (X x); generalize dependent (C x); repeat (let x1 := fresh "x" in intro x1). gen_x a. gen_x b. gen_x c. gen_x d. repeat match goal with | [ |- context[p_identity_of ?F ?x] ] => generalize dependent (p_identity_of F x) | [ |- context[p_composition_of ?F ?x ?y ?z ?f ?g] ] => generalize dependent (p_composition_of F x y z f g) | [ |- context[p_morphism_of ?F ?m] ] => generalize dependent (p_morphism_of F m) | [ |- context[p_object_of ?F ?x] ] => generalize dependent (p_object_of F x) | [ H : context[p_morphism_of ?F ?m] |- _ ] => generalize dependent (p_morphism_of F m) | [ |- context[@p_morphism_of _ _ ?F ?x ?y] ] => generalize dependent (@p_morphism_of _ _ F x y) end. simpl. intros. lazymatch goal with | [ H : context[ap ?f ?H'] |- _ ] => rename H' into fst_hyp; rename H into rew_hyp; move rew_hyp at top end. generalize dependent fst_hyp. clear. intros. move rew_hyp at top. move H at top. repeat match goal with | [ H : Isomorphic _ _ |- _ ] => let x := fresh "x" in let H' := fresh "H" in destruct H as [x H']; simpl in * end. move rew_hyp at top. repeat match goal with | [ H : _ |- _ ] => revert H end. intro H. intro C. >> *) Lemma pseudofunctor_to_cat_assoc_helper : forall {x x0 : C} {x2 : Category.Core.morphism C x x0} {x1 : C} {x5 : Category.Core.morphism C x0 x1} {x4 : C} {x7 : Category.Core.morphism C x1 x4} {p p0 : PreCategory} {f : Category.Core.morphism C x x4 -> Functor p0 p} {p1 p2 : PreCategory} {f0 : Functor p2 p} {f1 : Functor p1 p2} {f2 : Functor p0 p2} {f3 : Functor p0 p1} {f4 : Functor p1 p} {x16 : Category.Core.morphism (_ -> _) (f (x7 o x5 o x2)) (f4 o f3)%functor} {x15 : Category.Core.morphism (_ -> _) f2 (f1 o f3)%functor} {H2 : IsIsomorphism x15} {x11 : Category.Core.morphism (_ -> _) (f (x7 o (x5 o x2))) (f0 o f2)%functor} {H1 : IsIsomorphism x11} {x9 : Category.Core.morphism (_ -> _) f4 (f0 o f1)%functor} {fst_hyp : x7 o x5 o x2 = x7 o (x5 o x2)} (rew_hyp : forall x3 : p0, (idtoiso (p0 -> p) (ap f fst_hyp) : Category.Core.morphism _ _ _) x3 = x11^-1 x3 o (f0 _1 (x15^-1 x3) o (1 o (x9 (f3 x3) o x16 x3)))) {H0' : IsIsomorphism x16} {H1' : IsIsomorphism x9} {x13 : p} {x3 : p0} {x6 : p1} {x10 : p2} {x14 : Category.Core.morphism p (f0 x10) x13} {x12 : Category.Core.morphism p2 (f1 x6) x10} {x8 : Category.Core.morphism p1 (f3 x3) x6}, exist (fun f5 : Category.Core.morphism C x x4 => Category.Core.morphism p ((f f5) x3) x13) (x7 o x5 o x2) (x14 o (f0 _1 x12 o x9 x6) o (f4 _1 x8 o x16 x3)) = (x7 o (x5 o x2); x14 o (f0 _1 (x12 o (f1 _1 x8 o x15 x3)) o x11 x3)). Proof. helper_t assoc_before_commutes_tac. assoc_fin_tac. Qed. Lemma pseudofunctor_to_cat_left_identity_helper : forall {x1 x2 : C} {f : Category.Core.morphism C x2 x1} {p p0 : PreCategory} {f0 : Category.Core.morphism C x2 x1 -> Functor p0 p} {f1 : Functor p p} {x0 : Category.Core.morphism (_ -> _) (f0 (1 o f)) (f1 o f0 f)%functor} {x : Category.Core.morphism (_ -> _) f1 1%functor} {fst_hyp : 1 o f = f} (rewrite_hyp : forall x3 : p0, (idtoiso (p0 -> p) (ap f0 fst_hyp) : Category.Core.morphism _ _ _) x3 = 1 o (x ((f0 f) x3) o x0 x3)) {H0' : IsIsomorphism x0} {H1' : IsIsomorphism x} {x3 : p} {x4 : p0} {f' : Category.Core.morphism p ((f0 f) x4) x3}, exist (fun f2 : Category.Core.morphism C x2 x1 => Category.Core.morphism p ((f0 f2) x4) x3) (1 o f) (x x3 o (f1 _1 f' o x0 x4)) = (f; f'). Proof. helper_t idtac. Qed. Lemma pseudofunctor_to_cat_right_identity_helper : forall {x1 x2 : C} {f : Category.Core.morphism C x2 x1} {p p0 : PreCategory} {f0 : Category.Core.morphism C x2 x1 -> Functor p0 p} {f1 : Functor p0 p0} {x0 : Category.Core.morphism (_ -> _) (f0 (f o 1)) (f0 f o f1)%functor} {H0' : IsIsomorphism x0} {x : Category.Core.morphism (_ -> _) f1 1%functor} {H1' : IsIsomorphism x} {fst_hyp : f o 1 = f} (rew_hyp : forall x3 : p0, (idtoiso (p0 -> p) (ap f0 fst_hyp) : Category.Core.morphism _ _ _) x3 = 1 o ((f0 f) _1 (x x3) o x0 x3)) {x3 : p} {x4 : p0} {f' : Category.Core.morphism p ((f0 f) x4) x3}, exist (fun f2 : Category.Core.morphism C x2 x1 => Category.Core.morphism p ((f0 f2) x4) x3) (f o 1) (f' o ((f0 f) _1 (x x4) o x0 x4)) = (f; f'). Proof. helper_t idtac. Qed. (** ** Category of elements *) Definition category : PreCategory. Proof. refine (@Build_PreCategory Pair (fun s d => morphism s d) identity compose _ _ _ _); [ abstract ( intros ? ? ? ? [f ?] [g ?] [h ?]; exact (pseudofunctor_to_cat_assoc_helper (apD10 (ap components_of (p_composition_of_coherent_for_rewrite F _ _ _ _ f g h)))) ) | abstract ( intros ? ? [f ?]; exact (pseudofunctor_to_cat_left_identity_helper (apD10 (ap components_of (p_left_identity_of_coherent_for_rewrite F _ _ f)))) ) | abstract ( intros ? ? [f ?]; exact (pseudofunctor_to_cat_right_identity_helper (apD10 (ap components_of (p_right_identity_of_coherent_for_rewrite F _ _ f)))) ) ]. Defined. (** ** First projection functor *) Definition pr1 : Functor category C := Build_Functor category C c (fun s d => @pr1 _ _) (fun _ _ _ _ _ => idpath) (fun _ => idpath). End Grothendieck. Coq-HoTT-9.0/theories/Categories/Grothendieck/ToCat.v000066400000000000000000000016221474641544500224550ustar00rootroot00000000000000(** * Grothendieck Construction of a functor to Cat *) Require Import Category.Core Functor.Core. Require Import Pseudofunctor.FromFunctor. Require Import Cat.Core. Require Import Grothendieck.PseudofunctorToCat. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section Grothendieck. Context `{Funext}. Variable P : PreCategory -> Type. (*Context `{forall C, IsHProp (P C)}.*) Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation cat := (@sub_pre_cat _ P HF). Variable C : PreCategory. Variable F : Functor C cat. (** ** Category of elements *) Definition category : PreCategory := category (pseudofunctor_of_functor_to_cat F). (** ** First projection functor *) Definition pr1 : Functor category C := pr1 (pseudofunctor_of_functor_to_cat F). End Grothendieck. Coq-HoTT-9.0/theories/Categories/Grothendieck/ToSet.v000066400000000000000000000011021474641544500224720ustar00rootroot00000000000000(** * Grothendieck Construction of a functor to Set *) (** We want to have the following as subdirectories/modules, not at top level. Unfortunately, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *) (** ** construction *) Require Grothendieck.ToSet.Core. (** ** classification of morphisms *) Require Grothendieck.ToSet.Morphisms. (** ** preservation of saturation *) Require Grothendieck.ToSet.Univalent. Include Grothendieck.ToSet.Core. Coq-HoTT-9.0/theories/Categories/Grothendieck/ToSet/000077500000000000000000000000001474641544500223115ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Grothendieck/ToSet/Core.v000066400000000000000000000057021474641544500233740ustar00rootroot00000000000000(** * Grothendieck Construction of a functor to Set *) Require Import Category.Core Functor.Core. Require Import SetCategory.Core. Require Import Basics.Trunc Types.Sigma. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section Grothendieck. Context `{Funext}. (** Quoting Wikipedia: The Grothendieck construction is an auxiliary construction used in the mathematical field of category theory. Let << F : C → Set >> be a functor from any small category to the category of sets. The Grothendieck construct for [F] is the category [Γ F] whose objects are pairs [(c, x)], where [c : C] is an object and [x : F c] is an element, and for which the set [Hom (Γ F) (c1, x1) (c2, x2)] is the set of morphisms [f : c1 → c2] in [C] such that [F₁ f x1 = x2]. *) Variable C : PreCategory. Variable F : Functor C set_cat. Record Pair := { c : C; x : F c }. Definition issig_pair : { c : C | F c } <~> Pair. Proof. issig. Defined. Local Notation morphism s d := { f : morphism C s.(c) d.(c) | F _1 f s.(x) = d.(x) }. Definition compose_H s d d' (m1 : morphism d d') (m2 : morphism s d) : (F _1 (m1 .1 o m2 .1)) s.(x) = d'.(x). Proof. etransitivity; [ | exact (m1.2) ]. etransitivity; [ | apply ap; exact (m2.2) ]. match goal with | [ |- ?f ?x = ?g (?h ?x) ] => change (f x = (g o h) x) end. match goal with | [ |- ?f ?x = ?g ?x ] => apply (@apD10 _ _ f g) end. apply (composition_of F). Defined. Definition compose s d d' (m1 : morphism d d') (m2 : morphism s d) : morphism s d'. Proof. exists (m1.1 o m2.1). apply compose_H. Defined. Definition identity_H s := apD10 (identity_of F s.(c)) s.(x). Definition identity s : morphism s s. Proof. exists 1. apply identity_H. Defined. Global Arguments compose_H : simpl never. Global Arguments identity_H : simpl never. Global Arguments identity _ / . Global Arguments compose _ _ _ _ _ / . (** ** Category of elements *) Definition category : PreCategory. Proof. refine (@Build_PreCategory Pair (fun s d => morphism s d) identity compose _ _ _ _); abstract ( repeat intro; apply path_sigma_uncurried; simpl; ((exists (associativity _ _ _ _ _ _ _ _)) || (exists (left_identity _ _ _ _)) || (exists (right_identity _ _ _ _))); exact (center _) ). Defined. (** ** First projection functor *) Definition pr1 : Functor category C := Build_Functor category C c (fun s d => @pr1 _ _) (fun _ _ _ _ _ => idpath) (fun _ => idpath). End Grothendieck. Coq-HoTT-9.0/theories/Categories/Grothendieck/ToSet/Morphisms.v000066400000000000000000000032141474641544500244610ustar00rootroot00000000000000(** * Classification of morphisms of the Grothendieck Construction of a functor to Set *) Require Import Category.Core Functor.Core. Require Import Category.Morphisms. Require Import SetCategory.Core. Require Import Grothendieck.ToSet.Core. Require Import HoTT.Basics HoTT.Types. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section Grothendieck. Context `{Funext}. Context {C : PreCategory} {F : Functor C set_cat}. Definition isequiv_sigma_category_isomorphism {s d : category F} : (s <~=~> d)%category <~> { e : (s.(c) <~=~> d.(c))%category | (F _1 e s.(x) = d.(x))%category }. Proof. simple refine (equiv_adjointify _ _ _ _). { intro m. simple refine (_; _). { exists (m : morphism _ _ _).1. exists (m^-1).1. { exact (ap proj1 (@left_inverse _ _ _ m _)). } { exact (ap proj1 (@right_inverse _ _ _ m _)). } } { exact (m : morphism _ _ _).2. } } { intro m. exists (m.1 : morphism _ _ _ ; m.2). eexists (m.1^-1; ((ap (F _1 (m.1)^-1) m.2)^) @ (ap10 ((((composition_of F _ _ _ _ _)^) @ (ap (fun m => F _1 m) (@left_inverse _ _ _ m.1 _)) @ (identity_of F _)) : (F _1 (m.1 : morphism _ _ _)^-1) o F _1 m.1 = idmap) s.(x))); apply path_sigma_hprop. - exact left_inverse. - exact right_inverse. } { intro x; apply path_sigma_hprop; apply path_isomorphic. reflexivity. } { intro x; apply path_isomorphic; reflexivity. } Defined. End Grothendieck. Coq-HoTT-9.0/theories/Categories/Grothendieck/ToSet/Univalent.v000066400000000000000000000032311474641544500244440ustar00rootroot00000000000000(** * Saturation of the Grothendieck Construction of a functor to Set *) Require Import Category.Core Functor.Core. Require Import Category.Univalent. Require Import Category.Morphisms. Require Import SetCategory.Core. Require Import Grothendieck.ToSet.Core Grothendieck.ToSet.Morphisms. Require Import HoTT.Basics.Equivalences HoTT.Basics.Trunc. Require Import HoTT.Types.Universe HoTT.Types.Sigma. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section Grothendieck. Context `{Funext}. Variable C : PreCategory. Context `{IsCategory C}. Variable F : Functor C set_cat. Definition category_isotoid_helper {s d} (a : c s = c d) : (transport (fun c : C => F c) a (x s) = x d) <~> (F _1 (idtoiso C a)) (x s) = x d. Proof. apply equiv_path. apply ap10, ap. destruct a; simpl. exact (ap10 (identity_of F _)^ _). Defined. Arguments category_isotoid_helper : simpl never. Definition category_isotoid {s d : category F} : s = d <~> (s <~=~> d)%category. Proof. refine (isequiv_sigma_category_isomorphism^-1 oE _ oE (equiv_ap' (issig_pair F)^-1 s d)). refine (_ oE (equiv_path_sigma _ _ _)^-1). simpl. simple refine (equiv_functor_sigma' _ _). { exists (@idtoiso C _ _). exact _. } { exact category_isotoid_helper. } Defined. Global Instance preservation : IsCategory (category F). Proof. intros s d. refine (@isequiv_homotopic _ _ category_isotoid (idtoiso (category F) (x:=s) (y:=d)) _ _). intro x. destruct x; apply path_isomorphic, path_sigma_hprop. reflexivity. Defined. End Grothendieck. Coq-HoTT-9.0/theories/Categories/GroupoidCategory.v000066400000000000000000000005551474641544500223270ustar00rootroot00000000000000(** * Groupoids *) (** ** Definition *) Require GroupoidCategory.Core. (** ** Morphisms in a groupoid *) Require GroupoidCategory.Morphisms. (** ** Propositional self-duality *) Require GroupoidCategory.Dual. Include GroupoidCategory.Core. Include GroupoidCategory.Core.GroupoidCategoryInternals. Include GroupoidCategory.Morphisms. Include GroupoidCategory.Dual. Coq-HoTT-9.0/theories/Categories/GroupoidCategory/000077500000000000000000000000001474641544500221335ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/GroupoidCategory/Core.v000066400000000000000000000044171474641544500232200ustar00rootroot00000000000000(** * Groupoids *) Require Import Category.Morphisms Category.Strict. Require Import Trunc PathGroupoids Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. (** A groupoid is a precategory where every morphism is an isomorphism. Since 1-types are 1-groupoids, we can construct the category corresponding to the 1-groupoid of a 1-type. *) (** ** Definition of what it means to be a groupoid *) Class IsGroupoid (C : PreCategory) := isgroupoid : forall s d (m : morphism C s d), IsIsomorphism m. Global Instance trunc_isgroupoid `{Funext} C : IsHProp (IsGroupoid C) := istrunc_forall. (** We don't want access to all of the internals of a groupoid category at top level. *) Module GroupoidCategoryInternals. Section groupoid_category. Variable X : Type. Context `{IsTrunc 1 X}. Local Notation morphism := (@paths X). Definition compose s d d' (m : morphism d d') (m' : morphism s d) : morphism s d' := transitivity m' m. Definition identity x : morphism x x := reflexivity _. Global Arguments compose [s d d'] m m' / . Global Arguments identity x / . End groupoid_category. End GroupoidCategoryInternals. (** ** Categorification of the groupoid of a 1-type *) Definition groupoid_category X `{IsTrunc 1 X} : PreCategory. Proof. refine (@Build_PreCategory X (@paths X) (@GroupoidCategoryInternals.identity X) (@GroupoidCategoryInternals.compose X) _ _ _ _); simpl; intros; path_induction; reflexivity. Defined. Arguments groupoid_category X {_}. Global Instance isgroupoid_groupoid_category X `{IsTrunc 1 X} : IsGroupoid (groupoid_category X). Proof. intros s d m; simpl in *. exact (Build_IsIsomorphism (groupoid_category X) s d m m^%path (concat_pV m) (concat_Vp m)). Defined. (** ** 0-types give rise to strict (groupoid) categories *) Lemma isstrict_groupoid_category X `{IsHSet X} : IsStrictCategory (groupoid_category X). Proof. typeclasses eauto. Defined. Coq-HoTT-9.0/theories/Categories/GroupoidCategory/Dual.v000066400000000000000000000015711474641544500232130ustar00rootroot00000000000000(** * Propositional self-duality of groupoid categories *) Require Import Category.Core GroupoidCategory.Core Category.Paths Category.Dual. Require Import HoTT.Types. Require Import Basics.Trunc Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Lemma path_groupoid_dual `{Univalence} `{IsTrunc 1 X} : (groupoid_category X)^op = groupoid_category X. Proof. repeat match goal with | _ => intro | _ => progress cbn | _ => reflexivity | _ => apply path_forall | _ => apply (path_universe (symmetry _ _)) | _ => exact (center _) | _ => progress rewrite ?transport_path_universe, ?transport_path_universe_V | _ => progress path_category | _ => progress path_induction end. Qed. Coq-HoTT-9.0/theories/Categories/GroupoidCategory/Morphisms.v000066400000000000000000000016441474641544500243100ustar00rootroot00000000000000(** * Morphisms in a groupoid *) Require Import Category.Core Category.Morphisms Category.Univalent GroupoidCategory.Core. Require Import Trunc Equivalences HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Section groupoid_category. Variable X : Type. Context `{IsTrunc 1 X}. Definition isotoid (s d : groupoid_category X) : s <~=~> d -> s = d := fun f => f : morphism _ _ _. (** ** All groupoids are categories *) Global Instance iscategory_groupoid_category : IsCategory (groupoid_category X). Proof. repeat intro. apply (isequiv_adjointify (@idtoiso (groupoid_category X) _ _) (@isotoid _ _)); repeat intro; destruct_head @Isomorphic; destruct_head @IsIsomorphism; compute in *; path_induction_hammer. Qed. End groupoid_category. Coq-HoTT-9.0/theories/Categories/HomFunctor.v000066400000000000000000000037031474641544500211230ustar00rootroot00000000000000(** * Hom Functor *) Require Import Category.Core Functor.Core SetCategory.Core Category.Dual. Require Functor.Prod.Core. Import Category.Prod.CategoryProdNotations Functor.Prod.Core.FunctorProdCoreNotations. Require Import Basics.Trunc. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. (** ** Definition of [hom : Cᵒᵖ × C → Set] as a functor *) Section hom_functor. Context `{Funext}. Variable C : PreCategory. Local Notation obj_of c'c := (Build_HSet (morphism C (fst (c'c : object (C^op * C))) (snd (c'c : object (C^op * C))))). Let hom_functor_morphism_of s's d'd (hf : morphism (C^op * C) s's d'd) : morphism set_cat (obj_of s's) (obj_of d'd) := fun g => snd hf o g o fst hf. Definition hom_functor : Functor (C^op * C) set_cat. refine (Build_Functor (C^op * C) set_cat (fun c'c => obj_of c'c) hom_functor_morphism_of _ _); subst hom_functor_morphism_of; simpl; abstract ( repeat (apply path_forall || intros [] || intro); simpl in *; rewrite <- ?associativity, ?left_identity, ?right_identity; reflexivity ). Defined. End hom_functor. Section covariant_contravariant. Context `{Funext}. Variable C : PreCategory. Local Open Scope functor_scope. Local Arguments Functor.Prod.Core.induced_snd / . Local Arguments Functor.Prod.Core.induced_fst / . (** ** Covariant hom functor [hom_C(A, ─) : C → set] *) Definition covariant_hom_functor (A : object C^op) := Eval simpl in Functor.Prod.Core.induced_snd (hom_functor C) A. (** ** Contravariant hom functor [hom_C(─, A) : Cᵒᵖ → set] *) Definition contravariant_hom_functor (A : C) := Eval simpl in Functor.Prod.Core.induced_fst (hom_functor C) A. End covariant_contravariant. Coq-HoTT-9.0/theories/Categories/HomotopyPreCategory.v000066400000000000000000000042241474641544500230210ustar00rootroot00000000000000(** * Homotopy PreCategory of Types *) Require Import Category.Core. Require Import HoTT.Basics HoTT.Truncations.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope category_scope. (** Quoting the HoTT Book: Example. There is a precategory whose type of objects is [U] and with [hom(X,Y) : ∥X → Y∥₀], and composition defined by induction on truncation from ordinary composition [(Y → Z) → (X → Y) → (X → Z)]. We call this the homotopy precategory of types. *) (** We don't want access to all of the internals of this category at top level. *) Module HomotopyPreCategoryInternals. Section homotopy_precategory. Local Notation object := Type (only parsing). Local Notation morphism s d := (Trunc 0 (s -> d)) (only parsing). Definition compose s d d' (m : morphism d d') (m' : morphism s d) : morphism s d'. Proof. revert m'; apply Trunc_rec; intro m'. revert m; apply Trunc_rec; intro m. apply tr. exact (m o m')%core. Defined. Definition identity x : morphism x x := tr idmap. Global Arguments compose [s d d'] m m' / . Global Arguments identity x / . End homotopy_precategory. End HomotopyPreCategoryInternals. (** ** The Homotopy PreCategory of Types *) Definition homotopy_precategory : PreCategory. Proof. refine (@Build_PreCategory Type _ (@HomotopyPreCategoryInternals.identity) (@HomotopyPreCategoryInternals.compose) _ _ _ _); simpl; intros; repeat match goal with | [ m : Trunc _ _ |- _ ] => revert m; apply Trunc_ind; [ intro; match goal with | [ |- IsHSet (?a = ?b :> ?T) ] => generalize a b; intros; let H := fresh in assert (H : forall x y : T, IsHProp (x = y)) end; typeclasses eauto | intro ] end; simpl; apply ap; exact idpath. Defined. Coq-HoTT-9.0/theories/Categories/IndiscreteCategory.v000066400000000000000000000046531474641544500226330ustar00rootroot00000000000000(** * Indiscrete category *) Require Import Functor.Core Category.Strict Category.Univalent Category.Morphisms. Require Import Types.Unit Trunc HoTT.Tactics Equivalences. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** ** Definition of an indiscrete category *) Module Export Core. Section indiscrete_category. (** The indiscrete category has exactly one morphism between any two objects. *) Variable X : Type. (** We define the symmetrized version of associaitivity differently so that the dual of an indiscrete category is convertible with the indiscrete category. *) Definition indiscrete_category : PreCategory := @Build_PreCategory' X (fun _ _ => Unit) (fun _ => tt) (fun _ _ _ _ _ => tt) (fun _ _ _ _ _ _ _ => idpath) (fun _ _ _ _ _ _ _ => idpath) (fun _ _ f => match f with tt => idpath end) (fun _ _ f => match f with tt => idpath end) (fun _ => idpath) _. End indiscrete_category. (** *** Indiscrete categories are strict categories *) Definition isstrict_indiscrete_category `{H : IsHSet X} : IsStrictCategory (indiscrete_category X) := H. (** *** Indiscrete categories are (saturated/univalent) categories *) Global Instance iscategory_indiscrete_category `{H : IsHProp X} : IsCategory (indiscrete_category X). Proof. intros. eapply (isequiv_adjointify (idtoiso (indiscrete_category X) (x := s) (y := d)) (fun _ => center _)); abstract ( repeat intro; destruct_head_hnf @Isomorphic; destruct_head_hnf @IsIsomorphism; destruct_head_hnf @Unit; path_induction_hammer ). Defined. End Core. (** ** Functors to an indiscrete category are given by their action on objects *) Module Functors. Section to. Variable X : Type. Variable C : PreCategory. Variable objOf : C -> X. Definition to : Functor C (indiscrete_category X) := Build_Functor C (indiscrete_category X) objOf (fun _ _ _ => tt) (fun _ _ _ _ _ => idpath) (fun _ => idpath). End to. End Functors. Coq-HoTT-9.0/theories/Categories/InitialTerminalCategory.v000066400000000000000000000015141474641544500236200ustar00rootroot00000000000000(** * Initial and terminal categories *) (** ** Definitions *) Require InitialTerminalCategory.Core. Include InitialTerminalCategory.Core. (** We want to have the following as subdirectories/modules, not at top level. Unfortunately, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *) (** ** Functors to and from initial and terminal categories *) Require InitialTerminalCategory.Functors. (** ** Natural transformations between functors from initial categories and to terminal categories *) Require InitialTerminalCategory.NaturalTransformations. (** ** Pseudounctors from initial and terminal categories *) Require InitialTerminalCategory.Pseudofunctors. Require Export InitialTerminalCategory.Notations. Coq-HoTT-9.0/theories/Categories/InitialTerminalCategory/000077500000000000000000000000001474641544500234305ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/InitialTerminalCategory/Core.v000066400000000000000000000032131474641544500245060ustar00rootroot00000000000000(** * Initial and terminal category definitions *) Require Import HoTT.Basics HoTT.Types. Require Import Category.Core. Require Import NatCategory. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Unset Primitive Projections. (* suppress a warning about [IsTerminalCategory] *) Notation initial_category := (nat_category 0) (only parsing). Notation terminal_category := (nat_category 1) (only parsing). (** ** Terminal categories *) (** A precategory is terminal if its objects and morphisms are contractible types. *) Class IsTerminalCategory (C : PreCategory) `{Contr (object C)} `{forall s d, Contr (morphism C s d)} : Type0 := {}. (** ** Initial categories *) (** An initial precategory is one whose objects have the recursion priniciple of the empty type *) Class IsInitialCategory (C : PreCategory) := initial_category_ind : forall P : Type, C -> P. Global Instance trunc_initial_category `{IsInitialCategory C} : IsHProp C := istrunc_S _ (fun x y => initial_category_ind _ x). Global Instance trunc_initial_category_mor `{IsInitialCategory C} x y : Contr (morphism C x y) := initial_category_ind _ x. (** ** Default intitial ([0]) and terminal ([1]) precategories. *) Global Instance is_initial_category_0 : IsInitialCategory 0 := (fun T => @Empty_ind (fun _ => T)). Global Instance: IsTerminalCategory 1 | 0 := {}. Global Instance: Contr (object 1) | 0 := _. Global Instance : `{Contr (morphism 1 x y)} | 0 := fun x y => _. Global Instance default_terminal C {H H1} : @IsTerminalCategory C H H1 | 10 := {}. Arguments initial_category_ind / . Arguments is_initial_category_0 / . Coq-HoTT-9.0/theories/Categories/InitialTerminalCategory/Functors.v000066400000000000000000000063141474641544500254260ustar00rootroot00000000000000(** * Functors to and from initial and terminal categories *) Require Import Category.Core Functor.Core Functor.Paths. Require Import InitialTerminalCategory.Core. Require Import NatCategory. Require Import HoTT.Basics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section functors. Variable C : PreCategory. (** *** Functor to any terminal category *) Definition to_terminal `{@IsTerminalCategory one Hone Hone'} : Functor C one := Build_Functor C one (fun _ => center _) (fun _ _ _ => center _) (fun _ _ _ _ _ => contr _) (fun _ => contr _). (** *** Constant functor from any terminal category *) Definition from_terminal `{@IsTerminalCategory one Hone Hone'} (c : C) : Functor one C := Build_Functor one C (fun _ => c) (fun _ _ _ => identity c) (fun _ _ _ _ _ => symmetry _ _ (@identity_identity _ _)) (fun _ => idpath). (** *** Functor from any initial category *) Definition from_initial `{@IsInitialCategory zero} : Functor zero C := Build_Functor zero C (fun x => initial_category_ind _ x) (fun x _ _ => initial_category_ind _ x) (fun x _ _ _ _ => initial_category_ind _ x) (fun x => initial_category_ind _ x). End functors. Local Arguments to_terminal / . Local Arguments from_terminal / . Local Arguments from_initial / . Definition to_1 C : Functor C 1 := Eval simpl in to_terminal C. Definition from_1 C c : Functor 1 C := Eval simpl in from_terminal C c. Definition from_0 C : Functor 0 C := Eval simpl in from_initial C. Local Notation "! x" := (@from_terminal _ terminal_category _ _ _ x) : functor_scope. (** *** Uniqueness principles about initial and terminal categories and functors *) Section unique. Context `{Funext}. Global Instance trunc_initial_category_function `{@IsInitialCategory zero} T : Contr (zero -> T). Proof. refine (Build_Contr _ (initial_category_ind _) _). intro y. apply path_forall; intro x. apply (initial_category_ind _ x). Defined. Variable C : PreCategory. Global Instance trunc_initial_category `{@IsInitialCategory zero} : Contr (Functor zero C). Proof. refine (Build_Contr _ (from_initial C) _). abstract ( intros; apply path_functor_uncurried; (exists (center _)); apply path_forall; intro x; apply (initial_category_ind _ x) ). Defined. Global Instance trunc_to_initial_category `{@IsInitialCategory zero} : IsHProp (Functor C zero). Proof. typeclasses eauto. Qed. Definition to_initial_category_empty `{@IsInitialCategory zero} (F : Functor C zero) : IsInitialCategory C := fun P x => initial_category_ind P (F x). Global Instance trunc_terminal_category `{@IsTerminalCategory one H1 H2} : Contr (Functor C one). Proof. refine (Build_Contr _ (to_terminal C) _). intros. exact (center _). Defined. End unique. Module Export InitialTerminalCategoryFunctorsNotations. Notation "! x" := (@from_terminal _ terminal_category _ _ _ x) : functor_scope. End InitialTerminalCategoryFunctorsNotations. Coq-HoTT-9.0/theories/Categories/InitialTerminalCategory/NaturalTransformations.v000066400000000000000000000035711474641544500303450ustar00rootroot00000000000000(** * Natural transformations between functors from initial categories and to terminal categories *) Require Import Category.Core Functor.Core NaturalTransformation.Core NaturalTransformation.Paths. Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors. Require Import Contractible. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section NaturalTransformations. Variable C : PreCategory. Definition from_initial `{@IsInitialCategory zero} (F G : Functor zero C) : NaturalTransformation F G := Build_NaturalTransformation F G (fun x => initial_category_ind _ x) (fun x _ _ => initial_category_ind _ x). Global Instance trunc_from_initial `{Funext} `{@IsInitialCategory zero} (F G : Functor zero C) : Contr (NaturalTransformation F G). Proof. refine (Build_Contr _ (from_initial F G) _). abstract ( intros; apply path_natural_transformation; intro x; exact (initial_category_ind _ x) ). Defined. Local Existing Instance Functors.to_initial_category_empty. Global Instance trunc_to_initial `{Funext} `{@IsInitialCategory zero} (F G : Functor zero C) : Contr (NaturalTransformation F G) := trunc_from_initial F G. Definition to_terminal `{@IsTerminalCategory one H1 H2} (F G : Functor C one) : NaturalTransformation F G := Build_NaturalTransformation F G (fun x => center _) (fun _ _ _ => path_contr _ _). Global Instance trunc_to_terminal `{Funext} `{@IsTerminalCategory one H1 H2} (F G : Functor C one) : Contr (NaturalTransformation F G). Proof. refine (Build_Contr _ (to_terminal F G) _). abstract (path_natural_transformation; exact (contr _)). Defined. End NaturalTransformations. Coq-HoTT-9.0/theories/Categories/InitialTerminalCategory/Notations.v000066400000000000000000000004741474641544500256020ustar00rootroot00000000000000(** * Initial and terminal category notations *) Require InitialTerminalCategory.Functors. Require InitialTerminalCategory.Pseudofunctors. Export InitialTerminalCategory.Functors.InitialTerminalCategoryFunctorsNotations. Export InitialTerminalCategory.Pseudofunctors.InitialTerminalCategoryPseudofunctorsNotations. Coq-HoTT-9.0/theories/Categories/InitialTerminalCategory/Pseudofunctors.v000066400000000000000000000041531474641544500266450ustar00rootroot00000000000000(** * Pseudofunctors from initial and terminal categories *) Require Import Category.Core Functor.Core. Require Import Functor.Identity. Require Import Pseudofunctor.Core. Require Import InitialTerminalCategory.Core. Require Import FunctorCategory.Morphisms. Require Import NaturalTransformation.Paths. Require Import NatCategory. Require Import PathGroupoids. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section pseudofunctors. (** ** Constant functor from any terminal category *) Definition from_terminal `{Funext} `{@IsTerminalCategory one Hone Hone'} (c : PreCategory) : Pseudofunctor one. Proof. refine (Build_Pseudofunctor one (fun _ => c) (fun _ _ _ => 1%functor) (fun _ _ _ _ _ => reflexivity _) (fun _ => reflexivity _) _ _ _); simpl; abstract ( intros; path_natural_transformation; rewrite ap_const; simpl; reflexivity ). Defined. (** *** Functor from any initial category *) Definition from_initial `{Funext} `{@IsInitialCategory zero} : Pseudofunctor zero := Build_Pseudofunctor zero (fun x => initial_category_ind _ x) (fun x _ _ => initial_category_ind _ x) (fun x _ _ _ _ => initial_category_ind _ x) (fun x => initial_category_ind _ x) (fun x => initial_category_ind _ x) (fun x => initial_category_ind _ x) (fun x => initial_category_ind _ x). End pseudofunctors. Local Arguments from_terminal / . Local Arguments from_initial / . Definition from_1 `{Funext} c : Pseudofunctor 1 := Eval simpl in from_terminal c. Definition from_0 `{Funext} : Pseudofunctor 0 := Eval simpl in from_initial. Local Notation "! x" := (@from_terminal _ terminal_category _ _ _ x) : pseudofunctor_scope. Module Export InitialTerminalCategoryPseudofunctorsNotations. Notation "! x" := (@from_terminal _ terminal_category _ _ _ x) : pseudofunctor_scope. End InitialTerminalCategoryPseudofunctorsNotations. Coq-HoTT-9.0/theories/Categories/KanExtensions.v000066400000000000000000000003271474641544500216270ustar00rootroot00000000000000(** * Kan Extensions *) (** ** Definitions *) Require KanExtensions.Core. (** ** Kan Extensions assemble into functors *) Require KanExtensions.Functors. Include KanExtensions.Core. Include KanExtensions.Functors. Coq-HoTT-9.0/theories/Categories/KanExtensions/000077500000000000000000000000001474641544500214365ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/KanExtensions/Core.v000066400000000000000000000116451474641544500225240ustar00rootroot00000000000000(** * Kan Extensions *) Require Import Category.Core Functor.Core. Require Import FunctorCategory.Core. Require Import Functor.Composition.Functorial.Core. Require Import UniversalProperties. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. (** Quoting nCatLab on Kan Exensions: ** Idea The Kan extension of a functor [F : C → D] with respect to a functor << C | | p ↓ C' >> is, if it exists, a kind of best approximation to the problem of finding a functor [C' → D] such that << F C -----> D | ↗ | p / | / ↓ / C' >> hence to extending the domain of [F] through [p] from [C] to [C']. More generally, this makes sense not only in Cat but in any 2-category. Similarly, a Kan lift is the best approximation to lifting a morphism [F : C → D] through a morphism << D' | ↓ D >> to a morphism [F̂] << D' ↗ | / | F̂ / | / | / F ↓ C --------> D >> Kan extensions are ubiquitous. See the discussion at Examples below. ** Definitions There are various slight variants of the definition of Kan extension. In good cases they all exist and all coincide, but in some cases only some of these will actually exist. We (have to) distinguish the following cases: - “ordinary” or “weak” Kan extensions These define the extension of an entire functor, by an adjointness relation. Here we (have to) distinguish further between - global Kan extensions, which define extensions of all possible functors of given domain and codomain (if all of them indeed exist); - local Kan extensions, which define extensions of single functors only, which may exist even if not every functor has an extension. - “pointwise” or “strong” Kan extensions These define the value of an extended functor on each object (each “point”) by a weighted (co)limit. Furthermore, a pointwise Kan extension can be “absolute”. If the pointwise version exists, then it coincides with the “ordinary” or “weak” version, but the former may exist without the pointwise version existing. See below for more. Some authors (such as Kelly) assert that only pointwise Kan extensions deserve the name “Kan extension,” and use the term as “weak Kan extension” for a functor equipped with a universal natural transformation. It is certainly true that most Kan extensions which arise in practice are pointwise. This distinction is even more important in enriched category theory. *) Section kan_extensions. (** ** Ordinary or weak Kan extensions *** Global Kan extensions Let [p : C → C'] be a functor. For [D] any other category, write [p* : (C' → D) → (C → D)] for the induced functor on the functor categories: this sends a functor [h : C' → D] to the composite functor << p h p* h : C --> C' --> D >> *) (** *** Pullback-along functor *) Context `{Funext}. Variables C C' D : PreCategory. Section pullback_along. Definition pullback_along_functor : object ((C -> C') -> (C' -> D) -> (C -> D)) := Functor.Composition.Functorial.Core.compose_functor _ _ _. Definition pullback_along (p : Functor C C') : object ((C' -> D) -> (C -> D)) := Eval hnf in pullback_along_functor p. End pullback_along. (** Definition. If [p*] has a left adjoint, typically denoted [p_! : (C → D) → (C' → D)] or [Lan_p : (C → D) → (C' → D)] then this left adjoint is called the (ordinary or weak) left Kan extension operation along [p]. For [h ∈ (C -> D)] we call [p_! h] the left Kan extension of [h] along [p]. Similarly, if [p*] has a right adjoint, this right adjoint is called the right Kan extension operation along [p]. It is typically denoted [p_* : (C → D) → (C' → D)] or [Ran = Ran_p : (C → D) → (C' → D)]. The analogous definition clearly makes sense as stated in other contexts, such as in enriched category theory. Observation. If [C' = 1] is the terminal category, then - the left Kan extension operation forms the colimit of a functor; - the right Kan extension operation forms the limit of a functor. *) (** *** Left Kan extensions *) (** Colimits are initial morphisms. *) Definition IsLeftKanExtensionAlong (p : Functor C C') (h : Functor C D) := @IsInitialMorphism (_ -> _) _ h (pullback_along p). (** *** Right Kan extensions *) (** Limits are terminal morphisms *) Definition IsRightKanExtensionAlong (p : Functor C C') (h : Functor C D) := @IsTerminalMorphism _ (_ -> _) (pullback_along p) h. End kan_extensions. Coq-HoTT-9.0/theories/Categories/KanExtensions/Functors.v000066400000000000000000000030541474641544500234320ustar00rootroot00000000000000(** * Kan extensions assemble into functors *) Require Import Category.Core Functor.Core. Require Import KanExtensions.Core. Require Import Adjoint.UniversalMorphisms.Core. Require Import FunctorCategory.Core. Require Import Adjoint.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section kan_extension_functors. Context `{Funext}. Variables C C' D : PreCategory. Variable p : object (C -> C'). (** ** Left Kan extension functor *) Section lan. Context `(has_left_kan_extensions : forall h : object (C -> D), @IsLeftKanExtensionAlong _ _ _ _ p h (left_kan_extensions h)). Definition left_kan_extension_functor : Functor (C -> D) (C' -> D) := functor__of__initial_morphism has_left_kan_extensions. Definition left_kan_extension_adjunction : left_kan_extension_functor -| pullback_along D p := adjunction__of__initial_morphism has_left_kan_extensions. End lan. (** ** Right Kan extension functor *) Section ran. Context `(has_right_kan_extensions : forall h : object (C -> D), @IsRightKanExtensionAlong _ _ _ _ p h (right_kan_extensions h)). Definition right_kan_extension_functor : Functor (C -> D) (C' -> D) := functor__of__terminal_morphism has_right_kan_extensions. Definition right_kan_extension_adjunction : pullback_along D p -| right_kan_extension_functor := adjunction__of__terminal_morphism has_right_kan_extensions. End ran. End kan_extension_functors. Coq-HoTT-9.0/theories/Categories/LaxComma.v000066400000000000000000000005451474641544500205410ustar00rootroot00000000000000(** * Lax Comma Categories *) (** Since there are only notations in [LaxComma.Notations], we can just export those. *) Local Set Warnings Append "-notation-overridden". Require Export LaxComma.Notations. (** ** Definitions *) Require LaxComma.Core. Include LaxComma.Core. (** We don't want to make utf-8 notations the default, so we don't export them. *) Coq-HoTT-9.0/theories/Categories/LaxComma/000077500000000000000000000000001474641544500203465ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/LaxComma/Core.v000066400000000000000000000260431474641544500214320ustar00rootroot00000000000000(** * Lax Comma Category *) Require Import Functor.Core. Require Import Category.Dual. Require Import InitialTerminalCategory.Core InitialTerminalCategory.Pseudofunctors. Require Import Cat.Core. Require Pseudofunctor.Identity. Require Import Category.Strict. Require Import NaturalTransformation.Paths. Require Import Pseudofunctor.Core. Require LaxComma.CoreLaws. Import Functor.Identity.FunctorIdentityNotations. Import Pseudofunctor.Identity.PseudofunctorIdentityNotations. Import LaxComma.CoreLaws.LaxCommaCategory. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. (** Quoting David Spivak: David: ok so an object of [FC ⇓ D] is a pair [(X, G)], where [X] is a finite category (or a small category or whatever you wanted) and [G : X --> D] is a functor. a morphism in [FC ⇓ D] is a ``natural transformation diagram'' (as opposed to a commutative diagram, in which the natural transformation would be ``identity'') so a map in [FC ⇓ D] from [(X, G)] to [(X', G')] is a pair [(F, α)] where [F : X --> X'] is a functor and [α : G --> G' ∘ F] is a natural transformation and the punchline is that there is a functor [colim : FC ⇓ D --> D] David: consider for yourself the case where [F : X --> X'] is identity ([X = X']) and (separately) the case where [α : G --> G ∘ F] is identity. the point is, you've already done the work to get this colim functor. because every map in [FC ⇓ D] can be written as a composition of two maps, one where the [F]-part is identity and one where the [α]-part is identity. and you've worked both of those cases out already. *) (** ** Definition of Lax Comma Category *) Definition lax_comma_category `{Funext} A B (S : Pseudofunctor A) (T : Pseudofunctor B) `{forall a b, IsHSet (Functor (S a) (T b))} : PreCategory := @Build_PreCategory (@object _ _ _ S T) (@morphism _ _ _ S T) (@identity _ _ _ S T) (@compose _ _ _ S T) (@associativity _ _ _ S T) (@left_identity _ _ _ S T) (@right_identity _ _ _ S T) _. Definition oplax_comma_category `{Funext} A B (S : Pseudofunctor A) (T : Pseudofunctor B) `{forall a b, IsHSet (Functor (S a) (T b))} : PreCategory := (lax_comma_category S T)^op. Global Instance isstrict_lax_comma_category `{Funext} A B (S : Pseudofunctor A) (T : Pseudofunctor B) `{IsStrictCategory A, IsStrictCategory B} `{forall a b, IsHSet (Functor (S a) (T b))} : IsStrictCategory (@lax_comma_category _ A B S T _). Proof. typeclasses eauto. Qed. Global Instance isstrict_oplax_comma_category `{fs : Funext} A B S T HA HB H : IsStrictCategory (@oplax_comma_category fs A B S T H) := @isstrict_lax_comma_category fs A B S T HA HB H. (* Section category. Context `{IsCategory A, IsCategory B}. (*Context `{Funext}. *) Definition comma_category_isotoid (x y : comma_category) : x ≅ y -> x = y. Proof. intro i. destruct i as [i [i' ? ?]]. hnf in *. destruct i, i'. simpl in *. Global Instance comma_category_IsCategory `{IsCategory A, IsCategory B} : IsCategory comma_category. Proof. hnf. unfold IsStrictCategory in *. typeclasses eauto. Qed. End category. *) (** ** Definition of Lax (Co)Slice Category *) Section lax_slice_category. Context `{Funext}. Variables A a : PreCategory. Variable S : Pseudofunctor A. Context `{forall a0, IsHSet (Functor (S a0) a)}. Context `{forall a0, IsHSet (Functor a (S a0))}. Definition lax_slice_category : PreCategory := lax_comma_category S !a. Definition lax_coslice_category : PreCategory := lax_comma_category !a S. Definition oplax_slice_category : PreCategory := oplax_comma_category S !a. Definition oplax_coslice_category : PreCategory := oplax_comma_category !a S. (** [x ↓ F] is a coslice category; [F ↓ x] is a slice category; [x ↓ F] deals with morphisms [x -> F y]; [F ↓ x] has morphisms [F y -> x] *) End lax_slice_category. Arguments lax_slice_category {_} [A] a S {_}. Arguments lax_coslice_category {_} [A] a S {_}. Arguments oplax_slice_category {_} [A] a S {_}. Arguments oplax_coslice_category {_} [A] a S {_}. (** ** Definition of Lax (Co)Slice Category Over *) Section lax_slice_category_over. Local Open Scope type_scope. Context `{Funext}. Variable P : PreCategory -> Type. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation cat := (@sub_pre_cat _ P HF). Variable a : PreCategory. Context `{forall a0 : cat, IsHSet (Functor a0.1 a)}. Context `{forall a0 : cat, IsHSet (Functor a a0.1)}. Definition lax_slice_category_over : PreCategory := @lax_slice_category _ cat a (Pseudofunctor.Identity.identity P) _. Definition lax_coslice_category_over : PreCategory := @lax_coslice_category _ cat a (Pseudofunctor.Identity.identity P) _. Definition oplax_slice_category_over : PreCategory := @oplax_slice_category _ cat a (Pseudofunctor.Identity.identity P) _. Definition oplax_coslice_category_over : PreCategory := @oplax_coslice_category _ cat a (Pseudofunctor.Identity.identity P) _. End lax_slice_category_over. Arguments lax_slice_category_over {_} P {HF} a {_}. Arguments lax_coslice_category_over {_} P {HF} a {_}. Arguments oplax_slice_category_over {_} P {HF} a {_}. Arguments oplax_coslice_category_over {_} P {HF} a {_}. (** ** Definition of Lax (Co)Slice Arrow Category *) Section lax_arrow_category. Local Open Scope type_scope. Context `{Funext}. Variable P : PreCategory -> Type. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation cat := (@sub_pre_cat _ P HF). Definition lax_arrow_category : PreCategory := @lax_comma_category _ cat cat (Pseudofunctor.Identity.identity P) (Pseudofunctor.Identity.identity P) (fun C D => HF C.2 D.2). Definition oplax_arrow_category : PreCategory := @oplax_comma_category _ cat cat (Pseudofunctor.Identity.identity P) (Pseudofunctor.Identity.identity P) (fun C D => HF C.2 D.2). End lax_arrow_category. Arguments lax_arrow_category {_} P {_}. Arguments oplax_arrow_category {_} P {_}. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Module Export LaxCommaCoreNotations. (** We play some games to get nice notations for lax comma categories. *) Section tc_notation_boiler_plate. Local Open Scope type_scope. Class LCC_Builder {A B C} (x : A) (y : B) (z : C) : Set := lcc_builder_dummy : Unit. Definition get_LCC `{@LCC_Builder A B C x y z} : C := z. Global Arguments get_LCC / {A B C} x y {z} {_}. Global Instance LCC_comma `{Funext} A B (S : Pseudofunctor A) (T : Pseudofunctor B) {_ : forall a b, IsHSet (Functor (S a) (T b))} : LCC_Builder S T (lax_comma_category S T) | 1000 := tt. Global Instance LCC_slice `{Funext} A x (F : Pseudofunctor A) `{forall a0, IsHSet (Functor (F a0) x)} : LCC_Builder F x (lax_slice_category x F) | 100 := tt. Global Instance LCC_coslice `{Funext} A x (F : Pseudofunctor A) `{forall a0, IsHSet (Functor x (F a0))} : LCC_Builder x F (lax_coslice_category x F) | 100 := tt. Global Instance LCC_slice_over `{Funext} P `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)} a `{forall a0 : @sub_pre_cat _ P HF, IsHSet (Functor a0.1 a)} : LCC_Builder a (@sub_pre_cat _ P HF) (@lax_slice_category_over _ P HF a _) | 10 := tt. Global Instance LCC_coslice_over `{Funext} P `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)} a `{forall a0 : @sub_pre_cat _ P HF, IsHSet (Functor a a0.1)} : LCC_Builder (@sub_pre_cat _ P HF) a (@lax_coslice_category_over _ P HF a _) | 10 := tt. Class OLCC_Builder {A B C} (x : A) (y : B) (z : C) : Set := olcc_builder_dummy : Unit. Definition get_OLCC `{@OLCC_Builder A B C x y z} : C := z. Global Arguments get_OLCC / {A B C} x y {z} {_}. Global Instance OLCC_comma `{Funext} A B (S : Pseudofunctor A) (T : Pseudofunctor B) {_ : forall a b, IsHSet (Functor (S a) (T b))} : OLCC_Builder S T (lax_comma_category S T) | 1000 := tt. Global Instance OLCC_slice `{Funext} A x (F : Pseudofunctor A) `{forall a0, IsHSet (Functor (F a0) x)} : OLCC_Builder F x (lax_slice_category x F) | 100 := tt. Global Instance OLCC_coslice `{Funext} A x (F : Pseudofunctor A) `{forall a0, IsHSet (Functor x (F a0))} : OLCC_Builder x F (lax_coslice_category x F) | 100 := tt. Global Instance OLCC_slice_over `{Funext} P `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)} a `{forall a0 : @sub_pre_cat _ P HF, IsHSet (Functor a0.1 a)} : OLCC_Builder a (@sub_pre_cat _ P HF) (@lax_slice_category_over _ P HF a _) | 10 := tt. Global Instance OLCC_coslice_over `{Funext} P `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)} a `{forall a0 : @sub_pre_cat _ P HF, IsHSet (Functor a a0.1)} : OLCC_Builder (@sub_pre_cat _ P HF) a (@lax_coslice_category_over _ P HF a _) | 10 := tt. End tc_notation_boiler_plate. (** We really want to use infix [⇓] and [⇑] for lax comma categories, but that's unicode. Infix [,] might also be reasonable, but I can't seem to get it to work without destroying the [(_, _)] notation for ordered pairs. So I settle for the ugly ASCII rendition [//] of [⇓] and [\\] for [⇑]. *) (** Set some notations for printing *) Notation "'CAT' // a" := (@lax_slice_category_over _ _ _ a _) : category_scope. Notation "a // 'CAT'" := (@lax_coslice_category_over _ _ _ a _) : category_scope. Notation "x // F" := (lax_coslice_category x F) (only printing) : category_scope. Notation "F // x" := (lax_slice_category x F) (only printing) : category_scope. Notation "S // T" := (lax_comma_category S T) (only printing) : category_scope. (** Set the notation for parsing; typeclasses will automatically decide which of the arguments are functors and which are objects, i.e., functors from the terminal category. *) Notation "S // T" := (get_LCC S T) : category_scope. Notation "'CAT' \\ a" := (@oplax_slice_category_over _ _ _ a _) : category_scope. Notation "a \\ 'CAT'" := (@oplax_coslice_category_over _ _ _ a _) : category_scope. Notation "x \\ F" := (oplax_coslice_category x F) (only printing) : category_scope. Notation "F \\ x" := (oplax_slice_category x F) (only printing) : category_scope. Notation "S \\ T" := (oplax_comma_category S T) (only printing) : category_scope. (** Set the notation for parsing; typeclasses will automatically decide which of the arguments are functors and which are objects, i.e., functors from the terminal category. *) Notation "S \\ T" := (get_OLCC S T) : category_scope. End LaxCommaCoreNotations. Coq-HoTT-9.0/theories/Categories/LaxComma/CoreLaws.v000066400000000000000000000473231474641544500222650ustar00rootroot00000000000000Require Import Functor.Core NaturalTransformation.Core. Require Import Category.Strict. Require Import Functor.Composition.Core. Require Import NaturalTransformation.Paths NaturalTransformation.Composition.Core. Require Import Category.Morphisms FunctorCategory.Core. Require Import Pseudofunctor.Core Pseudofunctor.RewriteLaws. Require Import NaturalTransformation.Composition.Laws. Require Import FunctorCategory.Morphisms. Require LaxComma.CoreParts. Require Import HoTT.Tactics. Import Functor.Identity.FunctorIdentityNotations. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. (** Quoting David Spivak: David: ok so an object of [FC ⇓ D] is a pair [(X, G)], where [X] is a finite category (or a small category or whatever you wanted) and [G : X --> D] is a functor. a morphism in [FC ⇓ D] is a ``natural transformation diagram'' (as opposed to a commutative diagram, in which the natural transformation would be ``identity'') so a map in [FC ⇓ D] from [(X, G)] to [(X', G')] is a pair [(F, α)] where [F : X --> X'] is a functor and [α : G --> G' ∘ F] is a natural transformation and the punchline is that there is a functor [colim : FC ⇓ D --> D] David: consider for yourself the case where [F : X --> X'] is identity ([X = X']) and (separately) the case where [α : G --> G ∘ F] is identity. the point is, you've already done the work to get this colim functor. because every map in [FC ⇓ D] can be written as a composition of two maps, one where the [F]-part is identity and one where the [α]-part is identity. and you've worked both of those cases out already. *) Module Import LaxCommaCategory. Include LaxComma.CoreParts.LaxCommaCategoryParts. Section lax_comma_category_parts. Context `{Funext}. Variables A B : PreCategory. Variable S : Pseudofunctor A. Variable T : Pseudofunctor B. Context `{forall a b, IsHSet (Functor (S a) (T b))}. Local Notation object := (@object _ A B S T). Local Notation morphism := (@morphism _ A B S T). Local Notation compose := (@compose _ A B S T). Local Notation identity := (@identity _ A B S T). Local Ltac t_do_work := repeat match goal with | _ => reflexivity | [ |- context[components_of ?T^-1 ?x] ] => progress change (T^-1 x) with ((T x)^-1) | [ |- context[?F _1 ?m^-1] ] => progress change (F _1 m^-1) with ((F _1 m)^-1) | _ => progress repeat iso_collapse_inverse_right' end. Local Ltac t_start := simpl in *; repeat match goal with | [ H : ?x = _ |- _ ] => rewrite H; clear H; try clear x end; path_natural_transformation; simpl in *; rewrite !Category.Core.left_identity, !Category.Core.right_identity; rewrite !composition_of. Local Ltac t := t_start; rewrite <- !Category.Core.associativity; (** A reflective simplifier would be really useful here... *) repeat match goal with | _ => progress t_do_work | [ |- context[components_of ?T ?x] ] => simpl rewrite <- !(commutes_pT_F T) | [ |- context[components_of ?T ?x] ] => simpl rewrite <- !(commutes T) | _ => iso_move_inverse end. (** Ugh. The following code constructs the type of the helper lemma: << Lemma associativity x1 x2 x3 x4 (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4) : compose (compose m3 m2) m1 = compose m3 (compose m2 m1). Proof. refine (@path_morphism' _ _ (compose (compose m3 m2) m1) (compose m3 (compose m2 m1)) (Category.Core.associativity _ _ _ _ _ _ _ _) (Category.Core.associativity _ _ _ _ _ _ _ _) _). simpl in *. repeat match goal with | [ |- context[@morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ (Category.Morphisms.idtoiso ?C0 (ap (p_morphism_of ?F (s:=_) (d:=_)) (Category.Core.associativity ?C ?x1 ?x2 ?x3 ?x4 ?m1 ?m2 ?m3))))] ] => generalize (@p_composition_of_coherent_inverse_for_rewrite _ C F x1 x2 x3 x4 m1 m2 m3); generalize (Category.Morphisms.idtoiso C0 (ap (p_morphism_of F (s:=_) (d:=_)) (Category.Core.associativity C x1 x2 x3 x4 m1 m2 m3))) | [ |- context[Category.Morphisms.idtoiso ?C0 (ap (p_morphism_of ?F (s:=_) (d:=_)) (Category.Core.associativity ?C ?x1 ?x2 ?x3 ?x4 ?m1 ?m2 ?m3))] ] => generalize (@p_composition_of_coherent_for_rewrite _ C F x1 x2 x3 x4 m1 m2 m3); generalize (Category.Morphisms.idtoiso C0 (ap (p_morphism_of F (s:=_) (d:=_)) (Category.Core.associativity C x1 x2 x3 x4 m1 m2 m3))) end. simpl. destruct_head morphism. destruct_head object. simpl in *. repeat match goal with | [ |- context[p_composition_of ?F ?x ?y ?z ?m1 ?m2] ] => generalize dependent (p_composition_of F x y z m1 m2) | [ |- context[p_identity_of ?F ?x] ] => generalize dependent (p_identity_of F x) | [ |- context[p_morphism_of ?F ?x] ] => generalize dependent (p_morphism_of F x) | [ |- context[p_object_of ?F ?x] ] => generalize dependent (p_object_of F x) end. simpl. clear. repeat (let H := fresh "x" in intro H). repeat match goal with H : _ |- _ => revert H end. intro. >> *) Lemma associativity_helper {x x0 : PreCategory} {x1 : Functor x0 x} {x2 x3 : PreCategory} {x4 : Functor x3 x2} {x5 x6 : PreCategory} {x7 : Functor x6 x5} {x8 x9 : PreCategory} {x10 : Functor x9 x8} {x11 : Functor x9 x6} {x12 : Functor x9 x3} {x13 : Functor x0 x6} {x14 : Functor x9 x6} {x15 : Functor x8 x5} {x16 : Functor x x5} {x17 : Functor x9 x0} {x18 : Functor x8 x} {x19 : NaturalTransformation (x18 o x10) (x1 o x17)} {x20 : Functor x0 x3} {x21 : Functor x x2} {x22 : NaturalTransformation (x21 o x1) (x4 o x20)} {x23 : Functor x8 x2} {x24 : Functor x3 x6} {x25 : Functor x2 x5} {x26 : NaturalTransformation (x25 o x4) (x7 o x24)} {x27 : Functor x8 x5} {x28 : @Isomorphic (_ -> _) x27 (x25 o x23)%functor} {x29 : @Isomorphic (_ -> _) x23 (x21 o x18)%functor} {x30 : @Isomorphic (_ -> _) x16 (x25 o x21)%functor} {x31 : @Isomorphic (_ -> _) x15 (x16 o x18)%functor} {x32 : @Isomorphic (_ -> _) x14 (x13 o x17)%functor} {x33 : @Isomorphic (_ -> _) x13 (x24 o x20)%functor} {x34 : @Isomorphic (_ -> _) x12 (x20 o x17)%functor} {x35 : @Isomorphic (_ -> _) x11 (x24 o x12)%functor} {x36 : @Isomorphic (_ -> _) x14 x11} (x37 : (x36 : Category.Core.morphism _ _ _) = (x35 ^-1 o (x24 oL x34 ^-1 o (associator_1 x24 x20 x17 o ((x33 : Category.Core.morphism _ _ _) oR x17 o (x32 : Category.Core.morphism _ _ _)))))%natural_transformation) {x38 : @Isomorphic (_ -> _) x15 x27} (x39 : x38 ^-1 = (x31 ^-1 o (x30 ^-1 oR x18) o inverse (associator_1 x25 x21 x18) o (x25 oL (x29 : Category.Core.morphism _ _ _)) o (x28 : Category.Core.morphism _ _ _))%natural_transformation) : (x7 oL (x36 : Category.Core.morphism _ _ _) o (x7 oL x32 ^-1 o associator_1 x7 x13 x17 o (x7 oL x33 ^-1 o associator_1 x7 x24 x20 o (x26 oR x20) o associator_2 x25 x4 x20 o (x25 oL x22) o associator_1 x25 x21 x1 o ((x30 : Category.Core.morphism _ _ _) oR x1) oR x17) o associator_2 x16 x1 x17 o (x16 oL x19) o associator_1 x16 x18 x10 o ((x31 : Category.Core.morphism _ _ _) oR x10)) o (x38 ^-1 oR x10))%natural_transformation = (x7 oL x35 ^-1 o associator_1 x7 x24 x12 o (x26 oR x12) o associator_2 x25 x4 x12 o (x25 oL (x4 oL x34 ^-1 o associator_1 x4 x20 x17 o (x22 oR x17) o associator_2 x21 x1 x17 o (x21 oL x19) o associator_1 x21 x18 x10 o ((x29 : Category.Core.morphism _ _ _) oR x10))) o associator_1 x25 x23 x10 o ((x28 : Category.Core.morphism _ _ _) oR x10))%natural_transformation. Proof. t. (* 18.647s *) Qed. Lemma associativity x1 x2 x3 x4 (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4) : compose (compose m3 m2) m1 = compose m3 (compose m2 m1). Proof. refine (@path_morphism' _ A B S T _ _ (compose (compose m3 m2) m1) (compose m3 (compose m2 m1)) (Category.Core.associativity _ _ _ _ _ _ _ _) (Category.Core.associativity _ _ _ _ _ _ _ _) _). simpl. apply associativity_helper. - exact (p_composition_of_coherent_for_rewrite _ _ _ _ _ _ _ _). - exact (p_composition_of_coherent_inverse_for_rewrite _ _ _ _ _ _ _ _). Defined. (** Ugh. To construct the type of this lemma, the code is: << Lemma left_identity (s d : object) (m : morphism s d) : compose (identity _) m = m. Proof. refine (@path_morphism' _ _ (compose (identity _) m) m (Category.Core.left_identity _ _ _ _) (Category.Core.left_identity _ _ _ _) _). simpl in *. repeat match goal with | [ |- context[@morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ (Category.Morphisms.idtoiso ?C0 (ap (p_morphism_of ?F (s:=_) (d:=_)) (Category.Core.left_identity ?C ?x ?y ?f))))] ] => generalize (@p_left_identity_of_coherent_inverse_for_rewrite _ C F x y f); generalize (Category.Morphisms.idtoiso C0 (ap (p_morphism_of F (s:=_) (d:=_)) (Category.Core.left_identity C x y f))) | [ |- context[Category.Morphisms.idtoiso ?C0 (ap (p_morphism_of ?F (s:=_) (d:=_)) (Category.Core.left_identity ?C ?x ?y ?f))] ] => generalize (@p_left_identity_of_coherent_for_rewrite _ C F x y f); generalize (Category.Morphisms.idtoiso C0 (ap (p_morphism_of F (s:=_) (d:=_)) (Category.Core.left_identity C x y f))) end. simpl. destruct_head morphism. destruct_head object. simpl in *. repeat match goal with | [ |- context[p_composition_of ?F ?x ?y ?z ?m1 ?m2] ] => generalize dependent (p_composition_of F x y z m1 m2) | [ |- context[p_identity_of ?F ?x] ] => generalize dependent (p_identity_of F x) | [ |- context[p_morphism_of ?F ?x] ] => generalize dependent (p_morphism_of F x) | [ |- context[p_object_of ?F ?x] ] => generalize dependent (p_object_of F x) end. simpl. clear. repeat (let H := fresh "x" in intro H). repeat match goal with H : _ |- _ => revert H end. intro. >> *) Lemma left_identity_helper {x x0 : PreCategory} {x1 : Functor x0 x} {x2 x3 : PreCategory} {x4 : Functor x3 x2} {x5 x6 : Functor x3 x0} {x7 : Functor x2 x} {x8 : NaturalTransformation (x7 o x4) (x1 o x6)} {x9 : Functor x2 x} {x10 : Functor x0 x0} {x11 : Functor x x} {x12 : @Isomorphic (_ -> _) x11 1%functor} {x13 : @Isomorphic (_ -> _) x10 1%functor} {x14 : @Isomorphic (_ -> _) x9 (x11 o x7)%functor} {x15 : @Isomorphic (_ -> _) x5 (x10 o x6)%functor} {x16 : @Isomorphic (_ -> _) x5 x6} {x17 : (x16 : Category.Core.morphism _ _ _) = (left_identity_natural_transformation_1 x6 o ((x13 : Category.Core.morphism _ _ _) oR x6 o (x15 : Category.Core.morphism _ _ _)))%natural_transformation} {x18 : @Isomorphic (_ -> _) x9 x7} {x19 : x18 ^-1 = (x14 ^-1 o (x12 ^-1 oR x7) o inverse (left_identity_natural_transformation_1 x7))%natural_transformation} : (x1 oL (x16 : Category.Core.morphism _ _ _) o (x1 oL x15 ^-1 o associator_1 x1 x10 x6 o (x1 oL x13 ^-1 o right_identity_natural_transformation_2 x1 o left_identity_natural_transformation_1 x1 o ((x12 : Category.Core.morphism _ _ _) oR x1) oR x6) o associator_2 x11 x1 x6 o (x11 oL x8) o associator_1 x11 x7 x4 o ((x14 : Category.Core.morphism _ _ _) oR x4)) o (x18 ^-1 oR x4))%natural_transformation = x8. Proof. t. (* 3.959 s *) Qed. Lemma left_identity (s d : object) (m : morphism s d) : compose (identity _) m = m. Proof. refine (@path_morphism' _ A B S T _ _ (compose (identity _) m) m (Category.Core.left_identity _ _ _ _) (Category.Core.left_identity _ _ _ _) _). simpl. refine left_identity_helper. - exact (p_left_identity_of_coherent_for_rewrite _ _ _ _). - exact (p_left_identity_of_coherent_inverse_for_rewrite _ _ _ _). Defined. (** To generate the type of this helper lemma, we used: << Lemma right_identity (s d : object) (m : morphism s d) : compose m (identity _) = m. Proof. refine (@path_morphism' _ _ (compose m (identity _)) m (Category.Core.right_identity _ _ _ _) (Category.Core.right_identity _ _ _ _) _). simpl in *. repeat match goal with | [ |- context[@morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ (Category.Morphisms.idtoiso ?C0 (ap (p_morphism_of ?F (s:=_) (d:=_)) (Category.Core.right_identity ?C ?x ?y ?f))))] ] => generalize (@p_right_identity_of_coherent_inverse_for_rewrite _ C F x y f); generalize (Category.Morphisms.idtoiso C0 (ap (p_morphism_of F (s:=_) (d:=_)) (Category.Core.right_identity C x y f))) | [ |- context[Category.Morphisms.idtoiso ?C0 (ap (p_morphism_of ?F (s:=_) (d:=_)) (Category.Core.right_identity ?C ?x ?y ?f))] ] => generalize (@p_right_identity_of_coherent_for_rewrite _ C F x y f); generalize (Category.Morphisms.idtoiso C0 (ap (p_morphism_of F (s:=_) (d:=_)) (Category.Core.right_identity C x y f))) end. simpl. destruct_head morphism. destruct_head object. simpl in *. repeat match goal with | [ |- context[p_composition_of ?F ?x ?y ?z ?m1 ?m2] ] => generalize dependent (p_composition_of F x y z m1 m2) | [ |- context[p_identity_of ?F ?x] ] => generalize dependent (p_identity_of F x) | [ |- context[p_morphism_of ?F ?x] ] => generalize dependent (p_morphism_of F x) | [ |- context[p_object_of ?F ?x] ] => generalize dependent (p_object_of F x) end. simpl. clear. repeat (let H := fresh "x" in intro H). repeat match goal with H : _ |- _ => revert H end. intro. >> *) Lemma right_identity_helper {x x0 : PreCategory} {x1 : Functor x0 x} {x2 x3 : PreCategory} {x4 : Functor x3 x2} {x5 x6 : Functor x3 x0} {x7 : Functor x2 x} {x8 : NaturalTransformation (x7 o x4) (x1 o x6)} {x9 : Functor x2 x} {x10 : Functor x3 x3} {x11 : Functor x2 x2} {x12 : @Isomorphic (_ -> _) x11 1%functor} {x13 : @Isomorphic (_ -> _) x10 1%functor} {x14 : @Isomorphic (_ -> _) x9 (x7 o x11)%functor} {x15 : @Isomorphic (_ -> _) x5 (x6 o x10)%functor} {x16 : @Isomorphic (_ -> _) x5 x6} {x17 : (x16 : Category.Core.morphism _ _ _) = (right_identity_natural_transformation_1 x6 o (x6 oL (x13 : Category.Core.morphism _ _ _) o (x15 : Category.Core.morphism _ _ _)))%natural_transformation} {x18 : @Isomorphic (_ -> _) x9 x7} {x19 : x18 ^-1 = (x14 ^-1 o (x7 oL x12 ^-1) o inverse (right_identity_natural_transformation_1 x7))%natural_transformation} : (x1 oL (x16 : Category.Core.morphism _ _ _) o (x1 oL x15 ^-1 o associator_1 x1 x6 x10 o (x8 oR x10) o associator_2 x7 x4 x10 o (x7 oL (x4 oL x13 ^-1 o right_identity_natural_transformation_2 x4 o left_identity_natural_transformation_1 x4 o ((x12 : Category.Core.morphism _ _ _) oR x4))) o associator_1 x7 x11 x4 o ((x14 : Category.Core.morphism _ _ _) oR x4)) o (x18 ^-1 oR x4))%natural_transformation = x8. Proof. t. (* 3.26 s *) Qed. Lemma right_identity (s d : object) (m : morphism s d) : compose m (identity _) = m. Proof. refine (@path_morphism' _ A B S T _ _ (compose m (identity _)) m (Category.Core.right_identity _ _ _ _) (Category.Core.right_identity _ _ _ _) _). simpl. refine right_identity_helper. - exact (p_right_identity_of_coherent_for_rewrite _ _ _ _). - exact (p_right_identity_of_coherent_inverse_for_rewrite _ _ _ _). Defined. End lax_comma_category_parts. End LaxCommaCategory. Coq-HoTT-9.0/theories/Categories/LaxComma/CoreParts.v000066400000000000000000000226341474641544500224460ustar00rootroot00000000000000Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Core. Require Import NaturalTransformation.Paths NaturalTransformation.Composition.Core. Require Import Category.Morphisms FunctorCategory.Core. Require Import Pseudofunctor.Core. Require Import NaturalTransformation.Composition.Laws. Require Import Trunc Types.Sigma. Require Import Basics.Tactics. Import Functor.Identity.FunctorIdentityNotations. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. Local Open Scope type_scope. (** Quoting David Spivak: David: ok so an object of [FC ⇓ D] is a pair [(X, G)], where [X] is a finite category (or a small category or whatever you wanted) and [G : X --> D] is a functor. a morphism in [FC ⇓ D] is a ``natural transformation diagram'' (as opposed to a commutative diagram, in which the natural transformation would be ``identity'') so a map in [FC ⇓ D] from [(X, G)] to [(X', G')] is a pair [(F, α)] where [F : X --> X'] is a functor and [α : G --> G' ∘ F] is a natural transformation and the punchline is that there is a functor [colim : FC ⇓ D --> D] David: consider for yourself the case where [F : X --> X'] is identity ([X = X']) and (separately) the case where [α : G --> G ∘ F] is identity. the point is, you've already done the work to get this colim functor. because every map in [FC ⇓ D] can be written as a composition of two maps, one where the [F]-part is identity and one where the [α]-part is identity. and you've worked both of those cases out already. *) Module Import LaxCommaCategoryParts. Section lax_comma_category_parts. Context `{Funext}. Variables A B : PreCategory. Variable S : Pseudofunctor A. Variable T : Pseudofunctor B. Context `{forall a b, IsHSet (Functor (S a) (T b))}. Record object := { a : A; b : B; f : Functor (S a) (T b) }. Local Notation object_sig_T := ({ a : A | { b : B | Functor (S a) (T b) }}). Lemma issig_object : object_sig_T <~> object. Proof. issig. Defined. Global Instance trunc_object `{IsTrunc n A, IsTrunc n B} `{forall s d, IsTrunc n (Functor (S s) (T d))} : IsTrunc n object. Proof. eapply istrunc_equiv_istrunc; [ exact issig_object | ]. typeclasses eauto. Qed. Lemma path_object (x y : object) : forall (Ha : x.(a) = y.(a)) (Hb : x.(b) = y.(b)), match Ha in _ = X, Hb in _ = Y return Functor (S X) (T Y) with | idpath, idpath => x.(f) end = y.(f) -> x = y. Proof. destruct x, y; simpl. intros; path_induction; reflexivity. Defined. Definition path_object_uncurried x y (H : { HaHb : (x.(a) = y.(a)) * (x.(b) = y.(b)) | match fst HaHb in _ = X, snd HaHb in _ = Y return Functor (S X) (T Y) with | idpath, idpath => x.(f) end = y.(f) }) : x = y := @path_object x y (fst H.1) (snd H.1) H.2. Lemma ap_a_path_object x y Ha Hb Hf : ap (@a) (@path_object x y Ha Hb Hf) = Ha. Proof. destruct x, y; simpl in *. destruct Ha, Hb, Hf; simpl in *. reflexivity. Qed. Lemma ap_b_path_object x y Ha Hb Hf : ap (@b) (@path_object x y Ha Hb Hf) = Hb. Proof. destruct x, y; simpl in *. destruct Ha, Hb, Hf; simpl in *. reflexivity. Qed. Global Opaque path_object. Record morphism (abf a'b'f' : object) := { g : Category.Core.morphism A (abf.(a)) (a'b'f'.(a)); h : Category.Core.morphism B (abf.(b)) (a'b'f'.(b)); p : NaturalTransformation (p_morphism_of T h o abf.(f)) (a'b'f'.(f) o p_morphism_of S g) }. Local Notation morphism_sig_T abf a'b'f' := ({ g : Category.Core.morphism A (abf.(a)) (a'b'f'.(a)) | { h : Category.Core.morphism B (abf.(b)) (a'b'f'.(b)) | NaturalTransformation (p_morphism_of T h o abf.(f)) (a'b'f'.(f) o p_morphism_of S g) }}). Lemma issig_morphism abf a'b'f' : (morphism_sig_T abf a'b'f') <~> morphism abf a'b'f'. Proof. issig. Defined. Global Instance trunc_morphism abf a'b'f' `{IsTrunc n (Category.Core.morphism A (abf.(a)) (a'b'f'.(a)))} `{IsTrunc n (Category.Core.morphism B (abf.(b)) (a'b'f'.(b)))} `{forall m1 m2, IsTrunc n (NaturalTransformation (p_morphism_of T m2 o abf.(f)) (a'b'f'.(f) o p_morphism_of S m1))} : IsTrunc n (morphism abf a'b'f'). Proof. eapply istrunc_equiv_istrunc; [ exact (issig_morphism _ _) | ]. typeclasses eauto. Qed. Lemma path_morphism abf a'b'f' (gh g'h' : morphism abf a'b'f') : forall (Hg : gh.(g) = g'h'.(g)) (Hh : gh.(h) = g'h'.(h)), match Hg in _ = g, Hh in _ = h return NaturalTransformation (p_morphism_of T h o abf.(f)) (a'b'f'.(f) o p_morphism_of S g) with | idpath, idpath => gh.(p) end = g'h'.(p) -> gh = g'h'. Proof. intros Hg Hh Hp. destruct gh, g'h'; simpl in *. destruct Hg, Hh, Hp. reflexivity. Qed. Definition path_morphism_uncurried abf a'b'f' gh g'h' (H : { HgHh : (gh.(g) = g'h'.(g)) * (gh.(h) = g'h'.(h)) | match fst HgHh in _ = g, snd HgHh in _ = h return NaturalTransformation (p_morphism_of T h o abf.(f)) (a'b'f'.(f) o p_morphism_of S g) with | idpath, idpath => gh.(p) end = g'h'.(p) }) : gh = g'h' := @path_morphism abf a'b'f' gh g'h' (fst H.1) (snd H.1) H.2. Lemma path_morphism'_helper abf a'b'f' (gh g'h' : morphism abf a'b'f') : forall (Hg : gh.(g) = g'h'.(g)) (Hh : gh.(h) = g'h'.(h)), ((_ oL (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ S _ _) Hg) : Category.Core.morphism _ _ _)) o (gh.(p)) o ((Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ T _ _) Hh) : Category.Core.morphism _ _ _)^-1 oR _) = g'h'.(p))%natural_transformation -> match Hg in _ = g, Hh in _ = h return NaturalTransformation (p_morphism_of T h o abf.(f)) (a'b'f'.(f) o p_morphism_of S g) with | idpath, idpath => gh.(p) end = g'h'.(p). Proof. simpl; intros Hg Hh Hp. destruct g'h'; simpl in *. destruct Hg, Hh, Hp; simpl in *. path_natural_transformation. autorewrite with functor morphism. reflexivity. Qed. Definition path_morphism' abf a'b'f' (gh g'h' : morphism abf a'b'f') (Hg : gh.(g) = g'h'.(g)) (Hh : gh.(h) = g'h'.(h)) (Hp : ((_ oL (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ S _ _) Hg) : Category.Core.morphism _ _ _)) o (gh.(p)) o ((Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ T _ _) Hh) : Category.Core.morphism _ _ _)^-1 oR _) = g'h'.(p))%natural_transformation) : gh = g'h' := @path_morphism abf a'b'f' gh g'h' Hg Hh (@path_morphism'_helper abf a'b'f' gh g'h' Hg Hh Hp). Definition path_morphism'_uncurried abf a'b'f' gh g'h' (H : { HgHh : (gh.(g) = g'h'.(g)) * (gh.(h) = g'h'.(h)) | ((_ oL (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ S _ _) (fst HgHh)) : Category.Core.morphism _ _ _)) o (gh.(p)) o ((Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ T _ _) (snd HgHh)) : Category.Core.morphism _ _ _)^-1 oR _) = g'h'.(p))%natural_transformation }) : gh = g'h' := @path_morphism' abf a'b'f' gh g'h' (fst H.1) (snd H.1) H.2. Definition compose s d d' (gh : morphism d d') (g'h' : morphism s d) : morphism s d'. Proof. exists (gh.(g) o g'h'.(g)) (gh.(h) o g'h'.(h)). exact ((_ oL (p_composition_of S _ _ _ _ _)^-1) o (associator_1 _ _ _) o (gh.(p) oR _) o (associator_2 _ _ _) o (_ oL g'h'.(p)) o (associator_1 _ _ _) o ((p_composition_of T _ _ _ _ _ : Category.Core.morphism _ _ _) oR _))%natural_transformation. Defined. Global Arguments compose _ _ _ _ _ / . Definition identity x : morphism x x. Proof. exists (identity (x.(a))) (identity (x.(b))). exact ((_ oL (p_identity_of S _ : Category.Core.morphism _ _ _)^-1) o (right_identity_natural_transformation_2 _) o (left_identity_natural_transformation_1 _) o ((p_identity_of T _ : Category.Core.morphism _ _ _) oR _))%natural_transformation. Defined. Global Arguments identity _ / . End lax_comma_category_parts. End LaxCommaCategoryParts. Coq-HoTT-9.0/theories/Categories/LaxComma/Notations.v000066400000000000000000000004731474641544500225170ustar00rootroot00000000000000(** * Notations for lax comma categories *) Require LaxComma.Core. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Include LaxComma.Core.LaxCommaCoreNotations. Coq-HoTT-9.0/theories/Categories/LaxComma/Utf8.v000066400000000000000000000027631474641544500213730ustar00rootroot00000000000000(** * Unicode notations for comma categories *) Local Set Warnings Append "-notation-overridden". Require Import LaxComma.Core. Require Export LaxComma.Notations. Require Import Basics.Utf8. (** Set some notations for printing *) Notation "'CAT' ⇓ a" := (@lax_slice_category_over _ _ _ a _) : category_scope. Notation "a ⇓ 'CAT'" := (@lax_coslice_category_over _ _ _ a _) : category_scope. Notation "x ⇓ F" := (lax_coslice_category x F) (only printing) : category_scope. Notation "F ⇓ x" := (lax_slice_category x F) (only printing) : category_scope. Notation "S ⇓ T" := (lax_comma_category S T) (only printing) : category_scope. (** Set the notation for parsing; typeclasses will automatically decide which of the arguments are functors and which are objects, i.e., functors from the terminal category. *) Notation "S ⇓ T" := (get_LCC S T) : category_scope. Notation "'CAT' ⇑ a" := (@oplax_slice_category_over _ _ _ a _) : category_scope. Notation "a ⇑ 'CAT'" := (@oplax_coslice_category_over _ _ _ a _) : category_scope. Notation "x ⇑ F" := (oplax_coslice_category x F) (only printing) : category_scope. Notation "F ⇑ x" := (oplax_slice_category x F) (only printing) : category_scope. Notation "S ⇑ T" := (oplax_comma_category S T) (only printing) : category_scope. (** Set the notation for parsing; typeclasses will automatically decide which of the arguments are functors and which are objects, i.e., functors from the terminal category. *) Notation "S ⇑ T" := (get_OLCC S T) : category_scope. Coq-HoTT-9.0/theories/Categories/Limits.v000066400000000000000000000003401474641544500202720ustar00rootroot00000000000000(** * Limits and Colimits *) (** ** Definitions *) Require Limits.Core. (** ** (co)limits assemble into functors *) (** *** which are adjoints to Δ *) Require Limits.Functors. Include Limits.Core. Include Limits.Functors. Coq-HoTT-9.0/theories/Categories/Limits/000077500000000000000000000000001474641544500201065ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Limits/Core.v000066400000000000000000000143661474641544500211770ustar00rootroot00000000000000(** * Limits and Colimits *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Core. Require Import ExponentialLaws.Law1.Functors FunctorCategory.Core. Require Import KanExtensions.Core InitialTerminalCategory.Core NatCategory. Require Import Functor.Paths. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Import Comma.Core. Local Set Warnings Append "notation-overridden". Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Local Open Scope category_scope. (** ** The diagonal or "constant diagram" functor Δ *) Section diagonal_functor. Context `{Funext}. Variables C D : PreCategory. (** Quoting Dwyer and Spalinski: There is a diagonal or ``constant diagram'' functor << Δ : C → Cᴰ, >> which carries an object [X : C] to the constant functor [Δ X : D -> C] (by definition, this ``constant functor'' sends each object of [D] to [X] and each morphism of [D] to [Identity X]). The functor Δ assigns to each morphism [f : X -> X'] of [C] the constant natural transformation [t(f) : Δ X -> Δ X'] determined by the formula [t(f) d = f] for each object [d] of [D]. **) (** We use [C¹] rather than [C] for judgemental compatibility with Kan extensions. *) Definition diagonal_functor : Functor (1 -> C) (D -> C) := @pullback_along _ D 1 C (Functors.to_terminal _). Definition diagonal_functor' : Functor C (D -> C) := diagonal_functor o ExponentialLaws.Law1.Functors.inverse _. Section convert. Lemma diagonal_functor_diagonal_functor' X : diagonal_functor X = diagonal_functor' (X (center _)). Proof. path_functor. simpl. repeat (apply path_forall || intro). apply identity_of. Qed. End convert. End diagonal_functor. Arguments diagonal_functor : simpl never. Section diagonal_functor_lemmas. Context `{Funext}. Variables C D D' : PreCategory. Lemma compose_diagonal_functor x (F : Functor D' D) : diagonal_functor C D x o F = diagonal_functor _ _ x. Proof. path_functor. Qed. Definition compose_diagonal_functor_natural_transformation x (F : Functor D' D) : NaturalTransformation (diagonal_functor C D x o F) (diagonal_functor _ _ x) := Build_NaturalTransformation (diagonal_functor C D x o F) (diagonal_functor _ _ x) (fun z => identity _) (fun _ _ _ => transitivity (left_identity _ _ _ _) (symmetry _ _ (right_identity _ _ _ _))). End diagonal_functor_lemmas. #[export] Hint Rewrite @compose_diagonal_functor : category. Section Limit. Context `{Funext}. Variables C D : PreCategory. Variable F : Functor D C. (** ** Definition of Limit *) (** Quoting Dwyer and Spalinski: Let [D] be a small category and [F : D -> C] a functor. A limit for [F] is an object [L] of [C] together with a natural transformation [t : Δ L -> F] such that for every object [X] of [C] and every natural transformation [s : Δ X -> F], there exists a unique map [s' : X -> L] in [C] such that [t (Δ s') = s]. **) Definition IsLimit := @IsRightKanExtensionAlong _ D 1 C (Functors.to_terminal _) F. (*Definition IsLimit' := @IsTerminalMorphism (_ -> _) (_ -> _) (diagonal_functor C D) F.*) (* Definition Limit (L : C) := { t : SmallNaturalTransformation ((diagonal_functor C D) L) F & forall X : C, forall s : SmallNaturalTransformation ((diagonal_functor C D) X) F, { s' : C.(Morphism) X L | unique (fun s' => SNTComposeT t ((diagonal_functor C D).(MorphismOf) s') = s) s' } }.*) (** Quoting Dwyer and Spalinski: Let [D] be a small category and [F : D -> C] a functor. A colimit for [F] is an object [c] of [C] together with a natural transformation [t : F -> Δ c] such that for every object [X] of [C] and every natural transformation [s : F -> Δ X], there exists a unique map [s' : c -> X] in [C] such that [(Δ s') t = s]. **) (** ** Definition of Colimit *) Definition IsColimit := @IsLeftKanExtensionAlong _ D 1 C (Functors.to_terminal _) F. (*Definition IsColimit' := @IsInitialMorphism (_ -> _) (_ -> _) F (diagonal_functor C D).*) (* Definition Colimit (c : C) := { t : SmallNaturalTransformation F ((diagonal_functor C D) c) & forall X : C, forall s : SmallNaturalTransformation F ((diagonal_functor C D) X), { s' : C.(Morphism) c X | is_unique s' /\ SNTComposeT ((diagonal_functor C D).(MorphismOf) s') t = s } }.*) (** TODO(JasonGross): Figure out how to get good introduction and elimination rules working, which don't mention spurious identities. *) (*Section AbstractionBarrier. Section Limit. Set Printing Implicit. Section IntroductionAbstractionBarrier. Local Open Scope morphism_scope. Definition Build_IsLimit (lim_obj : C) (lim_mor : morphism (D -> C) (diagonal_functor' C D lim_obj) F) (lim := CommaCategory.Build_object (diagonal_functor C D) !(F : object (_ -> _)) !lim_obj (center _) lim_mor) (UniversalProperty : forall (lim_obj' : C) (lim_mor' : morphism (D -> C) (diagonal_functor' C D lim_obj') F), Contr { m : morphism C lim_obj' lim_obj | lim_mor o morphism_of (diagonal_functor' C D) m = lim_mor' }) : IsTerminalMorphism lim. Proof. apply Build_IsTerminalMorphism. intros A' p'. specialize (UniversalProperty (A' (center _))).*) End Limit. (** TODO(JasonGross): Port MorphismsBetweenLimits from catdb *) Coq-HoTT-9.0/theories/Categories/Limits/Functors.v000066400000000000000000000036721474641544500221100ustar00rootroot00000000000000(** * (co)limits assemble into functors *) Require Import Category.Core Functor.Core. Require Import KanExtensions.Functors. Require Import Limits.Core. Require Import FunctorCategory.Core. Require Import Adjoint.Core. Require Import NatCategory. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** (co)limits assemble into functors *) Local Open Scope category_scope. Section functors. Context `{Funext}. Variables C D : PreCategory. (** ** Colimit functor, which is left adjoint to Δ *) Section colimit. Context `(has_colimits : forall F : Functor D C, @IsColimit _ C D F (colimits F)). (** TODO(jgross): We'll probably want to compose this with the functor from [1 → C] to [C], and then compose the adjunctions similarly. This will require turning the equality in the exponential laws into an adjunction. Probably not very hard. *) Definition colimit_functor : Functor (D -> C) (1 -> C) := left_kan_extension_functor has_colimits. Definition colimit_adjunction : colimit_functor -| diagonal_functor _ _ := left_kan_extension_adjunction has_colimits. End colimit. Section limit. Context `(has_limits : forall F : Functor D C, @IsLimit _ C D F (limits F)). (** TODO(jgross): We'll probably want to compose this with the functor from [1 -> C] to [C], and then compose the adjunctions similarly. This will require turning the equality in the exponential laws into an adjunction. Probably not very hard. *) (** ** Limit functor, which is right adjoint to Δ *) Definition limit_functor : Functor (D -> C) (1 -> C) := right_kan_extension_functor has_limits. Definition limit_adjunction : diagonal_functor _ _ -| limit_functor := right_kan_extension_adjunction has_limits. End limit. End functors. Coq-HoTT-9.0/theories/Categories/Monoidal/000077500000000000000000000000001474641544500204075ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Monoidal/MonoidalCategory.v000066400000000000000000000072371474641544500240470ustar00rootroot00000000000000Require Import Basics.Utf8. Require Import Category.Core Category.Morphisms. Require Import Functor.Core Functor.Utf8. Require Import NaturalTransformation.Core. Require Import FunctorCategory.Core FunctorCategory.Morphisms. Require Import ProductLaws. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section MonoidalStructure. Context `{Funext}. Local Notation "x --> y" := (morphism _ x y). Section MonoidalCategoryConcepts. Variable C : PreCategory. Variable tensor : ((C * C) -> C)%category. Variable I : C. Local Notation "A ⊗ B" := (tensor (Basics.Overture.pair A B)). Local Open Scope functor_scope. Definition right_assoc := (tensor ∘ (Functor.Prod.pair 1 tensor) )%functor. Definition left_assoc := tensor ∘ (Functor.Prod.pair tensor 1) ∘ (Associativity.functor _ _ _). Definition associator := NaturalIsomorphism right_assoc left_assoc. (* Orientation (A ⊗ B) ⊗ C -> A ⊗ (B ⊗ C) *) Definition pretensor (A : C) := Core.induced_snd tensor A. Definition I_pretensor := pretensor I. Definition posttensor (A : C) := Core.induced_fst tensor A. Definition I_posttensor := posttensor I. Definition left_unitor := NaturalIsomorphism I_pretensor 1. Definition right_unitor := NaturalIsomorphism I_posttensor 1. Close Scope functor_scope. Variable alpha : associator. Variable lambda : left_unitor. Variable rho : right_unitor. Notation alpha_nat_trans := ((@morphism_isomorphic (C * (C * C) -> C)%category right_assoc left_assoc) alpha). Notation lambda_nat_trans := ((@morphism_isomorphic _ _ _) lambda). Notation rho_nat_trans := ((@morphism_isomorphic _ _ _) rho). Section coherence_laws. Variable a b c d : C. Local Definition P1 : (a ⊗ (b ⊗ (c ⊗ d))) --> (a ⊗ ((b ⊗ c) ⊗ d)). Proof. apply (morphism_of tensor); split; simpl. - exact (Core.identity a). - exact (alpha_nat_trans (b, (c, d))). Defined. Local Definition P2 : a ⊗ ((b ⊗ c) ⊗ d) --> (a ⊗ (b ⊗ c)) ⊗ d := alpha_nat_trans (a, (b ⊗ c, d)). Local Definition P3 : (a ⊗ (b ⊗ c)) ⊗ d --> ((a ⊗ b) ⊗ c ) ⊗ d. Proof. apply (morphism_of tensor); split; simpl. - exact (alpha_nat_trans (a,_)). - exact (Core.identity d). Defined. Local Definition P4 : a ⊗ (b ⊗ (c ⊗ d)) --> (a ⊗ b) ⊗ (c ⊗ d) := alpha_nat_trans (a, (b, (c ⊗ d))). Local Definition P5 : (a ⊗ b) ⊗ (c ⊗ d) --> ((a ⊗ b) ⊗ c ) ⊗ d := alpha_nat_trans (a ⊗ b,(c, d)). Local Open Scope morphism_scope. Definition pentagon_eq := P3 o P2 o P1 = P5 o P4. Close Scope morphism_scope. Local Definition Q1 : (a ⊗ (I ⊗ b)) --> a ⊗ b. Proof. apply (morphism_of tensor); split; simpl. - exact (Core.identity a). - exact (lambda_nat_trans _). Defined. Local Definition Q2 : (a ⊗ (I ⊗ b)) --> a ⊗ b. Proof. refine (@Category.Core.compose _ _ ((a ⊗ I) ⊗ b) _ _ _). - apply (morphism_of tensor); split; simpl. + exact (rho_nat_trans a). + exact (Core.identity b). - exact (alpha_nat_trans (a,(I,b))). Defined. Definition triangle_eq := Q1 = Q2. End coherence_laws. End MonoidalCategoryConcepts. Class MonoidalStructure (C : PreCategory) := Build_MonoidalStructure { tensor : (C * C -> C)%category; I : C; alpha : associator tensor; lambda : left_unitor tensor I; rho : right_unitor tensor I; pentagon_eq_holds : forall a b c d : C, pentagon_eq alpha a b c d; triangle_eq_holds : forall a b : C, triangle_eq alpha lambda rho a b; }. End MonoidalStructure. Coq-HoTT-9.0/theories/Categories/NatCategory.v000066400000000000000000000041541474641544500212600ustar00rootroot00000000000000(** * Discrete categories on [n] objects *) Require Import Category.Core DiscreteCategory IndiscreteCategory. Require Import Types.Unit Trunc Types.Sum Types.Empty. Require Import Basics.Nat. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope nat_scope. Module Export Core. (** ** [Fin n] types, or [CardinalityRepresentative] *) (** We use [Empty] for [0] and [Unit] for [1] so that we get nice judgmental behavior. TODO: this should be unified with [Spaces.Finite.Fin]. *) Fixpoint CardinalityRepresentative (n : nat) : Type0 := match n with | 0 => Empty | 1 => Unit | S n' => CardinalityRepresentative n' + Unit end. Coercion CardinalityRepresentative : nat >-> Sortclass. (** ** [Fin n] is an hSet *) Global Instance trunc_cardinality_representative (n : nat) : IsHSet (CardinalityRepresentative n). Proof. induction n; [ typeclasses eauto |]. induction n; [ typeclasses eauto |]. apply istrunc_S. intros [x|x] [y|y]; typeclasses eauto. Qed. (** ** Define the categories [n] *) Definition nat_category (n : nat) := match n with | 0 => indiscrete_category 0 | 1 => indiscrete_category 1 | S (S n') => discrete_category (S (S n')) end. Module Export NatCategoryCoreNotations. Notation "0" := (nat_category 0) : category_scope. Notation "1" := (nat_category 1) : category_scope. Notation "2" := (nat_category 2) : category_scope. Notation "3" := (nat_category 3) : category_scope. Notation "4" := (nat_category 4) : category_scope. Notation "5" := (nat_category 5) : category_scope. Notation "6" := (nat_category 6) : category_scope. Notation "7" := (nat_category 7) : category_scope. Notation "8" := (nat_category 8) : category_scope. Notation "9" := (nat_category 9) : category_scope. End NatCategoryCoreNotations. #[export] Typeclasses Transparent nat_category. #[export] Hint Unfold nat_category : core. Arguments nat_category / . End Core. Module Notations. Include Core.NatCategoryCoreNotations. End Notations. Coq-HoTT-9.0/theories/Categories/NaturalTransformation.v000066400000000000000000000033741474641544500234000ustar00rootroot00000000000000(** * Natural Transformations *) (** Since there are only notations in [NaturalTransformation.Notations], we can just export those. *) Require Export NaturalTransformation.Notations. (** ** Definition of natural transformation *) Require NaturalTransformation.Core. (** ** Composition of natural transformations *) Require NaturalTransformation.Composition.Core. (** ** Dual natural transformations *) Require NaturalTransformation.Dual. (** ** Identity natural transformation *) Require NaturalTransformation.Identity. (** ** Natural isomorphisms *) Require NaturalTransformation.Isomorphisms. (** ** Path space of natural transformation type *) Require NaturalTransformation.Paths. (** ** Pointwise natural transformations *) Require NaturalTransformation.Pointwise. (** ** Sums of natural transformations *) Require NaturalTransformation.Sum. (** ** Products of natural transformations *) Require NaturalTransformation.Prod. Include NaturalTransformation.Core. Include NaturalTransformation.Composition.Core. Include NaturalTransformation.Dual. Include NaturalTransformation.Identity. Include NaturalTransformation.Isomorphisms. Include NaturalTransformation.Paths. Include NaturalTransformation.Pointwise. Include NaturalTransformation.Sum. Include NaturalTransformation.Prod. (** We don't want to make utf-8 notations the default, so we don't export them. *) (** Since [Composition] is a separate sub-directory, we need to re-create the module structure *) (** We want to have the following as subdirectories/modules, not at top level. Unfortunately, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *) Require NaturalTransformation.Composition. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/000077500000000000000000000000001474641544500232025ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Composition.v000066400000000000000000000011651474641544500256770ustar00rootroot00000000000000(** * Composition of natural transformations *) (** ** Composition *) Require NaturalTransformation.Composition.Core. (** ** Functoriality *) Require NaturalTransformation.Composition.Functorial. (** ** Laws about composition *) Require NaturalTransformation.Composition.Laws. Include NaturalTransformation.Composition.Core. Include NaturalTransformation.Composition.Functorial. Include NaturalTransformation.Composition.Laws. Module Export NaturalTransformationCompositionNotations. Include NaturalTransformation.Composition.Core.NaturalTransformationCompositionCoreNotations. End NaturalTransformationCompositionNotations. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Composition/000077500000000000000000000000001474641544500255055ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Composition/Core.v000066400000000000000000000111621474641544500265650ustar00rootroot00000000000000(** * Composition of natural transformations *) Require Import Category.Core Functor.Core Functor.Composition.Core NaturalTransformation.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope morphism_scope. Local Open Scope natural_transformation_scope. (** ** Vertical composition *) Section composition. (** We have the diagram << F C -------> D | | | T | V C -------> D F' | | T' | V C ------> D F'' >> And we want the commutative diagram << F m F A -------> F B | | | | | T A | T B | | V F' m V F' A -------> F' B | | | | | T' A | T' B | | V F'' m V F'' A ------> F'' B >> *) Section compose. Variables C D : PreCategory. Variables F F' F'' : Functor C D. Variable T' : NaturalTransformation F' F''. Variable T : NaturalTransformation F F'. Local Notation CO c := (T' c o T c). Definition compose_commutes s d (m : morphism C s d) : CO d o F _1 m = F'' _1 m o CO s := (associativity _ _ _ _ _ _ _ _) @ ap (fun x => _ o x) (commutes T _ _ m) @ (associativity_sym _ _ _ _ _ _ _ _) @ ap (fun x => x o _) (commutes T' _ _ m) @ (associativity _ _ _ _ _ _ _ _). (** We define the symmetrized version separately so that we can get more unification in the functor [(C → D)ᵒᵖ → (Cᵒᵖ → Dᵒᵖ)] *) Definition compose_commutes_sym s d (m : morphism C s d) : F'' _1 m o CO s = CO d o F _1 m := (associativity_sym _ _ _ _ _ _ _ _) @ ap (fun x => x o _) (commutes_sym T' _ _ m) @ (associativity _ _ _ _ _ _ _ _) @ ap (fun x => _ o x) (commutes_sym T _ _ m) @ (associativity_sym _ _ _ _ _ _ _ _). Global Arguments compose_commutes : simpl never. Global Arguments compose_commutes_sym : simpl never. Definition compose : NaturalTransformation F F'' := Build_NaturalTransformation' F F'' (fun c => CO c) compose_commutes compose_commutes_sym. End compose. (** ** Whiskering *) Section whisker. Variables C D E : PreCategory. Section L. Variable F : Functor D E. Variables G G' : Functor C D. Variable T : NaturalTransformation G G'. Local Notation CO c := (F _1 (T c)). Definition whisker_l_commutes s d (m : morphism C s d) : F _1 (T d) o (F o G) _1 m = (F o G') _1 m o F _1 (T s) := ((composition_of F _ _ _ _ _)^) @ (ap (fun m => F _1 m) (commutes T _ _ _)) @ (composition_of F _ _ _ _ _). Definition whisker_l_commutes_sym s d (m : morphism C s d) : (F o G') _1 m o F _1 (T s) = F _1 (T d) o (F o G) _1 m := ((composition_of F _ _ _ _ _)^) @ (ap (fun m => F _1 m) (commutes_sym T _ _ _)) @ (composition_of F _ _ _ _ _). Global Arguments whisker_l_commutes : simpl never. Global Arguments whisker_l_commutes_sym : simpl never. Definition whisker_l := Build_NaturalTransformation' (F o G) (F o G') (fun c => CO c) whisker_l_commutes whisker_l_commutes_sym. End L. Section R. Variables F F' : Functor D E. Variable T : NaturalTransformation F F'. Variable G : Functor C D. Local Notation CO c := (T (G c)). Definition whisker_r_commutes s d (m : morphism C s d) : T (G d) o (F o G) _1 m = (F' o G) _1 m o T (G s) := commutes T _ _ _. Definition whisker_r_commutes_sym s d (m : morphism C s d) : (F' o G) _1 m o T (G s) = T (G d) o (F o G) _1 m := commutes_sym T _ _ _. Global Arguments whisker_r_commutes : simpl never. Global Arguments whisker_r_commutes_sym : simpl never. Definition whisker_r := Build_NaturalTransformation' (F o G) (F' o G) (fun c => CO c) whisker_r_commutes whisker_r_commutes_sym. End R. End whisker. End composition. Module Export NaturalTransformationCompositionCoreNotations. Infix "o" := compose : natural_transformation_scope. Infix "oL" := whisker_l : natural_transformation_scope. Infix "oR" := whisker_r : natural_transformation_scope. End NaturalTransformationCompositionCoreNotations. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Composition/Functorial.v000066400000000000000000000023721474641544500300060ustar00rootroot00000000000000(** * Functoriality of composition of natural transformations *) Require Import Category.Core Functor.Core. Require Import FunctorCategory.Core Functor.Composition.Core NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Section functorial_composition. Context `{Funext}. Variables C D E : PreCategory. Local Open Scope natural_transformation_scope. (** ** whiskering on the left is a functor *) Definition whiskerL_functor (F : (D -> E)%category) : ((C -> D) -> (C -> E))%category := Build_Functor (C -> D) (C -> E) (fun G => F o G)%functor (fun _ _ T => F oL T) (fun _ _ _ _ _ => composition_of_whisker_l _ _ _) (fun _ => whisker_l_right_identity _ _). (** ** whiskering on the right is a functor *) Definition whiskerR_functor (G : (C -> D)%category) : ((D -> E) -> (C -> E))%category := Build_Functor (D -> E) (C -> E) (fun F => F o G)%functor (fun _ _ T => T oR G) (fun _ _ _ _ _ => composition_of_whisker_r _ _ _) (fun _ => whisker_r_left_identity _ _). End functorial_composition. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Composition/Laws.v000066400000000000000000000154031474641544500266050ustar00rootroot00000000000000(** * Laws about composition of functors *) Require Import Category.Core Functor.Core Functor.Identity Functor.Composition.Core NaturalTransformation.Core NaturalTransformation.Identity NaturalTransformation.Composition.Core NaturalTransformation.Paths. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope natural_transformation_scope. Section natural_transformation_identity. Context `{Funext}. Variables C D : PreCategory. (** ** left identity : [1 ∘ T = T] *) Lemma left_identity (F F' : Functor C D) (T : NaturalTransformation F F') : 1 o T = T. Proof. path_natural_transformation; auto with morphism. Qed. (** ** right identity : [T ∘ 1 = T] *) Lemma right_identity (F F' : Functor C D) (T : NaturalTransformation F F') : T o 1 = T. Proof. path_natural_transformation; auto with morphism. Qed. (** ** right whisker left identity : [1 ∘ᴿ F = 1] *) Definition whisker_r_left_identity E (G : Functor D E) (F : Functor C D) : identity G oR F = 1. Proof. path_natural_transformation; auto with morphism. Qed. (** ** left whisker right identity : [G ∘ᴸ 1 = 1] *) Definition whisker_l_right_identity E (G : Functor D E) (F : Functor C D) : G oL identity F = 1. Proof. path_natural_transformation; auto with functor. Qed. End natural_transformation_identity. #[export] Hint Rewrite @left_identity @right_identity : category. #[export] Hint Rewrite @left_identity @right_identity : natural_transformation. Section whisker. Context `{fs : Funext}. (** ** whisker exchange law : [(G' ∘ᴸ T) ∘ (T' ∘ᴿ F) = (T' ∘ᴿ F') ∘ (G ∘ᴸ T)] *) Section exch. Variables C D E : PreCategory. Variables G G' : Functor D E. Variables F F' : Functor C D. Variable T' : NaturalTransformation G G'. Variable T : NaturalTransformation F F'. Lemma exchange_whisker : (G' oL T) o (T' oR F) = (T' oR F') o (G oL T). Proof. path_natural_transformation; simpl. symmetry. apply NaturalTransformation.Core.commutes. Qed. End exch. Section whisker. Variables C D : PreCategory. Variables F G H : Functor C D. Variable T : NaturalTransformation G H. Variable T' : NaturalTransformation F G. (** ** left whisker composition : [F ∘ᴸ (T ∘ T') = (F ∘ᴸ T) ∘ (F ∘ᴸ T')] *) Lemma composition_of_whisker_l E (I : Functor D E) : I oL (T o T') = (I oL T) o (I oL T'). Proof. path_natural_transformation; apply composition_of. Qed. (** ** right whisker composition : [(T ∘ T') ∘ᴿ F = (T ∘ᴿ F) ∘ (T' ∘ᴿ F)] *) Lemma composition_of_whisker_r B (I : Functor B C) : (T o T') oR I = (T oR I) o (T' oR I). Proof. path_natural_transformation; apply idpath. Qed. End whisker. End whisker. Section associativity. (** ** associators - natural transformations between [F ∘ (G ∘ H)] and [(F ∘ G) ∘ H] *) Section functors. Variables B C D E : PreCategory. Variable F : Functor D E. Variable G : Functor C D. Variable H : Functor B C. Local Notation F0 := ((F o G) o H)%functor. Local Notation F1 := (F o (G o H))%functor. Definition associator_1 : NaturalTransformation F0 F1 := Eval simpl in generalized_identity F0 F1 idpath idpath. Definition associator_2 : NaturalTransformation F1 F0 := Eval simpl in generalized_identity F1 F0 idpath idpath. End functors. (** ** associativity : [(T ∘ U) ∘ V = T ∘ (U ∘ V)] *) Section nt. Context `{fs : Funext}. Local Open Scope natural_transformation_scope. Definition associativity C D F G H I (V : @NaturalTransformation C D F G) (U : @NaturalTransformation C D G H) (T : @NaturalTransformation C D H I) : (T o U) o V = T o (U o V). Proof. path_natural_transformation. apply associativity. Qed. End nt. End associativity. Section functor_identity. Context `{Funext}. Variables C D : PreCategory. Local Ltac nt_id_t := split; path_natural_transformation; autorewrite with morphism; reflexivity. (** ** left unitors : natural transformations between [1 ∘ F] and [F] *) Section left. Variable F : Functor D C. Definition left_identity_natural_transformation_1 : NaturalTransformation (1 o F) F := Eval simpl in generalized_identity (1 o F) F idpath idpath. Definition left_identity_natural_transformation_2 : NaturalTransformation F (1 o F) := Eval simpl in generalized_identity F (1 o F) idpath idpath. Theorem left_identity_isomorphism : left_identity_natural_transformation_1 o left_identity_natural_transformation_2 = 1 /\ left_identity_natural_transformation_2 o left_identity_natural_transformation_1 = 1. Proof. nt_id_t. Qed. End left. (** ** right unitors : natural transformations between [F ∘ 1] and [F] *) Section right. Variable F : Functor C D. Definition right_identity_natural_transformation_1 : NaturalTransformation (F o 1) F := Eval simpl in generalized_identity (F o 1) F idpath idpath. Definition right_identity_natural_transformation_2 : NaturalTransformation F (F o 1) := Eval simpl in generalized_identity F (F o 1) idpath idpath. Theorem right_identity_isomorphism : right_identity_natural_transformation_1 o right_identity_natural_transformation_2 = 1 /\ right_identity_natural_transformation_2 o right_identity_natural_transformation_1 = 1. Proof. nt_id_t. Qed. End right. End functor_identity. (** ** Tactics for inserting appropriate associators, whiskers, and unitors *) Ltac nt_solve_associator' := repeat match goal with | _ => exact (associator_1 _ _ _) | _ => exact (associator_2 _ _ _) | _ => exact (left_identity_natural_transformation_1 _) | _ => exact (left_identity_natural_transformation_2 _) | _ => exact (right_identity_natural_transformation_1 _) | _ => exact (right_identity_natural_transformation_2 _) | [ |- NaturalTransformation (?F o _) (?F o _) ] => refine (whisker_l F _) | [ |- NaturalTransformation (_ o ?F) (_ o ?F) ] => refine (whisker_r _ F) end. Ltac nt_solve_associator := repeat first [ progress nt_solve_associator' | refine (compose (associator_1 _ _ _) _); progress nt_solve_associator' | refine (compose _ (associator_1 _ _ _)); progress nt_solve_associator' | refine (compose (associator_2 _ _ _) _); progress nt_solve_associator' | refine (compose _ (associator_2 _ _ _)); progress nt_solve_associator' ]. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Core.v000066400000000000000000000060571474641544500242710ustar00rootroot00000000000000(** * Definition of natural transformation *) Require Import Category.Core Functor.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Declare Scope natural_transformation_scope. Delimit Scope natural_transformation_scope with natural_transformation. Local Open Scope morphism_scope. Local Open Scope natural_transformation_scope. Section NaturalTransformation. Variables C D : PreCategory. Variables F G : Functor C D. (** Quoting from the lecture notes for 18.705, Commutative Algebra: A map of functors is known as a natural transformation. Namely, given two functors [F : C -> D], [G : C -> D], a natural transformation [T: F -> G] is a collection of maps [T A : F A -> G A], one for each object [A] of [C], such that [(T B) ∘ (F m) = (G m) ∘ (T A)] for every map [m : A -> B] of [C]; that is, the following diagram is commutative: << F m F A -------> F B | | | | | T A | T B | | V G m V G A --------> G B >> **) Record NaturalTransformation := Build_NaturalTransformation' { components_of :> forall c, morphism D (F c) (G c); commutes : forall s d (m : morphism C s d), components_of d o F _1 m = G _1 m o components_of s; (* We require the following symmetrized version so that for eta-expanded [T], we have [(T^op)^op = T] judgementally. *) commutes_sym : forall s d (m : C.(morphism) s d), G _1 m o components_of s = components_of d o F _1 m }. Definition Build_NaturalTransformation CO COM := Build_NaturalTransformation' CO COM (fun _ _ _ => symmetry _ _ (COM _ _ _)). End NaturalTransformation. Bind Scope natural_transformation_scope with NaturalTransformation. Create HintDb natural_transformation discriminated. Global Arguments components_of {C D}%_category {F G}%_functor T%_natural_transformation / c%_object : rename. Global Arguments commutes {C D F G} !T / _ _ _ : rename. Global Arguments commutes_sym {C D F G} !T / _ _ _ : rename. #[export] Hint Resolve commutes : category natural_transformation. (** ** Helper lemmas *) (** Some helper lemmas for rewriting. In the names, [p] stands for a morphism, [T] for natural transformation, and [F] for functor. *) Definition commutes_pT_F C D (F G : Functor C D) (T : NaturalTransformation F G) s d d' (m : morphism C s d) (m' : morphism D _ d') : (m' o T d) o F _1 m = (m' o G _1 m) o T s := ((Category.Core.associativity _ _ _ _ _ _ _ _) @ ap _ (commutes _ _ _ _) @ (Category.Core.associativity_sym _ _ _ _ _ _ _ _))%path. Definition commutes_T_Fp C D (F G : Functor C D) (T : NaturalTransformation F G) s d d' (m : morphism C s d) (m' : morphism D d' _) : T d o (F _1 m o m') = G _1 m o (T s o m') := ((Category.Core.associativity_sym _ _ _ _ _ _ _ _) @ ap10 (ap _ (commutes _ _ _ _)) _ @ (Category.Core.associativity _ _ _ _ _ _ _ _))%path. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Dual.v000066400000000000000000000022761474641544500242650ustar00rootroot00000000000000(** * Opposite natural transformations *) Require Category.Dual Functor.Dual. Import Category.Dual.CategoryDualNotations Functor.Dual.FunctorDualNotations. Require Import Category.Core Functor.Core NaturalTransformation.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. (** ** Definition of [Tᵒᵖ] *) Definition opposite C D (F G : Functor C D) (T : NaturalTransformation F G) : NaturalTransformation G^op F^op := Build_NaturalTransformation' (G^op) (F^op) (components_of T) (fun s d => commutes_sym T d s) (fun s d => commutes T d s). Local Notation "T ^op" := (opposite T) : natural_transformation_scope. (** ** [ᵒᵖ] is judgmentally involutive *) Local Open Scope natural_transformation_scope. Definition opposite_involutive C D (F G : Functor C D) (T : NaturalTransformation F G) : (T^op)^op = T := idpath. Module Export NaturalTransformationDualNotations. Notation "T ^op" := (opposite T) : natural_transformation_scope. End NaturalTransformationDualNotations. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Identity.v000066400000000000000000000052631474641544500251700ustar00rootroot00000000000000(** * Identity natural transformation *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope path_scope. Local Open Scope natural_transformation_scope. Section identity. Variables C D : PreCategory. (** There is an identity natrual transformation. We create a number of variants, for various uses. *) Section generalized. Variables F G : Functor C D. Hypothesis HO : object_of F = object_of G. Hypothesis HM : transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) HO (morphism_of F) = morphism_of G. Local Notation CO c := (transport (fun GO => morphism D (F c) (GO c)) HO (identity (F c))). Definition generalized_identity_commutes s d (m : morphism C s d) : CO d o F _1 m = G _1 m o CO s. Proof. case HM. case HO. exact (left_identity _ _ _ _ @ (right_identity _ _ _ _)^). Defined. Definition generalized_identity_commutes_sym s d (m : morphism C s d) : G _1 m o CO s = CO d o F _1 m. Proof. case HM. case HO. exact (right_identity _ _ _ _ @ (left_identity _ _ _ _)^). Defined. Definition generalized_identity : NaturalTransformation F G := Build_NaturalTransformation' F G (fun c => CO c) generalized_identity_commutes generalized_identity_commutes_sym. End generalized. Global Arguments generalized_identity_commutes / . Global Arguments generalized_identity_commutes_sym / . Global Arguments generalized_identity F G !HO !HM / . Section generalized'. Variables F G : Functor C D. Hypothesis H : F = G. Definition generalized_identity' : NaturalTransformation F G. Proof. apply (generalized_identity F G (ap (@object_of C D) H)). case H. reflexivity. Defined. End generalized'. Definition identity (F : Functor C D) : NaturalTransformation F F := Eval simpl in @generalized_identity F F 1 1. Global Arguments generalized_identity' F G !H / . End identity. Global Arguments generalized_identity_commutes : simpl never. Global Arguments generalized_identity_commutes_sym : simpl never. Module Export NaturalTransformationIdentityNotations. Notation "1" := (identity _) : natural_transformation_scope. End NaturalTransformationIdentityNotations. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Isomorphisms.v000066400000000000000000000123051474641544500260660ustar00rootroot00000000000000(** * Natural isomorphisms *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import NaturalTransformation.Composition.Core. Require Import Functor.Composition.Core. Require Import Category.Morphisms. Require Import FunctorCategory.Core. Require Import NaturalTransformation.Paths. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope natural_transformation_scope. Local Open Scope morphism_scope. Local Ltac iso_whisker_t := path_natural_transformation; try rewrite <- composition_of, <- identity_of; try f_ap; match goal with | [ H : IsIsomorphism _ |- context[components_of ?T0 ?x o components_of ?T1 ?x] ] => change (T0 x o T1 x) with (components_of ((T0 : morphism (_ -> _) _ _) o (T1 : morphism (_ -> _) _ _))%morphism x); progress rewrite ?(@left_inverse _ _ _ _ H), ?(@right_inverse _ _ _ _ H) end; reflexivity. Section composition. Context `{Funext}. (** ** Natural isomorphism respects composition *) Global Instance isisomorphism_compose `(T' : @NaturalTransformation C D F' F'') `(T : @NaturalTransformation C D F F') `{@IsIsomorphism (C -> D) F' F'' T'} `{@IsIsomorphism (C -> D) F F' T} : @IsIsomorphism (C -> D) F F'' (T' o T)%natural_transformation := @isisomorphism_compose (C -> D) _ _ T' _ _ T _. (** ** Left whiskering preserves natural isomorphisms *) Global Instance iso_whisker_l C D E (F : Functor D E) (G G' : Functor C D) (T : NaturalTransformation G G') `{@IsIsomorphism (C -> D) G G' T} : @IsIsomorphism (C -> E) (F o G)%functor (F o G')%functor (whisker_l F T). Proof. exists (whisker_l F (T : morphism (_ -> _) _ _)^-1); abstract iso_whisker_t. Defined. (** ** Right whiskering preserves natural isomorphisms *) Global Instance iso_whisker_r C D E (F F' : Functor D E) (T : NaturalTransformation F F') (G : Functor C D) `{@IsIsomorphism (D -> E) F F' T} : @IsIsomorphism (C -> E) (F o G)%functor (F' o G)%functor (whisker_r T G). Proof. exists (whisker_r (T : morphism (_ -> _) _ _)^-1 G); abstract iso_whisker_t. Defined. (** ** action of [idtoiso] on objects *) Definition idtoiso_components_of C D (F G : Functor C D) (T' : F = G) x : (Category.Morphisms.idtoiso (_ -> _) T' : morphism _ _ _) x = Category.Morphisms.idtoiso _ (ap10 (ap object_of T') x). Proof. destruct T'. reflexivity. Defined. (** ** [idtoiso] respsects composition *) Definition idtoiso_compose C D (F F' F'' : Functor C D) (T' : F' = F'') (T : F = F') : ((Category.Morphisms.idtoiso (_ -> _) T' : morphism _ _ _) o (Category.Morphisms.idtoiso (_ -> _) T : morphism _ _ _))%natural_transformation = (Category.Morphisms.idtoiso (_ -> _) (T @ T')%path : morphism _ _ _). Proof. path_natural_transformation; path_induction; simpl; auto with morphism. Defined. (** ** left whiskering respects [idtoiso] *) Definition idtoiso_whisker_l C D E (F : Functor D E) (G G' : Functor C D) (T : G = G') : whisker_l F (Category.Morphisms.idtoiso (_ -> _) T : morphism _ _ _) = (Category.Morphisms.idtoiso (_ -> _) (ap _ T) : morphism _ _ _). Proof. path_natural_transformation; path_induction; simpl; auto with functor. Defined. (** ** right whiskering respects [idtoiso] *) Definition idtoiso_whisker_r C D E (F F' : Functor D E) (T : F = F') (G : Functor C D) : whisker_r (Category.Morphisms.idtoiso (_ -> _) T : morphism _ _ _) G = (Category.Morphisms.idtoiso (_ -> _) (ap (fun _ => _ o _)%functor T) : morphism _ _ _). Proof. path_natural_transformation; path_induction; simpl; auto with functor. Defined. End composition. Arguments isisomorphism_compose {H C D F' F''} T' {F} T {H0 H1}. Arguments iso_whisker_l {H} C D E F G G' T {H0}. Arguments iso_whisker_r {H} C D E F F' T G {H0}. (** ** Equalities induced by isomorphisms of objects *) Section object_isomorphisms. Lemma path_components_of_isisomorphism `{IsIsomorphism C s d m} D (F G : Functor C D) (T : NaturalTransformation F G) : (G _1 m)^-1 o (T d o F _1 m) = T s. Proof. apply iso_moveR_Vp. apply commutes. Qed. Lemma path_components_of_isisomorphism' `{IsIsomorphism C s d m} D (F G : Functor C D) (T : NaturalTransformation F G) : (G _1 m o T s) o (F _1 m)^-1 = T d. Proof. apply iso_moveR_pV. symmetry. apply commutes. Qed. Definition path_components_of_isomorphic `(m : @Isomorphic C s d) D (F G : Functor C D) (T : NaturalTransformation F G) : (G _1 m)^-1 o (T d o F _1 m) = T s := @path_components_of_isisomorphism _ _ _ m m D F G T. Definition path_components_of_isomorphic' `(m : @Isomorphic C s d) D (F G : Functor C D) (T : NaturalTransformation F G) : (G _1 m o T s) o (F _1 m)^-1 = T d := @path_components_of_isisomorphism' _ _ _ m m D F G T. End object_isomorphisms. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Notations.v000066400000000000000000000011451474641544500253500ustar00rootroot00000000000000(** * Notations for natural transformations *) Require NaturalTransformation.Composition. Require NaturalTransformation.Dual. Require NaturalTransformation.Identity. Require NaturalTransformation.Prod. Require NaturalTransformation.Sum. Include NaturalTransformation.Composition.NaturalTransformationCompositionNotations. Include NaturalTransformation.Dual.NaturalTransformationDualNotations. Include NaturalTransformation.Identity.NaturalTransformationIdentityNotations. Include NaturalTransformation.Prod.NaturalTransformationProdNotations. Include NaturalTransformation.Sum.NaturalTransformationSumNotations. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Paths.v000066400000000000000000000063501474641544500244540ustar00rootroot00000000000000(** * Classify the path space of natural transformations *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Equivalences HoTT.Types Trunc Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope natural_transformation_scope. Section path_natural_transformation. Context `{Funext}. Variables C D : PreCategory. Variables F G : Functor C D. (** ** Equivalence between record and sigma versions of natural transformation *) Lemma equiv_sig_natural_transformation : { CO : forall x, morphism D (F x) (G x) | forall s d (m : morphism C s d), CO d o F _1 m = G _1 m o CO s } <~> NaturalTransformation F G. Proof. let build := constr:(@Build_NaturalTransformation _ _ F G) in let pr1 := constr:(@components_of _ _ F G) in let pr2 := constr:(@commutes _ _ F G) in apply (equiv_adjointify (fun u => build u.1 u.2) (fun v => (pr1 v; pr2 v))); hnf; [ intros []; intros; simpl; expand; f_ap; exact (center _) | intros; apply eta_sigma ]. Defined. (** ** The type of natural transformations is an hSet *) Global Instance trunc_natural_transformation : IsHSet (NaturalTransformation F G). Proof. eapply istrunc_equiv_istrunc; [ exact equiv_sig_natural_transformation | ]. typeclasses eauto. Qed. Section path. Variables T U : NaturalTransformation F G. (** ** Equality of natural transformations is implied by equality of components *) Lemma path'_natural_transformation : components_of T = components_of U -> T = U. Proof. intros. destruct T, U; simpl in *. path_induction. f_ap; refine (center _). Qed. Lemma path_natural_transformation : components_of T == components_of U -> T = U. Proof. intros. apply path'_natural_transformation. apply path_forall; assumption. Qed. Let path_inv : T = U -> components_of T == components_of U := (fun H _ => match H with idpath => idpath end). Lemma eisretr_path_natural_transformation : path_inv o path_natural_transformation == idmap. Proof. repeat intro. refine (center _). Qed. Lemma eissect_path_natural_transformation : path_natural_transformation o path_inv == idmap. Proof. repeat intro. refine (center _). Qed. Lemma eisadj_path_natural_transformation : forall x, @eisretr_path_natural_transformation (path_inv x) = ap path_inv (eissect_path_natural_transformation x). Proof. repeat intro. refine (center _). Qed. (** ** Equality of natural transformations is equivalent to equality of components *) Lemma equiv_path_natural_transformation : T = U <~> (components_of T == components_of U). Proof. econstructor. econstructor. exact eisadj_path_natural_transformation. Defined. End path. End path_natural_transformation. (** ** Tactic for proving equality of natural transformations *) Ltac path_natural_transformation := repeat match goal with | _ => intro | _ => apply path_natural_transformation; simpl end. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Pointwise.v000066400000000000000000000045141474641544500253560ustar00rootroot00000000000000(** * Pointwise Natural Transformations *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import FunctorCategory.Core NaturalTransformation.Paths Functor.Composition.Core NaturalTransformation.Composition.Core. Require Import Functor.Pointwise.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** Recall that a "pointwise" functor is a functor [Aᴮ → Cᴰ] induced by functors [D → B] and [A → C]. Given two functors [D → B] and a natural transformation between them, there is an induced natural transformation between the resulting functors between functor categories, and similarly for two functors [A → C]. In this file, we construct these natural transformations. They will be used to construct the pointwise induced adjunction [Fˣ ⊣ Gˣ] of an adjunction [F ⊣ G] for all categories [X]. *) Local Open Scope morphism_scope. Local Open Scope category_scope. Local Open Scope functor_scope. Local Open Scope natural_transformation_scope. Section pointwise. Context `{Funext}. Variables C D C' D' : PreCategory. Local Ltac t := path_natural_transformation; simpl; rewrite <- ?composition_of; try apply ap; first [ apply commutes | symmetry; apply commutes ]. (** ** [Tˣ] for a natural transformation [T : F → G] and a functor [x : C → D] *) Definition pointwise_l (F G : Functor C D) (T : NaturalTransformation F G) (F' : Functor C' D') : NaturalTransformation (pointwise F F') (pointwise G F'). Proof. refine (Build_NaturalTransformation (pointwise F F') (pointwise G F') (fun f : object (D -> C') => (F' o f) oL T)%natural_transformation _). abstract t. Defined. (** ** [Fᵀ] for a natural transformation [T : F' → G'] and a functor [F : C → D] *) Definition pointwise_r (F : Functor C D) (F' G' : Functor C' D') (T' : NaturalTransformation F' G') : NaturalTransformation (pointwise F F') (pointwise F G'). Proof. refine (Build_NaturalTransformation (pointwise F F') (pointwise F G') (fun f : object (D -> C') => T' oR f oR F)%natural_transformation _). abstract t. Defined. End pointwise. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Prod.v000066400000000000000000000045671474641544500243110ustar00rootroot00000000000000(** * Natural transformations involving product categories *) Require Import Category.Core Functor.Core Category.Prod Functor.Prod.Core NaturalTransformation.Core. Require Import Types.Prod. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. (** ** Product of natural transformations *) Section prod. Context {A : PreCategory}. Context {B : PreCategory}. Context {C : PreCategory}. Variables F F' : Functor A B. Variables G G' : Functor A C. Variable T : NaturalTransformation F F'. Variable U : NaturalTransformation G G'. Definition prod : NaturalTransformation (F * G) (F' * G') := Build_NaturalTransformation (F * G) (F' * G') (fun x : A => (T x, U x)) (fun _ _ _ => path_prod' (commutes T _ _ _) (commutes U _ _ _)). End prod. Local Infix "*" := prod : natural_transformation_scope. (** ** Natural transformations between partially applied functors *) Section induced. Variables C D E : PreCategory. Variable F : Functor (C * D) E. Local Ltac t := simpl; intros; rewrite <- !composition_of; simpl; rewrite ?left_identity, ?right_identity; reflexivity. Definition induced_fst s d (m : morphism C s d) : NaturalTransformation (Functor.Prod.Core.induced_snd F s) (Functor.Prod.Core.induced_snd F d). Proof. let F0 := match goal with |- NaturalTransformation ?F0 ?G0 => constr:(F0) end in let G0 := match goal with |- NaturalTransformation ?F0 ?G0 => constr:(G0) end in refine (Build_NaturalTransformation F0 G0 (fun d => @morphism_of _ _ F (_, _) (_, _) (m, @identity D d)) _). abstract t. Defined. Definition induced_snd s d (m : morphism D s d) : NaturalTransformation (Functor.Prod.Core.induced_fst F s) (Functor.Prod.Core.induced_fst F d). Proof. let F0 := match goal with |- NaturalTransformation ?F0 ?G0 => constr:(F0) end in let G0 := match goal with |- NaturalTransformation ?F0 ?G0 => constr:(G0) end in refine (Build_NaturalTransformation F0 G0 (fun c => @morphism_of _ _ F (_, _) (_, _) (@identity C c, m)) _). abstract t. Defined. End induced. Module Export NaturalTransformationProdNotations. Infix "*" := prod : natural_transformation_scope. End NaturalTransformationProdNotations. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Sum.v000066400000000000000000000017421474641544500241410ustar00rootroot00000000000000(** * Coproduct of natural transformations *) Require Import Category.Sum Functor.Sum NaturalTransformation.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section sum. Definition sum C C' D F G F' G' (T : @NaturalTransformation C D F G) (T' : @NaturalTransformation C' D F' G') : NaturalTransformation (F + F') (G + G'). Proof. refine (Build_NaturalTransformation (F + F') (G + G') (fun x => match x with | Basics.Overture.inl c => T c | Basics.Overture.inr c' => T' c' end) _). abstract ( repeat (intros [] || intro); simpl; auto with natural_transformation ). Defined. End sum. Module Export NaturalTransformationSumNotations. Notation "T + U" := (sum T U) : natural_transformation_scope. End NaturalTransformationSumNotations. Coq-HoTT-9.0/theories/Categories/NaturalTransformation/Utf8.v000066400000000000000000000007041474641544500242200ustar00rootroot00000000000000(** * Unicode notations for natural transformations *) Require Export Category.Utf8 Functor.Utf8. Require Import NaturalTransformation.Composition.Core NaturalTransformation.Dual. Require Import Basics.Utf8. Infix "∘" := compose : natural_transformation_scope. Infix "∘ˡ" := whisker_l : natural_transformation_scope. Infix "∘ʳ" := whisker_r : natural_transformation_scope. Notation "T 'ᵒᵖ'" := (opposite T) : natural_transformation_scope. Coq-HoTT-9.0/theories/Categories/Notations.v000066400000000000000000000010741474641544500210140ustar00rootroot00000000000000(** * Notations for categories *) Require Import Basics.Notations. Require Export Category.Notations. Require Export Functor.Notations. Require Export NaturalTransformation.Notations. Require Export FunctorCategory.Notations. Require NatCategory. Export NatCategory.Notations. Require Export InitialTerminalCategory.Notations. Require Export Profunctor.Notations. Local Set Warnings Append "-notation-overridden". Require Export Comma.Notations. Require Export Adjoint.Notations. Require Export Structure.Notations. Require ChainCategory. Export ChainCategory.Notations. Coq-HoTT-9.0/theories/Categories/ProductLaws.v000066400000000000000000000101341474641544500213020ustar00rootroot00000000000000(** * Laws about product categories *) Require Import HoTT.Basics HoTT.Types. Require Import Category.Core Functor.Core InitialTerminalCategory.Core InitialTerminalCategory.Functors Category.Prod Functor.Prod Functor.Composition.Core Functor.Identity Functor.Composition.Laws. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope functor_scope. Local Notation prod_type := Basics.Overture.prod. Local Notation fst_type := Basics.Overture.fst. Local Notation snd_type := Basics.Overture.snd. Local Notation pair_type := Basics.Overture.pair. (** ** Swap functor [C × D → D × C] *) Module Swap. Definition functor (C D : PreCategory) : Functor (C * D) (D * C) := Build_Functor (C * D) (D * C) (fun cd => (snd_type cd, fst_type cd)%core) (fun _ _ m => (snd_type m, fst_type m)%core) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition law (C D : PreCategory) : functor C D o functor D C = 1 := idpath. End Swap. (** ** [A * (B * C) ≅ (A * B) * C] *) Module Associativity. Section associativity. Variables A B C : PreCategory. Definition functor : Functor (A * (B * C)) ((A * B) * C) := (fst * (fst o snd)) * (snd o snd). Definition inverse : Functor ((A * B) * C) (A * (B * C)) := (fst o fst) * ((snd o fst) * snd). Definition law : functor o inverse = 1 /\ inverse o functor = 1 := (idpath, idpath)%core. End associativity. End Associativity. (** ** Laws about the initial category [0] *) Module Law0. Section law0. Context `{Funext}. Context `{IsInitialCategory zero}. Local Notation "0" := zero : category_scope. Variable C : PreCategory. Global Instance is_initial_category__product : IsInitialCategory (C * 0) := fun P c => initial_category_ind P (snd c). Global Instance is_initial_category__product' : IsInitialCategory (0 * C) := fun P c => initial_category_ind P (fst c). Definition functor : Functor (C * 0) 0 := Functors.from_initial _. Definition functor' : Functor (0 * C) 0 := Functors.from_initial _. Definition inverse : Functor 0 (C * 0) := Functors.from_initial _. Definition inverse' : Functor 0 (0 * C) := Functors.from_initial _. (** *** [C × 0 ≅ 0] *) Definition law : functor o inverse = 1 /\ inverse o functor = 1 := center _. (** *** [0 × C ≅ 0] *) Definition law' : functor' o inverse' = 1 /\ inverse' o functor' = 1 := center _. End law0. End Law0. (** ** Laws about the terminal category [1] *) Module Law1. Section law1. Context `{Funext}. Context `{IsTerminalCategory one}. Local Notation "1" := one : category_scope. Variable C : PreCategory. Definition functor : Functor (C * 1) C := fst. Definition functor' : Functor (1 * C) C := snd. Definition inverse : Functor C (C * 1) := 1 * Functors.to_terminal _. Definition inverse' : Functor C (1 * C) := Functors.to_terminal _ * 1. (** We could throw this in a [repeat match goal with ... end], but we know the order, so we hard-code the order to speed it up by a factor of about 10. *) Local Ltac t_prod := split; try first [ exact (compose_fst_prod _ _) | exact (compose_snd_prod _ _) ]; []; apply Functor.Prod.Universal.path_prod; rewrite <- !Functor.Composition.Laws.associativity by assumption; (rewrite ?compose_fst_prod, ?compose_snd_prod, ?Functor.Composition.Laws.left_identity, ?Functor.Composition.Laws.right_identity by assumption); try (reflexivity || exact (center _)). (** *** [C × 1 ≅ C] *) Lemma law1 : functor o inverse = 1 /\ inverse o functor = 1. Proof. unfold functor, inverse. t_prod. Qed. (** *** [1 × C ≅ C] *) Lemma law1' : functor' o inverse' = 1 /\ inverse' o functor' = 1. Proof. unfold functor', inverse'. t_prod. Qed. End law1. End Law1. Coq-HoTT-9.0/theories/Categories/Profunctor.v000066400000000000000000000005031474641544500211730ustar00rootroot00000000000000(** * Profunctors *) Require Export Profunctor.Notations. (** ** Definition *) Require Profunctor.Core. (** ** Identity Profunctor *) Require Profunctor.Identity. (** ** Representable Profunctors *) Require Profunctor.Representable. Include Profunctor.Core. Include Profunctor.Representable. Include Profunctor.Identity. Coq-HoTT-9.0/theories/Categories/Profunctor/000077500000000000000000000000001474641544500210065ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Profunctor/Core.v000066400000000000000000000053731474641544500220750ustar00rootroot00000000000000(** * Profunctors *) Require Import Category.Core Functor.Core Category.Prod Category.Dual SetCategory.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Declare Scope profunctor_scope. Delimit Scope profunctor_scope with profunctor. Section profunctor. (** Quoting nCatLab: If [C] and [D] are categories, a profunctor from [C] to [D] is a functor [Dᵒᵖ * C -> Set]. Such a profunctor is usually written as [F : C ⇸ D]. Every functor [f : C -> D] induces two profunctors [D(1, f) : C ⇸ D] and [D(f, 1) : D ⇸ C], defined by [D(1,f)(d,c) = D(d, f(c))] and [D(f, 1)(c,d) = D(f(c), d)]. These profunctors are called representable (or sometimes one of them is corepresentable). In particular the identity profunctor [Id : C ⇸ C] is represented by the identity functor and hence is given by the hom-functor [C(−, −) : Cᵒᵖ * C -> Set]. The notion generalizes to many other kinds of categories. For instance, if [C] and [D] are enriched over some symmetric closed monoidal category [V], then a profunctor from [C] to [D] is a [V]-functor [Dᵒᵖ ⊗ C -> V]. If they are internal categories, then a profunctor [C ⇸ D] is an internal diagram on [Dᵒᵖ * C], and so on. There are also other equivalent definitions in each case; see below. A profunctor is also sometimes called a (bi)module or a distributor or a correspondence, though the latter word is also used for a span. The term “module” tends to be common in Australia, especially in the enriched case; here the intuition is that for one-object [V]-categories, i.e. monoids in [V], profunctors really are the same as bimodules between such monoids in the usual sense. “Profunctor” is perhaps more common in the Set-based and internal cases (but is also used in the enriched case); here the intuition is that a profunctor is a generalization of a functor, via the construction of “representable” profunctors. Jean Bénabou, who invented the term and originally used “profunctor,” now prefers “distributor,” which is supposed to carry the intuition that a distributor generalizes a functor in a similar way to how a distribution generalizes a function. Note that the convention that a profunctor is a functor [Dᵒᵖ * C -> Set] is not universal; some authors reverse C and D and/or put the “op” on the other one. See the discussion below. *) Context `{Funext}. Variables C D : PreCategory. (** We capitalize [Profunctor] just like we capitalize [Functor]. *) Definition Profunctor := Functor (D^op * C) set_cat. End profunctor. Bind Scope profunctor_scope with Profunctor. Module Export ProfunctorCoreNotations. Notation "x -|-> y" := (Profunctor x y) : type_scope. End ProfunctorCoreNotations. Coq-HoTT-9.0/theories/Categories/Profunctor/Identity.v000066400000000000000000000012411474641544500227640ustar00rootroot00000000000000(** * Identity profunctor *) Require Import Category.Core Profunctor.Core HomFunctor. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope profunctor_scope. Section identity. (** Quoting nCatLab: In particular the identity profunctor [Id : C ⇸ C] is represented by the identity functor and hence is given by the hom-functor [C(−,−) : Cᵒᵖ × C → Set]. *) Definition identity `{Funext} (C : PreCategory) : C -|-> C := hom_functor C. End identity. Module Export ProfunctorIdentityNotations. Notation "1" := (identity _) : profunctor_scope. End ProfunctorIdentityNotations. Coq-HoTT-9.0/theories/Categories/Profunctor/Notations.v000066400000000000000000000003041474641544500231500ustar00rootroot00000000000000(** * Notations for profunctors *) Require Profunctor.Core. Require Profunctor.Identity. Include Profunctor.Core.ProfunctorCoreNotations. Include Profunctor.Identity.ProfunctorIdentityNotations. Coq-HoTT-9.0/theories/Categories/Profunctor/Representable.v000066400000000000000000000021371474641544500237730ustar00rootroot00000000000000(** * Representable profunctors *) Require Import Category.Core Functor.Core Functor.Prod.Core Profunctor.Core Functor.Dual Profunctor.Identity Functor.Composition.Core Functor.Identity. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Local Open Scope profunctor_scope. Section representable. (** Quoting nCatLab on profunctors: Every functor [f : C → D] induces two profunctors [D(1, f) : C ⇸ D] and [D(f, 1) : D ⇸ C], defined by [D(1, f)(d, c) = D(d, f(c))] and [D(f, 1)(c, d) = D(f(c), d)]. These profunctors are called representable (or sometimes one of them is corepresentable). *) Context `{Funext}. Definition representable C D (F : Functor C D) : C -|-> D := 1%profunctor o (1, F). (** TODO: Is there a define this so that we get proofs by duality about representable functors? If we had judgemental eta expansion, maybe we could do it as [swap o (representable F^op)^op]? *) Definition corepresentable C D (F : Functor C D) : D -|-> C := 1%profunctor o (F^op, 1). End representable. Coq-HoTT-9.0/theories/Categories/Profunctor/Utf8.v000066400000000000000000000003021474641544500220160ustar00rootroot00000000000000(** * Unicode notations for profunctors *) Require Import Profunctor.Core. Require Export Profunctor.Notations. Require Import Basics.Utf8. Notation "x ⇸ y" := (Profunctor x y) : type_scope. Coq-HoTT-9.0/theories/Categories/Pseudofunctor.v000066400000000000000000000006461474641544500217020ustar00rootroot00000000000000(** * Pseudofunctors *) (** ** Definition *) Require Pseudofunctor.Core. (** ** Helper lemmas for rewriting *) Require Pseudofunctor.RewriteLaws. (** ** Construction from a functor to cat *) Require Pseudofunctor.FromFunctor. (** ** Identity pseudofunctor *) Require Pseudofunctor.Identity. Include Pseudofunctor.Core. Include Pseudofunctor.RewriteLaws. Include Pseudofunctor.FromFunctor. Include Pseudofunctor.Identity. Coq-HoTT-9.0/theories/Categories/Pseudofunctor/000077500000000000000000000000001474641544500215055ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Pseudofunctor/Core.v000066400000000000000000000224021474641544500225640ustar00rootroot00000000000000(** * Pseudofunctors *) Require Import Category.Core Functor.Core. Require Import Category.Morphisms FunctorCategory.Morphisms. Require Import Functor.Composition.Core Functor.Identity. Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws. Require Import FunctorCategory.Core. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section pseudofunctor. Local Open Scope natural_transformation_scope. Context `{Funext}. Variable C : PreCategory. (** Quoting from nCatLab (http://ncatlab.org/nlab/show/pseudofunctor): Given bicategories [C] and [D], a pseudofunctor (or weak 2-functor, or just functor) [P : C → D] consists of: - for each object [x] of [C], an object [P_x] of [D]; - for each hom-category [C(x,y)] in [C], a functor [P_{x,y} : C(x,y) → D(P_x, P_y)]; - for each object [x] of [C], an invertible 2-morphism (2-cell) [P_{id_x} : id_{P_x} ⇒ P_{x,x}(id_x)]; - for each triple [x],[y],[z] of [C]-objects, a isomorphism (natural in [f : x → y] and [g : y → z]) [P_{x,y,z}(f,g) : P_{x,y}(f);P_{y,z}(g) ⇒ P_{x,z}(f;g)]; - for each hom-category [C(x,y)], << id_{Pₓ} ; P_{x, y}(f) // \\ // \\ P_{idₓ} ; id_{P_{x,y}(f)} // \\ λ_{P_{x,y}(f)} // \\ ⇙ ⇘ Pₓ,ₓ(idₓ) ; P_{x,y}(f) P_{x,y}(f) \\ ⇗ \\ // P_{x,x,y}(idₓ, f) \\ // P_{x,y}(λ_f) \\ // ⇘ // P_{x,y}(idₓ ; f) >> and << P_{x, y}(f) ; id_{P_y} // \\ // \\ id_{P_{x,y}(f)} ; P_{id_y} // \\ ρ_{P_{x,y}(f)} // \\ ⇙ ⇘ P_{x,y}(f) ; P_{y,y}(id_y) P_{x,y}(f) \\ ⇗ \\ // P_{x,y,y}(f, id_y) \\ // P_{x,y}(ρ_f) \\ // ⇘ // P_{x,y}(f ; id_y) >> commute; and - for each quadruple [w],[x],[y],[z] of [C]-objects, << α_{P_{w,x}(f),P_{x,y}(g),P_{y,z}(h)} (P_{w,x}(f) ; P_{x,y}(g)) ; P_{y,z}(h) ========================================⇒ P_{w,x}(f) ; (P_{x,y}(g) ; P_{y,z}(h)) ∥ ∥ ∥ ∥ P_{w,x,y}(f,g) ; id_{P_{y,z}(h)} ∥ ∥ id_{P_{w,x}(f)} ; P_{x,y,z}(g, h) ∥ ∥ ⇓ ⇓ P_{w,y}(f ; g) ; P_{y,z}(h) P_{w,x}(f) ; P_{x,z}(g ; h) ∥ ∥ ∥ ∥ P_{w,y,z}(f ; g, h) ∥ ∥ P_{w,x,z}(f, g ; h) ∥ ∥ ⇓ ⇓ P_{w,z}((f ; g) ; h) ========================================⇒ P_{w,z}(f ; (g ; h)) P_{w,z}(α_{f,g,h}) >> commutes. *) (* To obtain the [p_composition_of_coherent] type, I ran << Unset Implicit Arguments. Variable F : Pseudofunctor. Goal forall (w x y z : C) (f : morphism C w x) (g : morphism C x y) (h : morphism C y z), Type. Proof. intros. pose ((idtoiso (_ -> _) (ap (p_morphism_of F w z) (associativity C _ _ _ _ f g h))) : morphism _ _ _). pose ((p_composition_of F w y z h (g ∘ f)) : NaturalTransformation _ _). pose (p_morphism_of F y z h ∘ p_composition_of F w x y g f). pose (associator_1 (p_morphism_of F y z h) (p_morphism_of F x y g) (p_morphism_of F w x f)). pose (p_composition_of F x y z h g ∘ p_morphism_of F w x f). pose ((p_composition_of F w x z (h ∘ g) f) : NaturalTransformation _ _). simpl in *. repeat match goal with | [ H : _, H' : _ |- _ ] => unique_pose_with_body (NTComposeT H H'); subst H H' end. match goal with | [ H := _, H' := _ |- _ ] => assert (H = H'); subst H H' end. >> << Unset Implicit Arguments. Variable F : Pseudofunctor. Goal forall (x y : C) (f : morphism C x y), Type. Proof. intros. pose (p_identity_of F y ∘ p_morphism_of F x y f). pose (p_composition_of F x y y (Identity y) f : NaturalTransformation _ _). pose (idtoiso (_ -> _) (ap (p_morphism_of F x y) (left_identity _ _ _ f)) : morphism _ _ _). pose (left_identity_natural_transformation_2 (p_morphism_of F x y f)). simpl in *. repeat match goal with | [ H : _, H' : _ |- _ ] => unique_pose_with_body (NTComposeT H H'); subst H H' end. match goal with | [ H := _, H' := _ |- _ ] => assert (H = H'); subst H H' end. >> << Unset Implicit Arguments. Variable F : Pseudofunctor. Goal forall (x y : C) (f : morphism C x y), Type. Proof. intros. pose (p_morphism_of F x y f ∘ p_identity_of F x). pose (p_composition_of F x x y f (Identity x) : NaturalTransformation _ _). pose (idtoiso (_ -> _) (ap (p_morphism_of F x y) (right_identity _ _ _ f)) : morphism _ _ _). pose (right_identity_natural_transformation_2 (p_morphism_of F x y f)). simpl in *. repeat match goal with | [ H : _, H' : _ |- _ ] => unique_pose_with_body (NTComposeT H H'); subst H H' end. match goal with | [ H := _, H' := _ |- _ ] => assert (H = H'); subst H H' end. >> *) Record Pseudofunctor := { p_object_of :> C -> PreCategory; p_morphism_of : forall s d, morphism C s d -> Functor (p_object_of s) (p_object_of d); p_composition_of : forall s d d' (m1 : morphism C d d') (m2 : morphism C s d), (p_morphism_of _ _ (m1 o m2)) <~=~> (p_morphism_of _ _ m1 o p_morphism_of _ _ m2)%functor; p_identity_of : forall x, p_morphism_of x x 1 <~=~> 1%functor; p_composition_of_coherent : forall w x y z (f : morphism C w x) (g : morphism C x y) (h : morphism C y z), ((associator_1 (p_morphism_of y z h) (p_morphism_of x y g) (p_morphism_of w x f)) o ((p_composition_of x y z h g oR p_morphism_of w x f) o (p_composition_of w x z (h o g) f))) = ((p_morphism_of y z h oL p_composition_of w x y g f) o ((p_composition_of w y z h (g o f)) o (Category.Morphisms.idtoiso (_ -> _) (ap (p_morphism_of w z) (Category.Core.associativity C w x y z f g h)) : morphism _ _ _))); p_left_identity_of_coherent : forall x y (f : morphism C x y), ((p_identity_of y oR p_morphism_of x y f) o p_composition_of x y y 1 f) = ((left_identity_natural_transformation_2 (p_morphism_of x y f)) o (Category.Morphisms.idtoiso (_ -> _) (ap (p_morphism_of x y) (Category.Core.left_identity C x y f)) : morphism _ _ _)); p_right_identity_of_coherent : forall x y (f : morphism C x y), ((p_morphism_of x y f oL p_identity_of x) o p_composition_of x x y f 1) = ((right_identity_natural_transformation_2 (p_morphism_of x y f)) o (Category.Morphisms.idtoiso (_ -> _) (ap (p_morphism_of x y) (Category.Core.right_identity C x y f)) : morphism _ _ _)) }. End pseudofunctor. Declare Scope pseudofunctor_scope. Delimit Scope pseudofunctor_scope with pseudofunctor. Bind Scope pseudofunctor_scope with Pseudofunctor. Create HintDb pseudofunctor discriminated. Arguments p_object_of {_} {C%_category} F%_pseudofunctor / c%_object : rename. Arguments p_morphism_of {_} {C%_category} F%_pseudofunctor / {s d}%_object m%_morphism : rename. (*Notation "F ₀ x" := (p_object_of F x) : object_scope. Notation "F ₁ m" := (p_morphism_of F m) : morphism_scope.*) Coq-HoTT-9.0/theories/Categories/Pseudofunctor/FromFunctor.v000066400000000000000000000154251474641544500241470ustar00rootroot00000000000000(** * Functors to cat are pseudofunctors *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Functor.Composition.Core NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws. Require Import Functor.Identity. Require Import Pseudofunctor.Core. Require Import Cat.Core. Require Import FunctorCategory.Core. Require Import FunctorCategory.Morphisms NaturalTransformation.Isomorphisms. Require Import Category.Morphisms NaturalTransformation.Paths. Require Import Basics.PathGroupoids Basics.Trunc. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope morphism_scope. (** Every functor to Cat is a pseudofunctor *) Section of_functor. Context `{Funext}. Variable C : PreCategory. Context `{HP : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation cat := (@sub_pre_cat _ P HP). Variable F : Functor C cat. Definition path_functor_helper A B (F1 F2 : Functor A B) (pf1 pf2 : F1 = F2) : P A -> P B -> pf1 = pf2 := fun PA PB => @path_ishprop _ (@HP A B PA PB F1 F2) _ _. Local Hint Extern 0 (P ?x.1) => exact x.2 : core. Local Tactic Notation "transitivity_idtoiso" open_constr(hyp) := lazymatch goal with | [ |- ?f (Category.Morphisms.idtoiso ?C _) = _ ] => etransitivity (f (Category.Morphisms.idtoiso C hyp)); [ do 2 refine (ap _ _); (* https://coq.inria.fr/bugs/show_bug.cgi?id=3626 *) apply path_functor_helper; simpl; trivial | path_natural_transformation ] end. Local Ltac pseudofunctor_t := intros; unfold natural_transformation_of_natural_isomorphism; rewrite ?idtoiso_whisker_r, ?idtoiso_whisker_l; repeat ( let C := match goal with |- @paths (@NaturalTransformation ?C ?D ?F ?G) _ _ => constr:((C -> D)%category) end in first [ eapply (@iso_moveL_pV C) | eapply (@iso_moveL_Vp C) | eapply (@iso_moveL_pM C) | eapply (@iso_moveL_Mp C) ]; simpl ); rewrite ?idtoiso_inv; simpl; change @NaturalTransformation.Composition.Core.compose with (fun C D F G H => Category.Core.compose (C := C -> D) (s := F) (d := G) (d' := H)); cbv beta; rewrite ?idtoiso_comp; first [ transitivity_idtoiso (Functor.Composition.Laws.left_identity _) | transitivity_idtoiso ((Functor.Composition.Laws.left_identity _)^) | transitivity_idtoiso (Functor.Composition.Laws.right_identity _) | transitivity_idtoiso ((Functor.Composition.Laws.right_identity _)^) | transitivity_idtoiso (Functor.Composition.Laws.associativity _ _ _) | transitivity_idtoiso ((Functor.Composition.Laws.associativity _ _ _)^) ]; rewrite eta_idtoiso; simpl; rewrite ?ap_V, ?Functor.Composition.Laws.left_identity_fst, ?Functor.Composition.Laws.right_identity_fst, ?Functor.Composition.Laws.associativity_fst; try reflexivity. (* The following helpers were generated with << intros. repeat match goal with | [ |- context[idtoiso ?C (?f ?x)] ] => generalize (f x); intro | [ |- context[MorphismOf ?F ?f] ] => generalize dependent (MorphismOf F f); repeat (let x := fresh "x" in intro x) | [ |- context[ObjectOf ?F ?f] ] => generalize dependent (ObjectOf F f); repeat (let x := fresh "x" in intro x) end. simpl in *. unfold SubPreCatCat. simpl in *. clear. destruct_head_hnf @sig. simpl in *. repeat match goal with | [ H : _ |- _ ] => revert H end. intros H P. >> *) Lemma pseudofunctor_of_functor__composition_of {x0 x1 x2 x : PreCategory} {x7 x11 : Functor x0 x1} {x12 : x7 = x11} {x6 : Functor x0 x2} {x9 : Functor x2 x1} {x14 : x11 = (x9 o x6)%functor} {x4 : Functor x0 x} {x5 : Functor x x1} {x8 : x7 = (x5 o x4)%functor} {x10 : Functor x x2} {x13 : x6 = (x10 o x4)%functor} {x15 : x5 = (x9 o x10)%functor} (H0' : P x0) (H1' : P x1) (H2' : P x2) (H' : P x) : ((associator_1 x9 x10 x4) o ((idtoiso (x -> x1) x15 : morphism _ _ _) oR x4 o (idtoiso (x0 -> x1) x8 : morphism _ _ _)))%natural_transformation = (x9 oL (idtoiso (x0 -> x2) x13 : morphism _ _ _) o ((idtoiso (x0 -> x1) x14 : morphism _ _ _) o (idtoiso (x0 -> x1) x12 : morphism _ _ _)))%natural_transformation. Proof. clear F. symmetry; simpl; pseudofunctor_t. Qed. Lemma pseudofunctor_of_functor__left_identity_of {x0 x : PreCategory} {x2 : Functor x x} {x3 : x2 = 1%functor} {x4 x5 : Functor x0 x} {x6 : x4 = x5} {x7 : x4 = (x2 o x5)%functor} (H0' : P x0) (H' : P x) : ((Category.Morphisms.idtoiso (x -> x) x3 : morphism _ _ _) oR x5 o (Category.Morphisms.idtoiso (x0 -> x) x7 : morphism _ _ _))%natural_transformation = ((NaturalTransformation.Composition.Laws.left_identity_natural_transformation_2 x5) o (Category.Morphisms.idtoiso (x0 -> x) x6 : morphism _ _ _))%natural_transformation. Proof. clear F. simpl; pseudofunctor_t. Qed. Lemma pseudofunctor_of_functor__right_identity_of {x0 x : PreCategory} {x4 : Functor x0 x0} {x5 : x4 = 1%functor} {x2 x3 : Functor x0 x} {x6 : x2 = x3} {x7 : x2 = (x3 o x4)%functor} (H0' : P x0) (H' : P x) : (x3 oL (Category.Morphisms.idtoiso (x0 -> x0) x5 : morphism _ _ _) o (Category.Morphisms.idtoiso (x0 -> x) x7 : morphism _ _ _))%natural_transformation = ((NaturalTransformation.Composition.Laws.right_identity_natural_transformation_2 x3) o (Category.Morphisms.idtoiso (x0 -> x) x6 : morphism _ _ _))%natural_transformation. Proof. clear F. simpl; pseudofunctor_t. Qed. Definition pseudofunctor_of_functor : Pseudofunctor C := Build_Pseudofunctor C (fun x => pr1 (F x)) (fun s d m => F _1 m) (fun s d d' m0 m1 => Category.Morphisms.idtoiso (_ -> _) (composition_of F _ _ _ m1 m0)) (fun x => Category.Morphisms.idtoiso (_ -> _) (identity_of F x)) (fun w x y z _ _ _ => pseudofunctor_of_functor__composition_of (F w).2 (F z).2 (F y).2 (F x).2) (fun x y _ => pseudofunctor_of_functor__left_identity_of (F x).2 (F y).2) (fun x y _ => pseudofunctor_of_functor__right_identity_of (F x).2 (F y).2). End of_functor. Definition FunctorToCat `{Funext} {C} `{HP : forall C D, P C -> P D -> IsHSet (Functor C D)} := Functor C (@sub_pre_cat _ P HP). Identity Coercion functor_to_cat_id : FunctorToCat >-> Functor. Definition pseudofunctor_of_functor_to_cat `(F : @FunctorToCat H C P HP) := @pseudofunctor_of_functor _ C P HP F. Coq-HoTT-9.0/theories/Categories/Pseudofunctor/Identity.v000066400000000000000000000052631474641544500234730ustar00rootroot00000000000000(** * Identity pseudofunctor *) Require Import FunctorCategory.Morphisms. Require Import Category.Core Functor.Core. Require Import NaturalTransformation.Isomorphisms. Require Import NaturalTransformation.Paths. Require Import Cat.Core. Require Import Pseudofunctor.Core. (** Bring things into scope. *) Import NaturalTransformation.Identity. Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws. Import Category.Morphisms. Import FunctorCategory.Core. Require Import PathGroupoids. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope natural_transformation_scope. Section identity. Context `{Funext}. Variable P : PreCategory -> Type. Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}. Local Notation cat := (@sub_pre_cat _ P HF). Local Ltac t := path_natural_transformation; abstract ( autorewrite with functor morphism; unfold morphism_isomorphic; rewrite ap_idmap, idtoiso_components_of; rewrite ?Functor.Composition.Laws.associativity_fst, ?Functor.Composition.Laws.left_identity_fst, ?Functor.Composition.Laws.right_identity_fst; reflexivity ). Lemma identity_associativity (w x y z : PreCategory) (f : Functor w x) (g : Functor x y) (h : Functor y z) : associator_1 h g f o (1 oR f o 1) = h oL 1 o (1 o @morphism_isomorphic _ _ _ (idtoiso (w -> z) (ap idmap (Functor.Composition.Laws.associativity f g h)))). Proof. t. Defined. Lemma identity_left_identity (x y : PreCategory) (f : Functor x y) : 1 oR f o 1 = (left_identity_natural_transformation_2 f) o @morphism_isomorphic _ _ _ (idtoiso (x -> y) (ap idmap (Functor.Composition.Laws.left_identity f))). Proof. t. Defined. Lemma identity_right_identity (x y : PreCategory) (f : Functor x y) : f oL 1 o 1 = (right_identity_natural_transformation_2 f) o @morphism_isomorphic _ _ _ (idtoiso (x -> y) (ap idmap (Functor.Composition.Laws.right_identity f))). Proof. t. Defined. (** There is an identity pseudofunctor. It does the obvious thing. *) Definition identity : Pseudofunctor cat := Build_Pseudofunctor cat (fun C => C.1) (fun _ _ F => F) (fun _ _ _ _ _ => reflexivity _) (fun _ => reflexivity _) (fun x y z w => @identity_associativity x.1 y.1 z.1 w.1) (fun x y => @identity_left_identity x.1 y.1) (fun x y => @identity_right_identity x.1 y.1). End identity. Module Export PseudofunctorIdentityNotations. Notation "1" := (identity _) : pseudofunctor_scope. End PseudofunctorIdentityNotations. Coq-HoTT-9.0/theories/Categories/Pseudofunctor/RewriteLaws.v000066400000000000000000000217251474641544500241530ustar00rootroot00000000000000(** * Pseudofunctor rewriting helper lemmas *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Category.Morphisms FunctorCategory.Morphisms. Require Import Functor.Composition.Core. Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws. Require Import NaturalTransformation.Isomorphisms. Require Import NaturalTransformation.Paths. Require Import FunctorCategory.Core. Require Import Pseudofunctor.Core. Require Import HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section lemmas. Local Open Scope natural_transformation_scope. Context `{Funext}. Variable C : PreCategory. Variable F : Pseudofunctor C. Lemma p_composition_of_coherent_for_rewrite_helper w x y z (f : morphism C w x) (g : morphism C x y) (h : morphism C y z) (p p0 p1 p2 : PreCategory) (f0 : morphism C w z -> Functor p2 p1) (f1 : Functor p0 p1) (f2 : Functor p2 p) (f3 : Functor p p0) (f4 : Functor p2 p0) `(@IsIsomorphism (_ -> _) f4 (f3 o f2)%functor n) `(@IsIsomorphism (_ -> _) (f0 (h o (g o f))%morphism) (f1 o f4)%functor n0) : @paths (NaturalTransformation _ _) (@morphism_isomorphic _ _ _ (Category.Morphisms.idtoiso (p2 -> p1) (ap f0 (Category.Core.associativity C w x y z f g h)))) (n0^-1 o ((f1 oL n^-1) o ((f1 oL n) o (n0 o (@morphism_isomorphic _ _ _ (Category.Morphisms.idtoiso (p2 -> p1) (ap f0 (Category.Core.associativity C w x y z f g h))))))))%natural_transformation. Proof. simpl in *. let C := match goal with |- @paths (@NaturalTransformation ?C ?D ?F ?G) _ _ => constr:((C -> D)%category) end in apply (@iso_moveL_Vp C); apply (@iso_moveL_Mp C _ _ _ _ _ _ (iso_whisker_l _ _ _ _ _ _ _)). path_natural_transformation. reflexivity. Qed. Arguments p_composition_of_coherent_for_rewrite_helper {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. Section helper. Context {w x y z} {f : Functor (F w) (F z)} {f0 : Functor (F w) (F y)} {f1 : Functor (F x) (F y)} {f2 : Functor (F y) (F z)} {f3 : Functor (F w) (F x)} {f4 : Functor (F x) (F z)} {f5 : Functor (F w) (F z)} {n : f5 <~=~> (f4 o f3)%functor} {n0 : f4 <~=~> (f2 o f1)%functor} {n1 : f0 <~=~> (f1 o f3)%functor} {n2 : f <~=~> (f2 o f0)%functor}. Lemma p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper' : @IsIsomorphism (_ -> _) _ _ (n2 ^-1 o (f2 oL n1 ^-1 o (associator_1 f2 f1 f3 o (n0 oR f3 o n))))%natural_transformation. Proof. eapply isisomorphism_compose; [ eapply isisomorphism_inverse | eapply isisomorphism_compose; [ eapply iso_whisker_l; eapply isisomorphism_inverse | eapply isisomorphism_compose; [ typeclasses eauto | eapply isisomorphism_compose; [ eapply iso_whisker_r; typeclasses eauto | typeclasses eauto ] ] ] ]. Defined. Definition p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper := Eval hnf in p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper'. Local Arguments p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper / . Let inv := Eval simpl in @morphism_inverse _ _ _ _ p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper. Definition p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper__to_inverse X (H' : X = @Build_Isomorphic (_ -> _) _ _ _ p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper) : @morphism_inverse _ _ _ _ X = inv := ap (fun i => @morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ i)) H'. End helper. Lemma p_composition_of_coherent_iso_for_rewrite w x y z (f : morphism C w x) (g : morphism C x y) (h : morphism C y z) : (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ F w z) (Category.Core.associativity C w x y z f g h))) = @Build_Isomorphic (_ -> _) _ _ ((((p_composition_of F w y z h (g o f))^-1) o ((p_morphism_of F h oL (p_composition_of F w x y g f)^-1) o ((associator_1 (p_morphism_of F h) (p_morphism_of F g) (p_morphism_of F f)) o ((p_composition_of F x y z h g oR p_morphism_of F f) o p_composition_of F w x z (h o g) f)))))%natural_transformation p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper. Proof. apply path_isomorphic; simpl. simpl rewrite (@p_composition_of_coherent _ C F w x y z f g h). exact p_composition_of_coherent_for_rewrite_helper. Qed. Lemma p_left_identity_of_coherent_iso_for_rewrite x y (f : morphism C x y) : (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ F x y) (Category.Core.left_identity C x y f))) = @Build_Isomorphic (_ -> _) _ _ ((left_identity_natural_transformation_1 (p_morphism_of F f)) o ((p_identity_of F y oR p_morphism_of F f) o p_composition_of F x y y 1 f))%natural_transformation _. Proof. apply path_isomorphic; simpl. simpl rewrite (@p_left_identity_of_coherent _ C F x y f). path_natural_transformation. symmetry. etransitivity; apply Category.Core.left_identity. Qed. Lemma p_right_identity_of_coherent_iso_for_rewrite x y (f : morphism C x y) : (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ F x y) (Category.Core.right_identity C x y f))) = @Build_Isomorphic (_ -> _) _ _ ((right_identity_natural_transformation_1 (p_morphism_of F f)) o ((p_morphism_of F f oL p_identity_of F x) o p_composition_of F x x y f 1))%natural_transformation _. Proof. apply path_isomorphic; simpl. simpl rewrite (@p_right_identity_of_coherent _ C F x y f). path_natural_transformation. symmetry. etransitivity; apply Category.Core.left_identity. Qed. Local Notation typeof x := ((fun T (_ : T) => T) _ x) (only parsing). Let p_composition_of_coherent_for_rewrite_type w x y z f g h := Eval simpl in typeof (ap (@morphism_isomorphic _ _ _) (@p_composition_of_coherent_iso_for_rewrite w x y z f g h)). Definition p_composition_of_coherent_for_rewrite w x y z f g h : p_composition_of_coherent_for_rewrite_type w x y z f g h := ap (@morphism_isomorphic _ _ _) (@p_composition_of_coherent_iso_for_rewrite w x y z f g h). Let p_composition_of_coherent_inverse_for_rewrite_type w x y z f g h := Eval simpl in typeof (ap (fun i => @morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ i)) (@p_composition_of_coherent_iso_for_rewrite w x y z f g h)). Definition p_composition_of_coherent_inverse_for_rewrite w x y z f g h : p_composition_of_coherent_inverse_for_rewrite_type w x y z f g h := p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper__to_inverse (p_composition_of_coherent_iso_for_rewrite w x y z f g h). Let p_left_identity_of_coherent_for_rewrite_type x y f := Eval simpl in typeof (ap (@morphism_isomorphic _ _ _) (@p_left_identity_of_coherent_iso_for_rewrite x y f)). Definition p_left_identity_of_coherent_for_rewrite x y f : p_left_identity_of_coherent_for_rewrite_type x y f := ap (@morphism_isomorphic _ _ _) (@p_left_identity_of_coherent_iso_for_rewrite x y f). Let p_left_identity_of_coherent_inverse_for_rewrite_type x y f := Eval simpl in typeof (ap (fun i => @morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ i)) (@p_left_identity_of_coherent_iso_for_rewrite x y f)). Definition p_left_identity_of_coherent_inverse_for_rewrite x y f : p_left_identity_of_coherent_inverse_for_rewrite_type x y f := ap (fun i => @morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ i)) (@p_left_identity_of_coherent_iso_for_rewrite x y f). Let p_right_identity_of_coherent_for_rewrite_type x y f := Eval simpl in typeof (ap (@morphism_isomorphic _ _ _) (@p_right_identity_of_coherent_iso_for_rewrite x y f)). Definition p_right_identity_of_coherent_for_rewrite x y f : p_right_identity_of_coherent_for_rewrite_type x y f := Eval simpl in ap (@morphism_isomorphic _ _ _) (@p_right_identity_of_coherent_iso_for_rewrite x y f). Let p_right_identity_of_coherent_inverse_for_rewrite_type x y f := Eval simpl in typeof (ap (fun i => @morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ i)) (@p_right_identity_of_coherent_iso_for_rewrite x y f)). Definition p_right_identity_of_coherent_inverse_for_rewrite x y f : p_right_identity_of_coherent_inverse_for_rewrite_type x y f := ap (fun i => @morphism_inverse _ _ _ _ (@isisomorphism_isomorphic _ _ _ i)) (@p_right_identity_of_coherent_iso_for_rewrite x y f). End lemmas. Coq-HoTT-9.0/theories/Categories/PseudonaturalTransformation.v000066400000000000000000000002631474641544500246120ustar00rootroot00000000000000(** * Pseudonatural Transformations *) (** ** Definition of pseudonatural transformations *) Require PseudonaturalTransformation.Core. Include PseudonaturalTransformation.Core. Coq-HoTT-9.0/theories/Categories/PseudonaturalTransformation/000077500000000000000000000000001474641544500244225ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/PseudonaturalTransformation/Core.v000066400000000000000000000215201474641544500255010ustar00rootroot00000000000000(** * Definition of pseudonatural transformation *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Pseudofunctor.Core. Require Import Category.Morphisms FunctorCategory.Morphisms. Require Import Functor.Composition.Core. Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws. Require Import NaturalTransformation.Identity. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Declare Scope pseudonatural_transformation_scope. Delimit Scope pseudonatural_transformation_scope with pseudonatural_transformation. Local Open Scope natural_transformation_scope. Local Open Scope functor_scope. Local Open Scope morphism_scope. Local Open Scope pseudonatural_transformation_scope. (** Quoting Michael Shulman from an email: The 2-limit in question is sometimes called a "descent object", or the totalization of a truncated cosimplicial object. It's a generalization of an equalizer. The set of natural transformations between two ordinary functors [F],[G : C → D] is the equalizer of [Π_x D(Fx,Gx) ⇉ Π_{x→y} D(Fx,Gy)] The category of pseudonatural transformations between two 2-functors is the descent object of [Π_x D(Fx,Gx) ⇉ Π_{x→y} D(Fx,Gy) ⇛ Π_{x→y→z} D(Fx,Gz)] where there are three maps from the second product to the third, corresponding to picking out [x→y], [y→z], and [x→z]. In general, the descent object of [A ⇉ B ⇛ C] is the category of objects [a∈A] equipped with an isomorphism between their two images in [B] which results in a commutative triangle between their three images in [C]. *) (** Later, he said (https://github.com/HoTT/HoTT/pull/382##issuecomment-41240787): The "naturality" axiom is only necessary if the domain is a 2-category rather than a 1-category. However, the respect for units axiom really is necessary; I guess I forgot to mention that in the email. The way it comes up in the descent object is that there's a map from [B] to [A] given by projecting the components of identities, and the coherence cell has to become an identity when composed with that map. *) (** We construct the parts as above, but inline the resulting definitions for speed. << Module PseudonaturalTransformationParts. Section PseudonaturalTransformation. Context `{Funext}. Variable X : PreCategory. Variables F G : Pseudofunctor X. Definition A : PreCategory := (forall x : X, F x -> G x)%category. Definition B : PreCategory := (forall x y (m : morphism X x y), F x -> G y)%category. Definition C : PreCategory := (forall x y z (m1 : morphism X y z) (m2 : morphism X x y), F x -> G z)%category. Definition a_part := Eval simpl in object A. Definition A_to_B_1 : Functor A B. Proof. refine (Build_Functor A B (fun x__Fx_to_Gx => fun x y m => x__Fx_to_Gx y o p_morphism_of F m)%functor (fun x__s x__d x__m => fun x y m => x__m y oR p_morphism_of F m) _ _); simpl; repeat (intro || apply path_forall); [ apply composition_of_whisker_r | apply whisker_r_left_identity ]. Defined. Definition A_to_B_2 : Functor A B. Proof. refine (Build_Functor A B (fun x__Fx_to_Gx => fun x y m => p_morphism_of G m o x__Fx_to_Gx x)%functor (fun x__s x__d x__m => fun x y m => p_morphism_of G m oL x__m x) _ _); simpl; repeat (intro || apply path_forall); [ apply composition_of_whisker_l | apply whisker_l_right_identity ]. Defined. Definition b_part (a : a_part) := Eval simpl in forall x y m, (A_to_B_1 a x y m <~=~> A_to_B_2 a x y m). Definition B_to_A : Functor B A := Build_Functor B A (fun xym__Fx_to_Gy => fun x => xym__Fx_to_Gy x x 1) (fun x__s x__d x__m => fun x => x__m x x 1) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition b_id_part (a : a_part) (b : b_part a) := Eval simpl in forall x, (((left_identity_natural_transformation_1 _) o (p_identity_of G _ oR _) o (B_to_A _1 b x) o (_ oL (p_identity_of F _)^-1) o (left_identity_natural_transformation_2 _)) = 1)%natural_transformation. Definition B_to_C_1 : Functor B C. Proof. refine (Build_Functor B C (fun xym__Fx_to_Gy => fun x y z m1 m2 => xym__Fx_to_Gy y z m1 o p_morphism_of F m2)%functor (fun xym__s xym__d xym__m => fun x y z m1 m2 => xym__m y z m1 oR p_morphism_of F m2) _ _); simpl; repeat (intro || apply path_forall); [ apply composition_of_whisker_r | apply whisker_r_left_identity ]. Defined. Definition B_to_C_2 : Functor B C. Proof. refine (Build_Functor B C (fun xym__Fx_to_Gy => fun x y z m1 m2 => p_morphism_of G m1 o xym__Fx_to_Gy x y m2)%functor (fun xym__s xym__d xym__m => fun x y z m1 m2 => p_morphism_of G m1 oL xym__m x y m2) _ _); simpl; repeat (intro || apply path_forall); [ apply composition_of_whisker_l | apply whisker_l_right_identity ]. Defined. Definition B_to_C_3 : Functor B C := Build_Functor B C (fun xym__Fx_to_Gy => fun x y z m1 m2 => xym__Fx_to_Gy x z (m1 o m2)) (fun xym__s xym__d xym__m => fun x y z m1 m2 => xym__m x z (m1 o m2)) (fun _ _ _ _ _ => idpath) (fun _ => idpath). Definition c_part' (a : a_part) (b : b_part a) : forall (x y z : X) (m1 : morphism X y z) (m2 : morphism X x y), Type. Proof. hnf in a, b. pose (fun x y m => (b x y m : morphism _ _ _)) as bB; simpl in *. intros x y z m1 m2. exact (((associator_2 _ _ _) o (B_to_C_2 _1 bB x y z m1 m2) o (associator_1 _ _ _) o (B_to_C_1 _1 bB x y z m1 m2) o (associator_2 _ _ _)) = ((p_composition_of G _ _ _ m1 m2 oR _) o (B_to_C_3 _1 bB x y z m1 m2) o (_ oL (p_composition_of F _ _ _ m1 m2)^-1)))%natural_transformation. Defined. Arguments c_part' / . Definition c_part (a : a_part) (b : b_part a) := Eval simpl in forall x y z m1 m2, @c_part' a b x y z m1 m2. (** We would like to define [PseudonaturalTransformation] here, then our types are η-expanded. *) (*Record PseudonaturalTransformation := { p_components_of :> a_part; p_commutes : b_part p_components_of; p_commutes_coherent : c_part p_commutes }.*) End PseudonaturalTransformation. End PseudonaturalTransformationParts. Print PseudonaturalTransformationParts.a_part. Print PseudonaturalTransformationParts.b_part. Print PseudonaturalTransformationParts.b_id_part. Print PseudonaturalTransformationParts.c_part. >> *) Record PseudonaturalTransformation `{Funext} (X : PreCategory) (F G : Pseudofunctor X) := { p_components_of :> forall a : X, Functor (F a) (G a); p_commutes : forall (x y : X) (m : morphism X x y), ((p_components_of y o p_morphism_of F m)%functor <~=~> (p_morphism_of G m o p_components_of x)%functor)%natural_transformation; p_commutes_respects_identity : forall x : X, ((left_identity_natural_transformation_1 (p_components_of x)) o (p_identity_of G x oR p_components_of x) o (p_commutes x x 1%morphism) o (p_components_of x oL (p_identity_of F x) ^-1) o (right_identity_natural_transformation_2 (p_components_of x)) = 1)%natural_transformation; p_commutes_respects_composition : forall (x y z : X) (m1 : morphism X y z) (m2 : morphism X x y), (((associator_2 (p_morphism_of G m1) (p_morphism_of G m2) (p_components_of x)) o (p_morphism_of G m1 oL p_commutes x y m2) o (associator_1 (p_morphism_of G m1) (p_components_of y) (p_morphism_of F m2)) o (p_commutes y z m1 oR p_morphism_of F m2) o (associator_2 (p_components_of z) (p_morphism_of F m1) (p_morphism_of F m2))) = ((p_composition_of G x y z m1 m2 oR p_components_of x o p_commutes x z (m1 o m2)%morphism) o (p_components_of z oL (p_composition_of F x y z m1 m2) ^-1)))%natural_transformation }. Bind Scope pseudonatural_transformation_scope with PseudonaturalTransformation. Create HintDb pseuodnatural_transformation discriminated. Arguments p_components_of {_} {X}%_category {F G}%_pseudofunctor T%_pseudonatural_transformation a%_object : rename, simpl nomatch. #[export] Hint Resolve p_commutes_respects_identity p_commutes_respects_composition : category pseudonatural_transformation. Coq-HoTT-9.0/theories/Categories/SemiSimplicialSets.v000066400000000000000000000031061474641544500225770ustar00rootroot00000000000000(** * The category of semisimplicial sets *) Require Import Types Basics.Trunc. Require Import Category.Core Functor.Core. Require Import Category.Morphisms. Require Import Category.Dual FunctorCategory.Core. Require Import SetCategory.Core. Require Import SimplicialSets. Require Import Category.Sigma.OnMorphisms Category.Subcategory.Wide. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Module Export Core. Section semisimplicial_sets. Context `{Funext}. (** Quoting David Spivak: Consider the subcategory of [Δ] with the same objects (wide) but only injective morphisms. If we call that [Γ] (which is nonstandard), then semi-simplicial sets (also a non-standard term) (sic) are [Fun(Γᵒᵖ, Set)]. Define the obvious inclusion [Γ -> Δ], which we will use to make simplicial sets without having to worry about "degeneracies". *) Definition semisimplex_category : PreCategory := wide simplex_category (@IsMonomorphism _) _ _ _. Definition semisimplicial_inclusion_functor : semisimplex_category -> simplex_category := pr1_mor. Definition semisimplicial_category (C : PreCategory) : PreCategory := semisimplex_category^op -> C. Definition semisimplicial_set := semisimplicial_category set_cat. Definition semisimplicial_prop := semisimplicial_category prop_cat. End semisimplicial_sets. Notation semisimplicial_of obj := (semisimplicial_category (cat_of obj)). End Core. Coq-HoTT-9.0/theories/Categories/SetCategory.v000066400000000000000000000012431474641544500212650ustar00rootroot00000000000000(** * Category of sets *) (** ** Definitoins of [set_cat] and [prop_cat] *) Require SetCategory.Core. (** ** Morphisms in the category of sets *) Require SetCategory.Morphisms. (** If there were a [SetCategory.Functors.Core], we'd [Include] it here. *) Include SetCategory.Core. Include SetCategory.Morphisms. (** ** Functors to/from the category of sets *) (** Since [Functors] is a separate sub-directory, we need to re-create the module structure. Alas, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *) Require SetCategory.Functors. Coq-HoTT-9.0/theories/Categories/SetCategory/000077500000000000000000000000001474641544500210765ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/SetCategory/Core.v000066400000000000000000000021541474641544500221570ustar00rootroot00000000000000(** * PreCategories [set_cat] and [prop_cat] *) Require Import Category.Strict. Require Import HoTT.Basics HoTT.Types TruncType. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Notation cat_of obj := (@Build_PreCategory obj (fun x y => x -> y) (fun _ x => x) (fun _ _ _ f g => f o g)%core (fun _ _ _ _ _ _ _ => idpath) (fun _ _ _ => idpath) (fun _ _ _ => idpath) _). (** There is a category [Set], where the objects are sets and the morphisms are set morphisms *) Definition prop_cat `{Funext} : PreCategory := cat_of HProp. Definition set_cat `{Funext} : PreCategory := cat_of HSet. (** ** [Prop] is a strict category *) Global Instance isstrict_prop_cat `{Univalence} : IsStrictCategory prop_cat := _. (** Because, e.g., [@identity set_cat x ≡ x], and we want [rewrite] to notice this, we must inform it that it can try treating [identity] as [idmap]. *) Declare Equivalent Keys identity idmap. Coq-HoTT-9.0/theories/Categories/SetCategory/Functors.v000066400000000000000000000002041474641544500230640ustar00rootroot00000000000000(** * Functors between [set_cat] and [prop_cat] *) Require SetCategory.Functors.SetProp. Include SetCategory.Functors.SetProp. Coq-HoTT-9.0/theories/Categories/SetCategory/Functors/000077500000000000000000000000001474641544500227015ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/SetCategory/Functors/SetProp.v000066400000000000000000000041151474641544500244650ustar00rootroot00000000000000(** * Functors between [set_cat] and [prop_cat] *) Require Import Category.Core Functor.Core SetCategory.Core. Require Import Basics.Trunc. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Section set_coercions_definitions. Context `{Funext}. Variable C : PreCategory. Definition to_prop := Functor C prop_cat. Definition to_set := Functor C set_cat. Definition from_prop := Functor prop_cat C. Definition from_set := Functor set_cat C. End set_coercions_definitions. Identity Coercion to_prop_id : to_prop >-> Functor. Identity Coercion to_set_id : to_set >-> Functor. Identity Coercion from_prop_id : from_prop >-> Functor. Identity Coercion from_set_id : from_set >-> Functor. Section set_coercions. Context `{Funext}. Variable C : PreCategory. (** ** Functors to [prop_cat] give rise to functors to [set_cat] *) Definition to_prop2set (F : to_prop C) : to_set C := Build_Functor C set_cat (fun x => Build_HSet (F x)) (fun s d m => (F _1 m)%morphism) (fun s d d' m m' => composition_of F s d d' m m') (fun x => identity_of F x). (** ** Functors from [set_cat] give rise to functors to [prop_cat] *) Definition from_set2prop (F : from_set C) : from_prop C := Build_Functor prop_cat C (fun x => F (Build_HSet x)) (fun s d m => (F _1 (m : morphism set_cat (Build_HSet s) (Build_HSet d)))%morphism) (fun s d d' m m' => composition_of F (Build_HSet s) (Build_HSet d) (Build_HSet d') m m') (fun x => identity_of F (Build_HSet x)). End set_coercions. Coq-HoTT-9.0/theories/Categories/SetCategory/Morphisms.v000066400000000000000000000110201474641544500232400ustar00rootroot00000000000000(** * Morphisms in [set_cat] *) Require Import Category.Core NaturalTransformation.Core. Require Import Category.Morphisms NaturalTransformation.Paths. Require Import Category.Univalent. Require Import SetCategory.Core. Require Import HoTT.Basics HoTT.Types TruncType. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope morphism_scope. Local Open Scope category_scope. Lemma isisomorphism_set_cat_natural_transformation_paths `{fs : Funext} (X : set_cat) C D F G (T1 T2 : morphism set_cat X (Build_HSet (@NaturalTransformation C D F G))) (H : forall x y, T1 x y = T2 x y) `{@IsIsomorphism set_cat _ _ T1} : @IsIsomorphism set_cat _ _ T2. Proof. exists (T1^-1)%morphism; abstract ( first [ apply @iso_moveR_Vp | apply @iso_moveR_pV ]; repeat first [ intro | solve [ auto | symmetry; auto ] | apply @path_forall | path_natural_transformation ] ). Defined. Section equiv_iso_set_cat. (** ** Isomorphisms in [set_cat] are eqivalent to equivalences. *) Context `{Funext}. Definition isiso_isequiv s d (m : morphism set_cat s d) `{IsEquiv _ _ m} : IsIsomorphism m := Build_IsIsomorphism set_cat s d m m^-1%function (path_forall _ _ (eissect m)) (path_forall _ _ (eisretr m)). Definition isequiv_isiso s d (m : morphism set_cat s d) `{IsIsomorphism _ _ _ m} : IsEquiv m := Build_IsEquiv _ _ m m^-1%morphism (ap10 right_inverse) (ap10 left_inverse) (fun _ => path_ishprop _ _). Definition iso_equiv (s d : set_cat) (m : s <~> d) : s <~=~> d := Build_Isomorphic (@isiso_isequiv s d m _). Global Instance isequiv_isiso_isequiv s d : IsEquiv (@iso_equiv s d) | 0. Proof. refine (isequiv_adjointify (@iso_equiv s d) (fun m => Build_Equiv _ _ _ (@isequiv_isiso s d m m)) _ _); simpl in *; clear; abstract ( intros [? ?]; simpl; unfold iso_equiv; simpl; apply ap; apply path_ishprop ). Defined. Lemma path_idtoequiv_idtoiso (s d : set_cat) (p : s = d) : iso_equiv s d (equiv_path _ _ (ap trunctype_type p)) = idtoiso set_cat p. Proof. apply path_isomorphic. case p. reflexivity. Defined. End equiv_iso_set_cat. Section equiv_iso_prop_cat. (** ** Isomorphisms in [prop_cat] are eqivalent to equivalences. *) Context `{Funext}. Definition isiso_isequiv_prop s d (m : morphism prop_cat s d) `{IsEquiv _ _ m} : IsIsomorphism m := Build_IsIsomorphism prop_cat s d m m^-1%function (path_forall _ _ (eissect m)) (path_forall _ _ (eisretr m)). Definition isequiv_isiso_prop s d (m : morphism prop_cat s d) `{IsIsomorphism _ _ _ m} : IsEquiv m := Build_IsEquiv _ _ m m^-1%morphism (ap10 right_inverse) (ap10 left_inverse) (fun _ => path_ishprop _ _). Definition iso_equiv_prop (s d : prop_cat) (m : s <~> d) : s <~=~> d := Build_Isomorphic (@isiso_isequiv_prop s d m _). Global Instance isequiv_isiso_isequiv_prop s d : IsEquiv (@iso_equiv_prop s d) | 0. Proof. refine (isequiv_adjointify (@iso_equiv_prop s d) (fun m => Build_Equiv _ _ _ (@isequiv_isiso_prop s d m _)) _ _); simpl in *; clear; abstract ( intros [? ?]; simpl; unfold iso_equiv_prop; simpl; apply ap; apply path_ishprop ). Defined. Lemma path_idtoequiv_idtoiso_prop (s d : prop_cat) (p : s = d) : iso_equiv_prop s d (equiv_path _ _ (ap trunctype_type p)) = idtoiso prop_cat p. Proof. apply path_isomorphic. case p. reflexivity. Defined. End equiv_iso_prop_cat. Local Close Scope morphism_scope. Global Instance iscategory_set_cat `{Univalence} : IsCategory set_cat. Proof. intros C D. eapply @isequiv_homotopic; [ | intro; apply path_idtoequiv_idtoiso ]. change (IsEquiv (iso_equiv C D o equiv_path C D o @ap _ _ trunctype_type C D)). typeclasses eauto. Defined. Global Instance iscategory_prop_cat `{Univalence} : IsCategory prop_cat. Proof. intros C D. eapply @isequiv_homotopic; [ | intro; apply path_idtoequiv_idtoiso_prop ]. change (IsEquiv (iso_equiv_prop C D o equiv_path C D o @ap _ _ trunctype_type C D)). typeclasses eauto. Defined. Coq-HoTT-9.0/theories/Categories/SimplicialSets.v000066400000000000000000000035751474641544500217730ustar00rootroot00000000000000(** * The simplex category Δ, and the precategory of simplicial sets, [Δᵒᵖ → set] *) Require Import Basics Types Spaces.Nat.Core. Require Import Category.Core Functor.Core Functor.Paths. Require Import SetCategory.Core. Require Import ChainCategory FunctorCategory.Core. Require Import Category.Dual. Require Import Functor.Identity Functor.Composition.Core Functor.Composition.Laws. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope functor_scope. Local Open Scope category_scope. (** We define the precategory Δ of simplexes, or finite non-empty linear orders *) Module Export Core. Section simplicial_sets. Context `{Funext}. (** We say that the objects of Δ are natural numbers, where a number [n] is morally considered as the canonical [n]-simplex, a finite linear order on [n + 1] elements. By declaring [chain] to be a local coercion from [nat] to [PreCategory], we can rely on on-the-fly eta-expansion to make this moral consideration a reality, telling Coq that it can unify, for example, [nat -> nat -> Type] with [PreCategory -> PreCategory -> Type] by silently inserting [chain]. *) Local Coercion chain : nat >-> PreCategory. Definition simplex_category := @Build_PreCategory nat Functor identity compose associativity left_identity right_identity _. Definition simplicial_category (C : PreCategory) : PreCategory := simplex_category^op -> C. Definition simplicial_set := simplicial_category set_cat. Definition simplicial_prop := simplicial_category prop_cat. End simplicial_sets. Notation simplicial_of obj := (simplicial_category (cat_of obj)). End Core. Module Utf8. Notation Δ := simplex_category. End Utf8. Coq-HoTT-9.0/theories/Categories/Structure.v000066400000000000000000000005151474641544500210350ustar00rootroot00000000000000(** Since there are only notations in [Structure.Notations], we can just export those. *) Require Export Structure.Notations. Require Structure.Core. Require Structure.IdentityPrinciple. Include Structure.Core. Include Structure.IdentityPrinciple. (** We don't want to make utf-8 notations the default, so we don't export them. *) Coq-HoTT-9.0/theories/Categories/Structure/000077500000000000000000000000001474641544500206455ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Categories/Structure/Core.v000066400000000000000000000216061474641544500217310ustar00rootroot00000000000000(** * Notions of Structure *) Require Import Category.Core. Require Import HoTT.Basics HoTT.Types HSet. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope category_scope. Local Open Scope morphism_scope. (** * Structures *) Declare Scope structure_scope. Declare Scope long_structure_scope. Delimit Scope structure_scope with structure. Delimit Scope long_structure_scope with long_structure. Local Open Scope structure_scope. (** Quoting the Homotopy Type Theory Book (with slight changes for notational consistency): *) (** ** 9.8 The structure identity principle The _structure identity principle_ is an informal principle that expresses that isomorphic structures are identical. We aim to prove a general abstract result which can be applied to a wide family of notions of structure, where structures may be many-sorted or even dependently-sorted, in-finitary, or even higher order. The simplest kind of single-sorted structure consists of a type with no additional structure. The univalence axiom expresses the structure identity principle for that notion of structure in a strong form: for types [A], [B], the canonical function [(A = B) → (A ≃ B)] is an equivalence. We start with a precategory [X]. In our application to single-sorted first order structures, [X] will be the category of [U]-small sets, where [U] is a univalent type universe. *) (** *** Notion of Structure *) (** Definition: A _notion of structure_ [(P,H)] over [X] consists of the following. We use [X₀] to denote the objects of [X], and [homₓ(x, y)] to denote the morphisms [morphism X x y] of [X]. (i) A type family [P : X₀ → Type]. For each [x : X₀] the elements of [P x] are called _[(P, H)]-structures_ on [x]. (ii) For [x y : X₀] and [α : P x], [β : P y], to each [f : homₓ(x, y)] a mere proposition [H_{αβ}(f)]. If [H_{αβ}(f)] is true, we say that [f] is a _[(P, H)]-homomorphism_ from [α] to [β]. (iii) For [x : X₀] and [α : P x], we have [H_{αα}(1ₓ)]. (iv) For [x y z : X₀] and [α : P x], [β : P y], [γ : P z], if [f : homₓ(x, y)], we have [H_{αβ}(f)→ H_{βγ}(g) → H_{αγ}(g ∘ f)]. *) (** Note: We rearrange some parameters to [H] to ease Coq's unification engine and typeclass machinery. *) Record NotionOfStructure (X : PreCategory) := { structure :> X -> Type; is_structure_homomorphism : forall x y (f : morphism X x y) (a : structure x) (b : structure y), Type; istrunc_is_structure_homomorphism : forall x y a b f, IsHProp (@is_structure_homomorphism x y a b f); is_structure_homomorphism_identity : forall x (a : structure x), is_structure_homomorphism (identity x) a a; is_structure_homomorphism_composition : forall x y z (a : structure x) (b : structure y) (c : structure z) (f : morphism X x y) (g : morphism X y z), is_structure_homomorphism f a b -> is_structure_homomorphism g b c -> is_structure_homomorphism (g o f) a c }. (** It would be nice to make this a class, but we can't: << Existing Class is_structure_homomorphism. >> gives << Toplevel input, characters 0-41: Anomaly: Mismatched instance and context when building universe substitution. Please report. >> When we move to polyproj, it won't anymore. *) Global Existing Instance istrunc_is_structure_homomorphism. Create HintDb structure_homomorphisms discriminated. #[export] Hint Resolve is_structure_homomorphism_identity is_structure_homomorphism_composition : structure_homomorphisms. (** When [(P, H)] is a notion of structure, for [α β : P x] we define [(α ≤ₓ β) := H_{αβ}(1ₓ)]. *) Local Notation "a <=_{ x } b" := (is_structure_homomorphism _ x x (identity x) a b) : long_structure_scope. Local Notation "a <= b" := (a <=_{ _ } b)%long_structure : structure_scope. (** By (iii) and (iv), this is a preorder with [P x] its type of objects. *) (** *** Being a structure homomorphism is a preorder *) Global Instance preorder_is_structure_homomorphism X (P : NotionOfStructure X) x : PreOrder (is_structure_homomorphism P x x (identity x)). Proof. split; repeat intro; eauto with structure_homomorphisms. rewrite <- identity_identity. eauto with structure_homomorphisms. Defined. (** *** Standard notion of structure *) (** We say that [(P, H)] is a _standard notion of structure_ if this preorder is in fact a partial order, for all [x : X]. *) (** A partial order is an antisymmetric preorder, i.e., we must have [a <= b <= a -> a = b]. *) Class IsStandardNotionOfStructure X (P : NotionOfStructure X) := antisymmetry_structure : forall x (a b : P x), a <= b -> b <= a -> a = b. (** Note that for a standard notion of structure, each type [P x] must actually be a set. *) Global Instance istrunc_homomorphism_standard_notion_of_structure X P `{@IsStandardNotionOfStructure X P} x : IsHSet (P x). Proof. eapply (@ishset_hrel_subpaths _ (fun a b => (a <= b) * (b <= a))); try typeclasses eauto. - repeat intro; split; apply reflexivity. - intros ? ? [? ?]; apply antisymmetry_structure; assumption. Defined. (** *** Precategory of structures *) (** We now define, for any notion of structure [(P, H)], a _precategory of [(P, H)]-structures_, [A = Str_{(P, H)}(X)]. - The type of objects of [A] is the type [A₀ := ∑ₓ P x]. If [a ≡ (x; α)], we may write [|a| := x]. - For [(x; α) : A₀] and [(y; β) : A₀], we define [hom_A((x; α), (y; β)) := { f : x → y | H_{αβ}(f) }]. The composition and identities are inherited from [X]; conditions (iii) and (iv) ensure that these lift to [A]. *) Module PreCategoryOfStructures. Section precategory. (** We use [Records] because they are faster than sigma types. *) Variable X : PreCategory. Variable P : NotionOfStructure X. Local Notation object := { x : X | P x }. (*Lemma issig_object : { x : X | P x } <~> object. Proof. issig Build_object x a. Defined. Lemma path_object : forall xa yb (H : x xa = x yb), transport P H (a xa) = a yb -> xa = yb. Proof. intros [? ?] [? ?] H H'; simpl in *; path_induction; reflexivity. Defined.*) Record morphism (xa yb : object) := { f : Category.Core.morphism X xa.1 yb.1; h : is_structure_homomorphism _ _ _ f xa.2 yb.2 }. Lemma issig_morphism (xa yb : object) : { f : Category.Core.morphism X xa.1 yb.1 | is_structure_homomorphism _ _ _ f xa.2 yb.2 } <~> morphism xa yb. Proof. issig. Defined. Lemma path_morphism : forall xa yb (fh gi : morphism xa yb), f fh = f gi -> fh = gi. Proof. intros ? ? [? ?] [? ?] H; simpl in *; path_induction; apply ap. apply path_ishprop. Defined. End precategory. (*Global Arguments path_object {X P xa yb} H _.*) Global Arguments path_morphism {X P xa yb fh gi} H. End PreCategoryOfStructures. Section precategory. Import PreCategoryOfStructures. Definition precategory_of_structures X (P : NotionOfStructure X) : PreCategory. Proof. refine (@Build_PreCategory _ (@morphism _ P) (fun xa => {| f := identity xa.1; h := is_structure_homomorphism_identity _ _ xa.2 |}) (fun xa yb zc gi fh => {| f := (f gi) o (f fh); h := is_structure_homomorphism_composition _ _ _ _ _ _ _ _ _ (h fh) (h gi) |}) _ _ _ (fun s d => istrunc_equiv_istrunc _ (issig_morphism P s d))); simpl; abstract ( repeat match goal with | |- @morphism _ P _ _ -> _ => intros [? ?]; simpl in * | |- _ -> _ => intro end; first [ apply path_morphism; exact (associativity _ _ _ _ _ _ _ _) | apply path_morphism; exact (left_identity _ _ _ _) | apply path_morphism; exact (right_identity _ _ _ _) ] ). Defined. End precategory. Module Export StructureCoreNotations. Notation "a <=_{ x } b" := (is_structure_homomorphism _ x x (identity x) a b) : long_structure_scope. Notation "a <= b" := (a <=_{ _ } b)%long_structure : structure_scope. End StructureCoreNotations. Coq-HoTT-9.0/theories/Categories/Structure/IdentityPrinciple.v000066400000000000000000000101441474641544500244730ustar00rootroot00000000000000(** * The Structure Identity Principle *) Require Import Category.Core Category.Univalent Category.Morphisms. Require Import Structure.Core. Require Import Types.Sigma Trunc Equivalences. Require Import Basics.Iff Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope path_scope. Local Open Scope category_scope. Local Open Scope morphism_scope. Local Open Scope structure_scope. (** Quoting the Homotopy Type Theory Book (with slight changes for notational consistency): *) (** Theorem (Structure identity principle): If [X] is a category and [(P, H)] is a standard notion of structure over [X], then the precategory [Str_{(P, H)}(X)] is a category. *) Section sip. Variable X : PreCategory. Variable P : NotionOfStructure X. Context `{IsCategory X}. Context `{@IsStandardNotionOfStructure X P}. Let StrX := @precategory_of_structures X P. Definition sip_isotoid_helper (xa yb : StrX) (f : xa <~=~> yb) : xa.1 <~=~> yb.1. Proof. exists (PreCategoryOfStructures.f (f : morphism _ _ _)). exists (PreCategoryOfStructures.f f^-1). - exact (ap (@PreCategoryOfStructures.f _ _ _ _) (@left_inverse _ _ _ _ f)). - exact (ap (@PreCategoryOfStructures.f _ _ _ _) (@right_inverse _ _ _ _ f)). Defined. Lemma sip_isotoid_helper_refl (xa : StrX) : @sip_isotoid_helper xa xa (reflexivity _) = reflexivity _. Proof. unfold sip_isotoid_helper, reflexivity, isomorphic_refl. apply ap. apply path_ishprop. Defined. Lemma sip_helper x y (p : x = y) (a : P x) (b : P y) : transport P p a = b <-> is_structure_homomorphism P _ _ (idtoiso X p) a b * is_structure_homomorphism P _ _ (idtoiso X p)^-1 b a. Proof. split. - intros; path_induction; split; apply reflexivity. - intros [H0 H1]; path_induction; simpl in *. apply antisymmetry_structure; assumption. Defined. Definition sip_isotoid (xa yb : StrX) (f : xa <~=~> yb) : xa = yb. Proof. refine (path_sigma_uncurried _ _ _ (isotoid X xa.1 yb.1 (sip_isotoid_helper f); _)). apply sip_helper; simpl. split; lazymatch goal with | [ |- context[idtoiso ?X ((isotoid ?X ?x ?y) ?m)] ] => pose proof (eisretr (@idtoiso X x y) m) as H'; pattern (idtoiso X ((isotoid X x y) m)) end; refine (transport _ H'^ _); clear H'; simpl; apply PreCategoryOfStructures.h. Defined. Lemma sip_isotoid_refl xa : @sip_isotoid xa xa (reflexivity _) = reflexivity _. Proof. refine (_ @ eta_path_sigma_uncurried _). refine (ap (path_sigma_uncurried _ _ _) _). apply equiv_path_sigma_hprop. simpl. refine (_ @ eisretr (isotoid X xa.1 xa.1) 1%path). apply ap. apply sip_isotoid_helper_refl. Defined. Lemma path_f_idtoiso_precategory_of_structures xa yb (p : xa = yb) : PreCategoryOfStructures.f (idtoiso (precategory_of_structures P) p : morphism _ _ _) = idtoiso X p..1. Proof. induction p; reflexivity. Defined. Lemma structure_identity_principle_helper (xa yb : StrX) (x : xa <~=~> yb) : PreCategoryOfStructures.f (idtoiso (precategory_of_structures P) (sip_isotoid x) : morphism _ _ _) = PreCategoryOfStructures.f (x : morphism _ _ _). Proof. refine (path_f_idtoiso_precategory_of_structures _ @ _). refine ((ap _ (ap _ _)) @ (ap (@morphism_isomorphic _ _ _) (eisretr (@idtoiso X xa.1 yb.1) (sip_isotoid_helper _)))). exact (pr1_path_sigma_uncurried _). Defined. Global Instance structure_identity_principle : IsCategory (precategory_of_structures P). Proof. intros xa yb. refine (isequiv_adjointify _ (@sip_isotoid xa yb) _ _); intro; simpl in *. - abstract ( apply path_isomorphic; simpl; apply PreCategoryOfStructures.path_morphism; apply structure_identity_principle_helper ). - abstract (induction x; apply sip_isotoid_refl). Defined. End sip. Coq-HoTT-9.0/theories/Categories/Structure/Notations.v000066400000000000000000000001521474641544500230100ustar00rootroot00000000000000(** * Notations for structures *) Require Structure.Core. Include Structure.Core.StructureCoreNotations. Coq-HoTT-9.0/theories/Categories/Structure/Utf8.v000066400000000000000000000003561474641544500216660ustar00rootroot00000000000000Require Import Structure.Core. Require Export Structure.Notations. Require Import Basics.Utf8. Notation "a ≤_{ x } b" := (a <=_{ x } b)%long_structure : long_structure_scope. Notation "a ≤ b" := (a <= b)%structure : structure_scope. Coq-HoTT-9.0/theories/Categories/UniversalProperties.v000066400000000000000000000406171474641544500230710ustar00rootroot00000000000000(** * Universal morphisms *) Require Import Category.Core Functor.Core. Require Import Category.Dual Functor.Dual. Require Import Category.Objects. Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors. Require Comma.Core. Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *) Import Comma.Core. Local Set Warnings Append "notation-overridden". Require Import Trunc Types.Sigma HoTT.Tactics. Require Import Basics.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Section UniversalMorphism. (** Quoting Wikipedia: Suppose that [U : D → C] is a functor from a category [D] to a category [C], and let [X] be an object of [C]. Consider the following dual (opposite) notions: *) Local Ltac univ_hprop_t UniversalProperty := apply @istrunc_succ in UniversalProperty; eapply @istrunc_sigma; first [ intro; simpl; match goal with | [ |- context[?m o 1] ] => simpl rewrite (right_identity _ _ _ m) | [ |- context[1 o ?m] ] => simpl rewrite (left_identity _ _ _ m) end; assumption | by typeclasses eauto ]. (** ** Initial morphisms *) Section InitialMorphism. (** *** Definition *) Variables C D : PreCategory. Variable X : C. Variable U : Functor D C. (** An initial morphism from [X] to [U] is an initial object in the category [(X ↓ U)] of morphisms from [X] to [U]. In other words, it consists of a pair [(A, φ)] where [A] is an object of [D] and [φ: X → U A] is a morphism in [C], such that the following initial property is satisfied: - Whenever [Y] is an object of [D] and [f : X → U Y] is a morphism in [C], then there exists a unique morphism [g : A → Y] such that the following diagram commutes: << φ X -----> U A A \ . . \ . U g . g f \ . . ↘ ↓ ↓ U Y Y >> *) Definition IsInitialMorphism (Ap : object (X / U)) := IsInitialObject (X / U) Ap. (** *** Introduction rule *) Section IntroductionAbstractionBarrier. Definition Build_IsInitialMorphism (*(Ap : Object (X ↓ U))*) (A : D)(* := CCO_b Ap*) (p : morphism C X (U A))(*:= CCO_f Ap*) (Ap := CommaCategory.Build_object !X U tt A p) (UniversalProperty : forall (A' : D) (p' : morphism C X (U A')), Contr { m : morphism D A A' | U _1 m o p = p' }) : IsInitialMorphism Ap. Proof. intro x. specialize (UniversalProperty (CommaCategory.b x) (CommaCategory.f x)). (** We want to preserve the computation rules for the morphisms, even though they're unique up to unique isomorphism. *) eapply istrunc_equiv_istrunc. - apply CommaCategory.issig_morphism. - apply contr_inhabited_hprop. + abstract univ_hprop_t UniversalProperty. + (exists tt). (exists (@center _ UniversalProperty).1). abstract (progress rewrite ?right_identity, ?left_identity; exact (@center _ UniversalProperty).2). Defined. Definition Build_IsInitialMorphism_curried (A : D) (p : morphism C X (U A)) (Ap := CommaCategory.Build_object !X U tt A p) (m : forall (A' : D) (p' : morphism C X (U A')), morphism D A A') (H : forall (A' : D) (p' : morphism C X (U A')), U _1 (m A' p') o p = p') (H' : forall (A' : D) (p' : morphism C X (U A')) m', U _1 m' o p = p' -> m A' p' = m') : IsInitialMorphism Ap := Build_IsInitialMorphism A p (fun A' p' => Build_Contr _ (m A' p'; H A' p') (fun m' => path_sigma _ (m A' p'; H A' p') m' (H' A' p' m'.1 m'.2) (center _))). (** Projections from nested sigmas are currently rather slow. We should just be able to do << Definition Build_IsInitialMorphism_uncurried (univ : { A : D | { p : morphism C X (U A) | let Ap := CommaCategory.Build_object !X U tt A p in forall (A' : D) (p' : morphism C X (U A')), { m : morphism D A A' | { H : U _1 m o p = p' | forall m', U _1 m' o p = p' -> m = m' }}}}) := @Build_IsInitialMorphism_curried (univ.1) (univ.2.1) (fun A' p' => (univ.2.2 A' p').1) (fun A' p' => (univ.2.2 A' p').2.1) (fun A' p' => (univ.2.2 A' p').2.2). >> But that's currently too slow. (About 6-8 seconds, on my machine.) So instead we factor out all of the type parts by hand, and then apply them after. *) Let make_uncurried A' B' C' D' E'0 (E'1 : forall a a' b b' (c : C' a a'), D' a a' b b' c -> E'0 a a' -> Type) (E' : forall a a' b b' (c : C' a a'), D' a a' b b' c -> E'0 a a' -> Type) F' (f : forall (a : A') (b : B' a) (c : forall (a' : A') (b' : B' a'), C' a a') (d : forall (a' : A') (b' : B' a'), D' a a' b b' (c a' b')) (e : forall (a' : A') (b' : B' a') (e0 : E'0 a a') (e1 : E'1 a a' b b' (c a' b') (d a' b') e0), E' a a' b b' (c a' b') (d a' b') e0), F' a b) (univ : { a : A' | { b : B' a | forall (a' : A') (b' : B' a'), { c : C' a a' | { d : D' a a' b b' c | forall (e0 : E'0 a a') (e1 : E'1 a a' b b' c d e0), E' a a' b b' c d e0 }}}}) : F' univ.1 univ.2.1 := f (univ.1) (univ.2.1) (fun A' p' => (univ.2.2 A' p').1) (fun A' p' => (univ.2.2 A' p').2.1) (fun A' p' => (univ.2.2 A' p').2.2). Definition Build_IsInitialMorphism_uncurried : forall (univ : { A : D | { p : morphism C X (U A) | let Ap := CommaCategory.Build_object !X U tt A p in forall (A' : D) (p' : morphism C X (U A')), { m : morphism D A A' | { H : U _1 m o p = p' | forall m', U _1 m' o p = p' -> m = m' }}}}), IsInitialMorphism (CommaCategory.Build_object !X U tt univ.1 univ.2.1) := @make_uncurried _ _ _ _ _ _ _ _ (@Build_IsInitialMorphism_curried). End IntroductionAbstractionBarrier. Global Arguments Build_IsInitialMorphism : simpl never. Global Arguments Build_IsInitialMorphism_curried : simpl never. Global Arguments Build_IsInitialMorphism_uncurried : simpl never. (** *** Elimination rule *) Section EliminationAbstractionBarrier. Variable Ap : object (X / U). Definition IsInitialMorphism_object (M : IsInitialMorphism Ap) : D := CommaCategory.b Ap. Definition IsInitialMorphism_morphism (M : IsInitialMorphism Ap) : morphism C X (U (IsInitialMorphism_object M)) := CommaCategory.f Ap. Definition IsInitialMorphism_property_morphism (M : IsInitialMorphism Ap) (Y : D) (f : morphism C X (U Y)) : morphism D (IsInitialMorphism_object M) Y := CommaCategory.h (@center _ (M (CommaCategory.Build_object !X U tt Y f))). Definition IsInitialMorphism_property_morphism_property (M : IsInitialMorphism Ap) (Y : D) (f : morphism C X (U Y)) : (U _1 (IsInitialMorphism_property_morphism M Y f)) o IsInitialMorphism_morphism M = f := concat (CommaCategory.p (@center _ (M (CommaCategory.Build_object !X U tt Y f)))) (right_identity _ _ _ _). Definition IsInitialMorphism_property_morphism_unique (M : IsInitialMorphism Ap) (Y : D) (f : morphism C X (U Y)) m' (H : U _1 m' o IsInitialMorphism_morphism M = f) : IsInitialMorphism_property_morphism M Y f = m' := ap (@CommaCategory.h _ _ _ _ _ _ _) (@contr _ (M (CommaCategory.Build_object !X U tt Y f)) (CommaCategory.Build_morphism Ap (CommaCategory.Build_object !X U tt Y f) tt m' (H @ (right_identity _ _ _ _)^)%path)). Definition IsInitialMorphism_property (M : IsInitialMorphism Ap) (Y : D) (f : morphism C X (U Y)) : Contr { m : morphism D (IsInitialMorphism_object M) Y | U _1 m o IsInitialMorphism_morphism M = f } := Build_Contr _ (IsInitialMorphism_property_morphism M Y f; IsInitialMorphism_property_morphism_property M Y f) (fun m' => path_sigma _ (IsInitialMorphism_property_morphism M Y f; IsInitialMorphism_property_morphism_property M Y f) m' (@IsInitialMorphism_property_morphism_unique M Y f m'.1 m'.2) (center _)). End EliminationAbstractionBarrier. Global Arguments IsInitialMorphism_object : simpl never. Global Arguments IsInitialMorphism_morphism : simpl never. Global Arguments IsInitialMorphism_property : simpl never. Global Arguments IsInitialMorphism_property_morphism : simpl never. Global Arguments IsInitialMorphism_property_morphism_property : simpl never. Global Arguments IsInitialMorphism_property_morphism_unique : simpl never. End InitialMorphism. (** ** Terminal morphisms *) Section TerminalMorphism. (** *** Definition *) Variables C D : PreCategory. Variable U : Functor D C. Variable X : C. (** A terminal morphism from [U] to [X] is a terminal object in the comma category [(U ↓ X)] of morphisms from [U] to [X]. In other words, it consists of a pair [(A, φ)] where [A] is an object of [D] and [φ : U A -> X] is a morphism in [C], such that the following terminal property is satisfied: - Whenever [Y] is an object of [D] and [f : U Y -> X] is a morphism in [C], then there exists a unique morphism [g : Y -> A] such that the following diagram commutes: << Y U Y . . \ g . U g . \ f . . \ ↓ ↓ ↘ A U A -----> X φ >> *) Local Notation op_object Ap := (CommaCategory.Build_object (Functors.from_terminal C^op X) (U^op) (CommaCategory.b (Ap : object (U / X))) (CommaCategory.a (Ap : object (U / X))) (CommaCategory.f (Ap : object (U / X))) : object ((X : object C^op) / U^op)). Definition IsTerminalMorphism (Ap : object (U / X)) : Type := @IsInitialMorphism (C^op) _ X (U^op) (op_object Ap). (** *** Introduction rule *) Section IntroductionAbstractionBarrier. Definition Build_IsTerminalMorphism : forall (*(Ap : Object (U ↓ X))*) (A : D)(* := CommaCategory.a Ap*) (p : morphism C (U A) X)(*:= CommaCategory.f Ap*) (Ap := CommaCategory.Build_object U !X A tt p) (UniversalProperty : forall (A' : D) (p' : morphism C (U A') X), Contr { m : morphism D A' A | p o U _1 m = p' }), IsTerminalMorphism Ap := @Build_IsInitialMorphism (C^op) (D^op) X (U^op). Definition Build_IsTerminalMorphism_curried : forall (A : D) (p : morphism C (U A) X) (Ap := CommaCategory.Build_object U !X A tt p) (m : forall (A' : D) (p' : morphism C (U A') X), morphism D A' A) (H : forall (A' : D) (p' : morphism C (U A') X), p o U _1 (m A' p') = p') (H' : forall (A' : D) (p' : morphism C (U A') X) m', p o U _1 m' = p' -> m A' p' = m'), IsTerminalMorphism Ap := @Build_IsInitialMorphism_curried (C^op) (D^op) X (U^op). Definition Build_IsTerminalMorphism_uncurried : forall (univ : { A : D | { p : morphism C (U A) X | let Ap := CommaCategory.Build_object U !X A tt p in forall (A' : D) (p' : morphism C (U A') X), { m : morphism D A' A | { H : p o U _1 m = p' | forall m', p o U _1 m' = p' -> m = m' }}}}), IsTerminalMorphism (CommaCategory.Build_object U !X univ.1 tt univ.2.1) := @Build_IsInitialMorphism_uncurried (C^op) (D^op) X (U^op). End IntroductionAbstractionBarrier. (** *** Elimination rule *) Section EliminationAbstractionBarrier. Variable Ap : object (U / X). Variable M : IsTerminalMorphism Ap. Definition IsTerminalMorphism_object : D := @IsInitialMorphism_object C^op D^op X U^op (op_object Ap) M. Definition IsTerminalMorphism_morphism : morphism C (U IsTerminalMorphism_object) X := @IsInitialMorphism_morphism C^op D^op X U^op (op_object Ap) M. Definition IsTerminalMorphism_property : forall (Y : D) (f : morphism C (U Y) X), Contr { m : morphism D Y IsTerminalMorphism_object | IsTerminalMorphism_morphism o U _1 m = f } := @IsInitialMorphism_property C^op D^op X U^op (op_object Ap) M. Definition IsTerminalMorphism_property_morphism : forall (Y : D) (f : morphism C (U Y) X), morphism D Y IsTerminalMorphism_object := @IsInitialMorphism_property_morphism C^op D^op X U^op (op_object Ap) M. Definition IsTerminalMorphism_property_morphism_property : forall (Y : D) (f : morphism C (U Y) X), IsTerminalMorphism_morphism o (U _1 (IsTerminalMorphism_property_morphism Y f)) = f := @IsInitialMorphism_property_morphism_property C^op D^op X U^op (op_object Ap) M. Definition IsTerminalMorphism_property_morphism_unique : forall (Y : D) (f : morphism C (U Y) X) m' (H : IsTerminalMorphism_morphism o U _1 m' = f), IsTerminalMorphism_property_morphism Y f = m' := @IsInitialMorphism_property_morphism_unique C^op D^op X U^op (op_object Ap) M. End EliminationAbstractionBarrier. End TerminalMorphism. Section UniversalMorphism. (** The term universal morphism refers either to an initial morphism or a terminal morphism, and the term universal property refers either to an initial property or a terminal property. In each definition, the existence of the morphism [g] intuitively expresses the fact that [(A, φ)] is ``general enough'', while the uniqueness of the morphism ensures that [(A, φ)] is ``not too general''. *) End UniversalMorphism. End UniversalMorphism. Arguments Build_IsInitialMorphism [C D] X U A p UniversalProperty _. Arguments Build_IsTerminalMorphism [C D] U X A p UniversalProperty _. Coq-HoTT-9.0/theories/Categories/Utf8.v000066400000000000000000000007171474641544500176670ustar00rootroot00000000000000(** * Unicode notations for categories *) Local Set Warnings Append "-notation-overridden". Require Export HoTT.Categories.Notations. Require Export Category.Utf8 Functor.Utf8 NaturalTransformation.Utf8. Require Export Comma.Utf8. Require Export Adjoint.Utf8. Require Export FunctorCategory.Utf8. Require Export Profunctor.Utf8. Require Export Structure.Utf8. Require ChainCategory. Export ChainCategory.Utf8. Require SimplicialSets. Export SimplicialSets.Utf8. Coq-HoTT-9.0/theories/Categories/Yoneda.v000066400000000000000000000314721474641544500202620ustar00rootroot00000000000000(** * The Yoneda Lemma *) Require Import Category.Core Functor.Core NaturalTransformation.Core. Require Import Category.Dual Functor.Dual. Require Import Functor.Composition.Core. Require Import Category.Morphisms FunctorCategory.Morphisms. Require Import SetCategory. Require Import Functor.Attributes. Require Import Functor.Composition.Functorial. Require Import Functor.Identity. Require Import HomFunctor. Require Import FunctorCategory.Core. Require Import NaturalTransformation.Paths. Require Import HoTT.Tactics. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. Local Open Scope morphism_scope. Local Open Scope category_scope. Local Open Scope functor_scope. (** Quoting Wikipedia on the Yoneda lemma (chainging [A] to [a] and [C] to [A] so that we can use unicode superscripts and subscripts): In mathematics, specifically in category theory, the Yoneda lemma is an abstract result on functors of the type morphisms into a fixed object. It is a vast generalisation of Cayley's theorem from group theory (viewing a group as a particular kind of category with just one object). It allows the embedding of any category into a category of functors (contravariant set-valued functors) defined on that category. It also clarifies how the embedded category, of representable functors and their natural transformations, relates to the other objects in the larger functor category. It is an important tool that underlies several modern developments in algebraic geometry and representation theory. It is named after Nobuo Yoneda. ** Generalities The Yoneda lemma suggests that instead of studying the (locally small) category [A], one should study the category of all functors of [A] into [Set] (the category of sets with functions as morphisms). [Set] is a category we understand well, and a functor of [A] into [Set] can be seen as a "representation" of [A] in terms of known structures. The original category [A] is contained in this functor category, but new objects appear in the functor category which were absent and "hidden" in [A]. Treating these new objects just like the old ones often unifies and simplifies the theory. This approach is akin to (and in fact generalizes) the common method of studying a ring by investigating the modules over that ring. The ring takes the place of the category [A], and the category of modules over the ring is a category of functors defined on [A]. ** Formal statement *** General version Yoneda's lemma concerns functors from a fixed category [A] to the category of sets, [Set]. If [A] is a locally small category (i.e. the hom-sets are actual sets and not proper classes), then each object [a] of [A] gives rise to a natural functor to [Set] called a hom-functor. This functor is denoted: [hᵃ = Hom(a, ─)]. The (covariant) hom-functor [hᵃ] sends [x] to the set of morphisms [Hom(a, x)] and sends a morphism [f] from [x] to [y] to the morphism [f ∘ ─] (composition with [f] on the left) that sends a morphism [g] in [Hom(a, x)] to the morphism [f ∘ g] in [Hom(a, y)]. That is, [f ↦ Hom(a, f) = ⟦ Hom(a, x) ∋ g ↦ f ∘ g ∈ Hom(a,y) ⟧]. *) (** ** The (co)yoneda functors [A → (Aᵒᵖ → set)] *) Section yoneda. Context `{Funext}. (* TODO(JasonGross): Find a way to unify the [yoneda] and [coyoneda] lemmas into a single lemma which is more functorial. *) Definition coyoneda A : Functor A^op (A -> set_cat) := ExponentialLaws.Law4.Functors.inverse _ _ _ (hom_functor A). Definition yoneda A : Functor A (A^op -> set_cat) := coyoneda A^op. End yoneda. (** ** The (co)yoneda lemma *) Section coyoneda_lemma. Section functor. Context `{Funext}. Variable A : PreCategory. (** Let [F] be an arbitrary functor from [A] to [Set]. Then Yoneda's lemma says that: *) (*Variable F : Functor A (@set_cat fs).*) (** For each object [a] of [A], *) (*Variable a : A.*) (** the natural transformations from [hᵃ] to [F] are in one-to-one correspondence with the elements of [F(a)]. That is, [Nat(hᵃ, F) ≅ F(a)]. Moreover this isomorphism is natural in [a] and [F] when both sides are regarded as functors from [Setᴬ × A] to [Set]. Given a natural transformation [Φ] from [hᵃ] to [F], the corresponding element of [F(a)] is [u = Φₐ(idₐ)]. *) (* Definition coyoneda_lemma_morphism (a : A) : morphism set_cat (BuildhSet (morphism (A -> set_cat) (coyoneda A a) F) _) (F a) := fun phi => phi a 1%morphism. *) Definition coyoneda_functor : Functor (A -> set_cat) (A -> set_cat) := (compose_functor _ _ set_cat (coyoneda A)^op) o (yoneda (A -> set_cat)). End functor. Section nt. Context `{Funext}. Variable A : PreCategory. Definition coyoneda_natural_transformation_helper F : morphism (_ -> _) (coyoneda_functor A F) F. Proof. refine (Build_NaturalTransformation (coyoneda_functor A F) F (fun a phi => phi a 1%morphism) _). simpl. abstract ( repeat (intro || apply path_forall); simpl in *; match goal with | [ T : NaturalTransformation _ _ |- _ ] => simpl rewrite <- (fun s d m => apD10 (commutes T s d m)) end; rewrite ?left_identity, ?right_identity; reflexivity ). Defined. Definition coyoneda_natural_transformation : morphism (_ -> _) (coyoneda_functor A) 1. Proof. hnf. simpl. let F := match goal with |- NaturalTransformation ?F ?G => constr:(F) end in let G := match goal with |- NaturalTransformation ?F ?G => constr:(G) end in refine (Build_NaturalTransformation F G coyoneda_natural_transformation_helper _). simpl. abstract (repeat first [ intro | progress path_natural_transformation | reflexivity ]). Defined. End nt. Definition coyoneda_lemma_morphism_inverse `{Funext} A (F : object (A -> set_cat)) a : morphism set_cat (F a) (coyoneda_functor A F a). Proof. intro Fa. hnf. simpl in *. let F0 := match goal with |- NaturalTransformation ?F ?G => constr:(F) end in let G0 := match goal with |- NaturalTransformation ?F ?G => constr:(G) end in refine (Build_NaturalTransformation F0 G0 (fun a' : A => (fun f : morphism A a a' => F _1 f Fa)) _ ). simpl. abstract ( repeat first [ reflexivity | intro | apply path_forall | progress rewrite ?composition_of, ?identity_of ] ). Defined. Global Instance coyoneda_lemma `{Funext} A : IsIsomorphism (coyoneda_natural_transformation A). Proof. eapply isisomorphism_natural_transformation. simpl. intro F. eapply isisomorphism_natural_transformation. intro a. simpl. exists (coyoneda_lemma_morphism_inverse F a); simpl in *; abstract ( repeat (intro || apply path_forall || path_natural_transformation); simpl in *; solve [ simpl rewrite <- (fun c d m => ap10 (commutes x c d m)); rewrite ?right_identity, ?left_identity; reflexivity | rewrite identity_of; reflexivity ] ). Defined. End coyoneda_lemma. Section yoneda_lemma. (** There is a contravariant version of Yoneda's lemma which concerns contravariant functors from [A] to [Set]. This version involves the contravariant hom-functor [hₐ = Hom(─, A)], which sends [x] to the hom-set [Hom(x, a)]. Given an arbitrary contravariant functor [G] from [A] to [Set], Yoneda's lemma asserts that [Nat(hₐ, G) ≅ G(a)]. *) Section functor. Context `{Funext}. Variable A : PreCategory. (** Let [F] be an arbitrary functor from [A] to [Set]. Then Yoneda's lemma says that: *) (*Variable F : Functor A (@set_cat fs).*) (** For each object [a] of [A], *) (*Variable a : A.*) (** the natural transformations from [hᵃ] to [F] are in one-to-one correspondence with the elements of [F(a)]. That is, [Nat(hᵃ, F) ≅ F(a)]. Moreover this isomorphism is natural in [a] and [F] when both sides are regarded as functors from [Setᴬ × A] to [Set]. Given a natural transformation [Φ] from [hᵃ] to [F], the corresponding element of [F(a)] is [u = Φₐ(idₐ)]. *) (* Definition yoneda_lemma_morphism A (G : object (A^op -> set_cat)) (a : A) : morphism set_cat (BuildhSet (morphism (A^op -> set_cat) (yoneda A a) G) _) (G a) := fun phi => phi a 1%morphism.*) Definition yoneda_functor : Functor (A^op -> set_cat) (A^op -> set_cat) := coyoneda_functor A^op. End functor. Context `{Funext}. Variable A : PreCategory. Definition yoneda_natural_transformation : morphism (_ -> _) 1 (yoneda_functor A) := @morphism_inverse _ _ _ _ (coyoneda_lemma A^op). Global Instance yoneda_lemma : IsIsomorphism yoneda_natural_transformation := @isisomorphism_inverse _ _ _ _ (coyoneda_lemma A^op). End yoneda_lemma. (** ** The Yoneda embedding An important special case of Yoneda's lemma is when the functor [F] from [A] to [Set] is another hom-functor [hᵇ]. In this case, the covariant version of Yoneda's lemma states that [Nat(hᵃ, hᵇ) ≅ Hom(b, a)]. That is, natural transformations between hom-functors are in one-to-one correspondence with morphisms (in the reverse direction) between the associated objects. Given a morphism [f : b → a] the associated natural transformation is denoted [Hom(f, ─)]. Mapping each object [a] in [A] to its associated hom-functor [hᵃ= Hom(a, ─)] and each morphism [f : B → A] to the corresponding natural transformation [Hom(f, ─)] determines a contravariant functor [h⁻] from [A] to [Setᴬ], the functor category of all (covariant) functors from [A] to [Set]. One can interpret [h⁻] as a covariant functor: [h⁻ : Aᵒᵖ → Setᴬ]. The meaning of Yoneda's lemma in this setting is that the functor [h⁻] is fully faithful, and therefore gives an embedding of [Aᵒᵖ] in the category of functors to [Set]. The collection of all functors {[hᵃ], [a] in [A]} is a subcategory of [Set̂ᴬ]. Therefore, Yoneda embedding implies that the category [Aᵒᵖ] is isomorphic to the category {[hᵃ], [a] in [A]}. The contravariant version of Yoneda's lemma states that [Nat(hₐ, h_b) ≅ Hom(a, b)]. Therefore, [h₋] gives rise to a covariant functor from [A] to the category of contravariant functors to [Set]: [h₋ : A → Set⁽⁽ᴬ⁾ᵒᵖ⁾]. Yoneda's lemma then states that any locally small category [A] can be embedded in the category of contravariant functors from [A] to [Set] via [h₋]. This is called the Yoneda embedding. *) Section FullyFaithful. Context `{Funext}. Definition coyoneda_embedding (A : PreCategory) : IsFullyFaithful (coyoneda A). Proof. intros a b. pose proof (@isisomorphism_inverse _ _ _ _ (@isisomorphism_components_of _ _ _ _ _ _ (@isisomorphism_components_of _ _ _ _ _ _ (@coyoneda_lemma _ A) (@coyoneda _ A b)) a)) as H'. simpl in *. unfold coyoneda_lemma_morphism_inverse in *; simpl in *. unfold Functors.inverse_object_of_morphism_of in *; simpl in *. let m := match type of H' with IsIsomorphism ?m => constr:(m) end in apply isisomorphism_set_cat_natural_transformation_paths with (T1 := m). - simpl. clear H'. intros; apply path_forall; intro; rewrite left_identity, right_identity; reflexivity. - destruct H' as [m' H0' H1']. (exists m'). + exact H0'. + exact H1'. Qed. Definition yoneda_embedding (A : PreCategory) : IsFullyFaithful (yoneda A). Proof. intros a b. pose proof (@coyoneda_embedding A^op a b) as CYE. unfold yoneda. let T := type of CYE in let T' := (eval simpl in T) in pose proof ((fun x : T => (x : T')) CYE) as CYE'. let G := match goal with |- ?G => constr:(G) end in let G' := (eval simpl in G) in exact ((fun x : G' => (x : G)) CYE'). Qed. End FullyFaithful. Coq-HoTT-9.0/theories/Classes/000077500000000000000000000000001474641544500161555ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Classes/categories/000077500000000000000000000000001474641544500203025ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Classes/categories/ua_category.v000066400000000000000000000051461474641544500230010ustar00rootroot00000000000000Require Import HoTT.Types HoTT.Categories.Category.Core HoTT.Categories.Category.Univalent HoTT.Classes.theory.ua_isomorphic. Import Morphisms.CategoryMorphismsNotations isomorphic_notations. Local Open Scope category. (** Given any signature [σ], there is a precategory of set algebras and homomorphisms for that signature. *) Lemma precategory_algebra `{Funext} (σ : Signature) : PreCategory. Proof. apply (@Build_PreCategory (SetAlgebra σ) Homomorphism hom_id (@hom_compose σ)); [intros; by apply path_hset_homomorphism .. | exact _]. Defined. (** Category isomorphic implies algebra isomorphic. *) Lemma catiso_to_uaiso `{Funext} {σ} {A B : object (precategory_algebra σ)} : A <~=~> B → A ≅ B. Proof. intros [f [a b c]]. unshelve eapply (@BuildIsomorphic _ _ _ f). intros s. refine (isequiv_adjointify (f s) (a s) _ _). - exact (apD10_homomorphism c s). - exact (apD10_homomorphism b s). Defined. (** Algebra isomorphic implies category isomorphic. *) Lemma uaiso_to_catiso `{Funext} {σ} {A B : object (precategory_algebra σ)} : A ≅ B → A <~=~> B. Proof. intros [f F G]. set (h := BuildHomomorphism f). apply (@Morphisms.Build_Isomorphic _ A B h). apply (@Morphisms.Build_IsIsomorphism _ A B h (hom_inv h)). - apply path_hset_homomorphism. funext s x. apply eissect. - apply path_hset_homomorphism. funext s x. apply eisretr. Defined. (** Category isomorphic and algebra isomorphic is equivalent. *) Global Instance isequiv_catiso_to_uaiso `{Funext} {σ : Signature} (A B : object (precategory_algebra σ)) : IsEquiv (@catiso_to_uaiso _ σ A B). Proof. refine (isequiv_adjointify catiso_to_uaiso uaiso_to_catiso _ _). - intros [f F G]. by apply path_hset_isomorphic. - intros [f F]. by apply Morphisms.path_isomorphic. Defined. (** [Morphisms.idtoiso] factorizes as the composition of equivalences. *) Lemma path_idtoiso_isomorphic_id `{Funext} {σ : Signature} (A B : object (precategory_algebra σ)) : @Morphisms.idtoiso (precategory_algebra σ) A B = catiso_to_uaiso^-1 o isomorphic_id o (path_setalgebra A B)^-1. Proof. funext p. destruct p. by apply Morphisms.path_isomorphic. Defined. (** The precategory of set algebras and homomorphisms for a signature is a (univalent) category. *) Lemma iscategory_algebra `{Univalence} (σ : Signature) : IsCategory (precategory_algebra σ). Proof. intros A B. rewrite path_idtoiso_isomorphic_id. apply @isequiv_compose. - apply isequiv_compose. - apply isequiv_inverse. Qed. Definition category_algebra `{Univalence} (σ : Signature) : Category := Build_Category (iscategory_algebra σ). Coq-HoTT-9.0/theories/Classes/implementations/000077500000000000000000000000001474641544500213655ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Classes/implementations/assume_rationals.v000066400000000000000000000016541474641544500251330ustar00rootroot00000000000000From HoTT.Classes Require Import interfaces.canonical_names interfaces.orders interfaces.rationals theory.rationals. Monomorphic Universe UQ. Parameters (Q : Type@{UQ}) (Qap : Apart@{UQ UQ} Q) (Qplus : Plus Q) (Qmult : Mult Q) (Qzero : Zero Q) (Qone : One Q) (Qneg : Negate Q) (Qrecip : DecRecip Q) (Qle : Le@{UQ UQ} Q) (Qlt : Lt@{UQ UQ} Q) (QtoField : RationalsToField@{UQ UQ UQ UQ} Q) (Qrats : Rationals@{UQ UQ UQ UQ UQ UQ UQ UQ UQ UQ} Q) (Qtrivialapart : TrivialApart Q) (Qdec : DecidablePaths Q) (Qmeet : Meet Q) (Qjoin : Join Q) (Qlattice : LatticeOrder Qle) (Qle_total : TotalRelation (@le Q _)) (Qabs : Abs Q). (* I don't even want to know why this is necessary. *) Parameter Qenum : Enumerable Q. Notation "Q+" := (Qpos Q). Global Existing Instances Qap Qplus Qmult Qzero Qone Qneg Qrecip Qle Qlt QtoField Qrats Qtrivialapart Qdec Qmeet Qjoin Qlattice Qle_total Qabs Qenum. Coq-HoTT-9.0/theories/Classes/implementations/binary_naturals.v000066400000000000000000000552331474641544500247610ustar00rootroot00000000000000Require Import HoTT.Spaces.Nat.Core. Require Import HoTT.Tactics. Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.naturals HoTT.Classes.interfaces.orders HoTT.Classes.implementations.peano_naturals HoTT.Classes.theory.rings HoTT.Classes.orders.semirings HoTT.Classes.theory.apartness. Section basics. (* This definition of binary naturals is due to Martín Escardó and Cory Knapp *) Inductive binnat : Type0 := | bzero : binnat (* zero *) | double1 : binnat -> binnat (* 2n+1 *) | double2 : binnat -> binnat. (* 2n+2 *) Fixpoint Succ (n : binnat) : binnat := match n with | bzero => double1 bzero | double1 n' => double2 n' | double2 n' => double1 (Succ n') end. Fixpoint double (n : binnat) : binnat := match n with | bzero => bzero | double1 n' => double2 (double n') | double2 n' => double2 (Succ (double n')) end. Fixpoint Double (n : nat) : nat := match n with | O => O | S n' => S (S (Double n')) end. Definition Double1 (n : nat) : nat := S (Double n). Definition Double2 (n : nat) : nat := S (S (Double n)). Fixpoint binary (n : nat) : binnat := match n with | O => bzero | S n' => Succ (binary n') end. End basics. Section binary_equiv. Local Fixpoint unary' (n : binnat) : nat := match n with | bzero => O | double1 n' => Double1 (unary' n') | double2 n' => Double2 (unary' n') end. Local Definition succunary (n : binnat) : unary' (Succ n) = S (unary' n). Proof. induction n. - reflexivity. - reflexivity. - simpl. rewrite IHn. reflexivity. Qed. Local Definition unarybinary : unary' o binary == idmap. Proof. intros n; induction n as [|n IHn]. - reflexivity. - simpl. rewrite succunary. apply ap. exact IHn. Qed. Definition double1binary (n : nat) : binary (Double1 n) = double1 (binary n). Proof. induction n. - reflexivity. - change (binary (Double1 n.+1)) with (Succ (Succ (binary (Double n).+1))). rewrite IHn. reflexivity. Qed. Definition double2binary (n : nat) : binary (Double2 n) = double2 (binary n). Proof. induction n. - reflexivity. - change (binary (Double2 n.+1)) with (Succ (Succ (binary (Double n).+2))). rewrite IHn. reflexivity. Qed. Local Definition binaryunary : binary o unary' == idmap. Proof. intros n; induction n. - reflexivity. - rewrite double1binary. apply ap. exact IHn. - rewrite double2binary. apply ap. exact IHn. Qed. Global Instance isequiv_binary : IsEquiv binary := isequiv_adjointify binary unary' binaryunary unarybinary. Definition equiv_binary : nat <~> binnat := Build_Equiv _ _ binary isequiv_binary. End binary_equiv. Notation equiv_unary := equiv_binary ^-1. Notation unary := equiv_unary. Section semiring_struct. Global Instance binnat_0 : Zero binnat := bzero. Global Instance binnat_1 : One binnat := double1 bzero. Local Fixpoint binnat_plus' (m n : binnat) : binnat := match m, n with | bzero , n' => n' | double1 m' , bzero => double1 m' (* compute m + n as 2m'+1 + 2n'+1 = 2(m'+n') + 2 *) | double1 m' , double1 n' => double2 (binnat_plus' m' n') (* compute m + n as 2m'+1 + 2n'+2 = 2(m'+n')+2 + 1 = 2(m' + n' + 1) + 1 *) | double1 m' , double2 n' => double1 (Succ (binnat_plus' m' n')) | double2 m' , bzero => double2 m' (* compute m + n as 2m'+2 + 2n'+1 = 2(m'+n')+2 + 1 = 2(m' + n' + 1) + 1 *) | double2 m' , double1 n' => double1 (Succ (binnat_plus' m' n')) (* compute m + n as 2m'+2 + 2n'+2 = 2(m'+n')+2 + 2 = 2(m' + n' + 1) + 2*) | double2 m' , double2 n' => double2 (Succ (binnat_plus' m' n')) end. Global Instance binnat_plus : Plus binnat := binnat_plus'. Local Fixpoint binnat_mult' (m n : binnat) : binnat := match m with | bzero => bzero (* compute (2m'+1)*n as 2m'n+n *) | double1 m' => (binnat_mult' m' n) + (binnat_mult' m' n) + n | double2 m' => (binnat_mult' m' n) + (binnat_mult' m' n) + n + n end. Global Instance binnat_mult : Mult binnat := binnat_mult'. End semiring_struct. Section semiring_laws. Definition binarysucc (n : nat) : binary n.+1 = Succ (binary n). Proof. reflexivity. Qed. Definition unarysucc : forall m, unary (Succ m) = S (unary m). Proof. equiv_intros binary n. rewrite <- binarysucc. rewrite eissect, eissect. reflexivity. Qed. Definition binnatplussucc : forall (m n : binnat), (Succ m) + n = Succ (m + n). Proof. induction m; induction n; try reflexivity; simpl; rewrite <- IHm; done. Qed. Definition binaryplus (m n : nat) : binary m + binary n = binary (m + n). Proof. induction m; induction n; try reflexivity. - simpl. rewrite binnatplussucc. apply ap. done. - simpl. rewrite <- IHm. rewrite binnatplussucc. done. Qed. Definition unaryplus (m n : binnat) : unary m + unary n = unary (m + n). Proof. etransitivity (unary (binary (_^-1 m + _^-1 n))). - apply ((eissect binary (unary m + unary n)) ^). - rewrite <- binaryplus. rewrite (eisretr binary m), (eisretr binary n). reflexivity. Qed. Local Instance binnat_add_assoc : Associative binnat_plus. Proof. hnf; equiv_intros binary x y z. change binnat_plus with plus. rewrite binaryplus, binaryplus, binaryplus, binaryplus. apply ap. apply associativity. Qed. Local Instance binnat_add_comm : Commutative binnat_plus. Proof. hnf; equiv_intros binary x y. change binnat_plus with plus. rewrite binaryplus, binaryplus. apply ap. apply plus_comm. Qed. Definition binnatmultsucc : forall (m n : binnat), (Succ m) * n = n + (m * n). Proof. induction m. - intros n. change (bzero + n = n + bzero). apply commutativity. - intros n. simpl. change (double2 m * n) with ((m * n) + (m * n) + n + n). apply commutativity. - intros n. simpl. change (double1 (Succ m) * n) with ((Succ m) * n + (Succ m) * n + n). rewrite IHm. rewrite (commutativity n (double2 m * n)). rewrite (commutativity n (m * n)). rewrite <- (associativity (m * n) n (m * n + n)). rewrite (commutativity n (m * n + n)). rewrite (associativity (m * n) _ _). rewrite (associativity (m * n) (m * n) n). done. Qed. Definition binarymult (m n : nat) : binary m * binary n = binary (m * n). Proof. induction m; induction n; try reflexivity; rewrite binnatmultsucc, IHm, binaryplus; done. Qed. Definition unarymult (m n : binnat) : unary m * unary n = unary (m * n). Proof. etransitivity (unary (binary (_^-1 m * _^-1 n))). - apply ((eissect binary (unary m * unary n)) ^). - rewrite <- binarymult. rewrite (eisretr binary m), (eisretr binary n). reflexivity. Qed. Local Instance binnat_mult_assoc : Associative binnat_mult. Proof. hnf; equiv_intros binary x y z. change binnat_mult with mult. rewrite binarymult, binarymult, binarymult, binarymult. apply ap. apply associativity. Qed. Local Instance binnat_mult_comm : Commutative binnat_mult. Proof. hnf; equiv_intros binary x y. change binnat_mult with mult. rewrite binarymult, binarymult. apply ap. apply commutativity. Qed. Local Instance binnat_distr_l : LeftDistribute binnat_mult binnat_plus. Proof. hnf; equiv_intros binary x y z. change binnat_plus with plus. change binnat_mult with mult. rewrite binaryplus, binarymult, binarymult, binarymult, binaryplus. apply ap. apply plus_mult_distr_l. Qed. Local Instance binnat_distr_r : RightDistribute binnat_mult binnat_plus. Proof. hnf; equiv_intros binary x y z. change binnat_plus with plus. change binnat_mult with mult. rewrite binaryplus, binarymult, binarymult, binarymult, binaryplus. apply ap. apply plus_mult_distr_r. Qed. Global Instance binnat_set : IsHSet binnat. Proof. apply (istrunc_isequiv_istrunc nat binary). Qed. Global Instance binnat_semiring : IsSemiCRing binnat. Proof. split; try split; try split; try split; hnf; intros. 1, 5: apply istrunc_S; intros x y; exact (binnat_set x y). all: apply (equiv_inj unary). 1, 2, 3, 7: repeat rewrite <- unaryplus. 4, 5, 6, 7: rewrite <- unarymult. 4, 5, 7: rewrite <- unarymult. 4, 5: rewrite <- unarymult. 4: rewrite <- unaryplus. 5: rewrite <- unarymult. all: apply nat_semiring. Qed. End semiring_laws. Section naturals. Local Instance binary_preserving : IsSemiRingPreserving binary. Proof. split; split. 1, 3: hnf; intros x y; [> apply (binaryplus x y) ^ | apply (binarymult x y) ^ ]. all: reflexivity. Qed. Global Instance binnat_le : Le binnat := fun m n => unary m <= unary n. Global Instance binnat_lt : Lt binnat := fun m n => unary m < unary n. Global Instance binnat_apart : Apart binnat := fun m n => unary m ≶ unary n. Local Instance binnart_apart_symmetric : IsApart binnat. Proof. split. - apply _. - intros x y. apply nat_full. - intros x y. apply nat_full. - intros x y z w. apply nat_full. assumption. - intros m n. split. + intros E. apply (equiv_inj unary). apply nat_full. assumption. + intros p. apply nat_full. exact (ap unary p). Qed. Local Instance binnat_full : FullPseudoSemiRingOrder binnat_le binnat_lt. Proof. split. - intros m n; apply nat_le_hprop. - split; try intros m n; try apply nat_full. + split; try intros m n; try apply nat_full. * split; try intros m n; try apply nat_full. -- apply _. -- apply cotransitive. -- split; intros E. ++ assert (X : unary m = unary n) by by apply tight_apart. apply (((equiv_ap unary m n) ^-1) X). ++ rewrite E. apply nat_full. reflexivity. * intros E k. apply nat_full. exact E. + intros E. assert (H : exists w, (unary n) = (unary m) + w) by by apply nat_full. destruct H as [w L]. exists (binary w). rewrite <- (eisretr unary w), unaryplus in L. apply (equiv_inj unary). exact L. + intros m. split; intros k l E; unfold lt, binnat_lt in *. * rewrite <- unaryplus, <- unaryplus. apply nat_full. exact E. * rewrite <- unaryplus, <- unaryplus in E. apply (strictly_order_reflecting (plus (unary m))). exact E. + intros k l E. apply nat_full. unfold apart, binnat_apart in E. rewrite <- (unarymult m n), <- (unarymult k l) in E. exact E. + intros E F. unfold lt, binnat_lt. rewrite <- (unarymult m n). apply nat_full; assumption. - intros m n. apply nat_full. Qed. Global Instance binnat_naturals_to_semiring : NaturalsToSemiRing binnat:= fun _ _ _ _ _ _ => fix f (n: binnat) := match n with | bzero => 0 | double1 n' => 2 * (f n') + 1 | double2 n' => 2 * (f n') + 2 end. Definition nat_to_semiring_helper : NaturalsToSemiRing nat := fun _ _ _ _ _ _ => fix f (n: nat) := match n with | 0%nat => 0 | S n' => 1 + f n' end. Section for_another_semiring. Universe U. Context {R:Type} `{IsSemiCRing R}. Notation toR := (naturals_to_semiring binnat R). Notation toR_fromnat := (naturals_to_semiring nat R). Notation toR_vianat := (toR_fromnat ∘ unary). Definition f_suc (m : binnat) : toR (Succ m) = (toR m)+1. Proof. induction m. - change (2 * 0 + 1 = 0 + 1). rewrite mult_comm. rewrite mult_0_l. done. - change (2 * (toR m) + 2 = 2 * (toR m) + 1 + 1). apply plus_assoc. - induction m as [|m _|m _]. + change (2 * (2 * 0 + 1) + 1 = 2 * 0 + 2 + 1). rewrite plus_mult_distr_l. rewrite (@mult_1_r _ Aplus Amult Azero Aone H _). rewrite mult_0_r, mult_0_r. reflexivity. + change (2 * (2 * (toR m) + 2) + 1 = 2 * (2 * (toR m) + 1 ) + 2 + 1). apply (ap (fun z => z + 1)). assert (L : 2 * toR m + 2 = 2 * toR m + 1 + 1) by by rewrite plus_assoc. rewrite L; clear L. rewrite plus_mult_distr_l. rewrite mult_1_r. reflexivity. + simpl in IHm. change ((2 * (toR (double1 (Succ m))) + 1 = 2 * (toR (double2 m)) + 2 + 1)). rewrite IHm; clear IHm. rewrite plus_mult_distr_l. rewrite mult_1_r. reflexivity. Qed. Definition f_nat : forall m : binnat, toR m = toR_vianat m. Proof. equiv_intro binary n. induction n as [|n IHn]. - reflexivity. - induction n as [|n _]. + change ((1 + 1) * 0 + 1 = 1). rewrite mult_0_r. apply plus_0_l. + rewrite f_suc. rewrite IHn. assert (L : (toR_fromnat ∘ binary^-1) (binary n.+1) + 1 = toR_fromnat ((binary^-1 (binary n.+1)).+1)%nat). { simpl rewrite (plus_comm _ 1). simpl rewrite unarysucc. reflexivity. } rewrite L; clear L. rewrite <- unarysucc. rewrite <- binarysucc. reflexivity. Qed. Local Definition f_preserves_plus (a a' : binnat) : toR (a + a') = toR a + toR a'. Proof. rewrite f_nat, f_nat, f_nat. unfold Compose. rewrite <- (unaryplus a a'). apply nat_to_sr_morphism. Qed. Local Definition f_preserves_mult (a a' : binnat) : toR (a * a') = toR a * toR a'. Proof. rewrite f_nat, f_nat, f_nat. unfold Compose. rewrite <- (unarymult a a'). apply nat_to_sr_morphism. Qed. Global Instance binnat_to_sr_morphism : IsSemiRingPreserving toR. Proof. split; split. - rapply f_preserves_plus. - reflexivity. - rapply f_preserves_mult. - unfold IsUnitPreserving. apply f_nat. Defined. Lemma binnat_toR_unique (h : binnat -> R) `{!IsSemiRingPreserving h} : forall x, toR x = h x. Proof. equiv_intro binary n. rewrite f_nat; unfold Compose. rewrite eissect. refine (toR_unique (h ∘ binary) n). Qed. End for_another_semiring. Global Instance binnat_naturals : Naturals binnat. Proof. split. - exact binnat_semiring. - exact binnat_full. - intros. apply binnat_to_sr_morphism. - intros. apply binnat_toR_unique. assumption. Qed. End naturals. Section decidable. Local Definition ineq_bzero_double1 n : bzero <> double1 n. Proof. intros p. change ((fun x => match x with | double1 y => Unit | _ => Empty end) bzero). rapply (@transport binnat). - exact p^. - exact tt. Qed. Local Definition ineq_bzero_double2 n : bzero <> double2 n. Proof. intros p. change ((fun x => match x with | double2 y => Unit | _ => Empty end) bzero). rapply (@transport binnat). - exact p^. - exact tt. Qed. Local Definition ineq_double1_double2 m n : double1 m <> double2 n. Proof. intros p. change ((fun x => match x with | double2 y => Unit | _ => Empty end) (double1 m)). rapply (@transport binnat). - exact p^. - exact tt. Qed. Local Definition undouble (m : binnat) : binnat := match m with | bzero => bzero | double1 k => k | double2 k => k end. Local Instance double1_inj : IsInjective double1 := { injective := fun a b E => ap undouble E }. Local Instance double2_inj : IsInjective double2 := { injective := fun a b E => ap undouble E }. Global Instance binnat_dec : DecidablePaths binnat. Proof. intros m; induction m as [|m IHm|m IHm]; intros n; induction n as [|n IHn|n IHn]. all: first [ left ; reflexivity | right ; (idtac + apply symmetric_neq); first [ apply ineq_bzero_double1 | apply ineq_bzero_double2 | apply ineq_double1_double2 ] | destruct (IHm n) as [eq | ineq]; [ left; apply ap; exact eq | right; intros E; first [ apply (injective double1) in E | apply (injective double2) in E ]; auto ] ]. Defined. End decidable. Section other_laws. Instance binnat_plus_cancel_l (z:binnat) : LeftCancellation plus z. Proof. intros x y p. apply (equiv_inj unary). apply (ap unary) in p. rewrite <- unaryplus, <- unaryplus in p. exact (left_cancellation _ _ _ _ p). Qed. Instance binnat_mult_cancel_l (z : binnat): PropHolds (z <> 0) -> LeftCancellation (.*.) z. Proof. intros E. hnf in E. assert (H : unary z <> unary 0). { intros q. apply (equiv_inj unary) in q. exact (E q). } intros x y p. apply (ap unary) in p. rewrite <- unarymult, <- unarymult in p. exact (equiv_inj unary (nat_mult_cancel_l (unary z) H _ _ p)). Qed. Local Instance binnat_le_total : TotalRelation (_:Le binnat). Proof. intros x y. apply nat_le_total. Qed. Local Instance binnat_lt_irrefl : Irreflexive (_:Lt binnat). Proof. intros x. apply nat_lt_irrefl. Qed. End other_laws. Section trichotomy. (* TODO this is an inefficient implementation. Instead, write this without going via the unary naturals. *) Instance binnat_trichotomy : Trichotomy (lt:Lt binnat). Proof. intros x y. pose (T := nat_trichotomy (unary x) (unary y)). destruct T as [l|[c|r]]. - left; assumption. - right; left. apply (equiv_inj unary); assumption. - right; right; assumption. Defined. End trichotomy. Section minus. Local Definition Pred (m : binnat) : binnat := match m with | bzero => bzero | double1 m' => double m' | double2 m' => double1 m' end. Local Definition succ_double (m : binnat) : Succ (double m) = double1 m. Proof. induction m. - reflexivity. - change (double1 (Succ (double m)) = double1 (double1 m)). rewrite IHm; reflexivity. - change (double1 (Succ (Succ (double m))) = double1 (double2 m)). rewrite IHm; reflexivity. Qed. Local Definition double_succ (m : binnat) : double (Succ m) = double2 m. Proof. induction m. - reflexivity. - change (double2 (Succ (double m)) = double2 (double1 m)). rewrite succ_double; reflexivity. - change (double2 (double (Succ m)) = double2 (double2 m)). rewrite IHm; reflexivity. Qed. Local Definition pred_succ (m : binnat) : Pred (Succ m) = m. Proof. induction m; try reflexivity. - exact (double_succ m). Qed. Local Definition double_pred (m : binnat) : double (Pred m) = Pred (Pred (double m)). Proof. induction m; try reflexivity. - exact (double_succ (double m))^. Qed. Local Definition pred_double2 (m : binnat) : Pred (double2 m) = double1 m. Proof. induction m; reflexivity. Qed. Local Definition pred_double1 (m : binnat) : Pred (double1 m) = double m. Proof. induction m; reflexivity. Qed. (* 2*(m-1)+1 = 2*m - 1 *) Local Fixpoint binnat_cut_minus' (m n : binnat) : binnat := match m, n with | bzero , n' => bzero | m' , bzero => m' (* compute m - n as 2m'+1 - 2n'+1 = 2(m'-n') *) | double1 m' , double1 n' => double (binnat_cut_minus' m' n') (* compute m - n as 2m'+1 - 2n'+2 = 2(m'-n') - 1 = Pred (double (m' - n')) *) | double1 m' , double2 n' => Pred (double (binnat_cut_minus' m' n')) (* compute m - n as 2m'+2 - 2n'+1 *) | double2 m' , double1 n' => Pred (double (binnat_cut_minus' (Succ m') n')) (* compute m - n as 2m'+2 - 2n'+2 = 2(m'-n') = double (m' - n') *) | double2 m' , double2 n' => double (binnat_cut_minus' m' n') end. Global Instance binnat_cut_minus: CutMinus binnat := binnat_cut_minus'. Local Definition binnat_minus_zero (m : binnat) : m ∸ bzero = m. Proof. induction m; reflexivity. Qed. Local Definition binnat_zero_minus (m : binnat) : bzero ∸ m = bzero. Proof. induction m; reflexivity. Qed. Local Definition pred_succ_minus (m n : binnat) : Pred (Succ m ∸ n) = m ∸ n. Proof. revert n; induction m; intros n; induction n; try reflexivity. - change (Pred (double (bzero ∸ n)) = bzero). rewrite binnat_zero_minus; reflexivity. - change (Pred (Pred (double (bzero ∸ n))) = bzero ∸ double2 n). rewrite binnat_zero_minus, binnat_zero_minus; reflexivity. - change (Pred (Pred (double (Succ m ∸ n))) = double (m ∸ n)). rewrite <- double_pred. apply ap. exact (IHm n). - change (double (Succ m) = double2 m ∸ bzero). rewrite binnat_minus_zero. exact (double_succ m). - change (Pred (Pred (double (Succ m ∸ n))) = double (m ∸ n)). rewrite <- double_pred. apply ap. exact (IHm n). Qed. Local Definition double_cases (m : binnat) : (bzero = double m) + hfiber double2 (double m). Proof. induction m. - left; reflexivity. - right; exists (double m); reflexivity. - right; exists (Succ (double m)); reflexivity. Defined. Local Definition binnat_minus_succ (m n : binnat) : Succ m ∸ Succ n = m ∸ n. Proof. revert n; induction m; intros n; induction n; try reflexivity. - change (Pred (double (bzero ∸ n)) = bzero ∸ double1 n). rewrite binnat_zero_minus, binnat_zero_minus. reflexivity. - change (double (bzero ∸ (Succ n)) = bzero ∸ double2 n). rewrite binnat_zero_minus, binnat_zero_minus. reflexivity. - change (Pred (double (Succ m ∸ bzero)) = double1 m ∸ bzero). rewrite binnat_minus_zero, binnat_minus_zero. rewrite double_succ, pred_double2. reflexivity. - change (Pred (double (Succ m ∸ Succ n)) = Pred (double (m ∸ n))). rewrite IHm. reflexivity. - change (double (Succ m ∸ bzero) = double2 m ∸ bzero). rewrite binnat_minus_zero, binnat_minus_zero, double_succ. reflexivity. - change (double (Succ m ∸ Succ n) = double (m ∸ n)). rewrite IHm. reflexivity. Qed. Local Definition binaryminus (x y : nat) : binary x ∸ binary y = binary (x ∸ y). Proof. revert y; induction x; intros y; induction y; try reflexivity. - apply binnat_zero_minus. - apply binnat_minus_zero. - simpl in *. rewrite binnat_minus_succ. rewrite IHx. reflexivity. Qed. Local Definition unaryminus (m n : binnat) : unary m ∸ unary n = unary (m ∸ n). Proof. etransitivity (unary (binary (_^-1 m ∸ _^-1 n))). - apply ((eissect binary (unary m ∸ unary n)) ^). - rewrite <- binaryminus. rewrite (eisretr binary m), (eisretr binary n). reflexivity. Qed. Global Instance binnat_cut_minus_spec : CutMinusSpec binnat binnat_cut_minus. Proof. split. - intros m n E. apply (equiv_inj unary). rewrite <- unaryplus, <- unaryminus. apply nat_cut_minus_spec. assumption. - intros m n E. apply (equiv_inj unary). rewrite <- unaryminus. apply nat_cut_minus_spec. assumption. Qed. End minus. Coq-HoTT-9.0/theories/Classes/implementations/bool.v000066400000000000000000000007441474641544500225140ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra. Global Instance join_bool : Join Bool := orb. Global Instance meet_bool : Meet Bool := andb. Global Instance bottom_bool : Bottom Bool := false. Global Instance top_bool : Top Bool := true. Section contents. Local Ltac solve_bool := repeat (intros [|]); compute; (contradiction || auto). Global Instance lattice_bool : IsBoundedLattice Bool. Proof. repeat split; (apply _ || solve_bool). Defined. End contents. Coq-HoTT-9.0/theories/Classes/implementations/family_prod.v000066400000000000000000000043341474641544500240650ustar00rootroot00000000000000Require Import HoTT.Utf8Minimal HoTT.Basics.Overture Types.Unit HoTT.Spaces.List.Core. Local Open Scope list_scope. (** The following section implements a datatype [FamilyProd] which is a kind of product/tuple. *) Section family_prod. Context {I : Type}. (** [FamilyProd F ℓ] is a product type defined by << FamilyProd F [i1;i2;...;in] = F i1 * F i2 * ... * F in * Unit >> It is convenient to have the [Unit] in the end. *) Definition FamilyProd (F : I → Type) : list I → Type := fold_right (λ (i:I) (A:Type), F i * A) Unit. (** Map function for [FamilyProd F ℓ], << map_family_prod f (x1, x2, ..., xn, tt) = (f x1, f x2, ..., f xn, tt) >> *) Fixpoint map_family_prod {F G : I → Type} {ℓ : list I} (f : ∀ i, F i → G i) : FamilyProd F ℓ → FamilyProd G ℓ := match ℓ with | nil => const_tt _ | i :: ℓ' => λ '(x,s), (f i x, map_family_prod f s) end. (** [for_all_family_prod F P (x1, ..., xn, tt) = True] if [P i1 x1 ∧ P i2 x2 ∧ ... ∧ P in xn] holds. *) Fixpoint for_all_family_prod (F : I → Type) {ℓ : list I} (P : ∀ i, F i -> Type) : FamilyProd F ℓ → Type := match ℓ with | nil => λ _, Unit | i :: _ => λ '(x,s), P i x ∧ for_all_family_prod F P s end. (** [for_all_2_family_prod F G R (x1,...,xn,tt) (y1,...,yn,tt) = True] if [R i1 x1 y1 ∧ R i2 x2 y2 ∧ ... ∧ P in xn yn] holds. *) Fixpoint for_all_2_family_prod (F G : I → Type) {ℓ : list I} (R : ∀ i, F i -> G i -> Type) : FamilyProd F ℓ → FamilyProd G ℓ → Type := match ℓ with | nil => λ _ _, Unit | i :: _ => λ '(x,s) '(y,t), R i x y ∧ for_all_2_family_prod F G R s t end. (** If [R : ∀ i, relation (F i)] is a family of relations indexed by [i:I] and [R i] is reflexive for all [i], then << for_all_2_family_prod F F R s s >> holds. *) Lemma reflexive_for_all_2_family_prod (F : I → Type) (R : ∀ i, Relation (F i)) `{!∀ i, Reflexive (R i)} {ℓ : list I} (s : FamilyProd F ℓ) : for_all_2_family_prod F F R s s. Proof with try reflexivity. induction ℓ... split... apply IHℓ. Defined. End family_prod. Coq-HoTT-9.0/theories/Classes/implementations/field_of_fractions.v000066400000000000000000000370461474641544500254050ustar00rootroot00000000000000Require Import HoTT.HIT.quotient. Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.theory.dec_fields. Module Frac. Section contents. Universe UR. Context `{Funext} `{Univalence} (R:Type@{UR}) `{IsIntegralDomain R} `{DecidablePaths R}. Record Frac@{} : Type := frac { num: R; den: R; den_ne_0: PropHolds (den <> 0) }. (* We used to have [den] and [den_nonzero] bundled, which did work relatively nicely with Program, but the extra messyness in proofs etc turned out not to be worth it. *) Lemma Frac_ishset' : IsHSet Frac. Proof. assert (E : sig (fun n : R => sig (fun d : R => d <> 0 )) <~> Frac). - issig. - apply (istrunc_equiv_istrunc _ E). Qed. Global Instance Frac_ishset@{} : IsHSet Frac := ltac:(first [exact Frac_ishset'@{UR Ularge Set}| exact Frac_ishset'@{}]). Local Existing Instance den_ne_0. Global Instance Frac_inject@{} : Cast R Frac. Proof. intros x. apply (frac x 1 _). Defined. Global Instance Frac_0@{} : Zero Frac := ('0 : Frac). Global Instance Frac_1@{} : One Frac := ('1 : Frac). Instance pl@{} : Plus Frac. Proof. intros q r; refine (frac (num q * den r + num r * den q) (den q * den r) _). Defined. Definition equiv@{} := fun x y => num x * den y = num y * den x. Global Instance equiv_equiv_rel@{} : EquivRel equiv. Proof. split. - intros x. hnf. reflexivity. - intros x y. unfold equiv. apply symmetry. - intros x y z. unfold equiv. intros E1 E2. apply (mult_left_cancel (den y)). + solve_propholds. + rewrite !mult_assoc, !(mult_comm (den y)). rewrite E1, <-E2. rewrite <-!mult_assoc. rewrite (mult_comm (den x)). reflexivity. Qed. Global Instance equiv_dec@{} : forall x y: Frac, Decidable (equiv x y) := fun x y => decide_rel (=) (num x * den y) (num y * den x). Lemma pl_respect@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> equiv (q1 + r1) (q2 + r2). Proof. unfold equiv;intros q1 q2 Eq r1 r2 Er. simpl. rewrite plus_mult_distr_r. rewrite <-(associativity (num q1) (den r1)). rewrite (associativity (den r1)), (mult_comm (den r1)), <-(associativity (den q2)). rewrite (associativity (num q1)), Eq. rewrite (mult_comm (den q2)), <-(associativity (num r1)), (associativity (den q1)). rewrite (mult_comm (den q1)), <-(associativity (den r2)), (associativity (num r1)). rewrite Er. rewrite (mult_comm (den r1)), <-(associativity (num q2)), (associativity (den q1)). rewrite (mult_comm (den q1)), <-(associativity (den r2)), (associativity (num q2)). rewrite <-(associativity (num r2)), (associativity (den r1)), (mult_comm _ (den q2)). rewrite (mult_comm (den r1)), (associativity (num r2)). apply symmetry;apply plus_mult_distr_r. Qed. Lemma pl_comm@{} : forall q r, equiv (pl q r) (pl r q). Proof. intros q r;unfold equiv;simpl. rewrite (mult_comm (den r)), plus_comm. reflexivity. Qed. Lemma pl_assoc@{} : forall q r t, equiv (pl q (pl r t)) (pl (pl q r) t). Proof. intros;unfold equiv;simpl. apply ap011;[|apply symmetry,associativity]. rewrite plus_mult_distr_r. rewrite (plus_mult_distr_r _ _ (den t)). rewrite plus_assoc. apply ap011;[apply ap011|]. - apply associativity. - rewrite <-(associativity (num r)), <-(associativity (num r) (den q)). rewrite (mult_comm (den t)). reflexivity. - rewrite (mult_comm (den q));apply symmetry,associativity. Qed. Instance ml@{} : Mult Frac. Proof. intros q r; refine (frac (num q * num r) (den q * den r) _). Defined. Lemma ml_respect@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> equiv (q1 * r1) (q2 * r2). Proof. unfold equiv;intros q1 q2 Eq r1 r2 Er. simpl. rewrite <-(associativity (num q1)), (associativity (num r1)). rewrite (mult_comm (num r1)), <-(associativity (den q2)), (associativity (num q1)). rewrite Eq, Er. rewrite <-(associativity (num q2)), (associativity (den q1)), (mult_comm (den q1)). rewrite <-(simple_associativity (num r2)), <-(simple_associativity (num q2)). reflexivity. Qed. Instance neg@{} : Negate Frac. Proof. intros q;refine (frac (- num q) (den q) _). Defined. Lemma neg_respect@{} : forall q r, equiv q r -> equiv (- q) (- r). Proof. unfold equiv;simpl;intros q r E. rewrite <-2!negate_mult_distr_l. rewrite E;reflexivity. Qed. Lemma nonzero_num@{} x : ~ (equiv x 0) <-> num x <> 0. Proof. split; intros E F; apply E. - red. rewrite F. simpl. rewrite 2!mult_0_l. reflexivity. - red in F;simpl in F. rewrite mult_1_r, mult_0_l in F. trivial. Qed. Lemma pl_0_l@{} x : equiv (0 + x) x. Proof. red;simpl. rewrite mult_1_r, mult_0_l, mult_1_l, plus_0_l. reflexivity. Qed. Lemma pl_0_r@{} x : equiv (x + 0) x. Proof. red;simpl. rewrite 2!mult_1_r, mult_0_l, plus_0_r. reflexivity. Qed. Lemma pl_neg_l@{} x : equiv (- x + x) 0. Proof. red;simpl. rewrite mult_1_r, mult_0_l. rewrite <-plus_mult_distr_r. rewrite plus_negate_l. apply mult_0_l. Qed. Lemma ml_assoc@{} q r t : equiv (ml q (ml r t)) (ml (ml q r) t). Proof. red;simpl. rewrite (associativity (num q)), (associativity (den q)). reflexivity. Qed. Instance dec_rec@{} : DecRecip Frac := fun x => match decide_rel (=) (num x) 0 with | inl _ => 0 | inr P => frac (den x) (num x) P end. Lemma dec_recip_respect@{} : forall q r, equiv q r -> equiv (/ q) (/ r). Proof. unfold equiv,dec_recip,dec_rec;intros q r E;simpl. destruct (decide_rel paths (num q) 0) as [E1|E1], (decide_rel paths (num r) 0) as [E2|E2];simpl. - trivial. - rewrite E1 in E;rewrite mult_0_l in E. destruct E2. apply (right_cancellation_ne_0 mult (den q));try solve_propholds. rewrite mult_0_l;apply symmetry,E. - rewrite E2 in E;rewrite mult_0_l in E. destruct E1. apply (right_cancellation_ne_0 mult (den r));try solve_propholds. rewrite mult_0_l;trivial. - rewrite (mult_comm (den q)), (mult_comm (den r)). apply symmetry, E. Qed. End contents. Arguments Frac R {Rzero} : rename. Arguments frac {R Rzero} _ _ _ : rename. Arguments num {R Rzero} _ : rename. Arguments den {R Rzero} _ : rename. Arguments den_ne_0 {R Rzero} _ _ : rename. Arguments equiv {R _ _} _ _. Section morphisms. Context {R1} `{IsIntegralDomain R1} `{DecidablePaths R1}. Context {R2} `{IsIntegralDomain R2} `{DecidablePaths R2}. Context `(f : R1 -> R2) `{!IsSemiRingPreserving f} `{!IsInjective f}. Definition lift (x : Frac R1) : Frac R2. Proof. apply (frac (f (num x)) (f (den x))). apply isinjective_ne_0. apply (den_ne_0 x). Defined. Lemma lift_respects : forall q r, equiv q r -> equiv (lift q) (lift r). Proof. unfold equiv;simpl;intros q r E. rewrite <-2!preserves_mult. apply ap,E. Qed. End morphisms. End Frac. Import Frac. Module FracField. Section contents. (* NB: we need a separate IsHSet instance so we don't need to depend on everything to define F. *) Universe UR. Context `{Funext} `{Univalence} {R:Type@{UR} } `{IsHSet R} `{IsIntegralDomain R} `{DecidablePaths R}. Local Existing Instance den_ne_0. (* Add Ring R: (stdlib_ring_theory R). *) Definition F@{} := quotient equiv. Global Instance class@{} : Cast (Frac R) F := class_of _. (* injection from R *) Global Instance inject@{} : Cast R F := Compose class (Frac_inject _). Definition path@{} {x y} : equiv x y -> ' x = ' y := related_classes_eq _. Definition F_rect@{i} (P : F -> Type@{i}) {sP : forall x, IsHSet (P x)} (dclass : forall x : Frac R, P (' x)) (dequiv : forall x y E, (path E) # (dclass x) = (dclass y)) : forall q, P q := quotient_ind equiv P dclass dequiv. Definition F_compute P {sP} dclass dequiv x : @F_rect P sP dclass dequiv (' x) = dclass x := 1. Definition F_compute_path P {sP} dclass dequiv q r (E : equiv q r) : apD (@F_rect P sP dclass dequiv) (path E) = dequiv q r E := quotient_ind_compute_path _ _ _ _ _ _ _ _. Definition F_ind@{i} (P : F -> Type@{i}) {sP : forall x, IsHProp (P x)} (dclass : forall x : Frac R, P (' x)) : forall x, P x. Proof. apply (@F_rect P (fun _ => istrunc_hprop) dclass). intros;apply path_ishprop. Qed. Definition F_ind2@{i j} (P : F -> F -> Type@{i}) {sP : forall x y, IsHProp (P x y)} (dclass : forall x y : Frac R, P (' x) (' y)) : forall x y, P x y. Proof. apply (@F_ind (fun x => forall y, _)). - intros;apply istrunc_forall@{UR i j}. - intros x. apply (F_ind _);intros y. apply dclass. Qed. Definition F_ind3@{i j} (P : F -> F -> F -> Type@{i}) {sP : forall x y z, IsHProp (P x y z)} (dclass : forall x y z : Frac R, P (' x) (' y) (' z)) : forall x y z, P x y z. Proof. apply (@F_ind (fun x => forall y z, _)). - intros;apply istrunc_forall@{UR j j}. - intros x. apply (F_ind2@{i j} _). auto. Qed. Definition F_rec@{i} {T : Type@{i} } {sT : IsHSet T} : forall (dclass : Frac R -> T) (dequiv : forall x y, equiv x y -> dclass x = dclass y), F -> T := quotient_rec equiv. Definition F_rec_compute T sT dclass dequiv x : @F_rec T sT dclass dequiv (' x) = dclass x := 1. Definition F_rec2@{i j} {T:Type@{i} } {sT : IsHSet T} : forall (dclass : Frac R -> Frac R -> T) (dequiv : forall x1 x2, equiv x1 x2 -> forall y1 y2, equiv y1 y2 -> dclass x1 y1 = dclass x2 y2), F -> F -> T := @quotient_rec2@{UR UR UR j i} _ _ _ _ _ (Build_HSet _). Definition F_rec2_compute {T sT} dclass dequiv x y : @F_rec2 T sT dclass dequiv (' x) (' y) = dclass x y := 1. (* Relations, operations and constants *) Global Instance F0@{} : Zero F := ('0 : F). Global Instance F1@{} : One F := ('1 : F). Global Instance Fplus@{} : Plus F. Proof. refine (F_rec2 (fun x y => ' (Frac.pl _ x y)) _). intros. apply path. apply Frac.pl_respect;trivial. Defined. Definition Fplus_compute@{} q r : (' q) + (' r) = ' (Frac.pl _ q r) := 1. Global Instance Fneg@{} : Negate F. Proof. refine (F_rec (fun x => ' (Frac.neg _ x)) _). intros;apply path; eapply Frac.neg_respect;try apply _. trivial. Defined. Definition Fneg_compute@{} q : - (' q) = ' (Frac.neg _ q) := 1. Global Instance Fmult@{} : Mult F. Proof. refine (F_rec2 (fun x y => ' (Frac.ml _ x y)) _). intros. apply path. apply Frac.ml_respect;trivial. Defined. Definition Fmult_compute@{} q r : (' q) * (' r) = ' (Frac.ml _ q r) := 1. Instance Fmult_comm@{} : Commutative Fplus. Proof. hnf. apply (F_ind2 _). intros;apply path, Frac.pl_comm. Qed. Instance F_ring@{} : IsCRing F. Proof. repeat split; first [change sg_op with mult; change mon_unit with 1| change sg_op with plus; change mon_unit with 0]. - apply _. - hnf. apply (F_ind3 _). intros;apply path. apply Frac.pl_assoc. - hnf. apply (F_ind _). intros;apply path, Frac.pl_0_l. - hnf. apply (F_ind _). intros;apply path, Frac.pl_0_r. - hnf. apply (F_ind _). intros;apply path, Frac.pl_neg_l. - hnf;intros. rewrite (commutativity (f:=plus)). revert x;apply (F_ind _). intros;apply path, Frac.pl_neg_l. - apply _. - apply _. - hnf; apply (F_ind3 _). intros;apply path, Frac.ml_assoc. - hnf. apply (F_ind _). intros;apply path. red;simpl. rewrite 2!mult_1_l. reflexivity. - hnf. apply (F_ind _). intros;apply path. red;simpl. rewrite 2!mult_1_r. reflexivity. - hnf; apply (F_ind2 _). intros;apply path. red;simpl. rewrite (mult_comm (num y)), (mult_comm (den y)). reflexivity. - hnf. apply (F_ind3 _). intros a b c;apply path. red;simpl. rewrite <-!(mult_assoc (num a)). rewrite <-plus_mult_distr_l. rewrite <-(mult_assoc (num a)). apply ap. rewrite (mult_comm (den a) (den c)), (mult_comm (den a) (den b)). rewrite (mult_assoc (num b)), (mult_assoc (num c)). rewrite <-plus_mult_distr_r. rewrite <-(mult_assoc _ (den a) (den a * _)). apply ap. rewrite (mult_comm (den b)), <-mult_assoc. apply ap. rewrite (mult_comm (den a)). apply associativity. Qed. Global Instance Fdec_rec@{} : DecRecip F. Proof. refine (F_rec (fun x => ' (Frac.dec_rec _ x)) _). intros. apply path. apply Frac.dec_recip_respect;trivial. Defined. Lemma classes_eq_related@{} : forall q r, ' q = ' r -> equiv q r. Proof. apply classes_eq_related@{UR UR Ularge UR Ularge};apply _. Qed. Lemma class_neq@{} : forall q r, ~ (equiv q r) -> ' q <> ' r. Proof. intros q r E1 E2;apply E1;apply classes_eq_related, E2. Qed. Lemma classes_neq_related@{} : forall q r, ' q <> ' r -> ~ (equiv q r). Proof. intros q r E1 E2;apply E1,path,E2. Qed. Lemma dec_recip_0@{} : / 0 = 0. Proof. unfold dec_recip. simpl. unfold Frac.dec_rec;simpl. destruct (decide_rel paths 0 0) as [_|E]. - reflexivity. - destruct E;reflexivity. Qed. Lemma dec_recip_nonzero_aux@{} : forall q, ' q <> 0 -> num q <> 0. Proof. intros q E;apply classes_neq_related in E. apply Frac.nonzero_num in E. trivial. Qed. Lemma dec_recip_nonzero@{} : forall q (E : ' q <> 0), / (' q) = ' (frac (den q) (num q) (dec_recip_nonzero_aux q E)). Proof. intros. apply path. red;simpl. unfold Frac.dec_rec. apply classes_neq_related, Frac.nonzero_num in E. destruct (decide_rel paths (num q) 0) as [E'|?];[destruct E;apply E'|]. simpl. reflexivity. Qed. Global Instance F_field@{} : IsDecField F. Proof. split;try apply _. - red. apply class_neq. unfold equiv;simpl. rewrite 2!mult_1_r. solve_propholds. - apply dec_recip_0. - apply (F_ind (fun x => _ -> _)). intros x E. rewrite (dec_recip_nonzero _ E). apply path;red;simpl. rewrite mult_1_r,mult_1_l. apply mult_comm. Qed. Lemma dec_class@{} : forall q r, Decidable (class q = class r). Proof. intros q r. destruct (dec (equiv q r)) as [E|E]. - left. apply path,E. - right. intros E'. apply E. apply (classes_eq_related _ _ E'). Defined. Global Instance F_dec@{} : DecidablePaths F. Proof. hnf. apply (F_ind2 _). apply dec_class. Qed. Lemma mult_num_den@{} q : ' q = (' num q) / ' den q. Proof. apply path. red. simpl. rewrite mult_1_l. unfold Frac.dec_rec. simpl. destruct (decide_rel paths (den q) 0) as [E|E];simpl. - destruct (den_ne_0 q E). - rewrite mult_1_r. reflexivity. Qed. Lemma recip_den_num@{} q : / ' q = (' den q) / 'num q. Proof. apply path;red;simpl. unfold Frac.dec_rec;simpl. destruct (decide_rel paths (num q) 0) as [E|E];simpl. - rewrite (mult_0_r (Azero:=Azero)), 2!mult_0_l. reflexivity. - rewrite mult_1_l,mult_1_r. reflexivity. Qed. (* A final word about inject *) Global Instance inject_sr_morphism@{} : IsSemiRingPreserving (cast R F). Proof. repeat (split; try apply _). - intros x y. apply path. change ((x + y) * (1 * 1) = (x * 1 + y * 1) * 1). rewrite !mult_1_r. reflexivity. - intros x y. apply path. change ((x * y) * (1 * 1) = x * y * 1). rewrite !mult_1_r. reflexivity. Qed. Global Instance inject_injective@{} : IsInjective (cast R F). Proof. repeat (split; try apply _). intros x y E. apply classes_eq_related in E. red in E. simpl in E. rewrite 2!mult_1_r in E;trivial. Qed. End contents. Arguments F R {_ _ _}. Module Lift. Section morphisms. Universe UR1 UR2. Context `{Funext} `{Univalence}. Context {R1:Type@{UR1} } `{IsIntegralDomain R1} `{DecidablePaths R1}. Context {R2:Type@{UR2} } `{IsIntegralDomain R2} `{DecidablePaths R2}. Context `(f : R1 -> R2) `{!IsSemiRingPreserving f} `{!IsInjective f}. Definition lift@{} : F R1 -> F R2. Proof. apply (F_rec (fun x => class (Frac.lift f x))). intros;apply path,Frac.lift_respects;trivial. Defined. Global Instance lift_sr_morphism@{i} : IsSemiRingPreserving lift. Proof. (* This takes a few seconds. *) split;split;red. - apply (F_ind2@{UR1 UR2 i} _). intros;simpl. apply @path. (* very slow or doesn't terminate without the @ but fast with it *) red;simpl. repeat (rewrite <-(preserves_mult (f:=f)) || rewrite <-(preserves_plus (f:=f))). reflexivity. - simpl. apply path. red;simpl. rewrite (preserves_0 (f:=f)). rewrite 2!mult_0_l. reflexivity. - apply (F_ind2@{UR1 UR2 i} _). intros;simpl. apply @path. red;simpl. rewrite <-!(preserves_mult (f:=f)). reflexivity. - simpl. apply path. red;simpl. apply commutativity. Qed. Global Instance lift_injective@{i} : IsInjective lift. Proof. red. apply (F_ind2@{UR1 i i} (fun _ _ => _ -> _)). intros x y E. simpl in E. apply classes_eq_related in E. red in E;simpl in E. apply path. red. apply (injective f). rewrite 2!(preserves_mult (f:=f)). apply E. Qed. End morphisms. End Lift. End FracField. Coq-HoTT-9.0/theories/Classes/implementations/hprop_lattice.v000066400000000000000000000057311474641544500244170ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Universes.TruncType. (** Demonstrate the [HProp] is a (bounded) lattice w.r.t. the logical operations. This requires Univalence. *) Global Instance join_hor : Join HProp := hor. Definition hand (X Y : HProp) : HProp := Build_HProp (X * Y). Global Instance meet_hprop : Meet HProp := hand. Global Instance bottom_hprop : Bottom HProp := False_hp. Global Instance top_hprop : Top HProp := Unit_hp. Section contents. Context `{Univalence}. (* We use this notation because [hor] can accept arguments of type [Type], which leads to minor confusion in the instances below *) Notation lor := (hor : HProp -> HProp -> HProp). (* This tactic attempts to destruct a truncated sum (disjunction) *) Local Ltac hor_intros := let x := fresh in intro x; repeat (strip_truncations; destruct x as [x | x]). Instance commutative_hor : Commutative lor. Proof. intros ??. apply path_iff_hprop; hor_intros; apply tr; auto. Defined. Instance commutative_hand : Commutative hand. Proof. intros ??. apply path_hprop. apply equiv_prod_symm. Defined. Instance associative_hor : Associative lor. Proof. intros ???. apply path_iff_hprop; hor_intros; apply tr; ((by auto) || (left; apply tr) || (right; apply tr)); auto. Defined. Instance associative_hand : Associative hand. Proof. intros ???. apply path_hprop. apply equiv_prod_assoc. Defined. Instance idempotent_hor : BinaryIdempotent lor. Proof. intros ?. compute. apply path_iff_hprop; hor_intros; auto. by apply tr, inl. Defined. Instance idempotent_hand : BinaryIdempotent hand. Proof. intros ?. apply path_iff_hprop. - intros [a _] ; apply a. - intros a; apply (pair a a). Defined. Instance leftidentity_hor : LeftIdentity lor False_hp. Proof. intros ?. apply path_iff_hprop; hor_intros; try contradiction || assumption. by apply tr, inr. Defined. Instance rightidentity_hor : RightIdentity lor False_hp. Proof. intros ?. apply path_iff_hprop; hor_intros; try contradiction || assumption. by apply tr, inl. Defined. Instance leftidentity_hand : LeftIdentity hand Unit_hp. Proof. intros ?. apply path_trunctype, prod_unit_l. Defined. Instance rightidentity_hand : RightIdentity hand Unit_hp. Proof. intros ?. apply path_trunctype, prod_unit_r. Defined. Instance absorption_hor_hand : Absorption lor hand. Proof. intros ??. apply path_iff_hprop. - intros X; strip_truncations. destruct X as [? | [? _]]; assumption. - intros ?. by apply tr, inl. Defined. Instance absorption_hand_hor : Absorption hand lor. Proof. intros ??. apply path_iff_hprop. - intros [? _]; assumption. - intros ?. split. * assumption. * by apply tr, inl. Defined. Global Instance boundedlattice_hprop : IsBoundedLattice HProp. Proof. repeat split; apply _. Defined. End contents. Coq-HoTT-9.0/theories/Classes/implementations/natpair_integers.v000066400000000000000000001076231474641544500251230ustar00rootroot00000000000000Require Import HoTT.HIT.quotient HoTT.Universes.TruncType. Require Import HoTT.Classes.implementations.peano_naturals HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.interfaces.integers HoTT.Classes.theory.rings HoTT.Classes.theory.groups HoTT.Classes.theory.apartness HoTT.Classes.orders.sum HoTT.Classes.orders.rings HoTT.Classes.tactics.ring_tac HoTT.Classes.theory.naturals. Generalizable Variables B. Import ring_quote.Quoting.Instances. Local Set Universe Minimization ToSet. Module NatPair. Module Import PairT. Record T (N : Type) := C { pos : N ; neg : N }. Arguments C {N} _ _. Arguments pos {N} _. Arguments neg {N} _. Section contents. Universe UN UNalt. Context (N : Type@{UN}) `{Naturals@{UN UN UN UN UN UN UN UNalt} N}. Global Instance T_set : IsHSet (T N). Proof. assert (E : sig (fun _ : N => N) <~> (T N)). - issig. - apply (istrunc_equiv_istrunc _ E). Qed. Global Instance inject : Cast N (T N) := fun x => C x 0. Definition equiv := fun x y => pos x + neg y = pos y + neg x. Global Instance equiv_is_equiv_rel@{} : EquivRel equiv. Proof. split. - hnf. reflexivity. - hnf. unfold equiv. intros ??;apply symmetry. - hnf. unfold equiv. intros a b c E1 E2. apply (left_cancellation (+) (neg b)). rewrite (plus_assoc (neg b) (pos a)). rewrite (plus_comm (neg b) (pos a)), E1. rewrite (plus_comm (pos b)). rewrite <-plus_assoc. rewrite E2. rewrite (plus_comm (pos c) (neg b)). rewrite plus_assoc. rewrite (plus_comm (neg a)). rewrite <-plus_assoc. rewrite (plus_comm (neg a)). reflexivity. Qed. Instance pl : Plus (T N) := fun x y => C (pos x + pos y) (neg x + neg y). Instance ml : Mult (T N) := fun x y => C (pos x * pos y + neg x * neg y) (pos x * neg y + neg x * pos y). Instance opp : Negate (T N) := fun x => C (neg x) (pos x). Instance SR0 : Zero (T N) := C 0 0. Instance SR1 : One (T N) := C 1 0. Lemma pl_respects : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> equiv (q1 + r1) (q2 + r2). Proof. unfold equiv;simpl. intros q1 q2 Eq r1 r2 Er. rewrite (plus_assoc _ (neg q2)). rewrite <-(plus_assoc (pos q1)). rewrite (plus_comm (pos r1)). rewrite (plus_assoc (pos q1)). rewrite Eq. rewrite <-(plus_assoc _ (pos r1)). rewrite Er. rewrite plus_assoc. rewrite <-(plus_assoc (pos q2)). rewrite (plus_comm (neg q1)). rewrite !plus_assoc. reflexivity. Qed. Lemma ml_respects : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> equiv (q1 * r1) (q2 * r2). Proof. intros q1 q2 Eq r1 r2 Er. transitivity (q1 * r2);unfold equiv in *;simpl. - transitivity (pos q1 * (pos r1 + neg r2) + neg q1 * (neg r1 + pos r2)). + rewrite 2!plus_mult_distr_l. rewrite <-2!plus_assoc. apply ap. rewrite 2!plus_assoc. rewrite (plus_comm (neg q1 * neg r1)). reflexivity. + rewrite Er. rewrite plus_mult_distr_l. rewrite (plus_comm (neg r1)). rewrite <-Er. rewrite plus_mult_distr_l. rewrite <-2!plus_assoc. apply ap. rewrite (plus_comm (neg q1 * pos r1)). rewrite 2!plus_assoc. rewrite (plus_comm (pos q1 * neg r1)). reflexivity. - transitivity ((pos q1 + neg q2) * pos r2 + (neg q1 + pos q2) * neg r2). + rewrite 2!plus_mult_distr_r. rewrite <-2!plus_assoc;apply ap. rewrite (plus_comm (pos q2 * neg r2)). rewrite 2!plus_assoc. rewrite (plus_comm (neg q1 * neg r2)). reflexivity. + rewrite Eq,plus_mult_distr_r. rewrite (plus_comm (neg q1)),<-Eq,plus_mult_distr_r. rewrite <-2!plus_assoc. apply ap. rewrite plus_assoc,(plus_comm (neg q1 * pos r2)). apply plus_comm. Qed. Lemma opp_respects : forall q1 q2, equiv q1 q2 -> equiv (opp q1) (opp q2). Proof. unfold equiv;simpl. intros q1 q2 E. rewrite !(plus_comm (neg _)). symmetry. apply E. Qed. Definition Tle : Le (T N) := fun a b => pos a + neg b <= pos b + neg a. Definition Tlt : Lt (T N) := fun a b => pos a + neg b < pos b + neg a. Definition Tapart : Apart (T N) := fun a b => apart (pos a + neg b) (pos b + neg a). Global Instance Tle_hprop@{} : is_mere_relation (T N) Tle. Proof. intros;unfold Tle. apply full_pseudo_srorder_le_hprop. Qed. Global Instance Tlt_hprop@{} : is_mere_relation (T N) Tlt. Proof. intros;unfold Tlt;apply _. Qed. Local Existing Instance pseudo_order_apart. Global Instance Tapart_hprop@{} : is_mere_relation (T N) Tapart. Proof. intros;unfold Tapart;apply _. Qed. Lemma le_respects_aux@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> Tle q1 r1 -> Tle q2 r2. Proof. unfold equiv,Tle;intros [pa na] [pb nb] Eq [pc nc] [pd nd] Er E;simpl in *. apply (order_reflecting (+ (pc + na))). assert (Erw : pb + nd + (pc + na) = (pb + na) + (pc + nd)) by ring_with_nat. rewrite Erw,<-Eq,Er;clear Erw. assert (Erw : pa + nb + (pd + nc) = pd + nb + (pa + nc)) by ring_with_nat. rewrite Erw. apply (order_preserving _), E. Qed. Lemma le_respects@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> Tle q1 r1 <~> Tle q2 r2. Proof. intros. apply equiv_iff_hprop_uncurried. split;apply le_respects_aux; trivial;apply symmetry;trivial. Qed. Lemma lt_respects_aux@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> Tlt q1 r1 -> Tlt q2 r2. Proof. unfold equiv,Tlt;intros [pa na] [pb nb] Eq [pc nc] [pd nd] Er E;simpl in *. apply (strictly_order_reflecting (+ (pc + na))). assert (Erw : pb + nd + (pc + na) = (pb + na) + (pc + nd)) by ring_with_nat. rewrite Erw,<-Eq,Er;clear Erw. assert (Erw : pa + nb + (pd + nc) = pd + nb + (pa + nc)) by ring_with_nat. rewrite Erw. apply (strictly_order_preserving _), E. Qed. Lemma lt_respects@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> Tlt q1 r1 <~> Tlt q2 r2. Proof. intros. apply equiv_iff_hprop_uncurried. split;apply lt_respects_aux; trivial;apply symmetry;trivial. Qed. Lemma apart_cotrans@{} : CoTransitive Tapart. Proof. hnf. unfold Tapart. intros q1 q2 Eq r. apply (strong_left_cancellation (+) (neg r)) in Eq. apply (merely_destruct (cotransitive Eq (pos r + neg q1 + neg q2))); intros [E|E];apply tr. - left. apply (strong_extensionality (+ (neg q2))). assert (Hrw : pos q1 + neg r + neg q2 = neg r + (pos q1 + neg q2)) by ring_with_nat. rewrite Hrw;clear Hrw. trivial. - right. apply (strong_extensionality (+ (neg q1))). assert (Hrw : pos r + neg q2 + neg q1 = pos r + neg q1 + neg q2) by ring_with_nat. rewrite Hrw;clear Hrw. assert (Hrw : pos q2 + neg r + neg q1 = neg r + (pos q2 + neg q1)) by ring_with_nat. rewrite Hrw;clear Hrw. trivial. Qed. Existing Instance apart_cotrans. Instance : Symmetric Tapart. Proof. hnf. unfold Tapart. intros ??;apply symmetry. Qed. Lemma apart_respects_aux@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> Tapart q1 r1 -> Tapart q2 r2. Proof. assert (forall q1 q2, equiv q1 q2 -> forall r, Tapart q1 r -> Tapart q2 r) as E. - intros q1 q2 Eq r Er. unfold Tapart,equiv in *. apply (strong_extensionality (+ (neg q1))). assert (Hrw : pos q2 + neg r + neg q1 = (pos q2 + neg q1) + neg r) by ring_with_nat. rewrite Hrw;clear Hrw. rewrite <-Eq. assert (Hrw : pos q1 + neg q2 + neg r = neg q2 + (pos q1 + neg r)) by ring_with_nat. rewrite Hrw;clear Hrw. assert (Hrw : pos r + neg q2 + neg q1 = neg q2 + (pos r + neg q1)) by ring_with_nat;rewrite Hrw;clear Hrw. apply (strong_left_cancellation _ _),Er. - intros ?? Eq ?? Er E'. apply E with q1;trivial. apply symmetry;apply E with r1;apply symmetry;trivial. apply symmetry;trivial. Qed. Lemma apart_respects : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 -> Tapart q1 r1 <~> Tapart q2 r2. Proof. intros ?? Eq ?? Er. apply equiv_iff_hprop_uncurried. split;apply apart_respects_aux; trivial;apply symmetry;trivial. Qed. Section to_ring. Context {B : Type@{UNalt} } `{IsCRing@{UNalt} B}. Definition to_ring@{} : T N -> B. Proof. intros p. exact (naturals_to_semiring N B (pos p) - naturals_to_semiring N B (neg p)). Defined. Lemma to_ring_respects@{} : forall a b, equiv a b -> to_ring a = to_ring b. Proof. unfold equiv;intros [pa na] [pb nb] E. unfold to_ring;simpl in *. apply (left_cancellation (+) (naturals_to_semiring N B na + naturals_to_semiring N B nb)). path_via (naturals_to_semiring N B pa + naturals_to_semiring N B nb + 0); [rewrite <-(plus_negate_r (naturals_to_semiring N B na));ring_with_nat |rewrite plus_0_r]. path_via (naturals_to_semiring N B pb + naturals_to_semiring N B na + 0); [rewrite plus_0_r| rewrite <-(plus_negate_r (naturals_to_semiring N B nb));ring_with_nat]. rewrite <-2!preserves_plus. apply ap,E. Qed. End to_ring. End contents. Arguments equiv {_ _} _ _. Arguments Tle {_ _ _} _ _. Arguments Tlt {_ _ _} _ _. Arguments Tapart {_ _ _} _ _. Arguments to_ring N {_} B {_ _ _ _ _ _} / _. End PairT. Section contents. Universe UN UNalt. Context `{Funext} `{Univalence} (N : Type@{UN}) `{Naturals@{UN UN UN UN UN UN UN UNalt} N}. (* Add Ring SR : (rings.stdlib_semiring_theory SR). *) Instance N_fullpartial : FullPartialOrder Ale Alt := fullpseudo_fullpartial@{UN UN UN UN UN UN UN Ularge}. Definition Z@{} : Type@{UN} := @quotient _ PairT.equiv@{UN UNalt} _. Global Instance Z_of_pair : Cast (PairT.T N) Z := class_of _. Global Instance Z_of_N : Cast N Z := Compose Z_of_pair (PairT.inject@{UN UNalt} _). Definition Z_path {x y} : PairT.equiv x y -> Z_of_pair x = Z_of_pair y := related_classes_eq _. Definition related_path {x y} : Z_of_pair x = Z_of_pair y -> PairT.equiv x y := classes_eq_related@{UN UN Ularge UN Ularge} _ _ _. Definition Z_rect@{i} (P : Z -> Type@{i}) {sP : forall x, IsHSet (P x)} (dclass : forall x : PairT.T N, P (' x)) (dequiv : forall x y E, (Z_path E) # (dclass x) = (dclass y)) : forall q, P q := quotient_ind PairT.equiv P dclass dequiv. Definition Z_compute P {sP} dclass dequiv x : @Z_rect P sP dclass dequiv (Z_of_pair x) = dclass x := 1. Definition Z_compute_path P {sP} dclass dequiv q r (E : PairT.equiv q r) : apD (@Z_rect P sP dclass dequiv) (Z_path E) = dequiv q r E := quotient_ind_compute_path _ _ _ _ _ _ _ _. Definition Z_ind@{i} (P : Z -> Type@{i}) {sP : forall x : Z, IsHProp (P x)} (dclass : forall x : PairT.T N, P (cast (PairT.T N) Z x)) : forall x : Z, P x. Proof. apply (Z_rect@{i} P dclass). intros;apply path_ishprop@{i}. Defined. Definition Z_ind2 (P : Z -> Z -> Type) {sP : forall x y, IsHProp (P x y)} (dclass : forall x y : PairT.T N, P (' x) (' y)) : forall x y, P x y. Proof. apply (Z_ind (fun x => forall y, _));intros x. apply (Z_ind _);intros y. apply dclass. Defined. Definition Z_ind3@{i j} (P : Z -> Z -> Z -> Type@{i}) {sP : forall x y z : Z, IsHProp (P x y z)} (dclass : forall x y z : PairT.T N, P (' x) (' y) (' z)) : forall x y z : Z, P x y z. Proof. apply (@Z_ind (fun x => forall y z, _));intros x. 2:apply (Z_ind2@{i j} _);auto. apply (@istrunc_forall@{UN j j} _). intros. apply istrunc_forall@{UN i j}. Defined. Definition Z_rec@{i} {T : Type@{i} } {sT : IsHSet T} : forall (dclass : PairT.T N -> T) (dequiv : forall x y, PairT.equiv x y -> dclass x = dclass y), Z -> T := quotient_rec _. Definition Z_rec_compute T sT dclass dequiv x : @Z_rec T sT dclass dequiv (' x) = dclass x := 1. Definition Z_rec2@{i j} {T:Type@{i} } {sT : IsHSet T} : forall (dclass : PairT.T N -> PairT.T N -> T) (dequiv : forall x1 x2, PairT.equiv x1 x2 -> forall y1 y2, PairT.equiv y1 y2 -> dclass x1 y1 = dclass x2 y2), Z -> Z -> T := @quotient_rec2@{UN UN UN j i} _ _ _ _ _ (Build_HSet _). Definition Z_rec2_compute {T sT} dclass dequiv x y : @Z_rec2 T sT dclass dequiv (' x) (' y) = dclass x y := 1. Lemma dec_Z_of_pair `{DecidablePaths N} : forall q r : PairT.T N, Decidable (' q = ' r). Proof. intros q r. destruct (dec (PairT.equiv q r)) as [E|E]. - left. apply Z_path,E. - right. intros E'. apply E. apply (related_path E'). Defined. Global Instance R_dec `{DecidablePaths N} : DecidablePaths Z. Proof. hnf. apply (Z_ind2 _). apply dec_Z_of_pair. Defined. (* Relations, operations and constants *) Global Instance Z0 : Zero Z := ' 0. Global Instance Z1 : One Z := ' 1. Global Instance Z_plus@{} : Plus Z. Proof. refine (Z_rec2 (fun x y => ' (PairT.pl@{UN UNalt} _ x y)) _). intros;apply Z_path;eapply PairT.pl_respects;trivial. Defined. Definition Z_plus_compute q r : (' q) + (' r) = ' (PairT.pl _ q r) := 1. Global Instance Z_mult@{} : Mult Z. Proof. refine (Z_rec2 (fun x y => ' (PairT.ml@{UN UNalt} _ x y)) _). intros;apply Z_path;eapply PairT.ml_respects;trivial. Defined. (* Without this, typeclass resolution for e.g. [Monoid Z Z_plus] tries to get it from [SemiRing Z Z_plus ?mult] and fills the evar with the unfolded value, which does case analysis on quotient. *) Global Typeclasses Opaque Z_plus Z_mult. Definition Z_mult_compute q r : (' q) * (' r) = ' (PairT.ml _ q r) := 1. Global Instance Z_negate@{} : Negate Z. Proof. red. apply (Z_rec (fun x => ' (PairT.opp@{UN UNalt} _ x))). intros;apply Z_path;eapply PairT.opp_respects;trivial. Defined. Definition Z_negate_compute q : - (' q) = ' (PairT.opp _ q) := 1. Lemma Z_ring@{} : IsCRing Z. Proof. repeat split. 1,8: exact _. all: first [change sg_op with mult; change mon_unit with 1 | change sg_op with plus; change mon_unit with 0]; hnf. - apply (Z_ind3 _). intros a b c;apply Z_path;red;simpl. rewrite !plus_assoc. reflexivity. - apply (Z_ind _). intros a;apply Z_path;red;simpl. rewrite !plus_0_l. reflexivity. - apply (Z_ind _). intros a;apply Z_path;red;simpl. rewrite !plus_0_r. reflexivity. - apply (Z_ind _). intros a;apply Z_path;red;simpl. rewrite plus_0_l,plus_0_r. apply plus_comm. - apply (Z_ind _). intros a;apply Z_path;red;simpl. rewrite plus_0_l,plus_0_r. apply plus_comm. - apply (Z_ind2 _). intros a b;apply Z_path;red;simpl. apply ap011;apply plus_comm. - apply (Z_ind3 _). intros [pa na] [pb nb] [pc nc];apply Z_path;red;simpl. ring_with_nat. - apply (Z_ind _). intros;apply Z_path;red;simpl. ring_with_nat. - apply (Z_ind _). intros;apply Z_path;red;simpl. ring_with_nat. - apply (Z_ind2 _). intros;apply Z_path;red;simpl. ring_with_nat. - apply (Z_ind3 _). intros [pa na] [pb nb] [pc nc];apply Z_path;red;simpl. ring_with_nat. Qed. (* A final word about inject *) Lemma Z_of_N_morphism@{} : IsSemiRingPreserving (cast N Z). Proof. repeat (constructor; try apply _). - intros x y. apply Z_path. red. simpl. ring_with_nat. - intros x y. apply Z_path. red;simpl. ring_with_nat. Qed. Global Existing Instance Z_of_N_morphism. Global Instance Z_of_N_injective@{} : IsInjective (cast N Z). Proof. intros x y E. apply related_path in E. red in E. simpl in E. rewrite 2!plus_0_r in E. trivial. Qed. Lemma Npair_splits@{} : forall n m : N, ' (PairT.C n m) = ' n + - ' m. Proof. intros. apply Z_path;red;simpl. ring_with_nat. Qed. Definition Zle_HProp@{} : Z -> Z -> HProp@{UN}. Proof. apply (@Z_rec2@{Ularge Ularge} _ (@trunctype_istrunc@{Ularge} _ _) (fun q r => Build_HProp (PairT.Tle q r))). intros. apply path_hprop. simpl. apply (PairT.le_respects _);trivial. Defined. Global Instance Zle@{} : Le Z := fun x y => Zle_HProp x y. Global Instance ishprop_Zle : is_mere_relation _ Zle. Proof. unfold Zle;exact _. Qed. Lemma Zle_def@{} : forall a b : PairT.T N, @paths@{Uhuge} Type@{UN} (' a <= ' b) (PairT.Tle@{UN UNalt} a b). Proof. intros; exact idpath. Qed. Lemma Z_partial_order' : PartialOrder Zle. Proof. split;[apply _|apply _|split|]. - hnf. apply (Z_ind _). intros. change (PairT.Tle x x). red. reflexivity. - hnf. apply (Z_ind3 (fun _ _ _ => _ -> _ -> _)). intros [pa na] [pb nb] [pc nc]. rewrite !Zle_def;unfold PairT.Tle;simpl. intros E1 E2. apply (order_reflecting (+ (nb + pb))). assert (Hrw : pa + nc + (nb + pb) = (pa + nb) + (pb + nc)) by abstract ring_with_nat. rewrite Hrw;clear Hrw. assert (Hrw : pc + na + (nb + pb) = (pb + na) + (pc + nb)) by abstract ring_with_nat. rewrite Hrw;clear Hrw. apply plus_le_compat;trivial. - hnf. apply (Z_ind2 (fun _ _ => _ -> _ -> _)). intros [pa na] [pb nb];rewrite !Zle_def;unfold PairT.Tle;simpl. intros E1 E2;apply Z_path;red;simpl. apply (antisymmetry le);trivial. Qed. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) Instance Z_partial_order@{} : PartialOrder Zle := ltac:(first [exact Z_partial_order'@{Ularge Ularge Ularge Ularge Ularge}| exact Z_partial_order']). Lemma Zle_cast_embedding' : OrderEmbedding (cast N Z). Proof. split;red. - intros. rewrite Zle_def. unfold PairT.Tle. simpl. rewrite 2!plus_0_r;trivial. - intros ??. rewrite Zle_def. unfold PairT.Tle. simpl. rewrite 2!plus_0_r;trivial. Qed. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) Global Instance Zle_cast_embedding@{} : OrderEmbedding (cast N Z) := ltac:(first [exact Zle_cast_embedding'@{Ularge Ularge}| exact Zle_cast_embedding']). Lemma Zle_plus_preserving_l' : forall z : Z, OrderPreserving ((+) z). Proof. red. apply (Z_ind3 (fun _ _ _ => _ -> _)). intros [pc nc] [pa na] [pb nb]. rewrite !Zle_def;unfold PairT.Tle;simpl. intros E. assert (Hrw : pc + pa + (nc + nb) = (pc + nc) + (pa + nb)) by ring_with_nat. rewrite Hrw;clear Hrw. assert (Hrw : pc + pb + (nc + na) = (pc + nc) + (pb + na)) by ring_with_nat. rewrite Hrw;clear Hrw. apply (order_preserving _),E. Qed. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) Instance Zle_plus_preserving_l@{} : forall z : Z, OrderPreserving ((+) z) := ltac:(first [exact Zle_plus_preserving_l'@{Ularge Ularge}| exact Zle_plus_preserving_l']). Lemma Zmult_nonneg' : forall x y : Z, PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) -> PropHolds (0 ≤ x * y). Proof. unfold PropHolds. apply (Z_ind2 (fun _ _ => _ -> _ -> _)). intros [pa na] [pb nb]. rewrite !Zle_def;unfold PairT.Tle;simpl. rewrite !plus_0_l,!plus_0_r. intros E1 E2. destruct (decompose_le E1) as [a [Ea1 Ea2]], (decompose_le E2) as [b [Eb1 Eb2]]. rewrite Ea2, Eb2. apply compose_le with (a * b). - apply nonneg_mult_compat;trivial. - ring_with_nat. Qed. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) Instance Zmult_nonneg@{} : forall x y : Z, PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) -> PropHolds (0 ≤ x * y) := ltac:(first [exact Zmult_nonneg'@{Ularge Ularge Ularge}| exact Zmult_nonneg']). Global Instance Z_order@{} : SemiRingOrder Zle. Proof. pose proof Z_ring; apply rings.from_ring_order; apply _. Qed. (* Make this computable? Would need to compute through Z_ind2. *) Global Instance Zle_dec `{forall x y : N, Decidable (x <= y)} : forall x y : Z, Decidable (x <= y). Proof. apply (Z_ind2 _). intros a b. change (Decidable (PairT.Tle a b)). unfold PairT.Tle. apply _. Qed. Definition Zlt_HProp@{} : Z -> Z -> HProp@{UN}. Proof. apply (@Z_rec2@{Ularge Ularge} _ (@trunctype_istrunc@{Ularge} _ _) (fun q r => Build_HProp (PairT.Tlt q r))). intros. apply path_hprop. simpl. apply (PairT.lt_respects _);trivial. Defined. Global Instance Zlt@{} : Lt Z := fun x y => Zlt_HProp x y. Global Instance ishprop_Zlt : is_mere_relation _ Zlt. Proof. unfold Zlt;exact _. Qed. Lemma Zlt_def' : forall a b, ' a < ' b = PairT.Tlt a b. Proof. reflexivity. Qed. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) Definition Zlt_def@{i} := ltac:(first [exact Zlt_def'@{Uhuge i}|exact Zlt_def'@{i}]). Lemma Zlt_strict' : StrictOrder Zlt. Proof. split. - apply _. - (* we need to change so that it sees Empty, needed to figure out IsHProp (using Funext) *) change (forall x, x < x -> Empty). apply (Z_ind (fun _ => _ -> _)). intros [pa na];rewrite Zlt_def;unfold PairT.Tlt;simpl. apply irreflexivity,_. - hnf. apply (Z_ind3 (fun _ _ _ => _ -> _ -> _)). intros [pa na] [pb nb] [pc nc];rewrite !Zlt_def;unfold PairT.Tlt;simpl. intros E1 E2. apply (strictly_order_reflecting (+ (nb + pb))). assert (Hrw : pa + nc + (nb + pb) = (pa + nb) + (pb + nc)) by ring_with_nat. rewrite Hrw;clear Hrw. assert (Hrw : pc + na + (nb + pb) = (pb + na) + (pc + nb)) by ring_with_nat. rewrite Hrw;clear Hrw. apply plus_lt_compat;trivial. Qed. Instance Zlt_strict@{} : StrictOrder Zlt := ltac:(first [exact Zlt_strict'@{Ularge Ularge Ularge Ularge Ularge}| exact Zlt_strict'@{}]). Lemma plus_strict_order_preserving_l' : forall z : Z, StrictlyOrderPreserving ((+) z). Proof. red; apply (Z_ind3 (fun _ _ _ => _ -> _)). intros [pa na] [pb nb] [pc nc]. rewrite !Zlt_def;unfold PairT.Tlt;simpl. intros E. assert (Hrw : pa + pb + (na + nc) = (pa + na) + (pb + nc)) by ring_with_nat. rewrite Hrw;clear Hrw. assert (Hrw : pa + pc + (na + nb) = (pa + na) + (pc + nb)) by ring_with_nat. rewrite Hrw;clear Hrw. apply (strictly_order_preserving _),E. Qed. Instance Zplus_strict_order_preserving_l@{} : forall z : Z, StrictlyOrderPreserving ((+) z) := ltac:(first [exact plus_strict_order_preserving_l'@{Ularge Ularge}| exact plus_strict_order_preserving_l'@{}]). Lemma Zmult_pos' : forall x y : Z, PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x * y). Proof. unfold PropHolds. apply (Z_ind2 (fun _ _ => _ -> _ -> _)). intros [pa na] [pb nb]. rewrite !Zlt_def;unfold PairT.Tlt;simpl. rewrite !plus_0_l,!plus_0_r. intros E1 E2. destruct (decompose_lt E1) as [a [Ea1 Ea2]], (decompose_lt E2) as [b [Eb1 Eb2]]. rewrite Ea2, Eb2. apply compose_lt with (a * b). - apply pos_mult_compat;trivial. - ring_with_nat. Qed. Instance Zmult_pos@{} : forall x y : Z, PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x * y) := ltac:(first [exact Zmult_pos'@{Ularge Ularge Ularge}| exact Zmult_pos'@{}]). Global Instance Z_strict_srorder : StrictSemiRingOrder Zlt. Proof. pose proof Z_ring; apply from_strict_ring_order; apply _. Qed. Global Instance Zlt_dec `{forall x y : N, Decidable (x < y)} : forall x y : Z, Decidable (x < y). Proof. apply (Z_ind2 _). intros a b. change (Decidable (PairT.Tlt a b)). unfold PairT.Tlt. apply _. Qed. Local Existing Instance pseudo_order_apart. Definition Zapart_HProp@{} : Z -> Z -> HProp@{UN}. Proof. apply (@Z_rec2@{Ularge Ularge} _ _ (fun q r => Build_HProp (PairT.Tapart q r))). intros. apply path_hprop. simpl. apply (PairT.apart_respects _);trivial. Defined. Global Instance Zapart@{} : Apart Z := fun x y => Zapart_HProp x y. Lemma Zapart_def' : forall a b, apart (' a) (' b) = PairT.Tapart a b. Proof. reflexivity. Qed. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) Definition Zapart_def@{i} := ltac:(first [exact Zapart_def'@{Uhuge i}| exact Zapart_def'@{i}]). Global Instance ishprop_Zapart : is_mere_relation _ Zapart. Proof. unfold Zapart;exact _. Qed. Lemma Z_trivial_apart' `{!TrivialApart N} : TrivialApart Z. Proof. split;[exact _|idtac]. apply (Z_ind2 _). intros [pa na] [pb nb];rewrite Zapart_def;unfold PairT.Tapart;simpl. split;intros E1. - intros E2. apply related_path in E2. red in E2;simpl in E2. apply trivial_apart in E1. auto. - apply trivial_apart. intros E2. apply E1,Z_path. red;simpl. trivial. Qed. Global Instance Z_trivial_apart@{} `{!TrivialApart N} : TrivialApart Z := ltac:(first [exact Z_trivial_apart'@{Ularge}| exact Z_trivial_apart'@{}]). Lemma Z_is_apart' : IsApart Z. Proof. split. - apply _. - apply _. - hnf. apply (Z_ind2 (fun _ _ => _ -> _)). intros [pa na] [pb nb];rewrite !Zapart_def;unfold PairT.Tapart;simpl. apply symmetry. - hnf. intros x y E z;revert x y z E. apply (Z_ind3 (fun _ _ _ => _ -> _)). intros a b c;rewrite !Zapart_def;unfold PairT.Tapart;simpl. intros E1. apply (strong_left_cancellation (+) (PairT.neg c)) in E1. eapply (merely_destruct (cotransitive E1 _));intros [E2|E2];apply tr. + left. apply (strong_extensionality (+ (PairT.neg b))). assert (Hrw : PairT.pos a + PairT.neg c + PairT.neg b = PairT.neg c + (PairT.pos a + PairT.neg b)) by ring_with_nat;rewrite Hrw;exact E2. + right. apply (strong_extensionality (+ (PairT.neg a))). assert (Hrw : PairT.pos c + PairT.neg b + PairT.neg a = PairT.pos c + PairT.neg a + PairT.neg b) by ring_with_nat;rewrite Hrw;clear Hrw. assert (Hrw : PairT.pos b + PairT.neg c + PairT.neg a = PairT.neg c + (PairT.pos b + PairT.neg a)) by ring_with_nat;rewrite Hrw;clear Hrw. trivial. - apply (Z_ind2 _). intros a b;rewrite Zapart_def;unfold PairT.Tapart. split;intros E. + apply Z_path;red. apply tight_apart,E. + apply related_path in E. apply tight_apart,E. Qed. Instance Z_is_apart@{} : IsApart Z := ltac:(first [exact Z_is_apart'@{Ularge Ularge Ularge Ularge Ularge Ularge}| exact Z_is_apart'@{}]). Lemma Z_full_psorder' : FullPseudoOrder Zle Zlt. Proof. split;[apply _|split;try apply _|]. - apply (Z_ind2 _). intros a b;rewrite !Zlt_def;unfold PairT.Tlt. apply pseudo_order_antisym. - hnf. intros a b E c;revert a b c E. apply (Z_ind3 (fun _ _ _ => _ -> _)). intros [pa na] [pb nb] [pc nc];rewrite !Zlt_def;unfold PairT.Tlt. intros E1. apply (strictly_order_preserving (+ nc)) in E1. eapply (merely_destruct (cotransitive E1 _));intros [E2|E2];apply tr. + left. apply (strictly_order_reflecting ((nb) +)). assert (Hrw : nb + (pa + nc) = pa + nb + nc) by ring_with_nat;rewrite Hrw;exact E2. + right. apply (strictly_order_reflecting ((na) +)). assert (Hrw : na + (pc + nb) = nb + (pc + na)) by ring_with_nat;rewrite Hrw;clear Hrw. assert (Hrw : na + (pb + nc) = pb + na + nc) by ring_with_nat;rewrite Hrw;clear Hrw. trivial. - apply @Z_ind2. + intros a b. apply @istrunc_prod;[|apply _]. apply (@istrunc_arrow _). apply ishprop_sum;try apply _. intros E1 E2;apply (irreflexivity lt a). transitivity b;trivial. + intros a b;rewrite Zapart_def,!Zlt_def;unfold PairT.Tapart,PairT.Tlt. apply apart_iff_total_lt. - apply (Z_ind2 _). intros a b;rewrite Zle_def,Zlt_def;unfold PairT.Tlt,PairT.Tle. apply le_iff_not_lt_flip. Qed. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) Instance Z_full_psorder@{} : FullPseudoOrder Zle Zlt := ltac:(first [exact Z_full_psorder'@{Ularge Ularge Ularge Ularge Ularge Ularge Ularge Ularge Ularge}| exact Z_full_psorder'@{Ularge Ularge Ularge Ularge Ularge Ularge Ularge Ularge Ularge Ularge}| exact Z_full_psorder'@{}]). Lemma Zmult_strong_ext_l' : forall z : Z, StrongExtensionality (z *.). Proof. red;apply (Z_ind3 (fun _ _ _ => _ -> _)). intros [zp zn] [xp xn] [yp yn];rewrite !Zapart_def;unfold PairT.Tapart;simpl. intros E1. refine (merely_destruct (strong_binary_extensionality (+) (zp * (xp + yn)) (zn * (yp + xn)) (zp * (yp + xn)) (zn * (xp + yn)) _) _). - assert (Hrw : zp * (xp + yn) + zn * (yp + xn) = zp * xp + zn * xn + (zp * yn + zn * yp)) by ring_with_nat;rewrite Hrw;clear Hrw. assert (Hrw : zp * (yp + xn) + zn * (xp + yn) = zp * yp + zn * yn + (zp * xn + zn * xp)) by ring_with_nat;rewrite Hrw;exact E1. - intros [E2|E2]. + apply (strong_extensionality (zp *.)). trivial. + apply symmetry;apply (strong_extensionality (zn *.)). trivial. Qed. Instance Zmult_strong_ext_l@{} : forall z : Z, StrongExtensionality (z *.) := ltac:(first [exact Zmult_strong_ext_l'@{Ularge Ularge}| exact Zmult_strong_ext_l'@{}]). Instance Z_full_pseudo_srorder@{} : FullPseudoSemiRingOrder Zle Zlt. Proof. pose proof Z_ring. first [apply from_full_pseudo_ring_order@{UN UN UN UN UN UN UN Ularge}| apply from_full_pseudo_ring_order]; try apply _. apply apartness.strong_binary_setoid_morphism_commutative. Qed. Goal FullPseudoSemiRingOrder Zle Zlt. Proof. Fail exact Z_full_pseudo_srorder@{i}. Abort. Global Instance Z_to_ring@{} : IntegersToRing@{UN UNalt} Z. Proof. red. intros R ??????. eapply Z_rec. apply (PairT.to_ring_respects N). Defined. Lemma Z_to_ring_morphism' `{IsCRing B} : IsSemiRingPreserving (integers_to_ring Z B). Proof. split;split;red. - change (@sg_op B _) with (@plus B _); change (@sg_op Z _) with (@plus Z _). apply (Z_ind2 _). intros [pa na] [pb nb]. unfold integers_to_ring;simpl. rewrite !(preserves_plus (f:=naturals_to_semiring N B)). rewrite negate_plus_distr. ring_with_nat. - change (@mon_unit B _) with (@zero B _); change (@mon_unit Z _) with (@zero Z _). unfold integers_to_ring;simpl. rewrite (preserves_0 (f:=naturals_to_semiring N B)). rewrite negate_0,plus_0_r;trivial. - change (@sg_op B _) with (@mult B _); change (@sg_op Z _) with (@mult Z _). apply (Z_ind2 _). intros [pa na] [pb nb]. unfold integers_to_ring;simpl. rewrite !(preserves_plus (f:=naturals_to_semiring N B)). rewrite !(preserves_mult (f:=naturals_to_semiring N B)). rewrite (preserves_plus (f:=naturals_to_semiring N B)). rewrite !(preserves_mult (f:=naturals_to_semiring N B)). rewrite negate_plus_distr. rewrite negate_mult_distr_r,negate_mult_distr_l. rewrite <-(negate_mult_negate (naturals_to_semiring N B na) (naturals_to_semiring N B nb)). ring_with_nat. - change (@mon_unit B _) with (@one B _); change (@mon_unit Z _) with (@one Z _). unfold integers_to_ring;simpl. rewrite (preserves_1 (f:=naturals_to_semiring N B)). rewrite (preserves_0 (f:=naturals_to_semiring N B)). rewrite negate_0,plus_0_r;trivial. Qed. Instance Z_to_ring_morphism@{} `{IsCRing B} : IsSemiRingPreserving (integers_to_ring Z B) := ltac:(first [exact Z_to_ring_morphism'@{Ularge}| exact Z_to_ring_morphism'@{}]). Lemma Z_to_ring_unique@{} `{IsCRing B} (h : Z -> B) `{!IsSemiRingPreserving h} : forall x : Z, integers_to_ring Z B x = h x. Proof. pose proof Z_ring. apply (Z_ind _). intros [pa na];unfold integers_to_ring;simpl. rewrite Npair_splits. rewrite (preserves_plus (f:=h)),(preserves_negate (f:=h)). change (h (' pa)) with (Compose h (cast N Z) pa). change (h (' na)) with (Compose h (cast N Z) na). rewrite 2!(naturals_initial (h:=Compose h (cast N Z))). trivial. Qed. Global Instance Z_integers@{} : Integers Z. Proof. split;try apply _. - apply Z_ring. - apply @Z_to_ring_unique. Qed. Context `{!NatDistance N}. Lemma Z_abs_aux_0@{} : forall a b z : N, a + z = b -> z = 0 -> naturals_to_semiring N Z 0 = ' {| PairT.pos := a; PairT.neg := b |}. Proof. intros a b z E E'. rewrite (preserves_0 (A:=N)). rewrite E',plus_0_r in E. rewrite E. apply Z_path. red;simpl. apply plus_comm. Qed. Lemma Z_abs_aux_neg@{} : forall a b z : N, a + z = b -> naturals_to_semiring N Z z = - ' {| PairT.pos := a; PairT.neg := b |}. Proof. intros a b z E. rewrite <-(naturals.to_semiring_unique (cast N Z)). apply Z_path. red;simpl. rewrite plus_0_r,plus_comm;trivial. Qed. Lemma Z_abs_aux_pos@{} : forall a b z : N, b + z = a -> naturals_to_semiring N Z z = ' {| PairT.pos := a; PairT.neg := b |}. Proof. intros a b z E. rewrite <-(naturals.to_semiring_unique (cast N Z)). apply Z_path;red;simpl. rewrite plus_0_r,plus_comm;trivial. Qed. (* We use decidability of equality on N to make sure we always go left when the inputs are equal. Otherwise we would have to truncate IntAbs. *) Definition Z_abs_def@{} : forall x : PairT.T N, (exists n : N, naturals_to_semiring N Z n = ' x) |_| (exists n : N, naturals_to_semiring N Z n = - ' x). Proof. intros [a b]. destruct (nat_distance_sig a b) as [[z E]|[z E]]. - destruct (dec (z = 0)) as [E'|_]. + left. exists 0. apply Z_abs_aux_0 with z;trivial. + right. exists z. apply Z_abs_aux_neg;trivial. - left. exists z. apply Z_abs_aux_pos;trivial. Defined. Lemma Z_abs_respects' : forall (x y : PairT.T N) (E : PairT.equiv x y), transport (fun q : Z => (exists n : N, naturals_to_semiring N Z n = q) |_| (exists n : N, naturals_to_semiring N Z n = - q)) (Z_path E) (Z_abs_def x) = Z_abs_def y. Proof. intros [pa pb] [na nb] E. red in E; simpl in E. unfold Z_abs_def. destruct (nat_distance_sig pa pb) as [[z1 E1] | [z1 E1]];simpl. - destruct (dec (z1 = 0)) as [E2 | E2]. + rewrite Sum.transport_sum. rewrite Sigma.transport_sigma. destruct (nat_distance_sig na nb) as [[z2 E3] | [z2 E3]]; [destruct (dec (z2 = 0)) as [E4 | E4]|];simpl. * apply ap. apply Sigma.path_sigma_hprop;simpl. apply PathGroupoids.transport_const. * destruct E4. rewrite <-E1,<-E3,E2,plus_0_r,<-(plus_0_r (na+pa)) in E. rewrite plus_assoc,(plus_comm pa) in E. apply (left_cancellation plus _) in E. trivial. * apply ap. apply Sigma.path_sigma_hprop. simpl. rewrite PathGroupoids.transport_const. rewrite E2,plus_0_r in E1. rewrite <-E3,E1 in E. apply (left_cancellation plus (pb + nb)). rewrite plus_0_r. etransitivity;[apply E|]. ring_with_nat. + rewrite Sum.transport_sum,Sigma.transport_sigma. destruct (nat_distance_sig na nb) as [[z2 E3] | [z2 E3]]; [destruct (dec (z2 = 0)) as [E4 | E4]|];simpl. * destruct E2. rewrite E4,plus_0_r in E3;rewrite <-E1,<-E3 in E. apply (left_cancellation plus (pa+na)). rewrite (plus_comm pa na),plus_0_r,<-plus_assoc. rewrite (plus_comm na pa). symmetry;trivial. * apply ap. apply Sigma.path_sigma_hprop. simpl. rewrite PathGroupoids.transport_const. rewrite <-E1,<-E3 in E. apply (left_cancellation plus (pa + na)). rewrite <-(plus_assoc pa na z2),(plus_comm pa na),<-plus_assoc. symmetry;trivial. * destruct E2. rewrite <-E1,<-E3 in E. assert (Erw : nb + z2 + (pa + z1) = (pa + nb) + (z2 + z1)) by ring_with_nat. rewrite <-(plus_0_r (pa+nb)),Erw in E. apply (left_cancellation plus _),symmetry,naturals.zero_sum in E. apply E. - rewrite Sum.transport_sum,Sigma.transport_sigma. simpl. destruct (nat_distance_sig na nb) as [[z2 E3] | [z2 E3]]; [destruct (dec (z2 = 0)) as [E4 | E4]|];simpl. + apply ap. apply Sigma.path_sigma_hprop. simpl. rewrite PathGroupoids.transport_const. rewrite <-E1,<-E3,E4,plus_0_r in E. apply (left_cancellation plus (na+pb)). rewrite plus_0_r. path_via (pb + z1 + na). ring_with_nat. + destruct E4. rewrite <-E1,<-E3 in E. assert (Hrw : pb + z1 + (na + z2) = (na + pb) + (z1 + z2)) by ring_with_nat. rewrite <-(plus_0_r (na+pb)),Hrw in E. apply (left_cancellation _ _),naturals.zero_sum in E. apply E. + apply ap,Sigma.path_sigma_hprop. simpl. rewrite PathGroupoids.transport_const. rewrite <-E1,<-E3 in E. apply (left_cancellation plus (pb+nb)). path_via (pb + z1 + nb);[|path_via (nb + z2 + pb)];ring_with_nat. Qed. Lemma Z_abs' : IntAbs Z N. Proof. red. apply (Z_rect _ Z_abs_def). exact Z_abs_respects'. Qed. Global Instance Z_abs@{} : IntAbs@{UN UN UN UN UN UN UN UN UN UN UN UN UN UN UN UN UN} Z N := Z_abs'. Notation n_to_z := (naturals_to_semiring N Z). Definition zero_product_aux a b : n_to_z a * n_to_z b = 0 -> n_to_z a = 0 |_| n_to_z b = 0. Proof. rewrite <-rings.preserves_mult. rewrite <-!(naturals.to_semiring_unique (cast N Z)). intros E. change 0 with (' 0) in E. apply (injective _) in E. apply zero_product in E. destruct E as [E|E];rewrite E;[left|right];apply preserves_0. Qed. Lemma Z_zero_product' : ZeroProduct Z. Proof. intros x y E. destruct (int_abs_sig Z N x) as [[a Ea]|[a Ea]], (int_abs_sig Z N y) as [[b Eb]|[b Eb]]. - rewrite <-Ea,<-Eb in E. apply zero_product_aux in E. rewrite <-Ea,<-Eb. trivial. - apply (ap negate) in E. rewrite negate_mult_distr_r in E. rewrite <-Ea,<-Eb in E. rewrite negate_0 in E. apply zero_product_aux in E. destruct E as [E|E]. + left;rewrite <-Ea;trivial. + right. apply (injective negate). rewrite negate_0,<-Eb;trivial. - apply (ap negate) in E. rewrite negate_mult_distr_l in E. rewrite <-Ea,<-Eb in E. rewrite negate_0 in E. apply zero_product_aux in E. destruct E as [E|E]. + left. apply (injective negate). rewrite negate_0,<-Ea;trivial. + right;rewrite <-Eb;trivial. - rewrite <-negate_mult_negate,<-Ea,<-Eb in E. apply zero_product_aux in E. destruct E as [E|E]. + left. apply (injective negate). rewrite negate_0,<-Ea;trivial. + right. apply (injective negate). rewrite negate_0,<-Eb;trivial. Qed. Global Instance Z_zero_product@{} : ZeroProduct Z := ltac:(first [exact Z_zero_product'@{Ularge Ularge}| exact Z_zero_product'@{}]). End contents. Module Instances. Global Existing Instances T_set inject Tle_hprop Tlt_hprop Tapart_hprop Z_of_pair Z_of_N R_dec Z0 Z1 Z_plus Z_mult Z_negate Z_of_N_injective Zle ishprop_Zle Zle_cast_embedding Z_order Zle_dec Zlt ishprop_Zlt Z_strict_srorder Zlt_dec Zapart ishprop_Zapart Z_trivial_apart Z_to_ring Z_integers Z_abs Z_zero_product Z_of_N_morphism. End Instances. End NatPair. Coq-HoTT-9.0/theories/Classes/implementations/ne_list.v000066400000000000000000000102311474641544500232060ustar00rootroot00000000000000Require Import HoTT.Utf8Minimal HoTT.Spaces.List.Core HoTT.Basics.Overture Basics.Tactics HoTT.Spaces.Nat.Core. Local Open Scope nat_scope. Local Open Scope type_scope. Declare Scope ne_list_scope. Delimit Scope ne_list_scope with ne_list. Open Scope ne_list_scope. (** Nonempty list implementation [ne_list.ne_list]. *) Module ne_list. Section with_type. Context {T: Type}. (** A nonempty list. Below there is an implicit coercion [ne_list >-> list]. *) Inductive ne_list : Type := one: T → ne_list | cons: T → ne_list → ne_list. Fixpoint app (a b: ne_list): ne_list := match a with | one x => cons x b | cons x y => cons x (app y b) end. Fixpoint foldr {R} (u: T → R) (f: T → R → R) (a: ne_list): R := match a with | one x => u x | cons x y => f x (foldr u f y) end. Fixpoint foldr1 (f: T → T → T) (a: ne_list): T := match a with | one x => x | cons x y => f x (foldr1 f y) end. Definition head (l: ne_list): T := match l with one x => x | cons x _ => x end. Fixpoint to_list (l: ne_list): list T := match l with | one x => x :: nil | cons x xs => x :: to_list xs end. Fixpoint from_list (x: T) (xs: list T): ne_list := match xs with | nil => one x | List.Core.cons h t => cons x (from_list h t) end. Definition tail (l: ne_list): list T := match l with one _ => nil | cons _ x => to_list x end. Lemma decomp_eq (l: ne_list): l = from_list (head l) (tail l). Proof with auto. induction l... destruct l... cbn in *. rewrite IHl... Qed. Definition last: ne_list → T := foldr1 (fun x y => y). Fixpoint replicate_Sn (x: T) (n: nat): ne_list := match n with | 0 => one x | S n' => cons x (replicate_Sn x n') end. Fixpoint take (n: nat) (l: ne_list): ne_list := match l, n with | cons x xs, S n' => take n' xs | _, _ => one (head l) end. Fixpoint front (l: ne_list) : list T := match l with | one _ => nil | cons x xs => x :: front xs end. Lemma two_level_rect (P: ne_list → Type) (Pone: ∀ x, P (one x)) (Ptwo: ∀ x y, P (cons x (one y))) (Pmore: ∀ x y z, P z → (∀ y', P (cons y' z)) → P (cons x (cons y z))) : ∀ l, P l. Proof with auto. cut (∀ l, P l * ∀ x, P (cons x l)). - intros. apply X. - destruct l... revert t. induction l... intros. split. + apply IHl. + intro. apply Pmore; intros; apply IHl. Qed. Lemma tail_length (l: ne_list) : S (length (List.Core.tail (to_list l))) = length (to_list l). Proof. destruct l; reflexivity. Qed. End with_type. Arguments ne_list : clear implicits. Fixpoint tails {T} (l: ne_list T): ne_list (ne_list T) := match l with | one x => one (one x) | cons x y => cons l (tails y) end. Lemma tails_are_shorter {T} (y x: ne_list T): InList x (to_list (tails y)) → leq (length (to_list x)) (length (to_list y)). Proof. induction y; cbn. - intros [[] | C]. + constructor. + elim C. - intros [[] | C]. + exact _. + by apply leq_succ_r, IHy. Qed. Fixpoint map {A B} (f: A → B) (l: ne_list A): ne_list B := match l with | one x => one (f x) | cons h t => cons (f h) (map f t) end. Lemma list_map {A B} (f: A → B) (l: ne_list A) : to_list (map f l) = List.Core.list_map f (to_list l). Proof. induction l. - reflexivity. - cbn. rewrite <- IHl. reflexivity. Qed. Fixpoint inits {A} (l: ne_list A): ne_list (ne_list A) := match l with | one x => one (one x) | cons h t => cons (one h) (map (cons h) (inits t)) end. Fixpoint zip {A B: Type} (l: ne_list A) (m: ne_list B) : ne_list (A * B) := match l with | one a => one (a, head m) | cons a l => match m with | one b => one (a, b) | cons b m => cons (a, b) (zip l m) end end. Module notations. Global Notation ne_list := ne_list. Global Notation "[: x :]" := (one x) : ne_list_scope. Global Notation "[: x ; .. ; y ; z :]" := (cons x .. (cons y (one z)) ..) : ne_list_scope. Global Infix ":::" := cons : ne_list_scope. End notations. End ne_list. Global Coercion ne_list.to_list : ne_list.ne_list >-> list. Coq-HoTT-9.0/theories/Classes/implementations/peano_naturals.v000066400000000000000000000455771474641544500246110ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.naturals HoTT.Classes.interfaces.orders HoTT.Classes.theory.rings HoTT.Classes.orders.semirings HoTT.Classes.theory.apartness. Local Set Universe Minimization ToSet. (* This should go away one Coq has universe cumulativity through inductives. *) Section nat_lift. Universe N. (* It's important that the universe [N] be free. Occasionally, Coq will choose universe variables in proofs that force [N] to be [Set]. To pinpoint where this happens, you can add the line [Constraint Set < N.] here, and see what fails below. *) Let natpaths := @paths@{N} nat. Arguments natpaths (_ _)%_nat_scope. Infix "=N=" := natpaths. Definition natpaths_symm : Symmetric@{N N} natpaths. Proof. unfold natpaths; apply _. Defined. Global Instance nat_0: Zero@{N} nat := 0%nat. Global Instance nat_1: One@{N} nat := 1%nat. Global Instance nat_plus: Plus@{N} nat := Nat.Core.nat_add. Notation mul := Nat.Core.nat_mul. Global Instance nat_mult: Mult@{N} nat := Nat.Core.nat_mul. Ltac simpl_nat := change (@plus nat _) with Nat.Core.nat_add; change (@mult nat _) with Nat.Core.nat_mul; simpl; change Nat.Core.nat_add with (@plus nat Nat.Core.nat_add); change Nat.Core.nat_mul with (@mult nat Nat.Core.nat_mul). (** [0 + a =N= a] *) Local Instance add_0_l : LeftIdentity@{N N} (plus : Plus nat) 0 := fun _ => idpath. Definition add_S_l a b : S a + b =N= S (a + b) := idpath. (** [a + 0 =N= a] *) Local Instance add_0_r : RightIdentity@{N N} (plus : Plus nat) (zero : Zero nat). Proof. intros a; induction a as [| a IHa]. - reflexivity. - apply (ap S), IHa. Qed. Lemma add_S_r : forall a b, a + S b =N= S (a + b). Proof. intros a b; induction a as [| a IHa]. - reflexivity. - apply (ap S), IHa. Qed. (** [forall a b c : nat, a + (b + c) = (a + b) + c]. The RHS is written [a + b + c]. *) Local Instance add_assoc : Associative@{N} (plus : Plus nat). Proof. intros a b c; induction a as [| a IHa]. - reflexivity. - change (S (a + (b + c)) = S (a + b + c)). apply (ap S), IHa. Qed. Local Instance add_comm : Commutative@{N N} (plus : Plus nat). Proof. intros a b; induction a as [| a IHa]. - rhs apply add_0_r. reflexivity. - rhs apply add_S_r. apply (ap S), IHa. Qed. Local Instance mul_0_l : LeftAbsorb@{N N} (mult : Mult nat) (zero : Zero nat) := fun _ => idpath. Definition mul_S_l a b : (S a) * b =N= b + a * b := idpath. (** [1 * a =N= a]. *) Local Instance mul_1_l : LeftIdentity@{N N} (mult : Mult nat) (one : One nat) := add_0_r. Local Instance mul_0_r : RightAbsorb@{N N} (mult : Mult nat) (zero : Zero nat). Proof. intros a; induction a as [| a IHa]. - reflexivity. - change (a * 0 = 0). exact IHa. Qed. Lemma mul_S_r a b : a * S b =N= a + a * b. Proof. induction a as [| a IHa]. - reflexivity. - change (S (b + a * S b) = S (a + (b + a * b))). apply (ap S). rhs rapply add_assoc. rhs rapply (ap (fun x => x + _) (add_comm _ _)). rhs rapply (add_assoc _ _ _)^. exact (ap (plus b) IHa). Qed. (** [a * 1 =N= a]. *) Local Instance mul_1_r : RightIdentity@{N N} (mult : Mult nat) (one : One nat). Proof. intros a. lhs nrapply mul_S_r. lhs nrapply (ap _ (mul_0_r a)). apply add_0_r. Qed. Local Instance mul_comm : Commutative@{N N} (mult : Mult nat). Proof. intros a b; induction a as [| a IHa]. - rhs apply mul_0_r. reflexivity. - rhs apply mul_S_r. change (b + a * b = b + b * a). apply (ap (fun x => b + x)), IHa. Qed. (** [a * (b + c) =N= a * b + a * c]. *) Local Instance add_mul_distr_l : LeftDistribute@{N} (mult : Mult nat) (plus : Plus nat). Proof. intros a b c; induction a as [| a IHa]. - reflexivity. - change ((b + c) + a * (b + c) = (b + a * b) + (c + a * c)). lhs rapply (add_assoc _ _ _)^. rhs rapply (add_assoc _ _ _)^. apply (ap (plus b)). rhs rapply add_assoc. rhs rapply (ap (fun x => x + _) (add_comm _ _)). rhs rapply (add_assoc _ _ _)^. apply (ap (plus c)), IHa. Qed. (** [(a + b) * c =N= a * c + b * c]. This also follows from [plus_mult_distr_r], which currently requires that we already have a semiring. It should be adjusted to not require associativity. *) Local Instance add_mul_distr_r : RightDistribute@{N} (mult : Mult nat) (plus : Plus nat). Proof. intros a b c. lhs apply mul_comm. lhs apply add_mul_distr_l. apply ap011; apply mul_comm. Defined. Local Instance mul_assoc : Associative@{N} (mult : Mult nat). Proof. intros a b c; induction a as [| a IHa]. - reflexivity. - simpl_nat. rhs apply add_mul_distr_r. apply ap, IHa. Qed. Global Instance S_neq_0 x : PropHolds (~ (S x =N= 0)). Proof. intros E. change ((fun a => match a with S _ => Unit | 0%nat => Empty end) 0). eapply transport. - exact E. - split. Qed. Definition pred x := match x with | 0%nat => 0 | S k => k end. Global Instance S_inj : IsInjective@{N N} S := { injective := fun a b E => ap pred E }. (** This is also in Spaces.Nat.Core. *) Global Instance nat_dec: DecidablePaths@{N} nat. Proof. hnf. apply (nat_rect@{N} (fun x => forall y, _)). - intros [|b]. + left;reflexivity. + right;apply symmetric_neq,S_neq_0. - intros a IHa [|b]. + right;apply S_neq_0. + destruct (IHa b). * left. apply ap;trivial. * right;intros E. apply (injective S) in E. auto. Defined. Global Instance nat_set : IsTrunc@{N} 0 nat. Proof. apply hset_pathcoll, pathcoll_decpaths, nat_dec. Qed. Instance nat_semiring : IsSemiCRing@{N} nat. Proof. repeat (split; try exact _). Qed. (* Add Ring nat: (rings.stdlib_semiring_theory nat). *) Lemma O_nat_0 : O =N= 0. Proof. reflexivity. Qed. Lemma S_nat_plus_1 x : S x =N= x + 1. Proof. rewrite add_comm. reflexivity. Qed. Lemma S_nat_1_plus x : S x =N= 1 + x. Proof. reflexivity. Qed. Lemma nat_induction (P : nat -> Type) : P 0 -> (forall n, P n -> P (1 + n)) -> forall n, P n. Proof. apply nat_rect. Qed. Lemma plus_eq_zero : forall a b : nat, a + b =N= 0 -> a =N= 0 /\ b =N= 0. Proof. intros [|a];[intros [|b];auto|]. - intros E. destruct (S_neq_0 _ E). - intros ? E. destruct (S_neq_0 _ E). Qed. Lemma mult_eq_zero : forall a b : nat, a * b =N= 0 -> a =N= 0 |_| b =N= 0. Proof. intros [|a] [|b];auto. - intros _;right;reflexivity. - simpl_nat. intros E. destruct (S_neq_0 _ E). Defined. Instance nat_zero_divisors : NoZeroDivisors nat. Proof. intros x [Ex [y [Ey1 Ey2]]]. apply mult_eq_zero in Ey2. destruct Ey2;auto. Qed. Instance nat_plus_cancel_l : forall z:nat, LeftCancellation@{N} plus z. Proof. red. intros a;induction a as [|a IHa];simpl_nat;intros b c E. - trivial. - apply IHa. apply (injective S). assumption. Qed. Instance nat_mult_cancel_l : forall z : nat, PropHolds (~ (z =N= 0)) -> LeftCancellation@{N} (.*.) z. Proof. unfold PropHolds. unfold LeftCancellation. intros a Ea b c E;revert b c a Ea E. induction b as [|b IHb];intros [|c];simpl_nat;intros a Ea E. - reflexivity. - rewrite mul_0_r in E. rewrite mul_S_r in E;apply symmetry in E. apply plus_eq_zero in E. destruct (Ea (fst E)). - rewrite mul_0_r,mul_S_r in E. apply plus_eq_zero in E. destruct (Ea (fst E)). - rewrite 2!mul_S_r in E. apply (left_cancellation _ _) in E. apply ap. apply IHb with a;trivial. Qed. (* Order *) Global Instance nat_le: Le@{N N} nat := Nat.Core.leq. Global Instance nat_lt: Lt@{N N} nat := Nat.Core.lt. Lemma le_plus : forall n k, n <= k + n. Proof. induction k. - apply Nat.Core.leq_refl. - simpl_nat. constructor. assumption. Qed. Lemma le_exists : forall n m : nat, iff@{N N N} (n <= m) (sig@{N N} (fun k => m =N= k + n)). Proof. intros n m;split. - intros E;induction E as [|m E IH]. + exists 0;split. + destruct IH as [k IH]. exists (S k). rewrite IH;reflexivity. - intros [k Hk]. rewrite Hk. apply le_plus. Qed. Lemma zero_least : forall a, 0 <= a. Proof. induction a;constructor;auto. Qed. Lemma le_S_S : forall a b : nat, iff@{N N N} (a <= b) (S a <= S b). Proof. intros. etransitivity;[apply le_exists|]. etransitivity;[|apply symmetry,le_exists]. split;intros [k E];exists k. - rewrite E,add_S_r. reflexivity. - rewrite add_S_r in E;apply (injective _) in E. trivial. Qed. Lemma lt_0_S : forall a : nat, 0 < S a. Proof. intros. apply le_S_S. apply zero_least. Qed. Lemma le_S_either : forall a b, a <= S b -> a <= b |_| a = S b. Proof. intros [|a] b. - intros;left;apply zero_least. - intros E. apply (snd (le_S_S _ _)) in E. destruct E as [|b E];auto. left. apply le_S_S. trivial. Defined. Lemma le_lt_dec : forall a b : nat, a <= b |_| b < a. Proof. induction a as [|a IHa]. - intros;left;apply zero_least. - intros [|b]. + right. apply lt_0_S. + destruct (IHa b). * left. apply le_S_S;trivial. * right. apply le_S_S. trivial. Defined. Lemma not_lt_0 : forall a, ~ (a < 0). Proof. intros a E. apply le_exists in E. destruct E as [k E]. apply natpaths_symm,plus_eq_zero in E. apply (S_neq_0 _ (snd E)). Qed. Lemma lt_le : forall a b, a < b -> a <= b. Proof. intros. destruct b. - destruct (not_lt_0 a). trivial. - constructor. apply le_S_S. trivial. Qed. Local Instance nat_le_total : TotalRelation@{N N} (_:Le nat). Proof. hnf. intros a b. destruct (le_lt_dec a b);[left|right]. - trivial. - apply lt_le;trivial. Qed. Local Instance nat_lt_irrefl : Irreflexive@{N N} (_:Lt nat). Proof. hnf. intros x E. apply le_exists in E. destruct E as [k E]. apply (S_neq_0 k). apply (left_cancellation@{N} (+) x). fold natpaths. rewrite add_0_r, add_S_r,<-add_S_l. rewrite add_comm. apply natpaths_symm,E. Qed. Local Instance nat_le_hprop : is_mere_relation nat le. Proof. intros m n;apply Trunc.hprop_allpath. generalize (idpath (S n) : S n =N= S n). generalize n at 2 3 4 5. change (forall n0 : nat, S n =N= S n0 -> forall le_mn1 le_mn2 : m <= n0, le_mn1 = le_mn2). induction (S n) as [|n0 IHn0]. - intros ? E;destruct (S_neq_0 _ (natpaths_symm _ _ E)). - clear n; intros n H. apply (injective S) in H. rewrite <- H; intros le_mn1 le_mn2; clear n H. pose (def_n2 := idpath n0); path_via (paths_ind n0 (fun n _ => le m _) le_mn2 n0 def_n2). generalize def_n2; revert le_mn1 le_mn2. generalize n0 at 1 4 5 8; intros n1 le_mn1. destruct le_mn1; intros le_mn2; destruct le_mn2. + intros def_n0. rewrite (Trunc.path_ishprop def_n0 idpath). simpl. reflexivity. + intros def_n0; generalize le_mn2; rewrite <-def_n0; intros le_mn0. destruct (irreflexivity nat_lt _ le_mn0). + intros def_n0. destruct (irreflexivity nat_lt m0). rewrite def_n0 in le_mn1;trivial. + intros def_n0. pose proof (injective S _ _ def_n0) as E. destruct E. rewrite (Trunc.path_ishprop def_n0 idpath). simpl. apply ap. apply IHn0;trivial. Qed. Local Instance nat_le_po : PartialOrder nat_le. Proof. repeat split. - apply _. - apply _. - hnf;intros; constructor. - hnf. intros a b c E1 E2. apply le_exists in E1;apply le_exists in E2. destruct E1 as [k1 E1], E2 as [k2 E2]. rewrite E2,E1,add_assoc. apply le_plus. - hnf. intros a b E1 E2. apply le_exists in E1;apply le_exists in E2. destruct E1 as [k1 E1], E2 as [k2 E2]. assert (k1 + k2 = 0) as E. + apply (left_cancellation (+) a). rhs rapply plus_0_r. path_via (k2 + b). rewrite E1. rewrite (plus_comm a), (plus_assoc k2), (plus_comm k2). reflexivity. + apply plus_eq_zero in E. destruct E as [Ek1 Ek2]. rewrite Ek2,plus_0_l in E2. trivial. Qed. Local Instance nat_strict : StrictOrder (_:Lt nat). Proof. split. - cbv; exact _. - apply _. - hnf. intros a b c E1 E2. apply le_exists;apply le_exists in E1;apply le_exists in E2. destruct E1 as [k1 E1], E2 as [k2 E2]. exists (S (k1+k2)). rewrite E2,E1. rewrite !add_S_r,add_S_l. rewrite (add_assoc k2), (add_comm k2). reflexivity. Qed. Instance nat_trichotomy : Trichotomy@{N N i} (lt:Lt nat). Proof. hnf. fold natpaths. intros a b. destruct (le_lt_dec a b) as [[|]|E];auto. - right;left;split. - left. apply le_S_S. trivial. Qed. Global Instance nat_apart : Apart@{N N} nat := fun n m => n < m |_| m < n. Instance nat_apart_mere : is_mere_relation nat nat_apart. Proof. intros;apply ishprop_sum;try apply _. intros E1 E2. apply (irreflexivity nat_lt x). transitivity y;trivial. Qed. Instance decidable_nat_apart x y : Decidable (nat_apart x y). Proof. rapply decidable_sum@{N N N}; apply Nat.Core.decidable_lt. Defined. Global Instance nat_trivial_apart : TrivialApart nat. Proof. split. - apply _. - intros a b;split;intros E. + destruct E as [E|E];apply irrefl_neq in E;trivial. apply symmetric_neq;trivial. + hnf. destruct (trichotomy _ a b) as [?|[?|?]];auto. destruct E;trivial. Qed. Lemma nat_not_lt_le : forall a b, ~ (a < b) -> b <= a. Proof. intros ?? E. destruct (le_lt_dec b a);auto. destruct E;auto. Qed. Lemma nat_lt_not_le : forall a b : nat, a < b -> ~ (b <= a). Proof. intros a b E1 E2. apply le_exists in E1;apply le_exists in E2. destruct E1 as [k1 E1], E2 as [k2 E2]. apply (S_neq_0 (k1 + k2)). apply (left_cancellation (+) a). fold natpaths. rewrite add_0_r. rewrite E1 in E2. rewrite add_S_r;rewrite !add_S_r in E2. rewrite (add_assoc a), (add_comm a), <-(add_assoc k1), (add_comm a). rewrite (add_assoc k1), (add_comm k1), <-(add_assoc k2). apply natpaths_symm,E2. Qed. Global Instance nat_le_dec: forall x y : nat, Decidable (x ≤ y). Proof. intros a b. destruct (le_lt_dec a b). - left;trivial. - right. apply nat_lt_not_le. trivial. Defined. Lemma S_gt_0 : forall a, 0 < S a. Proof. intros;apply le_S_S,zero_least. Qed. Lemma nonzero_gt_0 : forall a, ~ (a =N= 0) -> 0 < a. Proof. intros [|a] E. - destruct E;split. - apply S_gt_0. Qed. Lemma nat_le_lt_trans : forall a b c : nat, a <= b -> b < c -> a < c. Proof. intros a b c E1 E2. apply le_exists in E1;apply le_exists in E2. destruct E1 as [k1 E1],E2 as [k2 E2];rewrite E2,E1. rewrite add_S_r,add_assoc. apply le_S_S,le_plus. Qed. Lemma lt_strong_cotrans : forall a b : nat, a < b -> forall c, a < c |_| c < b. Proof. intros a b E1 c. destruct (le_lt_dec c a) as [E2|E2]. - right. apply nat_le_lt_trans with a;trivial. - left;trivial. Defined. Lemma nat_full' : FullPseudoSemiRingOrder nat_le nat_lt. Proof. split;[apply _|split|]. - split;try apply _. + intros a b [E1 E2]. destruct (irreflexivity lt a). transitivity b;trivial. + hnf. intros a b E c;apply tr;apply lt_strong_cotrans;trivial. + reflexivity. - intros a b E. apply nat_not_lt_le,le_exists in E. destruct E as [k E];exists k;rewrite plus_comm;auto. - split. + intros a b E. apply le_exists in E;destruct E as [k Hk]. rewrite Hk. rewrite add_S_r,<-add_S_l. rewrite plus_assoc,(plus_comm z (S k)), <-plus_assoc. apply le_S_S,le_plus. + intros a b E. apply le_exists in E;destruct E as [k E]. rewrite <-add_S_r,plus_assoc,(plus_comm k z),<-plus_assoc in E. apply (left_cancellation plus _) in E. rewrite E;apply le_plus. - intros ???? E. apply trivial_apart in E. destruct (dec (apart x₁ x₂)) as [?|ex];apply tr;auto. right. apply tight_apart in ex. apply trivial_apart. intros ey. apply E. apply ap011;trivial. - unfold PropHolds. intros a b Ea Eb. apply nonzero_gt_0. intros E. apply mult_eq_zero in E. destruct E as [E|E];[rewrite E in Ea|rewrite E in Eb]; apply (irreflexivity lt 0);trivial. - intros a b;split. + intros E1 E2. apply nat_lt_not_le in E2. auto. + intros E. destruct (le_lt_dec a b);auto. destruct E;auto. Qed. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) Definition nat_full@{} := ltac:(first[exact nat_full'@{Ularge Ularge}| exact nat_full'@{Ularge Ularge N}| exact nat_full'@{}]). Local Existing Instance nat_full. Lemma le_nat_max_l n m : n <= Nat.Core.nat_max n m. Proof. revert m. induction n as [|n' IHn]; intros m; induction m as [|m' IHm]; try reflexivity; cbn. - apply zero_least. - apply le_S_S. exact (IHn m'). Qed. Lemma le_nat_max_r n m : m <= Nat.Core.nat_max n m. Proof. revert m. induction n as [|n' IHn]; intros m; induction m as [|m' IHm]; try reflexivity; cbn. - apply zero_least. - apply le_S_S. exact (IHn m'). Qed. Instance S_embedding : OrderEmbedding S. Proof. split. - intros ??;apply le_S_S. - intros ??;apply le_S_S. Qed. Global Instance S_strict_embedding : StrictOrderEmbedding S. Proof. split;apply _. Qed. Global Instance nat_naturals_to_semiring : NaturalsToSemiRing@{N i} nat := fun _ _ _ _ _ _ => fix f (n: nat) := match n with 0%nat => 0 | 1%nat => 1 | S n' => 1 + f n' end. Section for_another_semiring. Universe U. Context {R:Type@{U} } `{IsSemiCRing@{U} R}. Notation toR := (naturals_to_semiring nat R). (* Add Ring R: (rings.stdlib_semiring_theory R). *) Local Definition f_S : forall x, toR (S x) = 1 + toR x. Proof. intros [|x]. - symmetry;apply plus_0_r. - reflexivity. Defined. Local Definition f_preserves_plus a a': toR (a + a') = toR a + toR a'. Proof. induction a as [|a IHa]. - change (toR a' = 0 + toR a'). apply symmetry,plus_0_l. - change (toR (S (a + a')) = toR (S a) + toR a'). rewrite !f_S,IHa. apply associativity. Qed. Local Definition f_preserves_mult a a': toR (a * a') = toR a * toR a'. Proof. induction a as [|a IHa]. - change (0 = 0 * toR a'). rewrite mult_0_l. reflexivity. - rewrite f_S. change (toR (a' + a * a') = (1 + toR a) * toR a'). rewrite f_preserves_plus, IHa. rewrite plus_mult_distr_r,mult_1_l. reflexivity. Qed. Global Instance nat_to_sr_morphism : IsSemiRingPreserving (naturals_to_semiring nat R). Proof. split; split. - rapply f_preserves_plus. - reflexivity. - rapply f_preserves_mult. - reflexivity. Defined. Lemma toR_unique (h : nat -> R) `{!IsSemiRingPreserving h} x : naturals_to_semiring nat R x = h x. Proof. induction x as [|n E]. + change (0 = h 0). apply symmetry,preserves_0. + rewrite f_S. change (1 + naturals_to_semiring nat R n = h (1+n)). rewrite (preserves_plus (f:=h)). rewrite E. apply ap10,ap,symmetry,preserves_1. Qed. End for_another_semiring. Lemma nat_naturals : Naturals@{N N N N N N N i} nat. Proof. split;try apply _. intros;apply toR_unique, _. Qed. Global Existing Instance nat_naturals. Global Instance nat_cut_minus: CutMinus@{N} nat := Nat.Core.nat_sub. Lemma plus_minus : forall a b, cut_minus (a + b) b =N= a. Proof. unfold cut_minus,nat_cut_minus. intros a b;revert a;induction b as [|b IH]. - intros [|a];simpl;try split. apply ap,add_0_r. - intros [|a]. + simpl. pose proof (IH 0) as E. rewrite add_0_l in E. exact E. + simpl. change nat_plus with plus. rewrite add_S_r,<-add_S_l;apply IH. Qed. Lemma le_plus_minus : forall n m : nat, n <= m -> m =N= (n + (cut_minus m n)). Proof. intros n m E. apply le_exists in E. destruct E as [k E];rewrite E. rewrite plus_minus. apply add_comm. Qed. Lemma minus_ge : forall a b, a <= b -> cut_minus a b =N= 0. Proof. unfold cut_minus,nat_cut_minus. intros a b;revert a;induction b as [|b IH];intros [|a];simpl. - split. - intros E;destruct (not_lt_0 _ E). - split. - intros E. apply IH;apply le_S_S,E. Qed. Global Instance nat_cut_minus_spec : CutMinusSpec@{N N} nat nat_cut_minus. Proof. split. - intros x y E. rewrite add_comm. symmetry. apply (le_plus_minus _ _ E). - apply minus_ge. Qed. End nat_lift. Coq-HoTT-9.0/theories/Classes/implementations/pointwise.v000066400000000000000000000041371474641544500236020ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra. (** If [B] is a (bounded) lattice, then so is [A -> B], pointwise. This relies on functional extensionality. *) Section contents. Context `{Funext}. Context {A B : Type}. Context `{BJoin : Join B}. Context `{BMeet : Meet B}. Context `{BBottom : Bottom B}. Context `{BTop : Top B}. Global Instance bot_fun : Bottom (A -> B) := fun _ => ⊥. Global Instance top_fun : Top (A -> B) := fun _ => ⊤. Global Instance join_fun : Join (A -> B) := fun (f g : A -> B) (a : A) => (f a) ⊔ (g a). Global Instance meet_fun : Meet (A -> B) := fun (f g : A -> B) (a : A) => (f a) ⊓ (g a). (** Try to solve some of the lattice obligations automatically *) Create HintDb lattice_hints. #[local] Hint Resolve associativity absorption commutativity | 1 : lattice_hints. Local Ltac reduce_fun := compute; intros; apply path_forall; intro. Global Instance lattice_fun `{!IsLattice B} : IsLattice (A -> B). Proof. repeat split; try apply _; reduce_fun. 1,4: apply associativity. 1,3: apply commutativity. 1,2: apply binary_idempotent. 1,2: apply absorption. Defined. Instance boundedjoinsemilattice_fun `{!IsBoundedJoinSemiLattice B} : IsBoundedJoinSemiLattice (A -> B). Proof. repeat split; try apply _; reduce_fun. * apply associativity. * apply left_identity. * apply right_identity. * apply commutativity. * apply binary_idempotent. Defined. Instance boundedmeetsemilattice_fun `{!IsBoundedMeetSemiLattice B} : IsBoundedMeetSemiLattice (A -> B). Proof. repeat split; try apply _; reduce_fun. * apply associativity. * apply left_identity. * apply right_identity. * apply commutativity. * apply binary_idempotent. Defined. Global Instance boundedlattice_fun `{!IsBoundedLattice B} : IsBoundedLattice (A -> B). Proof. repeat split; try apply _; reduce_fun; apply absorption. Defined. End contents. #[export] Hint Resolve associativity absorption commutativity | 1 : lattice_hints. Coq-HoTT-9.0/theories/Classes/interfaces/000077500000000000000000000000001474641544500203005ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Classes/interfaces/abstract_algebra.v000066400000000000000000000475541474641544500237660ustar00rootroot00000000000000Require Export Basics.Classes Basics.Overture. Require Import Spaces.Nat.Core. Require Export HoTT.Classes.interfaces.canonical_names. Require Import Modalities.ReflectiveSubuniverse. Local Set Polymorphic Inductive Cumulativity. Generalizable Variables A B C f g x y. (* For various structures we omit declaration of substructures. For example, if we say: Class Setoid_Morphism := { setoidmor_a : Setoid A ; setoidmor_b : Setoid B ; sm_proper : Proper ((=) ==> (=)) f }. #[export] Existing Instances setoidmor_a setoidmor_b sm_proper. then each time a Setoid instance is required, Coq will try to prove that a Setoid_Morphism exists. This obviously results in an enormous blow-up of the search space. Moreover, one should be careful to declare a Setoid_Morphisms as a substructure. Consider [f t1 t2], now if we want to perform setoid rewriting in [t2] Coq will first attempt to prove that [f t1] is Proper, for which it will attempt to prove [Setoid_Morphism (f t1)]. If many structures declare Setoid_Morphism as a substructure, setoid rewriting will become horribly slow. *) (* An unbundled variant of the former CoRN CSetoid. We do not include a proof that A is a Setoid because it can be derived. *) Class IsApart A {Aap : Apart A} : Type := { apart_set : IsHSet A ; apart_mere : is_mere_relation _ apart ; apart_symmetric : Symmetric (≶) ; apart_cotrans : CoTransitive (≶) ; tight_apart : forall x y, ~(x ≶ y) <-> x = y }. #[export] Existing Instances apart_set apart_mere apart_symmetric apart_cotrans. Global Instance apart_irrefl `{IsApart A} : Irreflexive (≶). Proof. intros x ap. apply (tight_apart x x). - reflexivity. - assumption. Qed. Arguments tight_apart {A Aap IsApart} _ _. Section setoid_morphisms. Context {A B} {Aap : Apart A} {Bap : Apart B} (f : A -> B). Class StrongExtensionality := strong_extensionality : forall x y, f x ≶ f y -> x ≶ y. End setoid_morphisms. (* HOTT TODO check if this is ok/useful *) #[export] Hint Extern 4 (?f _ = ?f _) => eapply (ap f) : core. Section setoid_binary_morphisms. Context {A B C} {Aap: Apart A} {Bap : Apart B} {Cap : Apart C} (f : A -> B -> C). Class StrongBinaryExtensionality := strong_binary_extensionality : forall x₁ y₁ x₂ y₂, f x₁ y₁ ≶ f x₂ y₂ -> hor (x₁ ≶ x₂) (y₁ ≶ y₂). End setoid_binary_morphisms. (* Since apartness usually only becomes relevant when considering fields (e.g. the real numbers), we do not include it in the lower part of the algebraic hierarchy (as opposed to CoRN). *) Section upper_classes. Universe i. Context (A : Type@{i}). Local Open Scope mc_mult_scope. Class IsSemiGroup {Aop: SgOp A} := { sg_set : IsHSet A ; sg_ass : Associative (.*.) }. #[export] Existing Instances sg_set sg_ass. Class IsCommutativeSemiGroup {Aop : SgOp A} := { comsg_sg : @IsSemiGroup (.*.) ; comsg_comm : Commutative (.*.) }. #[export] Existing Instances comsg_sg comsg_comm. Class IsSemiLattice {Aop : SgOp A} := { semilattice_sg : @IsCommutativeSemiGroup (.*.) ; semilattice_idempotent : BinaryIdempotent (.*.)}. #[export] Existing Instances semilattice_sg semilattice_idempotent. Class IsMonoid {Aop : SgOp A} {Aunit : MonUnit A} := { monoid_semigroup : IsSemiGroup ; monoid_left_id : LeftIdentity (.*.) mon_unit ; monoid_right_id : RightIdentity (.*.) mon_unit }. #[export] Existing Instances monoid_semigroup monoid_left_id monoid_right_id. Class IsCommutativeMonoid {Aop : SgOp A} {Aunit : MonUnit A} := { commonoid_mon : @IsMonoid (.*.) Aunit ; commonoid_commutative : Commutative (.*.) }. #[export] Existing Instances commonoid_mon commonoid_commutative. Class IsGroup {Aop : SgOp A} {Aunit : MonUnit A} {Ainv : Inverse A} := { group_monoid : @IsMonoid (.*.) mon_unit ; inverse_l : LeftInverse (.*.) (^) mon_unit ; inverse_r: RightInverse (.*.) (^) mon_unit }. #[export] Existing Instances group_monoid inverse_l inverse_r. Class IsBoundedSemiLattice {Aop : SgOp A} {Aunit : MonUnit A} := { bounded_semilattice_mon : @IsCommutativeMonoid (.*.) Aunit ; bounded_semilattice_idempotent : BinaryIdempotent (.*.)}. #[export] Existing Instances bounded_semilattice_mon bounded_semilattice_idempotent. Local Close Scope mc_mult_scope. Class IsAbGroup {Aop : SgOp A} {Aunit : MonUnit A} {Ainv : Inverse A} := { abgroup_group : @IsGroup Aop Aunit Ainv ; abgroup_commutative : Commutative Aop }. #[export] Existing Instances abgroup_group abgroup_commutative. Context {Aplus : Plus A} {Amult : Mult A} {Azero : Zero A} {Aone : One A}. Class IsSemiCRing := { semiplus_monoid : @IsCommutativeMonoid (+) 0 ; semimult_monoid : @IsCommutativeMonoid (.*.) 1 ; semiring_distr : LeftDistribute (.*.) (+) ; semiring_left_absorb : LeftAbsorb (.*.) 0 }. #[export] Existing Instances semiplus_monoid semimult_monoid semiring_distr semiring_left_absorb. Context {Anegate : Negate A}. Class IsRing := { ring_abgroup :: @IsAbGroup (+) 0 (-) ; ring_monoid :: @IsMonoid (.*.) 1 ; ring_dist_left :: LeftDistribute (.*.) (+) ; ring_dist_right :: RightDistribute (.*.) (+) }. Class IsCRing := { cring_group : @IsAbGroup (+) 0 (-) ; cring_monoid : @IsCommutativeMonoid (.*.) 1 ; cring_dist : LeftDistribute (.*.) (+) }. #[export] Existing Instances cring_group cring_monoid cring_dist. Global Instance isring_iscring : IsCRing -> IsRing. Proof. intros H. econstructor; try exact _. intros a b c. lhs rapply commutativity. lhs rapply distribute_l. f_ap; apply commutativity. Defined. Class IsIntegralDomain := { intdom_ring : IsCRing ; intdom_nontrivial : PropHolds (not (1 = 0)) ; intdom_nozeroes : NoZeroDivisors A }. #[export] Existing Instances intdom_nozeroes. (* We do not include strong extensionality for (-) and (/) because it can de derived *) Class IsField {Aap: Apart A} {Arecip: Recip A} := { field_ring : IsCRing ; field_apart : IsApart A ; field_plus_ext : StrongBinaryExtensionality (+) ; field_mult_ext : StrongBinaryExtensionality (.*.) ; field_nontrivial : PropHolds (1 ≶ 0) ; recip_inverse : forall x, x.1 // x = 1 }. #[export] Existing Instances field_ring field_apart field_plus_ext field_mult_ext. (* We let /0 = 0 so properties as Injective (/), f (/x) = / (f x), / /x = x, /x * /y = /(x * y) hold without any additional assumptions *) Class IsDecField {Adec_recip : DecRecip A} := { decfield_ring : IsCRing ; decfield_nontrivial : PropHolds (1 <> 0) ; dec_recip_0 : /0 = 0 ; dec_recip_inverse : forall x, x <> 0 -> x / x = 1 }. #[export] Existing Instances decfield_ring. Class FieldCharacteristic@{j} {Aap : Apart@{i j} A} (k : nat) : Type@{j} := field_characteristic : forall n : nat, Nat.Core.lt 0 n -> iff@{j j j} (forall m : nat, not@{j} (paths@{Set} n (nat_mul k m))) (@apart A Aap (nat_iter n (1 +) 0) 0). End upper_classes. (* Due to bug #2528 *) #[export] Hint Extern 4 (PropHolds (1 <> 0)) => eapply @intdom_nontrivial : typeclass_instances. #[export] Hint Extern 5 (PropHolds (1 ≶ 0)) => eapply @field_nontrivial : typeclass_instances. #[export] Hint Extern 5 (PropHolds (1 <> 0)) => eapply @decfield_nontrivial : typeclass_instances. (* For a strange reason IsCRing instances of Integers are sometimes obtained by Integers -> IntegralDomain -> Ring and sometimes directly. Making this an instance with a low priority instead of using intdom_ring:> IsCRing forces Coq to take the right way *) #[export] Hint Extern 10 (IsCRing _) => apply @intdom_ring : typeclass_instances. Arguments recip_inverse {A Aplus Amult Azero Aone Anegate Aap Arecip IsField} _. Arguments dec_recip_inverse {A Aplus Amult Azero Aone Anegate Adec_recip IsDecField} _ _. Arguments dec_recip_0 {A Aplus Amult Azero Aone Anegate Adec_recip IsDecField}. Section lattice. Context A {Ajoin: Join A} {Ameet: Meet A} {Abottom : Bottom A} {Atop : Top A}. Class IsJoinSemiLattice := join_semilattice : @IsSemiLattice A join_is_sg_op. #[export] Existing Instance join_semilattice. Class IsBoundedJoinSemiLattice := bounded_join_semilattice : @IsBoundedSemiLattice A join_is_sg_op bottom_is_mon_unit. #[export] Existing Instance bounded_join_semilattice. Class IsMeetSemiLattice := meet_semilattice : @IsSemiLattice A meet_is_sg_op. #[export] Existing Instance meet_semilattice. Class IsBoundedMeetSemiLattice := bounded_meet_semilattice : @IsBoundedSemiLattice A meet_is_sg_op top_is_mon_unit. #[export] Existing Instance bounded_meet_semilattice. Class IsLattice := { lattice_join : IsJoinSemiLattice ; lattice_meet : IsMeetSemiLattice ; join_meet_absorption : Absorption (⊔) (⊓) ; meet_join_absorption : Absorption (⊓) (⊔) }. #[export] Existing Instances lattice_join lattice_meet join_meet_absorption meet_join_absorption. Class IsBoundedLattice := { boundedlattice_join : IsBoundedJoinSemiLattice ; boundedlattice_meet : IsBoundedMeetSemiLattice ; boundedjoin_meet_absorption : Absorption (⊔) (⊓) ; boundedmeet_join_absorption : Absorption (⊓) (⊔)}. #[export] Existing Instances boundedlattice_join boundedlattice_meet boundedjoin_meet_absorption boundedmeet_join_absorption. Class IsDistributiveLattice := { distr_lattice_lattice : IsLattice ; join_meet_distr_l : LeftDistribute (⊔) (⊓) }. #[export] Existing Instances distr_lattice_lattice join_meet_distr_l. End lattice. Section morphism_classes. Section sgmorphism_classes. Context {A B : Type} {Aop : SgOp A} {Bop : SgOp B} {Aunit : MonUnit A} {Bunit : MonUnit B}. Local Open Scope mc_mult_scope. Class IsSemiGroupPreserving (f : A -> B) := preserves_sg_op : forall x y, f (x * y) = f x * f y. Class IsUnitPreserving (f : A -> B) := preserves_mon_unit : f mon_unit = mon_unit. Class IsMonoidPreserving (f : A -> B) := { monmor_sgmor : IsSemiGroupPreserving f ; monmor_unitmor : IsUnitPreserving f }. #[export] Existing Instances monmor_sgmor monmor_unitmor. End sgmorphism_classes. Section ringmorphism_classes. Context {A B : Type} {Aplus : Plus A} {Bplus : Plus B} {Amult : Mult A} {Bmult : Mult B} {Azero : Zero A} {Bzero : Zero B} {Aone : One A} {Bone : One B}. Class IsSemiRingPreserving (f : A -> B) := { semiringmor_plus_mor : @IsMonoidPreserving A B (+) (+) 0 0 f ; semiringmor_mult_mor : @IsMonoidPreserving A B (.*.) (.*.) 1 1 f }. #[export] Existing Instances semiringmor_plus_mor semiringmor_mult_mor. Context {Aap : Apart A} {Bap : Apart B}. Class IsSemiRingStrongPreserving (f : A -> B) := { strong_semiringmor_sr_mor : IsSemiRingPreserving f ; strong_semiringmor_strong_mor : StrongExtensionality f }. #[export] Existing Instances strong_semiringmor_sr_mor strong_semiringmor_strong_mor. End ringmorphism_classes. Section latticemorphism_classes. Context {A B : Type} {Ajoin : Join A} {Bjoin : Join B} {Ameet : Meet A} {Bmeet : Meet B}. Class IsJoinPreserving (f : A -> B) := join_slmor_sgmor : @IsSemiGroupPreserving A B join_is_sg_op join_is_sg_op f. #[export] Existing Instances join_slmor_sgmor. Class IsMeetPreserving (f : A -> B) := meet_slmor_sgmor : @IsSemiGroupPreserving A B meet_is_sg_op meet_is_sg_op f. #[export] Existing Instances meet_slmor_sgmor. Context {Abottom : Bottom A} {Bbottom : Bottom B}. Class IsBoundedJoinPreserving (f : A -> B) := bounded_join_slmor_monmor : @IsMonoidPreserving A B join_is_sg_op join_is_sg_op bottom_is_mon_unit bottom_is_mon_unit f. #[export] Existing Instances bounded_join_slmor_monmor. Class IsLatticePreserving (f : A -> B) := { latticemor_join_mor : IsJoinPreserving f ; latticemor_meet_mor : IsMeetPreserving f }. #[export] Existing Instances latticemor_join_mor latticemor_meet_mor. End latticemorphism_classes. End morphism_classes. Section id_mor. Context `{SgOp A} `{MonUnit A}. Global Instance id_sg_morphism : IsSemiGroupPreserving (@id A). Proof. split. Defined. Global Instance id_monoid_morphism : IsMonoidPreserving (@id A). Proof. split; split. Defined. End id_mor. Section compose_mor. Context `{SgOp A} `{MonUnit A} `{SgOp B} `{MonUnit B} `{SgOp C} `{MonUnit C} (f : A -> B) (g : B -> C). (** Making these global instances causes typeclass loops. Instead they are declared below as [Hint Extern]s that apply only when the goal has the specified form. *) Local Instance compose_sg_morphism : IsSemiGroupPreserving f -> IsSemiGroupPreserving g -> IsSemiGroupPreserving (g ∘ f). Proof. red; intros fp gp x y. unfold Compose. refine ((ap g _) @ _). - apply fp. - apply gp. Defined. Local Instance compose_monoid_morphism : IsMonoidPreserving f -> IsMonoidPreserving g -> IsMonoidPreserving (g ∘ f). Proof. intros;split. - apply _. - red;unfold Compose. etransitivity;[|apply (preserves_mon_unit (f:=g))]. apply ap,preserves_mon_unit. Defined. End compose_mor. Section invert_mor. Context `{SgOp A} `{MonUnit A} `{SgOp B} `{MonUnit B} (f : A -> B). Local Instance invert_sg_morphism : forall `{!IsEquiv f}, IsSemiGroupPreserving f -> IsSemiGroupPreserving (f^-1). Proof. red; intros E fp x y. apply (equiv_inj f). lhs nrapply eisretr. symmetry. lhs nrapply fp. f_ap; apply eisretr. Defined. Local Instance invert_monoid_morphism : forall `{!IsEquiv f}, IsMonoidPreserving f -> IsMonoidPreserving (f^-1). Proof. intros;split. - apply _. - apply (equiv_inj f). refine (_ @ _). + apply eisretr. + symmetry; apply preserves_mon_unit. Defined. End invert_mor. #[export] Hint Extern 4 (IsSemiGroupPreserving (_ ∘ _)) => class_apply @compose_sg_morphism : typeclass_instances. #[export] Hint Extern 4 (IsMonoidPreserving (_ ∘ _)) => class_apply @compose_monoid_morphism : typeclass_instances. #[export] Hint Extern 4 (IsSemiGroupPreserving (_ o _)) => class_apply @compose_sg_morphism : typeclass_instances. #[export] Hint Extern 4 (IsMonoidPreserving (_ o _)) => class_apply @compose_monoid_morphism : typeclass_instances. #[export] Hint Extern 4 (IsSemiGroupPreserving (_^-1)) => class_apply @invert_sg_morphism : typeclass_instances. #[export] Hint Extern 4 (IsMonoidPreserving (_^-1)) => class_apply @invert_monoid_morphism : typeclass_instances. #[export] Instance isinjective_mapinO_tr {A B : Type} (f : A -> B) {p : MapIn (Tr (-1)) f} : IsInjective f := fun x y pfeq => ap pr1 (@center _ (p (f y) (x; pfeq) (y; idpath))). Section strong_injective. Context {A B} {Aap : Apart A} {Bap : Apart B} (f : A -> B) . Class IsStrongInjective := { strong_injective : forall x y, x ≶ y -> f x ≶ f y ; strong_injective_mor : StrongExtensionality f }. End strong_injective. Section extras. Class CutMinusSpec A (cm : CutMinus A) `{Zero A} `{Plus A} `{Le A} := { cut_minus_le : forall x y, y ≤ x -> x ∸ y + y = x ; cut_minus_0 : forall x y, x ≤ y -> x ∸ y = 0 }. Global Instance ishprop_issemigrouppreserving `{Funext} {A B : Type} `{IsHSet B} `{SgOp A} `{SgOp B} {f : A -> B} : IsHProp (IsSemiGroupPreserving f). Proof. unfold IsSemiGroupPreserving; exact _. Defined. Definition issig_IsSemiRingPreserving {A B : Type} `{Plus A, Plus B, Mult A, Mult B, Zero A, Zero B, One A, One B} {f : A -> B} : _ <~> IsSemiRingPreserving f := ltac:(issig). Definition issig_IsMonoidPreserving {A B : Type} `{SgOp A} `{SgOp B} `{MonUnit A} `{MonUnit B} {f : A -> B} : _ <~> IsMonoidPreserving f := ltac:(issig). Global Instance ishprop_ismonoidpreserving `{Funext} {A B : Type} `{SgOp A} `{SgOp B} `{IsHSet B} `{MonUnit A} `{MonUnit B} (f : A -> B) : IsHProp (IsMonoidPreserving f). Proof. srapply (istrunc_equiv_istrunc _ issig_IsMonoidPreserving). srapply (istrunc_equiv_istrunc _ (equiv_sigma_prod0 _ _)^-1). srapply istrunc_prod. unfold IsUnitPreserving. exact _. Defined. Global Instance ishprop_issemiringpreserving `{Funext} {A B : Type} `{IsHSet B} `{Plus A, Plus B, Mult A, Mult B, Zero A, Zero B, One A, One B} (f : A -> B) : IsHProp (IsSemiRingPreserving f). Proof. snrapply (istrunc_equiv_istrunc _ issig_IsSemiRingPreserving). exact _. Defined. Definition issig_issemigroup x y : _ <~> @IsSemiGroup x y := ltac:(issig). Global Instance ishprop_issemigroup `{Funext} : forall x y, IsHProp (@IsSemiGroup x y). Proof. intros x y; apply istrunc_S; intros a b. rewrite <- (eisretr (issig_issemigroup x y) a). rewrite <- (eisretr (issig_issemigroup x y) b). set (a' := (issig_issemigroup x y)^-1 a). set (b' := (issig_issemigroup x y)^-1 b). clearbody a' b'; clear a b. srapply (contr_equiv _ (ap (issig_issemigroup x y))). rewrite <- (eissect (equiv_sigma_prod0 _ _) a'). rewrite <- (eissect (equiv_sigma_prod0 _ _) b'). set (a := equiv_sigma_prod0 _ _ a'). set (b := equiv_sigma_prod0 _ _ b'). clearbody a b; clear a' b'. srapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)). srapply (contr_equiv _ (equiv_path_prod _ _)). srapply contr_prod. destruct a as [a' a], b as [b' b]. do 3 (nrefine (contr_equiv' _ (@equiv_path_forall H _ _ _ _)); nrefine (@contr_forall H _ _ _); intro). exact _. Defined. Definition issig_ismonoid x y z : _ <~> @IsMonoid x y z := ltac:(issig). Global Instance ishprop_ismonoid `{Funext} x y z : IsHProp (@IsMonoid x y z). Proof. apply istrunc_S. intros a b. rewrite <- (eisretr (issig_ismonoid x y z) a). rewrite <- (eisretr (issig_ismonoid x y z) b). set (a' := (issig_ismonoid x y z)^-1 a). set (b' := (issig_ismonoid x y z)^-1 b). clearbody a' b'; clear a b. srapply (contr_equiv _ (ap (issig_ismonoid x y z))). rewrite <- (eissect (equiv_sigma_prod0 _ _) a'). rewrite <- (eissect (equiv_sigma_prod0 _ _) b'). set (a := equiv_sigma_prod0 _ _ a'). set (b := equiv_sigma_prod0 _ _ b'). clearbody a b; clear a' b'. srapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)). srapply (contr_equiv _ (equiv_path_prod _ _)). srapply contr_prod. destruct a as [a' a], b as [b' b]; cbn. rewrite <- (eissect (equiv_sigma_prod0 _ _) a). rewrite <- (eissect (equiv_sigma_prod0 _ _) b). set (a'' := equiv_sigma_prod0 _ _ a). set (b'' := equiv_sigma_prod0 _ _ b). clearbody a'' b''; clear a b. srapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)). srapply (contr_equiv _ (equiv_path_prod _ _)). destruct a'' as [a a''], b'' as [b b'']; cbn. snrapply contr_prod. all: srapply contr_paths_contr. all: srapply contr_inhabited_hprop. all: srapply istrunc_forall. Defined. Definition issig_isgroup w x y z : _ <~> @IsGroup w x y z := ltac:(issig). Global Instance ishprop_isgroup `{Funext} w x y z : IsHProp (@IsGroup w x y z). Proof. apply istrunc_S. intros a b. rewrite <- (eisretr (issig_isgroup w x y z) a). rewrite <- (eisretr (issig_isgroup w x y z) b). set (a' := (issig_isgroup w x y z)^-1 a). set (b' := (issig_isgroup w x y z)^-1 b). clearbody a' b'; clear a b. srapply (contr_equiv _ (ap (issig_isgroup w x y z))). rewrite <- (eissect (equiv_sigma_prod0 _ _) a'). rewrite <- (eissect (equiv_sigma_prod0 _ _) b'). set (a := equiv_sigma_prod0 _ _ a'). set (b := equiv_sigma_prod0 _ _ b'). clearbody a b; clear a' b'. srapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)). srapply (contr_equiv _ (equiv_path_prod _ _)). srapply contr_prod. destruct a as [a' a], b as [b' b]; cbn. rewrite <- (eissect (equiv_sigma_prod0 _ _) a). rewrite <- (eissect (equiv_sigma_prod0 _ _) b). set (a'' := equiv_sigma_prod0 _ _ a). set (b'' := equiv_sigma_prod0 _ _ b). clearbody a'' b''; clear a b. srapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)). srapply (contr_equiv _ (equiv_path_prod _ _)). destruct a'' as [a a''], b'' as [b b'']; cbn. srapply contr_prod. all: srapply contr_paths_contr. all: srapply contr_inhabited_hprop. all: srapply istrunc_forall. Defined. End extras. Coq-HoTT-9.0/theories/Classes/interfaces/archimedean.v000066400000000000000000000013261474641544500227310ustar00rootroot00000000000000From HoTT.Classes Require Import interfaces.abstract_algebra interfaces.rationals interfaces.orders. Section property. Context (Q : Type). Context `{Qrats : Rationals Q}. Context (F : Type). Context `{Aorderedfield : OrderedField F}. (* We are assuming `A` to be of characteristic 0 because this is what `rationals_to_field` requires. But this requirement should eventually simply be implemented by the fact that F is an ordered field. *) Context {Achar : FieldCharacteristic F 0}. Definition qinc : Cast Q F := rationals_to_field Q F. Existing Instance qinc. Class ArchimedeanProperty := archimedean_property : forall x y, x < y -> hexists (fun q => x < ' q < y). End property. Coq-HoTT-9.0/theories/Classes/interfaces/canonical_names.v000066400000000000000000000423421474641544500236060ustar00rootroot00000000000000Require Export HoTT.Basics HoTT.Types HoTT.Truncations.Core. Declare Scope mc_scope. Open Scope mc_scope. Generalizable Variables A B f g x y. Monomorphic Universe Ularge Uhuge. Monomorphic Constraint Ularge < Uhuge. Lemma merely_destruct {A} {P : Type} {sP : IsHProp P} (x : merely A) : (A -> P) -> P. Proof. intros E;revert x. apply Trunc_ind. - apply _. - exact E. Qed. Notation " g ∘ f " := (Compose g f). Notation "(∘)" := Compose (only parsing) : mc_scope. Definition id {A : Type} (a : A) := a. Notation "(=)" := paths (only parsing) : mc_scope. Notation "( x =)" := (paths x) (only parsing) : mc_scope. Notation "(= x )" := (fun y => paths y x) (only parsing) : mc_scope. Notation "(<>)" := (fun x y => ~x = y) (only parsing) : mc_scope. Notation "( x <>)" := (fun y => x <> y) (only parsing) : mc_scope. Notation "(<> x )" := (fun y => y <> x) (only parsing) : mc_scope. Class Apart A := apart : Relation A. Infix "≶" := apart : mc_scope. Notation "(≶)" := apart (only parsing) : mc_scope. Notation "( x ≶)" := (apart x) (only parsing) : mc_scope. Notation "(≶ x )" := (fun y => apart y x) (only parsing) : mc_scope. (* Even for setoids with decidable equality x <> y does not imply x ≶ y. Therefore we introduce the following class. *) Class TrivialApart A {Aap : Apart A} := { trivial_apart_prop : is_mere_relation A apart ; trivial_apart : forall x y, x ≶ y <-> x <> y }. #[export] Existing Instance trivial_apart_prop. Definition sig_apart `{Apart A} (P: A -> Type) : Apart (sig P) := fun x y => x.1 ≶ y.1. #[export] Hint Extern 10 (Apart (sig _)) => apply @sig_apart : typeclass_instances. Class Cast A B := cast: A -> B. Arguments cast _ _ {Cast} _. Notation "' x" := (cast _ _ x) : mc_scope. #[global] Typeclasses Transparent Cast. (* Other canonically named relations/operations/constants: *) Class SgOp A := sg_op: A -> A -> A. Class MonUnit A := mon_unit: A. Class Plus A := plus: A -> A -> A. Class Mult A := mult: A -> A -> A. Class One A := one: A. Class Zero A := zero: A. Class Negate A := negate: A -> A. Class Inverse A := inv: A -> A. Class DecRecip A := dec_recip: A -> A. Definition ApartZero R `{Zero R} `{Apart R} := sig (≶ zero). Class Recip A `{Apart A} `{Zero A} := recip: ApartZero A -> A. #[global] Typeclasses Transparent SgOp MonUnit Plus Mult Zero One Negate. Class Meet A := meet: A -> A -> A. Class Join A := join: A -> A -> A. Class Top A := top: A. Class Bottom A := bottom: A. #[global] Typeclasses Transparent Meet Join Top Bottom. Class Le A := le: Relation A. Class Lt A := lt: Relation A. #[global] Typeclasses Transparent Le Lt. Definition NonNeg R `{Zero R} `{Le R} := sig (le zero). Definition Pos R `{Zero R} `{Lt R} := sig (lt zero). Definition NonPos R `{Zero R} `{Le R} := sig (fun y => le y zero). (** *** Hints for converting between types of operations *) Global Instance plus_is_sg_op `{f : Plus A} : SgOp A := f. Definition sg_op_is_plus `{f : SgOp A} : Plus A := f. Global Instance mult_is_sg_op `{f : Mult A} : SgOp A := f. Definition sg_op_is_mult `{f : SgOp A} : Mult A := f. Global Instance zero_is_mon_unit `{c : Zero A} : MonUnit A := c. Definition mon_unit_is_zero `{c : MonUnit A} : Zero A := c. Global Instance one_is_mon_unit `{c : One A} : MonUnit A := c. Definition mon_unit_is_one `{c : MonUnit A} : One A := c. Global Instance meet_is_sg_op `{f : Meet A} : SgOp A := f. Global Instance join_is_sg_op `{f : Join A} : SgOp A := f. Definition top_is_mon_unit `{s : Top A} : MonUnit A := s. Definition bottom_is_mon_unit `{s : Bottom A} : MonUnit A := s. Global Instance negate_is_inverse `{i : Negate A} : Inverse A := i. Definition inverse_is_negate `{i : Inverse A} : Negate A := i. #[export] Hint Extern 4 (Apart (ApartZero _)) => apply @sig_apart : typeclass_instances. #[export] Hint Extern 4 (Apart (NonNeg _)) => apply @sig_apart : typeclass_instances. #[export] Hint Extern 4 (Apart (Pos _)) => apply @sig_apart : typeclass_instances. (** For more information on using [mc_add_scope] and [mc_mult_scope], see the files test/Algebra/Groups/Expressions.v and test/Algebra/Rings/Expressions.v. *) Module AdditiveNotations. (** [mc_add_scope] is generally used when working with abelian groups. *) Declare Scope mc_add_scope. Infix "+" := sg_op : mc_add_scope. Notation "(+)" := sg_op (only parsing) : mc_add_scope. Notation "( x +)" := (sg_op x) (only parsing) : mc_add_scope. Notation "(+ x )" := (fun y => sg_op y x) (only parsing) : mc_add_scope. Notation "0" := mon_unit : mc_add_scope. Notation "- x" := (inv x) : mc_add_scope. Notation "(-)" := inv (only parsing) : mc_add_scope. Notation "x - y" := (sg_op x (inv y)) : mc_add_scope. End AdditiveNotations. Module MultiplicativeNotations. (** [mc_mult_scope] is generally used when working with general groups. *) Declare Scope mc_mult_scope. Infix "*" := sg_op : mc_mult_scope. Notation "( x *.)" := (sg_op x) (only parsing) : mc_mult_scope. Notation "(.*.)" := sg_op (only parsing) : mc_mult_scope. Notation "(.* x )" := (fun y => sg_op y x) (only parsing) : mc_mult_scope. Notation "1" := mon_unit : mc_mult_scope. Notation "x ^" := (inv x) : mc_mult_scope. Notation "(^)" := inv (only parsing) : mc_mult_scope. End MultiplicativeNotations. (** We group these notations into a module, so that just this subset can be exported in some cases. *) Module Export BinOpNotations. Export AdditiveNotations MultiplicativeNotations. Infix "+" := plus : mc_scope. Notation "(+)" := plus (only parsing) : mc_scope. Notation "( x +)" := (plus x) (only parsing) : mc_scope. Notation "(+ x )" := (fun y => y + x) (only parsing) : mc_scope. Infix "*" := mult : mc_scope. (* We don't add "( * )", "( * x )" and "( x * )" notations because they conflict with comments. *) Notation "( x *.)" := (mult x) (only parsing) : mc_scope. Notation "(.*.)" := mult (only parsing) : mc_scope. Notation "(.* x )" := (fun y => y * x) (only parsing) : mc_scope. Notation "- x" := (negate x) : mc_scope. Notation "(-)" := negate (only parsing) : mc_scope. Notation "x - y" := (x + negate y) : mc_scope. Notation "0" := zero : mc_scope. Notation "1" := one : mc_scope. Notation "2" := (1 + 1) : mc_scope. Notation "3" := (1 + (1 + 1)) : mc_scope. Notation "4" := (1 + (1 + (1 + 1))) : mc_scope. Notation "5" := (1 + (1 + (1 + (1 + 1)))) : mc_scope. Notation "6" := (1 + (1 + (1 + (1 + (1 + 1))))) : mc_scope. Notation "- 1" := (-(1)) : mc_scope. Notation "- 2" := (-(2)) : mc_scope. Notation "- 3" := (-(3)) : mc_scope. Notation "- 4" := (-(4)) : mc_scope. End BinOpNotations. Notation "/ x" := (dec_recip x) : mc_scope. Notation "(/)" := dec_recip (only parsing) : mc_scope. Notation "x / y" := (x * /y) : mc_scope. Notation "// x" := (recip x) : mc_scope. Notation "(//)" := recip (only parsing) : mc_scope. Notation "x // y" := (x * //y) : mc_scope. Notation "⊤" := top : mc_scope. Notation "⊥" := bottom : mc_scope. Infix "⊓" := meet : mc_scope. Notation "(⊓)" := meet (only parsing) : mc_scope. Notation "( X ⊓)" := (meet X) (only parsing) : mc_scope. Notation "(⊓ X )" := (fun Y => Y ⊓ X) (only parsing) : mc_scope. Infix "⊔" := join : mc_scope. Notation "(⊔)" := join (only parsing) : mc_scope. Notation "( X ⊔)" := (join X) (only parsing) : mc_scope. Notation "(⊔ X )" := (fun Y => Y ⊔ X) (only parsing) : mc_scope. Infix "≤" := le : mc_scope. Notation "(≤)" := le (only parsing) : mc_scope. Notation "( x ≤)" := (le x) (only parsing) : mc_scope. Notation "(≤ x )" := (fun y => y ≤ x) (only parsing) : mc_scope. Infix "<=" := le (only parsing) : mc_scope. Notation "(<=)" := le (only parsing) : mc_scope. Notation "( x <=)" := (le x) (only parsing) : mc_scope. Notation "(<= x )" := (fun y => y ≤ x) (only parsing) : mc_scope. Infix "<" := lt : mc_scope. Notation "(<)" := lt (only parsing) : mc_scope. Notation "( x <)" := (lt x) (only parsing) : mc_scope. Notation "(< x )" := (fun y => y < x) (only parsing) : mc_scope. Notation "x ≤ y ≤ z" := (x ≤ y /\ y ≤ z) : mc_scope. Notation "x ≤ y < z" := (x ≤ y /\ y < z) : mc_scope. Notation "x < y < z" := (x < y /\ y < z) : mc_scope. Notation "x < y ≤ z" := (x < y /\ y ≤ z) : mc_scope. (** It is likely that ≤ and < are transitive (and ≤ reflexive) so inform [auto] of this. *) Ltac auto_trans := match goal with [ H: ?R ?x ?y, I: ?R ?y ?z |- ?R ?x ?z] => apply (transitivity H I) end. #[export] Hint Extern 2 (?x ≤ ?y) => reflexivity : core. #[export] Hint Extern 4 (?x ≤ ?z) => auto_trans : core. #[export] Hint Extern 4 (?x < ?z) => auto_trans : core. Class Abs A `{Le A} `{Zero A} `{Negate A} := abs_sig: forall (x : A), { y : A | (0 ≤ x -> y = x) /\ (x ≤ 0 -> y = -x)}. Definition abs `{Abs A} := fun x : A => (abs_sig x).1. (* Common properties: *) (* Class Inverse `(A -> B) : Type := inverse: B -> A. Arguments inverse {A B} _ {Inverse} _. Typeclasses Transparent Inverse. Notation "f ⁻¹" := (inverse f) : mc_scope. *) Class Idempotent `(f: A -> A -> A) (x : A) : Type := idempotency: f x x = x. Arguments idempotency {A} _ _ {Idempotent}. Class UnaryIdempotent {A} (f: A -> A) : Type := unary_idempotent : Idempotent Compose f. #[export] Existing Instances unary_idempotent. Lemma unary_idempotency `{UnaryIdempotent A f} x : f (f x) = f x. Proof. change (f (f x)) with (Compose f f x). apply (ap (fun g => g x)). change (Compose f f = f). apply idempotency. apply _. Qed. Class BinaryIdempotent `(op: A -> A -> A) : Type := binary_idempotent : forall x, Idempotent op x. #[export] Existing Instances binary_idempotent. Class LeftIdentity {A B} (op : A -> B -> B) (x : A): Type := left_identity: forall y, op x y = y. Class RightIdentity {A B} (op : A -> B -> A) (y : B): Type := right_identity: forall x, op x y = x. Class Absorption {A B C} (op1: A -> C -> A) (op2: A -> B -> C) : Type := absorption: forall x y, op1 x (op2 x y) = x. Class LeftAbsorb {A B} (op : A -> B -> A) (x : A): Type := left_absorb: forall y, op x y = x. Class RightAbsorb {A B} (op : A -> B -> B) (y : B): Type := right_absorb: forall x, op x y = y. Class LeftInverse {A} {B} {C} (op : A -> B -> C) (inv : B -> A) (unit : C) := left_inverse: forall x, op (inv x) x = unit. Class RightInverse {A} {B} {C} (op : A -> B -> C) (inv : A -> B) (unit : C) := right_inverse: forall x, op x (inv x) = unit. Class Commutative {B A} (f : A -> A -> B) : Type := commutativity: forall x y, f x y = f y x. #[global] Typeclasses Transparent Commutative. Class HeteroAssociative {A B C AB BC ABC} (fA_BC: A -> BC -> ABC) (fBC: B -> C -> BC) (fAB_C: AB -> C -> ABC) (fAB : A -> B -> AB): Type := associativity : forall x y z, fA_BC x (fBC y z) = fAB_C (fAB x y) z. Class Associative {A} (f : A -> A -> A) := simple_associativity : HeteroAssociative f f f f. #[export] Existing Instances simple_associativity. Class Involutive {A} (f : A -> A) := involutive: forall x, f (f x) = x. Class TotalRelation `(R : Relation A) : Type := total : forall x y : A, R x y |_| R y x. Arguments total {A} _ {TotalRelation} _ _. Class Trichotomy `(R : Relation A) := trichotomy : forall x y : A, R x y |_| x = y |_| R y x. Arguments trichotomy {A} R {Trichotomy} _ _. Arguments irreflexivity {A} _ {Irreflexive} _ _. Class CoTransitive `(R : Relation A) : Type := cotransitive : forall x y, R x y -> forall z, hor (R x z) (R z y). Arguments cotransitive {A R CoTransitive x y} _ _. Class EquivRel `(R : Relation A) : Type := Build_EquivRel { EquivRel_Reflexive : Reflexive R ; EquivRel_Symmetric : Symmetric R ; EquivRel_Transitive : Transitive R }. #[export] Existing Instances EquivRel_Reflexive EquivRel_Symmetric EquivRel_Transitive. Definition SigEquivRel {A:Type} (R : Relation A) : Type := {_ : Reflexive R | { _ : Symmetric R | Transitive R}}. Global Instance trunc_sig_equiv_rel `{Funext} {A : Type} (R : Relation A) {n} `{!forall (x y : A), IsTrunc n (R x y)} : IsTrunc n (SigEquivRel R). Proof. apply @istrunc_sigma. - apply istrunc_forall. - intros. apply @istrunc_sigma; intros; apply istrunc_forall. Defined. Lemma issig_equiv_rel {A:Type} (R : Relation A) : SigEquivRel R <~> EquivRel R. Proof. issig. Defined. Global Instance istrunc_equiv_rel `{Funext} {A : Type} (R : Relation A) {n} `{!forall (x y : A), IsTrunc n (R x y)} : IsTrunc n (EquivRel R). Proof. exact (istrunc_equiv_istrunc (SigEquivRel R) (issig_equiv_rel R)). Qed. Class Conjugate A := conj : A -> A. Class DistrOpp {A} `(SgOp A) `(Conjugate A) := distropp : forall x y : A, conj (sg_op x y) = sg_op (conj y) (conj x). Class SwapOp {A} `(Negate A) `(Conjugate A) := swapop : forall x, conj (-x) = - (conj x). Class FactorNegLeft {A} `(Negate A) `(SgOp A) := factorneg_l : forall x y, sg_op (-x) y = - (sg_op x y). Class FactorNegRight {A} `(Negate A) `(SgOp A) := factorneg_r : forall x y, sg_op x (-y) = - (sg_op x y). Class LeftHeteroDistribute {A B C} (f : A -> B -> C) (g_r : B -> B -> B) (g : C -> C -> C) : Type := distribute_l : forall a b c, f a (g_r b c) = g (f a b) (f a c). Class RightHeteroDistribute {A B C} (f : A -> B -> C) (g_l : A -> A -> A) (g : C -> C -> C) : Type := distribute_r: forall a b c, f (g_l a b) c = g (f a c) (f b c). Class LeftDistribute {A} (f g: A -> A -> A) := simple_distribute_l : LeftHeteroDistribute f g g. #[export] Existing Instances simple_distribute_l. Class RightDistribute {A} (f g: A -> A -> A) := simple_distribute_r : RightHeteroDistribute f g g. #[export] Existing Instances simple_distribute_r. Class HeteroSymmetric {A} {T : A -> A -> Type} (R : forall {x y}, T x y -> T y x -> Type) : Type := hetero_symmetric `(a : T x y) (b : T y x) : R a b -> R b a. (* Although cancellation is the same as being injective, we want a proper name to refer to this commonly used property. *) Section cancellation. Context `(op : A -> A -> A) (z : A). Class LeftCancellation := left_cancellation : forall x y, op z x = op z y -> x = y. Class RightCancellation := right_cancellation : forall x y, op x z = op y z -> x = y. Context {Aap : Apart A}. Class StrongLeftCancellation := strong_left_cancellation : forall x y, x ≶ y -> op z x ≶ op z y. Class StrongRightCancellation := strong_right_cancellation : forall x y, x ≶ y -> op x z ≶ op y z. End cancellation. (* Common names for properties that hold in N, Z, Q, ... *) Class ZeroProduct A `{!Mult A} `{!Zero A} : Type := zero_product : forall x y, x * y = 0 -> x = 0 |_| y = 0. Class ZeroDivisor {R} `{Zero R} `{Mult R} (x : R) : Type := zero_divisor : x <> 0 /\ exists y, y <> 0 /\ x * y = 0. Class NoZeroDivisors R `{Zero R} `{Mult R} : Type := no_zero_divisors x : ~ZeroDivisor x. Global Instance zero_product_no_zero_divisors `{ZeroProduct A} : NoZeroDivisors A. Proof. intros x [? [? [? E]]]. destruct (zero_product _ _ E); auto. Qed. (* A common induction principle for both the naturals and integers *) Class Biinduction R `{Zero R} `{One R} `{Plus R} : Type := biinduction (P : R -> Type) : P 0 -> (forall n, P n <-> P (1 + n)) -> forall n, P n. (** Additional operations **) Class CutMinus A := cut_minus : A -> A -> A. Infix "∸" := cut_minus : mc_scope. Notation "(∸)" := cut_minus (only parsing) : mc_scope. Notation "( x ∸)" := (cut_minus x) (only parsing) : mc_scope. Notation "(∸ y )" := (fun x => x ∸ y) (only parsing) : mc_scope. Inductive comparison : Set := LT | EQ | GT. Class Compare A := compare : A -> A -> comparison. Infix "?=" := compare : mc_scope. Notation "(?=)" := compare (only parsing) : mc_scope. Notation "( x ?=)" := (compare x) (only parsing) : mc_scope. Notation "(?= y )" := (fun x => x ?= y) (only parsing) : mc_scope. Class Eqb A := eqb : A -> A -> Bool. Infix "=?" := eqb : mc_scope. Notation "(=?)" := eqb (only parsing) : mc_scope. Notation "( x =?)" := (eqb x) (only parsing) : mc_scope. Notation "(=? y )" := (fun x => x =? y) (only parsing) : mc_scope. Class Ltb A := ltb : A -> A -> Bool. Infix " x A -> Bool. Infix "<=?" := leb : mc_scope. Notation "(<=?)" := leb (only parsing) : mc_scope. Notation "( x <=?)" := (leb x) (only parsing) : mc_scope. Notation "(<=? y )" := (fun x => x <=? y) (only parsing) : mc_scope. Class Return (M : Type -> Type) := ret : forall {A}, A -> M A. Class Bind (M : Type -> Type) := bind : forall {A B}, M A -> (A -> M B) -> M B. Class Enumerable@{i} (A : Type@{i}) := { enumerator : nat -> A ; enumerator_issurj : IsSurjection enumerator }. #[export] Existing Instance enumerator_issurj. Arguments enumerator A {_} _. Arguments enumerator_issurj A {_} _. (* The following class is nice to parametrize instances by additional properties, for example: [forall z, PropHolds (z <> 0) -> LeftCancellation op z] This tool is very powerful as we can combine it with instances as: [forall x y, PropHolds (x <> 0) -> PropHolds (y <> 0) -> PropHolds (x * y <> 0)] Of course, one should be very careful not to make too many instances as that could easily lead to a blow-up of the search space (or worse, cycles). *) Class PropHolds (P : Type) := prop_holds: P. #[export] Hint Extern 0 (PropHolds _) => assumption : typeclass_instances. Ltac solve_propholds := match goal with | [ |- PropHolds (?P) ] => apply _ | [ |- ?P ] => change (PropHolds P); apply _ end. Coq-HoTT-9.0/theories/Classes/interfaces/cauchy.v000066400000000000000000000114101474641544500217400ustar00rootroot00000000000000From HoTT.Classes Require Import interfaces.abstract_algebra interfaces.rationals interfaces.orders implementations.peano_naturals orders.fields theory.dec_fields theory.fields theory.rationals. Section cauchy. Context (Q : Type). Context `{Rationals Q}. Context {Q_dec_paths : DecidablePaths Q}. Context {Qtriv : TrivialApart Q}. Context (F : Type). Context `{Forderedfield : OrderedField F}. Let qinc : Cast Q F := rationals_to_field Q F. Existing Instance qinc. (* TODO The following two instances should probably come from the `Rationals` instance. *) Context (qinc_strong_presving : IsSemiRingStrongPreserving qinc). Existing Instance qinc_strong_presving. Section sequence. Context (x : nat -> F). Class CauchyModulus (M : Qpos Q -> nat) := cauchy_convergence : forall epsilon : Qpos Q, forall m n, M epsilon <= m -> M epsilon <= n -> - ' (' epsilon) < (x m) - (x n) < ' (' epsilon). Class IsLimit (l : F) := is_limit : forall epsilon : Qpos Q, hexists (fun N : nat => forall n : nat, N <= n -> - ' (' epsilon) < l - x n < ' (' epsilon)). End sequence. Class IsComplete := is_complete : forall x : nat -> F, forall M , CauchyModulus x M -> exists l, IsLimit x l. Section theory. Context (x : nat -> F) {M} `{CauchyModulus x M}. Lemma modulus_close_limit {l} (islim : IsLimit x l) (epsilon : Qpos Q) : x (M (epsilon / 2)) - ' (' epsilon) < l < x (M (epsilon / 2)) + ' (' epsilon). Proof. assert (lim_close := is_limit x (epsilon / 2)); strip_truncations. destruct lim_close as [N isclose']. set (n := Nat.Core.nat_max (M (epsilon / 2)) N). assert (leNn := le_nat_max_r (M (epsilon / 2)) N : N ≤ n). assert (isclose := isclose' n leNn). clear isclose'. assert (leMn := le_nat_max_l (M (epsilon / 2)) N : M (epsilon / 2) ≤ n). assert (leMM : M (epsilon / 2) ≤ M (epsilon / 2) ) by apply (Nat.Core.leq_refl). assert (x_close := cauchy_convergence x (epsilon/2) n (M (epsilon / 2)) leMn leMM). cbn in isclose, x_close. rewrite (@preserves_mult Q F _ _ _ _ _ _ _ _ _ _ _ _) in isclose, x_close. assert (eq22 : ' 2 = 2). { rewrite (@preserves_plus Q F _ _ _ _ _ _ _ _ _ _ _ _). rewrite (@preserves_1 Q F _ _ _ _ _ _ _ _ _ _). reflexivity. } set (ap20 := positive_apart_zero 2 lt_0_2 : 2 ≶ 0). assert (ap20' : ' 2 ≶ 0). { rewrite eq22; exact ap20. } rewrite (dec_recip_to_recip 2 ap20') in isclose, x_close. assert (eq_recip_22 : recip' (' 2) ap20' = recip' 2 ap20). { apply recip_proper_alt. exact eq22. } unfold recip' in eq_recip_22. rewrite eq_recip_22 in isclose, x_close. clear eq22 ap20' eq_recip_22. rewrite <- (field_split2 (' (' epsilon))). set (eps_recip_2 := (' (' epsilon) * recip' 2 ap20)). fold ap20. change (' (' epsilon) * recip' 2 ap20) with eps_recip_2. unfold recip' in eps_recip_2. set (xMeps2 := x (M (epsilon / 2))). fold xMeps2 in x_close. rewrite negate_plus_distr. split. - apply (strictly_order_reflecting (+ (- x n))). refine (transitivity _ (fst isclose)). clear isclose. fold eps_recip_2. fold eps_recip_2 in x_close. apply fst, flip_lt_minus_r in x_close. rewrite plus_comm in x_close. apply flip_lt_minus_l in x_close. rewrite plus_comm in x_close. apply flip_lt_minus_l in x_close. rewrite <-(plus_assoc xMeps2 _ (- x n)). rewrite (plus_comm _ (- x n)). rewrite (plus_assoc xMeps2 (- x n) _). apply (strictly_order_reflecting (+ eps_recip_2)). apply (strictly_order_reflecting (+ eps_recip_2)). rewrite plus_negate_l, plus_0_l. rewrite <- (plus_assoc (xMeps2 - x n) _ _). rewrite <- (plus_assoc (-eps_recip_2) _ _). rewrite plus_negate_l, plus_0_r. rewrite <- (plus_assoc (xMeps2 - x n) _ _). rewrite plus_negate_l, plus_0_r. assumption. - apply (strictly_order_reflecting (+ (- x n))). refine (transitivity (snd isclose) _). clear isclose. fold eps_recip_2. fold eps_recip_2 in x_close. apply snd in x_close. apply flip_lt_minus_l in x_close. rewrite plus_comm in x_close. apply (strictly_order_reflecting (+ x n)). rewrite <- (plus_assoc _ (-x n) (x n)). rewrite plus_negate_l, plus_0_r. rewrite (plus_comm eps_recip_2 (x n)). rewrite (plus_assoc xMeps2 _ _). apply (strictly_order_preserving (+ eps_recip_2)). assumption. Qed. End theory. End cauchy. Coq-HoTT-9.0/theories/Classes/interfaces/integers.v000066400000000000000000000025361474641544500223150ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.interfaces.naturals HoTT.Classes.theory.rings (* for Ring -> SemiRing *). Class IntegersToRing@{i j} (A:Type@{i}) := integers_to_ring: forall (R:Type@{j}) `{IsCRing R}, A -> R. Arguments integers_to_ring A {_} R {_ _ _ _ _ _} _. Class Integers A {Aap:Apart A} {Aplus Amult Azero Aone Anegate Ale Alt} `{U : IntegersToRing A} := { integers_ring : @IsCRing A Aplus Amult Azero Aone Anegate ; integers_order : FullPseudoSemiRingOrder Ale Alt ; integers_to_ring_mor : forall {B} `{IsCRing B}, IsSemiRingPreserving (integers_to_ring A B) ; integers_initial: forall {B} `{IsCRing B} {h : A -> B} `{!IsSemiRingPreserving h} x, integers_to_ring A B x = h x}. #[export] Existing Instances integers_ring integers_order integers_to_ring_mor. Section specializable. Context (Z N : Type) `{Integers Z} `{Naturals N}. Class IntAbs := int_abs_sig : forall x, { n : N | naturals_to_semiring N Z n = x } |_| { n : N | naturals_to_semiring N Z n = -x }. Definition int_abs `{ia : IntAbs} (x : Z) : N := match int_abs_sig x with | inl (n;_) => n | inr (n;_) => n end. Definition int_to_nat `{Zero N} `{ia : IntAbs} (x : Z) : N := match int_abs_sig x with | inl (n;_) => n | inr (n;_) => 0 end. End specializable. Coq-HoTT-9.0/theories/Classes/interfaces/monad.v000066400000000000000000000006051474641544500215660ustar00rootroot00000000000000Require Export HoTT.Classes.interfaces.canonical_names. Class Monad (M : Type -> Type) {Mret : Return M} {Mbind : Bind M} := { monad_ret_bind : forall {A B} a (f : A -> M B), bind (ret a) f = f a ; monad_bind_ret : forall {A} (x : M A), bind x ret = x ; monad_bind_assoc : forall {A B C} x (f : A -> M B) (g : B -> M C), bind (bind x f) g = bind x (fun a => bind (f a) g) }. Coq-HoTT-9.0/theories/Classes/interfaces/naturals.v000066400000000000000000000021551474641544500223230ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders. Class NaturalsToSemiRing@{i j} (A : Type@{i}) := naturals_to_semiring: forall (B : Type@{j}) `{IsSemiCRing B}, A -> B. Arguments naturals_to_semiring A {_} B {_ _ _ _ _} _. Class Naturals A {Aap:Apart A} {Aplus Amult Azero Aone Ale Alt} `{U: NaturalsToSemiRing A} := { naturals_ring : @IsSemiCRing A Aplus Amult Azero Aone ; naturals_order : FullPseudoSemiRingOrder Ale Alt ; naturals_to_semiring_mor : forall {B} `{IsSemiCRing B}, IsSemiRingPreserving (naturals_to_semiring A B) ; naturals_initial: forall {B} `{IsSemiCRing B} {h : A -> B} `{!IsSemiRingPreserving h} x, naturals_to_semiring A B x = h x }. #[export] Existing Instances naturals_ring naturals_order naturals_to_semiring_mor. (* Specializable operations: *) Class NatDistance N `{Plus N} := nat_distance_sig : forall x y : N, { z : N | x + z = y } |_| { z : N | y + z = x }. Definition nat_distance {N} `{nd : NatDistance N} (x y : N) := match nat_distance_sig x y with | inl (n;_) => n | inr (n;_) => n end. Coq-HoTT-9.0/theories/Classes/interfaces/orders.v000066400000000000000000000223461474641544500217740ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra. Generalizable Variables A. (* In this file we describe interfaces for ordered structures. Since we are in a constructive setting we use a pseudo order instead of a total order. Therefore we also have to include an apartness relation. Obviously, in case we consider decidable structures these interfaces are quite inconvenient. Hence we will, later on, provide means to go back and forth between the usual classical notions and these constructive notions. On the one hand, if we have an ordinary (total) partial order (≤) with a corresponding strict order (<), we will prove that we can construct a FullPartialOrder and PseudoPartialOrder, respectively. On the other hand, if equality is decidable, we will prove that we have the usual properties like Trichotomy (<) and TotalRelation (≤). *) Class PartialOrder `(Ale : Le A) := { po_hset : IsHSet A ; po_hprop : is_mere_relation A Ale ; po_preorder : PreOrder (≤) ; po_antisym : AntiSymmetric (≤) }. #[export] Existing Instances po_hset po_hprop po_preorder po_antisym. Class TotalOrder `(Ale : Le A) := { total_order_po : PartialOrder (≤) ; total_order_total : TotalRelation (≤) }. #[export] Existing Instances total_order_po total_order_total. (* We define a variant of the order theoretic definition of meet and join semilattices. Notice that we include a meet operation instead of the more common: forall x y, exists m, m ≤ x /\ m ≤ y /\ forall z, z ≤ x -> z ≤ y -> m ≤ z Our definition is both stronger and more convenient than the above. This is needed to prove equavalence with the algebraic definition. We do this in orders.lattices. *) Class MeetSemiLatticeOrder `(Ale : Le A) `{Meet A} := { meet_sl_order : PartialOrder (≤) ; meet_lb_l : forall x y, x ⊓ y ≤ x ; meet_lb_r : forall x y, x ⊓ y ≤ y ; meet_glb : forall x y z, z ≤ x -> z ≤ y -> z ≤ x ⊓ y }. #[export] Existing Instances meet_sl_order. Class JoinSemiLatticeOrder `(Ale : Le A) `{Join A} := { join_sl_order : PartialOrder (≤) ; join_ub_l : forall x y, x ≤ x ⊔ y ; join_ub_r : forall x y, y ≤ x ⊔ y ; join_lub : forall x y z, x ≤ z -> y ≤ z -> x ⊔ y ≤ z }. #[export] Existing Instances join_sl_order. Class LatticeOrder `(Ale : Le A) `{Meet A} `{Join A} := { lattice_order_meet : MeetSemiLatticeOrder (≤) ; lattice_order_join : JoinSemiLatticeOrder (≤) }. #[export] Existing Instances lattice_order_meet lattice_order_join. Class StrictOrder `(Alt : Lt A) := { strict_order_mere : is_mere_relation A lt ; strictorder_irrefl : Irreflexive (<) ; strictorder_trans : Transitive (<) }. #[export] Existing Instances strict_order_mere strictorder_irrefl strictorder_trans. (* The constructive notion of a total strict total order. We will prove that (<) is in fact a StrictOrder. *) Class PseudoOrder `{Aap : Apart A} (Alt : Lt A) := { pseudo_order_apart : IsApart A ; pseudo_order_mere_lt : is_mere_relation A lt ; pseudo_order_antisym : forall x y, ~(x < y /\ y < x) ; pseudo_order_cotrans : CoTransitive (<) ; apart_iff_total_lt : forall x y, x ≶ y <-> x < y |_| y < x }. #[export] Existing Instances pseudo_order_mere_lt pseudo_order_cotrans. (* A partial order (≤) with a corresponding (<). We will prove that (<) is in fact a StrictOrder *) Class FullPartialOrder `{Aap : Apart A} (Ale : Le A) (Alt : Lt A) := { strict_po_apart : IsApart A ; strict_po_mere_lt : is_mere_relation A lt ; strict_po_po : PartialOrder (≤) ; strict_po_trans : Transitive (<) ; lt_iff_le_apart : forall x y, x < y <-> x ≤ y /\ x ≶ y }. #[export] Existing Instances strict_po_po strict_po_trans. (* A pseudo order (<) with a corresponding (≤). We will prove that (≤) is in fact a PartialOrder. *) Class FullPseudoOrder `{Aap : Apart A} (Ale : Le A) (Alt : Lt A) := { fullpseudo_le_hprop : is_mere_relation A Ale ; full_pseudo_order_pseudo : PseudoOrder Alt ; le_iff_not_lt_flip : forall x y, x ≤ y <-> ~(y < x) }. #[export] Existing Instances fullpseudo_le_hprop full_pseudo_order_pseudo. Section order_maps. Context {A B : Type} {Ale: Le A} {Ble: Le B}(f : A -> B). Class OrderPreserving := order_preserving : forall x y, (x ≤ y -> f x ≤ f y). Class OrderReflecting := order_reflecting : forall x y, (f x ≤ f y -> x ≤ y). Class OrderEmbedding := { order_embedding_preserving : OrderPreserving ; order_embedding_reflecting : OrderReflecting }. #[export] Existing Instances order_embedding_preserving order_embedding_reflecting. End order_maps. Section srorder_maps. Context {A B : Type} {Alt: Lt A} {Blt: Lt B} (f : A -> B). Class StrictlyOrderPreserving := strictly_order_preserving : forall x y, (x < y -> f x < f y). Class StrictlyOrderReflecting := strictly_order_reflecting : forall x y, (f x < f y -> x < y). Class StrictOrderEmbedding := { strict_order_embedding_preserving : StrictlyOrderPreserving ; strict_order_embedding_reflecting : StrictlyOrderReflecting }. #[export] Existing Instances strict_order_embedding_preserving strict_order_embedding_reflecting. End srorder_maps. #[export] Hint Extern 4 (?f _ ≤ ?f _) => apply (order_preserving f) : core. #[export] Hint Extern 4 (?f _ < ?f _) => apply (strictly_order_preserving f) : core. (* We define various classes to describe the order on the lower part of the algebraic hierarchy. This results in the notion of a PseudoSemiRingOrder, which specifies the order on the naturals, integers, rationals and reals. This notion is quite similar to a strictly linearly ordered unital commutative protoring in Davorin Lešnik's PhD thesis. *) Class SemiRingOrder `{Plus A} `{Mult A} `{Zero A} `{One A} (Ale : Le A) := { srorder_po : PartialOrder Ale ; srorder_partial_minus : forall x y, x ≤ y -> exists z, y = x + z ; srorder_plus : forall z, OrderEmbedding (z +) ; nonneg_mult_compat : forall x y, PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) -> PropHolds (0 ≤ x * y) }. #[export] Existing Instances srorder_po srorder_plus. Class StrictSemiRingOrder `{Plus A} `{Mult A} `{Zero A} `{One A} (Alt : Lt A) := { strict_srorder_so : StrictOrder Alt ; strict_srorder_partial_minus : forall x y, x < y -> exists z, y = x + z ; strict_srorder_plus : forall z, StrictOrderEmbedding (z +) ; pos_mult_compat : forall x y, PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x * y) }. #[export] Existing Instances strict_srorder_so strict_srorder_plus. Class PseudoSemiRingOrder `{Apart A} `{Plus A} `{Mult A} `{Zero A} `{One A} (Alt : Lt A) := { pseudo_srorder_strict : PseudoOrder Alt ; pseudo_srorder_partial_minus : forall x y, ~(y < x) -> exists z, y = x + z ; pseudo_srorder_plus : forall z, StrictOrderEmbedding (z +) ; pseudo_srorder_mult_ext : StrongBinaryExtensionality (.*.) ; pseudo_srorder_pos_mult_compat : forall x y, PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x * y) }. #[export] Existing Instances pseudo_srorder_strict pseudo_srorder_plus pseudo_srorder_mult_ext. Class FullPseudoSemiRingOrder `{Apart A} `{Plus A} `{Mult A} `{Zero A} `{One A} (Ale : Le A) (Alt : Lt A) := { full_pseudo_srorder_le_hprop : is_mere_relation A Ale ; full_pseudo_srorder_pso : PseudoSemiRingOrder Alt ; full_pseudo_srorder_le_iff_not_lt_flip : forall x y, x ≤ y <-> ~(y < x) }. #[export] Existing Instances full_pseudo_srorder_le_hprop full_pseudo_srorder_pso. (* Due to bug #2528 *) #[export] Hint Extern 7 (PropHolds (0 < _ * _)) => eapply @pos_mult_compat : typeclass_instances. #[export] Hint Extern 7 (PropHolds (0 ≤ _ * _)) => eapply @nonneg_mult_compat : typeclass_instances. (* Alternatively, we could have defined the standard notion of a RingOrder: Class RingOrder `{Equiv A} `{Plus A} `{Mult A} `{Zero A} (Ale : Le A) := { ringorder_po :> PartialOrder Ale ; ringorder_plus :> forall z, OrderPreserving (z +) ; ringorder_mult : forall x y, 0 ≤ x -> 0 ≤ y -> 0 ≤ x * y }. Unfortunately, this notion is too weak when we consider semirings (e.g. the naturals). Moreover, in case of rings, we prove that this notion is equivalent to our SemiRingOrder class (see orders.rings.from_ring_order). Hence we omit defining such a class. Similarly we prove that a FullSemiRingOrder and a FullPseudoRingOrder are equivalent. Class FullPseudoRingOrder `{Apart A} `{Plus A} `{Mult A} `{Zero A} (Ale : Le A) (Alt : Lt A) := { pseudo_ringorder_spo :> FullPseudoOrder Ale Alt ; pseudo_ringorder_mult_ext :> StrongSetoid_BinaryMorphism (.*.) ; pseudo_ringorder_plus :> forall z, StrictlyOrderPreserving (z +) ; pseudo_ringorder_mult : forall x y, 0 < x -> 0 < y -> 0 < x * y }. *) (* Next, a constructive definition of fields - the ordered fields from HoTT book chapter 11. *) Class OrderedField (A : Type) {Alt : Lt A} {Ale : Le A} {Aap : Apart A} {Azero : Zero A} {Aone : One A} {Aplus : Plus A} {Anegate : Negate A} {Amult : Mult A} {Arecip : Recip A} {Ajoin : Join A} {Ameet : Meet A} := { ordered_field_field : @IsField A Aplus Amult Azero Aone Anegate Aap Arecip ; ordered_field_lattice : LatticeOrder Ale ; ordered_field_fssro : @FullPseudoSemiRingOrder A _ _ _ Azero _ _ _ }. #[export] Existing Instances ordered_field_field ordered_field_lattice ordered_field_fssro. Coq-HoTT-9.0/theories/Classes/interfaces/rationals.v000066400000000000000000000022201474641544500224570ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders. (* Universes: - i universe of origin type - j universe of target types - k universe of applied apart of target types - l universe of Field property of target types *) Class RationalsToField@{i j k l} (A : Type@{i}) := rationals_to_field : forall (B : Type@{j}) `{IsField@{j l k} B} `{!FieldCharacteristic B 0}, A -> B. Arguments rationals_to_field A {_} B {_ _ _ _ _ _ _ _ _} _. (* The Rationals are the initial field of characteristic 0. *) Class Rationals A {Aap : Apart A} {Aplus Amult Azero Aone Aneg Arecip Ale Alt} `{U : !RationalsToField A} := { rationals_field : @IsDecField A Aplus Amult Azero Aone Aneg Arecip ; rationals_order : FullPseudoSemiRingOrder Ale Alt ; rationals_to_field_mor : forall {B} `{IsField B} `{!FieldCharacteristic B 0}, IsSemiRingPreserving (rationals_to_field A B) ; rationals_initial : forall {B} `{IsField B} `{!FieldCharacteristic B 0} {h : A -> B} `{!IsSemiRingPreserving h} x, rationals_to_field A B x = h x }. #[export] Existing Instances rationals_field rationals_order rationals_to_field_mor. Coq-HoTT-9.0/theories/Classes/interfaces/round.v000066400000000000000000000007011474641544500216140ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.interfaces.naturals HoTT.Classes.implementations.peano_naturals. Section round_up. Class RoundUpStrict A `{IsSemiCRing A} `{StrictSemiRingOrder A} := round_up_strict : forall a : A, {n : nat & a < naturals_to_semiring nat A n}. Global Arguments round_up_strict A {_ _ _ _ _ _ _ _ _ _ _ _} _. End round_up. Coq-HoTT-9.0/theories/Classes/interfaces/ua_algebra.v000066400000000000000000000174131474641544500225570ustar00rootroot00000000000000(** This file defines [Algebra]. *) Require Export HoTT.Utf8Minimal HoTT.Basics HoTT.Classes.implementations.ne_list HoTT.Classes.implementations.family_prod. Require Import HoTT.Types HoTT.Universes.HSet HoTT.Spaces.List.Core. Import ne_list.notations. Declare Scope Algebra_scope. Delimit Scope Algebra_scope with Algebra. Open Scope Algebra_scope. Definition SymbolType_internal : Type → Type := ne_list. (** A [Signature] is used to characterise [Algebra]s. In particular a signature specifies which operations (functions) an algebra for the signature is expected to provide. A signature consists of - A type of [Sort]s. An algebra for the signature must provide a type for each [s : Sort]. - A type of function symbols [Symbol]. For each function symbol [u : Symbol], an algebra for the signature must provide a corresponding operation. - The field [symbol_types σ u] indicates which type the operation corresponding to [u] should have. *) Record Signature : Type := BuildSignature { Sort : Type ; Symbol : Type ; symbol_types : Symbol → SymbolType_internal Sort }. (** We have this implicit coercion allowing us to use a signature [σ:Signature] as a map [Symbol σ → SymbolType σ] (see [SymbolType] below). *) Global Coercion symbol_types : Signature >-> Funclass. (** A single sorted [Signature] is a signature with [Sort = Unit]. *) Definition BuildSingleSortedSignature (sym : Type) (arities : sym → nat) : Signature := BuildSignature Unit sym (ne_list.replicate_Sn tt o arities). (** Let [σ:Signature]. For each symbol [u : Symbol σ], [σ u] associates [u] to a [SymbolType σ]. This represents the required type of the algebra operation corresponding to [u]. *) Definition SymbolType (σ : Signature) : Type := ne_list (Sort σ). (** For [s : SymbolType σ], [cod_symboltype σ] is the codomain of the symbol type [s]. *) Definition cod_symboltype {σ} : SymbolType σ → Sort σ := ne_list.last. (** For [s : SymbolType σ], [cod_symboltype σ] is the domain of the symbol type [s]. *) Definition dom_symboltype {σ} : SymbolType σ → list (Sort σ) := ne_list.front. (** For [s : SymbolType σ], [cod_symboltype σ] is the arity of the symbol type [s]. That is the number [n:nat] of arguments of the [SymbolType σ]. *) Definition arity_symboltype {σ} : SymbolType σ → nat := length o dom_symboltype. (** An [Algebra] must provide a family of [Carriers σ] indexed by [Sort σ]. These carriers are the "objects" (types) of the algebra. *) (* [Carriers] is a notation because it will be used for an implicit coercion [Algebra >-> Funclass] below. *) Notation Carriers σ := (Sort σ → Type). (** The function [Operation] maps a family of carriers [A : Carriers σ] and [w : SymbolType σ] to the corresponding function type. << Operation A [:s1; s2; ...; sn; t:] = A s1 → A s2 → ... → A sn → A t >> where [[:s1; s2; ...; sn; t:] : SymbolType σ] is a symbol type with domain [[s1; s2; ...; sn]] and codomain [t]. *) Fixpoint Operation {σ} (A : Carriers σ) (w : SymbolType σ) : Type := match w with | [:s:] => A s | s ::: w' => A s → Operation A w' end. Global Instance trunc_operation `{Funext} {σ : Signature} (A : Carriers σ) {n} `{!∀ s, IsTrunc n (A s)} (w : SymbolType σ) : IsTrunc n (Operation A w). Proof. induction w; exact _. Defined. (** Uncurry of an [f : Operation A w], such that << ap_operation f (x1,x2,...,xn) = f x1 x2 ... xn >> *) Fixpoint ap_operation {σ} {A : Carriers σ} {w : SymbolType σ} : Operation A w → FamilyProd A (dom_symboltype w) → A (cod_symboltype w) := match w with | [:s:] => λ f _, f | s ::: w' => λ f '(x, l), ap_operation (f x) l end. (** Funext for uncurried [Operation A w]. If << ap_operation f (x1,x2,...,xn) = ap_operation g (x1,x2,...,xn) >> for all [(x1,x2,...,xn) : A s1 * A s2 * ... * A sn], then [f = g]. *) Fixpoint path_forall_ap_operation `{Funext} {σ : Signature} {A : Carriers σ} {w : SymbolType σ} : ∀ (f g : Operation A w), (∀ a : FamilyProd A (dom_symboltype w), ap_operation f a = ap_operation g a) -> f = g := match w with | [:s:] => λ (f g : A s) p, p tt | s ::: w' => λ (f g : A s → Operation A w') p, path_forall f g (λ x, path_forall_ap_operation (f x) (g x) (λ a, p (x,a))) end. (** An [Algebra σ] for a signature [σ] consists of a family [carriers : Carriers σ] indexed by the sorts [s : Sort σ], and for each symbol [u : Symbol σ], an operation of type [Operation carriers (σ u)], where [σ u : SymbolType σ] is the symbol type of [u]. *) Record Algebra {σ : Signature} : Type := BuildAlgebra { carriers : Carriers σ ; operations : ∀ (u : Symbol σ), Operation carriers (σ u) }. Arguments Algebra : clear implicits. Arguments BuildAlgebra {σ} carriers operations. (** We have a convenient implicit coercion from an algebra to the family of carriers. *) Global Coercion carriers : Algebra >-> Funclass. Bind Scope Algebra_scope with Algebra. Definition SigAlgebra (σ : Signature) : Type := {c : Carriers σ | ∀ (u : Symbol σ), Operation c (σ u) }. Lemma issig_algebra (σ : Signature) : SigAlgebra σ <~> Algebra σ. Proof. issig. Defined. Class IsTruncAlgebra (n : trunc_index) {σ : Signature} (A : Algebra σ) := trunc_carriers_algebra : ∀ (s : Sort σ), IsTrunc n (A s). Global Existing Instance trunc_carriers_algebra. Notation IsHSetAlgebra := (IsTruncAlgebra 0). Global Instance hprop_is_trunc_algebra `{Funext} (n : trunc_index) {σ : Signature} (A : Algebra σ) : IsHProp (IsTruncAlgebra n A). Proof. apply istrunc_forall. Qed. Global Instance trunc_algebra_succ {σ : Signature} (A : Algebra σ) {n} `{!IsTruncAlgebra n A} : IsTruncAlgebra n.+1 A | 1000. Proof. intro; exact _. Qed. (** To find a path between two algebras [A B : Algebra σ] it suffices to find paths between the carriers and the operations. *) Lemma path_algebra {σ : Signature} (A B : Algebra σ) (p : carriers A = carriers B) (q : transport (λ X, ∀ u, Operation X (σ u)) p (operations A) = operations B) : A = B. Proof. destruct A,B. cbn in *. by path_induction. Defined. Lemma path_ap_carriers_path_algebra {σ} (A B : Algebra σ) (p : carriers A = carriers B) (q : transport (λ X, ∀ u, Operation X (σ u)) p (operations A) = operations B) : ap carriers (path_algebra A B p q) = p. Proof. destruct A as [A a], B as [B b]. cbn in *. by destruct p,q. Defined. (** Suppose [p],[q] are paths in [Algebra σ]. To show that [p = q] it suffices to find a path [r] between the paths corresponding to [p] and [q] in [SigAlgebra σ]. *) Lemma path_path_algebra {σ : Signature} {A B : Algebra σ} (p q : A = B) (r : ap (issig_algebra σ)^-1 p = ap (issig_algebra σ)^-1 q) : p = q. Proof. set (e := (equiv_ap (issig_algebra σ)^-1 A B)). by apply (@equiv_inv _ _ (ap e) (Equivalences.isequiv_ap _ _)). Defined. (** If [p q : A = B] and [IsHSetAlgebra B]. Then [ap carriers p = ap carriers q] implies [p = q]. *) Lemma path_path_hset_algebra `{Funext} {σ : Signature} {A B : Algebra σ} `{IsHSetAlgebra B} (p q : A = B) (r : ap carriers p = ap carriers q) : p = q. Proof. apply path_path_algebra. unshelve eapply path_path_sigma. - transitivity (ap carriers p); [by destruct p |]. transitivity (ap carriers q); [exact r | by destruct q]. - apply path_ishprop. Defined. Module algebra_notations. (** Given [A : Algebra σ] and function symbol [u : Symbol σ], we use the notation [u .# A] to refer to the corresponding algebra operation of type [Operation A (σ u)]. *) Global Notation "u .# A" := (operations A u) : Algebra_scope. End algebra_notations. Coq-HoTT-9.0/theories/Classes/interfaces/ua_congruence.v000066400000000000000000000047071474641544500233140ustar00rootroot00000000000000Require Import HoTT.Universes.HProp HoTT.Classes.interfaces.canonical_names HoTT.Classes.interfaces.ua_algebra. Import algebra_notations ne_list.notations. Section congruence. Context {σ : Signature} (A : Algebra σ) (Φ : ∀ s, Relation (A s)). (** An operation [f : A s1 → A s2 → ... → A sn → A t] satisfies [OpCompatible f] iff << Φ s1 x1 y1 ∧ Φ s2 x2 y2 ∧ ... ∧ Φ sn xn yn >> implies << Φ t (f x1 x2 ... xn) (f y1 y2 ... yn). >> *) Definition OpCompatible {w : SymbolType σ} (f : Operation A w) : Type := ∀ (a b : FamilyProd A (dom_symboltype w)), for_all_2_family_prod A A Φ a b -> Φ (cod_symboltype w) (ap_operation f a) (ap_operation f b). Class OpsCompatible : Type := ops_compatible : ∀ (u : Symbol σ), OpCompatible u.#A. Global Instance trunc_ops_compatible `{Funext} {n : trunc_index} `{!∀ s x y, IsTrunc n (Φ s x y)} : IsTrunc n OpsCompatible. Proof. apply istrunc_forall. Qed. (** A family of relations [Φ] is a congruence iff it is a family of mere equivalence relations and [OpsCompatible A Φ] holds. *) Class IsCongruence : Type := BuildIsCongruence { is_mere_relation_cong : ∀ (s : Sort σ), is_mere_relation (A s) (Φ s) ; equiv_rel_cong : ∀ (s : Sort σ), EquivRel (Φ s) ; ops_compatible_cong : OpsCompatible }. Global Arguments BuildIsCongruence {is_mere_relation_cong} {equiv_rel_cong} {ops_compatible_cong}. Global Existing Instance is_mere_relation_cong. Global Existing Instance equiv_rel_cong. Global Existing Instance ops_compatible_cong. Global Instance hprop_is_congruence `{Funext} : IsHProp IsCongruence. Proof. apply (equiv_hprop_allpath _)^-1. intros [C1 C2 C3] [D1 D2 D3]. by destruct (path_ishprop C1 D1), (path_ishprop C2 D2), (path_ishprop C3 D3). Defined. End congruence. (** If [Φ] is a congruence and [f : A s1 → A s2 → ... → A sn] an operation such that [OpCompatible A Φ f] holds. Then [OpCompatible (f x)] holds for all [x : A s1]. *) Lemma op_compatible_cons {σ : Signature} {A : Algebra σ} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ} (s : Sort σ) (w : SymbolType σ) (f : Operation A (s ::: w)) (x : A s) (P : OpCompatible A Φ f) : OpCompatible A Φ (f x). Proof. intros a b R. exact (P (x,a) (x,b) (EquivRel_Reflexive x, R)). Defined. Coq-HoTT-9.0/theories/Classes/interfaces/ua_setalgebra.v000066400000000000000000000034531474641544500232720ustar00rootroot00000000000000(** This file defines [SetAlgebra], a specialized [Algebra] where the carriers are always sets. *) Require Export HoTT.Classes.interfaces.ua_algebra. Record SetAlgebra {σ : Signature} : Type := BuildSetAlgebra { algebra_setalgebra : Algebra σ ; is_hset_algebra_setalgebra : IsHSetAlgebra algebra_setalgebra }. Arguments SetAlgebra : clear implicits. Global Existing Instance is_hset_algebra_setalgebra. Global Coercion algebra_setalgebra : SetAlgebra >-> Algebra. (** To find a path [A = B] between set algebras [A B : SetAlgebra σ], it is enough to find a path between the defining algebras, [algebra_setalgebra A = algebra_setalgebra B]. *) Lemma path_setalgebra `{Funext} {σ} (A B : SetAlgebra σ) (p : algebra_setalgebra A = algebra_setalgebra B) : A = B. Proof. destruct A as [A AH], B as [B BH]. cbn in *. transparent assert (a : (p#AH = BH)) by apply path_ishprop. by path_induction. Defined. (** The id path is mapped to the id path by [path_setalgebra]. *) Lemma path_setalgebra_1 `{Funext} {σ} (A : SetAlgebra σ) : path_setalgebra A A idpath = idpath. Proof. transparent assert (p : (∀ I : IsHSetAlgebra A, path_ishprop I I = idpath)). - intros. apply path_ishprop. - unfold path_setalgebra. by rewrite p. Qed. (** The function [path_setalgebra A B] is an equivalence with inverse [ap algebra_setalgebra]. *) Global Instance isequiv_path_setalgebra `{Funext} {σ : Signature} (A B : SetAlgebra σ) : IsEquiv (path_setalgebra A B). Proof. refine (isequiv_adjointify (path_setalgebra A B) (ap algebra_setalgebra) _ _). - abstract (intro p; induction p; by rewrite path_setalgebra_1). - abstract ( intro e; destruct A as [A AH], B as [B BH]; cbn in e; destruct e; unfold path_setalgebra; by destruct path_ishprop). Defined. Coq-HoTT-9.0/theories/Classes/isomorphisms/000077500000000000000000000000001474641544500207115ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Classes/isomorphisms/rings.v000066400000000000000000000104771474641544500222330ustar00rootroot00000000000000Require Import HoTT.Types.Arrow. Require Export HoTT.Classes.interfaces.abstract_algebra. Require Import HoTT.Classes.theory.rings. Module SemiRings. Class Operations := operations : sig (fun T => Plus T * Mult T * Zero T * One T)%type. Definition BuildOperations (T : Type) `{Plus T} `{Mult T} `{Zero T} `{One T} : Operations := exist _ T (plus,mult,zero,one). Coercion SR_carrier (s : Operations) : Type := s.1. Global Instance SR_plus (s : Operations) : Plus s := fst (fst (fst s.2)). Global Instance SR_mult (s : Operations) : Mult s := snd (fst (fst s.2)). Global Instance SR_zero (s : Operations) : Zero s := snd (fst s.2). Global Instance SR_one (s : Operations) : One s := snd s.2. Arguments SR_plus !_ / _ _. Arguments SR_mult !_ / _ _. Arguments SR_zero !_ /. Arguments SR_one !_ /. Section contents. Universe U V. Context `{Funext} `{Univalence}. Context (A B : Operations@{U V}). Context (f : A -> B) `{!IsEquiv f} `{!IsSemiRingPreserving f}. Lemma iso_same_semirings : A = B. Proof. apply path_sigma_uncurried. destruct A as [TA [[[plA mlA] zA] uA]], B as [TB [[[plB mlB] zB] uB]];simpl in *. change plA with (@plus TA plA);change plB with (@plus TB plB); change mlA with (@mult TA mlA);change mlB with (@mult TB mlB); change zA with (@zero TA zA);change zB with (@zero TB zB); change uA with (@one TA uA);change uB with (@one TB uB). exists (path_universe f). rewrite !transport_prod;simpl. unfold Plus,Mult,Zero,One. repeat apply path_prod;simpl;try ( apply path_forall;intros x;rewrite transport_arrow; apply path_forall;intros y;rewrite transport_arrow); rewrite transport_path_universe, ?transport_path_universe_V. - rewrite (preserves_plus (f:=f)). apply ap011;apply eisretr. - rewrite (preserves_mult (f:=f)). apply ap011;apply eisretr. - apply preserves_0. - apply preserves_1. Qed. Lemma iso_leibnitz : forall P : Operations -> Type, P A -> P B. Proof. intros P;apply transport. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) first [exact iso_same_semirings|exact iso_same_semirings@{V V}]. Qed. End contents. End SemiRings. Module Rings. Class Operations := operations : sig (fun T => Plus T * Mult T * Zero T * One T * Negate T)%type. Definition BuildOperations (T : Type) `{Plus T} `{Mult T} `{Zero T} `{One T} `{Negate T} : Operations := exist _ T (plus,mult,zero,one,negate). Coercion R_carrier (s : Operations) : Type := s.1. Global Instance R_plus (s : Operations) : Plus s := fst (fst (fst (fst s.2))). Global Instance R_mult (s : Operations) : Mult s := snd (fst (fst (fst s.2))). Global Instance R_zero (s : Operations) : Zero s := snd (fst (fst s.2)). Global Instance R_one (s : Operations) : One s := snd (fst s.2). Global Instance R_negate (s : Operations) : Negate s := snd s.2. Arguments R_plus !_ / _ _. Arguments R_mult !_ / _ _. Arguments R_zero !_ /. Arguments R_one !_ /. Arguments R_negate !_ / _. Section contents. Universe U V. Context `{Funext} `{Univalence}. Context (A B : Operations@{U V}). (* NB: we need to know they're rings for preserves_negate *) Context (f : A -> B) `{!IsEquiv f} `{!IsCRing A} `{!IsCRing B} `{!IsSemiRingPreserving f}. Lemma iso_same_rings : A = B. Proof. apply path_sigma_uncurried. destruct A as [TA [[[[plA mlA] zA] uA] nA]], B as [TB [[[[plB mlB] zB] uB] nB]];simpl in *. change plA with (@plus TA plA);change plB with (@plus TB plB); change mlA with (@mult TA mlA);change mlB with (@mult TB mlB); change zA with (@zero TA zA);change zB with (@zero TB zB); change uA with (@one TA uA);change uB with (@one TB uB); change nA with (@negate TA nA);change nB with (@negate TB nB). exists (path_universe f). rewrite !transport_prod;simpl. unfold Plus,Mult,Zero,One,Negate. repeat apply path_prod;simpl;try ( apply path_forall;intros x;rewrite transport_arrow; try (apply path_forall;intros y;rewrite transport_arrow)); rewrite transport_path_universe, ?transport_path_universe_V. - rewrite (preserves_plus (f:=f)). apply ap011;apply eisretr. - rewrite (preserves_mult (f:=f)). apply ap011;apply eisretr. - apply preserves_0. - apply preserves_1. - rewrite (preserves_negate (f:=f)). apply ap,eisretr. Qed. Lemma iso_leibnitz : forall P : Operations -> Type, P A -> P B. Proof. intros P;apply transport. (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *) first [exact iso_same_rings|exact iso_same_rings@{V V}]. Qed. End contents. End Rings. Coq-HoTT-9.0/theories/Classes/orders/000077500000000000000000000000001474641544500174535ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Classes/orders/archimedean.v000066400000000000000000000061161474641544500221060ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.interfaces.rationals HoTT.Classes.interfaces.archimedean HoTT.Classes.theory.fields HoTT.Classes.orders.rings. Generalizable Variables Q F. Section strict_field_order. Context `{Rationals Q}. Context {Qmeet} {Qjoin} `{@LatticeOrder Q (_ : Le Q) Qmeet Qjoin}. Context `{OrderedField F}. Context {archim : ArchimedeanProperty Q F}. Definition qinc : Cast Q F := rationals_to_field Q F. Existing Instance qinc. Lemma char_minus_left x y : - x < y -> - y < x. Proof. intros ltnxy. rewrite <- (negate_involutive x). apply (snd (flip_lt_negate _ _)). assumption. Qed. Lemma char_minus_right x y : x < - y -> y < - x. Proof. intros ltnxy. rewrite <- (negate_involutive y). apply (snd (flip_lt_negate _ _)). assumption. Qed. Lemma char_plus_left : forall (q : Q) (x y : F), ' q < x + y <-> hexists (fun s : Q => (' s < x) /\ (' (q - s) < y)). Proof. Abort. Lemma char_plus_right : forall (r : Q) (x y : F), x + y < ' r <-> hexists (fun t : Q => (x < ' t) /\ (y < ' (r - t))). Proof. Abort. Definition hexists4 {X Y Z W} (f : X -> Y -> Z -> W -> Type) : HProp := hexists (fun xyzw => match xyzw with | ((x , y) , (z , w)) => f x y z w end). Lemma char_times_left : forall (q : Q) (x y : F), ' q < x * y <-> hexists4 (fun a b c d : Q => (q < meet (meet a b) (meet c d)) /\ ((' a < x < ' b) /\ (' c < y < ' d) ) ). Proof. Abort. Lemma char_times_right : forall (r : Q) (x y : F), x * y < ' r <-> hexists4 (fun a b c d : Q => and (join (join a b) (join c d) < r) (and (' a < x < ' b) (' c < y < ' d) ) ). Proof. Abort. Lemma char_recip_pos_left : forall (q : Q) (z : F) (nu : 0 < z), 'q < recip' z (positive_apart_zero z nu) <-> ' q * z < 1. Proof. Abort. Lemma char_recip_pos_right : forall (r : Q) (z : F) (nu : 0 < z), recip' z (positive_apart_zero z nu) < ' r <-> 1 < ' r * z. Proof. Abort. Lemma char_recip_neg_left : forall (q : Q) (w : F) (nu : w < 0), 'q < recip' w (negative_apart_zero w nu) <-> ' q * w < 1. Proof. Abort. Lemma char_recip_neg_right : forall (r : Q) (w : F) (nu : w < 0), recip' w (negative_apart_zero w nu) < ' r <-> ' r * w < 1. Proof. Abort. Lemma char_meet_left : forall (q : Q) (x y : F), ' q < meet x y <-> ' q < x /\ ' q < y. Proof. Abort. Lemma char_meet_right : forall (r : Q) (x y : F), meet x y < 'r <-> hor (x < 'r) (y < 'r). Proof. Abort. Lemma char_join_left : forall (q : Q) (x y : F), ' q < join x y <-> hor ('q < x) ('q < y). Proof. Abort. Lemma char_join_right : forall (r : Q) (x y : F), join x y < ' r <-> x < ' r /\ y < ' r. Proof. Abort. End strict_field_order. Coq-HoTT-9.0/theories/Classes/orders/dec_fields.v000066400000000000000000000060541474641544500217300ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.theory.dec_fields. Require Export HoTT.Classes.orders.rings. Generalizable Variables F f R Fle Flt. Section contents. Context `{IsDecField F} `{Apart F} `{!TrivialApart F} `{!FullPseudoSemiRingOrder Fle Flt} `{DecidablePaths F}. (* Add Ring F : (stdlib_ring_theory F). *) Instance pos_dec_recip_compat x : PropHolds (0 < x) -> PropHolds (0 < /x). Proof. intros E. apply (strictly_order_reflecting (x *.)). rewrite dec_recip_inverse by (apply orders.lt_ne_flip;trivial). rewrite mult_0_r. solve_propholds. Qed. Instance nonneg_dec_recip_compat x : PropHolds (0 ≤ x) -> PropHolds (0 ≤ /x). Proof. intros E. red. destruct (dec (x = 0)) as [E2 | E2]. - rewrite E2, dec_recip_0. rewrite E2 in E;trivial. - apply lt_le. apply pos_dec_recip_compat. apply lt_iff_le_ne. split;trivial. apply symmetric_neq;trivial. Qed. Lemma neg_dec_recip_compat x : x < 0 -> /x < 0. Proof. intros. apply flip_neg_negate. rewrite dec_recip_negate. apply pos_dec_recip_compat. apply flip_neg_negate. trivial. Qed. Lemma nonpos_dec_recip_compat x : x ≤ 0 -> /x ≤ 0. Proof. intros. apply flip_nonpos_negate. rewrite dec_recip_negate. apply nonneg_dec_recip_compat. apply flip_nonpos_negate;trivial. Qed. Lemma flip_le_dec_recip x y : 0 < y -> y ≤ x -> /x ≤ /y. Proof. intros E1 E2. apply (order_reflecting_pos (.*.) x). - apply lt_le_trans with y;trivial. - rewrite dec_recip_inverse. + apply (order_reflecting_pos (.*.) y);trivial. rewrite (commutativity x), simple_associativity, dec_recip_inverse. * rewrite mult_1_l,mult_1_r. trivial. * apply lt_ne_flip;trivial. + apply lt_ne_flip. apply lt_le_trans with y;trivial. Qed. Lemma flip_le_dec_recip_l x y : 0 < y -> /y ≤ x -> /x ≤ y. Proof. intros E1 E2. rewrite <-(dec_recip_involutive y). apply flip_le_dec_recip;trivial. apply pos_dec_recip_compat;trivial. Qed. Lemma flip_le_dec_recip_r x y : 0 < y -> y ≤ /x -> x ≤ /y. Proof. intros E1 E2. rewrite <-(dec_recip_involutive x). apply flip_le_dec_recip;trivial. Qed. Lemma flip_lt_dec_recip x y : 0 < y -> y < x -> /x < /y. Proof. intros E1 E2. assert (0 < x) by (transitivity y;trivial). apply (strictly_order_reflecting (x *.)). rewrite dec_recip_inverse. - apply (strictly_order_reflecting (y *.)). rewrite (commutativity x), simple_associativity, dec_recip_inverse. + rewrite mult_1_l,mult_1_r. trivial. + apply lt_ne_flip. trivial. - apply lt_ne_flip;trivial. Qed. Lemma flip_lt_dec_recip_l x y : 0 < y -> /y < x -> /x < y. Proof. intros E1 E2. rewrite <-(dec_recip_involutive y). apply flip_lt_dec_recip; trivial. apply pos_dec_recip_compat. trivial. Qed. Lemma flip_lt_dec_recip_r x y : 0 < y -> y < /x -> x < /y. Proof. intros E1 E2. rewrite <-(dec_recip_involutive x). apply flip_lt_dec_recip;trivial. Qed. End contents. (* Due to bug #2528 *) #[export] Hint Extern 12 (PropHolds (0 ≤ _)) => eapply @nonneg_dec_recip_compat : typeclass_instances. #[export] Hint Extern 12 (PropHolds (0 < _)) => eapply @pos_dec_recip_compat : typeclass_instances. Coq-HoTT-9.0/theories/Classes/orders/fields.v000066400000000000000000000066561474641544500211250ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.theory.fields. Require Export HoTT.Classes.orders.rings. Generalizable Variables F f R Fle Flt. Section contents. Context `{OrderedField F}. Lemma pos_recip_compat (x : F) (Px : 0 < x) : 0 < //(x;positive_apart_zero x Px). Proof. apply (strictly_order_reflecting (x *.)). rewrite mult_0_r. rewrite (recip_inverse' x). apply lt_0_1. Qed. Lemma neg_recip_compat (x : F) (Px : x < 0) : //(x;negative_apart_zero x Px) < 0. Proof. set (negxpos := fst (flip_neg_negate x) Px). apply (strictly_order_reflecting ((-x) *.)). rewrite mult_0_r. rewrite <- negate_mult_distr_l. rewrite (recip_inverse' x). apply flip_pos_negate, lt_0_1. Qed. Lemma flip_lt_recip x y (Py : 0 < y) (ltyx : y < x) : let apy0 := positive_apart_zero y Py in let apx0 := positive_apart_zero x (transitivity Py ltyx) in //(x;apx0) < //(y;apy0). Proof. assert (0 < x) by (transitivity y;trivial). apply (strictly_order_reflecting (x *.)). rewrite (recip_inverse' x ). rewrite mult_comm. apply (strictly_order_reflecting (y *.)). rewrite mult_assoc, mult_1_r. rewrite (recip_inverse' y), mult_1_l; assumption. Qed. Lemma flip_lt_recip_l x y (Py : 0 < y) (ltyx : //(y;positive_apart_zero y Py) < x) : let apx0 := positive_apart_zero x (transitivity (pos_recip_compat y Py) ltyx) in //(x;apx0) < y. Proof. set (apy0 := positive_apart_zero y Py). set (eq := recip_involutive (y;apy0)). set (eq' := ap pr1 eq). cbn in eq'. rewrite <- eq'. unfold recip_on_apart. (* need : // (y; apy0) < x *) (* have : //(y;pseudo_order_lt_apart_flip 0 y Py) < x *) set (ltyx2 := ltyx). unfold ltyx2. rewrite (recip_irrelevant y (positive_apart_zero y Py) apy0) in ltyx2. set (ltyx_recips := flip_lt_recip x (// (y; apy0)) (pos_recip_compat y Py) ltyx2). cbn in ltyx_recips. rewrite (recip_irrelevant x _ (positive_apart_zero x (transitivity (pos_recip_compat y Py) ltyx))) in ltyx_recips. cbn. rewrite (recip_irrelevant (//(y;apy0)) _ (recip_apart y apy0)) in ltyx_recips. assumption. Qed. Lemma flip_lt_recip_r (x y : F) (Px : 0 < x) (Py : 0 < y) (ltyx : y < //(x;positive_apart_zero x Px)) : x < //(y;positive_apart_zero y Py). Proof. set (apx0 := positive_apart_zero x Px). set (apy0 := positive_apart_zero y Py). change x with ((x;apx0) : ApartZero F).1. rewrite <- (recip_involutive (x;apx0)). unfold recip_on_apart; cbn. assert (ltry := pos_recip_compat y Py). rewrite (recip_irrelevant y (positive_apart_zero y Py) apy0) in ltry. change y with ((y;apy0) : ApartZero F).1 in ltyx. rewrite <- (recip_involutive (y;apy0)) in ltyx. unfold recip_on_apart in ltyx; cbn in ltyx. rewrite (recip_irrelevant (//(y;apy0)) (recip_apart y apy0) (positive_apart_zero (// (y; apy0)) ltry)) in ltyx. assert (ltxy := flip_lt_recip_l (// (x; apx0)) (// (y; apy0)) ltry ltyx). cbn in ltxy. rewrite (recip_irrelevant (//(x;apx0)) (positive_apart_zero (// (x; apx0)) (transitivity (pos_recip_compat (// (y; apy0)) ltry) ltyx)) (recip_apart x apx0)) in ltxy. assumption. Qed. Lemma field_split2 (x : F) : (x * recip' 2 (positive_apart_zero 2 lt_0_2)) + (x * recip' 2 (positive_apart_zero 2 lt_0_2)) = x. Proof. rewrite <- plus_mult_distr_l. rewrite <- (mult_1_l (recip' 2 (positive_apart_zero 2 lt_0_2))). rewrite <- plus_mult_distr_r. rewrite (recip_inverse' 2 (positive_apart_zero 2 lt_0_2)). rewrite mult_1_r. reflexivity. Qed. End contents. Coq-HoTT-9.0/theories/Classes/orders/integers.v000066400000000000000000000051421474641544500214640ustar00rootroot00000000000000Require HoTT.Classes.theory.int_abs. Require Import HoTT.Classes.implementations.peano_naturals HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.naturals HoTT.Classes.interfaces.orders HoTT.Classes.implementations.natpair_integers HoTT.Classes.theory.rings HoTT.Classes.theory.integers. Require Export HoTT.Classes.orders.nat_int. Import NatPair.Instances. Generalizable Variables N Z R f. Section integers. Context `{Funext} `{Univalence}. Context `{Integers Z} `{!TrivialApart Z}. (* Add Ring Z : (rings.stdlib_ring_theory Z). *) (* Add Ring nat : (rings.stdlib_semiring_theory nat). *) Lemma induction (P: Z -> Type): P 0 -> (forall n, 0 ≤ n -> P n -> P (1 + n)) -> (forall n, n ≤ 0 -> P n -> P (n - 1)) -> forall n, P n. Proof. intros P0 Psuc1 Psuc2 n. destruct (int_abs_sig Z nat n) as [[a A]|[a A]]. - rewrite <-A. clear A. revert a. apply naturals.induction. + rewrite rings.preserves_0. trivial. + intros m E. rewrite rings.preserves_plus, rings.preserves_1. apply Psuc1. * apply to_semiring_nonneg. * trivial. - rewrite <-(negate_involutive n), <-A. clear A. revert a. apply naturals.induction. + rewrite rings.preserves_0, rings.negate_0. trivial. + intros m E. rewrite rings.preserves_plus, rings.preserves_1. rewrite rings.negate_plus_distr, commutativity. apply Psuc2. * apply naturals.negate_to_ring_nonpos. * trivial. Qed. Lemma induction_nonneg (P: Z -> Type): P 0 -> (forall n, 0 ≤ n -> P n -> P (1 + n)) -> forall n, 0 ≤ n -> P n. Proof. intros P0 PS. refine (induction _ _ _ _); auto. intros n E1 ? E2. destruct (rings.is_ne_0 1). apply (antisymmetry (≤)). - apply (order_reflecting ((n - 1) +)). rewrite <-plus_assoc,plus_negate_l,2!plus_0_r. transitivity 0;trivial. - transitivity (n - 1);trivial. apply (order_reflecting (1 +)). rewrite plus_comm,<-plus_assoc,plus_negate_l,plus_0_r. transitivity 0. + trivial. + apply le_0_2. Qed. Global Instance: Biinduction Z. Proof. intros P P0 Psuc. apply induction; trivial. - intros ??;apply Psuc. - intros;apply Psuc. rewrite plus_comm,<-plus_assoc,plus_negate_l,plus_0_r. trivial. Qed. Global Instance slow_int_le_dec : forall x y: Z, Decidable (x ≤ y) | 10. Proof. intros x y. (* otherwise Z_le gets defined using peano.nat_ring but we only know order_reflecting when using naturals.nat_ring *) pose (naturals_ring) as E0. destruct (dec (integers_to_ring _ (NatPair.Z nat) x ≤ integers_to_ring _ (NatPair.Z nat) y)) as [E|E]. - left. apply (order_reflecting _) in E. trivial. - right. intro;apply E;apply (order_preserving _);trivial. Qed. End integers. Coq-HoTT-9.0/theories/Classes/orders/lattices.v000066400000000000000000000413321474641544500214550ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.orders.semirings HoTT.Classes.theory.lattices. Generalizable Variables K L f. (* We prove that the algebraic definition of a lattice corresponds to the order theoretic one. Note that we do not make any of these instances global, because that would cause loops. *) Section join_semilattice_order. Context `{JoinSemiLatticeOrder L}. Lemma join_ub_3_r x y z : z ≤ x ⊔ y ⊔ z. Proof. apply join_ub_r. Qed. Lemma join_ub_3_m x y z : y ≤ x ⊔ y ⊔ z. Proof. transitivity (x ⊔ y). - apply join_ub_r. - apply join_ub_l. Qed. Lemma join_ub_3_l x y z : x ≤ x ⊔ y ⊔ z. Proof. transitivity (x ⊔ y); apply join_ub_l. Qed. Lemma join_ub_3_assoc_l x y z : x ≤ x ⊔ (y ⊔ z). Proof. apply join_ub_l. Qed. Lemma join_ub_3_assoc_m x y z : y ≤ x ⊔ (y ⊔ z). Proof. transitivity (y ⊔ z). - apply join_ub_l. - apply join_ub_r. Qed. Lemma join_ub_3_assoc_r x y z : z ≤ x ⊔ (y ⊔ z). Proof. transitivity (y ⊔ z); apply join_ub_r. Qed. Instance join_sl_order_join_sl: IsJoinSemiLattice L. Proof. repeat split. - apply _. - intros x y z. apply (antisymmetry (≤)). + apply join_lub. * apply join_ub_3_l. * apply join_lub. ** apply join_ub_3_m. ** apply join_ub_3_r. + apply join_lub. * apply join_lub. ** apply join_ub_3_assoc_l. ** apply join_ub_3_assoc_m. * apply join_ub_3_assoc_r. - intros x y. apply (antisymmetry (≤)); apply join_lub; first [apply join_ub_l | apply join_ub_r]. - intros x. red. apply (antisymmetry (≤)). + apply join_lub; apply reflexivity. + apply join_ub_l. Qed. Lemma join_le_compat_r x y z : z ≤ x -> z ≤ x ⊔ y. Proof. intros E. transitivity x. - trivial. - apply join_ub_l. Qed. Lemma join_le_compat_l x y z : z ≤ y -> z ≤ x ⊔ y. Proof. intros E. rewrite (commutativity (f:=join)). apply join_le_compat_r. trivial. Qed. Lemma join_l x y : y ≤ x -> x ⊔ y = x. Proof. intros E. apply (antisymmetry (≤)). - apply join_lub;trivial. apply reflexivity. - apply join_ub_l. Qed. Lemma join_r x y : x ≤ y -> x ⊔ y = y. Proof. intros E. rewrite (commutativity (f:=join)). apply join_l. trivial. Qed. Lemma join_sl_le_spec x y : x ≤ y <-> x ⊔ y = y. Proof. split; intros E. - apply join_r. trivial. - rewrite <-E. apply join_ub_l. Qed. Global Instance join_le_preserving_l : forall z, OrderPreserving (z ⊔). Proof. red;intros. apply join_lub. - apply join_ub_l. - apply join_le_compat_l. trivial. Qed. Global Instance join_le_preserving_r : forall z, OrderPreserving (⊔ z). Proof. intros. apply maps.order_preserving_flip. Qed. Lemma join_le_compat x₁ x₂ y₁ y₂ : x₁ ≤ x₂ -> y₁ ≤ y₂ -> x₁ ⊔ y₁ ≤ x₂ ⊔ y₂. Proof. intros E1 E2. transitivity (x₁ ⊔ y₂). - apply (order_preserving (x₁ ⊔)). trivial. - apply (order_preserving (⊔ y₂));trivial. Qed. Lemma join_le x y z : x ≤ z -> y ≤ z -> x ⊔ y ≤ z. Proof. apply join_lub. Qed. Section total_join. Context `{!TotalRelation le}. Lemma total_join_either `{!TotalRelation le} x y : join x y = x |_| join x y = y. Proof. destruct (total le x y) as [E|E]. - right. apply join_r,E. - left. apply join_l,E. Qed. Definition max x y := match total le x y with | inl _ => y | inr _ => x end. Lemma total_join_max x y : join x y = max x y. Proof. unfold max;destruct (total le x y) as [E|E]. - apply join_r,E. - apply join_l,E. Qed. End total_join. Lemma join_idempotent x : x ⊔ x = x. Proof. assert (le1 : x ⊔ x ≤ x). { refine (join_lub _ _ _ _ _); apply reflexivity. } assert (le2 : x ≤ x ⊔ x). { refine (join_ub_l _ _). } refine (antisymmetry _ _ _ le1 le2). Qed. End join_semilattice_order. Section bounded_join_semilattice. Context `{JoinSemiLatticeOrder L} `{Bottom L} `{!IsBoundedJoinSemiLattice L}. Lemma above_bottom x : ⊥ ≤ x. Proof. apply join_sl_le_spec. rewrite left_identity. reflexivity. Qed. Lemma below_bottom x : x ≤ ⊥ -> x = ⊥. Proof. intros E. apply join_sl_le_spec in E. rewrite right_identity in E. trivial. Qed. End bounded_join_semilattice. Section meet_semilattice_order. Context `{MeetSemiLatticeOrder L}. Lemma meet_lb_3_r x y z : x ⊓ y ⊓ z ≤ z. Proof. apply meet_lb_r. Qed. Lemma meet_lb_3_m x y z : x ⊓ y ⊓ z ≤ y. Proof. transitivity (x ⊓ y). - apply meet_lb_l. - apply meet_lb_r. Qed. Lemma meet_lb_3_l x y z : x ⊓ y ⊓ z ≤ x. Proof. transitivity (x ⊓ y); apply meet_lb_l. Qed. Lemma meet_lb_3_assoc_l x y z : x ⊓ (y ⊓ z) ≤ x. Proof. apply meet_lb_l. Qed. Lemma meet_lb_3_assoc_m x y z : x ⊓ (y ⊓ z) ≤ y. Proof. transitivity (y ⊓ z). - apply meet_lb_r. - apply meet_lb_l. Qed. Lemma meet_lb_3_assoc_r x y z : x ⊓ (y ⊓ z) ≤ z. Proof. transitivity (y ⊓ z); apply meet_lb_r. Qed. Instance meet_sl_order_meet_sl: IsMeetSemiLattice L. Proof. repeat split. - apply _. - intros x y z. apply (antisymmetry (≤)). + apply meet_glb. * apply meet_glb. ** apply meet_lb_3_assoc_l. ** apply meet_lb_3_assoc_m. * apply meet_lb_3_assoc_r. + apply meet_glb. ** apply meet_lb_3_l. ** apply meet_glb. *** apply meet_lb_3_m. *** apply meet_lb_3_r. - intros x y. apply (antisymmetry (≤)); apply meet_glb; first [apply meet_lb_l | try apply meet_lb_r]. - intros x. red. apply (antisymmetry (≤)). + apply meet_lb_l. + apply meet_glb;apply reflexivity. Qed. Lemma meet_le_compat_r x y z : x ≤ z -> x ⊓ y ≤ z. Proof. intros E. transitivity x. - apply meet_lb_l. - trivial. Qed. Lemma meet_le_compat_l x y z : y ≤ z -> x ⊓ y ≤ z. Proof. intros E. rewrite (commutativity (f:=meet)). apply meet_le_compat_r. trivial. Qed. Lemma meet_l x y : x ≤ y -> x ⊓ y = x. Proof. intros E. apply (antisymmetry (≤)). - apply meet_lb_l. - apply meet_glb; trivial. apply reflexivity. Qed. Lemma meet_r x y : y ≤ x -> x ⊓ y = y. Proof. intros E. rewrite (commutativity (f:=meet)). apply meet_l. trivial. Qed. Lemma meet_sl_le_spec x y : x ≤ y <-> x ⊓ y = x. Proof. split; intros E. - apply meet_l;trivial. - rewrite <-E. apply meet_lb_r. Qed. Global Instance: forall z, OrderPreserving (z ⊓). Proof. red;intros. apply meet_glb. - apply meet_lb_l. - apply meet_le_compat_l. trivial. Qed. Global Instance: forall z, OrderPreserving (⊓ z). Proof. intros. apply maps.order_preserving_flip. Qed. Lemma meet_le_compat x₁ x₂ y₁ y₂ : x₁ ≤ x₂ -> y₁ ≤ y₂ -> x₁ ⊓ y₁ ≤ x₂ ⊓ y₂. Proof. intros E1 E2. transitivity (x₁ ⊓ y₂). - apply (order_preserving (x₁ ⊓)). trivial. - apply (order_preserving (⊓ y₂)). trivial. Qed. Lemma meet_le x y z : z ≤ x -> z ≤ y -> z ≤ x ⊓ y. Proof. apply meet_glb. Qed. Section total_meet. Context `{!TotalRelation le}. Lemma total_meet_either x y : meet x y = x |_| meet x y = y. Proof. destruct (total le x y) as [E|E]. - left. apply meet_l,E. - right. apply meet_r,E. Qed. Definition min x y := match total le x y with | inr _ => y | inl _ => x end. Lemma total_meet_min x y : meet x y = min x y. Proof. unfold min. destruct (total le x y) as [E|E]. - apply meet_l,E. - apply meet_r,E. Qed. End total_meet. Lemma meet_idempotent x : x ⊓ x = x. Proof. assert (le1 : x ⊓ x ≤ x). { refine (meet_lb_l _ _). } assert (le2 : x ≤ x ⊓ x). { refine (meet_glb _ _ _ _ _); apply reflexivity. } refine (antisymmetry _ _ _ le1 le2). Qed. End meet_semilattice_order. Section lattice_order. Context `{LatticeOrder L}. Instance: IsJoinSemiLattice L := join_sl_order_join_sl. Instance: IsMeetSemiLattice L := meet_sl_order_meet_sl. Instance: Absorption (⊓) (⊔). Proof. intros x y. apply (antisymmetry (≤)). - apply meet_lb_l. - apply meet_le. + apply reflexivity. + apply join_ub_l. Qed. Instance: Absorption (⊔) (⊓). Proof. intros x y. apply (antisymmetry (≤)). - apply join_le. + apply reflexivity. + apply meet_lb_l. - apply join_ub_l. Qed. Instance lattice_order_lattice: IsLattice L := {}. Lemma meet_join_distr_l_le x y z : (x ⊓ y) ⊔ (x ⊓ z) ≤ x ⊓ (y ⊔ z). Proof. apply meet_le. - apply join_le; apply meet_lb_l. - apply join_le. + transitivity y. * apply meet_lb_r. * apply join_ub_l. + transitivity z. * apply meet_lb_r. * apply join_ub_r. Qed. Lemma join_meet_distr_l_le x y z : x ⊔ (y ⊓ z) ≤ (x ⊔ y) ⊓ (x ⊔ z). Proof. apply meet_le. - apply join_le. + apply join_ub_l. + transitivity y. * apply meet_lb_l. * apply join_ub_r. - apply join_le. + apply join_ub_l. + transitivity z. * apply meet_lb_r. * apply join_ub_r. Qed. End lattice_order. Definition default_join_sl_le `{IsJoinSemiLattice L} : Le L := fun x y => x ⊔ y = y. Section join_sl_order_alt. Context `{IsJoinSemiLattice L} `{Le L} `{is_mere_relation L le} (le_correct : forall x y, x ≤ y <-> x ⊔ y = y). Lemma alt_Build_JoinSemiLatticeOrder : JoinSemiLatticeOrder (≤). Proof. repeat split. - apply _. - apply _. - intros x. apply le_correct. apply binary_idempotent. - intros x y z E1 E2. apply le_correct in E1;apply le_correct in E2;apply le_correct. rewrite <-E2, simple_associativity, E1. reflexivity. - intros x y E1 E2. apply le_correct in E1;apply le_correct in E2. rewrite <-E1, (commutativity (f:=join)). apply symmetry;trivial. - intros. apply le_correct. rewrite simple_associativity,binary_idempotent. reflexivity. - intros;apply le_correct. rewrite (commutativity (f:=join)). rewrite <-simple_associativity. rewrite (idempotency _ _). reflexivity. - intros x y z E1 E2. apply le_correct in E1;apply le_correct in E2;apply le_correct. rewrite <-simple_associativity, E2. trivial. Qed. End join_sl_order_alt. Definition default_meet_sl_le `{IsMeetSemiLattice L} : Le L := fun x y => x ⊓ y = x. Section meet_sl_order_alt. Context `{IsMeetSemiLattice L} `{Le L} `{is_mere_relation L le} (le_correct : forall x y, x ≤ y <-> x ⊓ y = x). Lemma alt_Build_MeetSemiLatticeOrder : MeetSemiLatticeOrder (≤). Proof. repeat split. - apply _. - apply _. - intros ?. apply le_correct. apply (idempotency _ _). - intros ? ? ? E1 E2. apply le_correct in E1;apply le_correct in E2;apply le_correct. rewrite <-E1, <-simple_associativity, E2. reflexivity. - intros ? ? E1 E2. apply le_correct in E1;apply le_correct in E2. rewrite <-E2, (commutativity (f:=meet)). apply symmetry,E1. - intros ? ?. apply le_correct. rewrite (commutativity (f:=meet)), simple_associativity, (idempotency _ _). reflexivity. - intros ? ?. apply le_correct. rewrite <-simple_associativity, (idempotency _ _). reflexivity. - intros ? ? ? E1 E2. apply le_correct in E1;apply le_correct in E2;apply le_correct. rewrite associativity, E1. trivial. Qed. End meet_sl_order_alt. Section join_order_preserving. Context `{JoinSemiLatticeOrder L} `{JoinSemiLatticeOrder K} (f : L -> K) `{!IsJoinPreserving f}. Lemma join_sl_mor_preserving: OrderPreserving f. Proof. intros x y E. apply join_sl_le_spec in E. apply join_sl_le_spec. rewrite <-preserves_join. apply ap, E. Qed. Lemma join_sl_mor_reflecting `{!IsInjective f}: OrderReflecting f. Proof. intros x y E. apply join_sl_le_spec in E. apply join_sl_le_spec. rewrite <-preserves_join in E. apply (injective f). assumption. Qed. End join_order_preserving. Section meet_order_preserving. Context `{MeetSemiLatticeOrder L} `{MeetSemiLatticeOrder K} (f : L -> K) `{!IsMeetPreserving f}. Lemma meet_sl_mor_preserving: OrderPreserving f. Proof. intros x y E. apply meet_sl_le_spec in E. apply meet_sl_le_spec. rewrite <-preserves_meet. apply ap, E. Qed. Lemma meet_sl_mor_reflecting `{!IsInjective f}: OrderReflecting f. Proof. intros x y E. apply meet_sl_le_spec in E. apply meet_sl_le_spec. rewrite <-preserves_meet in E. apply (injective f). assumption. Qed. End meet_order_preserving. Section order_preserving_join_sl_mor. Context `{JoinSemiLatticeOrder L} `{JoinSemiLatticeOrder K} `{!TotalOrder (_ : Le L)} `{!TotalOrder (_ : Le K)} `{!OrderPreserving (f : L -> K)}. Lemma order_preserving_join_sl_mor: IsJoinPreserving f. Proof. intros x y. case (total (≤) x y); intros E. - change (f (join x y) = join (f x) (f y)). rewrite (join_r _ _ E),join_r;trivial. apply (order_preserving _). trivial. - change (f (join x y) = join (f x) (f y)). rewrite 2!join_l; trivial. apply (order_preserving _). trivial. Qed. End order_preserving_join_sl_mor. Section order_preserving_meet_sl_mor. Context `{MeetSemiLatticeOrder L} `{MeetSemiLatticeOrder K} `{!TotalOrder (_ : Le L)} `{!TotalOrder (_ : Le K)} `{!OrderPreserving (f : L -> K)}. Lemma order_preserving_meet_sl_mor: IsSemiGroupPreserving f. Proof. intros x y. case (total (≤) x y); intros E. - change (f (meet x y) = meet (f x) (f y)). rewrite 2!meet_l;trivial. apply (order_preserving _). trivial. - change (f (meet x y) = meet (f x) (f y)). rewrite 2!meet_r; trivial. apply (order_preserving _). trivial. Qed. End order_preserving_meet_sl_mor. Section strict_ordered_field. Generalizable Variables Lle Llt Lmeet Ljoin Lapart. Context `{@LatticeOrder L Lle Lmeet Ljoin}. Context `{@FullPseudoOrder L Lapart Lle Llt}. Lemma join_lt_l_l x y z : z < x -> z < x ⊔ y. Proof. intros ltzx. refine (lt_le_trans z x _ _ _); try assumption. apply join_ub_l. Qed. Lemma join_lt_l_r x y z : z < y -> z < x ⊔ y. Proof. intros ltzy. refine (lt_le_trans z y _ _ _); try assumption. apply join_ub_r. Qed. Lemma join_lt_r x y z : x < z -> y < z -> x ⊔ y < z. Proof. intros ltxz ltyz. set (disj := cotransitive ltxz (x ⊔ y)). refine (Trunc_rec _ disj); intros [ltxxy|ltxyz]. - set (disj' := cotransitive ltyz (x ⊔ y)). refine (Trunc_rec _ disj'); intros [ltyxy|ltxyz]. + assert (ineqx : x ⊔ y <> x). { apply lt_ne_flip; assumption. } assert (nleyx : ~ (y ≤ x)) by exact (not_contrapositive (join_l x y) ineqx). assert (lexy : x ≤ y). { apply le_iff_not_lt_flip. intros ltyx. refine (nleyx (lt_le _ _ _)). } assert (ineqy : x ⊔ y <> y). { apply lt_ne_flip; assumption. } assert (nlexy : ~ (x ≤ y)) by exact (not_contrapositive (join_r x y) ineqy). assert (leyx : y ≤ x). { apply le_iff_not_lt_flip. intros ltxy. refine (nlexy (lt_le _ _ _)). } assert (eqxy : x = y) by refine (antisymmetry _ _ _ lexy leyx). rewrite <- eqxy in ineqx. destruct (ineqx (join_idempotent x)). + assumption. - assumption. Qed. Lemma meet_lt_r_l x y z : x < z -> x ⊓ y < z. Proof. intros ltxz. refine (le_lt_trans _ x _ _ _); try assumption. apply meet_lb_l. Qed. Lemma meet_lt_r_r x y z : y < z -> x ⊓ y < z. Proof. intros ltyz. refine (le_lt_trans _ y _ _ _); try assumption. apply meet_lb_r. Qed. Lemma meet_lt_l x y z : x < y -> x < z -> x < y ⊓ z. Proof. intros ltxy ltxz. set (disj := cotransitive ltxy (y ⊓ z)). refine (Trunc_rec _ disj); intros [ltxyy|ltyzy]. - assumption. - set (disj' := cotransitive ltxz (y ⊓ z)). refine (Trunc_rec _ disj'); intros [ltxyz|ltyzz]. + assumption. + assert (ineqy : y ⊓ z <> y). { apply lt_ne; assumption. } assert (nleyz : ~ (y ≤ z)) by exact (not_contrapositive (meet_l y z) ineqy). assert (lezy : z ≤ y). { apply le_iff_not_lt_flip. intros ltzy. refine (nleyz (lt_le _ _ _)). } assert (ineqz : y ⊓ z <> z). { apply lt_ne; assumption. } assert (nlezy : ~ (z ≤ y)) by exact (not_contrapositive (meet_r y z) ineqz). assert (leyz : y ≤ z). { apply le_iff_not_lt_flip. intros ltzy. refine (nlezy (lt_le _ _ _)). } assert (eqyz : y = z) by refine (antisymmetry _ _ _ leyz lezy). rewrite <- eqyz in ineqy. destruct (ineqy (meet_idempotent y)). Qed. End strict_ordered_field. Coq-HoTT-9.0/theories/Classes/orders/maps.v000066400000000000000000000230051474641544500206020ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.orders.orders HoTT.Classes.theory.apartness. Generalizable Variables A B C R S f g z. (* If a function between strict partial orders is order preserving (back), we can derive that it is strictly order preserving (back) *) Section strictly_order_preserving. Context `{FullPartialOrder A} `{FullPartialOrder B}. Global Instance strictly_order_preserving_inj `{!OrderPreserving (f : A -> B)} `{!IsStrongInjective f} : StrictlyOrderPreserving f | 20. Proof. intros x y E. apply lt_iff_le_apart in E. apply lt_iff_le_apart. destruct E as [E1 E2]. split. - apply (order_preserving f);trivial. - apply (strong_injective f);trivial. Qed. Global Instance strictly_order_reflecting_mor `{!OrderReflecting (f : A -> B)} `{!StrongExtensionality f} : StrictlyOrderReflecting f | 20. Proof. intros x y E. apply lt_iff_le_apart in E. apply lt_iff_le_apart. destruct E as [E1 E2]. split. - apply (order_reflecting f);trivial. - apply (strong_extensionality f);trivial. Qed. End strictly_order_preserving. (* For structures with a trivial apartness relation we have a stronger result of the above *) Section strictly_order_preserving_dec. Context `{FullPartialOrder A} `{!TrivialApart A} `{FullPartialOrder B} `{!TrivialApart B}. Local Existing Instance strict_po_apart. Global Instance dec_strictly_order_preserving_inj `{!OrderPreserving (f : A -> B)} `{!IsInjective f} : StrictlyOrderPreserving f | 19. Proof. pose proof (dec_strong_injective f). apply _. Qed. Global Instance dec_strictly_order_reflecting_mor `{!OrderReflecting (f : A -> B)} : StrictlyOrderReflecting f | 19. Proof. pose proof (dec_strong_morphism f). apply _. Qed. End strictly_order_preserving_dec. Section pseudo_injective. Context `{PseudoOrder A} `{PseudoOrder B}. Local Existing Instance pseudo_order_apart. Instance pseudo_order_embedding_ext `{!StrictOrderEmbedding (f : A -> B)} : StrongExtensionality f. Proof. intros x y E. apply apart_iff_total_lt;apply apart_iff_total_lt in E. destruct E; [left | right]; apply (strictly_order_reflecting f);trivial. Qed. Lemma pseudo_order_embedding_inj `{!StrictOrderEmbedding (f : A -> B)} : IsStrongInjective f. Proof. split;try apply _. intros x y E. apply apart_iff_total_lt;apply apart_iff_total_lt in E. destruct E; [left | right]; apply (strictly_order_preserving f);trivial. Qed. End pseudo_injective. (* If a function between pseudo partial orders is strictly order preserving (back), we can derive that it is order preserving (back) *) Section full_pseudo_strictly_preserving. Context `{FullPseudoOrder A} `{FullPseudoOrder B}. Local Existing Instance pseudo_order_apart. Lemma full_pseudo_order_preserving `{!StrictlyOrderReflecting (f : A -> B)} : OrderPreserving f. Proof. intros x y E1. apply le_iff_not_lt_flip;apply le_iff_not_lt_flip in E1. intros E2. apply E1. apply (strictly_order_reflecting f). trivial. Qed. Lemma full_pseudo_order_reflecting `{!StrictlyOrderPreserving (f : A -> B)} : OrderReflecting f. Proof. intros x y E1. apply le_iff_not_lt_flip;apply le_iff_not_lt_flip in E1. intros E2. apply E1. apply (strictly_order_preserving f). trivial. Qed. End full_pseudo_strictly_preserving. (* Some helper lemmas to easily transform order preserving instances. *) Section order_preserving_ops. Context `{Le R}. Lemma order_preserving_flip {op} `{!Commutative op} `{!OrderPreserving (op z)} : OrderPreserving (fun y => op y z). Proof. intros x y E. rewrite 2!(commutativity _ z). apply order_preserving;trivial. Qed. Lemma order_reflecting_flip {op} `{!Commutative op} `{!OrderReflecting (op z) } : OrderReflecting (fun y => op y z). Proof. intros x y E. apply (order_reflecting (op z)). rewrite 2!(commutativity (f:=op) z). trivial. Qed. Lemma order_preserving_nonneg (op : R -> R -> R) `{!Zero R} `{forall z, PropHolds (0 ≤ z) -> OrderPreserving (op z)} z : 0 ≤ z -> forall x y, x ≤ y -> op z x ≤ op z y. Proof. auto. Qed. Lemma order_preserving_flip_nonneg (op : R -> R -> R) `{!Zero R} {E:forall z, PropHolds (0 ≤ z) -> OrderPreserving (fun y => op y z)} z : 0 ≤ z -> forall x y, x ≤ y -> op x z ≤ op y z. Proof. apply E. Qed. Context `{Lt R}. Lemma order_reflecting_pos (op : R -> R -> R) `{!Zero R} {E:forall z, PropHolds (0 < z) -> OrderReflecting (op z)} z : 0 < z -> forall x y, op z x ≤ op z y -> x ≤ y. Proof. apply E. Qed. Lemma order_reflecting_flip_pos (op : R -> R -> R) `{!Zero R} {E:forall z, PropHolds (0 < z) -> OrderReflecting (fun y => op y z)} z : 0 < z -> forall x y, op x z ≤ op y z -> x ≤ y. Proof. apply E. Qed. End order_preserving_ops. Section strict_order_preserving_ops. Context `{Lt R}. Lemma strictly_order_preserving_flip {op} `{!Commutative op} `{!StrictlyOrderPreserving (op z)} : StrictlyOrderPreserving (fun y => op y z). Proof. intros x y E. rewrite 2!(commutativity _ z). apply strictly_order_preserving;trivial. Qed. Lemma strictly_order_reflecting_flip {op} `{!Commutative op} `{!StrictlyOrderReflecting (op z) } : StrictlyOrderReflecting (fun y => op y z). Proof. intros x y E. apply (strictly_order_reflecting (op z)). rewrite 2!(commutativity (f:=op) z). trivial. Qed. Lemma strictly_order_preserving_pos (op : R -> R -> R) `{!Zero R} {E:forall z, PropHolds (0 < z) -> StrictlyOrderPreserving (op z)} z : 0 < z -> forall x y, x < y -> op z x < op z y. Proof. apply E. Qed. Lemma strictly_order_preserving_flip_pos (op : R -> R -> R) `{!Zero R} {E:forall z, PropHolds (0 < z) -> StrictlyOrderPreserving (fun y => op y z)} z : 0 < z -> forall x y, x < y -> op x z < op y z. Proof. apply E. Qed. End strict_order_preserving_ops. Lemma projected_partial_order `{IsHSet A} {Ale : Le A} `{is_mere_relation A Ale} `{Ble : Le B} (f : A -> B) `{!IsInjective f} `{!PartialOrder Ble} : (forall x y, x ≤ y <-> f x ≤ f y) -> PartialOrder Ale. Proof. intros P. repeat split. - apply _. - apply _. - intros x. apply P. apply reflexivity. - intros x y z E1 E2. apply P. transitivity (f y); apply P;trivial. - intros x y E1 E2. apply (injective f). apply (antisymmetry (≤)); apply P;trivial. Qed. Lemma projected_total_order `{Ale : Le A} `{Ble : Le B} (f : A -> B) `{!TotalRelation Ble} : (forall x y, x ≤ y <-> f x ≤ f y) -> TotalRelation Ale. Proof. intros P x y. destruct (total (≤) (f x) (f y)); [left | right]; apply P;trivial. Qed. Lemma projected_strict_order `{Alt : Lt A} `{is_mere_relation A lt} `{Blt : Lt B} (f : A -> B) `{!StrictOrder Blt} : (forall x y, x < y <-> f x < f y) -> StrictOrder Alt. Proof. intros P. split. - apply _. - intros x E. destruct (irreflexivity (<) (f x)). apply P. trivial. - intros x y z E1 E2. apply P. transitivity (f y); apply P;trivial. Qed. Lemma projected_pseudo_order `{IsApart A} `{Alt : Lt A} `{is_mere_relation A lt} `{Apart B} `{Blt : Lt B} (f : A -> B) `{!IsStrongInjective f} `{!PseudoOrder Blt} : (forall x y, x < y <-> f x < f y) -> PseudoOrder Alt. Proof. pose proof (strong_injective_mor f). intros P. split; try apply _. - intros x y E. apply (pseudo_order_antisym (f x) (f y)). split; apply P,E. - intros x y E z. apply P in E. apply (merely_destruct (cotransitive E (f z))); intros [?|?];apply tr; [left | right]; apply P;trivial. - intros x y; split; intros E. + apply (strong_injective f) in E. apply apart_iff_total_lt in E. destruct E; [left | right]; apply P;trivial. + apply (strong_extensionality f). apply apart_iff_total_lt. destruct E; [left | right]; apply P;trivial. Qed. Lemma projected_full_pseudo_order `{IsApart A} `{Ale : Le A} `{Alt : Lt A} `{is_mere_relation A le} `{is_mere_relation A lt} `{Apart B} `{Ble : Le B} `{Blt : Lt B} (f : A -> B) `{!IsStrongInjective f} `{!FullPseudoOrder Ble Blt} : (forall x y, x ≤ y <-> f x ≤ f y) -> (forall x y, x < y <-> f x < f y) -> FullPseudoOrder Ale Alt. Proof. intros P1 P2. split. - apply _. - apply (projected_pseudo_order f);assumption. - intros x y; split; intros E. + intros F. destruct (le_not_lt_flip (f y) (f x));[apply P1|apply P2];trivial. + apply P1. apply not_lt_le_flip. intros F. apply E,P2. trivial. Qed. Global Instance id_order_preserving `{PartialOrder A} : OrderPreserving (@id A). Proof. red;trivial. Qed. Global Instance id_order_reflecting `{PartialOrder A} : OrderReflecting (@id A). Proof. red;trivial. Qed. Section composition. Context {A B C} `{Le A} `{Le B} `{Le C} (f : A -> B) (g : B -> C). Instance compose_order_preserving: OrderPreserving f -> OrderPreserving g -> OrderPreserving (g ∘ f). Proof. red;intros. unfold Compose. do 2 apply (order_preserving _). trivial. Qed. Instance compose_order_reflecting: OrderReflecting f -> OrderReflecting g -> OrderReflecting (g ∘ f). Proof. intros ?? x y E. unfold Compose in E. do 2 apply (order_reflecting _) in E. trivial. Qed. Instance compose_order_embedding: OrderEmbedding f -> OrderEmbedding g -> OrderEmbedding (g ∘ f) := {}. End composition. #[export] Hint Extern 4 (OrderPreserving (_ ∘ _)) => class_apply @compose_order_preserving : typeclass_instances. #[export] Hint Extern 4 (OrderReflecting (_ ∘ _)) => class_apply @compose_order_reflecting : typeclass_instances. #[export] Hint Extern 4 (OrderEmbedding (_ ∘ _)) => class_apply @compose_order_embedding : typeclass_instances. Coq-HoTT-9.0/theories/Classes/orders/nat_int.v000066400000000000000000000132461474641544500213040ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.theory.naturals HoTT.Classes.theory.rings. Require Export HoTT.Classes.orders.semirings. Generalizable Variables N R f. Section Univ. Context `{Funext} `{Univalence}. (* We axiomatize the order on the naturals and the integers as a non trivial pseudo semiring order that satisfies the biinduction principle. We prove some results that hold for the order on the naturals and the integers. In particular, we show that given another non trivial pseudo semiring order (that not necessarily has to satisfy the biinduction principle, for example the rationals or the reals), any morphism to it is an order embedding. *) Lemma to_semiring_nonneg `{FullPseudoSemiRingOrder N} `{!NaturalsToSemiRing N} `{!Naturals N} `{FullPseudoSemiRingOrder R} `{!IsSemiCRing R} `{!IsSemiRingPreserving (f : N -> R)} n : 0 ≤ f n. Proof. revert n. apply naturals.induction. - rewrite (preserves_0 (f:=f)). reflexivity. - intros n E. rewrite (preserves_plus (f:=f)), (preserves_1 (f:=f)). apply nonneg_plus_compat. + solve_propholds. + trivial. Qed. Section nat_int_order. Context `{Naturals N} `{Apart N} `{Le N} `{Lt N} `{!FullPseudoSemiRingOrder le lt} `{FullPseudoSemiRingOrder R} `{!IsSemiCRing R} `{!Biinduction R} `{PropHolds (1 ≶ 0)}. (* Add Ring R : (stdlib_semiring_theory R). *) Lemma nat_int_to_semiring : forall x : R, exists z, x = naturals_to_semiring N R z |_| x + naturals_to_semiring N R z = 0. Proof. apply biinduction. - exists 0. left. symmetry. apply preserves_0. - intros. split;intros E. + destruct E as [z [E|E]]. * exists (1+z). left. rewrite E. rewrite (preserves_plus (f:=naturals_to_semiring N R)), (preserves_1 (f:=naturals_to_semiring N R)). reflexivity. * destruct (naturals.case z) as [Ez|[z' Ez]]. ** rewrite Ez in *. rewrite (preserves_0 (A:=N)),plus_0_r in E. rewrite E. exists 1. left. rewrite (preserves_1 (A:=N)),plus_0_r. reflexivity. ** rewrite Ez in *;clear z Ez. exists z';right. path_via (n + naturals_to_semiring N R (1 + z')). clear E. rewrite (preserves_plus (A:=N)),(preserves_1 (A:=N)). rewrite plus_assoc,(plus_comm n);reflexivity. + destruct E as [z [E|E]]. * destruct (naturals.case z) as [Ez|[z' Ez]];rewrite Ez in *;clear z Ez. ** exists 1;right. rewrite (preserves_1 (A:=N)),plus_comm,E. apply preserves_0. ** exists z';left. rewrite (preserves_plus (A:=N)),(preserves_1 (A:=N)) in E. apply (left_cancellation plus 1). trivial. * exists (1+z). right. rewrite (preserves_plus (A:=N)), (preserves_1 (A:=N)),<-E. rewrite plus_assoc,(plus_comm n);reflexivity. Qed. Lemma nat_int_nonneg_decompose x : 0 ≤ x -> exists z, x = naturals_to_semiring N R z. Proof. destruct (nat_int_to_semiring x) as [z [Ez1 | Ez2]]. - exists z. trivial. - intros E. exists 0. rewrite (preserves_0 (A:=N)). apply (antisymmetry (≤)); trivial. rewrite <-Ez2. apply nonneg_plus_le_compat_r. apply to_semiring_nonneg. Qed. Lemma nat_int_le_plus x y : x ≤ y <-> exists z, y = x + naturals_to_semiring N R z. Proof. split. - intros E. destruct (decompose_le E) as [z [Ez1 Ez2]]. destruct (nat_int_nonneg_decompose _ Ez1) as [u Eu]. exists u. rewrite <-Eu. trivial. - intros [z Ez]. rewrite Ez. apply nonneg_plus_le_compat_r, to_semiring_nonneg. Qed. Lemma nat_int_lt_plus x y : x < y <-> exists z, y = x + 1 + naturals_to_semiring N R z. Proof. split. - intros E. destruct ((fst (nat_int_le_plus x y) (lt_le _ _ E))) as [z0 Ez]. destruct (naturals.case z0) as [E1|[z E1]];rewrite E1 in *;clear z0 E1. + rewrite preserves_0, plus_0_r in Ez. destruct (lt_ne_flip x y);trivial. + exists z. rewrite (preserves_plus (A:=N)), preserves_1, plus_assoc in Ez. trivial. - intros [z Ez]. rewrite Ez. apply nonneg_plus_lt_compat_r. + apply to_semiring_nonneg. + apply pos_plus_lt_compat_r; solve_propholds. Qed. Lemma lt_iff_plus_1_le x y : x < y <-> x + 1 ≤ y. Proof. etransitivity. - apply nat_int_lt_plus. - apply symmetry,nat_int_le_plus. Qed. Lemma lt_iff_S_le x y : x < y <-> 1 + x ≤ y. Proof. rewrite plus_comm. apply lt_iff_plus_1_le. Qed. Lemma pos_ge_1 x : 0 < x <-> 1 ≤ x. Proof. split; intros E. - rewrite <-(plus_0_l 1). apply lt_iff_plus_1_le. trivial. - apply lt_le_trans with 1; [solve_propholds | trivial]. Qed. Lemma le_iff_lt_plus_1 x y : x ≤ y <-> x < y + 1. Proof. split; intros E. - apply lt_iff_plus_1_le. apply (order_preserving (+1)). trivial. - apply (order_reflecting (+1)), lt_iff_plus_1_le. trivial. Qed. Lemma le_iff_lt_S x y : x ≤ y <-> x < 1 + y. Proof. rewrite plus_comm. apply le_iff_lt_plus_1. Qed. Section another_semiring. Context `{FullPseudoSemiRingOrder R2} `{!IsSemiCRing R2} `{PropHolds ((1 : R2) ≶ 0)} `{!IsSemiRingPreserving (f : R -> R2)}. Instance: OrderPreserving f. Proof. repeat (split; try apply _). intros x y E. apply nat_int_le_plus in E. destruct E as [z E]. rewrite E, (preserves_plus (f:=f)), (naturals.to_semiring_twice f _ _). apply nonneg_plus_le_compat_r. apply to_semiring_nonneg. Qed. Global Instance: StrictlyOrderPreserving f | 50. Proof. repeat (split; try apply _). intros x y E. apply nat_int_lt_plus in E. destruct E as [z E]. rewrite E, !(preserves_plus (f:=f)), preserves_1, (naturals.to_semiring_twice f _ _). apply nonneg_plus_lt_compat_r. - apply to_semiring_nonneg. - apply pos_plus_lt_compat_r; solve_propholds. Qed. Global Instance nat_morphism_order_embedding : OrderEmbedding f | 50. Proof. split; try apply _. apply full_pseudo_order_reflecting. Qed. End another_semiring. End nat_int_order. End Univ. Coq-HoTT-9.0/theories/Classes/orders/naturals.v000066400000000000000000000046561474641544500215060ustar00rootroot00000000000000Require Import HoTT.Types.Sigma. Require Import HoTT.Classes.theory.naturals. Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.theory.rings HoTT.Classes.orders.rings HoTT.Classes.implementations.peano_naturals. Require Export HoTT.Classes.orders.nat_int. Generalizable Variables N R Rle Rlt f. Section naturals_order. Context `{Funext} `{Univalence}. Context `{Naturals N} `{!TrivialApart N}. Instance nat_nonneg x : PropHolds (0 ≤ x). Proof. apply (to_semiring_nonneg (f:=id)). Qed. Lemma nat_le_plus {x y: N}: x ≤ y <-> exists z, y = x + z. Proof. split; intros E. - destruct (decompose_le E) as [z [Ez1 Ez2]]. exists z. trivial. - destruct E as [z Ez]. apply compose_le with z; [solve_propholds | trivial]. Qed. Lemma nat_not_neg x : ~(x < 0). Proof. apply le_not_lt_flip, nat_nonneg. Qed. Lemma nat_0_or_pos x : x = 0 |_| 0 < x. Proof. destruct (trichotomy (<) 0 x) as [?|[?|?]]; auto. - left;symmetry;trivial. - destruct (nat_not_neg x). trivial. Qed. Lemma nat_0_or_ge_1 x : x = 0 |_| 1 ≤ x. Proof. destruct (nat_0_or_pos x);auto. right;apply pos_ge_1. trivial. Qed. Lemma nat_ne_0_pos x : x <> 0 <-> 0 < x. Proof. split. - destruct (nat_0_or_pos x); auto. intros E;destruct E;trivial. - intros E1 E2. rewrite E2 in E1. destruct (irreflexivity (<) 0). trivial. Qed. Lemma nat_ne_0_ge_1 x : x <> 0 <-> 1 ≤ x. Proof. etransitivity. - apply nat_ne_0_pos. - apply pos_ge_1. Qed. Global Instance: forall (z : N), PropHolds (z <> 0) -> OrderReflecting (z *.). Proof. intros z ?. red. apply (order_reflecting_pos (.*.) z). apply nat_ne_0_pos. trivial. Qed. Global Instance slow_nat_le_dec: forall x y: N, Decidable (x ≤ y) | 10. Proof. intros x y. destruct (nat_le_dec (naturals_to_semiring _ nat x) (naturals_to_semiring _ nat y)) as [E | E]. - left. apply (order_reflecting (naturals_to_semiring N nat)). exact E. - right. intros E'. apply E. apply order_preserving;trivial. apply _. Qed. Section another_ring. Context `{IsCRing R} `{Apart R} `{!FullPseudoSemiRingOrder (A:=R) Rle Rlt} `{!IsSemiRingPreserving (f : N -> R)}. Lemma negate_to_ring_nonpos n : -f n ≤ 0. Proof. apply flip_nonneg_negate. apply to_semiring_nonneg. Qed. Lemma between_to_ring n : -f n ≤ f n. Proof. apply between_nonneg. apply to_semiring_nonneg. Qed. End another_ring. End naturals_order. #[export] Hint Extern 20 (PropHolds (_ ≤ _)) => eapply @nat_nonneg : typeclass_instances. Coq-HoTT-9.0/theories/Classes/orders/orders.v000066400000000000000000000335471474641544500211540ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.theory.apartness. Generalizable Variables A. Lemma irrefl_neq `{R : Relation A} `{!Irreflexive R} : forall x y, R x y -> x <> y. Proof. intros ?? E e;rewrite e in E. apply (irreflexivity _ _ E). Qed. Lemma le_flip `{Le A} `{!TotalRelation (≤)} x y : ~(y ≤ x) -> x ≤ y. Proof. intros nle. destruct (total _ x y) as [?|le];auto. destruct (nle le). Qed. Section partial_order. Context `{PartialOrder A}. Lemma eq_le x y : x = y -> x ≤ y. Proof. intros E. rewrite E. apply reflexivity. Qed. Lemma eq_le_flip x y : x = y -> y ≤ x. Proof. intros E. rewrite E. apply reflexivity. Qed. Lemma not_le_ne x y : ~(x ≤ y) -> x <> y. Proof. intros E1 E2. apply E1. rewrite E2. apply reflexivity. Qed. Lemma eq_iff_le x y : x = y <-> x ≤ y /\ y ≤ x. Proof. split; intros E. - rewrite E. split;apply reflexivity. - apply (antisymmetry (≤) x y);apply E. Qed. End partial_order. Section strict_order. Context `{StrictOrder A}. Lemma lt_flip x y : x < y -> ~(y < x). Proof. intros E1 E2. apply (irreflexivity (<) x). transitivity y;assumption. Qed. Lemma lt_antisym x y : ~(x < y < x). Proof. intros [E1 E2]. destruct (lt_flip x y);assumption. Qed. Lemma lt_ne x y : x < y -> x <> y. Proof. intros E1 E2. rewrite E2 in E1. apply (irreflexivity (<) y). assumption. Qed. Lemma lt_ne_flip x y : x < y -> y <> x. Proof. intro. apply symmetric_neq, lt_ne. assumption. Qed. Lemma eq_not_lt x y : x = y -> ~(x < y). Proof. intros E. rewrite E. apply (irreflexivity (<)). Qed. End strict_order. Section pseudo_order. Context `{PseudoOrder A}. Local Existing Instance pseudo_order_apart. Lemma apart_total_lt x y : x ≶ y -> x < y |_| y < x. Proof. intros. apply apart_iff_total_lt. assumption. Qed. Lemma pseudo_order_lt_apart x y : x < y -> x ≶ y. Proof. intros. apply apart_iff_total_lt. auto. Qed. Lemma pseudo_order_lt_apart_flip x y : x < y -> y ≶ x. Proof. intros. apply apart_iff_total_lt. auto. Qed. Lemma not_lt_apart_lt_flip x y : ~(x < y) -> x ≶ y -> y < x. Proof. intros nlt neq. apply apart_iff_total_lt in neq. destruct neq. - destruct nlt;auto. - auto. Qed. Lemma pseudo_order_cotrans_twice x₁ y₁ x₂ y₂ : x₁ < y₁ -> merely (x₂ < y₂ |_| x₁ < x₂ |_| y₂ < y₁). Proof. intros E1. apply (merely_destruct (cotransitive E1 x₂));intros [?|E2]; try solve [apply tr;auto]. apply (merely_destruct (cotransitive E2 y₂));intros [?|?];apply tr;auto. Qed. Lemma pseudo_order_lt_ext x₁ y₁ x₂ y₂ : x₁ < y₁ -> merely (x₂ < y₂ |_| x₁ ≶ x₂ |_| y₂ ≶ y₁). Proof. intros E. apply (merely_destruct (pseudo_order_cotrans_twice x₁ y₁ x₂ y₂ E)); intros [?|[?|?]];apply tr; auto using pseudo_order_lt_apart. Qed. Global Instance pseudoorder_strictorder : StrictOrder (_ : Lt A). Proof. split. - apply _. - intros x E. destruct (pseudo_order_antisym x x); auto. - intros x y z E1 E2. apply (merely_destruct (cotransitive E1 z));intros [?|?]; trivial. destruct (pseudo_order_antisym y z); auto. Qed. Global Instance nlt_trans : Transitive (complement (<)). Proof. intros x y z. intros E1 E2 E3. apply (merely_destruct (cotransitive E3 y)); intros [?|?]; contradiction. Qed. Global Instance nlt_antisymm : AntiSymmetric (complement (<)). Proof. intros x y H1 H2. apply tight_apart. intros nap. apply apart_iff_total_lt in nap. destruct nap;auto. Qed. Lemma ne_total_lt `{!TrivialApart A} x y : x <> y -> x < y |_| y < x. Proof. intros neq;apply trivial_apart in neq. apply apart_total_lt. assumption. Qed. Global Instance lt_trichotomy `{!TrivialApart A} `{DecidablePaths A} : Trichotomy (<). Proof. intros x y. destruct (dec (x = y)) as [?|?]; try auto. destruct (ne_total_lt x y); auto. Qed. End pseudo_order. Section full_partial_order. Context `{FullPartialOrder A}. Local Existing Instance strict_po_apart. (* Duplicate of strong_setoids.apart_ne. This is useful because a StrongSetoid is not defined as a substructure of a FullPartialOrder *) Instance strict_po_apart_ne x y : PropHolds (x ≶ y) -> PropHolds (x <> y). Proof. intros; apply _. Qed. Global Instance fullpartialorder_strictorder : StrictOrder (<). Proof. split; try apply _. - apply strict_po_mere_lt. - intros x. red. intros E;apply lt_iff_le_apart in E. destruct E as [_ ?]. apply (irreflexivity (≶) x). assumption. Qed. Lemma lt_le x y : PropHolds (x < y) -> PropHolds (x ≤ y). Proof. intro. apply lt_iff_le_apart. assumption. Qed. Lemma not_le_not_lt x y : ~(x ≤ y) -> ~(x < y). Proof. intros E1 E2. apply E1. apply lt_le. assumption. Qed. Lemma lt_apart x y : x < y -> x ≶ y. Proof. intro. apply lt_iff_le_apart. assumption. Qed. Lemma lt_apart_flip x y : x < y -> y ≶ x. Proof. intro. apply symmetry, lt_iff_le_apart. assumption. Qed. Lemma le_not_lt_flip x y : y ≤ x -> ~(x < y). Proof. intros E1 E2;apply lt_iff_le_apart in E2. destruct E2 as [E2a E2b]. revert E2b. apply tight_apart. apply (antisymmetry (≤));assumption. Qed. Lemma lt_not_le_flip x y : y < x -> ~(x ≤ y). Proof. intros E1 E2. apply (le_not_lt_flip y x);assumption. Qed. Lemma lt_le_trans x y z : x < y -> y ≤ z -> x < z. Proof. intros E1 E2. apply lt_iff_le_apart. apply lt_iff_le_apart in E1. destruct E1 as [E1a E1b]. split. - transitivity y;assumption. - apply (merely_destruct (cotransitive E1b z));intros [E3 | E3]; trivial. apply lt_apart. apply symmetry in E3. transitivity y;apply lt_iff_le_apart; auto. Qed. Lemma le_lt_trans x y z : x ≤ y -> y < z -> x < z. Proof. intros E2 E1. apply lt_iff_le_apart. apply lt_iff_le_apart in E1. destruct E1 as [E1a E1b]. split. - transitivity y;auto. - apply (merely_destruct (cotransitive E1b x));intros [E3 | E3]; trivial. apply lt_apart. apply symmetry in E3. transitivity y; apply lt_iff_le_apart; auto. Qed. Lemma lt_iff_le_ne `{!TrivialApart A} x y : x < y <-> x ≤ y /\ x <> y. Proof. transitivity (x <= y /\ apart x y). - apply lt_iff_le_apart. - split;intros [E1 E2];split;trivial;apply trivial_apart;trivial. Qed. Lemma le_equiv_lt `{!TrivialApart A} `{forall x y : A, Decidable (x = y)} x y : x ≤ y -> x = y |_| x < y. Proof. intros. destruct (dec (x = y)); try auto. right. apply lt_iff_le_ne; auto. Qed. Instance dec_from_lt_dec `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)} : DecidablePaths A. Proof. intros x y. destruct (decide_rel (<=) x y) as [E1|E1]; [destruct (decide_rel (<=) y x) as [E2|E2]|]. - left. apply (antisymmetry (<=));assumption. - right. intros E3;apply E2. pattern y. apply (transport _ E3). apply reflexivity. - right. intros E3;apply E1. pattern y; apply (transport _ E3). apply reflexivity. Defined. Definition lt_dec_slow `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)} : forall x y, Decidable (x < y). Proof. intros x y. destruct (dec (x ≤ y)); [destruct (dec (x = y))|]. - right. apply eq_not_lt. assumption. - left. apply lt_iff_le_ne. auto. - right. apply not_le_not_lt. assumption. Defined. End full_partial_order. (* Due to bug #2528 *) #[export] Hint Extern 5 (PropHolds (_ <> _)) => eapply @strict_po_apart_ne : typeclass_instances. #[export] Hint Extern 10 (PropHolds (_ ≤ _)) => eapply @lt_le : typeclass_instances. #[export] Hint Extern 20 (Decidable (_ < _)) => eapply @lt_dec_slow : typeclass_instances. Section full_pseudo_order. Context `{FullPseudoOrder A}. Local Existing Instance pseudo_order_apart. Lemma not_lt_le_flip x y : ~(y < x) -> x ≤ y. Proof. intros. apply le_iff_not_lt_flip. assumption. Qed. Instance fullpseudo_partial : PartialOrder (≤) | 10. Proof. repeat split. - apply _. - apply _. - intros x. apply not_lt_le_flip, (irreflexivity (<)). - intros x y z E1 E2. apply le_iff_not_lt_flip; apply le_iff_not_lt_flip in E1; apply le_iff_not_lt_flip in E2. change (complement (<) z x). transitivity y;assumption. - intros x y E1 E2. apply le_iff_not_lt_flip in E1; apply le_iff_not_lt_flip in E2. apply (antisymmetry (complement (<)));assumption. Qed. Lemma fullpseudo_fullpartial' : FullPartialOrder Ale Alt. Proof. split; try apply _. intros x y. split. - intros E. split. + apply not_lt_le_flip. apply lt_flip;assumption. + apply pseudo_order_lt_apart. assumption. - intros [? E]. apply not_lt_apart_lt_flip;[|symmetry;trivial]. apply le_iff_not_lt_flip. trivial. Qed. Global Instance fullpseudo_fullpartial@{i} : FullPartialOrder Ale Alt := ltac:(first [exact fullpseudo_fullpartial'@{i i Set Set Set}| exact fullpseudo_fullpartial'@{i i}]). Global Instance le_stable : forall x y, Stable (x ≤ y). Proof. intros x y. unfold Stable. intros dn. apply le_iff_not_lt_flip. intros E. apply dn. intros E';apply le_iff_not_lt_flip in E';auto. Qed. Lemma le_or_lt `{!TrivialApart A} `{DecidablePaths A} x y : x ≤ y |_| y < x. Proof. destruct (trichotomy (<) x y) as [|[|]]; try auto. - left. apply lt_le;trivial. - left. apply eq_le;trivial. Qed. Global Instance le_total `{!TrivialApart A} `{DecidablePaths A} : TotalOrder (≤). Proof. split; try apply _. intros x y. destruct (le_or_lt x y); auto. right. apply lt_le. trivial. Qed. Lemma not_le_lt_flip `{!TrivialApart A} `{DecidablePaths A} x y : ~(y ≤ x) -> x < y. Proof. intros. destruct (le_or_lt y x); auto. contradiction. Qed. Existing Instance dec_from_lt_dec. Definition lt_dec `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)} : forall x y, Decidable (x < y). Proof. intros. destruct (decide_rel (<=) y x). - right;apply le_not_lt_flip;assumption. - left; apply not_le_lt_flip;assumption. Defined. End full_pseudo_order. #[export] Hint Extern 8 (Decidable (_ < _)) => eapply @lt_dec : typeclass_instances. (* The following instances would be tempting, but turn out to be a bad idea. #[export] Hint Extern 10 (PropHolds (_ <> _)) => eapply @le_ne : typeclass_instances. #[export] Hint Extern 10 (PropHolds (_ <> _)) => eapply @le_ne_flip : typeclass_instances. It will then loop like: semirings.lt_0_1 -> lt_ne_flip -> ... *) Section dec_strict_setoid_order. Context `{StrictOrder A} `{Apart A} `{!TrivialApart A} `{DecidablePaths A}. Instance: IsApart A := dec_strong_setoid. Context `{!Trichotomy (<)}. Instance dec_strict_pseudo_order: PseudoOrder (<). Proof. split; try apply _. - intros x y [??]. destruct (lt_antisym x y); auto. - intros x y Exy z. destruct (trichotomy (<) x z) as [? | [Exz | Exz]];apply tr; try auto. right. rewrite <-Exz. assumption. - intros x y. transitivity (x <> y);[split;apply trivial_apart|]. split. + destruct (trichotomy (<) x y) as [?|[?|?]]; auto. intros E;contradiction E. + intros [?|?];[apply lt_ne|apply lt_ne_flip];trivial. Qed. End dec_strict_setoid_order. Section dec_partial_order. Context `{PartialOrder A} `{DecidablePaths A}. Definition dec_lt: Lt A := fun x y => x ≤ y /\ x <> y. Context `{Alt : Lt A} `{is_mere_relation A lt} (lt_correct : forall x y, x < y <-> x ≤ y /\ x <> y). Instance dec_order: StrictOrder (<). Proof. split. - apply _. - intros x E. apply lt_correct in E. destruct E as [_ []];trivial. - intros x y z E1 E2. apply lt_correct; apply lt_correct in E1; apply lt_correct in E2. destruct E1 as [E1a E1b],E2 as [E2a E2b]. split. + transitivity y;trivial. + intros E3. destruct E2b. apply (antisymmetry (≤)); trivial. rewrite <-E3. assumption. Qed. Context `{Apart A} `{!TrivialApart A}. Instance: IsApart A := dec_strong_setoid. Instance dec_full_partial_order: FullPartialOrder (≤) (<). Proof. split;try apply _. intros. transitivity (x <= y /\ x <> y);[| split;intros [? ?];split;trivial;apply trivial_apart;trivial]. apply lt_correct. Qed. Context `{!TotalRelation (≤)}. Instance: Trichotomy (<). Proof. intros x y. destruct (dec (x = y)); try auto. destruct (total (≤) x y);[left|right;right]; apply lt_correct;auto. split;auto. intro E;apply symmetry in E;auto. Qed. Instance dec_pseudo_order: PseudoOrder (<) := dec_strict_pseudo_order. Instance dec_full_pseudo_order: FullPseudoOrder (≤) (<). Proof. split; try apply _. intros x y. split. - intros ? E. apply lt_correct in E;destruct E as [? []]. apply (antisymmetry (≤));assumption. - intros E1. destruct (total (≤) x y); trivial. destruct (dec (x = y)) as [E2|E2]. + rewrite E2. apply reflexivity. + destruct E1. apply lt_correct;split;auto. apply symmetric_neq;assumption. Qed. End dec_partial_order. Lemma lt_eq_trans `{Lt A} : forall x y z, x < y -> y = z -> x < z. Proof. intros ???? [];trivial. Qed. Section pseudo. Context {A : Type}. Context `{PseudoOrder A}. Lemma nlt_lt_trans {x y z : A} : ~ (y < x) -> y < z -> x < z. Proof. intros nltyx ltyz. assert (disj := cotransitive ltyz x). strip_truncations. destruct disj as [ltyx|ltxz]. - destruct (nltyx ltyx). - exact ltxz. Qed. Lemma lt_nlt_trans {x y z : A} : x < y -> ~ (z < y) -> x < z. Proof. intros ltxy nltzy. assert (disj := cotransitive ltxy z). strip_truncations. destruct disj as [ltxz|ltzy]. - exact ltxz. - destruct (nltzy ltzy). Qed. Lemma lt_transitive : Transitive (_ : Lt A). Proof. intros x y z ltxy ltyz. assert (ltxyz := cotransitive ltxy z). strip_truncations. destruct ltxyz as [ltxz|ltzy]. - assumption. - destruct (pseudo_order_antisym y z (ltyz , ltzy)). Qed. Global Existing Instance lt_transitive. End pseudo. Coq-HoTT-9.0/theories/Classes/orders/rings.v000066400000000000000000000277741474641544500210050ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.theory.groups HoTT.Classes.theory.rings. Require Export HoTT.Classes.orders.semirings. Generalizable Variables R Rle Rlt R1le R1lt. Section from_ring_order. Context `{IsCRing R} `{!PartialOrder Rle} (plus_spec : forall z, OrderPreserving (z +)) (mult_spec : forall x y, PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) -> PropHolds (0 ≤ x * y)). Lemma from_ring_order: SemiRingOrder (≤). Proof. repeat (split; try apply _). - intros x y E. exists (- x + y). rewrite simple_associativity, plus_negate_r, plus_0_l. reflexivity. - intros x y E. rewrite <-(plus_0_l x), <-(plus_0_l y), <-!(plus_negate_l z), <-!simple_associativity. apply (order_preserving _). trivial. Qed. End from_ring_order. Section from_strict_ring_order. Context `{IsCRing R} `{!StrictOrder Rlt} (plus_spec : forall z, StrictlyOrderPreserving (z +)) (mult_spec : forall x y, PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x * y)). Lemma from_strict_ring_order: StrictSemiRingOrder (<). Proof. repeat (split; try apply _). - intros x y E. exists (- x + y). rewrite simple_associativity, plus_negate_r, plus_0_l. reflexivity. - intros x y E. rewrite <-(plus_0_l x), <-(plus_0_l y), <-!(plus_negate_l z), <-!simple_associativity. apply (strictly_order_preserving _). trivial. Qed. End from_strict_ring_order. Section from_pseudo_ring_order. Context `{IsCRing R} `{Apart R} `{!PseudoOrder Rlt} (plus_spec : forall z, StrictlyOrderPreserving (z +)) (mult_ext : StrongBinaryExtensionality (.*.)) (mult_spec : forall x y, PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x * y)). Lemma from_pseudo_ring_order: PseudoSemiRingOrder (<). Proof. repeat (split; try apply _). - intros x y E. exists (- x + y). rewrite simple_associativity, plus_negate_r, plus_0_l. reflexivity. - intros x y E. rewrite <-(plus_0_l x), <-(plus_0_l y), <-!(plus_negate_l z), <-!simple_associativity. apply (strictly_order_preserving _). trivial. Qed. End from_pseudo_ring_order. Section from_full_pseudo_ring_order. Context `{IsCRing R} `{Apart R} `{!FullPseudoOrder Rle Rlt} (plus_spec : forall z, StrictlyOrderPreserving (z +)) (mult_ext : StrongBinaryExtensionality (.*.)) (mult_spec : forall x y, PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x * y)). Lemma from_full_pseudo_ring_order: FullPseudoSemiRingOrder (≤) (<). Proof. split. - apply _. - apply from_pseudo_ring_order;trivial. - apply le_iff_not_lt_flip;trivial. Qed. End from_full_pseudo_ring_order. Section ring_order. Context `{IsCRing R} `{!SemiRingOrder Rle}. (* Add Ring R : (stdlib_ring_theory R). *) Lemma flip_le_negate x y : -y ≤ -x <-> x ≤ y. Proof. assert (forall a b, a ≤ b -> -b ≤ -a). - intros a b E. transitivity (-a + -b + a);[apply eq_le| transitivity (-a + -b + b);[|apply eq_le]]. + rewrite plus_comm, plus_assoc, plus_negate_r, plus_0_l. reflexivity. + apply (order_preserving _). trivial. + rewrite <-plus_assoc, plus_negate_l. apply plus_0_r. - split; intros; auto. rewrite <-(negate_involutive x), <-(negate_involutive y); auto. Qed. Lemma flip_nonneg_negate x : 0 ≤ x <-> -x ≤ 0. Proof. split; intros E. - rewrite <-negate_0. apply flip_le_negate. rewrite !involutive. trivial. - apply flip_le_negate. rewrite negate_0. trivial. Qed. Lemma flip_nonpos_negate x : x ≤ 0 <-> 0 ≤ -x. Proof. pattern x at 1;apply (transport _ (negate_involutive x)). split; intros; apply flip_nonneg_negate;trivial. Qed. Lemma flip_le_minus_r (x y z : R) : z ≤ y - x <-> z + x ≤ y. Proof. split; intros E. - rewrite plus_comm. rewrite (plus_conjugate_alt y x). apply (order_preserving _). trivial. - rewrite plus_comm. rewrite (plus_conjugate_alt z (- x)), involutive. apply (order_preserving _). trivial. Qed. Lemma flip_le_minus_l (x y z : R) : y - x ≤ z <-> y ≤ z + x. Proof. pattern x at 2;apply (transport _ (negate_involutive x)). split; apply flip_le_minus_r. Qed. Lemma flip_nonneg_minus (x y : R) : 0 ≤ y - x <-> x ≤ y. Proof. pattern x at 2;apply (transport _ (plus_0_l x)). apply flip_le_minus_r. Qed. Lemma flip_nonpos_minus (x y : R) : y - x ≤ 0 <-> y ≤ x. Proof. pattern x at 2;apply (transport _ (plus_0_l x)). apply flip_le_minus_l. Qed. Lemma nonneg_minus_compat (x y z : R) : 0 ≤ z -> x ≤ y -> x - z ≤ y. Proof. intros E1 E2. rewrite plus_comm, (plus_conjugate_alt y (- z)), involutive. apply (order_preserving (-(z) +)). transitivity y; trivial. pattern y at 1;apply (transport _ (plus_0_r y)). apply (order_preserving (y +)). trivial. Qed. Lemma nonneg_minus_compat_back (x y z : R) : 0 ≤ z -> x ≤ y - z -> x ≤ y. Proof. intros E1 E2. transitivity (y - z); trivial. apply nonneg_minus_compat;trivial. apply reflexivity. Qed. Lemma between_nonneg (x : R) : 0 ≤ x -> -x ≤ x. Proof. intros. transitivity 0; trivial. apply flip_nonneg_negate. trivial. Qed. End ring_order. Section strict_ring_order. Context `{IsCRing R} `{!StrictSemiRingOrder Rlt}. (* Add Ring Rs : (stdlib_ring_theory R). *) Lemma flip_lt_negate x y : -y < -x <-> x < y. Proof. assert (forall a b, a < b -> -b < -a). - intros a b E. rewrite (plus_conjugate (-b) (-a)), involutive. apply lt_eq_trans with (-a + -b + b). + apply (strictly_order_preserving _). trivial. + rewrite <-plus_assoc,plus_negate_l, plus_0_r. reflexivity. - split; intros; auto. rewrite <-(negate_involutive x), <-(negate_involutive y); auto. Qed. Lemma flip_lt_negate_r x y : y < - x -> x < - y. Proof. pattern y at 1. rewrite <- (@involutive _ (-) _ y). apply flip_lt_negate. Qed. Lemma flip_lt_negate_l x y : - x < y -> - y < x. Proof. pattern y at 1. rewrite <- (@involutive _ (-) _ y). apply flip_lt_negate. Qed. Lemma flip_pos_negate x : 0 < x <-> -x < 0. Proof. split; intros E. - rewrite <- negate_0. apply flip_lt_negate. rewrite !involutive;trivial. - apply flip_lt_negate. rewrite negate_0. trivial. Qed. Lemma flip_neg_negate x : x < 0 <-> 0 < -x. Proof. pattern x at 1;apply (transport _ (negate_involutive x)). split; intros; apply flip_pos_negate;trivial. Qed. Lemma flip_lt_minus_r (x y z : R) : z < y - x <-> z + x < y. Proof. split; intros E. - rewrite plus_comm, (plus_conjugate_alt y x). apply (strictly_order_preserving _). trivial. - rewrite plus_comm, (plus_conjugate_alt z (-x)), involutive. apply (strictly_order_preserving _). trivial. Qed. Lemma flip_lt_minus_l (x y z : R) : y - x < z <-> y < z + x. Proof. pattern x at 2;apply (transport _ (negate_involutive x)). split; apply flip_lt_minus_r. Qed. Lemma flip_pos_minus (x y : R) : 0 < y - x <-> x < y. Proof. pattern x at 2;apply (transport _ (plus_0_l x)). apply flip_lt_minus_r. Qed. Lemma flip_neg_minus (x y : R) : y - x < 0 <-> y < x. Proof. pattern x at 2;apply (transport _ (plus_0_l x)). apply flip_lt_minus_l. Qed. Lemma pos_minus_compat (x y z : R) : 0 < z -> x < y -> x - z < y. Proof. intros E1 E2. rewrite plus_comm, (plus_conjugate_alt y (-z)), involutive. apply (strictly_order_preserving (-(z) +)). transitivity y; trivial. pattern y at 1;apply (transport _ (plus_0_r y)). apply (strictly_order_preserving (y +)). trivial. Qed. Lemma pos_minus_lt_compat_r x z : 0 < z <-> x - z < x. Proof. pattern x at 2;apply (transport _ (plus_0_r x)). split; intros. - apply (strictly_order_preserving _), flip_pos_negate; assumption. - apply flip_pos_negate, (strictly_order_reflecting (x+)); assumption. Qed. Lemma pos_minus_lt_compat_l x z : 0 < z <-> - z + x < x. Proof. split; intros ltz. - rewrite (commutativity (-z) x); apply pos_minus_lt_compat_r; assumption. - rewrite (commutativity (-z) x) in ltz. apply (snd (pos_minus_lt_compat_r x z)); assumption. Qed. Lemma between_pos (x : R) : 0 < x -> -x < x. Proof. intros E. transitivity 0; trivial. apply flip_pos_negate. trivial. Qed. End strict_ring_order. Section strict_ring_apart. Context `{FullPseudoSemiRingOrder R}. Definition positive_apart_zero (z : R) (Pz : 0 < z) : z ≶ 0 := pseudo_order_lt_apart_flip 0 z Pz. Definition negative_apart_zero (z : R) (Nz : z < 0) : z ≶ 0 := pseudo_order_lt_apart z 0 Nz. End strict_ring_apart. Section another_ring_order. Context `{IsCRing R1} `{!SemiRingOrder R1le} `{IsCRing R2} `{R2le : Le R2} `{is_mere_relation R2 R2le}. Lemma projected_ring_order (f : R2 -> R1) `{!IsSemiRingPreserving f} `{!IsInjective f} : (forall x y, x ≤ y <-> f x ≤ f y) -> SemiRingOrder R2le. Proof. intros P. apply (projected_srorder f P). intros x y E. exists (-x + y). rewrite plus_assoc, plus_negate_r, plus_0_l. reflexivity. Qed. Context `{!SemiRingOrder R2le} {f : R1 -> R2} `{!IsSemiRingPreserving f}. Lemma reflecting_preserves_nonneg : (forall x, 0 ≤ f x -> 0 ≤ x) -> OrderReflecting f. Proof. intros E. repeat (split; try apply _). intros x y F. apply flip_nonneg_minus, E. rewrite preserves_plus, preserves_negate. apply (flip_nonneg_minus (f x)), F. Qed. Lemma preserves_ge_negate1 `{!OrderPreserving f} x : - 1 ≤ x -> - 1 ≤ f x. Proof. intros. rewrite <-(preserves_1 (f:=f)), <-preserves_negate. apply (order_preserving f). trivial. Qed. Lemma preserves_le_negate1 `{!OrderPreserving f} x : x ≤ - 1 -> f x ≤ - 1. Proof. intros. rewrite <-(preserves_1 (f:=f)), <-preserves_negate. apply (order_preserving f). trivial. Qed. End another_ring_order. Section another_strict_ring_order. Context `{IsCRing R1} `{!StrictSemiRingOrder R1lt} `{IsCRing R2} `{R2lt : Lt R2} `{is_mere_relation R2 lt}. Lemma projected_strict_ring_order (f : R2 -> R1) `{!IsSemiRingPreserving f} : (forall x y, x < y <-> f x < f y) -> StrictSemiRingOrder R2lt. Proof. intros P. pose proof (projected_strict_order f P). apply from_strict_ring_order. - intros z x y E. apply P. rewrite 2!(preserves_plus (f:=f)). apply (strictly_order_preserving _), P. trivial. - intros x y E1 E2. apply P. rewrite preserves_mult, preserves_0. apply pos_mult_compat; rewrite <-(preserves_0 (f:=f)); apply P; trivial. Qed. End another_strict_ring_order. Section another_pseudo_ring_order. Context `{IsCRing R1} `{Apart R1} `{!PseudoSemiRingOrder R1lt} `{IsCRing R2} `{IsApart R2} `{R2lt : Lt R2} `{is_mere_relation R2 lt}. Lemma projected_pseudo_ring_order (f : R2 -> R1) `{!IsSemiRingPreserving f} `{!IsStrongInjective f} : (forall x y, x < y <-> f x < f y) -> PseudoSemiRingOrder R2lt. Proof. intros P. pose proof (projected_pseudo_order f P). pose proof (projected_strict_ring_order f P). apply from_pseudo_ring_order; try apply _. pose proof (@pseudo_order_apart R1 H0 R1lt pseudo_srorder_strict : IsApart R1). pose proof (pseudo_order_apart : IsApart R2). pose proof (strong_injective_mor f). repeat (split; try apply _). intros x₁ y₁ x₂ y₂ E. apply (strong_injective f) in E. rewrite 2!(preserves_mult (f:=f)) in E. apply (merely_destruct (strong_binary_extensionality (.*.) _ _ _ _ E)); intros [?|?];apply tr; [left | right]; apply (strong_extensionality f); trivial. Qed. End another_pseudo_ring_order. Section another_full_pseudo_ring_order. Context `{IsCRing R1} `{Apart R1} `{!FullPseudoSemiRingOrder R1le R1lt} `{IsCRing R2} `{IsApart R2} `{R2le : Le R2} `{R2lt : Lt R2} `{is_mere_relation R2 le} `{is_mere_relation R2 lt}. Lemma projected_full_pseudo_ring_order (f : R2 -> R1) `{!IsSemiRingPreserving f} `{!IsStrongInjective f} : (forall x y, x ≤ y <-> f x ≤ f y) -> (forall x y, x < y <-> f x < f y) -> FullPseudoSemiRingOrder R2le R2lt. Proof. intros P1 P2. pose proof (projected_full_pseudo_order f P1 P2). pose proof (projected_pseudo_ring_order f P2). split; try apply _. apply le_iff_not_lt_flip. Qed. End another_full_pseudo_ring_order. Coq-HoTT-9.0/theories/Classes/orders/semirings.v000066400000000000000000000657451474641544500216630ustar00rootroot00000000000000Require Import HoTT.Classes.theory.apartness HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.theory.rings. Require Export HoTT.Classes.orders.orders HoTT.Classes.orders.maps. Generalizable Variables R Rlt f. Section semiring_order. Context `{SemiRingOrder R} `{!IsSemiCRing R}. (* Add Ring R : (stdlib_semiring_theory R). *) Global Instance plus_le_embed_l : forall (z : R), OrderEmbedding (+z). Proof. intro. split. - apply order_preserving_flip. - apply order_reflecting_flip. Qed. Global Instance plus_ordered_cancel_l : forall z, LeftCancellation (+) z. Proof. intros z x y E. apply (antisymmetry (≤)); apply (order_reflecting (z+)); apply eq_le;trivial. apply symmetry;trivial. Qed. Global Instance plus_ordered_cancel_r : forall z, RightCancellation (+) z. Proof. intros. apply (right_cancel_from_left (+)). Qed. Lemma nonneg_plus_le_compat_r x z : 0 ≤ z <-> x ≤ x + z. Proof. pattern x at 1. apply (transport _ (plus_0_r x)). split; intros. - apply (order_preserving _). trivial. - apply (order_reflecting (x+)). trivial. Qed. Lemma nonneg_plus_le_compat_l x z : 0 ≤ z <-> x ≤ z + x. Proof. rewrite (commutativity (f:=plus)). apply nonneg_plus_le_compat_r. Qed. Lemma plus_le_compat x₁ y₁ x₂ y₂ : x₁ ≤ y₁ -> x₂ ≤ y₂ -> x₁ + x₂ ≤ y₁ + y₂. Proof. intros E1 E2. transitivity (y₁ + x₂). - apply (order_preserving (+ x₂));trivial. - apply (order_preserving (y₁ +));trivial. Qed. Lemma plus_le_compat_r x y z : 0 ≤ z -> x ≤ y -> x ≤ y + z. Proof. intros. rewrite <-(plus_0_r x). apply plus_le_compat;trivial. Qed. Lemma plus_le_compat_l x y z : 0 ≤ z -> x ≤ y -> x ≤ z + y. Proof. rewrite (commutativity (f:=plus)). apply plus_le_compat_r. Qed. Lemma nonpos_plus_compat x y : x ≤ 0 -> y ≤ 0 -> x + y ≤ 0. Proof. intros. rewrite <-(plus_0_r 0). apply plus_le_compat;trivial. Qed. Instance nonneg_plus_compat (x y : R) : PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) -> PropHolds (0 ≤ x + y). Proof. intros. apply plus_le_compat_l;trivial. Qed. Lemma decompose_le {x y} : x ≤ y -> exists z, 0 ≤ z /\ y = x + z. Proof. intros E. destruct (srorder_partial_minus x y E) as [z Ez]. exists z. split; [| trivial]. apply (order_reflecting (x+)). rewrite plus_0_r, <-Ez. trivial. Qed. Lemma compose_le x y z : 0 ≤ z -> y = x + z -> x ≤ y. Proof. intros E1 E2. rewrite E2. apply nonneg_plus_le_compat_r. trivial. Qed. Global Instance nonneg_mult_le_l : forall (z : R), PropHolds (0 ≤ z) -> OrderPreserving (z *.). Proof. intros z E. repeat (split; try apply _). intros x y F. destruct (decompose_le F) as [a [Ea1 Ea2]]. rewrite Ea2, plus_mult_distr_l. apply nonneg_plus_le_compat_r. apply nonneg_mult_compat;trivial. Qed. Global Instance nonneg_mult_le_r : forall (z : R), PropHolds (0 ≤ z) -> OrderPreserving (.* z). Proof. intros. apply order_preserving_flip. Qed. Lemma mult_le_compat x₁ y₁ x₂ y₂ : 0 ≤ x₁ -> 0 ≤ x₂ -> x₁ ≤ y₁ -> x₂ ≤ y₂ -> x₁ * x₂ ≤ y₁ * y₂. Proof. intros Ex₁ Ey₁ E1 E2. transitivity (y₁ * x₂). - apply (order_preserving_flip_nonneg (.*.) x₂);trivial. - apply (order_preserving_nonneg (.*.) y₁); [| trivial]. transitivity x₁;trivial. Qed. Lemma ge_1_mult_le_compat_r x y z : 1 ≤ z -> 0 ≤ y -> x ≤ y -> x ≤ y * z. Proof. intros. transitivity y; [trivial |]. pattern y at 1;apply (transport _ (mult_1_r y)). apply (order_preserving_nonneg (.*.) y);trivial. Qed. Lemma ge_1_mult_le_compat_l x y z : 1 ≤ z -> 0 ≤ y -> x ≤ y -> x ≤ z * y. Proof. rewrite (commutativity (f:=mult)). apply ge_1_mult_le_compat_r. Qed. Lemma flip_nonpos_mult_l x y z : z ≤ 0 -> x ≤ y -> z * y ≤ z * x. Proof. intros Ez Exy. destruct (decompose_le Ez) as [a [Ea1 Ea2]], (decompose_le Exy) as [b [Eb1 Eb2]]. rewrite Eb2. apply compose_le with (a * b). - apply nonneg_mult_compat;trivial. - transitivity (z * x + (z + a) * b). + rewrite <-Ea2. rewrite mult_0_l,plus_0_r. reflexivity. + rewrite plus_mult_distr_r,plus_mult_distr_l. apply associativity. Qed. Lemma flip_nonpos_mult_r x y z : z ≤ 0 -> x ≤ y -> y * z ≤ x * z. Proof. rewrite 2!(commutativity _ z). apply flip_nonpos_mult_l. Qed. Lemma nonpos_mult x y : x ≤ 0 -> y ≤ 0 -> 0 ≤ x * y. Proof. intros. rewrite <-(mult_0_r x). apply flip_nonpos_mult_l;trivial. Qed. Lemma nonpos_nonneg_mult x y : x ≤ 0 -> 0 ≤ y -> x * y ≤ 0. Proof. intros. rewrite <-(mult_0_r x). apply flip_nonpos_mult_l;trivial. Qed. Lemma nonneg_nonpos_mult x y : 0 ≤ x -> y ≤ 0 -> x * y ≤ 0. Proof. intros. rewrite (commutativity (f:=mult)). apply nonpos_nonneg_mult;trivial. Qed. End semiring_order. (* Due to bug #2528 *) #[export] Hint Extern 7 (PropHolds (0 ≤ _ + _)) => eapply @nonneg_plus_compat : typeclass_instances. Section strict_semiring_order. Context `{IsSemiCRing R} `{!StrictSemiRingOrder Rlt}. (* Add Ring Rs : (stdlib_semiring_theory R). *) Global Instance plus_lt_embed : forall (z : R), StrictOrderEmbedding (+z). Proof. intro. split. - apply strictly_order_preserving_flip. - apply strictly_order_reflecting_flip. Qed. Lemma pos_plus_lt_compat_r x z : 0 < z <-> x < x + z. Proof. pattern x at 1;apply (transport _ (plus_0_r x)). split; intros. - apply (strictly_order_preserving _);trivial. - apply (strictly_order_reflecting (x+));trivial. Qed. Lemma pos_plus_lt_compat_l x z : 0 < z -> x < z + x. Proof. rewrite (commutativity (f:=plus)). apply pos_plus_lt_compat_r. Qed. Lemma plus_lt_compat x₁ y₁ x₂ y₂ : x₁ < y₁ -> x₂ < y₂ -> x₁ + x₂ < y₁ + y₂. Proof. intros E1 E2. transitivity (y₁ + x₂). - apply (strictly_order_preserving (+ x₂));trivial. - apply (strictly_order_preserving (y₁ +));trivial. Qed. Lemma plus_lt_compat_r x y z : 0 < z -> x < y -> x < y + z. Proof. intros. rewrite <-(plus_0_r x). apply plus_lt_compat;trivial. Qed. Lemma plus_lt_compat_l x y z : 0 < z -> x < y -> x < z + y. Proof. rewrite (commutativity (f:=plus)). apply plus_lt_compat_r. Qed. Lemma neg_plus_compat x y : x < 0 -> y < 0 -> x + y < 0. Proof. intros. rewrite <-(plus_0_r 0). apply plus_lt_compat;trivial. Qed. Instance pos_plus_compat (x y : R) : PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x + y). Proof. intros. apply plus_lt_compat_l;trivial. Qed. Lemma compose_lt x y z : 0 < z -> y = x + z -> x < y. Proof. intros E1 E2. rewrite E2. apply pos_plus_lt_compat_r;trivial. Qed. Lemma decompose_lt {x y} : x < y -> exists z, 0 < z /\ y = x + z. Proof. intros E. destruct (strict_srorder_partial_minus x y E) as [z Ez]. exists z. split; [| trivial]. apply (strictly_order_reflecting (x+)). rewrite <-Ez, rings.plus_0_r. trivial. Qed. Global Instance pos_mult_lt_l : forall (z : R), PropHolds (0 < z) -> StrictlyOrderPreserving (z *.). Proof. intros z E x y F. destruct (decompose_lt F) as [a [Ea1 Ea2]]. rewrite Ea2, plus_mult_distr_l. apply pos_plus_lt_compat_r. apply pos_mult_compat;trivial. Qed. Global Instance pos_mult_lt_r : forall (z : R), PropHolds (0 < z) -> StrictlyOrderPreserving (.* z). Proof. intros. apply strictly_order_preserving_flip. Qed. Lemma mult_lt_compat x₁ y₁ x₂ y₂ : 0 < x₁ -> 0 < x₂ -> x₁ < y₁ -> x₂ < y₂ -> x₁ * x₂ < y₁ * y₂. Proof. intros Ex₁ Ey₁ E1 E2. transitivity (y₁ * x₂). - apply (strictly_order_preserving_flip_pos (.*.) x₂);trivial. - apply (strictly_order_preserving_pos (.*.) y₁); [| trivial ]. transitivity x₁;trivial. Qed. Lemma gt_1_mult_lt_compat_r x y z : 1 < z -> 0 < y -> x < y -> x < y * z. Proof. intros. transitivity y; [ trivial |]. pattern y at 1;apply (transport _ (mult_1_r y)). apply (strictly_order_preserving_pos (.*.) y);trivial. Qed. Lemma gt_1_mult_lt_compat_l x y z : 1 < z -> 0 < y -> x < y -> x < z * y. Proof. rewrite (commutativity (f:=mult)). apply gt_1_mult_lt_compat_r. Qed. Lemma flip_neg_mult_l x y z : z < 0 -> x < y -> z * y < z * x. Proof. intros Ez Exy. destruct (decompose_lt Ez) as [a [Ea1 Ea2]], (decompose_lt Exy) as [b [Eb1 Eb2]]. rewrite Eb2. apply compose_lt with (a * b). - apply pos_mult_compat;trivial. - transitivity (z * x + (z + a) * b). + rewrite <-Ea2. rewrite mult_0_l,plus_0_r;reflexivity. + rewrite plus_mult_distr_r,plus_mult_distr_l. apply associativity. Qed. Lemma flip_neg_mult_r x y z : z < 0 -> x < y -> y * z < x * z. Proof. rewrite 2!(commutativity _ z). apply flip_neg_mult_l. Qed. Lemma neg_mult x y : x < 0 -> y < 0 -> 0 < x * y. Proof. intros. rewrite <-(mult_0_r x). apply flip_neg_mult_l;trivial. Qed. Lemma pos_mult x y : 0 < x -> 0 < y -> 0 < x * y. Proof. intros xpos ypos. rewrite <-(mult_0_r x). apply (pos_mult_lt_l); assumption. Qed. Lemma neg_pos_mult x y : x < 0 -> 0 < y -> x * y < 0. Proof. intros. rewrite <-(mult_0_r x). apply flip_neg_mult_l;trivial. Qed. Lemma pos_neg_mult x y : 0 < x -> y < 0 -> x * y < 0. Proof. intros. rewrite (commutativity (f:=mult)). apply neg_pos_mult;trivial. Qed. End strict_semiring_order. (* Due to bug #2528 *) #[export] Hint Extern 7 (PropHolds (0 < _ + _)) => eapply @pos_plus_compat : typeclass_instances. Section pseudo_semiring_order. Context `{PseudoSemiRingOrder R} `{!IsSemiCRing R}. (* Add Ring Rp : (stdlib_semiring_theory R). *) Local Existing Instance pseudo_order_apart. Global Instance pseudosrorder_strictsrorder : StrictSemiRingOrder (_ : Lt R). Proof. split; try apply _. - intros. apply pseudo_srorder_partial_minus, lt_flip. trivial. - apply pseudo_srorder_pos_mult_compat. Qed. Global Instance plus_strong_ext : StrongBinaryExtensionality (+). Proof. assert (forall z, StrongExtensionality (z +)). - intros. apply pseudo_order_embedding_ext. - apply apartness.strong_binary_setoid_morphism_commutative. Qed. Global Instance plus_strong_cancel_l : forall z, StrongLeftCancellation (+) z. Proof. intros z x y E. apply apart_iff_total_lt in E;apply apart_iff_total_lt. destruct E; [left | right]; apply (strictly_order_preserving (z +));trivial. Qed. Global Instance plus_strong_cancel_r : forall z, StrongRightCancellation (+) z. Proof. intros. apply (strong_right_cancel_from_left (+)). Qed. Lemma neg_mult_decompose x y : x * y < 0 -> (x < 0 /\ 0 < y) |_| (0 < x /\ y < 0). Proof. intros. assert (0 ≶ x) as Ex;[|assert (apart 0 y) as Ey]. - apply (strong_extensionality (.* y)). rewrite mult_0_l. apply pseudo_order_lt_apart_flip;trivial. - apply (strong_extensionality (x *.)). rewrite mult_0_r. apply pseudo_order_lt_apart_flip;trivial. - apply apart_iff_total_lt in Ex;apply apart_iff_total_lt in Ey. destruct Ex as [Ex|Ex], Ey as [Ey|Ey]; try auto. + destruct (irreflexivity (<) 0). transitivity (x * y); [| trivial]. apply pos_mult_compat;trivial. + destruct (irreflexivity (<) 0). transitivity (x * y); [| trivial]. apply neg_mult;trivial. Qed. Lemma pos_mult_decompose x y : 0 < x * y -> (0 < x /\ 0 < y) |_| (x < 0 /\ y < 0). Proof. intros. assert (0 ≶ x /\ apart 0 y) as [Ex Ey];[split|]. - apply (strong_extensionality (.* y)). rewrite mult_0_l. apply pseudo_order_lt_apart;trivial. - apply (strong_extensionality (x *.)). rewrite mult_0_r. apply pseudo_order_lt_apart;trivial. - apply apart_iff_total_lt in Ex;apply apart_iff_total_lt in Ey. destruct Ex as [Ex|Ex], Ey as [Ey|Ey]; try auto. + destruct (irreflexivity (<) 0). transitivity (x * y); [trivial |]. apply pos_neg_mult;trivial. + destruct (irreflexivity (<) 0). transitivity (x * y); [trivial |]. apply neg_pos_mult;trivial. Qed. Global Instance pos_mult_reflect_l : forall (z : R), PropHolds (0 < z) -> StrictlyOrderReflecting (z *.). Proof. intros z Ez x y E1. apply not_lt_apart_lt_flip. + intros E2. apply (lt_flip _ _ E1). apply (strictly_order_preserving (z *.));trivial. + apply (strong_extensionality (z *.)). apply pseudo_order_lt_apart_flip;trivial. Qed. Global Instance pos_mult_reflect_r : forall (z : R), PropHolds (0 < z) -> StrictlyOrderReflecting (.* z). Proof. intros. apply strictly_order_reflecting_flip. Qed. Global Instance apartzero_mult_strong_cancel_l : forall z, PropHolds (z ≶ 0) -> StrongLeftCancellation (.*.) z. Proof. intros z Ez x y E. red in Ez. apply apart_iff_total_lt in E;apply apart_iff_total_lt in Ez; apply apart_iff_total_lt. destruct E as [E|E], Ez as [Ez|Ez]. - right. apply flip_neg_mult_l;trivial. - left. apply (strictly_order_preserving_pos (.*.) z);trivial. - left. apply flip_neg_mult_l;trivial. - right. apply (strictly_order_preserving_pos (.*.) z);trivial. Qed. Global Instance apartzero_mult_strong_cancel_r : forall z, PropHolds (z ≶ 0) -> StrongRightCancellation (.*.) z. Proof. intros. apply (strong_right_cancel_from_left (.*.)). Qed. Global Instance apartzero_mult_cancel_l : forall z, PropHolds (z ≶ 0) -> LeftCancellation (.*.) z. Proof. intros. apply _. Qed. Global Instance apartzero_mult_cancel_r : forall z, PropHolds (z ≶ 0) -> RightCancellation (.*.) z. Proof. intros. apply _. Qed. Lemma square_pos x : x ≶ 0 -> 0 < x * x. Proof. intros E. apply apart_iff_total_lt in E. destruct E as [E|E]. - destruct (decompose_lt E) as [z [Ez1 Ez2]]. apply compose_lt with (z * z). + apply pos_mult_compat;trivial. + rewrite plus_0_l. apply (left_cancellation (+) (x * z)). rewrite <-plus_mult_distr_r, <-plus_mult_distr_l. rewrite (commutativity (f:=plus) z x), <-!Ez2. rewrite mult_0_l,mult_0_r. reflexivity. - apply pos_mult_compat;trivial. Qed. Lemma pos_mult_rev_l x y : 0 < x * y -> 0 < y -> 0 < x. Proof. intros. apply (strictly_order_reflecting (.* y)). rewrite rings.mult_0_l;trivial. Qed. Lemma pos_mult_rev_r x y : 0 < x * y -> 0 < x -> 0 < y. Proof. intros. apply pos_mult_rev_l with x. - rewrite (commutativity (f:=mult));trivial. - trivial. Qed. Context `{PropHolds (1 ≶ 0)}. Instance lt_0_1 : PropHolds (0 < 1). Proof. red. rewrite <-(mult_1_l 1). apply square_pos;trivial. Qed. Instance lt_0_2 : PropHolds (0 < 2). Proof. apply _. Qed. Instance lt_0_3 : PropHolds (0 < 3). Proof. apply _. Qed. Instance lt_0_4 : PropHolds (0 < 4). Proof. apply _. Qed. Lemma lt_1_2 : 1 < 2. Proof. apply pos_plus_lt_compat_r, lt_0_1. Qed. Lemma lt_1_3 : 1 < 3. Proof. apply pos_plus_lt_compat_r, lt_0_2. Qed. Lemma lt_1_4 : 1 < 4. Proof. apply pos_plus_lt_compat_r, lt_0_3. Qed. Lemma lt_2_3 : 2 < 3. Proof. apply (strictly_order_preserving (1+)), lt_1_2. Qed. Lemma lt_2_4 : 2 < 4. Proof. apply (strictly_order_preserving (1+)), lt_1_3. Qed. Lemma lt_3_4 : 3 < 4. Proof. apply (strictly_order_preserving (1+)), lt_2_3. Qed. Instance apart_0_2 : PropHolds (2 ≶ 0). Proof. red. apply symmetry. apply pseudo_order_lt_apart, lt_0_2. Qed. End pseudo_semiring_order. #[export] Hint Extern 7 (PropHolds (0 < 1)) => eapply @lt_0_1 : typeclass_instances. #[export] Hint Extern 7 (PropHolds (0 < 2)) => eapply @lt_0_2 : typeclass_instances. #[export] Hint Extern 7 (PropHolds (0 < 3)) => eapply @lt_0_3 : typeclass_instances. #[export] Hint Extern 7 (PropHolds (0 < 4)) => eapply @lt_0_4 : typeclass_instances. #[export] Hint Extern 7 (PropHolds (2 ≶ 0)) => eapply @apart_0_2 : typeclass_instances. Section full_pseudo_semiring_order. Context `{FullPseudoSemiRingOrder R} `{!IsSemiCRing R}. (* Add Ring Rf : (stdlib_semiring_theory R). *) Global Instance fullpseudosrorder_fullpseudoorder : FullPseudoOrder (_ : Le R) (_ : Lt R). Proof. split. - apply _. - apply _. - apply full_pseudo_srorder_le_iff_not_lt_flip. Qed. Global Instance fullpseudosrorder_srorder : SemiRingOrder (_ : Le R). Proof. split; try apply _. - intros x y E. apply le_iff_not_lt_flip in E. apply pseudo_srorder_partial_minus;trivial. - intros z. repeat (split; try apply _). + intros x y E1. apply le_iff_not_lt_flip in E1;apply le_iff_not_lt_flip. intros E2. apply E1. apply (strictly_order_reflecting (z+)). trivial. + intros x y E1. apply le_iff_not_lt_flip in E1;apply le_iff_not_lt_flip. intros E2. apply E1. apply (strictly_order_preserving _);trivial. - intros x y Ex Ey. apply le_iff_not_lt_flip in Ex;apply le_iff_not_lt_flip in Ey; apply le_iff_not_lt_flip. intros E. destruct (neg_mult_decompose x y E) as [[? ?]|[? ?]];auto. Qed. Global Instance : forall (z : R), PropHolds (0 < z) -> OrderReflecting (z *.). Proof. intros z E. apply full_pseudo_order_reflecting. Qed. Global Instance: forall (z : R), PropHolds (0 < z) -> OrderReflecting (.* z). Proof. intros. apply order_reflecting_flip. Qed. Lemma plus_lt_le_compat x₁ y₁ x₂ y₂ : x₁ < y₁ -> x₂ ≤ y₂ -> x₁ + x₂ < y₁ + y₂. Proof. intros E1 E2. apply lt_le_trans with (y₁ + x₂). - apply (strictly_order_preserving (+ x₂));trivial. - apply (order_preserving (y₁ +));trivial. Qed. Lemma plus_le_lt_compat x₁ y₁ x₂ y₂ : x₁ ≤ y₁ -> x₂ < y₂ -> x₁ + x₂ < y₁ + y₂. Proof. intros E1 E2. apply le_lt_trans with (y₁ + x₂). - apply (order_preserving (+ x₂));trivial. - apply (strictly_order_preserving (y₁ +));trivial. Qed. Lemma nonneg_plus_lt_compat_r x y z : 0 ≤ z -> x < y -> x < y + z. Proof. intros. rewrite <-(plus_0_r x). apply plus_lt_le_compat;trivial. Qed. Lemma nonneg_plus_lt_compat_l x y z : 0 ≤ z -> x < y -> x < z + y. Proof. intros. rewrite (commutativity (f:=plus)). apply nonneg_plus_lt_compat_r;trivial. Qed. Lemma pos_plus_le_lt_compat_r x y z : 0 < z -> x ≤ y -> x < y + z. Proof. intros. rewrite <-(plus_0_r x). apply plus_le_lt_compat;trivial. Qed. Lemma pos_plus_le_lt_compat_l x y z : 0 < z -> x ≤ y -> x < z + y. Proof. intros. rewrite (commutativity (f:=plus)). apply pos_plus_le_lt_compat_r;trivial. Qed. Lemma square_nonneg x : 0 ≤ x * x. Proof. apply not_lt_le_flip. intros E. destruct (lt_antisym (x * x) 0). split; [trivial |]. apply square_pos. pose proof pseudo_order_apart. apply (strong_extensionality (x *.)). rewrite mult_0_r. apply lt_apart. trivial. Qed. Lemma nonneg_mult_rev_l x y : 0 ≤ x * y -> 0 < y -> 0 ≤ x. Proof. intros. apply (order_reflecting (.* y)). rewrite rings.mult_0_l. trivial. Qed. Lemma nonneg_mult_rev_r x y : 0 ≤ x * y -> 0 < x -> 0 ≤ y. Proof. intros. apply nonneg_mult_rev_l with x. - rewrite (commutativity (f:=mult)). trivial. - trivial. Qed. Instance le_0_1 : PropHolds (0 ≤ 1). Proof. red. rewrite <-(mult_1_r 1). apply square_nonneg. Qed. Instance le_0_2 : PropHolds (0 ≤ 2). Proof. solve_propholds. Qed. Instance le_0_3 : PropHolds (0 ≤ 3). Proof. solve_propholds. Qed. Instance le_0_4 : PropHolds (0 ≤ 4). Proof. solve_propholds. Qed. Lemma le_1_2 : 1 ≤ 2. Proof. apply nonneg_plus_le_compat_r, le_0_1. Qed. Lemma le_1_3 : 1 ≤ 3. Proof. apply nonneg_plus_le_compat_r, le_0_2. Qed. Lemma le_1_4 : 1 ≤ 4. Proof. apply nonneg_plus_le_compat_r, le_0_3. Qed. Lemma le_2_3 : 2 ≤ 3. Proof. apply (order_preserving (1+)), le_1_2. Qed. Lemma le_2_4 : 2 ≤ 4. Proof. apply (order_preserving (1+)), le_1_3. Qed. Lemma le_3_4 : 3 ≤ 4. Proof. apply (order_preserving (1+)), le_2_3. Qed. Lemma ge_1_mult_compat x y : 1 ≤ x -> 1 ≤ y -> 1 ≤ x * y. Proof. intros. apply ge_1_mult_le_compat_r; trivial. transitivity 1. - apply le_0_1. - trivial. Qed. Lemma gt_1_ge_1_mult_compat x y : 1 < x -> 1 ≤ y -> 1 < x * y. Proof. intros. apply lt_le_trans with x; trivial. apply ge_1_mult_le_compat_r;[trivial| |apply reflexivity]. transitivity 1. - apply le_0_1. - apply lt_le;trivial. Qed. Lemma ge_1_gt_1_mult_compat x y : 1 ≤ x -> 1 < y -> 1 < x * y. Proof. intros. rewrite (commutativity (f:=mult)). apply gt_1_ge_1_mult_compat;trivial. Qed. Lemma pos_mult_le_lt_compat : forall a b c d, 0 <= a /\ a <= b -> 0 < b -> 0 <= c /\ c < d -> a * c < b * d. Proof. intros a b c d [E1 E2] E3 [E4 E5] . apply le_lt_trans with (b * c). - apply mult_le_compat;auto. - apply (strictly_order_preserving (b *.)). trivial. Qed. Context `{PropHolds (1 ≶ 0)}. Lemma not_le_1_0 : ~(1 ≤ 0). Proof. apply lt_not_le_flip, lt_0_1. Qed. Lemma not_le_2_0 : ~(2 ≤ 0). Proof. apply lt_not_le_flip, lt_0_2. Qed. Lemma repeat_nat_nonneg : forall n, 0 <= Core.nat_iter n (plus 1) 0. Proof. induction n;simpl. - reflexivity. - apply nonneg_plus_compat. + apply _. + apply IHn. Qed. Lemma repeat_nat_pos : forall n, 0 < Core.nat_iter (S n) (plus 1) 0. Proof. intros n. simpl. apply pos_plus_le_lt_compat_l. - solve_propholds. - apply repeat_nat_nonneg. Qed. Local Existing Instance pseudo_order_apart. Global Instance ordered_characteristic_0 : FieldCharacteristic R 0. Proof. hnf. intros [|n] _;split. - intros E'. destruct (E' O). reflexivity. - intros E';apply (irreflexivity _) in E';destruct E'. - intros _;apply apart_iff_total_lt;right;apply repeat_nat_pos. - intros _ m;simpl. intros E. apply (ap (fun n => match n with | S _ => Unit | _ => Empty end)) in E; simpl in E. rewrite <-E. trivial. Qed. End full_pseudo_semiring_order. (* Due to bug #2528 *) #[export] Hint Extern 7 (PropHolds (0 ≤ 1)) => eapply @le_0_1 : typeclass_instances. #[export] Hint Extern 7 (PropHolds (0 ≤ 2)) => eapply @le_0_2 : typeclass_instances. #[export] Hint Extern 7 (PropHolds (0 ≤ 3)) => eapply @le_0_3 : typeclass_instances. #[export] Hint Extern 7 (PropHolds (0 ≤ 4)) => eapply @le_0_4 : typeclass_instances. Section dec_semiring_order. (* Maybe these assumptions can be weakened? *) Context `{SemiRingOrder R} `{Apart R} `{!TrivialApart R} `{!NoZeroDivisors R} `{!TotalRelation (≤)} `{DecidablePaths R}. Context `{Rlt : Lt R} `{is_mere_relation R lt} (lt_correct : forall x y, x < y <-> x ≤ y /\ x <> y). Instance dec_srorder_fullpseudo : FullPseudoOrder _ _ := dec_full_pseudo_order lt_correct. Local Existing Instance pseudo_order_apart. Instance dec_pseudo_srorder: PseudoSemiRingOrder (<). Proof. split; try apply _. - intros x y E. apply srorder_partial_minus, not_lt_le_flip;trivial. - intros z. repeat (split; try apply _). intros x y E. apply lt_correct in E;apply lt_correct. destruct E as [E2a E2b]. split. + apply (order_preserving (z+));trivial. + intros E3. apply E2b. apply (left_cancellation (+) z);trivial. - apply (apartness.dec_strong_binary_morphism (.*.)). - intros x y E1 E2. apply lt_correct in E1;apply lt_correct in E2;apply lt_correct. destruct E1 as [E1a E1b], E2 as [E2a E2b]. split. + apply nonneg_mult_compat;trivial. + apply symmetric_neq. apply mult_ne_0; apply symmetric_neq;trivial. Qed. Instance dec_full_pseudo_srorder: FullPseudoSemiRingOrder (≤) (<). Proof. split; try apply _. apply le_iff_not_lt_flip. Qed. End dec_semiring_order. Section another_semiring. Context `{SemiRingOrder R1}. Lemma projected_srorder `{IsSemiCRing R2} `{R2le : Le R2} `{is_mere_relation R2 R2le} (f : R2 -> R1) `{!IsSemiRingPreserving f} `{!IsInjective f} : (forall x y, x ≤ y <-> f x ≤ f y) -> (forall x y : R2, x ≤ y -> exists z, y = x + z) -> SemiRingOrder R2le. Proof. intros P. pose proof (projected_partial_order f P). repeat (split; try apply _). - assumption. - red;intros. apply P. rewrite 2!(preserves_plus (f:=f)). apply (order_preserving _), P. trivial. - red;intros. apply P. apply (order_reflecting (f z +)). rewrite <-2!preserves_plus. apply P. trivial. - intros. apply P. rewrite preserves_mult, preserves_0. apply nonneg_mult_compat; rewrite <-(preserves_0 (f:=f)); apply P;trivial. Qed. Context `{!IsSemiCRing R1} `{SemiRingOrder R2} `{!IsSemiCRing R2} `{!IsSemiRingPreserving (f : R1 -> R2)}. (* If a morphism agrees on the positive cone then it is order preserving *) Lemma preserving_preserves_nonneg : (forall x, 0 ≤ x -> 0 ≤ f x) -> OrderPreserving f. Proof. intros E. repeat (split; try apply _). intros x y F. destruct (decompose_le F) as [z [Ez1 Ez2]]. apply compose_le with (f z). - apply E;trivial. - rewrite Ez2, (preserves_plus (f:=f)). trivial. Qed. Instance preserves_nonneg `{!OrderPreserving f} x : PropHolds (0 ≤ x) -> PropHolds (0 ≤ f x). Proof. intros. rewrite <-(preserves_0 (f:=f)). apply (order_preserving f);trivial. Qed. Lemma preserves_nonpos `{!OrderPreserving f} x : x ≤ 0 -> f x ≤ 0. Proof. intros. rewrite <-(preserves_0 (f:=f)). apply (order_preserving f);trivial. Qed. Lemma preserves_ge_1 `{!OrderPreserving f} x : 1 ≤ x -> 1 ≤ f x. Proof. intros. rewrite <-(preserves_1 (f:=f)). apply (order_preserving f);trivial. Qed. Lemma preserves_le_1 `{!OrderPreserving f} x : x ≤ 1 -> f x ≤ 1. Proof. intros. rewrite <-(preserves_1 (f:=f)). apply (order_preserving f);trivial. Qed. End another_semiring. Section another_semiring_strict. Context `{StrictSemiRingOrder R1} `{StrictSemiRingOrder R2} `{!IsSemiCRing R1} `{!IsSemiCRing R2} `{!IsSemiRingPreserving (f : R1 -> R2)}. Lemma strictly_preserving_preserves_pos : (forall x, 0 < x -> 0 < f x) -> StrictlyOrderPreserving f. Proof. intros E. repeat (split; try apply _). intros x y F. destruct (decompose_lt F) as [z [Ez1 Ez2]]. apply compose_lt with (f z). - apply E. trivial. - rewrite Ez2, (preserves_plus (f:=f)). trivial. Qed. Instance preserves_pos `{!StrictlyOrderPreserving f} x : PropHolds (0 < x) -> PropHolds (0 < f x). Proof. intros. rewrite <-(preserves_0 (f:=f)). apply (strictly_order_preserving f);trivial. Qed. Lemma preserves_neg `{!StrictlyOrderPreserving f} x : x < 0 -> f x < 0. Proof. intros. rewrite <-(preserves_0 (f:=f)). apply (strictly_order_preserving f);trivial. Qed. Lemma preserves_gt_1 `{!StrictlyOrderPreserving f} x : 1 < x -> 1 < f x. Proof. intros. rewrite <-(preserves_1 (f:=f)). apply (strictly_order_preserving f);trivial. Qed. Lemma preserves_lt_1 `{!StrictlyOrderPreserving f} x : x < 1 -> f x < 1. Proof. intros. rewrite <-(preserves_1 (f:=f)). apply (strictly_order_preserving f);trivial. Qed. End another_semiring_strict. (* Due to bug #2528 *) #[export] Hint Extern 15 (PropHolds (_ ≤ _ _)) => eapply @preserves_nonneg : typeclass_instances. #[export] Hint Extern 15 (PropHolds (_ < _ _)) => eapply @preserves_pos : typeclass_instances. (* Oddly enough, the above hints do not work for goals of the following shape? *) #[export] Hint Extern 15 (PropHolds (_ ≤ '_)) => eapply @preserves_nonneg : typeclass_instances. #[export] Hint Extern 15 (PropHolds (_ < '_)) => eapply @preserves_pos : typeclass_instances. Coq-HoTT-9.0/theories/Classes/orders/sum.v000066400000000000000000000020051474641544500204430ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra. Generalizable Variables A B. Global Instance Empty_lt : Lt@{Set Set} Empty. Proof. intros []. Defined. Global Instance Unit_lt : Lt@{Set Set} Unit := fun _ _ => Empty. Global Instance empty_tricho : Trichotomy@{Set Set Set} (_:Lt Empty). Proof. intros []. Qed. Global Instance unit_tricho : Trichotomy@{Set Set Set} (_:Lt Unit). Proof. intros [] [];auto. Defined. Section contents. Context `{Alt : Lt@{Set Set} A} `{Blt : Lt@{Set Set} B}. Global Instance sum_lt : Lt@{Set Set} (A |_| B) | 2 := fun s1 s2 => match s1, s2 with | inl a1, inl a2 => a1 < a2 | inr b1, inr b2 => b1 < b2 | inl _, inr _ => Unit | inr _, inl _ => Empty end. Global Instance sum_tricho `{!Trichotomy@{Set Set Set} Alt} `{!Trichotomy@{Set Set Set} Blt} : Trichotomy@{Set Set Set} sum_lt. Proof. hnf. intros [a1|b1] [a2|b2];simpl. - destruct (trichotomy _ a1 a2) as [?|[?|?]];auto. - auto. - auto. - destruct (trichotomy _ b1 b2) as [?|[?|?]];auto. Defined. End contents. Coq-HoTT-9.0/theories/Classes/tactics/000077500000000000000000000000001474641544500176075ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Classes/tactics/ring_pol.v000066400000000000000000000220011474641544500216020ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.theory.additional_operations HoTT.Classes.tactics.ring_quote HoTT.Classes.theory.rings. Generalizable Variables Vlt. Import Quoting. Local Set Universe Minimization ToSet. Section content. Local Existing Instance almost_ring_semiring. Local Existing Instance almostring_mor_sr_mor. Universe UC. Context {C : Type@{UC} } {V : Type0 }. Inductive Pol : Type@{UC} := | Pconst (c : C) | PX (P : Pol) (v : V) (Q : Pol). (* [C] is the scalar semiring: Z when working on rings, N on semirings, other sometimes. *) Context `{AlmostRing C} `{DecidablePaths C}. (* [V] is the type of variables, ie we are defining polynomials [C[V]]. It has a computable compare so we can normalise polynomials. *) Context `{Trichotomy@{Set Set Set} V Vlt}. (* Polynomials are supposed (at the meta level) to be in normal form: PX P v Q verifies + P <> 0 + forall w in P, w <= v + forall w in Q, w < v *) Fixpoint Peqb P Q : Bool := match P, Q with | Pconst c, Pconst d => c =? d | PX P1 v P2, PX Q1 w Q2 => andb (v =? w) (andb (Peqb P1 Q1) (Peqb P2 Q2)) | _, _ => false end. Global Instance Peqb_instance : Eqb Pol := Peqb. Arguments Peqb_instance _ _ /. Global Instance P0 : canonical_names.Zero Pol := Pconst 0. Global Instance P1 : canonical_names.One Pol := Pconst 1. Universe UR. Context {R : Type@{UR} } `{AlmostRing R} (phi : C -> R) `{!AlmostRingPreserving phi}. Notation Vars V := (V -> R). Fixpoint eval (vs : Vars V) (P : Pol) : R := match P with | Pconst c => phi c | PX P v Q => (eval vs P) * (vs v) + (eval vs Q) end. Lemma andb_true : forall a b : Bool, andb a b = true -> a = true /\ b = true. Proof. intros [|] [|];simpl;auto. Qed. Lemma eval_eqb' : forall P Q : Pol, P =? Q = true -> forall vs : Vars V, eval vs P = eval vs Q. Proof. induction P as [c|P1 IHP1 v P2 IHP2];destruct Q as [d|Q1 w Q2];intros E vs; change eqb with Peqb in E;simpl in E. - simpl. apply ap. apply decide_eqb_ok;trivial. - destruct (false_ne_true E). - destruct (false_ne_true E). - apply andb_true in E. destruct E as [E1 E2]. apply andb_true in E2. destruct E2 as [E2 E3]. simpl. apply compare_eqb_eq,tricho_compare_eq in E1. apply ap011;auto. apply ap011;auto. Qed. Definition eval_eqb@{} := ltac:(first [exact eval_eqb'@{Ularge}| exact eval_eqb']). Lemma eval_0' : forall P, P =? 0 = true -> forall vs, eval vs P = 0. Proof. induction P;simpl;intros E vs. - change eqb with Peqb in E;simpl in E. apply decide_eqb_ok in E. rewrite E. apply preserves_0. - change eqb with Peqb in E;simpl in E. destruct (false_ne_true E). Qed. Definition eval_0@{} := ltac:(first [exact eval_0'@{Ularge}| exact eval_0']). Fixpoint addC c P := match P with | Pconst d => Pconst (c + d) | PX P v Q => PX P v (addC c Q) end. Lemma eval_addC vs : forall c P, eval vs (addC c P) = (phi c) + eval vs P. Proof. induction P;simpl. - apply preserves_plus. - rewrite IHP2. rewrite 2!plus_assoc. rewrite (plus_comm (phi c)). reflexivity. Qed. (* c * v + Q *) Fixpoint addX' c v Q := match Q with | Pconst d => PX (Pconst c) v Q | PX Q1 w Q2 => match v ?= w with | LT => PX Q1 w (addX' c v Q2) | EQ => PX (addC c Q1) v Q2 | GT => PX (Pconst c) v Q end end. Definition addX c v Q := if c =? 0 then Q else addX' c v Q. Lemma eval_addX'@{} vs : forall c (v:V) Q, eval vs (addX' c v Q) = phi c * vs v + eval vs Q. Proof. induction Q as [d|Q1 IH1 w Q2 IH2]. - simpl. reflexivity. - simpl. pose proof (tricho_compare_eq v w) as E. destruct (v ?= w);[clear E|rewrite <-E by split;clear E w|clear E]. + simpl. rewrite IH2. rewrite 2!plus_assoc. apply ap011;trivial. apply plus_comm. + simpl. rewrite eval_addC. rewrite plus_mult_distr_r. symmetry;apply plus_assoc. + simpl. reflexivity. Qed. Lemma eval_addX vs : forall c (v:V) Q, eval vs (addX c v Q) = phi c * vs v + eval vs Q. Proof. intros. unfold addX. pose proof (decide_eqb_ok c 0) as E. destruct (c =? 0). - rewrite (fst E) by split. rewrite (preserves_0 (f:=phi)). rewrite mult_0_l,plus_0_l. split. - apply eval_addX'. Qed. Definition PXguard@{} P v Q := if eqb P 0 then Q else PX P v Q. Lemma eval_PXguard vs : forall P (v:V) Q, eval vs (PXguard P v Q) = eval vs P * vs v + eval vs Q. Proof. intros. unfold PXguard. pose proof (eval_0 P) as E. destruct (P =? 0). - rewrite E by split. rewrite mult_0_l,plus_0_l. split. - reflexivity. Qed. Fixpoint mulC c P := match P with | Pconst d => Pconst (c * d) | PX P v Q => (* in some semirings we can have zero divisors, so P' might be zero *) PXguard (mulC c P) v (mulC c Q) end. Lemma eval_mulC vs : forall c P, eval vs (mulC c P) = (phi c) * eval vs P. Proof. induction P as [d | P1 IH1 v P2 IH2];simpl. - apply preserves_mult. - rewrite eval_PXguard. rewrite IH1,IH2,plus_mult_distr_l,mult_assoc. reflexivity. Qed. (* if P <= v, P <> 0, and addP Q = P + Q then P * v + Q *) Fixpoint add_aux addP P v Q := match Q with | Pconst _ => PX P v Q | PX Q1 w Q2 => match v ?= w with | LT => PX Q1 w (add_aux addP P v Q2) | EQ => PXguard (addP Q1) v Q2 | GT => PX P v Q end end. Fixpoint add P Q := match P with | Pconst c => addC c Q | PX P1 v P2 => add_aux (add P1) P1 v (add P2 Q) end. Lemma eval_add_aux vs P addP (Eadd : forall Q, eval vs (addP Q) = eval vs P + eval vs Q) : forall (v:V) Q, eval vs (add_aux addP P v Q) = eval vs P * vs v + eval vs Q. Proof. induction Q as [d|Q1 IH1 w Q2 IH2]. - simpl. reflexivity. - simpl. pose proof (tricho_compare_eq v w) as E. destruct (v ?= w);[clear E|rewrite <-E by split;clear E w|clear E]. + simpl. rewrite IH2. rewrite 2!plus_assoc. rewrite (plus_comm (eval vs Q1 * vs w)). reflexivity. + rewrite eval_PXguard. rewrite Eadd. rewrite plus_mult_distr_r. symmetry;apply plus_assoc. + simpl. reflexivity. Qed. Lemma eval_add' vs : forall P Q, eval vs (add P Q) = eval vs P + eval vs Q. Proof. induction P as [c|P1 IH1 v P2 IH2];intros Q. - simpl. apply eval_addC. - simpl. rewrite eval_add_aux;auto. rewrite IH2. apply plus_assoc. Qed. Definition eval_add@{} := ltac:(first [exact eval_add'@{Ularge}| exact eval_add'@{}]). Fixpoint mulX v P := match P with | Pconst c => addX c v 0 | PX P1 w P2 => match v ?= w with | LT => PX (mulX v P1) w (mulX v P2) | _ => PX P v 0 end end. Lemma eval_mulX@{} vs : forall (v:V) (P:Pol), eval vs (mulX v P) = eval vs P * vs v. Proof. induction P as [c|P1 IH1 w P2 IH2]. - simpl. rewrite eval_addX. simpl. rewrite (preserves_0 (f:=phi)),plus_0_r. split. - simpl. pose proof (tricho_compare_eq v w) as E. destruct (v ?= w);[clear E|rewrite <-E by split;clear E w|clear E]. + simpl. rewrite plus_mult_distr_r,IH1,IH2. apply ap011;trivial. rewrite <-2!mult_assoc;apply ap,mult_comm. + simpl. rewrite (preserves_0 (f:=phi)),plus_0_r. reflexivity. + simpl. rewrite (preserves_0 (f:=phi)),plus_0_r. reflexivity. Qed. Definition mkPX P v Q := add (mulX v P) Q. Lemma eval_mkPX vs : forall P v Q, eval vs (mkPX P v Q) = (eval vs P) * (vs v) + eval vs Q. Proof. intros. unfold mkPX. rewrite eval_add,eval_mulX. reflexivity. Qed. Fixpoint mul P Q := match P, Q with | Pconst c, _ => mulC c Q | _, Pconst d => mulC d P | PX P1 v P2, PX Q1 w Q2 => (* P1 Q1 v w + P1 Q2 v + P2 Q1 w + P2 Q2 *) add (mulX v (add (mulX w (mul P1 Q1)) (mul P1 Q2))) (add (mulX w (mul P2 Q1)) (mul P2 Q2)) end. Lemma eval_mul' vs : forall P Q, eval vs (mul P Q) = eval vs P * eval vs Q. Proof. induction P as [c | P1 IHP1 v P2 IHP2];[apply eval_mulC|]. destruct Q as [d | Q1 w Q2]. - change (mul (PX P1 v P2) (Pconst d)) with (mulC d (PX P1 v P2)). rewrite eval_mulC. apply mult_comm. - simpl. rewrite plus_mult_distr_r,!plus_mult_distr_l. repeat (rewrite eval_add || rewrite eval_mulX). rewrite plus_mult_distr_r,(plus_mult_distr_l (eval vs P2)). rewrite IHP1,IHP2. apply ap011;apply ap011. + rewrite <-!mult_assoc. apply ap. rewrite (mult_comm (vs v)). apply mult_assoc. + rewrite <-mult_assoc,(mult_comm (vs v)),mult_assoc. rewrite IHP1;reflexivity. + symmetry;apply mult_assoc. + auto. Qed. Definition eval_mul@{} := ltac:(first [exact eval_mul'@{Ularge}|exact eval_mul'@{}]). Fixpoint toPol (e: Expr V) := match e with | Var v => PX 1 v 0 | Zero => 0 | One => 1 | Plus a b => add (toPol a) (toPol b) | Mult a b => mul (toPol a) (toPol b) | Neg a => mulC (almost_negate 1) (toPol a) end. Lemma eval_toPol@{} vs : forall e : Expr V, eval vs (toPol e) = Quoting.eval _ vs e. Proof. induction e as [v| | |a IHa b IHb|a IHa b IHb|a IHa];simpl. - rewrite (preserves_1 (f:=phi)),(preserves_0 (f:=phi)),plus_0_r,mult_1_l. reflexivity. - apply preserves_0. - apply preserves_1. - rewrite eval_add,IHa,IHb. reflexivity. - rewrite eval_mul,IHa,IHb. reflexivity. - rewrite eval_mulC. rewrite (almostring_mor_neg (f:=phi)),preserves_1. rewrite <-almost_ring_neg_pr. apply ap,IHa. Qed. End content. Coq-HoTT-9.0/theories/Classes/tactics/ring_quote.v000066400000000000000000000200201474641544500221440ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra. Class AlmostNegate A := almost_negate : A -> A. Class AlmostRing A {Aplus : Plus A} {Amult : Mult A} {Azero : Zero A} {Aone : One A} {Anegate : AlmostNegate A} := { almost_ring_semiring : IsSemiCRing A ; almost_ring_neg_pr : forall x : A, almost_negate x = (almost_negate 1) * x }. Section almostring_mor. Context {A B : Type} {Aplus : Plus A} {Bplus : Plus B} {Amult : Mult A} {Bmult : Mult B} {Azero : Zero A} {Bzero : Zero B} {Aone : One A} {Bone : One B} {Aneg : AlmostNegate A} {Bneg : AlmostNegate B}. Class AlmostRingPreserving (f : A -> B) := { almostring_mor_sr_mor : IsSemiRingPreserving f ; almostring_mor_neg : forall x, f (almost_negate x) = almost_negate (f x) }. End almostring_mor. Module Quoting. Inductive Expr (V:Type0) : Type0 := | Var (v : V) | Zero | One | Plus (a b : Expr V) | Mult (a b : Expr V) | Neg (a : Expr V) . Arguments Var {V} v. Arguments Zero {V}. Arguments One {V}. Arguments Plus {V} a b. Arguments Mult {V} a b. Arguments Neg {V} a. Section contents. Universe U. Context (R:Type@{U}) `{AlmostRing R}. Notation Vars V := (V -> R). Fixpoint eval {V:Type0} (vs : Vars V) (e : Expr V) : R := match e with | Var v => vs v | Zero => 0 | One => 1 | Plus a b => eval vs a + eval vs b | Mult a b => eval vs a * eval vs b | Neg a => almost_negate (eval vs a) end. Lemma eval_ext {V:Type0} (vs vs' : Vars V) : pointwise_paths@{Set U} vs vs' -> pointwise_paths@{Set U} (eval vs) (eval vs'). Proof. intros E e;induction e;simpl;auto;apply ap011;auto. Qed. Definition noVars : Vars Empty. Proof. intros []. Defined. Definition singleton x : Vars Unit := fun _ => x. Definition merge {A B:Type0 } (va:Vars A) (vb:Vars B) : Vars (sum@{Set Set} A B) := fun i => match i with inl i => va i | inr i => vb i end. Section Lookup. Class Lookup {A:Type0 } (x: R) (f: Vars A) := { lookup: A; lookup_correct: f lookup = x }. Global Arguments lookup {A} x f {_}. Context (x:R) {A B:Type0 } (va : Vars A) (vb : Vars B). Local Instance lookup_l `{!Lookup x va} : Lookup x (merge va vb). Proof. exists (inl (lookup x va)). apply lookup_correct. Defined. Local Instance lookup_r `{!Lookup x vb} : Lookup x (merge va vb). Proof. exists (inr (lookup x vb)). apply lookup_correct. Defined. Local Instance lookup_single : Lookup x (singleton x). Proof. exists tt. reflexivity. Defined. End Lookup. Fixpoint expr_map {V W:Type0 } (f : V -> W) (e : Expr V) : Expr W := match e with | Var v => Var (f v) | Zero => Zero | One => One | Plus a b => Plus (expr_map f a) (expr_map f b) | Mult a b => Mult (expr_map f a) (expr_map f b) | Neg a => Neg (expr_map f a) end. Lemma eval_map {V W:Type0 } (f : V -> W) v e : eval v (expr_map f e) = eval (Compose@{Set Set U} v f) e. Proof. induction e;simpl;try reflexivity;apply ap011;auto. Qed. Section Quote. Class Quote {V:Type0 } (l: Vars V) (n: R) {V':Type0 } (r: Vars V') := { quote : Expr (V |_| V') ; eval_quote : @eval (V |_| V') (merge l r) quote = n }. Global Arguments quote {V l} n {V' r _}. Global Arguments eval_quote {V l} n {V' r _}. Definition sum_assoc {A B C}: (A |_| B) |_| C -> A |_| (B |_| C). Proof. intros [[?|?]|?];auto. Defined. Definition sum_aux {A B C}: (A |_| B) -> A |_| (B |_| C). Proof. intros [?|?];auto. Defined. Local Instance quote_zero (V:Type0) (v: Vars V): Quote v 0 noVars. Proof. exists Zero. reflexivity. Defined. Local Instance quote_one (V:Type0) (v: Vars V): Quote v 1 noVars. Proof. exists One. reflexivity. Defined. Lemma quote_plus_ok (V:Type0) (v: Vars V) n (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'') `{!Quote v n v'} `{!Quote (merge v v') m v''} : eval (merge v (merge v' v'')) (Plus (expr_map sum_aux (quote n)) (expr_map sum_assoc (quote m))) = n + m. Proof. simpl. rewrite <-(eval_quote n), <-(eval_quote m), 2!eval_map. apply ap011;apply eval_ext. - intros [?|?];reflexivity. - intros [[?|?]|?];reflexivity. Qed. Local Instance quote_plus (V:Type0) (v: Vars V) n (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'') `{!Quote v n v'} `{!Quote (merge v v') m v''}: Quote v (n + m) (merge v' v''). Proof. econstructor. apply quote_plus_ok. Defined. Lemma quote_mult_ok (V:Type0) (v: Vars V) n (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'') `{!Quote v n v'} `{!Quote (merge v v') m v''} : eval (merge v (merge v' v'')) (Mult (expr_map sum_aux (quote n)) (expr_map sum_assoc (quote m))) = n * m. Proof. simpl. rewrite <-(eval_quote n), <-(eval_quote m), 2!eval_map. apply ap011;apply eval_ext. - intros [?|?];reflexivity. - intros [[?|?]|?];reflexivity. Qed. Local Instance quote_mult (V:Type0) (v: Vars V) n (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'') `{!Quote v n v'} `{!Quote (merge v v') m v''} : Quote v (n * m) (merge v' v''). Proof. econstructor. apply quote_mult_ok. Defined. Lemma quote_neg_ok@{} (V:Type0) (v : Vars V) n (V':Type0) (v' : Vars V') `{!Quote v n v'} : eval (merge v v') (Neg (quote n)) = almost_negate n. Proof. simpl. apply ap,eval_quote. Qed. Local Instance quote_neg (V:Type0) (v : Vars V) n (V':Type0) (v' : Vars V') `{!Quote v n v'} : Quote v (almost_negate n) v'. Proof. exists (Neg (quote n)). apply quote_neg_ok. Defined. Local Instance quote_old_var (V:Type0) (v: Vars V) x {i: Lookup x v} : Quote v x noVars | 8. Proof. exists (Var (inl (lookup x v))). apply lookup_correct. Defined. Local Instance quote_new_var (V:Type0) (v: Vars V) x : Quote v x (singleton x) | 9. Proof. exists (Var (inr tt)). reflexivity. Defined. End Quote. Definition quote': forall x {V':Type0 } {v: Vars V'} {d: Quote noVars x v}, Expr _ := @quote _ _. Definition eval_quote': forall x {V':Type0} {v: Vars V'} {d: Quote noVars x v}, eval (merge noVars v) (quote x) = x := @eval_quote _ _. Class EqQuote {V:Type0 } (l: Vars V) (n m: R) {V':Type0 } (r: Vars V') := { eqquote_l : Expr V ; eqquote_r : Expr (V |_| V') ; eval_eqquote : eval (merge l r) (expr_map inl eqquote_l) = eval (merge l r) eqquote_r -> n = m }. Lemma eq_quote_ok (V:Type0) (v: Vars V) n (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'') `{!Quote v n v'} `{!Quote (merge v v') m v''} : eval (merge v (merge v' v'')) (expr_map sum_aux (quote n)) = eval (merge v (merge v' v'')) (expr_map sum_assoc (quote m)) -> n = m. Proof. intros E. rewrite <-(eval_quote n), <-(eval_quote m). path_via (eval (merge v (merge v' v'')) (expr_map sum_aux (quote n))); [|path_via (eval (merge v (merge v' v'')) (expr_map sum_assoc (quote m)))]. - rewrite eval_map. apply eval_ext. intros [?|?];reflexivity. - rewrite eval_map. apply eval_ext. intros [[?|?]|?];reflexivity. Qed. Local Instance eq_quote (V:Type0) (v: Vars V) n (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'') `{!Quote v n v'} `{!Quote (merge v v') m v''} : EqQuote (merge v v') n m v''. Proof. econstructor. intros E. apply (@eq_quote_ok _ _ _ _ _ _ _ _ Quote0 Quote1). etransitivity;[etransitivity;[|exact E]|]. - rewrite 2!eval_map. apply eval_ext. intros [?|?];reflexivity. - rewrite (eval_map sum_assoc). apply eval_ext. intros [[?|?]|?];reflexivity. Defined. Definition sum_forget {A B} : Empty |_| A -> A |_| B. Proof. intros [[]|?];auto. Defined. Lemma quote_equality {V:Type0} {v: Vars V} {V':Type0} {v': Vars V'} (l r: R) `{!Quote noVars l v} `{!Quote v r v'} : let heap := (merge v v') in eval heap (expr_map sum_forget (quote l)) = eval heap (quote r) -> l = r. Proof. intros ? E. rewrite <-(eval_quote l),<-(eval_quote r). path_via (eval heap (expr_map sum_forget (quote l))). rewrite eval_map. apply eval_ext. intros [[]|?]. reflexivity. Qed. End contents. Module Export Instances. Global Existing Instances lookup_l lookup_r lookup_single quote_zero quote_one quote_plus quote_mult quote_neg eq_quote. Global Existing Instance quote_old_var | 8. Global Existing Instance quote_new_var | 9. End Instances. End Quoting. Coq-HoTT-9.0/theories/Classes/tactics/ring_tac.v000066400000000000000000000071321474641544500215670ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.tactics.ring_quote HoTT.Classes.tactics.ring_pol HoTT.Classes.theory.rings HoTT.Classes.orders.sum HoTT.Classes.interfaces.naturals HoTT.Classes.interfaces.integers. Generalizable Variables A B C R V f l n m Vlt. Import Quoting.Instances. Section content. Context `{DecidablePaths C}. Context `(phi : C -> R) `{AlmostRingPreserving C R phi} `{!AlmostRing C} `{!AlmostRing R}. Lemma normalize_eq `{Q : @Quoting.EqQuote R _ _ _ _ _ V l n m V' l'} `{Trichotomy V Vlt} `{Trichotomy V' Vlt'} : eval phi (Quoting.merge R l l') (toPol (Quoting.expr_map inl (Quoting.eqquote_l R))) = eval phi (Quoting.merge R l l') (toPol (Quoting.eqquote_r R)) -> n = m. Proof. intros E. eapply Quoting.eval_eqquote. etransitivity;[symmetry;apply (eval_toPol _)|]. etransitivity;[|apply (eval_toPol _)]. exact E. Qed. Lemma by_quoting `{Q : @Quoting.EqQuote R _ _ _ _ _ V l n m V' l'} `{Trichotomy V Vlt} `{Trichotomy V' Vlt'} : toPol (Quoting.expr_map inl (@Quoting.eqquote_l R _ _ _ _ _ _ _ _ _ _ _ Q)) =? toPol (@Quoting.eqquote_r R _ _ _ _ _ _ _ _ _ _ _ Q) = true -> n = m. Proof. intros E. apply normalize_eq. apply eval_eqb,E. Qed. Lemma normalize_prequoted `{Trichotomy V Vlt} (a b : Quoting.Expr V) vs : eval phi vs (toPol a) = eval phi vs (toPol b) -> Quoting.eval _ vs a = Quoting.eval _ vs b. Proof. rewrite !(eval_toPol _). trivial. Qed. Lemma prove_prequoted `{Trichotomy V Vlt} (a b : Quoting.Expr V) vs : toPol a =? toPol b = true -> Quoting.eval _ vs a = Quoting.eval _ vs b. Proof. intros. apply normalize_prequoted. apply eval_eqb;trivial. Qed. End content. Global Instance default_almostneg `{Zero A} : AlmostNegate A | 20 := fun _ => 0. Arguments default_almostneg _ _ _ /. Global Instance negate_almostneg `{Aneg : Negate A} : AlmostNegate A := (-). Arguments negate_almostneg _ _ _ /. Global Instance semiring_almostring `{IsSemiCRing A} : AlmostRing A | 10. Proof. split;try apply _. intros. unfold almost_negate;simpl. symmetry;apply mult_0_l. Qed. Global Instance ring_almostring `{IsCRing A} : AlmostRing A. Proof. split;try apply _. intros. unfold almost_negate;simpl. apply negate_mult_l. Qed. Global Instance sr_mor_almostring_mor `{IsSemiRingPreserving A B f} : AlmostRingPreserving f | 10. Proof. split;try apply _. unfold almost_negate;simpl. intros _. apply preserves_0. Qed. Section VarSec. Context `{IsCRing A} `{IsCRing B} {f : A -> B} `{!IsSemiRingPreserving f}. Global Instance ring_mor_almostring_mor : AlmostRingPreserving f. Proof. split;try apply _. unfold almost_negate;simpl. apply preserves_negate. Qed. End VarSec. Arguments normalize_eq {C _ R} phi {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _. Arguments by_quoting {C _ R} phi {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _. Ltac ring_with_nat := match goal with |- @paths ?R _ _ => ((pose proof (_ : IsSemiCRing R)) || fail "target equality not on a semiring"); apply (by_quoting (naturals_to_semiring nat R)); reflexivity end. Ltac ring_with_integers Z := match goal with |- @paths ?R _ _ => ((pose proof (_ : IsCRing R)) || fail "target equality not on a ring"); apply (by_quoting (integers_to_ring Z R)); reflexivity end. Ltac ring_with_self := match goal with |- @paths ?R _ _ => ((pose proof (_ : IsSemiCRing R)) || fail "target equality not on a ring"); apply (by_quoting (@id R)); reflexivity end. Ltac ring_repl a b := let Hrw := fresh "Hrw" in assert (Hrw : a = b);[ring_with_nat|rewrite Hrw;clear Hrw]. Tactic Notation "ring_replace" constr(x) "with" constr(y) := ring_repl x y. Coq-HoTT-9.0/theories/Classes/theory/000077500000000000000000000000001474641544500174675ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Classes/theory/additional_operations.v000066400000000000000000000047151474641544500242400ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.canonical_names. Generalizable Variables A R. Local Set Universe Minimization ToSet. Global Instance decide_eqb `{DecidablePaths A} : Eqb A := fun a b => if decide_rel paths a b then true else false. Lemma decide_eqb_ok@{i} {A:Type@{i} } `{DecidablePaths A} : forall a b, iff@{Set i i} (eqb a b = true) (a = b). Proof. unfold eqb,decide_eqb. intros a b;destruct (decide_rel paths a b) as [E1|E1];split;intros E2;auto. - destruct (false_ne_true E2). - destruct (E1 E2). Qed. Lemma LT_EQ : LT <> EQ. Proof. intros E. change ((fun r => match r with LT => Unit | _ => Empty end) EQ). rewrite <-E. split. Qed. Lemma LT_GT : LT <> GT. Proof. intros E. change ((fun r => match r with LT => Unit | _ => Empty end) GT). rewrite <-E. split. Qed. Lemma EQ_LT : EQ <> LT. Proof. apply symmetric_neq, LT_EQ. Qed. Lemma EQ_GT : EQ <> GT. Proof. intros E. change ((fun r => match r with EQ => Unit | _ => Empty end) GT). rewrite <-E. split. Qed. Lemma GT_EQ : GT <> EQ. Proof. apply symmetric_neq, EQ_GT. Qed. Global Instance compare_eqb `{Compare A} : Eqb A | 2 := fun a b => match a ?= b with | EQ => true | _ => false end. Lemma compare_eqb_eq `{Compare A} : forall a b : A, a =? b = true -> a ?= b = EQ. Proof. unfold eqb,compare_eqb;simpl. intros a b. destruct (a ?= b);trivial;intros E;destruct (false_ne_true E). Qed. Global Instance tricho_compare `{Trichotomy A R} : Compare A | 2 := fun a b => match trichotomy R a b with | inl _ => LT | inr (inl _) => EQ | inr (inr _) => GT end. Lemma tricho_compare_eq `{Trichotomy A R} : forall a b : A, compare a b = EQ -> a = b. Proof. unfold compare,tricho_compare. intros a b;destruct (trichotomy R a b) as [E|[E|E]];auto. - intros E1;destruct (LT_EQ E1). - intros E1;destruct (GT_EQ E1). Qed. Lemma tricho_compare_ok `{Trichotomy A R} `{Irreflexive A R} : forall a b : A, compare a b = EQ <-> a = b. Proof. unfold compare,tricho_compare. intros a b;destruct (trichotomy R a b) as [E1|[E1|E1]];split;auto. - intros E2;destruct (LT_EQ E2). - intros E2;rewrite E2 in E1. destruct (irreflexivity R _ E1). - intros E2;destruct (GT_EQ E2). - intros E2;rewrite E2 in E1. destruct (irreflexivity R _ E1). Qed. Lemma total_abs_either `{Abs A} `{!TotalRelation le} : forall x : A, (0 <= x /\ abs x = x) |_| (x <= 0 /\ abs x = - x). Proof. intros x. destruct (total le 0 x) as [E|E]. - left. split;trivial. apply ((abs_sig x).2);trivial. - right. split;trivial. apply ((abs_sig x).2);trivial. Qed. Coq-HoTT-9.0/theories/Classes/theory/apartness.v000066400000000000000000000151261474641544500216630ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra. Generalizable Variables A B C f g. Section contents. Context `{IsApart A}. Lemma apart_ne x y : PropHolds (x ≶ y) -> PropHolds (x <> y). Proof. unfold PropHolds. intros ap e;revert ap. apply tight_apart. assumption. Qed. Global Instance: forall x y : A, Stable (x = y). Proof. intros x y. unfold Stable. intros dn. apply tight_apart. intros ap. apply dn. apply apart_ne. assumption. Qed. End contents. (* Due to bug #2528 *) #[export] Hint Extern 3 (PropHolds (_ <> _)) => eapply @apart_ne : typeclass_instances. Lemma projected_strong_setoid `{IsApart B} `{Apart A} `{IsHSet A} `{is_mere_relation A apart} (f: A -> B) (eq_correct : forall x y, x = y <-> f x = f y) (apart_correct : forall x y, x ≶ y <-> f x ≶ f y) : IsApart A. Proof. split. - apply _. - apply _. - intros x y ap. apply apart_correct, symmetry, apart_correct. assumption. - intros x y ap z. apply apart_correct in ap. apply (merely_destruct (cotransitive ap (f z))). intros [?|?];apply tr;[left|right];apply apart_correct;assumption. - intros x y;split. + intros nap. apply eq_correct. apply tight_apart. intros ap. apply nap. apply apart_correct;assumption. + intros e ap. apply apart_correct in ap;revert ap. apply tight_apart. apply eq_correct;assumption. Qed. Global Instance sg_apart_mere `{IsApart A} (P : A -> Type) : is_mere_relation (sig P) apart. Proof. intros. unfold apart,sig_apart. apply _. Qed. Global Instance sig_strong_setoid `{IsApart A} (P: A -> Type) `{forall x, IsHProp (P x)} : IsApart (sig P). Proof. apply (projected_strong_setoid (@proj1 _ P)). - intros. split;apply Sigma.equiv_path_sigma_hprop. - intros;apply reflexivity. Qed. Section morphisms. Context `{IsApart A} `{IsApart B} `{IsApart C}. Global Instance strong_injective_injective `{!IsStrongInjective (f : A -> B)} : IsInjective f. Proof. pose proof (strong_injective_mor f). intros ? ? e. apply tight_apart. intros ap. apply tight_apart in e. apply e. apply strong_injective;auto. Qed. (* If a morphism satisfies the binary strong extensionality property, it is strongly extensional in both coordinates. *) Global Instance strong_setoid_morphism_1 `{!StrongBinaryExtensionality (f : A -> B -> C)} : forall z, StrongExtensionality (f z). Proof. intros z x y E. apply (merely_destruct (strong_binary_extensionality f z x z y E)). intros [?|?];trivial. destruct (irreflexivity (≶) z). assumption. Qed. Global Instance strong_setoid_morphism_unary_2 `{!StrongBinaryExtensionality (f : A -> B -> C)} : forall z, StrongExtensionality (fun x => f x z). Proof. intros z x y E. apply (merely_destruct (strong_binary_extensionality f x z y z E)). intros [?|?];trivial. destruct (irreflexivity (≶) z);assumption. Qed. (* Conversely, if a morphism is strongly extensional in both coordinates, it satisfies the binary strong extensionality property. We don't make this an instance in order to avoid loops. *) Lemma strong_binary_setoid_morphism_both_coordinates `{!IsApart A} `{!IsApart B} `{!IsApart C} {f : A -> B -> C} `{forall z, StrongExtensionality (f z)} `{forall z, StrongExtensionality (fun x => f x z)} : StrongBinaryExtensionality f. Proof. intros x₁ y₁ x₂ y₂ E. apply (merely_destruct (cotransitive E (f x₂ y₁))). intros [?|?];apply tr. - left. apply (strong_extensionality (fun x => f x y₁));trivial. - right. apply (strong_extensionality (f x₂));trivial. Qed. End morphisms. Section more_morphisms. Context `{IsApart A} `{IsApart B}. Lemma strong_binary_setoid_morphism_commutative {f : A -> A -> B} `{!Commutative f} `{forall z, StrongExtensionality (f z)} : StrongBinaryExtensionality f. Proof. apply @strong_binary_setoid_morphism_both_coordinates;try apply _. intros z x y. rewrite !(commutativity _ z). apply (strong_extensionality (f z)). Qed. End more_morphisms. Section default_apart. Context `{DecidablePaths A}. Instance default_apart : Apart A | 20 := fun x y => match dec (x = y) with | inl _ => false | inr _ => true end = true. Typeclasses Opaque default_apart. Instance default_apart_trivial : TrivialApart A (Aap:=default_apart). Proof. split. - unfold apart,default_apart. apply _. - intros x y;unfold apart,default_apart;split. + intros E. destruct (dec (x=y)). * destruct (false_ne_true E). * trivial. + intros E;destruct (dec (x=y)) as [e|_]. * destruct (E e). * split. Qed. End default_apart. (* In case we have a decidable setoid, we can construct a strong setoid. Again we do not make this an instance as it will cause loops *) Section dec_setoid. Context `{TrivialApart A} `{DecidablePaths A}. (* Not Global in order to avoid loops *) Instance ne_apart x y : PropHolds (x <> y) -> PropHolds (x ≶ y). Proof. intros ap. apply trivial_apart. assumption. Qed. Global Instance dec_strong_setoid: IsApart A. Proof. split. - apply _. - apply _. - intros x y ne. apply trivial_apart. apply trivial_apart in ne. intros e;apply ne,symmetry,e. - hnf. intros x y ne z. apply trivial_apart in ne. destruct (dec (x=z)) as [e|ne'];[destruct (dec (z=y)) as [e'|ne']|]. + destruct ne. path_via z. + apply tr;right. apply trivial_apart. assumption. + apply tr;left. apply trivial_apart. assumption. - intros x y;split. + intros nap. destruct (dec (x=y));auto. destruct nap. apply trivial_apart;trivial. + intros e. intros nap. apply trivial_apart in nap. auto. Qed. End dec_setoid. (* And a similar result for morphisms *) Section dec_setoid_morphisms. Context `{IsApart A} `{!TrivialApart A} `{IsApart B}. Instance dec_strong_morphism (f : A -> B) : StrongExtensionality f. Proof. intros x y E. apply trivial_apart. intros e. apply tight_apart in E;auto. Qed. Context `{!TrivialApart B}. Instance dec_strong_injective (f : A -> B) `{!IsInjective f} : IsStrongInjective f. Proof. split; try apply _. intros x y. intros ap. apply trivial_apart in ap. apply trivial_apart. intros e. apply ap. apply (injective f). assumption. Qed. Context `{IsApart C}. Instance dec_strong_binary_morphism (f : A -> B -> C) : StrongBinaryExtensionality f. Proof. intros x1 y1 x2 y2 hap. apply (merely_destruct (cotransitive hap (f x2 y1)));intros [h|h];apply tr. - left. apply trivial_apart. intros e. apply tight_apart in h;auto. exact (ap (fun x => f x y1) e). - right. apply trivial_apart. intros e. apply tight_apart in h;auto. Qed. End dec_setoid_morphisms. Coq-HoTT-9.0/theories/Classes/theory/dec_fields.v000066400000000000000000000213551474641544500217450ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.theory.fields HoTT.Classes.theory.apartness. Require Export HoTT.Classes.theory.rings. Generalizable Variables F f R. Section contents. Context `{IsDecField F} `{forall x y: F, Decidable (x = y)}. (* Add Ring F : (stdlib_ring_theory F). *) Global Instance decfield_zero_product : ZeroProduct F. Proof. intros x y E. destruct (dec (x = 0)) as [? | Ex];auto. right. rewrite <-(mult_1_r y), <-(dec_recip_inverse x) by assumption. rewrite associativity, (commutativity y), E. apply mult_0_l. Qed. Global Instance decfield_integral_domain : IsIntegralDomain F. Proof. split; try apply _. Qed. Lemma dec_recip_1: / 1 = 1. Proof. rewrite <-(rings.mult_1_l (/1)). apply dec_recip_inverse. solve_propholds. Qed. Lemma dec_recip_distr (x y: F): / (x * y) = / x * / y. Proof. destruct (dec (x = 0)) as [Ex|Ex]. - rewrite Ex, left_absorb, dec_recip_0. apply symmetry,mult_0_l. - destruct (dec (y = 0)) as [Ey|Ey]. + rewrite Ey, dec_recip_0, !mult_0_r. apply dec_recip_0. + assert (x * y <> 0) as Exy by (apply mult_ne_0;trivial). apply (left_cancellation_ne_0 (.*.) (x * y)); trivial. transitivity (x / x * (y / y)). * rewrite !dec_recip_inverse by assumption. rewrite mult_1_l;apply reflexivity. * rewrite !dec_recip_inverse by assumption. rewrite mult_assoc, (mult_comm x), <-(mult_assoc y). rewrite dec_recip_inverse by assumption. rewrite (mult_comm y), <-mult_assoc. rewrite dec_recip_inverse by assumption. reflexivity. Qed. Lemma dec_recip_zero x : / x = 0 <-> x = 0. Proof. split; intros E. - apply stable. intros Ex. destruct (is_ne_0 1). rewrite <-(dec_recip_inverse x), E by assumption. apply mult_0_r. - rewrite E. apply dec_recip_0. Qed. Lemma dec_recip_ne_0_iff x : / x <> 0 <-> x <> 0. Proof. split; intros E1 E2; destruct E1; apply dec_recip_zero;trivial. do 2 apply (snd (dec_recip_zero _)). trivial. Qed. Instance dec_recip_ne_0 x : PropHolds (x <> 0) -> PropHolds (/x <> 0). Proof. intro. apply (snd (dec_recip_ne_0_iff _)). trivial. Qed. Lemma equal_by_one_quotient (x y : F) : x / y = 1 -> x = y. Proof. intro Exy. destruct (dec (y = 0)) as [Ey|Ey]. - destruct (is_ne_0 1). rewrite <- Exy, Ey, dec_recip_0. apply mult_0_r. - apply (right_cancellation_ne_0 (.*.) (/y)). + apply dec_recip_ne_0. trivial. + rewrite dec_recip_inverse;trivial. Qed. Global Instance dec_recip_inj: IsInjective (/). Proof. repeat (split; try apply _). intros x y E. destruct (dec (y = 0)) as [Ey|Ey]. - rewrite Ey in *. rewrite dec_recip_0 in E. apply dec_recip_zero. trivial. - apply (right_cancellation_ne_0 (.*.) (/y)). + apply dec_recip_ne_0. trivial. + rewrite dec_recip_inverse by assumption. rewrite <-E, dec_recip_inverse;trivial. apply dec_recip_ne_0_iff. rewrite E. apply dec_recip_ne_0. trivial. Qed. Global Instance dec_recip_involutive: Involutive (/). Proof. intros x. destruct (dec (x = 0)) as [Ex|Ex]. - rewrite Ex, !dec_recip_0. trivial. - apply (right_cancellation_ne_0 (.*.) (/x)). + apply dec_recip_ne_0. trivial. + rewrite dec_recip_inverse by assumption. rewrite mult_comm, dec_recip_inverse. * reflexivity. * apply dec_recip_ne_0. trivial. Qed. Lemma equal_dec_quotients (a b c d : F) : b <> 0 -> d <> 0 -> (a * d = c * b <-> a / b = c / d). Proof. split; intro E. - apply (right_cancellation_ne_0 (.*.) b);trivial. apply (right_cancellation_ne_0 (.*.) d);trivial. transitivity (a * d * (b * /b));[| transitivity (c * b * (d * /d))]. + rewrite <-!(mult_assoc a). apply ap. rewrite (mult_comm d), (mult_comm _ b). reflexivity. + rewrite E, dec_recip_inverse, dec_recip_inverse;trivial. + rewrite <-!(mult_assoc c). apply ap. rewrite (mult_comm d), mult_assoc, (mult_comm b). reflexivity. - transitivity (a * d * 1);[rewrite mult_1_r;reflexivity|]. rewrite <-(dec_recip_inverse b);trivial. transitivity (c * b * 1);[|rewrite mult_1_r;reflexivity]. rewrite <-(dec_recip_inverse d);trivial. rewrite mult_comm, <-mult_assoc, (mult_assoc _ a), (mult_comm _ a), E. rewrite <-mult_assoc. rewrite (mult_comm _ d). rewrite mult_assoc, (mult_comm c). reflexivity. Qed. Lemma dec_quotients (a c b d : F) : b <> 0 -> d <> 0 -> a / b + c / d = (a * d + c * b) / (b * d). Proof. intros A B. assert (a / b = (a * d) / (b * d)) as E1. - apply equal_dec_quotients;auto. + solve_propholds. + rewrite (mult_comm b);apply associativity. - assert (c / d = (b * c) / (b * d)) as E2. + apply equal_dec_quotients;trivial. * solve_propholds. * rewrite mult_assoc, (mult_comm c). reflexivity. + rewrite E1, E2. rewrite (mult_comm c b). apply symmetry, simple_distribute_r. Qed. Lemma dec_recip_swap_l x y: x / y = / (/ x * y). Proof. rewrite dec_recip_distr, involutive. reflexivity. Qed. Lemma dec_recip_swap_r x y: / x * y = / (x / y). Proof. rewrite dec_recip_distr, involutive. reflexivity. Qed. Lemma dec_recip_negate x : -(/ x) = / (-x). Proof. destruct (dec (x = 0)) as [Ex|Ex]. - rewrite Ex, negate_0, dec_recip_0, negate_0. reflexivity. - apply (left_cancellation_ne_0 (.*.) (-x)). + apply (snd (flip_negate_ne_0 _)). trivial. + rewrite dec_recip_inverse. * rewrite negate_mult_negate. apply dec_recip_inverse. trivial. * apply (snd (flip_negate_ne_0 _)). trivial. Qed. End contents. (* Due to bug #2528 *) #[export] Hint Extern 7 (PropHolds (/ _ <> 0)) => eapply @dec_recip_ne_0 : typeclass_instances. (* Given a decidable field we can easily construct a constructive field. *) Section is_field. Context `{IsDecField F} `{Apart F} `{!TrivialApart F} `{Decidable.DecidablePaths F}. Global Instance recip_dec_field: Recip F := fun x => / x.1. Local Existing Instance dec_strong_setoid. Global Instance decfield_field : IsField F. Proof. split; try apply _. - apply (dec_strong_binary_morphism (+)). - apply (dec_strong_binary_morphism (.*.)). - intros [x Px]. rapply (dec_recip_inverse x). apply trivial_apart. trivial. Qed. Lemma dec_recip_correct (x : F) Px : / x = // (x;Px). Proof. apply (left_cancellation_ne_0 (.*.) x). - apply trivial_apart. trivial. - rewrite dec_recip_inverse, reciperse_alt by (apply trivial_apart;trivial). reflexivity. Qed. End is_field. (* Definition stdlib_field_theory F `{DecField F} : Field_theory.field_theory 0 1 (+) (.*.) (fun x y => x - y) (-) (fun x y => x / y) (/) (=). Proof with auto. intros. constructor. apply (theory.rings.stdlib_ring_theory _). apply (is_ne_0 1). reflexivity. intros. rewrite commutativity. by apply dec_recip_inverse. Qed. *) (* Section from_stdlib_field_theory. Context `(ftheory : @field_theory F Fzero Fone Fplus Fmult Fminus Fnegate Fdiv Frecip Fe) (rinv_0 : Fe (Frecip Fzero) Fzero) `{!@Setoid F Fe} `{!Proper (Fe ==> Fe ==> Fe) Fplus} `{!Proper (Fe ==> Fe ==> Fe) Fmult} `{!Proper (Fe ==> Fe) Fnegate} `{!Proper (Fe ==> Fe) Frecip}. Add Field F2 : ftheory. Definition from_stdlib_field_theory: @DecField F Fe Fplus Fmult Fzero Fone Fnegate Frecip. Proof with auto. destruct ftheory. repeat (constructor; try assumption); repeat intro ; unfold equiv, mon_unit, sg_op, zero_is_mon_unit, plus_is_sg_op, one_is_mon_unit, mult_is_sg_op, plus, mult, recip, negate; try field. unfold recip, mult. simpl. assert (Fe (Fmult x (Frecip x)) (Fmult (Frecip x) x)) as E by ring. rewrite E. Qed. End from_stdlib_field_theory. *) Section morphisms. Context `{IsDecField F} `{TrivialApart F} `{Decidable.DecidablePaths F}. Global Instance dec_field_to_domain_inj `{IsIntegralDomain R} `{!IsSemiRingPreserving (f : F -> R)} : IsInjective f. Proof. apply injective_preserves_0. intros x Efx. apply stable. intros Ex. destruct (is_ne_0 (1:R)). rewrite <-(rings.preserves_1 (f:=f)). rewrite <-(dec_recip_inverse x) by assumption. rewrite rings.preserves_mult, Efx. apply left_absorb. Qed. Lemma preserves_dec_recip `{IsDecField F2} `{forall x y: F2, Decidable (x = y)} `{!IsSemiRingPreserving (f : F -> F2)} x : f (/ x) = / f x. Proof. case (dec (x = 0)) as [E | E]. - rewrite E, dec_recip_0, preserves_0, dec_recip_0. reflexivity. - intros. apply (left_cancellation_ne_0 (.*.) (f x)). + apply isinjective_ne_0. trivial. + rewrite <-preserves_mult, 2!dec_recip_inverse. * apply preserves_1. * apply isinjective_ne_0. trivial. * trivial. Qed. Lemma dec_recip_to_recip `{IsField F2} `{!IsSemiRingStrongPreserving (f : F -> F2)} x Pfx : f (/ x) = // (f x;Pfx). Proof. assert (x <> 0). - intros Ex. destruct (apart_ne (f x) 0 Pfx). rewrite Ex, (preserves_0 (f:=f)). reflexivity. - apply (left_cancellation_ne_0 (.*.) (f x)). + apply isinjective_ne_0. trivial. + rewrite <-preserves_mult, dec_recip_inverse, reciperse_alt by assumption. apply preserves_1. Qed. End morphisms. Coq-HoTT-9.0/theories/Classes/theory/fields.v000066400000000000000000000207411474641544500211300ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.theory.apartness. Require Export HoTT.Classes.theory.rings. Generalizable Variables F f. Section field_properties. Context `{IsField F}. Definition recip' (x : F) (apx : x ≶ 0) : F := //(x;apx). (* Add Ring F : (stdlib_ring_theory F). *) Lemma recip_inverse' (x : F) (Px : x ≶ 0) : x // (x; Px) = 1. Proof. apply (recip_inverse (x;Px)). Qed. Lemma reciperse_alt (x : F) Px : x // (x;Px) = 1. Proof. rewrite <-(recip_inverse (x;Px)). trivial. Qed. Lemma recip_proper_alt x y Px Py : x = y -> // (x;Px) = // (y;Py). Proof. intro E. apply ap. apply Sigma.path_sigma with E. apply path_ishprop. Qed. Lemma recip_proper x y Py : x // (y;Py) = 1 -> x = y. Proof. intros eqxy. rewrite <- (mult_1_r y). rewrite <- eqxy. rewrite (mult_assoc y x (//(y;Py))). rewrite (mult_comm y x). rewrite <- (mult_assoc x y (//(y;Py))). rewrite (recip_inverse (y;Py)). rewrite (mult_1_r x). reflexivity. Qed. Lemma recip_irrelevant x Px1 Px2 : // (x;Px1) = // (x;Px2). Proof. apply recip_proper_alt. reflexivity. Qed. Lemma apart_0_proper {x y} : x ≶ 0 -> x = y -> y ≶ 0. Proof. intros ? E. rewrite <-E. trivial. Qed. Global Instance: IsStrongInjective (-). Proof. repeat (split; try apply _); intros x y E. - apply (strong_extensionality (+ x + y)). rewrite simple_associativity, left_inverse, plus_0_l. rewrite (commutativity (f:=plus) x y), simple_associativity, left_inverse, plus_0_l. apply symmetry;trivial. - apply (strong_extensionality (+ -x + -y)). rewrite simple_associativity, right_inverse, plus_0_l. rewrite (commutativity (f:=plus) (- x) (- y)), simple_associativity, right_inverse, plus_0_l. apply symmetry;trivial. Qed. Global Instance: IsStrongInjective (//). Proof. repeat (split; try apply _); intros x y E. - apply (strong_extensionality (x.1 *.)). rewrite recip_inverse, (commutativity (f:=mult)). apply (strong_extensionality (y.1 *.)). rewrite simple_associativity, recip_inverse. rewrite mult_1_l,mult_1_r. apply symmetry;trivial. - apply (strong_extensionality (.* // x)). rewrite recip_inverse, (commutativity (f:=mult)). apply (strong_extensionality (.* // y)). rewrite <-simple_associativity, recip_inverse. rewrite mult_1_l,mult_1_r. apply symmetry;trivial. Qed. Global Instance: forall z, StrongLeftCancellation (+) z. Proof. intros z x y E. apply (strong_extensionality (+ -z)). do 2 rewrite (commutativity (f:=plus) z _), <-simple_associativity,right_inverse,plus_0_r. trivial. Qed. Global Instance: forall z, StrongRightCancellation (+) z. Proof. intros. apply (strong_right_cancel_from_left (+)). Qed. Global Instance: forall z, PropHolds (z ≶ 0) -> StrongLeftCancellation (.*.) z. Proof. intros z Ez x y E. red in Ez. rewrite !(commutativity z). apply (strong_extensionality (.* // (z;(Ez : (≶0) z)))). rewrite <-!simple_associativity, !reciperse_alt. rewrite !mult_1_r;trivial. Qed. Global Instance: forall z, PropHolds (z ≶ 0) -> StrongRightCancellation (.*.) z. Proof. intros. apply (strong_right_cancel_from_left (.*.)). Qed. Lemma mult_apart_zero_l x y : x * y ≶ 0 -> x ≶ 0. Proof. intros. apply (strong_extensionality (.* y)). rewrite mult_0_l. trivial. Qed. Lemma mult_apart_zero_r x y : x * y ≶ 0 -> y ≶ 0. Proof. intros. apply (strong_extensionality (x *.)). rewrite mult_0_r. trivial. Qed. Instance mult_apart_zero x y : PropHolds (x ≶ 0) -> PropHolds (y ≶ 0) -> PropHolds (x * y ≶ 0). Proof. intros Ex Ey. apply (strong_extensionality (.* // (y;(Ey : (≶0) y)))). rewrite <-simple_associativity, reciperse_alt, mult_1_r, mult_0_l. trivial. Qed. Instance: NoZeroDivisors F. Proof. intros x [x_nonzero [y [y_nonzero E]]]. assert (~ ~ apart y 0) as Ey. - intros E';apply y_nonzero,tight_apart,E'. - apply Ey. intro y_apartzero. apply x_nonzero. rewrite <- (mult_1_r x). rewrite <- (reciperse_alt y y_apartzero). rewrite simple_associativity, E. apply mult_0_l. Qed. Global Instance : IsIntegralDomain F := {}. Global Instance apart_0_sig_apart_0: forall (x : ApartZero F), PropHolds (x.1 ≶ 0). Proof. intros [??];trivial. Qed. Instance recip_apart_zero x : PropHolds (// x ≶ 0). Proof. red. apply mult_apart_zero_r with (x.1). rewrite recip_inverse. solve_propholds. Qed. Lemma field_div_0_l x y : x = 0 -> x // y = 0. Proof. intros E. rewrite E. apply left_absorb. Qed. Lemma field_div_diag x y : x = y.1 -> x // y = 1. Proof. intros E. rewrite E. apply recip_inverse. Qed. Lemma equal_quotients (a c: F) b d : a * d.1 = c * b.1 <-> a // b = c // d. Proof. split; intro E. - rewrite <-(mult_1_l (a // b)), <- (recip_inverse d), (commutativity (f:=mult) d.1 (// d)), <-simple_associativity, (simple_associativity d.1), (commutativity (f:=mult) d.1 a), E, <-simple_associativity, simple_associativity, recip_inverse, mult_1_r. apply commutativity. - rewrite <-(mult_1_r (a * d.1)), <- (recip_inverse b), <-simple_associativity, (commutativity (f:=mult) b.1 (// b)), (simple_associativity d.1), (commutativity (f:=mult) d.1), !simple_associativity, E, <-(simple_associativity c), (commutativity (f:=mult) (// d)), recip_inverse, mult_1_r. reflexivity. Qed. Lemma recip_distr_alt (x y : F) Px Py Pxy : // (x * y ; Pxy) = // (x;Px) * // (y;Py). Proof. apply (left_cancellation_ne_0 (.*.) (x * y)). - apply apart_ne;trivial. - transitivity ((x // (x;Px)) * (y // (y;Py))). + rewrite 3!reciperse_alt,mult_1_r. reflexivity. + rewrite <-simple_associativity,<-simple_associativity. apply ap. rewrite simple_associativity. rewrite (commutativity (f:=mult) _ y). rewrite <-simple_associativity. reflexivity. Qed. Lemma apart_negate (x : F) (Px : x ≶ 0) : (-x) ≶ 0. Proof. (* Have: x <> 0 *) (* Want to show: -x <> 0 *) (* Since x=x+0 <> 0=x-x, have x<>x or 0<>-x *) assert (ap : x + 0 ≶ x - x). { rewrite (plus_0_r x). rewrite (plus_negate_r x). assumption. } refine (Trunc_rec _ (field_plus_ext F x 0 x (-x) ap)). intros [apxx|ap0x]. - destruct (apart_ne x x apxx); reflexivity. - symmetry; assumption. Qed. Definition negate_apart : ApartZero F -> ApartZero F. Proof. intros [x Px]. exists (-x). exact ((apart_negate x Px)). Defined. Lemma recip_negate (x : F) (Px : x ≶ 0) : (-//(x;Px))=//(negate_apart(x;Px)). Proof. apply (left_cancellation (.*.) x). rewrite <- negate_mult_distr_r. rewrite reciperse_alt. apply flip_negate. rewrite negate_mult_distr_l. refine (_^). apply reciperse_alt. Qed. Lemma recip_apart (x : F) (Px : x ≶ 0) : // (x;Px) ≶ 0. Proof. apply (strong_extensionality (x*.) (// (x; Px)) 0). rewrite (recip_inverse (x;Px)). rewrite mult_0_r. solve_propholds. Qed. Definition recip_on_apart (x : ApartZero F) : ApartZero F. Proof. exists (//x). apply recip_apart. Defined. Global Instance recip_involutive: Involutive recip_on_apart. Proof. intros [x apx0]. apply path_sigma_hprop. unfold recip_on_apart. cbn. apply (left_cancellation (.*.) (// (x; apx0))). rewrite (recip_inverse' (// (x; apx0)) (recip_apart x apx0)). rewrite mult_comm. rewrite (recip_inverse (x;apx0)). reflexivity. Qed. End field_properties. (* Due to bug #2528 *) #[export] Hint Extern 8 (PropHolds (// _ ≶ 0)) => eapply @recip_apart_zero : typeclass_instances. #[export] Hint Extern 8 (PropHolds (_ * _ ≶ 0)) => eapply @mult_apart_zero : typeclass_instances. Section morphisms. Context `{IsField F1} `{IsField F2} `{!IsSemiRingStrongPreserving (f : F1 -> F2)}. (* Add Ring F1 : (stdlib_ring_theory F1). *) Lemma strong_injective_preserves_0 : (forall x, x ≶ 0 -> f x ≶ 0) -> IsStrongInjective f. Proof. intros E1. split; try apply _. intros x y E2. apply (strong_extensionality (+ -f y)). rewrite plus_negate_r, <-preserves_minus. apply E1. apply (strong_extensionality (+ y)). rewrite <-simple_associativity,left_inverse,plus_0_l,plus_0_r. trivial. Qed. (* We have the following for morphisms to non-trivial strong rings as well. However, since we do not have an interface for strong rings, we ignore it. *) Global Instance: IsStrongInjective f. Proof. apply strong_injective_preserves_0. intros x Ex. apply mult_apart_zero_l with (f (// exist (≶0) x Ex)). rewrite <-rings.preserves_mult. rewrite reciperse_alt. rewrite (rings.preserves_1 (f:=f)). solve_propholds. Qed. Lemma preserves_recip x Px Pfx : f (// (x;Px)) = // (f x;Pfx). Proof. apply (left_cancellation_ne_0 (.*.) (f x)). - apply apart_ne;trivial. - rewrite <-rings.preserves_mult. rewrite !reciperse_alt. apply preserves_1. Qed. End morphisms. Coq-HoTT-9.0/theories/Classes/theory/groups.v000066400000000000000000000140021474641544500211720ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra. Local Open Scope mc_mult_scope. Generalizable Variables G H A B C f g. Section group_props. Context `{IsGroup G}. (** Group inverses are involutive *) Global Instance inverse_involutive : Involutive (^). Proof. intros x. transitivity (mon_unit * x). 2: apply left_identity. transitivity ((x^^ * x^) * x). 2: apply (@ap _ _ (fun y => y * x)), left_inverse. transitivity (x^^ * (x^ * x)). 2: apply associativity. transitivity (x^^ * mon_unit). 2: apply ap, symmetry, left_inverse. apply symmetry, right_identity. Qed. Global Instance isinj_group_inverse : IsInjective (^). Proof. intros x y E. refine ((involutive x)^ @ _ @ involutive y). apply ap, E. Qed. Lemma inverse_mon_unit : mon_unit^ = mon_unit. Proof. change ((fun x => mon_unit^ = x) mon_unit). apply (transport _ (left_inverse mon_unit)). apply symmetry, right_identity. Qed. Global Instance group_cancelL : forall z : G, LeftCancellation (.*.) z. Proof. intros z x y E. rhs_V rapply left_identity. rhs_V rapply (ap (.* y) (left_inverse z)). rhs_V rapply simple_associativity. rhs_V rapply (ap (-z *.) E). symmetry. lhs rapply simple_associativity. lhs rapply (ap (.* x) (left_inverse z)). apply left_identity. Defined. Global Instance group_cancelR: forall z : G, RightCancellation (.*.) z. Proof. intros z x y E. rewrite <-(right_identity x). rewrite <-(right_inverse (unit:=mon_unit) z). rewrite associativity. rewrite E. rewrite <-(associativity y ), right_inverse, right_identity. reflexivity. Qed. Lemma inverse_sg_op x y : (x * y)^ = y^ * x^. Proof. rewrite <- (left_identity (-y * -x)). rewrite <- (left_inverse (unit:=mon_unit) (x * y)). rewrite <- simple_associativity. rewrite <- simple_associativity. rewrite (associativity y). rewrite right_inverse. rewrite (left_identity (-x)). rewrite right_inverse. apply symmetry, right_identity. Qed. End group_props. Section abgroup_props. Local Open Scope mc_add_scope. Lemma negate_sg_op_distr `{IsAbGroup G} x y : -(x + y) = -x + -y. Proof. path_via (-y + -x). - rapply inverse_sg_op. - apply commutativity. Qed. Local Close Scope mc_add_scope. End abgroup_props. Section groupmor_props. Context `{IsGroup A} `{IsGroup B} {f : A -> B} `{!IsMonoidPreserving f}. Lemma preserves_inverse x : f x^ = (f x)^. Proof. apply (left_cancellation (.*.) (f x)). rewrite <-preserves_sg_op. rewrite 2!right_inverse. apply preserves_mon_unit. Qed. End groupmor_props. Section from_another_sg. Context `{IsSemiGroup A} `{IsHSet B} `{Bop : SgOp B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x * y) = f x * f y). Lemma projected_sg: IsSemiGroup B. Proof. split. - apply _. - repeat intro; apply (injective f). rewrite !op_correct. apply associativity. Qed. End from_another_sg. Section from_another_com. Context `{SgOp A} `{!Commutative (A:=A) sg_op} {B} `{Bop : SgOp B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x * y) = f x * f y). Lemma projected_comm : Commutative (A:=B) sg_op. Proof. intros x y. apply (injective f). rewrite 2!op_correct. apply commutativity. Qed. End from_another_com. Section from_another_com_sg. Context `{IsCommutativeSemiGroup A} `{IsHSet B} `{Bop : SgOp B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x * y) = f x * f y). Lemma projected_com_sg : IsCommutativeSemiGroup B. Proof. split. - apply (projected_sg f);assumption. - apply (projected_comm f);assumption. Qed. End from_another_com_sg. Section from_another_monoid. Context `{IsMonoid A} `{IsHSet B} `{Bop : SgOp B} `{Bunit : MonUnit B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x * y) = f x * f y) (unit_correct : f mon_unit = mon_unit). Lemma projected_monoid : IsMonoid B. Proof. split. - apply (projected_sg f). assumption. - repeat intro; apply (injective f). rewrite op_correct, unit_correct, left_identity. reflexivity. - repeat intro; apply (injective f). rewrite op_correct, unit_correct, right_identity. reflexivity. Qed. End from_another_monoid. Section from_another_com_monoid. Context `{IsCommutativeMonoid A} `{IsHSet B} `{Bop : SgOp B} `{Bunit : MonUnit B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x * y) = f x * f y) (unit_correct : f mon_unit = mon_unit). Lemma projected_com_monoid : IsCommutativeMonoid B. Proof. split. - apply (projected_monoid f);assumption. - apply (projected_comm f);assumption. Qed. End from_another_com_monoid. Section from_another_group. Context `{isg : IsGroup A} `{IsHSet B} `{Bop : SgOp B} `{Bunit : MonUnit B} `{Binv : Inverse B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x * y) = f x * f y) (unit_correct : f mon_unit = mon_unit) (inverse_correct : forall x, f x^ = (f x)^). Lemma projected_group : IsGroup B. Proof. split. - apply (projected_monoid f);assumption. - repeat intro; apply (injective f). rewrite op_correct, inverse_correct, unit_correct, left_inverse. apply reflexivity. - repeat intro; apply (injective f). rewrite op_correct, inverse_correct, unit_correct, right_inverse. reflexivity. Qed. End from_another_group. Section from_another_ab_group. Local Open Scope mc_add_scope. Context `{IsAbGroup A} `{IsHSet B} `{Bop : SgOp B} `{Bunit : MonUnit B} `{Bnegate : Negate B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x + y) = f x + f y) (unit_correct : f 0 = 0) (negate_correct : forall x, f (-x) = -f x). Lemma projected_ab_group : IsAbGroup B. Proof. split. - apply (projected_group f (isg:=abgroup_group _)); assumption. - apply (projected_comm f); assumption. Qed. Local Close Scope mc_add_scope. End from_another_ab_group. Coq-HoTT-9.0/theories/Classes/theory/int_abs.v000066400000000000000000000107201474641544500212750ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.naturals HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.orders.nat_int HoTT.Classes.theory.integers HoTT.Classes.theory.rings HoTT.Classes.theory.groups HoTT.Classes.orders.rings. Generalizable Variables N Z Zle Zlt R f. Section contents. Context `{Funext} `{Univalence}. Context `{Integers Z} `{Apart Z} `{!TrivialApart Z} `{!FullPseudoSemiRingOrder Zle Zlt} `{Naturals N}. (* Add Ring Z : (rings.stdlib_ring_theory Z). *) Lemma int_abs_unique (a b : IntAbs Z N) (z : Z) : int_abs Z N (ia:=a) z = int_abs Z N (ia:=b) z. Proof. unfold int_abs. destruct (int_abs_sig Z N (IntAbs:=a) z) as [[n1 E1]|[n1 E1]]; destruct (int_abs_sig Z N (IntAbs:=b) z) as [[n2 E2]|[n2 E2]]. - apply (injective (naturals_to_semiring N Z)). path_via z. - assert (E : n1 + n2 = 0);[|path_via 0;[|symmetry]; apply (naturals.zero_sum _ _ E)]. apply (injective (naturals_to_semiring N Z)). rewrite preserves_0,preserves_plus. rewrite E1,E2. apply plus_negate_r. - assert (E : n1 + n2 = 0);[|path_via 0;[|symmetry]; apply (naturals.zero_sum _ _ E)]. apply (injective (naturals_to_semiring N Z)). rewrite preserves_0,preserves_plus. rewrite E1,E2. apply plus_negate_l. - apply (injective (naturals_to_semiring N Z)). path_via (- z). Qed. Context `{!IntAbs Z N}. Context `{!IsSemiRingPreserving (f : N -> Z)}. Lemma int_abs_spec x : (0 ≤ x /\ f (int_abs Z N x) = x) |_| (x ≤ 0 /\ f (int_abs Z N x) = -x). Proof. unfold int_abs. destruct (int_abs_sig Z N x) as [[n E]|[n E]]. - left. rewrite <-E. split. + eapply @to_semiring_nonneg;apply _. + apply (naturals.to_semiring_unique_alt _ _). - right. split. + apply flip_nonpos_negate. rewrite <-E. eapply @to_semiring_nonneg;apply _. + rewrite <-E. apply (naturals.to_semiring_unique_alt _ _). Qed. Lemma int_abs_sig_alt x : (sig (fun n : N => f n = x)) |_| (sig (fun n : N => f n = - x)). Proof. destruct (int_abs_spec x) as [[??]|[??]]; eauto. Qed. Lemma int_abs_nat n : int_abs Z N (f n) = n. Proof. apply (injective f). destruct (int_abs_spec (f n)) as [[? E]|[? E]];trivial. apply naturals.negate_to_ring. rewrite E, involutive. trivial. Qed. Lemma int_abs_negate_nat n : int_abs Z N (-f n) = n. Proof. apply (injective f). destruct (int_abs_spec (-f n)) as [[? E]|[? E]]. - symmetry. apply naturals.negate_to_ring. apply symmetry; trivial. - rewrite involutive in E. trivial. Qed. Lemma int_abs_negate x : int_abs Z N (-x) = int_abs Z N x. Proof. destruct (int_abs_spec x) as [[_ E]|[_ E]]. - path_via (int_abs Z N (- f (int_abs Z N x))). apply int_abs_negate_nat. - rewrite <-E. apply int_abs_nat. Qed. Lemma int_abs_0_alt x : int_abs Z N x = 0 <-> x = 0. Proof. split; intros E1. - destruct (int_abs_spec x) as [[_ E2]|[_ E2]];[|apply flip_negate_0]; rewrite <-E2, E1, (preserves_0 (f:=f)); trivial. - rewrite E1, <-(preserves_0 (f:=f)). apply int_abs_nat. Qed. Lemma int_abs_ne_0 x : int_abs Z N x <> 0 <-> x <> 0. Proof. destruct (int_abs_0_alt x). split;intros E1 E2;auto. Qed. Lemma int_abs_0 : int_abs Z N 0 = 0. Proof. apply int_abs_0_alt;trivial. Qed. Lemma int_abs_nonneg x : 0 ≤ x -> f (int_abs Z N x) = x. Proof. intros E1. destruct (int_abs_spec x) as [[n E2]|[n E2]];trivial. assert (Hrw : x = 0). - apply (antisymmetry (<=));trivial. - rewrite Hrw,int_abs_0, (preserves_0 (f:=f)). trivial. Qed. Lemma int_abs_nonpos x : x ≤ 0 -> f (int_abs Z N x) = -x. Proof. intros E. rewrite <-int_abs_negate, int_abs_nonneg; auto. apply flip_nonpos_negate. trivial. Qed. Lemma int_abs_1 : int_abs Z N 1 = 1. Proof. apply (injective f). rewrite (preserves_1 (f:=f)). apply int_abs_nonneg; solve_propholds. Qed. Lemma int_abs_nonneg_plus x y : 0 ≤ x -> 0 ≤ y -> int_abs Z N (x + y) = int_abs Z N x + int_abs Z N y. Proof. intros. apply (injective f). rewrite (preserves_plus (f:=f)), !int_abs_nonneg;auto. apply nonneg_plus_compat;trivial. Qed. Lemma int_abs_mult x y : int_abs Z N (x * y) = int_abs Z N x * int_abs Z N y. Proof. apply (injective f). rewrite (preserves_mult (f:=f)). destruct (int_abs_spec x) as [[? Ex]|[? Ex]], (int_abs_spec y) as [[? Ey]|[? Ey]]; rewrite Ex, Ey. - rewrite int_abs_nonneg;trivial. apply nonneg_mult_compat;trivial. - rewrite int_abs_nonpos. + apply negate_mult_distr_r. + apply nonneg_nonpos_mult;trivial. - rewrite int_abs_nonpos. + apply negate_mult_distr_l. + apply nonpos_nonneg_mult;trivial. - rewrite int_abs_nonneg. + symmetry;apply negate_mult_negate. + apply nonpos_mult;trivial. Qed. End contents. Coq-HoTT-9.0/theories/Classes/theory/integers.v000066400000000000000000000134451474641544500215050ustar00rootroot00000000000000(* General results about arbitrary integer implementations. *) Require Import HoTT.Basics.Decidable. Require Import HoTT.Classes.theory.nat_distance HoTT.Classes.implementations.peano_naturals HoTT.Classes.interfaces.naturals HoTT.Classes.interfaces.orders HoTT.Classes.implementations.natpair_integers HoTT.Classes.theory.rings HoTT.Classes.isomorphisms.rings. Require Export HoTT.Classes.interfaces.integers. Import NatPair.Instances. Generalizable Variables N Z R f. Lemma to_ring_unique `{Integers Z} `{IsCRing R} (f: Z -> R) {h: IsSemiRingPreserving f} x : f x = integers_to_ring Z R x. Proof. symmetry. apply integers_initial. Qed. Lemma to_ring_unique_alt `{Integers Z} `{IsCRing R} (f g: Z -> R) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x : f x = g x. Proof. rewrite (to_ring_unique f), (to_ring_unique g);reflexivity. Qed. Lemma to_ring_involutive Z `{Integers Z} Z2 `{Integers Z2} x : integers_to_ring Z2 Z (integers_to_ring Z Z2 x) = x. Proof. change (Compose (integers_to_ring Z2 Z) (integers_to_ring Z Z2) x = id x). apply to_ring_unique_alt;apply _. Qed. Lemma morphisms_involutive `{Integers Z} `{IsCRing R} (f: R -> Z) (g: Z -> R) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x : f (g x) = x. Proof. exact (to_ring_unique_alt (f ∘ g) id _). Qed. Lemma to_ring_twice `{Integers Z} `{IsCRing R1} `{IsCRing R2} (f : R1 -> R2) (g : Z -> R1) (h : Z -> R2) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} `{!IsSemiRingPreserving h} x : f (g x) = h x. Proof. exact (to_ring_unique_alt (f ∘ g) h _). Qed. Lemma to_ring_self `{Integers Z} (f : Z -> Z) `{!IsSemiRingPreserving f} x : f x = x. Proof. exact (to_ring_unique_alt f id _). Qed. (* A ring morphism from integers to another ring is injective if there's an injection in the other direction: *) Lemma to_ring_injective `{Integers Z} `{IsCRing R} (f: R -> Z) (g: Z -> R) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} : IsInjective g. Proof. intros x y E. change (id x = id y). rewrite <-(to_ring_twice f g id x), <-(to_ring_twice f g id y). apply ap,E. Qed. Global Instance integers_to_integers_injective `{Integers Z} `{Integers Z2} (f: Z -> Z2) `{!IsSemiRingPreserving f} : IsInjective f. Proof. exact (to_ring_injective (integers_to_ring Z2 Z) _). Qed. Global Instance naturals_to_integers_injective `{Funext} `{Univalence} `{Integers@{i i i i i i i i} Z} `{Naturals@{i i i i i i i i} N} (f: N -> Z) `{!IsSemiRingPreserving f} : IsInjective f. Proof. intros x y E. apply (injective (cast N (NatPair.Z N))). rewrite <-2!(naturals.to_semiring_twice (integers_to_ring Z (NatPair.Z N)) f (cast N (NatPair.Z N))). apply ap,E. Qed. Section retract_is_int. Context `{Funext}. Context `{Integers Z} `{IsCRing Z2} {Z2ap : Apart Z2} {Z2le Z2lt} `{!FullPseudoSemiRingOrder (A:=Z2) Z2le Z2lt}. Context (f : Z -> Z2) `{!IsEquiv f} `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving (f^-1)}. (* If we make this an instance, then instance resolution will often loop *) Definition retract_is_int_to_ring : IntegersToRing Z2 := fun Z2 _ _ _ _ _ _ => integers_to_ring Z Z2 ∘ f^-1. Section for_another_ring. Context `{IsCRing R}. Instance: IsSemiRingPreserving (integers_to_ring Z R ∘ f^-1) := {}. Context (h : Z2 -> R) `{!IsSemiRingPreserving h}. Lemma same_morphism x : (integers_to_ring Z R ∘ f^-1) x = h x. Proof. transitivity ((h ∘ (f ∘ f^-1)) x). - symmetry. apply (to_ring_unique (h ∘ f)). - unfold Compose. apply ap. apply eisretr. Qed. End for_another_ring. (* If we make this an instance, then instance resolution will often loop *) Lemma retract_is_int: Integers Z2 (U:=retract_is_int_to_ring). Proof. split;try apply _. - unfold integers_to_ring, retract_is_int_to_ring. apply _. - intros;apply same_morphism;apply _. Qed. End retract_is_int. Section int_to_int_iso. Context `{Integers Z1} `{Integers Z2}. Global Instance int_to_int_equiv : IsEquiv (integers_to_ring Z1 Z2). Proof. apply Equivalences.isequiv_adjointify with (integers_to_ring Z2 Z1); red;apply (to_ring_involutive _ _). Defined. End int_to_int_iso. Section contents. Universe U. Context `{Funext} `{Univalence}. Context (Z : Type@{U}) `{Integers@{U U U U U U U U} Z}. Lemma from_int_stmt (Z':Type@{U}) `{Integers@{U U U U U U U U} Z'} : forall (P : Rings.Operations -> Type), P (Rings.BuildOperations Z') -> P (Rings.BuildOperations Z). Proof. apply Rings.iso_leibnitz with (integers_to_ring Z' Z);apply _. Qed. Global Instance int_dec : DecidablePaths Z | 10. Proof. apply decidablepaths_equiv with (NatPair.Z nat) (integers_to_ring (NatPair.Z nat) Z);apply _. Qed. Global Instance slow_int_abs `{Naturals N} : IntAbs Z N | 10. Proof. intros x. destruct (int_abs_sig (NatPair.Z N) N (integers_to_ring Z (NatPair.Z N) x)) as [[n E]|[n E]];[left|right];exists n. - apply (injective (integers_to_ring Z (NatPair.Z N))). rewrite <-E. apply (naturals.to_semiring_twice _ _ _). - apply (injective (integers_to_ring Z (NatPair.Z N))). rewrite preserves_negate, <-E. apply (naturals.to_semiring_twice _ _ _). Qed. Instance int_nontrivial : PropHolds ((1:Z) <>0). Proof. intros E. apply (rings.is_ne_0 (1:nat)). apply (injective (naturals_to_semiring nat Z)). exact E. (* because [naturals_to_semiring nat] plays nice with 1 *) Qed. Global Instance int_zero_product : ZeroProduct Z. Proof. intros x y E. destruct (zero_product (integers_to_ring Z (NatPair.Z nat) x) (integers_to_ring Z (NatPair.Z nat) y)). - rewrite <-(rings.preserves_mult (A:=Z)), E, (rings.preserves_0 (A:=Z)). trivial. - left. apply (injective (integers_to_ring Z (NatPair.Z nat))). rewrite rings.preserves_0. trivial. - right. apply (injective (integers_to_ring Z (NatPair.Z nat))). rewrite rings.preserves_0. trivial. Qed. Global Instance int_integral_domain : IsIntegralDomain Z := {}. End contents. Coq-HoTT-9.0/theories/Classes/theory/lattices.v000066400000000000000000000163051474641544500214730ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.theory.groups. Generalizable Variables A B C K L f. Global Instance bounded_sl_is_sl `{IsBoundedSemiLattice L} : IsSemiLattice L. Proof. repeat (split; try apply _). Qed. Global Instance bounded_join_sl_is_join_sl `{IsBoundedJoinSemiLattice L} : IsJoinSemiLattice L. Proof. repeat (split; try apply _). Qed. Global Instance bounded_meet_sl_is_meet_sl `{IsBoundedMeetSemiLattice L} : IsMeetSemiLattice L. Proof. repeat (split; try apply _). Qed. Global Instance bounded_lattice_is_lattice `{IsBoundedLattice L} : IsLattice L. Proof. repeat split; apply _. Qed. Global Instance bounded_sl_mor_is_sl_mor `{H : IsBoundedJoinPreserving A B f} : IsJoinPreserving f. Proof. red;apply _. Qed. Lemma preserves_join `{IsJoinPreserving L K f} x y : f (x ⊔ y) = f x ⊔ f y. Proof. apply preserves_sg_op. Qed. Lemma preserves_bottom `{IsBoundedJoinPreserving L K f} : f ⊥ = ⊥. Proof. apply preserves_mon_unit. Qed. Lemma preserves_meet `{IsMeetPreserving L K f} x y : f (x ⊓ y) = f x ⊓ f y. Proof. apply preserves_sg_op. Qed. Section bounded_join_sl_props. Context `{IsBoundedJoinSemiLattice L}. Instance join_bottom_l: LeftIdentity (⊔) ⊥ := _. Instance join_bottom_r: RightIdentity (⊔) ⊥ := _. End bounded_join_sl_props. Section lattice_props. Context `{IsLattice L}. Definition meet_join_absorption x y : x ⊓ (x ⊔ y) = x := absorption x y. Definition join_meet_absorption x y : x ⊔ (x ⊓ y) = x := absorption x y. End lattice_props. Section distributive_lattice_props. Context `{IsDistributiveLattice L}. Instance join_meet_distr_l: LeftDistribute (⊔) (⊓). Proof. exact (join_meet_distr_l _). Qed. Global Instance join_meet_distr_r: RightDistribute (⊔) (⊓). Proof. intros x y z. rewrite !(commutativity _ z). apply distribute_l. Qed. Global Instance meet_join_distr_l: LeftDistribute (⊓) (⊔). Proof. intros x y z. rewrite (simple_distribute_l (f:=join)). rewrite (simple_distribute_r (f:=join)). rewrite (idempotency (⊔) x). rewrite (commutativity (f:=join) y x), meet_join_absorption. path_via ((x ⊓ (x ⊔ z)) ⊓ (y ⊔ z)). - rewrite (meet_join_absorption x z). reflexivity. - rewrite <-simple_associativity. rewrite <-distribute_r. reflexivity. Qed. Global Instance meet_join_distr_r: RightDistribute (⊓) (⊔). Proof. intros x y z. rewrite !(commutativity _ z). apply distribute_l. Qed. Lemma distribute_alt x y z : (x ⊓ y) ⊔ (x ⊓ z) ⊔ (y ⊓ z) = (x ⊔ y) ⊓ (x ⊔ z) ⊓ (y ⊔ z). Proof. rewrite (distribute_r x y (x ⊓ z)), join_meet_absorption. rewrite (distribute_r _ _ (y ⊓ z)). rewrite (distribute_l x y z). rewrite (commutativity y (x ⊓ z)), <-(simple_associativity _ y). rewrite join_meet_absorption. rewrite (distribute_r x z y). rewrite (commutativity (f:=join) z y). rewrite (commutativity (x ⊔ y) (x ⊔ z)). rewrite simple_associativity, <-(simple_associativity (x ⊔ z)). rewrite (idempotency _ _). rewrite (commutativity (x ⊔ z) (x ⊔ y)). reflexivity. Qed. End distributive_lattice_props. Section lower_bounded_lattice. Context `{IsLattice L} `{Bottom L} `{!IsBoundedJoinSemiLattice L}. Global Instance meet_bottom_l: LeftAbsorb (⊓) ⊥. Proof. intros x. rewrite <-(join_bottom_l x), absorption. trivial. Qed. Global Instance meet_bottom_r: RightAbsorb (⊓) ⊥. Proof. intros x. rewrite (commutativity (f:=meet)), left_absorb. trivial. Qed. End lower_bounded_lattice. Section from_another_sl. Local Open Scope mc_add_scope. Context `{IsSemiLattice A} `{IsHSet B} `{Bop : SgOp B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x + y) = f x + f y). Lemma projected_sl: IsSemiLattice B. Proof. split. - apply (projected_com_sg f). assumption. - repeat intro; apply (injective f). rewrite !op_correct, (idempotency (+) _). reflexivity. Qed. End from_another_sl. Section from_another_bounded_sl. Local Open Scope mc_add_scope. Context `{IsBoundedSemiLattice A} `{IsHSet B} `{Bop : SgOp B} `{Bunit : MonUnit B} (f : B -> A) `{!IsInjective f} (op_correct : forall x y, f (x + y) = f x + f y) (unit_correct : f mon_unit = mon_unit). Lemma projected_bounded_sl: IsBoundedSemiLattice B. Proof. split. - apply (projected_com_monoid f);trivial. - repeat intro; apply (injective f). rewrite op_correct, (idempotency (+) _). trivial. Qed. End from_another_bounded_sl. Global Instance id_join_sl_morphism `{IsJoinSemiLattice A} : IsJoinPreserving (@id A) := {}. Global Instance id_meet_sl_morphism `{IsMeetSemiLattice A} : IsMeetPreserving (@id A) := {}. Global Instance id_bounded_join_sl_morphism `{IsBoundedJoinSemiLattice A} : IsBoundedJoinPreserving (@id A) := {}. Global Instance id_lattice_morphism `{IsLattice A} : IsLatticePreserving (@id A) := {}. Section morphism_composition. Context `{Join A} `{Meet A} `{Bottom A} `{Join B} `{Meet B} `{Bottom B} `{Join C} `{Meet C} `{Bottom C} (f : A -> B) (g : B -> C). Instance compose_join_sl_morphism: IsJoinPreserving f -> IsJoinPreserving g -> IsJoinPreserving (g ∘ f). Proof. red; apply _. Qed. Instance compose_meet_sl_morphism: IsMeetPreserving f -> IsMeetPreserving g -> IsMeetPreserving (g ∘ f). Proof. red;apply _. Qed. Instance compose_bounded_join_sl_morphism: IsBoundedJoinPreserving f -> IsBoundedJoinPreserving g -> IsBoundedJoinPreserving (g ∘ f). Proof. red; apply _. Qed. Instance compose_lattice_morphism: IsLatticePreserving f -> IsLatticePreserving g -> IsLatticePreserving (g ∘ f). Proof. split; apply _. Qed. Instance invert_join_sl_morphism: forall `{!IsEquiv f}, IsJoinPreserving f -> IsJoinPreserving (f^-1). Proof. red; apply _. Qed. Instance invert_meet_sl_morphism: forall `{!IsEquiv f}, IsMeetPreserving f -> IsMeetPreserving (f^-1). Proof. red; apply _. Qed. Instance invert_bounded_join_sl_morphism: forall `{!IsEquiv f}, IsBoundedJoinPreserving f -> IsBoundedJoinPreserving (f^-1). Proof. red; apply _. Qed. Instance invert_lattice_morphism: forall `{!IsEquiv f}, IsLatticePreserving f -> IsLatticePreserving (f^-1). Proof. split; apply _. Qed. End morphism_composition. #[export] Hint Extern 4 (IsJoinPreserving (_ ∘ _)) => class_apply @compose_join_sl_morphism : typeclass_instances. #[export] Hint Extern 4 (IsMeetPreserving (_ ∘ _)) => class_apply @compose_meet_sl_morphism : typeclass_instances. #[export] Hint Extern 4 (IsBoundedJoinPreserving (_ ∘ _)) => class_apply @compose_bounded_join_sl_morphism : typeclass_instances. #[export] Hint Extern 4 (IsLatticePreserving (_ ∘ _)) => class_apply @compose_lattice_morphism : typeclass_instances. #[export] Hint Extern 4 (IsJoinPreserving (_^-1)) => class_apply @invert_join_sl_morphism : typeclass_instances. #[export] Hint Extern 4 (IsMeetPreserving (_^-1)) => class_apply @invert_meet_sl_morphism : typeclass_instances. #[export] Hint Extern 4 (IsBoundedJoinPreserving (_^-1)) => class_apply @invert_bounded_join_sl_morphism : typeclass_instances. #[export] Hint Extern 4 (IsLatticePreserving (_^-1)) => class_apply @invert_lattice_morphism : typeclass_instances. Coq-HoTT-9.0/theories/Classes/theory/nat_distance.v000066400000000000000000000046461474641544500223240ustar00rootroot00000000000000Require Import HoTT.Classes.orders.naturals HoTT.Classes.implementations.peano_naturals. Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.orders HoTT.Classes.theory.naturals. Generalizable Variables N. Section contents. Context `{Funext} `{Univalence}. Context `{Naturals N}. (* Add Ring N : (rings.stdlib_semiring_theory N). *) (* NatDistance instances are all equivalent, because their behavior is fully determined by the specification. *) Lemma nat_distance_unique {a b : NatDistance N} : forall x y, @nat_distance _ _ a x y = @nat_distance _ _ b x y. Proof. intros. unfold nat_distance. destruct (@nat_distance_sig _ _ a x y) as [[z1 E1]|[z1 E1]], (@nat_distance_sig _ _ b x y) as [[z2 E2]|[z2 E2]];simpl. - apply (left_cancellation plus x). path_via y. - rewrite <-(rings.plus_0_r y),<-E2,<-rings.plus_assoc in E1. apply (left_cancellation plus y) in E1. apply naturals.zero_sum in E1. destruct E1;path_via 0. - rewrite <-(rings.plus_0_r x),<-E2,<-rings.plus_assoc in E1. apply (left_cancellation plus x) in E1. apply naturals.zero_sum in E1. destruct E1;path_via 0. - apply (left_cancellation plus y);path_via x. Qed. End contents. (* An existing instance of [CutMinus] allows to create an instance of [NatDistance] *) Global Instance natdistance_cut_minus `{Naturals N} `{!TrivialApart N} {cm} `{!CutMinusSpec N cm} `{forall x y, Decidable (x ≤ y)} : NatDistance N. Proof. red. intros. destruct (decide_rel (<=) x y) as [E|E]. - left. exists (y ∸ x). rewrite rings.plus_comm;apply cut_minus_le;trivial. - right. exists (x ∸ y). rewrite rings.plus_comm;apply cut_minus_le, orders.le_flip;trivial. Defined. (* Using the preceding instance we can make an instance for arbitrary models of the naturals by translation into [nat] on which we already have a [CutMinus] instance. *) Global Instance natdistance_default `{Naturals N} : NatDistance N | 10. Proof. intros x y. destruct (nat_distance_sig (naturals_to_semiring N nat x) (naturals_to_semiring N nat y)) as [[n E]|[n E]]. - left. exists (naturals_to_semiring nat N n). rewrite <-(naturals.to_semiring_involutive N nat y), <-E. rewrite (rings.preserves_plus (A:=nat)), (naturals.to_semiring_involutive _ _). split. - right. exists (naturals_to_semiring nat N n). rewrite <-(naturals.to_semiring_involutive N nat x), <-E. rewrite (rings.preserves_plus (A:=nat)), (naturals.to_semiring_involutive _ _). split. Defined. Coq-HoTT-9.0/theories/Classes/theory/naturals.v000066400000000000000000000167521474641544500215220ustar00rootroot00000000000000Require Import HoTT.Basics.Decidable. Require Import HoTT.Classes.interfaces.orders HoTT.Classes.implementations.peano_naturals HoTT.Classes.theory.rings HoTT.Classes.isomorphisms.rings. Require Export HoTT.Classes.interfaces.naturals. Generalizable Variables A N R SR f. (* This grabs a coercion. *) Import SemiRings. Lemma to_semiring_unique `{Naturals N} `{IsSemiCRing SR} (f: N -> SR) `{!IsSemiRingPreserving f} x : f x = naturals_to_semiring N SR x. Proof. symmetry. apply naturals_initial. Qed. Lemma to_semiring_unique_alt `{Naturals N} `{IsSemiCRing SR} (f g: N -> SR) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x : f x = g x. Proof. rewrite (to_semiring_unique f), (to_semiring_unique g);reflexivity. Qed. Lemma to_semiring_involutive N `{Naturals N} N2 `{Naturals N2} x : naturals_to_semiring N2 N (naturals_to_semiring N N2 x) = x. Proof. change (Compose (naturals_to_semiring N2 N) (naturals_to_semiring N N2) x = id x). apply to_semiring_unique_alt;apply _. Qed. Lemma morphisms_involutive `{Naturals N} `{IsSemiCRing R} (f : R -> N) (g : N -> R) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x : f (g x) = x. Proof. exact (to_semiring_unique_alt (f ∘ g) id _). Qed. Lemma to_semiring_twice `{Naturals N} `{IsSemiCRing R1} `{IsSemiCRing R2} (f : R1 -> R2) (g : N -> R1) (h : N -> R2) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} `{!IsSemiRingPreserving h} x : f (g x) = h x. Proof. exact (to_semiring_unique_alt (f ∘ g) h _). Qed. Lemma to_semiring_self `{Naturals N} (f : N -> N) `{!IsSemiRingPreserving f} x : f x = x. Proof. exact (to_semiring_unique_alt f id _). Qed. Lemma to_semiring_injective `{Naturals N} `{IsSemiCRing A} (f: A -> N) (g: N -> A) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} : IsInjective g. Proof. intros x y E. change (id x = id y). rewrite <-(to_semiring_twice f g id x), <-(to_semiring_twice f g id y). apply ap,E. Qed. Global Instance naturals_to_naturals_injective `{Naturals N} `{Naturals N2} (f: N -> N2) `{!IsSemiRingPreserving f} : IsInjective f | 15. Proof. exact (to_semiring_injective (naturals_to_semiring N2 N) _). Qed. Section retract_is_nat. Context `{Naturals N} `{IsSemiCRing SR} {SRap : Apart SR} {SRle SRlt} `{!FullPseudoSemiRingOrder (A:=SR) SRle SRlt}. Context (f : N -> SR) `{!IsEquiv f} `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving (f^-1)}. (* If we make this an instance, instance resolution will loop *) Definition retract_is_nat_to_sr : NaturalsToSemiRing SR := fun R _ _ _ _ _ => naturals_to_semiring N R ∘ f^-1. Section for_another_semirings. Context `{IsSemiCRing R}. Instance: IsSemiRingPreserving (naturals_to_semiring N R ∘ f^-1) := {}. Context (h : SR -> R) `{!IsSemiRingPreserving h}. Lemma same_morphism x : (naturals_to_semiring N R ∘ f^-1) x = h x. Proof. transitivity ((h ∘ (f ∘ f^-1)) x). - symmetry. apply (to_semiring_unique (h ∘ f)). - unfold Compose. apply ap, eisretr. Qed. End for_another_semirings. (* If we make this an instance, instance resolution will loop *) Lemma retract_is_nat : Naturals SR (U:=retract_is_nat_to_sr). Proof. split;try apply _. - unfold naturals_to_semiring, retract_is_nat_to_sr. apply _. - intros;apply same_morphism;apply _. Qed. End retract_is_nat. Section nat_to_nat_iso. Context `{Naturals N1} `{Naturals N2}. Global Instance nat_to_nat_equiv : IsEquiv (naturals_to_semiring N1 N2). Proof. apply Equivalences.isequiv_adjointify with (naturals_to_semiring N2 N1); red;apply (to_semiring_involutive _ _). Defined. End nat_to_nat_iso. Section contents. Universe U. (* {U U} because we do forall n : N, {id} n = nat_to_sr N N n *) Context `{Funext} `{Univalence} {N : Type@{U} } `{Naturals@{U U U U U U U U} N}. Lemma from_nat_stmt (N':Type@{U}) `{Naturals@{U U U U U U U U} N'} : forall (P : SemiRings.Operations -> Type), P (SemiRings.BuildOperations N') -> P (SemiRings.BuildOperations N). Proof. apply SemiRings.iso_leibnitz with (naturals_to_semiring N' N);apply _. Qed. Section borrowed_from_nat. Lemma induction : forall (P: N -> Type), P 0 -> (forall n, P n -> P (1 + n)) -> forall n, P n. Proof. pose (Q := fun s : SemiRings.Operations => forall P : s -> Type, P 0 -> (forall n, P n -> P (1 + n)) -> forall n, P n). change (Q (SemiRings.BuildOperations N)). apply (from_nat_stmt nat). unfold Q;clear Q. simpl. exact nat_induction. Qed. Lemma case : forall x : N, x = 0 |_| exists y : N, (x = 1 + y). Proof. refine (from_nat_stmt nat (fun s => forall x : s, x = 0 |_| exists y : s, x = 1 + y) _). simpl. intros [|x];eauto. Qed. Global Instance: Biinduction N. Proof. hnf. intros P E0 ES. apply induction;trivial. apply ES. Qed. Global Instance nat_plus_cancel_l : forall z : N, LeftCancellation (+) z. Proof. refine (from_nat_stmt@{i U} nat (fun s => forall z : s, LeftCancellation plus z) _). simpl. first [exact nat_plus_cancel_l@{U i}|exact nat_plus_cancel_l@{U}]. Qed. Global Instance: forall z : N, RightCancellation (+) z. Proof. intro. apply (right_cancel_from_left (+)). Qed. Global Instance: forall z : N, PropHolds (z <> 0) -> LeftCancellation (.*.) z. Proof. refine (from_nat_stmt nat (fun s => forall z : s, PropHolds (z <> 0) -> LeftCancellation mult z) _). simpl. apply nat_mult_cancel_l. Qed. Global Instance: forall z : N, PropHolds (z <> 0) -> RightCancellation (.*.) z. Proof. intros ? ?. apply (right_cancel_from_left (.*.)). Qed. Instance nat_nontrivial: PropHolds ((1:N) <> 0). Proof. refine (from_nat_stmt nat (fun s => PropHolds ((1:s) <> 0)) _). apply _. Qed. Instance nat_nontrivial_apart `{Apart N} `{!TrivialApart N} : PropHolds ((1:N) ≶ 0). Proof. apply apartness.ne_apart. solve_propholds. Qed. Lemma zero_sum : forall (x y : N), x + y = 0 -> x = 0 /\ y = 0. Proof. refine (from_nat_stmt nat (fun s => forall x y : s, x + y = 0 -> x = 0 /\ y = 0) _). simpl. apply plus_eq_zero. Qed. Lemma one_sum : forall (x y : N), x + y = 1 -> (x = 1 /\ y = 0) |_| (x = 0 /\ y = 1). Proof. refine (from_nat_stmt nat (fun s => forall (x y : s), x + y = 1 -> (x = 1 /\ y = 0) |_| (x = 0 /\ y = 1)) _). simpl. intros [|x] [|y];auto. - intros E. rewrite add_S_l,add_0_r in E. apply S_inj in E. rewrite E. auto. - intros E. rewrite add_S_l,add_S_r in E. apply S_inj in E. destruct (S_neq_0 _ E). Qed. Global Instance: ZeroProduct N. Proof. refine (from_nat_stmt nat (fun s => ZeroProduct s) _). simpl. red. apply mult_eq_zero. Qed. End borrowed_from_nat. Lemma nat_1_plus_ne_0 x : 1 + x <> 0. Proof. intro E. destruct (zero_sum 1 x E). apply nat_nontrivial. trivial. Qed. Global Instance slow_naturals_dec : DecidablePaths N. Proof. apply decidablepaths_equiv with nat (naturals_to_semiring nat N);apply _. Qed. Section with_a_ring. Context `{IsCRing R} `{!IsSemiRingPreserving (f : N -> R)} `{!IsInjective f}. Lemma to_ring_zero_sum x y : -f x = f y -> x = 0 /\ y = 0. Proof. intros E. apply zero_sum, (injective f). rewrite rings.preserves_0, rings.preserves_plus, <-E. apply plus_negate_r. Qed. Lemma negate_to_ring x y : -f x = f y -> f x = f y. Proof. intros E. destruct (to_ring_zero_sum x y E) as [E2 E3]. rewrite E2, E3. reflexivity. Qed. End with_a_ring. End contents. (* Due to bug #2528 *) #[export] Hint Extern 6 (PropHolds (1 <> 0)) => eapply @nat_nontrivial : typeclass_instances. #[export] Hint Extern 6 (PropHolds (1 ≶ 0)) => eapply @nat_nontrivial_apart : typeclass_instances. Coq-HoTT-9.0/theories/Classes/theory/premetric.v000066400000000000000000000767321474641544500216670ustar00rootroot00000000000000Require Import HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.rationals HoTT.Classes.interfaces.orders HoTT.Classes.implementations.peano_naturals HoTT.Classes.implementations.natpair_integers HoTT.Classes.theory.groups HoTT.Classes.theory.integers HoTT.Classes.theory.dec_fields HoTT.Classes.orders.dec_fields HoTT.Classes.orders.sum HoTT.Classes.theory.rationals HoTT.Classes.orders.lattices HoTT.Classes.implementations.assume_rationals HoTT.Classes.tactics.ring_quote HoTT.Classes.tactics.ring_tac. Import NatPair.Instances. Import Quoting.Instances. Generalizable Variables A B. Local Set Universe Minimization ToSet. Class Closeness@{i} (A : Type@{i}) := close : Q+ -> Relation@{i i} A. Global Instance Q_close@{} : Closeness Q := fun e q r => - ' e < q - r < ' e. Class Separated A `{Closeness A} := separated : forall x y, (forall e, close e x y) -> x = y :> A. Class Triangular A `{Closeness A} := triangular : forall u v w e d, close e u v -> close d v w -> close (e+d) u w. Class Rounded@{i j} (A:Type@{i}) `{Closeness A} := rounded : forall e u v, iff@{i j j} (close e u v) (merely@{j} (sig@{UQ j} (fun d => sig@{UQ j} (fun d' => e = d + d' /\ close d u v)))). Class PreMetric@{i j} (A:Type@{i}) {Aclose : Closeness A} := { premetric_prop : forall e, is_mere_relation A (close e) ; premetric_refl : forall e, Reflexive (close (A:=A) e) ; premetric_symm : forall e, Symmetric (close (A:=A) e) ; premetric_separated : Separated A ; premetric_triangular : Triangular A ; premetric_rounded : Rounded@{i j} A }. #[export] Existing Instances premetric_prop premetric_refl premetric_symm premetric_separated premetric_triangular premetric_rounded. Global Instance premetric_hset@{i j} `{Funext} {A:Type@{i} } `{PreMetric@{i j} A} : IsHSet A. Proof. apply (@HSet.ishset_hrel_subpaths@{j i j} _ (fun x y => forall e, close e x y)). - intros x;reflexivity. - apply _. - apply separated. Qed. Record Approximation@{i} (A:Type@{i}) {Aclose : Closeness A} := { approximate :> Q+ -> A ; approx_equiv : forall d e, close (d+e) (approximate d) (approximate e) }. Lemma approx_eq `{Funext} `{Closeness A} `{forall e x y, IsHProp (close e x y)} : forall x y : Approximation A, approximate _ x = approximate _ y -> x = y. Proof. intros [x Ex] [y Ey];simpl;intros E. destruct E. apply ap. apply path_ishprop. Qed. Definition IsLimit@{i} {A:Type@{i} } {Aclose : Closeness A} (x : Approximation A) (l : A) := forall e d : Q+, close (e+d) (x d) l. Class Lim@{i} (A:Type@{i}) {Aclose : Closeness A} := lim : Approximation A -> A. Class CauchyComplete@{i} (A:Type@{i}) {Aclose : Closeness A} {Alim : Lim A} := cauchy_complete : forall x : Approximation A, IsLimit x (lim x). Section contents. Context {funext : Funext} {univalence : Univalence}. Lemma rounded_plus `{Rounded A} : forall d d' u v, close d u v -> close (d+d') u v. Proof. intros d d' u v xi;apply rounded. apply tr;exists d,d';auto. Qed. Lemma rounded_le' `{Rounded A} : forall e u v, close e u v -> forall d, ' e <= ' d -> close d u v. Proof. intros e u v xi d E. apply le_equiv_lt in E. destruct E as [E|E]. - apply pos_eq in E. rewrite <-E;trivial. - pose proof (pos_eq _ (_ + _) (Qpos_diff_pr _ _ E)) as E'. rewrite E'. apply rounded_plus. trivial. Qed. (* Coq pre 8.8 produces phantom universes, see coq/coq#6483 **) Definition rounded_le@{i j} := ltac:(first [exact @rounded_le'@{j i Ularge}| exact @rounded_le'@{j i Ularge j}| exact @rounded_le'@{i j}]). Arguments rounded_le {A _ _} e u v _ d _. Section close_prod. Universe UA UB i. Context (A:Type@{UA}) (B:Type@{UB}) `{Closeness A} `{Closeness B} `{forall e, is_mere_relation A (close e)} `{forall e, is_mere_relation B (close e)}. Global Instance close_prod@{} : Closeness@{i} (A /\ B) := fun e x y => close e (fst x) (fst y) /\ close e (snd x) (snd y). Global Instance close_prod_refl@{} `{forall e, Reflexive (close (A:=A) e)} `{forall e, Reflexive (close (A:=B) e)} : forall e, Reflexive (close (A:=A /\ B) e). Proof. intros e;split;reflexivity. Qed. Global Instance close_prod_symm@{} `{forall e, Symmetric (close (A:=A) e)} `{forall e, Symmetric (close (A:=B) e)} : forall e, Symmetric (close (A:=A /\ B) e). Proof. intros e u v xi;split;symmetry;apply xi. Qed. Global Instance close_prod_separated@{} `{!Separated A} `{!Separated B} : Separated (A /\ B). Proof. intros x y E. apply Prod.path_prod;apply separated;intros;apply E. Qed. Global Instance close_prod_triangular@{} `{!Triangular A} `{!Triangular B} : Triangular (A /\ B). Proof. intros u v w e d E1 E2;split;(eapply triangular;[apply E1|apply E2]). Qed. Lemma close_prod_rounded' `{!Rounded A} `{!Rounded B} : Rounded (A /\ B). Proof. intros e u v. split. - intros [E0 E0'];apply rounded in E0;apply rounded in E0'. revert E0;apply (Trunc_ind _);intros [d1 [d1' [E1 E2]]]. revert E0';apply (Trunc_ind _);intros [d2 [d2' [E3 E4]]]. apply tr;exists (join d1 d2), (meet d1' d2');split. + rewrite E1. apply Qpos_sum_eq_join_meet. rewrite <-E1;trivial. + split. * apply rounded_le with d1;trivial. apply join_ub_l. * apply rounded_le with d2;trivial. apply join_ub_r. - apply (Trunc_ind _);intros [d [d' [E1 E2]]]. rewrite E1;split;apply rounded_plus,E2. Qed. (* Coq pre 8.8 produces phantom universes, see coq/coq#6483 **) Definition close_prod_rounded@{j} := ltac:(first [exact @close_prod_rounded'@{j j j j j}| exact @close_prod_rounded'@{j j}| exact @close_prod_rounded'@{j j j}]). Arguments close_prod_rounded {_ _} _ _ _. Global Existing Instance close_prod_rounded. Lemma prod_premetric@{j} `{!PreMetric@{UA j} A} `{!PreMetric@{UB j} B} : PreMetric@{i j} (A /\ B). Proof. split;try apply _. Qed. Global Existing Instance prod_premetric. Context {Alim : Lim A} {Blim : Lim B}. Global Instance prod_lim@{} : Lim (A /\ B). Proof. intros xy. split;apply lim; [exists (fun e => fst (xy e))|exists (fun e => snd (xy e))];intros;apply xy. Defined. Global Instance prod_cauchy_complete `{!CauchyComplete A} `{!CauchyComplete B} : CauchyComplete (A /\ B). Proof. intros xy e d;split. - apply (cauchy_complete {| approximate := fun e0 : Q+ => fst (xy e0); approx_equiv := _ |}). - apply (cauchy_complete {| approximate := fun e0 : Q+ => snd (xy e0); approx_equiv := _ |}). Qed. End close_prod. Section close_arrow. Context {A:Type} `{Bclose : Closeness B} `{!PreMetric B}. (* Using [forall x, close e (f x) (g x)] works for closed balls, not open ones. *) Global Instance close_arrow : Closeness (A -> B) := fun e f g => merely (exists d d', e = d + d' /\ forall x, close d (f x) (g x)). Lemma close_arrow_apply : forall e (f g : A -> B), close e f g -> forall x, close e (f x) (g x). Proof. intros e f g E x;revert E;apply (Trunc_ind _);intros [d [d' [E1 E2]]]. rewrite E1;apply rounded_plus;trivial. Qed. Global Instance close_arrow_premetric : PreMetric (A -> B). Proof. split. - apply _. - intros e f;apply tr; exists (e/2), (e/2);split. + apply (pos_split2 e). + intros x;reflexivity. - intros e f g;apply (Trunc_ind _);intros [d [d' [E1 E2]]]. apply tr;exists d, d';split;trivial. intros x;symmetry;trivial. - intros f g E. apply path_forall;intros x. apply separated. intros e. apply (merely_destruct (E e)). intros [d [d' [E1 E2]]]. rewrite E1. apply rounded_plus. trivial. - intros f g h e d E1 E2. apply (merely_destruct E1);intros [d1 [d1' [E3 E4]]]. apply (merely_destruct E2);intros [d2 [d2' [E5 E6]]]. apply tr;exists (d1+d2),(d1'+d2'). split. + rewrite E3,E5. abstract (apply pos_eq; ring_tac.ring_with_nat). + intros x. apply triangular with (g x);trivial. - intros e f g. split. + apply (Trunc_ind _). intros [d [d' [E1 E2]]]. apply tr;exists (d+d'/2),(d'/2). split. * rewrite <-Qpos_plus_assoc,<-pos_split2. exact E1. * apply tr. exists d, (d'/2);split;trivial. + apply (Trunc_ind _);intros [d [d' [E1 E2]]]. apply tr;exists d,d';split;trivial. apply close_arrow_apply. trivial. Qed. Context {Blim : Lim B}. Global Instance arrow_lim : Lim (A -> B). Proof. intros f x. apply lim. exists (fun e => f e x). intros. apply close_arrow_apply. apply approx_equiv. Defined. Arguments arrow_lim _ / _. Context `{!CauchyComplete B}. Global Instance arrow_cauchy_complete : CauchyComplete (A -> B). Proof. intros f e d. unfold lim;simpl. apply tr. exists (e/2 + d), (e/2). split. + abstract (set (e' := e/2);rewrite (pos_split2 e);unfold e'; apply pos_eq;ring_tac.ring_with_nat). + intros x. set (S := {| approximate := fun e0 : Q+ => (f e0) x ; approx_equiv := _ |}). pose proof (cauchy_complete S) as E;red in E. apply E. Qed. End close_arrow. Class NonExpanding `{Closeness A} `{Closeness B} (f : A -> B) := non_expanding : forall e x y, close e x y -> close e (f x) (f y). Arguments non_expanding {A _ B _} f {_ e x y} _. Class Lipschitz `{Closeness A} `{Closeness B} (f : A -> B) (L : Q+) := lipschitz : forall e x y, close e x y -> close (L * e) (f x) (f y). Arguments lipschitz {A _ B _} f L {_ e x y} _. Class Uniform `{Closeness A} `{Closeness B} (f : A -> B) (mu : Q+ -> Q+) := uniform : forall e x y, close (mu e) x y -> close e (f x) (f y). Arguments uniform {A _ B _} f mu {_} _ _ _ _. Class Continuous@{UA UB} {A:Type@{UA} } `{Closeness A} {B:Type@{UB} } `{Closeness B} (f : A -> B) := continuous : forall u e, merely@{Ularge} (sig@{UQ Ularge} (fun d => forall v, close d u v -> close e (f u) (f v))). Arguments continuous {A _ B _} f {_} _ _. Definition BinaryDup@{i} {A : Type@{i} } : A -> A /\ A := fun x => (x, x). Definition map2 {A B C D} (f : A -> C) (g : B -> D) : A /\ B -> C /\ D := fun x => (f (fst x), g (snd x)). Section closeness. Universe UA. Context {A:Type@{UA} } `{Closeness A}. Global Instance id_nonexpanding : NonExpanding (@id A). Proof. hnf;trivial. Qed. Global Instance BinaryDup_nonexpanding@{} : NonExpanding (@BinaryDup A). Proof. intros e x y E;split;exact E. Qed. Universe UB. Context {B:Type@{UB} } `{Closeness B} (f : A -> B). Lemma nonexpanding_lipschitz' `{!NonExpanding f} : Lipschitz f 1. Proof. red. intro;rewrite left_identity;apply non_expanding,_. Qed. Definition nonexpanding_lipschitz@{} `{!NonExpanding f} : Lipschitz f 1 := ltac:(first [exact nonexpanding_lipschitz'@{Ularge}| exact nonexpanding_lipschitz'@{}]). Global Existing Instance nonexpanding_lipschitz. Lemma lipschitz_nonexpanding@{} `{!Lipschitz f 1} : NonExpanding f. Proof. red. intros e x y E;rewrite <-(left_identity e). apply (lipschitz f 1 E). Qed. Global Instance const_nonexpanding@{} `{forall e, Reflexive (close (A:=B) e)} (b : B) : NonExpanding (fun _ : A => b). Proof. hnf. intros;reflexivity. Qed. Global Instance lipschitz_const@{} `{forall e, Reflexive (close (A:=B) e)} : forall (b:B) (L:Q+), Lipschitz (fun _ : A => b) L. Proof. intros;hnf. intros e _ _ _. reflexivity. Qed. Global Instance lipschitz_uniform@{} (L:Q+) `{!Lipschitz f L} : Uniform f (fun e => e / L) | 5. Proof. intros e u v xi. rewrite <-(pos_unconjugate L e),<-Qpos_mult_assoc. apply (lipschitz f L),xi. Qed. Lemma uniform_continuous@{} mu `{!Uniform@{UA UB} f mu} : Continuous f. Proof. hnf. intros u e;apply tr;exists (mu e). apply (uniform f mu). Qed. Global Existing Instance uniform_continuous | 5. Definition lipschitz_continuous@{} (L:Q+) `{!Lipschitz f L} : Continuous f := _. Definition nonexpanding_continuous@{} `{!NonExpanding f} : Continuous f := _. End closeness. Section compositions. Universe UA. Context {A:Type@{UA} } `{Closeness A}. Universe UB. Context {B:Type@{UB} } `{Closeness B}. Universe UC. Context {C:Type@{UC} } `{Closeness C} (g : B -> C) (f : A -> B). Global Instance nonexpanding_compose@{} {Eg : NonExpanding g} {Ef : NonExpanding f} : NonExpanding (Compose g f). Proof. hnf. intros e x y xi;exact (non_expanding g (non_expanding f xi)). Qed. Global Instance lipschitz_compose@{} Lg {Eg : Lipschitz g Lg} Lf {Ef : Lipschitz f Lf} : Lipschitz (Compose g f) (Lg * Lf). Proof. intros ??? He. unfold Compose;apply Ef,Eg in He. pattern (Lg * Lf * e). eapply transport;[|exact He]. apply associativity. Qed. Lemma lipschitz_compose_nonexpanding_r' L {Eg : Lipschitz g L} {Ef : NonExpanding f} : Lipschitz (Compose g f) L. Proof. rewrite <-(left_identity L),commutativity. apply _. Qed. Global Instance lipschitz_compose_nonexpanding_r@{} L {Eg : Lipschitz g L} {Ef : NonExpanding f} : Lipschitz (Compose g f) L := ltac:(first [exact (lipschitz_compose_nonexpanding_r'@{Ularge} L)| exact (lipschitz_compose_nonexpanding_r'@{} L)]). Lemma lipschitz_compose_nonexpanding_l' L {Eg : NonExpanding g} {Ef : Lipschitz f L} : Lipschitz (Compose g f) L. Proof. rewrite <-(left_identity L). apply _. Qed. Global Instance lipschitz_compose_nonexpanding_l@{} L {Eg : NonExpanding g} {Ef : Lipschitz f L} : Lipschitz (Compose g f) L := ltac:(first [exact (lipschitz_compose_nonexpanding_l'@{Ularge} L)| exact (lipschitz_compose_nonexpanding_l'@{} L)]). Lemma uniform_compose@{} mu {Eg : Uniform g mu} mu' {Ef : Uniform f mu'} : Uniform (Compose g f) (Compose mu' mu). Proof. intros e u v xi. unfold Compose. apply (uniform g _),(uniform f _),xi. Qed. Global Existing Instance uniform_compose. Global Instance continuous_compose@{} {Eg : Continuous g} {Ef : Continuous f} : Continuous (Compose g f). Proof. intros u e. apply (merely_destruct (continuous g (f u) e)). intros [d E]. apply (merely_destruct (continuous f u d)). intros [d' E']. apply tr;exists d';intros v xi. apply E,E',xi. Qed. End compositions. Section currying. Universe UA. Context {A:Type@{UA} } `{Closeness A}. Universe UB. Context {B:Type@{UB} } `{Closeness B}. Universe UC. Context {C:Type@{UC} } `{Closeness C} `{!Triangular C}. Global Instance uncurry_lipschitz (f : A -> B -> C) L1 L2 `{!forall x, Lipschitz (f x) L1} `{!forall y, Lipschitz (fun x => f x y) L2} : Lipschitz (uncurry f) (L1 + L2). Proof. intros e [u1 u2] [v1 v2] [xi1 xi2]. simpl in xi1,xi2. simpl. assert (Hrw : (L1 + L2) * e = L1 * e + L2 * e) by abstract (apply pos_eq;ring_tac.ring_with_nat); rewrite Hrw;clear Hrw. apply (triangular _ (f u1 v2)). - apply (lipschitz _ L1). trivial. - apply (lipschitz (fun u => f u v2) L2). trivial. Qed. Lemma uncurry_uniform `{!Rounded A} `{!Rounded B} (f : A -> B -> C) mu mu' `{!forall x, Uniform (f x) mu} `{!forall y, Uniform (fun x => f x y) mu'} : Uniform (uncurry f) (fun e => meet (mu (e/2)) (mu' (e/2))). Proof. intros e [u1 u2] [v1 v2] [xi1 xi2]. simpl in *. rewrite (pos_split2 e). apply (triangular _ (f u1 v2)). - apply (uniform (f u1) _). eapply rounded_le. + exact xi2. + apply meet_lb_l. - apply (uniform (fun v => f v v2) _). eapply rounded_le. + exact xi1. + apply meet_lb_r. Qed. End currying. Section pair. Universe UA. Context {A:Type@{UA} } `{Closeness A} `{forall e, Reflexive (close (A:=A) e)}. Universe UB. Context {B:Type@{UB} } `{Closeness B} `{forall e, Reflexive (close (A:=B) e)}. Global Instance pair_nonexpanding_l : forall x, NonExpanding (@pair A B x). Proof. intros x e u v xi;split;simpl. - reflexivity. - exact xi. Qed. Global Instance pair_nonexpanding_r : forall y, NonExpanding (fun x => @pair A B x y). Proof. intros x e u v xi;split;simpl. - exact xi. - reflexivity. Qed. Global Instance fst_nonexpanding : NonExpanding (@fst A B). Proof. intros e u v xi;apply xi. Qed. Global Instance snd_nonexpanding : NonExpanding (@snd A B). Proof. intros e u v xi;apply xi. Qed. End pair. Section prod_equiv. Universe UA. Context {A:Type@{UA} } `{Closeness A}. Universe UB. Context {B:Type@{UB} } `{Closeness B}. Global Instance equiv_prod_symm_nonexpanding : NonExpanding (@Prod.equiv_prod_symm A B). Proof. intros e u v xi;split;apply xi. Qed. Global Instance equiv_prod_symm_inv_nonexpanding : NonExpanding ((@Prod.equiv_prod_symm A B)^-1). Proof. intros e u v xi;split;apply xi. Qed. Universe UC. Context {C:Type@{UC} } `{Closeness C}. Global Instance equiv_prod_assoc_nonexpanding : NonExpanding (@Prod.equiv_prod_assoc A B C). Proof. intros e u v xi;repeat split;apply xi. Qed. Global Instance equiv_prod_assoc_inc_nonexpanding : NonExpanding ((@Prod.equiv_prod_assoc A B C)^-1). Proof. intros e u v xi;repeat split;apply xi. Qed. End prod_equiv. Section map2. Universe UA. Context {A:Type@{UA} } `{Closeness A}. Universe UB. Context {B:Type@{UB} } `{Closeness B}. Universe UC. Context {C:Type@{UC} } `{Closeness C}. Universe UD. Context {D:Type@{UD} } `{Closeness D}. Variables (f : A -> C) (g : B -> D). Lemma map2_nonexpanding' `{!NonExpanding f} `{!NonExpanding g} : NonExpanding (map2 f g). Proof. intros e u v xi;split;simpl; apply (non_expanding _),xi. Qed. Definition map2_nonexpanding@{i} := @map2_nonexpanding'@{i i}. Arguments map2_nonexpanding {_ _} e x y xi. Global Existing Instance map2_nonexpanding. Lemma map2_lipschitz' `{!Rounded C} `{!Rounded D} Lf Lg `{!Lipschitz f Lf} `{!Lipschitz g Lg} : Lipschitz (map2 f g) (join Lf Lg). Proof. intros e u v xi. split;simpl. - apply rounded_le with (Lf * e). + apply (lipschitz _ _),xi. + apply (order_preserving (.* ' e)). apply join_ub_l. - apply rounded_le with (Lg * e). + apply (lipschitz _ _),xi. + apply (order_preserving (.* ' e)). apply join_ub_r. Qed. (* Coq pre 8.8 produces phantom universes, see coq/coq#6483 **) Definition map2_lipschitz@{i} := ltac:(first [exact @map2_lipschitz'@{i i i}|exact @map2_lipschitz'@{i i i i}]). Arguments map2_lipschitz {_ _} Lf Lg {_ _} e x y xi. Global Existing Instance map2_lipschitz. Lemma map2_continuous' `{!Rounded A} `{!Rounded B} `{!Continuous f} `{!Continuous g} : Continuous (map2 f g). Proof. intros u e. apply (merely_destruct (continuous f (fst u) e));intros [d1 E1]. apply (merely_destruct (continuous g (snd u) e));intros [d2 E2]. apply tr;exists (meet d1 d2). intros v xi. split;simpl. - apply E1. apply rounded_le with (meet d1 d2). + apply xi. + apply meet_lb_l. - apply E2. apply rounded_le with (meet d1 d2). + apply xi. + apply meet_lb_r. Qed. (* Coq pre 8.8 produces phantom universes, see coq/coq#6483 **) Definition map2_continuous@{i} := ltac:(first [exact @map2_continuous'@{i i i}|exact @map2_continuous'@{i i i i}]). Arguments map2_continuous {_ _ _ _} u e. Global Existing Instance map2_continuous. End map2. Section interval. Universe UA UALE. Context {A:Type@{UA} } {Ale : Le@{UA UALE} A}. Definition Interval a b := sig (fun x : A => a <= x /\ x <= b). Definition interval_proj a b : Interval a b -> A := pr1. Context {Ameet : Meet A} {Ajoin : Join A} `{!LatticeOrder@{UA UALE} Ale}. Definition Interval_restrict@{} (a b : A) (E : a <= b) : A -> Interval a b. Proof. intros x. exists (join a (meet x b)). split. - apply join_ub_l. - apply join_le. + exact E. + apply meet_lb_r. Defined. Lemma Interval_restrict_pr : forall a b E x (E': a <= x /\ x <= b), Interval_restrict a b E x = exist _ x E'. Proof. intros a b E x E'. unfold Interval_restrict. apply Sigma.path_sigma_hprop. simpl. rewrite meet_l;[apply join_r|];apply E'. Qed. Context `{Closeness A}. Global Instance Interval_close (a b : A) : Closeness (Interval a b) := fun e x y => close e (interval_proj a b x) (interval_proj a b y). Arguments Interval_close _ _ _ _ _ /. (* NB: for some reason this forces UALE <= UA *) Lemma Interval_premetric@{i} `{!PreMetric@{UA i} A} a b : PreMetric@{UA i} (Interval a b). Proof. split. - unfold close;simpl. apply _. - intros e u. red;red. reflexivity. - intros e u v xi;red;red;symmetry;apply xi. - intros u v E. apply Sigma.path_sigma_hprop. apply separated,E. - intros u v w e d xi1 xi2. red;red. apply (triangular _ (interval_proj a b v)). + exact xi1. + exact xi2. - intros e u v. split. + intros xi. do 2 red in xi. apply (fst (rounded _ _ _)) in xi. exact xi. + intros E. unfold close,Interval_close in E. apply (snd (rounded _ _ _)) in E. exact E. Qed. Global Existing Instance Interval_premetric. Global Instance interval_proj_nonexpanding (a b : A) : NonExpanding (interval_proj a b) := fun _ _ _ xi => xi. End interval. Section rationals. Lemma Qclose_alt : forall e (q r : Q), close e q r <-> abs (q - r) < ' e. Proof. intros e q r;split. - intros [E1 E2]. destruct (total le 0 (q - r)) as [E|E]. + rewrite (Qabs_of_nonneg _ E). trivial. + rewrite (Qabs_of_nonpos _ E). apply flip_lt_negate. rewrite involutive. trivial. - intros E. split;[apply flip_lt_negate;rewrite involutive|]; apply le_lt_trans with (abs (q - r));trivial. + apply Qabs_le_neg_raw. + apply Qabs_le_raw. Qed. Lemma Qclose_neg@{} : forall e (x y : Q), close e x y <-> close e (- x) (- y). Proof. intros e x y;split;intros E;apply Qclose_alt in E;apply Qclose_alt. - rewrite <-(negate_plus_distr),Qabs_neg. trivial. - rewrite <-(negate_plus_distr),Qabs_neg in E. trivial. Qed. Instance Q_close_symm@{} : forall e, Symmetric (@close Q _ e). Proof. red;unfold close;simpl. intros e x y [E1 E2];split. - apply flip_lt_negate. rewrite <-negate_swap_r,involutive. trivial. - apply flip_lt_negate. rewrite negate_swap_r,involutive. trivial. Qed. Lemma Q_triangular_one@{} : forall (q r : Q) (e : Q+) (Hqr : close e q r) (q0 : Q) (n : Q+), (close n q q0 -> close (e + n) r q0). Proof. unfold close;simpl. intros q r e [E1 E1'] s n [E2 E2']. split. - apply flip_lt_negate. rewrite negate_swap_r,!involutive. apply flip_lt_negate in E2. rewrite negate_swap_r,!involutive in E2. pose proof (plus_lt_compat _ _ _ _ E1' E2) as E. assert (Hrw : s - r = q - r + (s - q)) by abstract ring_tac.ring_with_integers (NatPair.Z nat). rewrite Hrw;trivial. - apply flip_lt_negate in E1. rewrite negate_swap_r,!involutive in E1. pose proof (plus_lt_compat _ _ _ _ E1 E2') as E. assert (Hrw : r - s = r - q + (q - s)) by abstract ring_tac.ring_with_integers (NatPair.Z nat). rewrite Hrw;trivial. Qed. Instance Q_triangular@{} : Triangular Q. Proof. hnf. intros u v w e d E1 E2. apply Q_triangular_one with v. - symmetry;trivial. - trivial. Qed. Lemma Qclose_separating_not_lt : forall q r : Q, (forall e, close e q r) -> ~ (q < r). Proof. intros q r E1 E2. pose proof (E1 (Qpos_diff _ _ E2)) as E3. apply symmetry in E3;apply Qclose_alt in E3. unfold cast in E3;simpl in E3. apply (irreflexivity lt (r - q)). apply le_lt_trans with (abs (r - q));trivial. apply Qabs_le_raw. Qed. Instance Qclose_separating : Separated Q. Proof. hnf. intros q r E1. apply tight_apart. intros E2. apply apart_iff_total_lt in E2. destruct E2 as [E2|E2]. - exact (Qclose_separating_not_lt _ _ E1 E2). - refine (Qclose_separating_not_lt _ _ _ E2). intros;symmetry;trivial. Qed. Instance Qclose_rounded@{} : Rounded Q. Proof. intros e q r;split. - intros E;apply Qclose_alt in E. pose proof (Q_average_between _ _ E) as [E1 E2]. apply tr;simple refine (exist _ (mkQpos ((abs (q - r) + ' e) / 2) _) _). { apply pos_mult_compat;[|solve_propholds]. red. apply pos_plus_le_lt_compat_r;[solve_propholds|apply Qabs_nonneg]. } simpl. exists (Qpos_diff _ _ E2). split. + apply pos_eq. exact (Qpos_diff_pr _ _ E2). + apply Qclose_alt. exact E1. - apply (Trunc_ind _). intros [d [d' [He xi]]]. apply Qclose_alt;rewrite He. apply Qclose_alt in xi. apply lt_le_trans with (' d);trivial. apply nonneg_plus_le_compat_r. solve_propholds. Qed. Global Instance Q_premetric@{} : PreMetric Q. Proof. split;try apply _. intros e u;apply Qclose_alt. rewrite plus_negate_r. unfold abs. rewrite (fst (abs_sig 0).2). - solve_propholds. - reflexivity. Qed. Global Instance Qneg_nonexpanding@{} : NonExpanding ((-) : Negate Q). Proof. intros e x y. apply Qclose_neg. Defined. Global Instance Qplus_nonexpanding_l@{} : forall s : Q, NonExpanding (+ s). Proof. red. unfold close,Q_close;simpl. intros s e q r E. assert (Hrw : q + s - (r + s) = q - r) by abstract ring_tac.ring_with_integers (NatPair.Z nat). rewrite Hrw;trivial. Qed. Global Instance Qplus_nonexpanding_r@{} : forall s : Q, NonExpanding (s +). Proof. red;unfold close,Q_close;simpl. intros s e q r E. assert (Hrw : s + q - (s + r) = q - r) by abstract ring_tac.ring_with_integers (NatPair.Z nat). rewrite Hrw;trivial. Qed. Global Instance Qabs_nonexpanding : NonExpanding (abs (A:=Q)). Proof. intros e q r xi. apply Qclose_alt in xi;apply Qclose_alt. apply le_lt_trans with (abs (q - r));trivial. apply Qabs_triangle_alt. Qed. Global Instance Qmeet_nonexpanding_l : forall s : Q, NonExpanding (⊓ s). Proof. intros s e q r xi. apply Qclose_alt;apply Qclose_alt in xi. apply le_lt_trans with (abs (q - r));trivial. clear xi. destruct (total le q s) as [E1|E1], (total le r s) as [E2|E2]; rewrite ?(meet_l _ _ E1), ?(meet_r _ _ E1), ?(meet_l _ _ E2), ?(meet_r _ _ E2). - reflexivity. - rewrite (Qabs_of_nonpos (q - r)) by (apply (snd (flip_nonpos_minus _ _)); transitivity s;trivial). rewrite <-negate_swap_r. rewrite (Qabs_of_nonpos _ (snd (flip_nonpos_minus _ _) E1)). rewrite <-negate_swap_r. apply (order_preserving (+ (- q))). trivial. - rewrite (Qabs_of_nonneg (q - r)) by (apply (snd (flip_nonneg_minus _ _)); transitivity s;trivial). rewrite (Qabs_of_nonneg _ (snd (flip_nonneg_minus _ _) E2)). apply (order_preserving (+ (- r))). trivial. - rewrite plus_negate_r,Qabs_of_nonneg by reflexivity. apply Qabs_nonneg. Qed. Global Instance Qmeet_nonexpanding_r : forall s : Q, NonExpanding (s ⊓). Proof. intros s e q r xi. pose proof meet_sl_order_meet_sl. rewrite !(commutativity s). apply (non_expanding (fun x => meet x s)). trivial. Qed. Global Instance Qjoin_nonexpanding_l : forall s : Q, NonExpanding (⊔ s). Proof. intros s e q r xi. apply Qclose_alt;apply Qclose_alt in xi. apply le_lt_trans with (abs (q - r));trivial. clear xi. destruct (total le q s) as [E1|E1], (total le r s) as [E2|E2]; rewrite ?(join_l _ _ E1), ?(join_r _ _ E1), ?(join_l _ _ E2), ?(join_r _ _ E2). - rewrite plus_negate_r,Qabs_of_nonneg by reflexivity. apply Qabs_nonneg. - rewrite (Qabs_of_nonpos (q - r)) by (apply (snd (flip_nonpos_minus _ _)); transitivity s;trivial). rewrite <-negate_swap_r. rewrite (Qabs_of_nonpos _ (snd (flip_nonpos_minus _ _) E2)). rewrite <-negate_swap_r. apply (order_preserving (r +)). apply (snd (flip_le_negate _ _)). trivial. - rewrite (Qabs_of_nonneg (q - r)) by (apply (snd (flip_nonneg_minus _ _)); transitivity s;trivial). rewrite (Qabs_of_nonneg _ (snd (flip_nonneg_minus _ _) E1)). apply (order_preserving (q +)). apply (snd (flip_le_negate _ _)). trivial. - reflexivity. Qed. Global Instance Qjoin_nonexpanding_r : forall s : Q, NonExpanding (s ⊔). Proof. intros s e q r xi. pose proof join_sl_order_join_sl. rewrite !(commutativity s). apply (non_expanding (fun x => join x s)). trivial. Qed. Global Instance Qmult_lipschitz@{} : forall q : Q, Lipschitz (q *.) (pos_of_Q q). Proof. intros q e x y xi. apply Qclose_alt. rewrite negate_mult_distr_r,<-plus_mult_distr_l,Qabs_mult. apply pos_mult_le_lt_compat;try split. - apply Qabs_nonneg. - rewrite Qabs_is_join. apply join_le. + apply flip_le_negate;rewrite involutive; apply Q_abs_plus_1_bounds. + apply Q_abs_plus_1_bounds. - solve_propholds. - apply Qabs_nonneg. - apply Qclose_alt,xi. Qed. Global Instance Qpos_upper_close e : Closeness (Qpos_upper e) := fun n x y => close n x.1 y.1. Arguments Qpos_upper_close _ _ _ _ /. Global Instance Q_recip_lipschitz (e : Q+) : Lipschitz ((/) ∘ pr1 ∘ (Qpos_upper_inject e)) (/ (e * e)). Proof. intros n q r xi. unfold Compose;simpl. apply Qclose_alt. assert (PropHolds (0 < join q (' e))) as E by (apply lt_le_trans with (' e);[solve_propholds|apply join_ub_r]). apply (strictly_order_reflecting ((join q (' e)) *.)). assert (PropHolds (0 < join r (' e))) as E' by (apply lt_le_trans with (' e);[solve_propholds|apply join_ub_r]). apply (strictly_order_reflecting ((join r (' e)) *.)). set (X := join r (' e)) at 2 3. rewrite <-(Qabs_of_nonneg (join r _)) by solve_propholds. set (Y := join q (' e)) at 2 3. rewrite <-(Qabs_of_nonneg (join q _)) by solve_propholds. rewrite <-!Qabs_mult. rewrite !(plus_mult_distr_l (Aplus:=Qplus)). rewrite dec_recip_inverse by (apply irrefl_neq,symmetric_neq in E;trivial). rewrite mult_1_r. assert (Hrw : (r ⊔ ' e) * ((q ⊔ ' e) * - / (r ⊔ ' e)) = - Y * (X / X)) by ring_tac.ring_with_integers (NatPair.Z nat). rewrite Hrw;clear Hrw. rewrite dec_recip_inverse by (apply irrefl_neq,symmetric_neq in E';trivial). rewrite mult_1_r. unfold X, Y. eapply lt_le_trans. - apply Qclose_alt. eapply (non_expanding (⊔ ' e)). symmetry. apply xi. - transitivity (' (((e * e) / (e * e)) * n)). + rewrite pos_recip_r,Qpos_mult_1_l;reflexivity. + rewrite <-!Qpos_mult_assoc. change (' (e * (e * (/ (e * e) * n)))) with (' e * (' e * ' (/ (e * e) * n))). apply mult_le_compat;try solve_propholds;[apply join_ub_r|]. apply mult_le_compat;try solve_propholds;[apply join_ub_r|]. reflexivity. Qed. End rationals. Section cauchy. Universe UA. Context {A : Type@{UA} } {Aclose : Closeness A}. Context `{!PreMetric A}. Lemma limit_unique : forall x l1 l2, IsLimit x l1 -> IsLimit x l2 -> l1 = l2. Proof. intros x l1 l2 E1 E2. apply separated. intros e. rewrite (pos_split2 e),(pos_split2 (e/2)). apply triangular with (x (e / 2 / 2));[symmetry;apply E1|apply E2]. Qed. Lemma equiv_through_approx0 : forall (y : Approximation A) ly, IsLimit y ly -> forall u e d, close e u (y d) -> close (e+d) u ly. Proof. intros y ly E1 u e d xi. apply (merely_destruct ((fst (rounded _ _ _) xi))). intros [d0 [d' [He E2]]]. pose proof (triangular _ _ _ _ _ E2 (E1 d' _)) as E3. assert (Hrw : e + d = d0 + (d' + d));[|rewrite Hrw;trivial]. rewrite He. symmetry. apply Qpos_plus_assoc. Qed. Context {Alim : Lim A} `{!CauchyComplete A}. Lemma equiv_through_approx : forall u (y : Approximation A) e d, close e u (y d) -> close (e+d) u (lim y). Proof. intros u y;apply equiv_through_approx0. apply cauchy_complete. Qed. Lemma equiv_lim_lim (x y : Approximation A) (e d n e' : Q+) : e = d + n + e' -> close e' (x d) (y n) -> close e (lim x) (lim y). Proof. intros He xi. rewrite He. assert (Hrw : d + n + e' = e' + d + n) by (apply pos_eq;ring_tac.ring_with_nat); rewrite Hrw;clear Hrw. apply equiv_through_approx. symmetry. apply equiv_through_approx. symmetry;trivial. Qed. Lemma lim_same_distance@{} : forall (x y : Approximation A) e, (forall d n, close (e+d) (x n) (y n)) -> forall d, close (e+d) (lim x) (lim y). Proof. intros x y e E d. apply equiv_lim_lim with (d/3) (d/3) (e + d/3);[|apply E]. path_via (e + 3 / 3 * d). - rewrite pos_recip_r,Qpos_mult_1_l;trivial. - apply pos_eq;ring_tac.ring_with_nat. Qed. End cauchy. Section lipschitz_lim. Context {A:Type} {Aclose : Closeness A} `{!PreMetric A} `{Bclose : Closeness B} `{!PreMetric B} {Blim : Lim B} `{!CauchyComplete B}. Global Instance lipschitz_lim_lipschitz (s : Approximation (A -> B)) L `{!forall e, Lipschitz (s e) L} : Lipschitz (lim s) L. Proof. intros e x y xi. apply rounded in xi;revert xi;apply (Trunc_ind _);intros [d [d' [E xi]]]. rewrite E,Qpos_plus_mult_distr_l. apply lim_same_distance. clear e d' E. intros d' n. simpl. apply rounded_plus. apply (lipschitz (s n) L). trivial. Qed. End lipschitz_lim. End contents. Arguments rounded_le {_ _ A _ _} e u v _ d _. Arguments non_expanding {A _ B _} f {_ e x y} _. Arguments lipschitz {A _ B _} f L {_ e x y} _. Arguments uniform {A _ B _} f mu {_} _ _ _ _. Arguments continuous {A _ B _} f {_} _ _. Arguments map2_nonexpanding {A _ B _ C _ D _} f g {_ _} e x y xi. Arguments map2_lipschitz {_ _ A _ B _ C _ D _} f g {_ _} Lf Lg {_ _} e x y xi. Arguments map2_continuous {_ _ A _ B _ C _ D _} f g {_ _ _ _} u e. Arguments Interval_close {_ _ _} _ _ _ _ _ /. Arguments Lim A {_}. Arguments lim {A _ _} _. Arguments Approximation A {_}. Arguments Build_Approximation {A _} _ _. Arguments approximate {A _} _ _. Arguments approx_equiv {A _} _ _ _. Arguments CauchyComplete A {_ _}. Arguments arrow_lim {A B _ _ _} _ / _. Coq-HoTT-9.0/theories/Classes/theory/rationals.v000066400000000000000000000420001474641544500216460ustar00rootroot00000000000000Require Import HoTT.Classes.implementations.peano_naturals HoTT.Classes.implementations.natpair_integers HoTT.Classes.interfaces.abstract_algebra HoTT.Classes.interfaces.naturals HoTT.Classes.interfaces.rationals HoTT.Classes.interfaces.orders HoTT.Classes.theory.groups HoTT.Classes.theory.integers HoTT.Classes.theory.dec_fields HoTT.Classes.orders.sum HoTT.Classes.orders.dec_fields HoTT.Classes.orders.lattices HoTT.Classes.theory.additional_operations HoTT.Classes.tactics.ring_quote HoTT.Classes.tactics.ring_tac. Import Quoting.Instances. Import NatPair.Instances. Local Set Universe Minimization ToSet. Section contents. Context `{Funext} `{Univalence}. Universe UQ. Context {Q : Type@{UQ} } {Qap : Apart@{UQ UQ} Q} {Qplus : Plus Q} {Qmult : Mult Q} {Qzero : Zero Q} {Qone : One Q} {Qneg : Negate Q} {Qrecip : DecRecip Q} {Qle : Le@{UQ UQ} Q} {Qlt : Lt@{UQ UQ} Q} {QtoField : RationalsToField@{UQ UQ UQ UQ} Q} {Qrats : Rationals@{UQ UQ UQ UQ UQ UQ UQ UQ UQ UQ} Q} {Qtrivialapart : TrivialApart Q} {Qdec : DecidablePaths Q} {Qmeet : Meet Q} {Qjoin : Join Q} {Qlattice : LatticeOrder Qle} {Qle_total : TotalRelation (@le Q _)} {Qabs : Abs Q}. Global Instance rational_1_neq_0 : PropHolds (@apart Q _ 1 0). Proof. red. apply trivial_apart. solve_propholds. Qed. Record Qpos@{} : Type@{UQ} := mkQpos { pos : Q; is_pos : 0 < pos }. Notation "Q+" := Qpos. Global Instance Qpos_Q@{} : Cast Qpos Q := pos. Arguments Qpos_Q /. Lemma Qpos_plus_pr@{} : forall a b : Qpos, 0 < 'a + 'b. Proof. intros. apply semirings.pos_plus_compat;apply is_pos. Qed. Global Instance Qpos_plus@{} : Plus Qpos := fun a b => mkQpos _ (Qpos_plus_pr a b). Global Instance pos_is_pos@{} : forall q : Q+, PropHolds (0 < ' q) := is_pos. Lemma pos_eq@{} : forall a b : Q+, @paths Q (' a) (' b) -> a = b. Proof. intros [a Ea] [b Eb] E. change (a = b) in E. destruct E;apply ap;apply path_ishprop. Qed. Global Instance Qpos_isset : IsHSet Q+. Proof. apply (@HSet.ishset_hrel_subpaths _ (fun e d => ' e = ' d)). - intros e; reflexivity. - apply _. - exact pos_eq. Qed. Global Instance Qpos_one@{} : One Q+. Proof. exists 1. apply lt_0_1. Defined. Global Instance Qpos_mult@{} : Mult Q+. Proof. intros a b;exists (' a * ' b). solve_propholds. Defined. Global Instance qpos_plus_comm@{} : Commutative (@plus Q+ _). Proof. hnf. intros. apply pos_eq. change (' x + ' y = ' y + ' x). apply plus_comm. Qed. Global Instance qpos_mult_comm@{} : Commutative (@mult Q+ _). Proof. hnf;intros;apply pos_eq,mult_comm. Qed. Global Instance pos_recip@{} : DecRecip Q+. Proof. intros e. exists (/ ' e). apply pos_dec_recip_compat. solve_propholds. Defined. Global Instance pos_of_nat@{} : Cast nat Q+. Proof. intros n. destruct n as [|k]. - exists 1;apply lt_0_1. - exists (naturals_to_semiring nat Q (S k)). induction k as [|k Ik]. + change (0 < 1). apply lt_0_1. + change (0 < 1 + naturals_to_semiring nat Q (S k)). set (K := naturals_to_semiring nat Q (S k)) in *;clearbody K. apply pos_plus_compat. * apply lt_0_1. * trivial. Defined. Lemma pos_recip_r@{} : forall e : Q+, e / e = 1. Proof. intros;apply pos_eq. unfold dec_recip,cast,pos_recip;simpl. change (' e / ' e = 1). apply dec_recip_inverse. apply lt_ne_flip. solve_propholds. Qed. Lemma pos_recip_r'@{} : forall e : Q+, @paths Q (' e / ' e) 1. Proof. intros. change (' (e / e) = 1). rewrite pos_recip_r. reflexivity. Qed. Lemma pos_mult_1_r@{} : forall e : Q+, e * 1 = e. Proof. intros;apply pos_eq. apply mult_1_r. Qed. Lemma pos_split2@{} : forall e : Q+, e = e / 2 + e / 2. Proof. intros. path_via (e * (2 / 2)). - rewrite pos_recip_r,pos_mult_1_r;reflexivity. - apply pos_eq. change (' e * (2 / 2) = ' e / 2 + ' e / 2). ring_tac.ring_with_nat. Qed. Lemma pos_split3@{} : forall e : Q+, e = e / 3 + e / 3 + e / 3. Proof. intros. path_via (e * (3 / 3)). - rewrite pos_recip_r,pos_mult_1_r;reflexivity. - apply pos_eq. change (' e * (3 / 3) = ' e / 3 + ' e / 3 + ' e / 3). ring_tac.ring_with_nat. Qed. Global Instance Qpos_mult_assoc@{} : Associative (@mult Q+ _). Proof. hnf. intros;apply pos_eq. apply mult_assoc. Qed. Global Instance Qpos_plus_assoc@{} : Associative (@plus Q+ _). Proof. hnf. intros;apply pos_eq. apply plus_assoc. Qed. Global Instance Qpos_mult_1_l@{} : LeftIdentity (@mult Q+ _) 1. Proof. hnf;intros;apply pos_eq;apply mult_1_l. Qed. Global Instance Qpos_mult_1_r@{} : RightIdentity (@mult Q+ _) 1. Proof. hnf;intros;apply pos_eq;apply mult_1_r. Qed. Lemma pos_recip_through_plus@{} : forall a b c : Q+, a + b = c * (a / c + b / c). Proof. intros. path_via ((a + b) * (c / c)). - rewrite pos_recip_r;apply pos_eq,symmetry,mult_1_r. - apply pos_eq;ring_tac.ring_with_nat. Qed. Lemma pos_unconjugate@{} : forall a b : Q+, a * b / a = b. Proof. intros. path_via (a / a * b). - apply pos_eq;ring_tac.ring_with_nat. - rewrite pos_recip_r;apply Qpos_mult_1_l. Qed. Lemma Qpos_recip_1 : / 1 = 1 :> Q+. Proof. apply pos_eq. exact dec_recip_1. Qed. Lemma Qpos_plus_mult_distr_l : @LeftDistribute Q+ mult plus. Proof. hnf. intros;apply pos_eq,plus_mult_distr_l. Qed. Global Instance Qpos_meet@{} : Meet Q+. Proof. intros a b. exists (meet (' a) (' b)). apply not_le_lt_flip. intros E. destruct (total_meet_either (' a) (' b)) as [E1|E1]; rewrite E1 in E;(eapply le_iff_not_lt_flip;[exact E|]); solve_propholds. Defined. Global Instance Qpos_join@{} : Join Q+. Proof. intros a b. exists (join (' a) (' b)). apply not_le_lt_flip. intros E. destruct (total_join_either (' a) (' b)) as [E1|E1]; rewrite E1 in E;(eapply le_iff_not_lt_flip;[exact E|]); solve_propholds. Defined. Lemma Q_sum_eq_join_meet@{} : forall a b c d : Q, a + b = c + d -> a + b = join a c + meet b d. Proof. intros ???? E. destruct (total le a c) as [E1|E1]. - rewrite (join_r _ _ E1). rewrite meet_r;trivial. apply (order_preserving (+ b)) in E1. rewrite E in E1. apply (order_reflecting (c +)). trivial. - rewrite (join_l _ _ E1). rewrite meet_l;trivial. apply (order_reflecting (a +)). rewrite E. apply (order_preserving (+ d)). trivial. Qed. Lemma Qpos_sum_eq_join_meet@{} : forall a b c d : Q+, a + b = c + d -> a + b = join a c + meet b d. Proof. intros ???? E. apply pos_eq;apply Q_sum_eq_join_meet. change (' a + ' b) with (' (a + b)). rewrite E;reflexivity. Qed. Lemma Qpos_le_lt_min : forall a b : Q+, ' a <= ' b -> exists c ca cb, a = c + ca /\ b = c + cb. Proof. intros a b E. exists (a/2),(a/2). simple refine (exist _ _ _);simpl. - exists (' (a / 2) + (' b - ' a)). apply nonneg_plus_lt_compat_r. + apply (snd (flip_nonneg_minus _ _)). trivial. + solve_propholds. - split. + apply pos_split2. + apply pos_eq. unfold cast at 2;simpl. unfold cast at 3;simpl. set (a':=a/2);rewrite (pos_split2 a);unfold a';clear a'. ring_tac.ring_with_integers (NatPair.Z nat). Qed. Lemma Qpos_lt_min@{} : forall a b : Q+, exists c ca cb : Q+, a = c + ca /\ b = c + cb. Proof. intros. destruct (total le (' a) (' b)) as [E|E]. - apply Qpos_le_lt_min;trivial. - apply Qpos_le_lt_min in E. destruct E as [c [cb [ca [E1 E2]]]]. exists c,ca,cb;auto. Qed. Definition Qpos_diff : forall q r : Q, q < r -> Q+. Proof. intros q r E;exists (r-q). apply (snd (flip_pos_minus _ _) E). Defined. Lemma Qpos_diff_pr@{} : forall q r E, r = q + ' (Qpos_diff q r E). Proof. intros q r E. change (r = q + (r - q)). abstract ring_tac.ring_with_integers (NatPair.Z nat). Qed. Lemma Qmeet_plus_l : forall a b c : Q, meet (a + b) (a + c) = a + meet b c. Proof. intros. destruct (total le b c) as [E|E]. - rewrite (meet_l _ _ E). apply meet_l. apply (order_preserving (a +)),E. - rewrite (meet_r _ _ E). apply meet_r. apply (order_preserving (a +)),E. Qed. Lemma Qabs_nonneg@{} : forall q : Q, 0 <= abs q. Proof. intros q;destruct (total_abs_either q) as [E|E];destruct E as [E1 E2];rewrite E2. - trivial. - apply flip_nonneg_negate. rewrite involutive;trivial. Qed. Lemma Qabs_nonpos_0@{} : forall q : Q, abs q <= 0 -> q = 0. Proof. intros q E. pose proof (antisymmetry le _ _ E (Qabs_nonneg _)) as E1. destruct (total_abs_either q) as [[E2 E3]|[E2 E3]];rewrite E3 in E1. - trivial. - apply (injective (-)). rewrite negate_0. trivial. Qed. Lemma Qabs_0_or_pos : forall q : Q, q = 0 |_| 0 < abs q. Proof. intros q. destruct (le_or_lt (abs q) 0) as [E|E]. - left. apply Qabs_nonpos_0. trivial. - right. trivial. Qed. Lemma Qabs_of_nonneg@{} : forall q : Q, 0 <= q -> abs q = q. Proof. intro;apply ((abs_sig _).2). Qed. Lemma Qabs_of_nonpos : forall q : Q, q <= 0 -> abs q = - q. Proof. intro;apply ((abs_sig _).2). Qed. Lemma Qabs_le_raw@{} : forall x : Q, x <= abs x. Proof. intros x;destruct (total_abs_either x) as [[E1 E2]|[E1 E2]]. - rewrite E2;reflexivity. - transitivity (0:Q);trivial. rewrite E2. apply flip_nonpos_negate. trivial. Qed. Lemma Qabs_neg@{} : forall x : Q, abs (- x) = abs x. Proof. intros x. destruct (total_abs_either x) as [[E1 E2]|[E1 E2]]. - rewrite E2. path_via (- - x);[|rewrite involutive;trivial]. apply ((abs_sig (- x)).2). apply flip_nonneg_negate;trivial. - rewrite E2. apply ((abs_sig (- x)).2). apply flip_nonpos_negate;trivial. Qed. Lemma Qabs_le_neg_raw : forall x : Q, - x <= abs x. Proof. intros x. rewrite <-Qabs_neg. apply Qabs_le_raw. Qed. Lemma Q_abs_le_pr@{} : forall x y : Q, abs x <= y <-> - y <= x /\ x <= y. Proof. intros x y;split. - intros E. split. + apply flip_le_negate. rewrite involutive. transitivity (abs x);trivial. apply Qabs_le_neg_raw. + transitivity (abs x);trivial. apply Qabs_le_raw. - intros [E1 E2]. destruct (total_abs_either x) as [[E3 E4]|[E3 E4]];rewrite E4. + trivial. + apply flip_le_negate;rewrite involutive;trivial. Qed. Lemma Qabs_is_join@{} : forall q : Q, abs q = join (- q) q. Proof. intros q. symmetry. destruct (total_abs_either q) as [[E1 E2]|[E1 E2]];rewrite E2. - apply join_r. transitivity (0:Q);trivial. apply flip_nonneg_negate;trivial. - apply join_l. transitivity (0:Q);trivial. apply flip_nonpos_negate;trivial. Qed. Lemma Qlt_join : forall a b c : Q, a < c -> b < c -> join a b < c. Proof. intros a b c E1 E2. destruct (total le a b) as [E3|E3];rewrite ?(join_r _ _ E3),?(join_l _ _ E3); trivial. Qed. Lemma Q_average_between@{} : forall q r : Q, q < r -> q < (q + r) / 2 < r. Proof. intros q r E. split. - apply flip_pos_minus. assert (Hrw : (q + r) / 2 - q = (r - q) / 2);[|rewrite Hrw;clear Hrw]. { path_via ((q + r) / 2 - 2 / 2 * q). { rewrite dec_recip_inverse;[|solve_propholds]. rewrite mult_1_l;trivial. } ring_tac.ring_with_integers (NatPair.Z nat). } apply pos_mult_compat;[|apply _]. red. apply (snd (flip_pos_minus _ _)). trivial. - apply flip_pos_minus. assert (Hrw : r - (q + r) / 2 = (r - q) / 2);[|rewrite Hrw;clear Hrw]. { path_via (2 / 2 * r - (q + r) / 2). { rewrite dec_recip_inverse;[|solve_propholds]. rewrite mult_1_l;trivial. } ring_tac.ring_with_integers (NatPair.Z nat). } apply pos_mult_compat;[|apply _]. red. apply (snd (flip_pos_minus _ _)). trivial. Qed. Lemma path_avg_split_diff_l (q r : Q) : q + ((r - q) / 2) = (r + q) / 2. Proof. pattern q at 1. rewrite <- (mult_1_r q). pattern (1 : Q) at 1. rewrite <- (dec_recip_inverse 2) by solve_propholds. rewrite (associativity q 2 (/2)). rewrite <- (distribute_r (q*2) (r-q) (/2)). rewrite (distribute_l q 1 1). rewrite (mult_1_r q). rewrite (commutativity (q+q) (r-q)). rewrite <- (associativity r (-q) (q+q)). rewrite (associativity (-q) q q). rewrite (plus_negate_l q). rewrite (plus_0_l q). reflexivity. Qed. Lemma path_avg_split_diff_r (q r : Q) : r - ((r - q) / 2) = (r + q) / 2. Proof. pattern r at 1. rewrite <- (mult_1_r r). pattern (1 : Q) at 1. rewrite <- (dec_recip_inverse 2) by solve_propholds. rewrite (associativity r 2 (/2)). rewrite negate_mult_distr_l. rewrite <- (distribute_r (r*2) (-(r-q)) (/2)). rewrite (distribute_l r 1 1). rewrite (mult_1_r r). rewrite (commutativity (r+r) (-(r-q))). rewrite <- negate_swap_r. rewrite <- (associativity q (-r) (r+r)). rewrite (associativity (-r) r r). rewrite (plus_negate_l r). rewrite (plus_0_l r). rewrite (plus_comm q r). reflexivity. Qed. Lemma pos_gt_both : forall a b : Q, forall e, a < ' e -> b < ' e -> exists d d', a < ' d /\ b < ' d /\ e = d + d'. Proof. assert (Haux : forall a b : Q, a <= b -> forall e, a < ' e -> b < ' e -> exists d d', a < ' d /\ b < ' d /\ e = d + d'). { intros a b E e E1 E2. pose proof (Q_average_between _ _ (Qlt_join _ 0 _ E2 prop_holds)) as [E3 E4]. exists (mkQpos _ (le_lt_trans _ _ _ (join_ub_r _ _) E3)). unfold cast at 1 4;simpl. exists (Qpos_diff _ _ E4). repeat split. - apply le_lt_trans with b;trivial. apply le_lt_trans with (join b 0);trivial. apply join_ub_l. - apply le_lt_trans with (join b 0);trivial. apply join_ub_l. - apply pos_eq. unfold cast at 2;simpl. unfold cast at 2;simpl. unfold cast at 3;simpl. abstract ring_tac.ring_with_integers (NatPair.Z nat). } intros a b e E1 E2. destruct (total le a b) as [E|E];auto. destruct (Haux _ _ E e) as [d [d' [E3 [E4 E5]]]];trivial. eauto. Qed. Lemma two_fourth_is_one_half@{} : 2/4 = 1/2 :> Q+. Proof. assert (Hrw : 4 = 2 * 2 :> Q) by ring_tac.ring_with_nat. apply pos_eq. repeat (unfold cast;simpl). rewrite Hrw;clear Hrw. rewrite dec_recip_distr. rewrite mult_assoc. rewrite dec_recip_inverse;[|solve_propholds]. reflexivity. Unshelve. exact (fun _ => 1). (* <- wtf *) Qed. Lemma Q_triangle_le : forall q r : Q, abs (q + r) <= abs q + abs r. Proof. intros. rewrite (Qabs_is_join (q + r)). apply join_le. - rewrite negate_plus_distr. apply plus_le_compat;apply Qabs_le_neg_raw. - apply plus_le_compat;apply Qabs_le_raw. Qed. Lemma Qabs_triangle_alt_aux : forall x y : Q, abs x - abs y <= abs (x - y). Proof. intros q r. apply (order_reflecting (+ (abs r))). assert (Hrw : abs q - abs r + abs r = abs q) by ring_tac.ring_with_integers (NatPair.Z nat); rewrite Hrw;clear Hrw. etransitivity;[|apply Q_triangle_le]. assert (Hrw : q - r + r = q) by ring_tac.ring_with_integers (NatPair.Z nat); rewrite Hrw;clear Hrw. reflexivity. Qed. Lemma Qabs_triangle_alt : forall x y : Q, abs (abs x - abs y) <= abs (x - y). Proof. intros q r. rewrite (Qabs_is_join (abs q - abs r)). apply join_le. - rewrite <-(Qabs_neg (q - r)),<-!negate_swap_r. apply Qabs_triangle_alt_aux. - apply Qabs_triangle_alt_aux. Qed. Lemma Q_dense@{} : forall q r : Q, q < r -> exists s, q < s < r. Proof. intros q r E;econstructor;apply Q_average_between,E. Qed. Lemma Qabs_neg_flip@{} : forall a b : Q, abs (a - b) = abs (b - a). Proof. intros a b. rewrite <-Qabs_neg. rewrite <-negate_swap_r. trivial. Qed. Definition pos_of_Q : Q -> Q+ := fun q => {| pos := abs q + 1; is_pos := le_lt_trans _ _ _ (Qabs_nonneg q) (fst (pos_plus_lt_compat_r _ _) lt_0_1) |}. Lemma Q_abs_plus_1_bounds@{} : forall q : Q, - ' (pos_of_Q q) ≤ q ≤ ' (pos_of_Q q). Proof. intros. change (- (abs q + 1) ≤ q ≤ (abs q + 1)). split. - apply flip_le_negate. rewrite involutive. transitivity (abs q). + apply Qabs_le_neg_raw. + apply nonneg_plus_le_compat_r. solve_propholds. - transitivity (abs q). + apply Qabs_le_raw. + apply nonneg_plus_le_compat_r. solve_propholds. Qed. Lemma Qabs_mult@{} : forall a b : Q, abs (a * b) = abs a * abs b. Proof. intros a b. destruct (total_abs_either a) as [Ea|Ea];destruct Ea as [Ea1 Ea2];rewrite Ea2; destruct (total_abs_either b) as [Eb|Eb];destruct Eb as [Eb1 Eb2];rewrite Eb2. - apply ((abs_sig (a*b)).2). apply nonneg_mult_compat;trivial. - rewrite <-negate_mult_distr_r. apply ((abs_sig (a*b)).2). apply nonneg_nonpos_mult;trivial. - rewrite <-negate_mult_distr_l. apply ((abs_sig (a*b)).2). apply nonpos_nonneg_mult;trivial. - rewrite negate_mult_negate. apply ((abs_sig (a*b)).2). apply nonpos_mult;trivial. Qed. Lemma Qpos_neg_le@{} : forall a : Q+, - ' a <= ' a. Proof. intros a;apply between_nonneg;solve_propholds. Qed. Definition Qpos_upper (e : Q+) := exists x : Q, ' e <= x. Definition Qpos_upper_inject e : Q -> Qpos_upper e. Proof. intros x. exists (join x (' e)). apply join_ub_r. Defined. Global Instance QLe_dec : forall q r : Q, Decidable (q <= r). Proof. intros q r;destruct (le_or_lt q r). - left;trivial. - right;intros ?. apply (irreflexivity lt q). apply le_lt_trans with r;trivial. Qed. Global Instance QLt_dec : forall q r : Q, Decidable (q < r). Proof. intros q r;destruct (le_or_lt r q). - right;intros ?. apply (irreflexivity lt q). apply lt_le_trans with r;trivial. - left;trivial. Qed. Section enumerable. Context `{Enumerable Q}. Definition Qpos_enumerator : nat -> Q+. Proof. intros n. destruct (le_or_lt (enumerator Q n) 0) as [E|E]. - exact 1. - exists (enumerator Q n);trivial. Defined. Lemma Qpos_is_enumerator : IsSurjection@{UQ} Qpos_enumerator. Proof. apply BuildIsSurjection. unfold hfiber. intros e;generalize (@center _ (enumerator_issurj Q (' e))). apply (Trunc_ind _). intros [n E]. apply tr;exists n. unfold Qpos_enumerator. destruct (le_or_lt (enumerator Q n) 0) as [E1|E1]. - destruct (irreflexivity lt 0). apply lt_le_trans with (enumerator Q n);trivial. rewrite E;solve_propholds. - apply pos_eq,E. Qed. Global Instance Qpos_enumerable : Enumerable Q+. Proof. exists Qpos_enumerator. first [exact Qpos_is_enumerator@{Uhuge Ularge}| exact Qpos_is_enumerator@{}]. Qed. End enumerable. End contents. Arguments Qpos Q {_ _}. Coq-HoTT-9.0/theories/Classes/theory/rings.v000066400000000000000000000355741474641544500210160ustar00rootroot00000000000000Require Import HoTT.Classes.theory.groups HoTT.Classes.theory.apartness. Require Import HoTT.Classes.interfaces.abstract_algebra. Generalizable Variables R A B C f z. Definition is_ne_0 `(x : R) `{Zero R} `{p : PropHolds (x <> 0)} : x <> 0 := p. Definition is_nonneg `(x : R) `{Le R} `{Zero R} `{p : PropHolds (0 ≤ x)} : 0 ≤ x := p. Definition is_pos `(x : R) `{Lt R} `{Zero R} `{p : PropHolds (0 < x)} : 0 < x := p. (* Lemma stdlib_semiring_theory R `{SemiRing R} : Ring_theory.semi_ring_theory 0 1 (+) (.*.) (=). Proof. Qed. *) (* We cannot apply [left_cancellation (.*.) z] directly in case we have no [PropHolds (0 <> z)] instance in the context. *) Section cancellation. Context `(op : A -> A -> A) `{!Zero A}. Lemma left_cancellation_ne_0 `{forall z, PropHolds (z <> 0) -> LeftCancellation op z} z : z <> 0 -> LeftCancellation op z. Proof. auto. Qed. Lemma right_cancellation_ne_0 `{forall z, PropHolds (z <> 0) -> RightCancellation op z} z : z <> 0 -> RightCancellation op z. Proof. auto. Qed. Lemma right_cancel_from_left `{!Commutative op} `{!LeftCancellation op z} : RightCancellation op z. Proof. intros x y E. apply (left_cancellation op z). rewrite 2!(commutativity (f:=op) z _). assumption. Qed. End cancellation. Section strong_cancellation. Context `{IsApart A} (op : A -> A -> A). Lemma strong_right_cancel_from_left `{!Commutative op} `{!StrongLeftCancellation op z} : StrongRightCancellation op z. Proof. intros x y E. rewrite 2!(commutativity _ z). apply (strong_left_cancellation op z);trivial. Qed. Global Instance strong_left_cancellation_cancel `{!StrongLeftCancellation op z} : LeftCancellation op z | 20. Proof. intros x y E1. apply tight_apart in E1;apply tight_apart;intros E2. apply E1. apply (strong_left_cancellation op);trivial. Qed. Global Instance strong_right_cancellation_cancel `{!StrongRightCancellation op z} : RightCancellation op z | 20. Proof. intros x y E1. apply tight_apart in E1;apply tight_apart;intros E2. apply E1. apply (strong_right_cancellation op);trivial. Qed. End strong_cancellation. Section semiring_props. Context `{IsSemiCRing R}. (* Add Ring SR : (stdlib_semiring_theory R). *) Instance mult_ne_0 `{!NoZeroDivisors R} x y : PropHolds (x <> 0) -> PropHolds (y <> 0) -> PropHolds (x * y <> 0). Proof. intros Ex Ey Exy. unfold PropHolds in *. apply (no_zero_divisors x); split; eauto. Qed. Global Instance plus_0_r: RightIdentity (+) 0 := right_identity. Global Instance plus_0_l: LeftIdentity (+) 0 := left_identity. Global Instance mult_1_l: LeftIdentity (.*.) 1 := left_identity. Global Instance mult_1_r: RightIdentity (.*.) 1 := right_identity. Global Instance plus_assoc: Associative (+) := simple_associativity. Global Instance mult_assoc: Associative (.*.) := simple_associativity. Global Instance plus_comm: Commutative (+) := commutativity. Global Instance mult_comm: Commutative (.*.) := commutativity. Global Instance mult_0_l: LeftAbsorb (.*.) 0 := left_absorb. Global Instance mult_0_r: RightAbsorb (.*.) 0. Proof. intro. path_via (0 * x). - apply mult_comm. - apply left_absorb. Qed. Global Instance plus_mult_distr_r : RightDistribute (.*.) (+). Proof. intros x y z. etransitivity;[|etransitivity]. - apply mult_comm. - apply distribute_l. - apply ap011;apply mult_comm. Qed. Lemma plus_mult_distr_l : LeftDistribute (.*.) (+). Proof. apply _. Qed. Global Instance: forall r : R, @IsMonoidPreserving R R (+) (+) 0 0 (r *.). Proof. repeat (constructor; try apply _). - red. apply distribute_l. - apply right_absorb. Qed. End semiring_props. (* Due to bug #2528 *) #[export] Hint Extern 3 (PropHolds (_ * _ <> 0)) => eapply @mult_ne_0 : typeclass_instances. Section semiringmor_props. Context `{IsSemiRingPreserving A B f}. Lemma preserves_0: f 0 = 0. Proof. apply preserves_mon_unit. Qed. Lemma preserves_1: f 1 = 1. Proof. apply preserves_mon_unit. Qed. Lemma preserves_mult: forall x y, f (x * y) = f x * f y. Proof. intros. apply preserves_sg_op. Qed. Lemma preserves_plus: forall x y, f (x + y) = f x + f y. Proof. intros. apply preserves_sg_op. Qed. Lemma preserves_2: f 2 = 2. Proof. rewrite preserves_plus. rewrite preserves_1. reflexivity. Qed. Lemma preserves_3: f 3 = 3. Proof. rewrite ?preserves_plus, ?preserves_1. reflexivity. Qed. Lemma preserves_4: f 4 = 4. Proof. rewrite ?preserves_plus, ?preserves_1. reflexivity. Qed. Context `{!IsInjective f}. Instance isinjective_ne_0 x : PropHolds (x <> 0) -> PropHolds (f x <> 0). Proof. intros. rewrite <-preserves_0. apply (neq_isinj f). assumption. Qed. Lemma injective_ne_1 x : x <> 1 -> f x <> 1. Proof. intros. rewrite <-preserves_1. apply (neq_isinj f). assumption. Qed. End semiringmor_props. (* Due to bug #2528 *) #[export] Hint Extern 12 (PropHolds (_ _ <> 0)) => eapply @isinjective_ne_0 : typeclass_instances. (* Lemma stdlib_ring_theory R `{Ring R} : Ring_theory.ring_theory 0 1 (+) (.*.) (fun x y => x - y) (-) (=). Proof. Qed. *) Section cring_props. Context `{IsCRing R}. Instance: LeftAbsorb (.*.) 0. Proof. intro. rewrite (commutativity (f:=(.*.)) 0). apply (left_cancellation (+) (y * 0)). path_via (y * 0);[|apply symmetry, right_identity]. path_via (y * (0 + 0)). - apply symmetry,distribute_l. - apply ap. apply right_identity. Qed. Global Instance CRing_Semi: IsSemiCRing R. Proof. repeat (constructor; try apply _). Qed. End cring_props. Section ring_props. Context `{IsRing R}. Global Instance mult_left_absorb : LeftAbsorb (.*.) 0. Proof. intro y. rapply (right_cancellation (+) (0 * y)). lhs_V rapply simple_distribute_r. rhs rapply left_identity. nrapply (ap (.* y)). apply left_identity. Defined. Global Instance mult_right_absorb : RightAbsorb (.*.) 0. Proof. intro x. rapply (right_cancellation (+) (x * 0)). lhs_V rapply simple_distribute_l. rhs rapply left_identity. nrapply (ap (x *.)). apply left_identity. Defined. (** This hint helps other results go through. We do it in two steps, since if we specify the type [IsGroup R], Coq infers the wrong implicit arguments to [IsGroup]. *) Definition isgroup_ring := abgroup_group R. Global Existing Instance isgroup_ring. Global Instance negate_involutive : Involutive (-) := inverse_involutive. (* alias for convenience *) Global Instance plus_negate_r : RightInverse (+) (-) 0. Proof. rapply inverse_r. Defined. Global Instance plus_negate_l : LeftInverse (+) (-) 0. Proof. rapply inverse_l. Defined. Lemma negate_swap_r : forall x y, x - y = -(y - x). Proof. intros; symmetry. lhs rapply groups.inverse_sg_op. f_ap. apply involutive. Defined. Lemma negate_swap_l x y : -x + y = -(x - y). Proof. rhs_V rapply negate_swap_r. apply commutativity. Defined. Global Instance isinj_ring_neg : IsInjective (-) := groups.isinj_group_inverse. Lemma negate_plus_distr : forall x y, -(x + y) = -x + -y. Proof. exact groups.negate_sg_op_distr. Qed. Lemma negate_mult_l x : -x = - 1 * x. Proof. apply (left_cancellation (+) x). path_via 0. - rapply inverse_r. - path_via (1 * x + (- 1) * x). + rhs_V rapply distribute_r. symmetry. rhs_V rapply (left_absorb x). f_ap. rapply inverse_r. + apply ap011;try reflexivity. apply left_identity. Defined. Lemma negate_mult_r x : -x = x * -1. Proof. apply (right_cancellation (+) x). transitivity (x * -1 + x * 1). - lhs apply left_inverse. rhs_V rapply simple_distribute_l. lhs_V rapply (right_absorb x). apply (ap (x *.)). symmetry. rapply inverse_l. - f_ap. apply right_identity. Defined. Lemma negate_mult_distr_l x y : -(x * y) = -x * y. Proof. lhs nrapply negate_mult_l. lhs rapply (simple_associativity (f := (.*.)) (-1) x y). apply (ap (.* y)). symmetry. apply negate_mult_l. Defined. Lemma negate_mult_distr_r x y : -(x * y) = x * -y. Proof. lhs nrapply negate_mult_r. lhs_V rapply (simple_associativity (f := (.*.)) x y). apply (ap (x *.)). symmetry. apply negate_mult_r. Defined. Lemma negate_mult_negate x y : -x * -y = x * y. Proof. rewrite <-negate_mult_distr_l, <-negate_mult_distr_r. rapply involutive. Qed. Lemma negate_0: -0 = 0. Proof. exact groups.inverse_mon_unit. Qed. Global Instance minus_0_r: RightIdentity (fun x y => x - y) 0. Proof. intro x; rewrite negate_0. apply right_identity. Qed. Lemma equal_by_zero_sum x y : x - y = 0 <-> x = y. Proof. split; intros E. - rewrite <- (left_identity y). change (sg_op ?x ?y) with (0 + y). rewrite <- E. rewrite <-simple_associativity. rewrite left_inverse. apply symmetry,right_identity. - rewrite E. apply right_inverse. Qed. Lemma flip_negate x y : -x = y <-> x = -y. Proof. split; intros E. - rewrite <-E, involutive. trivial. - rewrite E, involutive. trivial. Qed. Lemma flip_negate_0 x : -x = 0 <-> x = 0. Proof. etransitivity. - apply flip_negate. - rewrite negate_0. apply reflexivity. Qed. Lemma flip_negate_ne_0 x : -x <> 0 <-> x <> 0. Proof. split; intros E ?; apply E; apply flip_negate_0;trivial. path_via x. apply involutive. Qed. Lemma negate_zero_prod_l x y : -x * y = 0 <-> x * y = 0. Proof. split; intros E. - apply (injective (-)). rewrite negate_mult_distr_l, negate_0. trivial. - apply (injective (-)). rewrite negate_mult_distr_l, negate_involutive, negate_0. trivial. Qed. Lemma negate_zero_prod_r x y : x * -y = 0 <-> x * y = 0. Proof. etransitivity. 2: apply negate_zero_prod_l. split. - intros E. lhs_V nrapply negate_mult_distr_l. lhs nrapply negate_mult_distr_r. exact E. - intros E. lhs_V nrapply negate_mult_distr_r. lhs nrapply negate_mult_distr_l. exact E. Defined. Context `{!NoZeroDivisors R} `{forall x y:R, Stable (x = y)}. Global Instance mult_left_cancel: forall z, PropHolds (z <> 0) -> LeftCancellation (.*.) z. Proof. intros z z_nonzero x y E. apply stable. intro U. apply (mult_ne_0 z (x - y) (is_ne_0 z)). - intro. apply U. apply equal_by_zero_sum. trivial. - rewrite distribute_l, E. rewrite <-simple_distribute_l,right_inverse. apply right_absorb. Qed. Instance mult_ne_0' `{!NoZeroDivisors R} x y : PropHolds (x <> 0) -> PropHolds (y <> 0) -> PropHolds (x * y <> 0). Proof. intros Ex Ey Exy. unfold PropHolds in *. apply (no_zero_divisors x); split; eauto. Qed. Global Instance mult_right_cancel : forall z, PropHolds (z <> 0) -> RightCancellation (.*.) z. Proof. intros z ? x y p. apply stable. intro U. nrapply (mult_ne_0' (x - y) z). - exact _. - intros r. apply U, equal_by_zero_sum, r. - exact _. - lhs rapply ring_dist_right. rewrite <- negate_mult_distr_l. apply equal_by_zero_sum in p. exact p. Defined. Lemma plus_conjugate x y : x = y + x - y. Proof. rewrite (commutativity (f := (+)) y x), <- (simple_associativity (f := (+)) x y (-y)), right_inverse, right_identity. reflexivity. Qed. Lemma plus_conjugate_alt x y : x = y + (x - y). Proof. rewrite (simple_associativity (f := (+))). apply plus_conjugate. Qed. End ring_props. Section integral_domain_props. Context `{IsIntegralDomain R}. Instance intdom_nontrivial_apart `{Apart R} `{!TrivialApart R} : PropHolds (1 ≶ 0). Proof. apply apartness.ne_apart. rapply intdom_nontrivial. Qed. End integral_domain_props. (* Due to bug #2528 *) #[export] Hint Extern 6 (PropHolds (1 ≶ 0)) => eapply @intdom_nontrivial_apart : typeclass_instances. Section ringmor_props. Context `{IsRing A} `{IsRing B} `{!IsSemiRingPreserving (f : A -> B)}. Definition preserves_negate x : f (- x) = - f x. Proof. rapply preserves_inverse. Defined. Lemma preserves_minus x y : f (x - y) = f x - f y. Proof. rewrite <-preserves_negate. apply preserves_plus. Qed. Lemma injective_preserves_0 : (forall x, f x = 0 -> x = 0) -> IsInjective f. Proof. intros E1 x y E. apply equal_by_zero_sum. apply E1. rewrite preserves_minus, E. apply right_inverse. Qed. End ringmor_props. Section from_another_ring. Context `{IsCRing A} `{IsHSet B} `{Bplus : Plus B} `{Zero B} `{Bmult : Mult B} `{One B} `{Bnegate : Negate B} (f : B -> A) `{!IsInjective f} (plus_correct : forall x y, f (x + y) = f x + f y) (zero_correct : f 0 = 0) (mult_correct : forall x y, f (x * y) = f x * f y) (one_correct : f 1 = 1) (negate_correct : forall x, f (-x) = -f x). Lemma projected_ring: IsCRing B. Proof. split. - apply (groups.projected_ab_group f);assumption. - apply (groups.projected_com_monoid f mult_correct one_correct);assumption. - repeat intro; apply (injective f). rewrite plus_correct, !mult_correct, plus_correct. apply distribute_l. Qed. End from_another_ring. (* Section from_stdlib_semiring_theory. Context `(H: @semi_ring_theory R Rzero Rone Rplus Rmult Re) `{!@Setoid R Re} `{!Proper (Re ==> Re ==> Re) Rplus} `{!Proper (Re ==> Re ==> Re) Rmult}. Add Ring R2: H. Definition from_stdlib_semiring_theory: @SemiRing R Re Rplus Rmult Rzero Rone. Proof. repeat (constructor; try assumption); repeat intro ; unfold equiv, mon_unit, sg_op, zero_is_mon_unit, plus_is_sg_op, one_is_mon_unit, mult_is_sg_op, zero, mult, plus; ring. Qed. End from_stdlib_semiring_theory. Section from_stdlib_ring_theory. Context `(H: @ring_theory R Rzero Rone Rplus Rmult Rminus Rnegate Re) `{!@Setoid R Re} `{!Proper (Re ==> Re ==> Re) Rplus} `{!Proper (Re ==> Re ==> Re) Rmult} `{!Proper (Re ==> Re) Rnegate}. Add Ring R3: H. Definition from_stdlib_ring_theory: @Ring R Re Rplus Rmult Rzero Rone Rnegate. Proof. repeat (constructor; try assumption); repeat intro ; unfold equiv, mon_unit, sg_op, zero_is_mon_unit, plus_is_sg_op, one_is_mon_unit, mult_is_sg_op, mult, plus, negate; ring. Qed. End from_stdlib_ring_theory. *) Global Instance id_sr_morphism `{IsSemiCRing A}: IsSemiRingPreserving (@id A) := {}. Section morphism_composition. Context `{Mult A} `{Plus A} `{One A} `{Zero A} `{Mult B} `{Plus B} `{One B} `{Zero B} `{Mult C} `{Plus C} `{One C} `{Zero C} (f : A -> B) (g : B -> C). Instance compose_sr_morphism: IsSemiRingPreserving f -> IsSemiRingPreserving g -> IsSemiRingPreserving (g ∘ f). Proof. split; apply _. Qed. Instance invert_sr_morphism: forall `{!IsEquiv f}, IsSemiRingPreserving f -> IsSemiRingPreserving (f^-1). Proof. split; apply _. Qed. End morphism_composition. #[export] Hint Extern 4 (IsSemiRingPreserving (_ ∘ _)) => class_apply @compose_sr_morphism : typeclass_instances. #[export] Hint Extern 4 (IsSemiRingPreserving (_^-1)) => class_apply @invert_sr_morphism : typeclass_instances. Coq-HoTT-9.0/theories/Classes/theory/ua_first_isomorphism.v000066400000000000000000000206001474641544500241210ustar00rootroot00000000000000(** This file defines the kernel of a homomorphism [cong_ker], the image of a homomorphism [in_image_hom], and it proves the first isomorphism theorem [isomorphic_first_isomorphism]. The first identification theorem [id_first_isomorphism] follows. *) Require Import Basics.Notations HSet Colimits.Quotient Classes.interfaces.canonical_names Classes.theory.ua_isomorphic Classes.theory.ua_subalgebra Classes.theory.ua_quotient_algebra. Import algebra_notations quotient_algebra_notations subalgebra_notations isomorphic_notations. (** The following section defines the kernel of a homomorphism [cong_ker], and shows that it is a congruence.*) Section cong_ker. Context {σ : Signature} {A B : Algebra σ} `{IsHSetAlgebra B} (f : ∀ s, A s → B s) `{!IsHomomorphism f}. Definition cong_ker (s : Sort σ) : Relation (A s) := λ (x y : A s), f s x = f s y. (* Leave the following results about [cong_ker] opaque because they are h-props. *) Global Instance equiv_rel_ker (s : Sort σ) : EquivRel (cong_ker s). Proof. repeat constructor. - intros x y. exact inverse. - intros x y z. exact concat. Qed. Lemma path_ap_operation_ker_related {w : SymbolType σ} (β : Operation B w) (a b : FamilyProd A (dom_symboltype w)) (R : for_all_2_family_prod A A cong_ker a b) : ap_operation β (map_family_prod f a) = ap_operation β (map_family_prod f b). Proof. induction w. - reflexivity. - destruct a as [x a], b as [y b], R as [r R]. cbn. destruct r. by apply IHw. Qed. Global Instance ops_compatible_ker : OpsCompatible A cong_ker. Proof. intros u a b R. unfold cong_ker. destruct (path_homomorphism_ap_operation f u a)^. destruct (path_homomorphism_ap_operation f u b)^. by apply path_ap_operation_ker_related. Qed. Global Instance is_congruence_ker : IsCongruence A cong_ker := BuildIsCongruence A cong_ker. End cong_ker. (** The next section defines an "in image predicate", [in_image_hom]. It gives rise to the homomorphic image of a homomorphism. *) Section in_image_hom. Context `{Funext} {σ : Signature} {A B : Algebra σ} (f : ∀ s, A s → B s) {hom : IsHomomorphism f}. Definition in_image_hom (s : Sort σ) (y : B s) : HProp := merely (hfiber (f s) y). Lemma closed_under_op_in_image_hom {w : SymbolType σ} (α : Operation A w) (β : Operation B w) (P : OpPreserving f α β) : ClosedUnderOp B in_image_hom β. Proof. induction w. - exact (tr (α; P)). - intro y. refine (Trunc_rec _). intros [x p]. apply (IHw (α x)). by destruct p. Qed. Lemma is_closed_under_ops_in_image_hom : IsClosedUnderOps B in_image_hom. Proof. intro u. eapply closed_under_op_in_image_hom, hom. Qed. Global Instance is_subalgebra_predicate_in_image_hom : IsSubalgebraPredicate B in_image_hom := BuildIsSubalgebraPredicate is_closed_under_ops_in_image_hom. End in_image_hom. (** The folowing section proves the first isomorphism theorem, [isomorphic_first_isomorphism] and the first identification theorem [id_first_isomorphism]. *) Section first_isomorphism. Context `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B} (f : ∀ s, A s → B s) {hom : IsHomomorphism f}. (** The homomorphism [def_first_isomorphism] is informally given by << def_first_isomorphism s (class_of _ x) := f s x. >> *) Definition def_first_isomorphism (s : Sort σ) : (A / cong_ker f) s → (B && in_image_hom f) s. Proof. refine (Quotient_rec (cong_ker f s) _ (λ x, (f s x; tr (x; idpath))) _). intros x y p. by apply path_sigma_hprop. Defined. Lemma oppreserving_first_isomorphism {w : SymbolType σ} (α : Operation A w) (β : Operation B w) (γ : Operation (A / cong_ker f) w) (C : ClosedUnderOp B (in_image_hom f) β) (P : OpPreserving f α β) (G : ComputeOpQuotient A (cong_ker f) α γ) : OpPreserving def_first_isomorphism γ (op_subalgebra B (in_image_hom f) β C). Proof. induction w. - apply path_sigma_hprop. generalize dependent γ. refine (Quotient_ind_hprop (cong_ker f t) _ _). intros x G. destruct P. apply (related_quotient_paths (cong_ker f t) _ _ (G tt)). - refine (Quotient_ind_hprop (cong_ker f t) _ _). intro x. apply (IHw (α x) (β (f t x)) (γ (class_of _ x))). + exact (P x). + intro a. exact (G (x,a)). Qed. (* Leave [is_homomorphism_first_isomorphism] opaque because [IsHomomorphism] is an hprop when [B] is a set algebra. *) Global Instance is_homomorphism_first_isomorphism : IsHomomorphism def_first_isomorphism. Proof. intro u. apply (oppreserving_first_isomorphism u.#A). - apply hom. - apply compute_op_quotient. Qed. Definition hom_first_isomorphism : Homomorphism (A / cong_ker f) (B && in_image_hom f) := BuildHomomorphism def_first_isomorphism. Global Instance embedding_first_isomorphism (s : Sort σ) : IsEmbedding (hom_first_isomorphism s). Proof. apply isembedding_isinj_hset. refine (Quotient_ind_hprop (cong_ker f s) _ _). intro x. refine (Quotient_ind_hprop (cong_ker f s) _ _). intros y p. apply qglue. exact (p..1). Qed. Global Instance surjection_first_isomorphism (s : Sort σ) : IsSurjection (hom_first_isomorphism s). Proof. apply BuildIsSurjection. intros [x M]. refine (Trunc_rec _ M). intros [y Y]. apply tr. exists (class_of _ y). by apply path_sigma_hprop. Qed. Global Instance is_isomorphism_first_isomorphism : IsIsomorphism hom_first_isomorphism. Proof. intro s. apply isequiv_surj_emb; exact _. Qed. Theorem isomorphic_first_isomorphism : A / cong_ker f ≅ B && in_image_hom f. Proof. exact (BuildIsomorphic def_first_isomorphism). Defined. (* The first identification theorem [id_first_isomorphism] is an h-prop, so we can leave it opaque. *) Corollary id_first_isomorphism : A / cong_ker f = B && in_image_hom f. Proof. exact (id_isomorphic isomorphic_first_isomorphism). Qed. End first_isomorphism. (** The next section gives a specialization of the first isomorphism theorem, where the homomorphism is surjective. *) Section first_isomorphism_surjection. Context `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B} (f : ∀ s, A s → B s) `{!IsHomomorphism f} {S : ∀ s, IsSurjection (f s)}. Global Instance is_isomorphism_inc_first_isomorphism_surjection : IsIsomorphism (hom_inc_subalgebra B (in_image_hom f)). Proof. apply is_isomorphism_inc_improper_subalgebra. intros s x; cbn. apply center, S. Qed. (** The homomorphism [hom_first_isomorphism_surjection] is the composition of two isomorphisms, so it is an isomorphism. *) Definition hom_first_isomorphism_surjection : Homomorphism (A / cong_ker f) B := hom_compose (hom_inc_subalgebra B (in_image_hom f)) (hom_first_isomorphism f). Theorem isomorphic_first_isomorphism_surjection : A / cong_ker f ≅ B. Proof. exact (BuildIsomorphic hom_first_isomorphism_surjection). Defined. Corollary id_first_isomorphism_surjection : (A / cong_ker f) = B. Proof. exact (id_isomorphic isomorphic_first_isomorphism_surjection). Qed. End first_isomorphism_surjection. (** The next section specializes the first isomorphism theorem to the case where the homomorphism is injective. It proves that an injective homomorphism is an isomorphism between its domain and its image. *) Section first_isomorphism_inj. Context `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B} (f : ∀ s, A s → B s) `{!IsHomomorphism f} (inj : ∀ s, IsInjective (f s)). Global Instance is_isomorphism_quotient_first_isomorphism_inj : IsIsomorphism (hom_quotient (cong_ker f)). Proof. apply is_isomorphism_quotient. intros s x y p. apply inj, p. Qed. (** The homomorphism [hom_first_isomorphism_inj] is the composition of two isomorphisms, so it is an isomorphism. *) Definition hom_first_isomorphism_inj : Homomorphism A (B && in_image_hom f) := hom_compose (hom_first_isomorphism f) (hom_quotient (cong_ker f)). Definition isomorphic_first_isomorphism_inj : A ≅ B && in_image_hom f := BuildIsomorphic hom_first_isomorphism_inj. Definition id_first_isomorphism_inj : A = B && in_image_hom f := id_isomorphic isomorphic_first_isomorphism_inj. End first_isomorphism_inj. Coq-HoTT-9.0/theories/Classes/theory/ua_homomorphism.v000066400000000000000000000276051474641544500230760ustar00rootroot00000000000000(** This file implements [IsHomomorphism] and [IsIsomorphism]. It developes basic algebra homomorphisms and isomorphims. The main theorem in this file is the [path_isomorphism] theorem, which states that there is a path between isomorphic algebras. *) Require Export HoTT.Classes.interfaces.ua_setalgebra. Require Import HoTT.Types HoTT.Tactics. Import algebra_notations ne_list.notations. Section is_homomorphism. Context {σ} {A B : Algebra σ} (f : ∀ (s : Sort σ), A s → B s). (** The family of functions [f] above is [OpPreserving α β] with respect to operations [α : A s1 → A s2 → ... → A sn → A t] and [β : B s1 → B s2 → ... → B sn → B t] if << f t (α x1 x2 ... xn) = β (f s1 x1) (f s2 x2) ... (f sn xn) >> *) Fixpoint OpPreserving {w : SymbolType σ} : Operation A w → Operation B w → Type := match w with | [:s:] => λ α β, f s α = β | s ::: y => λ α β, ∀ (x : A s), OpPreserving (α x) (β (f s x)) end. Global Instance trunc_oppreserving `{Funext} {n : trunc_index} `{!IsTruncAlgebra n.+1 B} {w : SymbolType σ} (α : Operation A w) (β : Operation B w) : IsTrunc n (OpPreserving α β). Proof. induction w; exact _. Qed. (** The family of functions [f : ∀ (s : Sort σ), A s → B s] above is a homomorphism if for each function symbol [u : Symbol σ], it is [OpPreserving u.#A u.#B] with respect to the algebra operations [u.#A] and [u.#B] corresponding to [u]. *) Class IsHomomorphism : Type := oppreserving_hom : ∀ (u : Symbol σ), OpPreserving u.#A u.#B. Global Instance trunc_is_homomorphism `{Funext} {n : trunc_index} `{!IsTruncAlgebra n.+1 B} : IsTrunc n IsHomomorphism. Proof. apply istrunc_forall. Qed. End is_homomorphism. Record Homomorphism {σ} {A B : Algebra σ} : Type := BuildHomomorphism { def_hom : ∀ (s : Sort σ), A s → B s ; is_homomorphism_hom : IsHomomorphism def_hom }. Arguments Homomorphism {σ}. Arguments BuildHomomorphism {σ A B} def_hom {is_homomorphism_hom}. (** We the implicit coercion from [Homomorphism A B] to the family of functions [∀ s, A s → B s]. *) Global Coercion def_hom : Homomorphism >-> Funclass. Global Existing Instance is_homomorphism_hom. Lemma apD10_homomorphism {σ} {A B : Algebra σ} {f g : Homomorphism A B} : f = g → ∀ s, f s == g s. Proof. intro p. by destruct p. Defined. Definition SigHomomorphism {σ} (A B : Algebra σ) : Type := { def_hom : ∀ s, A s → B s | IsHomomorphism def_hom }. Lemma issig_homomorphism {σ} (A B : Algebra σ) : SigHomomorphism A B <~> Homomorphism A B. Proof. issig. Defined. Global Instance trunc_homomorphism `{Funext} {σ} {A B : Algebra σ} {n : trunc_index} `{!IsTruncAlgebra n B} : IsTrunc n (Homomorphism A B). Proof. apply (istrunc_equiv_istrunc _ (issig_homomorphism A B)). Qed. (** To find a path between two homomorphisms [f g : Homomorphism A B] it suffices to find a path between the defining families of functions and the [is_homomorphism_hom] witnesses. *) Lemma path_homomorphism {σ} {A B : Algebra σ} (f g : Homomorphism A B) (p : def_hom f = def_hom g) (q : p#(is_homomorphism_hom f) = is_homomorphism_hom g) : f = g. Proof. destruct f, g. simpl in *. by path_induction. Defined. (** To find a path between two homomorphisms [f g : Homomorphism A B] it suffices to find a path between the defining families of functions if [IsHSetAlgebra B]. *) Lemma path_hset_homomorphism `{Funext} {σ} {A B : Algebra σ} `{!IsHSetAlgebra B} (f g : Homomorphism A B) (p : def_hom f = def_hom g) : f = g. Proof. apply (path_homomorphism f g p). apply path_ishprop. Defined. (** A family of functions [f : ∀ s, A s → B s] is an isomorphism if it is a homomorphism, and for each [s : Sort σ], [f s] is an equivalence. *) (* We make [IsHomomorphism] an argument here, rather than a field, so having both [f : Homomorphism A B] and [X : IsIsomorphism f] in context does not result in having two proofs of [IsHomomorphism f] in context. *) Class IsIsomorphism {σ : Signature} {A B : Algebra σ} (f : ∀ s, A s → B s) `{!IsHomomorphism f} := isequiv_isomorphism : ∀ (s : Sort σ), IsEquiv (f s). Global Existing Instance isequiv_isomorphism. Definition equiv_isomorphism {σ : Signature} {A B : Algebra σ} (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f} : ∀ (s : Sort σ), A s <~> B s. Proof. intro s. rapply (Build_Equiv _ _ (f s)). Defined. Global Instance hprop_is_isomorphism `{Funext} {σ : Signature} {A B : Algebra σ} (f : ∀ s, A s → B s) `{!IsHomomorphism f} : IsHProp (IsIsomorphism f). Proof. apply istrunc_forall. Qed. (** Let [f : ∀ s, A s → B s] be a homomorphism. The following section proves that [f] is "OpPreserving" with respect to uncurried algebra operations in the sense that << f t (α (x1,x2,...,xn,tt)) = β (f s1 x1,f s2 x1,...,f sn xn,tt) >> for all [(x1,x2,...,xn,tt) : FamilyProd A [s1;s2;...;sn]], where [α] and [β] are uncurried algebra operations in [A] and [B] respectively. *) Section homomorphism_ap_operation. Context {σ : Signature} {A B : Algebra σ}. Lemma path_oppreserving_ap_operation (f : ∀ s, A s → B s) {w : SymbolType σ} (a : FamilyProd A (dom_symboltype w)) (α : Operation A w) (β : Operation B w) (P : OpPreserving f α β) : f (cod_symboltype w) (ap_operation α a) = ap_operation β (map_family_prod f a). Proof. induction w. - assumption. - destruct a as [x a]. apply IHw. apply P. Defined. (** A homomorphism [f : ∀ s, A s → B s] satisfies << f t (α (a1, a2, ..., an, tt)) = β (f s1 a1, f s2 a2, ..., f sn an, tt) >> where [(a1, a2, ..., an, tt) : FamilyProd A [s1; s2; ...; sn]] and [α], [β] uncurried versions of [u.#A], [u.#B] respectively. *) Lemma path_homomorphism_ap_operation (f : ∀ s, A s → B s) `{!IsHomomorphism f} : ∀ (u : Symbol σ) (a : FamilyProd A (dom_symboltype (σ u))), f (cod_symboltype (σ u)) (ap_operation u.#A a) = ap_operation u.#B (map_family_prod f a). Proof. intros u a. by apply path_oppreserving_ap_operation. Defined. End homomorphism_ap_operation. (** The next section shows that the family of identity functions, [λ s x, x] is an isomorphism. *) Section hom_id. Context {σ} (A : Algebra σ). Global Instance is_homomorphism_id : IsHomomorphism (λ s (x : A s), x). Proof. intro u. generalize u.#A. intro w. induction (σ u). - reflexivity. - by intro x. Defined. Global Instance is_isomorphism_id : IsIsomorphism (λ s (x : A s), x). Proof. intro s. exact _. Qed. Definition hom_id : Homomorphism A A := BuildHomomorphism (λ s x, x). End hom_id. (** Suppose [f : ∀ s, A s → B s] is an isomorphism. The following section shows that the family of inverse functions, [λ s, (f s)^-1] is an isomorphism. *) Section hom_inv. Context {σ} {A B : Algebra σ} (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}. Global Instance is_homomorphism_inv : IsHomomorphism (λ s, (f s)^-1). Proof. intro u. generalize u.#A u.#B (oppreserving_hom f u). intros a b P. induction (σ u). - destruct P. apply (eissect (f t)). - intro. apply IHs. exact (transport (λ y, OpPreserving f _ (b y)) (eisretr (f t) x) (P (_^-1 x))). Defined. Global Instance is_isomorphism_inv : IsIsomorphism (λ s, (f s)^-1). Proof. intro s. exact _. Qed. Definition hom_inv : Homomorphism B A := BuildHomomorphism (λ s, (f s)^-1). End hom_inv. (** Let [f : ∀ s, A s → B s] and [g : ∀ s, B s → C s]. The next section shows that composition given by [λ (s : Sort σ), g s o f s] is again a homomorphism. If both [f] and [g] are isomorphisms, then the composition is an isomorphism. *) Section hom_compose. Context {σ} {A B C : Algebra σ}. Lemma oppreserving_compose (g : ∀ s, B s → C s) `{!IsHomomorphism g} (f : ∀ s, A s → B s) `{!IsHomomorphism f} {w : SymbolType σ} (α : Operation A w) (β : Operation B w) (γ : Operation C w) (G : OpPreserving g β γ) (F : OpPreserving f α β) : OpPreserving (λ s, g s o f s) α γ. Proof. induction w; simpl in *. - by path_induction. - intro x. by apply (IHw _ (β (f _ x))). Defined. Global Instance is_homomorphism_compose (g : ∀ s, B s → C s) `{!IsHomomorphism g} (f : ∀ s, A s → B s) `{!IsHomomorphism f} : IsHomomorphism (λ s, g s o f s). Proof. intro u. by apply (oppreserving_compose g f u.#A u.#B u.#C). Defined. Global Instance is_isomorphism_compose (g : ∀ s, B s → C s) `{IsIsomorphism σ B C g} (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f} : IsIsomorphism (λ s, g s o f s). Proof. intro s. apply isequiv_compose. Qed. Definition hom_compose (g : Homomorphism B C) (f : Homomorphism A B) : Homomorphism A C := BuildHomomorphism (λ s, g s o f s). End hom_compose. (** The following section shows that there is a path between isomorphic algebras. *) Section path_isomorphism. Context `{Univalence} {σ : Signature} {A B : Algebra σ}. (** Let [F G : I → Type]. If [f : ∀ (i:I), F i <~> G i] is a family of equivalences, then by function extensionality composed with univalence there is a path [F = G]. *) Local Notation path_equiv_family f := (path_forall _ _ (λ i, path_universe (f i))). (** Given a family of equivalences [f : ∀ (s : Sort σ), A s <~> B s] which is [OpPreserving f α β] with respect to algebra operations << α : A s1 → A s2 → ... → A sn → A t β : B s1 → B s2 → ... → B sn → B t >> By transporting [α] along the path [path_equiv_family f] we find a path from the transported operation [α] to [β]. *) Lemma path_operations_equiv {w : SymbolType σ} (α : Operation A w) (β : Operation B w) (f : ∀ (s : Sort σ), A s <~> B s) (P : OpPreserving f α β) : transport (λ C : Carriers σ, Operation C w) (path_equiv_family f) α = β. Proof. induction w; simpl in *. - transport_path_forall_hammer. exact (ap10 (transport_idmap_path_universe (f t)) α @ P). - funext y. transport_path_forall_hammer. rewrite transport_forall_constant. rewrite transport_arrow_toconst. rewrite (transport_path_universe_V (f t)). apply IHw. specialize (P ((f t)^-1 y)). by rewrite (eisretr (f t) y) in P. Qed. (** Suppose [u : Symbol σ] is a function symbol. Recall that [u.#A] is notation for [operations A u : Operation A (σ u)]. This is the algebra operation corresponding to function symbol [u]. *) (** An isomorphism [f : ∀ s, A s → B s] induces a family of equivalences [e : ∀ (s : Sort σ), A s <~> B s]. Let [u : Symbol σ] be a function symbol. Since [f] is a homomorphism, the induced family of equivalences [e] satisfies [OpPreserving e (u.#A) (u.#B)]. By [path_operations_equiv] above, we can then transport [u.#A] along the path [path_equiv_family e] and obtain a path to [u.#B]. *) Lemma path_operations_isomorphism (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f} (u : Symbol σ) : transport (λ C : Carriers σ, Operation C (σ u)) (path_equiv_family (equiv_isomorphism f)) u.#A = u.#B. Proof. by apply path_operations_equiv. Defined. (** If there is an isomorphism [f : ∀ s, A s → B s] then [A = B]. *) Theorem path_isomorphism (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f} : A = B. Proof. apply (path_algebra _ _ (path_equiv_family (equiv_isomorphism f))). (* Make the last part abstract because it relies on [path_operations_equiv], which is opaque. In cases where the involved algebras are set algebras, then this part is a mere proposition. *) abstract ( funext u; exact (transport_forall_constant _ _ u @ path_operations_isomorphism f u)). Defined. End path_isomorphism. Coq-HoTT-9.0/theories/Classes/theory/ua_isomorphic.v000066400000000000000000000117261474641544500225260ustar00rootroot00000000000000(** This file develops [Isomorphic], [≅]. See ua_homomorphism.v for [IsHomomorphism] and [IsIsomorphism]. *) Require Export HoTT.Classes.theory.ua_homomorphism. Require Import HoTT.Types HoTT.Tactics. (** Two algebras [A B : Algebra σ] are isomorphic if there is an isomorphism [∀ s, A s → B s]. *) Record Isomorphic {σ : Signature} (A B : Algebra σ) := BuildIsomorphic { def_isomorphic : ∀ s, A s → B s ; is_homomorphism_isomorphic : IsHomomorphism def_isomorphic ; is_isomorphism_isomorphic : IsIsomorphism def_isomorphic }. Arguments BuildIsomorphic {σ A B} def_isomorphic {is_homomorphism_isomorphic} {is_isomorphism_isomorphic}. Arguments def_isomorphic {σ A B}. Arguments is_homomorphism_isomorphic {σ A B}. Arguments is_isomorphism_isomorphic {σ A B}. Global Existing Instance is_homomorphism_isomorphic. Global Existing Instance is_isomorphism_isomorphic. Module isomorphic_notations. Global Notation "A ≅ B" := (Isomorphic A B) : Algebra_scope. End isomorphic_notations. Import isomorphic_notations. Definition SigIsomorphic {σ : Signature} (A B : Algebra σ) := { def_iso : ∀ s, A s → B s | { _ : IsHomomorphism def_iso | IsIsomorphism def_iso }}. Lemma issig_isomorphic {σ : Signature} (A B : Algebra σ) : SigIsomorphic A B <~> A ≅ B. Proof. issig. Defined. (** Isomorphic algebras can be identified [A ≅ B → A = B]. *) Corollary id_isomorphic `{Univalence} {σ} {A B : Algebra σ} (e : A ≅ B) : A = B. Proof. exact (path_isomorphism (def_isomorphic e)). Defined. (** Identified algebras are isomorophic [A = B → A ≅ B] *) Lemma isomorphic_id {σ} {A B : Algebra σ} (p : A = B) : A ≅ B. Proof. destruct p. exact (BuildIsomorphic (hom_id A)). Defined. (** To find a path between two witnesses [F G : A ≅ B], it suffices to find a path between the defining families of functions and the [is_homomorphism_hom] witnesses. *) Lemma path_isomorphic `{Funext} {σ : Signature} {A B : Algebra σ} (F G : A ≅ B) (a : def_isomorphic F = def_isomorphic G) (b : a#(is_homomorphism_isomorphic F) = is_homomorphism_isomorphic G) : F = G. Proof. apply (ap (issig_isomorphic A B)^-1)^-1. srapply path_sigma. - exact a. - apply path_sigma_hprop. refine (ap _ (transport_sigma _ _) @ _). apply b. Defined. (** Suppose [IsHSetAlgebra B]. To find a path between two isomorphic witnesses [F G : A ≅ B], it suffices to find a path between the defining families of functions. *) Lemma path_hset_isomorphic `{Funext} {σ : Signature} {A B : Algebra σ} `{IsHSetAlgebra B} (F G : A ≅ B) (a : def_isomorphic F = def_isomorphic G) : F = G. Proof. apply (path_isomorphic F G a). apply path_ishprop. Defined. Section path_def_isomorphic_id_transport. Context {σ : Signature} {A B : Algebra σ}. Lemma path_def_isomorphic_id_transport_dom (p : A = B) : def_isomorphic (isomorphic_id p) = transport (λ C, ∀ s, C s → B s) (ap carriers p)^ (hom_id B). Proof. by path_induction. Defined. Lemma path_def_isomorphic_id_transport_cod (p : A = B) : def_isomorphic (isomorphic_id p) = transport (λ C, ∀ s, A s → C s) (ap carriers p) (hom_id A). Proof. by path_induction. Defined. End path_def_isomorphic_id_transport. (** If [IsHSetAlgebra A], then [path_isomorphism] maps the identity homomorphism of [A] to the identity path. *) (* I suspect that the following lemma holds even when [A] is not a set algebra. To show this, [path_isomorphism] and [path_operations_equiv] should be made transparent, which they are not at the moment. *) Lemma path_path_isomorphism_hom_id_hset `{Univalence} {σ : Signature} (A : Algebra σ) `{IsHSetAlgebra A} : path_isomorphism (hom_id A) = idpath. Proof. apply path_path_hset_algebra. rewrite path_ap_carriers_path_algebra. apply (paths_ind (λ s, idpath) (λ f _, path_forall A A f = idpath)). - apply path_forall_1. - intros. funext s. symmetry. rewrite (path_ishprop _ (isequiv_idmap (A s))). apply path_universe_1. Qed. (** The following section shows that [isomorphic_id] is an equivalence with inverse [id_isomorphic]. *) Section isequiv_isomorphic_id. Context `{Univalence} {σ} (A B : Algebra σ) `{IsHSetAlgebra B}. Lemma sect_id_isomorphic : (@isomorphic_id σ A B) o id_isomorphic == idmap. Proof. intro F. apply path_hset_isomorphic. rewrite path_def_isomorphic_id_transport_cod. funext s x. rewrite !transport_forall_constant. rewrite path_ap_carriers_path_algebra. transport_path_forall_hammer. apply transport_path_universe. Qed. Lemma sect_isomorphic_id : id_isomorphic o (@isomorphic_id σ A B) == idmap. Proof. intro p. destruct p. apply path_path_isomorphism_hom_id_hset. exact _. Qed. Global Instance isequiv_isomorphic_id : IsEquiv (@isomorphic_id σ A B) := isequiv_adjointify isomorphic_id id_isomorphic sect_id_isomorphic sect_isomorphic_id. End isequiv_isomorphic_id. Coq-HoTT-9.0/theories/Classes/theory/ua_prod_algebra.v000066400000000000000000000131601474641544500227650ustar00rootroot00000000000000Require Import HoTT.Types.Bool HoTT.Classes.theory.ua_homomorphism. Import algebra_notations ne_list.notations. (** The following section defines product algebra [ProdAlgebra]. Section [bin_prod_algebra] specialises the definition to binary product algebra. *) Section prod_algebra. Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ). Definition carriers_prod_algebra : Carriers σ := λ (s : Sort σ), ∀ (i:I), A i s. Fixpoint op_prod_algebra (w : SymbolType σ) : (∀ i, Operation (A i) w) → Operation carriers_prod_algebra w := match w return (∀ i, Operation (A i) w) → Operation carriers_prod_algebra w with | [:_:] => idmap | _ ::: g => λ f p, op_prod_algebra g (λ i, f i (p i)) end. Definition ops_prod_algebra (u : Symbol σ) : Operation carriers_prod_algebra (σ u) := op_prod_algebra (σ u) (λ (i:I), u.#(A i)). Definition ProdAlgebra : Algebra σ := BuildAlgebra carriers_prod_algebra ops_prod_algebra. Global Instance trunc_prod_algebra {n : trunc_index} `{!∀ i, IsTruncAlgebra n (A i)} : IsTruncAlgebra n ProdAlgebra. Proof. intro s. exact _. Qed. End prod_algebra. (** The next section defines the product projection homomorphisms. *) Section hom_proj_prod_algebra. Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ). Definition def_proj_prod_algebra (i:I) (s : Sort σ) (c : ProdAlgebra I A s) : A i s := c i. Lemma oppreserving_proj_prod_algebra {w : SymbolType σ} (i : I) (v : ∀ i : I, Operation (A i) w) (α : Operation (A i) w) (P : v i = α) : OpPreserving (def_proj_prod_algebra i) (op_prod_algebra I A w v) α. Proof. induction w. - exact P. - intro p. apply (IHw (λ i, v i (p i)) (α (p i))). f_ap. Defined. Global Instance is_homomorphism_proj_prod_algebra (i:I) : IsHomomorphism (def_proj_prod_algebra i). Proof. intro u. by apply oppreserving_proj_prod_algebra. Defined. Definition hom_proj_prod_algebra (i : I) : Homomorphism (ProdAlgebra I A) (A i) := BuildHomomorphism (def_proj_prod_algebra i). End hom_proj_prod_algebra. (** The product algebra univarsal mapping property [ump_prod_algebra]. *) Section ump_prod_algebra. Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ) (C : Algebra σ). Definition hom_prod_algebra_mapout (f : Homomorphism C (ProdAlgebra I A)) (i:I) : Homomorphism C (A i) := hom_compose (hom_proj_prod_algebra I A i) f. Definition def_prod_algebra_mapin (f : ∀ (i:I) s, C s → A i s) : ∀ (s : Sort σ) , C s → ProdAlgebra I A s := λ (s : Sort σ) (x : C s) (i : I), f i s x. Lemma oppreserving_prod_algebra_mapin {w : SymbolType σ} (f : ∀ (i:I) s, C s → A i s) (α : ∀ (i:I), Operation (A i) w) (β : Operation C w) (P : ∀ (i:I), OpPreserving (f i) β (α i)) : OpPreserving (def_prod_algebra_mapin f) β (op_prod_algebra I A w (λ i, α i)). Proof. induction w. - funext i. apply P. - intro x. apply IHw. intro i. apply P. Defined. Global Instance is_homomorphism_prod_algebra_mapin (f : ∀ (i:I), Homomorphism C (A i)) : IsHomomorphism (def_prod_algebra_mapin f). Proof. intro u. apply oppreserving_prod_algebra_mapin. intro i. apply f. Defined. Definition hom_prod_algebra_mapin (f : ∀ i, Homomorphism C (A i)) : Homomorphism C (ProdAlgebra I A) := BuildHomomorphism (def_prod_algebra_mapin f). (** Given a family of homomorphisms [h : ∀ (i:I), Homomorphism C (A i)] there is a unique homomorphism [f : Homomorphism C (ProdAlgebra I A)] such that [h i = hom_compose (pr i) f], where << pr i = hom_proj_prod_algebra I A i >> is the ith projection homomorphism. *) Lemma ump_prod_algebra `{!∀ i, IsHSetAlgebra (A i)} : (∀ (i:I), Homomorphism C (A i)) <~> Homomorphism C (ProdAlgebra I A). Proof. apply (equiv_adjointify hom_prod_algebra_mapin hom_prod_algebra_mapout). - intro f. by apply path_hset_homomorphism. - intro f. funext i. by apply path_hset_homomorphism. Defined. End ump_prod_algebra. (** Binary product algebra. *) Section bin_prod_algebra. Context `{Funext} {σ : Signature} (A B : Algebra σ). Definition bin_prod_algebras (b:Bool) : Algebra σ := if b then B else A. Global Instance trunc_bin_prod_algebras {n : trunc_index} `{!IsTruncAlgebra n A} `{!IsTruncAlgebra n B} : ∀ (b:Bool), IsTruncAlgebra n (bin_prod_algebras b). Proof. intros []; exact _. Qed. Definition BinProdAlgebra : Algebra σ := ProdAlgebra Bool bin_prod_algebras. Definition fst_prod_algebra : Homomorphism BinProdAlgebra A := hom_proj_prod_algebra Bool bin_prod_algebras false. Definition snd_prod_algebra : Homomorphism BinProdAlgebra B := hom_proj_prod_algebra Bool bin_prod_algebras true. End bin_prod_algebra. Module prod_algebra_notations. Global Notation "A × B" := (BinProdAlgebra A B) : Algebra_scope. End prod_algebra_notations. Import prod_algebra_notations. (** Specialisation of the product algebra univarsal mapping property to binary product. *) Section ump_bin_prod_algebra. Context `{Funext} {σ : Signature} (A B C : Algebra σ) `{!IsHSetAlgebra A} `{!IsHSetAlgebra B}. Lemma ump_bin_prod_algebra : Homomorphism C A * Homomorphism C B <~> Homomorphism C (A × B). Proof. set (k := λ (b:Bool), Homomorphism C (bin_prod_algebras A B b)). exact (equiv_compose (ump_prod_algebra Bool (bin_prod_algebras A B) C) (equiv_bool_forall_prod k)^-1). Defined. End ump_bin_prod_algebra. Coq-HoTT-9.0/theories/Classes/theory/ua_quotient_algebra.v000066400000000000000000000271201474641544500236720ustar00rootroot00000000000000Require Import Basics.Notations. Require Export HoTT.Classes.interfaces.ua_congruence. Require Import HSet Colimits.Quotient Spaces.List.Core Classes.interfaces.canonical_names Classes.theory.ua_homomorphism. Local Open Scope list_scope. Import algebra_notations ne_list.notations. Section quotient_algebra. Context `{Funext} {σ : Signature} (A : Algebra σ) (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}. (** The quotient algebra carriers is the family of set-quotients induced by [Φ]. *) Definition carriers_quotient_algebra : Carriers σ := λ s, Quotient (Φ s). (** Specialization of [quotient_ind_prop]. Suppose [P : FamilyProd carriers_quotient_algebra w → Type] and [∀ a, IsHProp (P a)]. To show that [P a] holds for all [a : FamilyProd carriers_quotient_algebra w], it is sufficient to show that [P (class_of _ x1, ..., class_of _ xn, tt)] holds for all [(x1, ..., xn, tt) : FamilyProd A w]. *) Fixpoint quotient_ind_prop_family_prod {w : list (Sort σ)} : ∀ (P : FamilyProd carriers_quotient_algebra w → Type) `{!∀ a, IsHProp (P a)} (dclass : ∀ x, P (map_family_prod (λ s, class_of (Φ s)) x)) (a : FamilyProd carriers_quotient_algebra w), P a := match w with | nil => λ P _ dclass 'tt, dclass tt | s :: w' => λ P _ dclass a, Quotient_ind_hprop (Φ s) (λ a, ∀ b, P (a,b)) (λ a, quotient_ind_prop_family_prod (λ c, P (class_of (Φ s) a, c)) (λ c, dclass (a, c))) (fst a) (snd a) end. (** Let [f : Operation A w], [g : Operation carriers_quotient_algebra w]. If [g] is the quotient algebra operation induced by [f], then we want [ComputeOpQuotient f g] to hold, since then << β (class_of _ a1, class_of _ a2, ..., class_of _ an) = class_of _ (α (a1, a2, ..., an)), >> where [α] is the uncurried [f] operation and [β] is the uncurried [g] operation. *) Definition ComputeOpQuotient {w : SymbolType σ} (f : Operation A w) (g : Operation carriers_quotient_algebra w) := ∀ (a : FamilyProd A (dom_symboltype w)), ap_operation g (map_family_prod (λ s, class_of (Φ s)) a) = class_of (Φ (cod_symboltype w)) (ap_operation f a). Local Notation QuotOp w := (∀ (f : Operation A w), OpCompatible A Φ f → ∃ g : Operation carriers_quotient_algebra w, ComputeOpQuotient f g) (only parsing). Local Notation op_qalg_cons q f P x := (q _ (f x) (op_compatible_cons Φ _ _ f x P)).1 (only parsing). Lemma op_quotient_algebra_well_def (q : ∀ (w : SymbolType σ), QuotOp w) (s : Sort σ) (w : SymbolType σ) (f : Operation A (s ::: w)) (P : OpCompatible A Φ f) (x y : A s) (C : Φ s x y) : op_qalg_cons q f P x = op_qalg_cons q f P y. Proof. apply (@path_forall_ap_operation _ σ). apply quotient_ind_prop_family_prod; try exact _. intro a. destruct (q _ _ (op_compatible_cons Φ s w f x P)) as [g1 P1]. destruct (q _ _ (op_compatible_cons Φ s w f y P)) as [g2 P2]. refine ((P1 a) @ _ @ (P2 a)^). apply qglue. exact (P (x,a) (y,a) (C, reflexive_for_all_2_family_prod A Φ a)). Defined. (* Given an operation [f : A s1 → A s2 → ... A sn → A t] and a witness [C : OpCompatible A Φ f], then [op_quotient_algebra f C] is a dependent pair with first component an operation [g : Q s1 → Q s2 → ... Q sn → Q t], where [Q := carriers_quotient_algebra], and second component a proof of [ComputeOpQuotient f g]. The first component [g] is the quotient algebra operation corresponding to [f]. The second component proof of [ComputeOpQuotient f g] is passed to the [op_quotient_algebra_well_def] lemma, which is used to show that the quotient algebra operation [g] is well defined, i.e. that << Φ s1 x1 y1 ∧ Φ s2 x2 y2 ∧ ... ∧ Φ sn xn yn >> implies << g (class_of _ x1) (class_of _ x2) ... (class_of _ xn) = g (class_of _ y1) (class_of _ y2) ... (class_of _ yn). >> *) Fixpoint op_quotient_algebra {w : SymbolType σ} : QuotOp w. Proof. refine ( match w return QuotOp w with | [:s:] => λ (f : A s) P, (class_of (Φ s) f; λ a, idpath) | s ::: w' => λ (f : A s → Operation A w') P, (Quotient_rec (Φ s) _ (λ (x : A s), op_qalg_cons op_quotient_algebra f P x) (op_quotient_algebra_well_def op_quotient_algebra s w' f P) ; _) end ). intros [x a]. apply (op_quotient_algebra w' (f x) (op_compatible_cons Φ s w' f x P)). Defined. Definition ops_quotient_algebra (u : Symbol σ) : Operation carriers_quotient_algebra (σ u) := (op_quotient_algebra u.#A (ops_compatible_cong A Φ u)).1. (** Definition of quotient algebra. See Lemma [compute_op_quotient] below for the computation rule of quotient algebra operations. *) Definition QuotientAlgebra : Algebra σ := BuildAlgebra carriers_quotient_algebra ops_quotient_algebra. (** The quotient algebra carriers are always sets. *) Global Instance hset_quotient_algebra : IsHSetAlgebra QuotientAlgebra. Proof. intro s. exact _. Qed. (** The following lemma gives the computation rule for the quotient algebra operations. It says that for [(a1, a2, ..., an) : A s1 * A s2 * ... * A sn], << β (class_of _ a1, class_of _ a2, ..., class_of _ an) = class_of _ (α (a1, a2, ..., an)) >> where [α] is the uncurried [u.#A] operation and [β] is the uncurried [u.#QuotientAlgebra] operation. *) Lemma compute_op_quotient (u : Symbol σ) : ComputeOpQuotient u.#A u.#QuotientAlgebra. Proof. apply op_quotient_algebra. Defined. End quotient_algebra. Module quotient_algebra_notations. Global Notation "A / Φ" := (QuotientAlgebra A Φ) : Algebra_scope. End quotient_algebra_notations. Import quotient_algebra_notations. (** The next section shows that A/Φ = A/Ψ whenever [Φ s x y <-> Ψ s x y] for all [s], [x], [y]. *) Section path_quotient_algebra. Context {σ : Signature} (A : Algebra σ) (Φ : ∀ s, Relation (A s)) {CΦ : IsCongruence A Φ} (Ψ : ∀ s, Relation (A s)) {CΨ : IsCongruence A Ψ}. Lemma path_quotient_algebra `{Funext} (p : Φ = Ψ) : A/Φ = A/Ψ. Proof. by destruct p, (path_ishprop CΦ CΨ). Defined. Lemma path_quotient_algebra_iff `{Univalence} (R : ∀ s x y, Φ s x y <-> Ψ s x y) : A/Φ = A/Ψ. Proof. apply path_quotient_algebra. funext s x y. refine (path_universe_uncurried _). apply equiv_iff_hprop; apply R. Defined. End path_quotient_algebra. (** The following section defines the quotient homomorphism [hom_quotient : Homomorphism A (A/Φ)]. *) Section hom_quotient. Context `{Funext} {σ} {A : Algebra σ} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}. Definition def_hom_quotient : ∀ (s : Sort σ), A s → (A/Φ) s := λ s x, class_of (Φ s) x. Lemma oppreserving_quotient `{Funext} (w : SymbolType σ) (g : Operation (A/Φ) w) (α : Operation A w) (G : ComputeOpQuotient A Φ α g) : OpPreserving def_hom_quotient α g. Proof. unfold ComputeOpQuotient in G. induction w; cbn in *. - by destruct (G tt)^. - intro x. apply IHw. intro a. apply (G (x,a)). Defined. Global Instance is_homomorphism_quotient `{Funext} : IsHomomorphism def_hom_quotient. Proof. intro u. apply oppreserving_quotient, compute_op_quotient. Defined. Definition hom_quotient : Homomorphism A (A/Φ) := BuildHomomorphism def_hom_quotient. Global Instance surjection_quotient : ∀ s, IsSurjection (hom_quotient s). Proof. intro s. apply issurj_class_of. Qed. End hom_quotient. (** If [Φ s x y] implies [x = y], then homomorphism [hom_quotient Φ] is an isomorphism. *) Global Instance is_isomorphism_quotient `{Univalence} {σ : Signature} {A : Algebra σ} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ} (P : ∀ s x y, Φ s x y → x = y) : IsIsomorphism (hom_quotient Φ). Proof. intro s. apply isequiv_surj_emb; [exact _ |]. apply isembedding_isinj_hset. intros x y p. by apply P, (related_quotient_paths (Φ s)). Qed. (** This section develops the universal mapping property [ump_quotient_algebra] of the quotient algebra. *) Section ump_quotient_algebra. Context `{Univalence} {σ} {A B : Algebra σ} `{!IsHSetAlgebra B} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}. (** In the nested section below we show that if [f : Homomorphism A B] maps elements related by [Φ] to equal elements, there is a [Homomorphism (A/Φ) B] out of the quotient algebra satisfying [compute_quotient_algebra_mapout] below. *) Section quotient_algebra_mapout. Context (f : Homomorphism A B) (R : ∀ s (x y : A s), Φ s x y → f s x = f s y). Definition def_hom_quotient_algebra_mapout : ∀ (s : Sort σ), (A/Φ) s → B s := λ s, (equiv_quotient_ump (Φ s) (Build_HSet (B s)))^-1 (f s; R s). Lemma oppreserving_quotient_algebra_mapout {w : SymbolType σ} (g : Operation (A/Φ) w) (α : Operation A w) (β : Operation B w) (G : ComputeOpQuotient A Φ α g) (P : OpPreserving f α β) : OpPreserving def_hom_quotient_algebra_mapout g β. Proof. unfold ComputeOpQuotient in G. induction w; cbn in *. - destruct (G tt)^. apply P. - refine (Quotient_ind_hprop (Φ t) _ _). intro x. apply (IHw (g (class_of (Φ t) x)) (α x) (β (f t x))). + intro a. apply (G (x,a)). + apply P. Defined. Global Instance is_homomorphism_quotient_algebra_mapout : IsHomomorphism def_hom_quotient_algebra_mapout. Proof. intro u. eapply oppreserving_quotient_algebra_mapout. - apply compute_op_quotient. - apply f. Defined. Definition hom_quotient_algebra_mapout : Homomorphism (A/Φ) B := BuildHomomorphism def_hom_quotient_algebra_mapout. (** The computation rule for [hom_quotient_algebra_mapout] is << hom_quotient_algebra_mapout s (class_of (Φ s) x) = f s x. >> *) Lemma compute_quotient_algebra_mapout : ∀ (s : Sort σ) (x : A s), hom_quotient_algebra_mapout s (class_of (Φ s) x) = f s x. Proof. reflexivity. Defined. End quotient_algebra_mapout. Definition hom_quotient_algebra_mapin (g : Homomorphism (A/Φ) B) : Homomorphism A B := hom_compose g (hom_quotient Φ). Lemma ump_quotient_algebra_lr : {f : Homomorphism A B | ∀ s (x y : A s), Φ s x y → f s x = f s y} → Homomorphism (A/Φ) B. Proof. intros [f P]. exists (hom_quotient_algebra_mapout f P). exact _. Defined. Lemma ump_quotient_algebra_rl : Homomorphism (A/Φ) B → {f : Homomorphism A B | ∀ s (x y : A s), Φ s x y → f s x = f s y}. Proof. intro g. exists (hom_quotient_algebra_mapin g). intros s x y E. exact (transport (λ z, g s (class_of (Φ s) x) = g s z) (qglue E) idpath). Defined. (** The universal mapping property of the quotient algebra. For each homomorphism [f : Homomorphism A B], mapping elements related by [Φ] to equal elements, there is a unique homomorphism [g : Homomorphism (A/Φ) B] satisfying << f = hom_compose g (hom_quotient Φ). >> *) Lemma ump_quotient_algebra : {f : Homomorphism A B | ∀ s (x y : A s), Φ s x y → f s x = f s y} <~> Homomorphism (A/Φ) B. Proof. apply (equiv_adjointify ump_quotient_algebra_lr ump_quotient_algebra_rl). - intro G. apply path_hset_homomorphism. funext s. exact (eissect (equiv_quotient_ump (Φ s) _) (G s)). - intro F. apply path_sigma_hprop. by apply path_hset_homomorphism. Defined. End ump_quotient_algebra. Coq-HoTT-9.0/theories/Classes/theory/ua_second_isomorphism.v000066400000000000000000000162611474641544500242550ustar00rootroot00000000000000(** The second isomorphism theorem [isomorphic_second_isomorphism]. *) Require Import Basics.Notations HSet Colimits.Quotient Classes.interfaces.canonical_names Classes.theory.ua_isomorphic Classes.theory.ua_subalgebra Classes.theory.ua_quotient_algebra. Import algebra_notations quotient_algebra_notations subalgebra_notations isomorphic_notations. Local Notation i := (hom_inc_subalgebra _ _). (** This section defines [cong_trace] and proves that it is a congruence, the restriction of a congruence to a subalgebra. *) Section cong_trace. Context {σ : Signature} {A : Algebra σ} (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}. Definition cong_trace (s : Sort σ) (x : (A&&P) s) (y : (A&&P) s) := Φ s (i s x) (i s y). Global Instance equiv_rel_trace_congruence (s : Sort σ) : EquivRel (cong_trace s). Proof. unfold cong_trace. constructor. - intros [y Y]. reflexivity. - intros [y1 Y1] [y2 Y2] S. by symmetry. - intros [y1 Y1] [y2 Y2] [y3 Y3] S T. by transitivity y2. Qed. Lemma for_all_2_family_prod_trace_congruence {w : SymbolType σ} (a b : FamilyProd (A&&P) (dom_symboltype w)) (R : for_all_2_family_prod (A&&P) (A&&P) cong_trace a b) : for_all_2_family_prod A A Φ (map_family_prod i a) (map_family_prod i b). Proof with try assumption. induction w... destruct a as [x a], b as [y b], R as [C R]. split... apply IHw... Qed. Global Instance ops_compatible_trace_trace : OpsCompatible (A&&P) cong_trace. Proof. intros u a b R. refine (transport (λ X, Φ _ X _) (path_homomorphism_ap_operation i u a)^ _). refine (transport (λ X, Φ _ _ X) (path_homomorphism_ap_operation i u b)^ _). apply (ops_compatible_cong A Φ). exact (for_all_2_family_prod_trace_congruence a b R). Qed. Global Instance is_congruence_trace : IsCongruence (A&&P) cong_trace. Proof. apply (@BuildIsCongruence _ (A&&P) cong_trace); [intros; apply (is_mere_relation_cong A Φ) | exact _ ..]. Qed. End cong_trace. (** The following section defines the [is_subalgebra_class] subalgebra predicate, which induces a subalgebra of [A/Φ]. *) Section is_subalgebra_class. Context `{Univalence} {σ : Signature} {A : Algebra σ} (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}. Definition is_subalgebra_class (s : Sort σ) (x : (A/Φ) s) : HProp := hexists (λ (y : (A&&P) s), in_class (Φ s) x (i s y)). Lemma op_closed_subalgebra_is_subalgebra_class {w : SymbolType σ} (γ : Operation (A/Φ) w) (α : Operation A w) (Q : ComputeOpQuotient A Φ α γ) (C : ClosedUnderOp A P α) : ClosedUnderOp (A/Φ) is_subalgebra_class γ. Proof. induction w. - specialize (Q tt). apply tr. exists (α; C). cbn in Q. destruct Q^. exact (EquivRel_Reflexive α). - refine (Quotient_ind_hprop (Φ t) _ _). intro x. refine (Trunc_rec _). intros [y R]. apply (IHw (γ (class_of (Φ t) x)) (α (i t y))). + intro a. destruct (qglue R)^. apply (Q (i t y,a)). + apply C. exact y.2. Qed. Definition is_closed_under_ops_is_subalgebra_class : IsClosedUnderOps (A/Φ) is_subalgebra_class. Proof. intro u. eapply op_closed_subalgebra_is_subalgebra_class. - apply compute_op_quotient. - apply is_closed_under_ops_subalgebra_predicate. exact _. Qed. Global Instance is_subalgebra_predicate_is_subalgebra_class : IsSubalgebraPredicate (A/Φ) is_subalgebra_class. Proof. apply BuildIsSubalgebraPredicate. apply is_closed_under_ops_is_subalgebra_class. Qed. End is_subalgebra_class. (** The next section proves the second isomorphism theorem, << (A&&P) / (cong_trace P Φ) ≅ (A/Φ) && (is_subalgebra_class P Φ). >> *) (* There is an alternative proof using the first isomorphism theorem, but the direct proof below seems simpler in HoTT. *) Section second_isomorphism. Context `{Univalence} {σ : Signature} (A : Algebra σ) (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}. Local Notation Ψ := (cong_trace P Φ). Local Notation Q := (is_subalgebra_class P Φ). Definition def_second_isomorphism (s : Sort σ) : ((A&&P) / Ψ) s → ((A/Φ) && Q) s := Quotient_rec (Ψ s) _ (λ (x : (A&&P) s), (class_of (Φ s) (i s x); tr (x; EquivRel_Reflexive x))) (λ (x y : (A&&P) s) (T : Ψ s x y), path_sigma_hprop (class_of (Φ s) (i s x); _) (class_of (Φ s) (i s y); _) (@qglue _ (Φ s) _ _ T)). Lemma oppreserving_second_isomorphism {w : SymbolType σ} (α : Operation A w) (γ : Operation (A/Φ) w) (ζ : Operation ((A&&P) / Ψ) w) (CA : ClosedUnderOp (A/Φ) Q γ) (CB : ClosedUnderOp A P α) (QA : ComputeOpQuotient A Φ α γ) (QB : ComputeOpQuotient (A&&P) Ψ (op_subalgebra A P α CB) ζ) : OpPreserving def_second_isomorphism ζ (op_subalgebra (A/Φ) Q γ CA). Proof. unfold ComputeOpQuotient in *. induction w; cbn in *. - apply path_sigma_hprop. cbn. destruct (QB tt)^, (QA tt)^. by apply qglue. - refine (Quotient_ind_hprop (Ψ t) _ _). intro x. apply (IHw (α (i t x)) (γ (class_of (Φ t) (i t x))) (ζ (class_of (Ψ t) x)) (CA (class_of (Φ t) (i t x)) (tr (x; _))) (CB (i t x) x.2)). + intro a. exact (QA (i t x, a)). + intro a. exact (QB (x, a)). Defined. Global Instance is_homomorphism_second_isomorphism : IsHomomorphism def_second_isomorphism. Proof. intro u. eapply oppreserving_second_isomorphism. - apply (compute_op_quotient A). - apply (compute_op_quotient (A&&P)). Defined. Definition hom_second_isomorphism : Homomorphism ((A&&P) / Ψ) ((A/Φ) && Q) := BuildHomomorphism def_second_isomorphism. Global Instance embedding_second_isomorphism (s : Sort σ) : IsEmbedding (hom_second_isomorphism s). Proof. apply isembedding_isinj_hset. refine (Quotient_ind_hprop (Ψ s) _ _). intro x. refine (Quotient_ind_hprop (Ψ s) _ _). intros y p. apply qglue. exact (related_quotient_paths (Φ s) (i s x) (i s y) (p..1)). Qed. Global Instance surjection_second_isomorphism (s : Sort σ) : IsSurjection (hom_second_isomorphism s). Proof. apply BuildIsSurjection. intros [y S]. generalize dependent S. generalize dependent y. refine (Quotient_ind_hprop (Φ s) _ _). intros y S. refine (Trunc_rec _ S). intros [y' S']. apply tr. exists (class_of _ y'). apply path_sigma_hprop. by apply qglue. Qed. Theorem is_isomorphism_second_isomorphism : IsIsomorphism hom_second_isomorphism. Proof. intro s. apply isequiv_surj_emb; exact _. Qed. Global Existing Instance is_isomorphism_second_isomorphism. Theorem isomorphic_second_isomorphism : (A&&P) / Ψ ≅ (A/Φ) && Q. Proof. exact (BuildIsomorphic def_second_isomorphism). Defined. Corollary id_second_isomorphism : (A&&P) / Ψ = (A/Φ) && Q. Proof. exact (id_isomorphic isomorphic_second_isomorphism). Defined. End second_isomorphism. Coq-HoTT-9.0/theories/Classes/theory/ua_subalgebra.v000066400000000000000000000131731474641544500224570ustar00rootroot00000000000000Require Import HoTT.Universes.HProp HoTT.Types HoTT.Classes.theory.ua_homomorphism. Import algebra_notations ne_list.notations. Section closed_under_op. Context `{Funext} {σ} (A : Algebra σ) (P : ∀ s, A s → Type). (** Let [α : A s1 → A s2 → ... → A sn → A t] be an algebra operation. Then [P] satisfies [ClosedUnderOp α] iff for [x1 : A s1], [x2 : A s2], ..., [xn : A sn], << P s1 x1 ∧ P s2 x2 ∧ ... ∧ P sn xn >> implies << P t (α x1 x2 ... xn) >> *) Fixpoint ClosedUnderOp {w : SymbolType σ} : Operation A w → Type := match w with | [:s:] => P s | s ::: w' => λ (α : A s → Operation A w'), ∀ (x : A s), P s x → ClosedUnderOp (α x) end. Global Instance trunc_closed_under_op {n} `{∀ s x, IsTrunc n (P s x)} {w : SymbolType σ} (α : Operation A w) : IsTrunc n (ClosedUnderOp α). Proof. induction w; cbn; exact _. Qed. Definition IsClosedUnderOps : Type := ∀ (u : Symbol σ), ClosedUnderOp u.#A. Global Instance trunc_is_closed_under_ops {n} `{∀ s x, IsTrunc n (P s x)} : IsTrunc n IsClosedUnderOps. Proof. apply istrunc_forall. Qed. End closed_under_op. (** [P : ∀ s, A s → Type] is a subalgebra predicate if it is closed under operations [IsClosedUnderOps A P] and [P s x] is an h-prop. *) Section subalgebra_predicate. Context {σ} (A : Algebra σ) (P : ∀ s, A s → Type). Class IsSubalgebraPredicate := BuildIsSubalgebraPredicate { hprop_subalgebra_predicate : ∀ s x, IsHProp (P s x); is_closed_under_ops_subalgebra_predicate : IsClosedUnderOps A P }. Global Instance hprop_is_subalgebra_predicate `{Funext} : IsHProp IsSubalgebraPredicate. Proof. apply hprop_allpath. intros [x1 x2] [y1 y2]. by destruct (path_ishprop x1 y1), (path_ishprop x2 y2). Defined. End subalgebra_predicate. Global Arguments BuildIsSubalgebraPredicate {σ A P hprop_subalgebra_predicate}. Global Existing Instance hprop_subalgebra_predicate. (** The next section defines subalgebra. *) Section subalgebra. Context {σ : Signature} (A : Algebra σ) (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}. (** The subalgebra carriers is the family of subtypes defined by [P]. *) Definition carriers_subalgebra : Carriers σ := λ (s : Sort σ), {x | P s x}. (** Let [α : A s1 → ... → A sn → A t] be an operation and let [C : ClosedUnderOp A P α]. The corresponding subalgebra operation [op_subalgebra α C : (A&P) s1 → ... → (A&P) sn → (A&P) t] is given by << op_subalgebra α C (x1; p1) ... (xn; pn) = (α x1 ... xn; C x1 p1 x2 p2 ... xn pn). >> *) Fixpoint op_subalgebra {w : SymbolType σ} : ∀ (α : Operation A w), ClosedUnderOp A P α → Operation carriers_subalgebra w := match w with | [:t:] => λ α c, (α; c) | s ::: w' => λ α c x, op_subalgebra (α x.1) (c x.1 x.2) end. (** The subalgebra operations [ops_subalgebra] are defined in terms of [op_subalgebra]. *) Definition ops_subalgebra (u : Symbol σ) : Operation carriers_subalgebra (σ u) := op_subalgebra u.#A (is_closed_under_ops_subalgebra_predicate A P u). Definition Subalgebra : Algebra σ := BuildAlgebra carriers_subalgebra ops_subalgebra. Global Instance trunc_subalgebra {n : trunc_index} `{!IsTruncAlgebra n.+1 A} : IsTruncAlgebra n.+1 Subalgebra. Proof. pose proof (hprop_subalgebra_predicate A P). intro s. apply @istrunc_sigma. - exact _. - intro. induction n; exact _. Qed. End subalgebra. Module subalgebra_notations. Notation "A && P" := (Subalgebra A P) : Algebra_scope. End subalgebra_notations. Import subalgebra_notations. (** The following section defines the inclusion homomorphism [Homomorphism (A&P) A], and some related results. *) Section hom_inc_subalgebra. Context {σ : Signature} (A : Algebra σ) (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}. Definition def_inc_subalgebra (s : Sort σ) : (A&&P) s → A s := pr1. Lemma oppreserving_inc_subalgebra {w : SymbolType σ} (α : Operation A w) (C : ClosedUnderOp A P α) : OpPreserving def_inc_subalgebra (op_subalgebra A P α C) α. Proof. induction w. - reflexivity. - intros x. apply IHw. Defined. Global Instance is_homomorphism_inc_subalgebra : IsHomomorphism def_inc_subalgebra. Proof. intro u. apply oppreserving_inc_subalgebra. Defined. Definition hom_inc_subalgebra : Homomorphism (A&&P) A := BuildHomomorphism def_inc_subalgebra. Lemma is_isomorphism_inc_improper_subalgebra (improper : ∀ s (x : A s), P s x) : IsIsomorphism hom_inc_subalgebra. Proof. intro s. refine (isequiv_adjointify _ (λ x, (x; improper s x)) _ _). - intro x. reflexivity. - intro x. by apply path_sigma_hprop. Qed. End hom_inc_subalgebra. (** The next section provides paths between subalgebras. These paths are convenient to have because the implicit type-class argument [IsClosedUnderOps] of [Subalgebra] is complicating things. *) Section path_subalgebra. Context {σ : Signature} (A : Algebra σ) (P : ∀ s, A s → Type) {CP : IsSubalgebraPredicate A P} (Q : ∀ s, A s → Type) {CQ : IsSubalgebraPredicate A Q}. Lemma path_subalgebra `{Funext} (p : P = Q) : A&&P = A&&Q. Proof. by destruct p, (path_ishprop CP CQ). Defined. Lemma path_subalgebra_iff `{Univalence} (R : ∀ s x, P s x <-> Q s x) : A&&P = A&&Q. Proof. apply path_subalgebra. funext s x. apply (@path_universe _ _ _ (fst (R s x))). apply (equiv_equiv_iff_hprop _ _ (R s x)). Defined. End path_subalgebra. Coq-HoTT-9.0/theories/Classes/theory/ua_third_isomorphism.v000066400000000000000000000152441474641544500241140ustar00rootroot00000000000000(** This file proves the third isomorphism theorem, [isomorphic_third_isomorphism]. *) Require Import Basics.Notations Colimits.Quotient Classes.interfaces.canonical_names Classes.theory.ua_quotient_algebra Classes.theory.ua_isomorphic Classes.theory.ua_first_isomorphism Spaces.List.Core. Import algebra_notations quotient_algebra_notations isomorphic_notations. (** This section defines the quotient [cong_quotient] of two congruences [Φ] and [Ψ], where [Ψ] is a subcongruence of [Φ]. It is shown that [cong_quotient] is a congruence. *) Section cong_quotient. Context `{Univalence} {σ : Signature} {A : Algebra σ} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ} (Ψ : ∀ s, Relation (A s)) `{!IsCongruence A Ψ} (subrel : ∀ (s : Sort σ) (x y : A s), Ψ s x y → Φ s x y). Definition cong_quotient (_ : ∀ s x y, Ψ s x y → Φ s x y) (s : Sort σ) (a b : (A/Ψ) s) := ∀ (x y : A s), in_class (Ψ s) a x → in_class (Ψ s) b y → Φ s x y. Global Instance equivalence_relation_quotient (s : Sort σ) : EquivRel (cong_quotient subrel s). Proof. constructor. - refine (Quotient_ind_hprop (Ψ s) _ _). intros x y z P Q. apply subrel. by transitivity x. - refine (Quotient_ind_hprop (Ψ s) _ _). intro x1. refine (Quotient_ind_hprop (Ψ s) _ _). intros x2 C y1 y2 P Q. symmetry. by apply C. - refine (Quotient_ind_hprop (Ψ s) _ _). intro x1. refine (Quotient_ind_hprop (Ψ s) _ _). intro x2. refine (Quotient_ind_hprop (Ψ s) _ _). intros x3 C D y1 y2 P Q. transitivity x2. + exact (C y1 x2 P (EquivRel_Reflexive x2)). + exact (D x2 y2 (EquivRel_Reflexive x2) Q). Defined. Lemma for_all_relation_quotient {w : list (Sort σ)} (a b : FamilyProd A w) : for_all_2_family_prod (A/Ψ) (A/Ψ) (cong_quotient subrel) (map_family_prod (λ s, class_of (Ψ s)) a) (map_family_prod (λ s, class_of (Ψ s)) b) → for_all_2_family_prod A A Φ a b. Proof. intro F. induction w; cbn in *. - constructor. - destruct a as [x a], b as [y b], F as [Q F]. split. + apply Q; simpl; reflexivity. + by apply IHw. Qed. Global Instance ops_compatible_quotient : OpsCompatible (A/Ψ) (cong_quotient subrel). Proof. intros u. refine (quotient_ind_prop_family_prod A Ψ _ _). intro a. refine (quotient_ind_prop_family_prod A Ψ _ _). intro b. (* It should not be necessary to provide the explicit types: *) destruct (compute_op_quotient A Ψ u a : ap_operation (u.#(A / Ψ)) (map_family_prod (λ s, class_of (Ψ s)) _) = _)^. destruct (compute_op_quotient A Ψ u b : ap_operation (u.#(A / Ψ)) (map_family_prod (λ s, class_of (Ψ s)) _) = _)^. intros R x y P Q. apply subrel in P. apply subrel in Q. transitivity (ap_operation u.#A a). - by symmetry. - transitivity (ap_operation u.#A b); try assumption. apply (ops_compatible A Φ u). by apply for_all_relation_quotient. Defined. Global Instance is_congruence_quotient : IsCongruence (A/Ψ) (cong_quotient subrel) := BuildIsCongruence (A/Ψ) (cong_quotient subrel). End cong_quotient. Section third_isomorphism. Context `{Univalence} {σ : Signature} {A : Algebra σ} (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ} (Ψ : ∀ s, Relation (A s)) `{!IsCongruence A Ψ} (subrel : ∀ (s : Sort σ) (x y : A s), Ψ s x y → Φ s x y). Lemma third_surjecton_well_def (s : Sort σ) (x y : A s) (P : Ψ s x y) : class_of (Φ s) x = class_of (Φ s) y. Proof. apply qglue. exact (subrel s x y P). Defined. Definition def_third_surjection (s : Sort σ) : (A/Ψ) s → (A/Φ) s := Quotient_rec (Ψ s) _ (class_of (Φ s)) (third_surjecton_well_def s). Lemma oppreserving_third_surjection {w : SymbolType σ} (f : Operation A w) : ∀ (α : Operation (A/Φ) w) (Qα : ComputeOpQuotient A Φ f α) (β : Operation (A/Ψ) w) (Qβ : ComputeOpQuotient A Ψ f β), OpPreserving def_third_surjection β α. Proof. induction w. - refine (Quotient_ind_hprop (Φ t) _ _). intros α Qα. refine (Quotient_ind_hprop (Ψ t) _ _). intros β Qβ. apply qglue. transitivity f. + apply subrel. apply (related_quotient_paths (Ψ t)). exact (Qβ tt). + apply (related_quotient_paths (Φ t)). symmetry. exact (Qα tt). - intros α Qα β Qβ. refine (Quotient_ind_hprop (Ψ t) _ _). intro x. exact (IHw (f x) (α (class_of (Φ t) x)) (λ a, Qα (x,a)) (β (class_of (Ψ t) x)) (λ a, Qβ (x,a))). Defined. Global Instance is_homomorphism_third_surjection : IsHomomorphism def_third_surjection. Proof. intro u. eapply oppreserving_third_surjection; apply compute_op_quotient. Defined. Definition hom_third_surjection : Homomorphism (A/Ψ) (A/Φ) := BuildHomomorphism def_third_surjection. Global Instance surjection_third_surjection (s : Sort σ) : IsSurjection (hom_third_surjection s). Proof. apply BuildIsSurjection. refine (Quotient_ind_hprop (Φ s) _ _). intro x. apply tr. by exists (class_of (Ψ s) x). Qed. Local Notation Θ := (cong_quotient Φ Ψ subrel). Lemma path_quotient_algebras_third_surjection : A/Ψ / cong_ker hom_third_surjection = A/Ψ / Θ. Proof. apply path_quotient_algebra_iff. intros s x y. split; generalize dependent y; generalize dependent x; refine (Quotient_ind_hprop (Ψ s) _ _); intro x; refine (Quotient_ind_hprop (Ψ s) _ _); intro y. - intros K x' y' Cx Cy. apply subrel in Cx. apply subrel in Cy. apply (related_quotient_paths (Φ s)) in K. transitivity x. + by symmetry. + by transitivity y. - intro T. apply qglue. exact (T x y (EquivRel_Reflexive x) (EquivRel_Reflexive y)). Defined. Definition hom_third_isomorphism : Homomorphism (A/Ψ/Θ) (A/Φ) := transport (λ X, Homomorphism X (A/Φ)) path_quotient_algebras_third_surjection (hom_first_isomorphism_surjection hom_third_surjection). Theorem is_isomorphism_third_isomorphism : IsIsomorphism hom_third_isomorphism. Proof. unfold hom_third_isomorphism. destruct path_quotient_algebras_third_surjection. exact _. Qed. Global Existing Instance is_isomorphism_third_isomorphism. (** The third isomorphism theorem. *) Corollary isomorphic_third_isomorphism : A/Ψ/Θ ≅ A/Φ. Proof. exact (BuildIsomorphic hom_third_isomorphism). Defined. Corollary id_third_isomorphism : A/Ψ/Θ = A/Φ. Proof. exact (id_isomorphic isomorphic_third_isomorphism). Defined. End third_isomorphism. Coq-HoTT-9.0/theories/Colimits/000077500000000000000000000000001474641544500163435ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Colimits/Coeq.v000066400000000000000000000715751474641544500174400ustar00rootroot00000000000000Require Import Basics. Require Import Types.Paths Types.Arrow Types.Sigma Types.Forall Types.Universe Types.Prod. Require Import Colimits.GraphQuotient. Require Import Homotopy.IdentitySystems. Local Open Scope path_scope. (** * Homotopy coequalizers *) (** ** Definition *) Definition Coeq@{i j u} {B : Type@{i}} {A : Type@{j}} (f g : B -> A) : Type@{u} := GraphQuotient@{i j u} (fun a b => {x : B & (f x = a) * (g x = b)}). Definition coeq {B A f g} (a : A) : @Coeq B A f g := gq a. Definition cglue {B A f g} b : @coeq B A f g (f b) = coeq (g b) := gqglue (b; (idpath,idpath)). Arguments Coeq : simpl never. Arguments coeq : simpl never. Arguments cglue : simpl never. Definition Coeq_ind {B A f g} (P : @Coeq B A f g -> Type) (coeq' : forall a, P (coeq a)) (cglue' : forall b, (cglue b) # (coeq' (f b)) = coeq' (g b)) : forall w, P w. Proof. rapply GraphQuotient_ind. intros a b [x [[] []]]. exact (cglue' x). Defined. Lemma Coeq_ind_beta_cglue {B A f g} (P : @Coeq B A f g -> Type) (coeq' : forall a, P (coeq a)) (cglue' : forall b, (cglue b) # (coeq' (f b)) = coeq' (g b)) (b:B) : apD (Coeq_ind P coeq' cglue') (cglue b) = cglue' b. Proof. rapply GraphQuotient_ind_beta_gqglue. Defined. Definition Coeq_rec {B A f g} (P : Type) (coeq' : A -> P) (cglue' : forall b, coeq' (f b) = coeq' (g b)) : @Coeq B A f g -> P. Proof. rapply GraphQuotient_rec. intros a b [x [[] []]]. exact (cglue' x). Defined. Definition Coeq_rec_beta_cglue {B A f g} (P : Type) (coeq' : A -> P) (cglue' : forall b:B, coeq' (f b) = coeq' (g b)) (b:B) : ap (Coeq_rec P coeq' cglue') (cglue b) = cglue' b. Proof. rapply GraphQuotient_rec_beta_gqglue. Defined. Definition Coeq_ind_hprop {B A f g} (P : @Coeq B A f g -> Type) `{forall x, IsHProp (P x)} (i : forall a, P (coeq a)) : forall x, P x. Proof. snrapply Coeq_ind. 1: exact i. intros b. rapply path_ishprop. Defined. Definition Coeq_ind_eta_homotopic {B A f g} {P : @Coeq B A f g -> Type} (h : forall w : Coeq f g, P w) : h == Coeq_ind P (h o coeq) (fun b => apD h (cglue b)). Proof. unfold pointwise_paths. nrapply (Coeq_ind _ (fun _ => 1)). intros b. lhs nrapply transport_paths_FlFr_D. lhs nrapply (whiskerL _ (Coeq_ind_beta_cglue _ _ _ _)). lhs nrapply (whiskerR (concat_p1 _)). nrapply concat_Vp. Defined. Definition Coeq_rec_eta_homotopic {B A f g} {P : Type} (h : @Coeq B A f g -> P) : h == Coeq_rec P (h o coeq) (fun b => ap h (cglue b)). Proof. unfold pointwise_paths. nrapply (Coeq_ind _ (fun _ => 1)). intros b. apply transport_paths_FlFr', equiv_p1_1q. symmetry; nrapply Coeq_rec_beta_cglue. Defined. Definition Coeq_ind_eta `{Funext} {B A f g} {P : @Coeq B A f g -> Type} (h : forall w : Coeq f g, P w) : h = Coeq_ind P (h o coeq) (fun b => apD h (cglue b)) := path_forall _ _ (Coeq_ind_eta_homotopic h). Definition Coeq_rec_eta `{Funext} {B A f g} {P : Type} (h : @Coeq B A f g -> P) : h = Coeq_rec P (h o coeq) (fun b => ap h (cglue b)) := path_forall _ _ (Coeq_rec_eta_homotopic h). Definition Coeq_ind_homotopy {B A f g} (P : @Coeq B A f g -> Type) {m n : forall a, P (coeq a)} (u : m == n) {r : forall b, (cglue b) # (m (f b)) = m (g b)} {s : forall b, (cglue b) # (n (f b)) = n (g b)} (p : forall b, ap (transport P (cglue b)) (u (f b)) @ (s b) = r b @ u (g b)) : Coeq_ind P m r == Coeq_ind P n s. Proof. unfold pointwise_paths. nrapply Coeq_ind; intros b. lhs nrapply (transport_paths_FlFr_D (f:=Coeq_ind P m r) (g:=Coeq_ind P n s)). lhs nrapply (whiskerL _ (Coeq_ind_beta_cglue P n s b)). lhs nrapply (whiskerR (whiskerR (ap inverse (Coeq_ind_beta_cglue P m r b)) _)). lhs nrapply concat_pp_p; nrapply moveR_Mp. rhs nrapply (whiskerR (inv_V _)). exact (p b). Defined. (** ** Universal property *) (** See Colimits/CoeqUnivProp.v for a similar universal property without [Funext]. *) Definition Coeq_unrec {B A} (f g : B -> A) {P} (h : Coeq f g -> P) : {k : A -> P & k o f == k o g}. Proof. exists (h o coeq). intros b. exact (ap h (cglue b)). Defined. Definition isequiv_Coeq_rec `{Funext} {B A} (f g : B -> A) P : IsEquiv (fun p : {h : A -> P & h o f == h o g} => Coeq_rec P p.1 p.2). Proof. srapply (isequiv_adjointify _ (Coeq_unrec f g)). - intros h. apply path_arrow. srapply Coeq_ind; intros b. 1: cbn;reflexivity. cbn. nrapply transport_paths_FlFr'. apply equiv_p1_1q. nrapply Coeq_rec_beta_cglue. - intros [h q]; srapply path_sigma'. + reflexivity. + cbn. rapply path_forall; intros b. apply Coeq_rec_beta_cglue. Defined. Definition equiv_Coeq_rec `{Funext} {B A} (f g : B -> A) P : {h : A -> P & h o f == h o g} <~> (Coeq f g -> P) := Build_Equiv _ _ _ (isequiv_Coeq_rec f g P). (** ** Functoriality *) Definition functor_coeq {B A f g B' A' f' g'} (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) : @Coeq B A f g -> @Coeq B' A' f' g'. Proof. refine (Coeq_rec _ (coeq o k) _); intros b. refine (ap coeq (p b) @ _ @ ap coeq (q b)^). apply cglue. Defined. Definition functor_coeq_beta_cglue {B A f g B' A' f' g'} (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) (b : B) : ap (functor_coeq h k p q) (cglue b) = ap coeq (p b) @ cglue (h b) @ ap coeq (q b)^ := (Coeq_rec_beta_cglue _ _ _ b). Definition functor_coeq_idmap {B A f g} : functor_coeq (B:=B) (A:=A) (f:=f) (g:=g) idmap idmap (fun _ => 1) (fun _ => 1) == idmap. Proof. snrapply Coeq_ind. 1: reflexivity. intros b. nrapply transport_paths_Flr'. apply moveR_pM. nrapply functor_coeq_beta_cglue. Defined. Definition functor_coeq_compose {B A f g B' A' f' g' B'' A'' f'' g''} (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) (h' : B' -> B'') (k' : A' -> A'') (p' : k' o f' == f'' o h') (q' : k' o g' == g'' o h') : functor_coeq (h' o h) (k' o k) (fun b => ap k' (p b) @ p' (h b)) (fun b => ap k' (q b) @ q' (h b)) == functor_coeq h' k' p' q' o functor_coeq h k p q. Proof. refine (Coeq_ind _ (fun a => 1) _); cbn; intros b. nrapply transport_paths_FlFr'. apply equiv_p1_1q; symmetry. rewrite ap_compose. rewrite !functor_coeq_beta_cglue, !ap_pp, functor_coeq_beta_cglue. rewrite <- !ap_compose. cbn. rewrite !ap_V, ap_pp, inv_pp, <- ap_compose, !concat_p_pp. reflexivity. Qed. Definition functor_coeq_homotopy {B A f g B' A' f' g'} (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) (h' : B -> B') (k' : A -> A') (p' : k' o f == f' o h') (q' : k' o g == g' o h') (r : h == h') (s : k == k') (u : forall b, s (f b) @ p' b = p b @ ap f' (r b)) (v : forall b, s (g b) @ q' b = q b @ ap g' (r b)) : functor_coeq h k p q == functor_coeq h' k' p' q'. Proof. refine (Coeq_ind _ (fun a => ap coeq (s a)) _); cbn; intros b. apply transport_paths_FlFr'. rewrite !functor_coeq_beta_cglue. Open Scope long_path_scope. rewrite 2 ap_V. rewrite !concat_p_pp. apply moveL_pV. rewrite <- (ap_pp (@coeq _ _ f' g') (s (f b)) (p' b)). rewrite u, ap_pp. rewrite !concat_pp_p; apply whiskerL. rewrite <- (ap_pp (@coeq _ _ f' g') (s (g b)) (q' b)). rewrite v, ap_pp. rewrite concat_V_pp. rewrite <- 2 ap_compose. exact (concat_Ap (@cglue _ _ f' g') (r b))^. Close Scope long_path_scope. Qed. Definition functor_coeq_sect {B A f g B' A' f' g'} (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) (h' : B' -> B) (k' : A' -> A) (p' : k' o f' == f o h') (q' : k' o g' == g o h') (r : h' o h == idmap) (s : k' o k == idmap) (u : forall b, ap k' (p b) @ p' (h b) @ ap f (r b) = s (f b)) (v : forall b, ap k' (q b) @ q' (h b) @ ap g (r b) = s (g b)) : (functor_coeq h' k' p' q') o (functor_coeq h k p q) == idmap. Proof. refine (Coeq_ind _ (fun a => ap coeq (s a)) _); cbn; intros b. refine (transport_paths_FFlr (cglue b) _ @ _). rewrite concat_pp_p; apply moveR_Vp. rewrite functor_coeq_beta_cglue, !ap_pp. rewrite <- !ap_compose; cbn. rewrite functor_coeq_beta_cglue. Open Scope long_path_scope. rewrite !concat_p_pp. rewrite <- u, !ap_pp, !(ap_compose k' coeq). rewrite !concat_pp_p; do 2 apply whiskerL. rewrite !concat_p_pp. rewrite <- v. rewrite !ap_pp, !ap_V, !concat_p_pp, !concat_pV_p. rewrite <- !ap_compose. exact (concat_Ap cglue (r b)). Close Scope long_path_scope. Qed. Section IsEquivFunctorCoeq. Context {B A f g B' A' f' g'} (h : B -> B') (k : A -> A') `{IsEquiv _ _ h} `{IsEquiv _ _ k} (p : k o f == f' o h) (q : k o g == g' o h). Definition functor_coeq_inverse : @Coeq B' A' f' g' -> @Coeq B A f g. Proof. refine (functor_coeq h^-1 k^-1 _ _). - intros b. refine (ap (k^-1 o f') (eisretr h b)^ @ _ @ eissect k (f (h^-1 b))). apply ap, inverse, p. - intros b. refine (ap (k^-1 o g') (eisretr h b)^ @ _ @ eissect k (g (h^-1 b))). apply ap, inverse, q. Defined. Definition functor_coeq_eissect : (functor_coeq h k p q) o functor_coeq_inverse == idmap. Proof. Open Scope long_path_scope. refine (functor_coeq_sect _ _ _ _ _ _ _ _ (eisretr h) (eisretr k) _ _); intros b. (** The two proofs are identical modulo replacing [f] by [g], [f'] by [g'], and [p] by [q]. *) all:rewrite !ap_pp, <- eisadj. all:rewrite <- !ap_compose. all:rewrite (concat_pA1_p (eisretr k) _ _). all:rewrite concat_pV_p. all:rewrite <- (ap_compose (k^-1 o _) k). all:rewrite (ap_compose _ (k o k^-1)). all:rewrite (concat_A1p (eisretr k) (ap _ (eisretr h b)^)). all:rewrite ap_V, concat_pV_p; reflexivity. Close Scope long_path_scope. Qed. Definition functor_coeq_eisretr : functor_coeq_inverse o (functor_coeq h k p q) == idmap. Proof. Open Scope long_path_scope. refine (functor_coeq_sect _ _ _ _ _ _ _ _ (eissect h) (eissect k) _ _); intros b. all:rewrite !concat_p_pp, eisadj, <- ap_V, <- !ap_compose. all:rewrite (ap_compose (_ o h) k^-1). all:rewrite <- !(ap_pp k^-1), !concat_pp_p. 1:rewrite (concat_Ap (fun b => (p b)^) (eissect h b)^). 2:rewrite (concat_Ap (fun b => (q b)^) (eissect h b)^). all:rewrite concat_p_Vp, concat_p_pp. all:rewrite <- (ap_compose (k o _) k^-1), (ap_compose _ (k^-1 o k)). all:rewrite (concat_A1p (eissect k) _). all:rewrite ap_V, concat_pV_p; reflexivity. Close Scope long_path_scope. Qed. Global Instance isequiv_functor_coeq : IsEquiv (functor_coeq h k p q) := isequiv_adjointify _ functor_coeq_inverse functor_coeq_eissect functor_coeq_eisretr. Definition equiv_functor_coeq : @Coeq B A f g <~> @Coeq B' A' f' g' := Build_Equiv _ _ (functor_coeq h k p q) _. End IsEquivFunctorCoeq. Definition equiv_functor_coeq' {B A f g B' A' f' g'} (h : B <~> B') (k : A <~> A') (p : k o f == f' o h) (q : k o g == g' o h) : @Coeq B A f g <~> @Coeq B' A' f' g' := equiv_functor_coeq h k p q. (** ** A double recursion principle *) Section CoeqRec2. Context {B A : Type} {f g : B -> A} {B' A' : Type} {f' g' : B' -> A'} (P : Type) (coeq' : A -> A' -> P) (cgluel : forall b a', coeq' (f b) a' = coeq' (g b) a') (cgluer : forall a b', coeq' a (f' b') = coeq' a (g' b')) (cgluelr : forall b b', cgluel b (f' b') @ cgluer (g b) b' = cgluer (f b) b' @ cgluel b (g' b')). Definition Coeq_rec2 : Coeq f g -> Coeq f' g' -> P. Proof. intros x y; revert x. snrapply Coeq_rec. - intros a. revert y. snrapply Coeq_rec. + intros a'. exact (coeq' a a'). + intros b'; cbn. apply cgluer. - intros b. revert y. snrapply Coeq_ind. + intros a'. cbn. apply cgluel. + intros b'. nrapply (transport_paths_FlFr' (cglue b')). lhs nrapply (_ @@ 1). 1: apply Coeq_rec_beta_cglue. rhs nrapply (1 @@ _). 2: apply Coeq_rec_beta_cglue. symmetry. apply cgluelr. Defined. Definition Coeq_rec2_beta (a : A) (a' : A') : Coeq_rec2 (coeq a) (coeq a') = coeq' a a' := 1. Definition Coeq_rec2_beta_cgluel (a : A) (b' : B') : ap (Coeq_rec2 (coeq a)) (cglue b') = cgluer a b'. Proof. nrapply Coeq_rec_beta_cglue. Defined. Definition Coeq_rec2_beta_cgluer (b : B) (a' : A') : ap (fun x => Coeq_rec2 x (coeq a')) (cglue b) = cgluel b a'. Proof. nrapply Coeq_rec_beta_cglue. Defined. (** TODO: [Coeq_rec2_beta_cgluelr] *) End CoeqRec2. (** ** A double induction principle *) Section CoeqInd2. Context `{Funext} {B A : Type} {f g : B -> A} {B' A' : Type} {f' g' : B' -> A'} (P : Coeq f g -> Coeq f' g' -> Type) (coeq' : forall a a', P (coeq a) (coeq a')) (cgluel : forall b a', transport (fun x => P x (coeq a')) (cglue b) (coeq' (f b) a') = coeq' (g b) a') (cgluer : forall a b', transport (fun y => P (coeq a) y) (cglue b') (coeq' a (f' b')) = coeq' a (g' b')) (** Perhaps this should really be written using [concatD]. *) (cgluelr : forall b b', ap (transport (P (coeq (g b))) (cglue b')) (cgluel b (f' b')) @ cgluer (g b) b' = transport_transport P (cglue b) (cglue b') (coeq' (f b) (f' b')) @ ap (transport (fun x => P x (coeq (g' b'))) (cglue b)) (cgluer (f b) b') @ cgluel b (g' b')). Definition Coeq_ind2 : forall x y, P x y. Proof. simple refine (Coeq_ind _ _ _). - intros a. simple refine (Coeq_ind _ _ _). + intros a'. exact (coeq' a a'). + intros b'; cbn. apply cgluer. - intros b. apply path_forall; intros a. revert a; simple refine (Coeq_ind _ _ _). + intros a'. cbn. refine (transport_forall_constant _ _ _ @ _). apply cgluel. + intros b'; cbn. refine (transport_paths_FlFr_D (cglue b') _ @ _). rewrite Coeq_ind_beta_cglue. (** Now begins the long haul. *) Open Scope long_path_scope. rewrite ap_pp. repeat rewrite concat_p_pp. (** Our first order of business is to get rid of the [Coeq_ind]s, which only occur in the following incarnation. *) set (G := (Coeq_ind (P (coeq (f b))) (fun a' : A' => coeq' (f b) a') (fun b'0 : B' => cgluer (f b) b'0))). (** Let's reduce the [apD (loop # G)] first. *) rewrite (apD_transport_forall_constant P (cglue b) G (cglue b')); simpl. rewrite !inv_pp, !inv_V. (** Now we can cancel a [transport_forall_constant]. *) rewrite !concat_pp_p; apply whiskerL. (** And a path-inverse pair. This removes all the [transport_forall_constant]s. *) rewrite !concat_p_pp, concat_pV_p. (** Now we can beta-reduce the last remaining [G]. *) subst G; rewrite Coeq_ind_beta_cglue; simpl. (** Now we just have to rearrange it a bit. *) rewrite !concat_pp_p; do 2 apply moveR_Vp; rewrite !concat_p_pp. apply cgluelr. Close Scope long_path_scope. Qed. End CoeqInd2. (** ** Symmetry *) Definition Coeq_sym_map {B A} (f g : B -> A) : Coeq f g -> Coeq g f := Coeq_rec (Coeq g f) coeq (fun b : B => (cglue b)^). Lemma sect_Coeq_sym_map {B A} {f g : B -> A} : (Coeq_sym_map f g) o (Coeq_sym_map g f) == idmap. Proof. srapply @Coeq_ind. - reflexivity. - intro b. simpl. abstract (rewrite transport_paths_FFlr, Coeq_rec_beta_cglue, ap_V, Coeq_rec_beta_cglue; hott_simpl). Defined. Lemma Coeq_sym {B A} {f g : B -> A} : @Coeq B A f g <~> Coeq g f. Proof. exact (equiv_adjointify (Coeq_sym_map f g) (Coeq_sym_map g f) sect_Coeq_sym_map sect_Coeq_sym_map). Defined. (** ** Descent *) (** We study "equifibrant" type families over a parallel pair [f, g: B -> A]. By univalence, the descent property tells us that these type families correspond to type families over the coequalizer, and we obtain an induction principle for such type families. Dependent descent data over some particular descent data are "equifibrant" type families over this descent data. The "equifibrancy" is only taken over the parallel pair [f g : B -> A], but there is an extra level of dependency coming from the descent data. In this case, we obtain an induction and recursion principle, but only with a computation rule for the recursion principle. The theory of descent is interesting to consider in itself. However, we will use it as a means to structure the code, and to obtain induction and recursion principles that are valuable in proving the flattening lemma, and characterizing path spaces. Thus we will gloss over the bigger picture, and not consider equivalences of descent data, nor homotopies of their sections. We will also not elaborate on uniqueness of the induced families. It's possible to prove the results in the Descent, Flattening and Paths Sections without univalence, by replacing all equivalences with paths, but in practice these results will be used with equivalences as input, making the form below more convenient. See https://github.com/HoTT/Coq-HoTT/pull/2147#issuecomment-2521570830 for further information *) Section Descent. Context `{Univalence}. (** Descent data over [f g : B -> A] is an "equifibrant" or "cartesian" type family [cd_fam : A -> Type]. This means that if [b : B], then the fibers [cd_fam (f b)] and [cd_fam (g b)] are equivalent, witnessed by [cd_e]. *) Record cDescent {A B : Type} {f g : B -> A} := { cd_fam (a : A) : Type; cd_e (b : B) : cd_fam (f b) <~> cd_fam (g b) }. Global Arguments cDescent {A B} f g. (** Let [A] and [B] be types, with a parallel pair [f g : B -> A]. *) Context {A B : Type} {f g : B -> A}. (** Descent data induces a type family over [Coeq f g]. *) Definition fam_cdescent (Pe : cDescent f g) : Coeq f g -> Type. Proof. snrapply (Coeq_rec _ (cd_fam Pe)). intro b. exact (path_universe_uncurried (cd_e Pe b)). Defined. (** A type family over [Coeq f g] induces descent data. *) Definition cdescent_fam (P : Coeq f g -> Type) : cDescent f g. Proof. snrapply Build_cDescent. - exact (P o coeq). - intro b. exact (equiv_transport P (cglue b)). Defined. (** Transporting over [fam_cdescent] along [cglue b] is given by [cd_e]. *) Definition transport_fam_cdescent_cglue (Pe : cDescent f g) (b : B) (pf : cd_fam Pe (f b)) : transport (fam_cdescent Pe) (cglue b) pf = cd_e Pe b pf. Proof. nrapply transport_path_universe'. nrapply Coeq_rec_beta_cglue. Defined. (** A section on the descent data is a fiberwise section that respects the equivalences. *) Record cDescentSection {Pe : cDescent f g} := { cds_sect (a : A) : cd_fam Pe a; cds_e (b : B) : cd_e Pe b (cds_sect (f b)) = cds_sect (g b) }. Global Arguments cDescentSection Pe : clear implicits. (** A descent section induces a genuine section of [fam_cdescent Pe]. *) Definition cdescent_ind {Pe : cDescent f g} (s : cDescentSection Pe) : forall (x : Coeq f g), fam_cdescent Pe x. Proof. snrapply (Coeq_ind _ (cds_sect s)). intro b. exact (transport_fam_cdescent_cglue Pe b _ @ cds_e s b). Defined. (** We record its computation rule *) Definition cdescent_ind_beta_cglue {Pe : cDescent f g} (s : cDescentSection Pe) (b : B) : apD (cdescent_ind s) (cglue b) = transport_fam_cdescent_cglue Pe b _ @ cds_e s b := Coeq_ind_beta_cglue _ (cds_sect s) _ _. (** Dependent descent data over descent data [Pe : cDescent f g] consists of a type family [cdd_fam : forall a : A, cd_fam Pe a -> Type] together with coherences [cdd_e b pf]. *) Record cDepDescent {Pe : cDescent f g} := { cdd_fam (a : A) (pa : cd_fam Pe a) : Type; cdd_e (b : B) (pf : cd_fam Pe (f b)) : cdd_fam (f b) pf <~> cdd_fam (g b) (cd_e Pe b pf) }. Global Arguments cDepDescent Pe : clear implicits. (** A dependent type family over [fam_cdescent Pe] induces dependent descent data over [Pe]. *) Definition cdepdescent_fam {Pe : cDescent f g} (Q : forall x : Coeq f g, (fam_cdescent Pe) x -> Type) : cDepDescent Pe. Proof. snrapply Build_cDepDescent. - intro a; cbn. exact (Q (coeq a)). - intros b pf. exact (equiv_transportDD (fam_cdescent Pe) Q (cglue b) (transport_fam_cdescent_cglue Pe b pf)). Defined. (** Dependent descent data over [Pe] induces a dependent type family over [fam_cdescent Pe]. *) Definition fam_cdepdescent {Pe : cDescent f g} (Qe : cDepDescent Pe) : forall (x : Coeq f g), (fam_cdescent Pe x) -> Type. Proof. snrapply Coeq_ind. - exact (cdd_fam Qe). - intro b. nrapply (moveR_transport_p _ (cglue b)). funext pa. rhs nrapply transport_arrow_toconst. rhs nrefine (ap (cdd_fam _ _) _). + exact (path_universe (cdd_e _ _ _)). + lhs nrapply (ap (fun x => (transport _ x _)) (inv_V (cglue _))). nrapply (transport_fam_cdescent_cglue _ _ _). Defined. (** A section of dependent descent data [Qe : cDepDescent Pe] is a fiberwise section [cdds_sect], together with coherences [cdds_e]. *) Record cDepDescentSection {Pe : cDescent f g} {Qe : cDepDescent Pe} := { cdds_sect (a : A) (pa : cd_fam Pe a) : cdd_fam Qe a pa; cdds_e (b : B) (pf : cd_fam Pe (f b)) : cdd_e Qe b pf (cdds_sect (f b) pf) = cdds_sect (g b) (cd_e Pe b pf) }. Global Arguments cDepDescentSection {Pe} Qe. (** A dependent descent section induces a genuine section over the total space of [fam_cdescent Pe]. *) Definition cdepdescent_ind {Pe : cDescent f g} {Q : forall (x : Coeq f g), (fam_cdescent Pe) x -> Type} (s : cDepDescentSection (cdepdescent_fam Q)) : forall (x : Coeq f g) (px : fam_cdescent Pe x), Q x px. Proof. nrapply (Coeq_ind _ (cdds_sect s) _). intro b. apply dpath_forall. intro pf. apply (equiv_inj (transport (Q (coeq (g b))) (transport_fam_cdescent_cglue Pe b pf))). rhs nrapply (apD (cdds_sect s (g b)) (transport_fam_cdescent_cglue Pe b pf)). exact (cdds_e s b pf). Defined. (** The data for a section into a constant type family. *) Record cDepDescentConstSection {Pe : cDescent f g} {Q : Type} := { cddcs_sect (a : A) (pa : cd_fam Pe a) : Q; cddcs_e (b : B) (pf : cd_fam Pe (f b)) : cddcs_sect (f b) pf = cddcs_sect (g b) (cd_e Pe b pf) }. Global Arguments cDepDescentConstSection Pe Q : clear implicits. (** The data for a section of a constant family induces a section over the total space of [fam_cdescent Pe]. *) Definition cdepdescent_rec {Pe : cDescent f g} {Q : Type} (s : cDepDescentConstSection Pe Q) : forall (x : Coeq f g), fam_cdescent Pe x -> Q. Proof. snrapply (Coeq_ind _ (cddcs_sect s)). intro b. nrapply dpath_arrow. intro pf. lhs nrapply transport_const. rhs nrapply (ap _ (transport_fam_cdescent_cglue Pe b pf)). exact (cddcs_e s b pf). Defined. (** Here is the computation rule on paths. *) Definition cdepdescent_rec_beta_cglue {Pe : cDescent f g} {Q : Type} (s : cDepDescentConstSection Pe Q) (b : B) {pf : cd_fam Pe (f b)} {pg : cd_fam Pe (g b)} (pb : cd_e Pe b pf = pg) : ap (sig_rec (cdepdescent_rec s)) (path_sigma _ (coeq (f b); pf) (coeq (g b); pg) (cglue b) (transport_fam_cdescent_cglue Pe b pf @ pb)) = cddcs_e s b pf @ ap (cddcs_sect s (g b)) pb. Proof. Open Scope long_path_scope. destruct pb. rhs nrapply concat_p1. lhs nrapply ap_sig_rec_path_sigma. lhs nrapply (ap (fun x => _ (ap10 x _) @ _)). 1: nrapply Coeq_ind_beta_cglue. do 3 lhs nrapply concat_pp_p. apply moveR_Vp. lhs nrefine (1 @@ (1 @@ (_ @@ 1))). 1: nrapply (ap10_dpath_arrow (fam_cdescent Pe) (fun _ => Q) (cglue b)). lhs nrefine (1 @@ _). { lhs nrapply (1 @@ concat_pp_p _ _ _). lhs nrapply (1 @@ concat_pp_p _ _ _). lhs nrapply concat_V_pp. lhs nrapply (1 @@ concat_pp_p _ _ _). rewrite concat_p1. nrapply (1 @@ (1 @@ concat_pV_p _ _)). } nrapply concat_V_pp. Close Scope long_path_scope. Defined. End Descent. (** ** The flattening lemma *) (** We saw above that given descent data [Pe] over a parallel pair [f g : B -> A], we obtained a type family [fam_cdescent Pe] over the coequalizer. The flattening lemma describes the total space [sig (fam_cdescent Pe)] of this type family as a coequalizer of [sig (cd_fam Pe)] by a certain parallel pair. This follows from the work above, which shows that [sig (fam_cdescent Pe)] has the same universal property as this coequalizer. The flattening lemma here also follows from the flattening lemma for GraphQuotients, avoiding the need for the material in Section Descent. However, that material is likely useful in general, so we have given an independent proof of the flattening lemma. See versions of the library before December 5, 2024 for the proof using the flattening lemma for GraphQuotients. *) Section Flattening. Context `{Univalence} {A B : Type} {f g : B -> A} (Pe : cDescent f g). (** We mimic the constructors of [Coeq] for the total space. Here is the point constructor, in curried form. *) Definition flatten_cd {a : A} (pa : cd_fam Pe a) : sig (fam_cdescent Pe) := (coeq a; pa). (** And here is the path constructor. *) Definition flatten_cd_glue (b : B) {pf : cd_fam Pe (f b)} {pg : cd_fam Pe (g b)} (pb : cd_e Pe b pf = pg) : flatten_cd pf = flatten_cd pg. Proof. snrapply path_sigma. - by apply cglue. - lhs nrapply transport_fam_cdescent_cglue. exact pb. Defined. (** Now that we've shown that [fam_cdescent Pe] acts like a [Coeq] of [sig (cd_fam Pe)] by an appropriate parallel pair, we can use this to prove the flattening lemma. The maps back and forth are very easy so this could almost be a formal consequence of the induction principle. *) Lemma equiv_cd_flatten : sig (fam_cdescent Pe) <~> Coeq (functor_sigma f (fun _ => idmap)) (functor_sigma g (cd_e Pe)). Proof. snrapply equiv_adjointify. - snrapply sig_rec. snrapply cdepdescent_rec. snrapply Build_cDepDescentConstSection. + exact (fun a x => coeq (a; x)). + intros b pf. cbn. apply (@cglue _ _ (functor_sigma f (fun _ => idmap)) (functor_sigma g (cd_e Pe)) (b; pf)). - snrapply Coeq_rec. + exact (fun '(a; x) => (coeq a; x)). + intros [b pf]; cbn. apply (flatten_cd_glue b 1). - snrapply Coeq_ind. 1: reflexivity. intros [b pf]; cbn. nrapply transport_paths_FFlr'; apply equiv_p1_1q. rewrite Coeq_rec_beta_cglue. lhs nrapply cdepdescent_rec_beta_cglue. nrapply concat_p1. - intros [x px]; revert x px. snrapply cdepdescent_ind. snrapply Build_cDepDescentSection. + by intros a pa. + intros b pf; cbn. lhs nrapply transportDD_is_transport. nrapply transport_paths_FFlr'; apply equiv_p1_1q. rewrite <- (concat_p1 (transport_fam_cdescent_cglue _ _ _)). rewrite cdepdescent_rec_beta_cglue. (* This needs to be in the form [transport_fam_cdescent_cglue Pe r pa @ p] to work, and the other [@ 1] introduced comes in handy as well. *) lhs nrapply (ap _ (concat_p1 _)). nrapply (Coeq_rec_beta_cglue _ _ _ (b; pf)). Defined. End Flattening. (** ** Characterization of path spaces *) (** A pointed type family over a coequalizer has an identity system structure precisely when its associated descent data satisfies Kraus and von Raumer's induction principle, https://arxiv.org/pdf/1901.06022. *) Section Paths. (** Let [f g : B -> A] be a parallel pair, with a distinguished point [a0 : A]. Let [Pe : cDescent f g] be descent data over [f g] with a distinguished point [p0 : cd_fam Pe a0]. Assume that any dependent descent data [Qe : cDepDescent Pe] with a distinguished point [q0 : cdd_fam Qe a0 p0] has a section that respects the distinguished points. This is the induction principle provided by Kraus and von Raumer. *) Context `{Univalence} {A B: Type} {f g : B -> A} (a0 : A) (Pe : cDescent f g) (p0 : cd_fam Pe a0) (based_cdepdescent_ind : forall (Qe : cDepDescent Pe) (q0 : cdd_fam Qe a0 p0), cDepDescentSection Qe) (based_cdepdescent_ind_beta : forall (Qe : cDepDescent Pe) (q0 : cdd_fam Qe a0 p0), cdds_sect (based_cdepdescent_ind Qe q0) a0 p0 = q0). (** Under these hypotheses, we get an identity system structure on [fam_cdescent Pe]. *) Local Instance idsys_flatten_cdescent : @IsIdentitySystem _ (coeq a0) (fam_cdescent Pe) p0. Proof. snrapply Build_IsIdentitySystem. - intros Q q0 x p. snrapply cdepdescent_ind. by apply based_cdepdescent_ind. - intros Q q0; cbn. nrapply (based_cdepdescent_ind_beta (cdepdescent_fam Q)). Defined. (** It follows that the fibers [fam_cdescent Pe x] are equivalent to path spaces [(coeq a0) = x]. *) Definition induced_fam_cd_equiv_path (x : Coeq f g) : (coeq a0) = x <~> fam_cdescent Pe x := @equiv_transport_identitysystem _ (coeq a0) (fam_cdescent Pe) p0 _ x. End Paths. Coq-HoTT-9.0/theories/Colimits/CoeqUnivProp.v000066400000000000000000000233471474641544500211350ustar00rootroot00000000000000Require Import Basics.Overture. Require Import Basics.Tactics. Require Import Basics.PathGroupoids. Require Import Types.Paths. Require Import Colimits.Coeq. Require Import Cubical.DPath. Require Import Cubical.DPathSquare. Require Import WildCat.Core. Require Import WildCat.Displayed. Require Import WildCat.Equiv. Require Import WildCat.EquivGpd. Require Import WildCat.Forall. Require Import WildCat.NatTrans. Require Import WildCat.Paths. Require Import WildCat.ZeroGroupoid. (** Using wild 0-groupoids, the universal property can be proven without funext. A simple equivalence of 0-groupoids between [Coeq f g -> P] and [{ h : A -> P & h o f == h o g }] would not carry all the higher-dimensional information, but if we generalize it to dependent functions, then it does suffice. *) Section UnivProp. Context {B A : Type} (f g : B -> A) (P : Coeq f g -> Type). (** This allows Coq to infer 0-groupoid structures of the form [@isgraph_forall C P (fun c => isgraph_paths (P c))] on any type of the form [forall c, P c]. [isgraph_paths] is not a global instance. [isgraph_total] is, but we need to adjust the priority. The other needed ingredients are all global instances. *) Local Existing Instances isgraph_total | 1. Local Existing Instances isgraph_paths | 2. (** The domain of the equivalence: sections of [P] over [Coeq f g]. Coq correctly infers the 0-groupoid structure [@isgraph_forall (Coeq f g) P (fun z : Coeq f g => isgraph_paths (P z))]. *) Definition Coeq_ind_type := forall z : Coeq f g, P z. (** The codomain of the equivalence is a sigma-groupoid of this family: *) Definition Coeq_ind_data (h : forall a : A, P (coeq a)) := forall b : B, DPath P (cglue b) (h (f b)) (h (g b)). (** We consider [Coeq_ind_data] to be a displayed 0-groupoid, where objects over [h : forall a : A, P (coeq a)] are dependent paths as defined above and morphisms over [p : h == k] are witnesses that [p] commutes with the homotopies over [h] and [k]. *) Local Instance isdgraph_Coeq_ind_data : IsDGraph Coeq_ind_data. Proof. intros h k p r s. exact (forall b, ap (transport P (cglue b)) (p (f b)) @ s b = r b @ p (g b)). Defined. Local Instance isd01cat_Coeq_ind_data : IsD01Cat Coeq_ind_data. Proof. nrapply Build_IsD01Cat. - intros h h' b; exact (concat_1p_p1 _). - intros h k j p q h' k' j' p' q' b. lhs nrapply ap_pp_p. lhs nrapply (whiskerL _ (p' b)). lhs nrapply concat_p_pp. lhs nrapply (whiskerR (q' b)). nrapply concat_pp_p. Defined. Local Instance isd0gpd_Coeq_ind_data : IsD0Gpd Coeq_ind_data. Proof. intros h k p r s p' b. lhs nrapply (whiskerR (ap_V _ _)). nrapply moveL_pV. lhs nrapply concat_pp_p. lhs nrapply (whiskerL _ (p' b)^). lhs nrapply concat_p_pp. lhs nrapply (whiskerR (concat_Vp _)). nrapply concat_1p. Defined. (** Here is the functor. The domain is the fully-applied type of [Coeq_ind]: sections of [P] over [Coeq f g]. The codomain consists of input data for [Coeq_ind] given a 0-groupoid structure via [is0gpd_total]. *) Definition Coeq_ind_inv : Coeq_ind_type -> sig Coeq_ind_data. Proof. intros h. exists (h o coeq). intros b. exact (apD h (cglue b)). Defined. (** Use [Set Printing Implicit] to see the 0-groupoid structures described above. *) Local Instance is0functor_Coeq_ind_inv : Is0Functor Coeq_ind_inv. Proof. nrapply Build_Is0Functor. intros h k p. exists (p o coeq). intros b. nrapply moveL_pM. exact ((apD_homotopic p (cglue b))^). Defined. Local Instance issurjinj_Coeq_ind_inv : IsSurjInj Coeq_ind_inv. Proof. nrapply Build_IsSurjInj. - intros [h r]. exists (Coeq_ind P h r). exists (fun a => idpath). intros b. apply equiv_1p_q1. symmetry. nrapply Coeq_ind_beta_cglue. - intros h k [p p']. snrapply Coeq_ind. 1: exact p. intros b; specialize (p' b). lhs nrapply transport_paths_FlFr_D. lhs nrapply concat_pp_p. lhs nrapply (whiskerL _ p'). lhs nrapply concat_p_pp. lhs nrapply (whiskerR (concat_Vp _)). nrapply concat_1p. Defined. Definition equiv_0gpd_Coeq_ind : Build_ZeroGpd Coeq_ind_type _ _ _ $<~> Build_ZeroGpd (sig Coeq_ind_data) _ _ _. Proof. snrapply Build_CatEquiv. 1: rapply Build_Morphism_0Gpd. rapply isequiv_0gpd_issurjinj. Defined. End UnivProp. (** Here we prove that the 0-groupoid universal property established in the previous section is natural with respect to [functor_coeq]. More precisely, we show that [Coeq_ind_inv] commutes with precomposition with [k] and [functor_coeq h k p q]. *) Section UnivPropNat. Context {B A : Type} (f g : B -> A) {B' A' : Type} (f' g' : B' -> A') (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) (P : Coeq f' g' -> Type). Local Open Scope dpath_scope. (** We recall these instances to allow Coq to infer the same 0-groupoid structures as in the previous section. *) Local Existing Instances isgraph_total | 1. Local Existing Instances isgraph_paths | 2. Local Existing Instances isdgraph_Coeq_ind_data. (** Help Coq find the same graph structure for the sigma-groupoid of [Coeq_ind_data] when precomposing with [functor_coeq]. *) Local Instance isgraph_Coeq_ind_data_total : IsGraph (sig (Coeq_ind_data f g (P o functor_coeq h k p q))). Proof. rapply isgraph_total. Defined. (** Given a map out of [A'] that coequalizes the parallel pair [f'] and [g'], we construct a map out of [A] that coequalizes [f] and [g]. Precomposing with [k] yields a dependent map [forall a : A, P (coeq (k a))], and [functor_coeq_beta_cglue] gives us a way to relate the paths. *) Definition functor_Coeq_ind_data : sig (Coeq_ind_data f' g' P) -> sig (Coeq_ind_data f g (P o functor_coeq h k p q)). Proof. intros [m r]. exists (m o k). intros b. unfold Coeq_ind_data in r. apply (dp_compose' _ _ (functor_coeq_beta_cglue h k p q b)). nrefine (_ @Dp r (h b) @Dp _). 1: exact (dp_compose coeq P (p b) (apD m (p b))). exact (dp_compose coeq P (q b)^ (apD m (q b)^)). Defined. (** A helper lemma for proving functoriality of [functor_Coeq_ind_data]. This is the action of [Coeq_ind _ _ _ o functor_coeq h k p q] on the path [cglue b]. *) Local Lemma Coeq_ind_functor_coeq_beta_cglue {b : B} {m : forall a' : A', P (coeq a')} {r : forall b' : B', DPath P (cglue b') (m (f' b')) (m (g' b'))} : apD (fun x => Coeq_ind P m r (functor_coeq h k p q x)) (cglue b) = (dp_compose' (functor_coeq h k p q) P (functor_coeq_beta_cglue h k p q b))^-1 ((dp_compose coeq P (p b) (apD m (p b)) @Dp r (h b)) @Dp dp_compose coeq P (q b)^ (apD m (q b)^)). Proof. nrefine (ap _ _ @ (dp_apD_compose' _ _ _ (Coeq_ind P m r))^)^. lhs nrapply (dp_whiskerL _ (dp_apD_compose_inv coeq P (Coeq_ind P m r))^). lhs nrapply (dp_whiskerR _ (dp_whiskerR _ (dp_apD_compose_inv coeq P _)^)). lhs nrapply (dp_whiskerR _ (dp_whiskerL _ (Coeq_ind_beta_cglue _ _ _ _)^)). lhs nrapply (dp_whiskerR _ (dp_apD_pp _ _ _ _ _)^). exact (dp_apD_pp _ _ _ _ _)^. Defined. Local Instance is0functor_functor_Coeq_ind_data : Is0Functor functor_Coeq_ind_data. Proof. nrapply Build_Is0Functor. intros [m r] [n s] [u v]. exists (u o k). intros b. lhs nrapply (whiskerL _ Coeq_ind_functor_coeq_beta_cglue^). rhs nrapply (whiskerR Coeq_ind_functor_coeq_beta_cglue^ _). nrapply moveL_Mp. lhs nrapply concat_p_pp. lhs nrefine (transport_paths_FlFr_D (cglue b) (Coeq_ind_homotopy P u v _))^. apply (ds_dp (Coeq_ind P m r o _) (Coeq_ind P n s o _) _ _ _). exact (dp_apD_nat (Coeq_ind_homotopy P u v o _) (cglue b)). Defined. (** Recall the domain of this functor is the type of dependent maps [forall z : Coeq f' g', P z]. By precomposing with [functor_coeq h k p q : Coeq f g -> Coeq f' g'] we get a dependent map [forall z : Coeq f g, (P (functor_coeq h k p q z))]. *) Definition functor_Coeq_ind_type : Coeq_ind_type f' g' P -> Coeq_ind_type f g (P o functor_coeq h k p q) := fun x => x o functor_coeq h k p q. Local Instance is0functor_functor_Coeq_ind_type : Is0Functor functor_Coeq_ind_type. Proof. nrapply Build_Is0Functor. intros m n r. exact (r o functor_coeq h k p q). Defined. (** We now have two different ways of mappping from [Coeq_ind_type f' g' P] to [sig (Coeq_ind_data f g (P o functor_coeq h k p q))]. Here we construct a transformation between these two maps. << Coeq_ind_type f' g' P ---------functor_Coeq_ind_type---> Coeq_ind_type f g (P o functor_coeq h k p q) | | | | Coeq_ind_inv f' g' P Coeq_ind_inv f g (P o functor_coeq h k p q) | | | | V V sig (Coeq_ind_data f' g' P) ---functor_Coeq_ind_data---> sig (Coeq_ind_data f g (P o functor_coeq h k p q)) >> *) Definition Coeq_ind_inv_nat : Coeq_ind_inv f g (P o functor_coeq h k p q) o functor_Coeq_ind_type $=> functor_Coeq_ind_data o (Coeq_ind_inv f' g' P). Proof. intros m. exists (fun _ => idpath). intros b; simpl. lhs nrapply concat_1p; rhs nrapply concat_p1. rhs nrapply (dp_apD_compose' _ _ (functor_coeq_beta_cglue h k p q b) _). nrapply ap. nrefine (_ @ (dp_apD_pp _ _ _ _ _)^). rhs nrapply (dp_whiskerR _ (dp_apD_pp _ _ _ _ _)). lhs nrapply (dp_whiskerL _ (dp_apD_compose_inv _ _ _)^). exact (dp_whiskerR _ (dp_whiskerR _ (dp_apD_compose_inv _ _ _)^)). Defined. End UnivPropNat. Coq-HoTT-9.0/theories/Colimits/Colimit.v000066400000000000000000000401271474641544500201360ustar00rootroot00000000000000Require Import Basics Types. Require Import Diagrams.Diagram. Require Import Diagrams.Graph. Require Import Diagrams.Cocone. Require Import Diagrams.ConstantDiagram. Require Import Diagrams.CommutativeSquares. Require Import Colimits.Coeq. Local Open Scope path_scope. Generalizable All Variables. (** This file contains the definition of colimits, and functoriality results on colimits. *) (** * Colimits *) (** ** Abstract definition *) (** A colimit is the extremity of a cocone. *) Class IsColimit `(D: Diagram G) (Q: Type) := { iscolimit_cocone : Cocone D Q; iscolimit_unicocone : UniversalCocone iscolimit_cocone; }. (* Use :> and remove the two following lines, once Coq 8.16 is the minimum required version. *) #[export] Existing Instance iscolimit_cocone. Coercion iscolimit_cocone : IsColimit >-> Cocone. Arguments Build_IsColimit {G D Q} C H : rename. Arguments iscolimit_cocone {G D Q} C : rename. Arguments iscolimit_unicocone {G D Q} H : rename. (** [cocone_postcompose_inv] is defined for convenience: it is only the inverse of [cocone_postcompose]. It allows to recover the map [h] from a cocone [C']. *) Definition cocone_postcompose_inv `{D: Diagram G} {Q X} (H : IsColimit D Q) (C' : Cocone D X) : Q -> X := @equiv_inv _ _ _ (iscolimit_unicocone H X) C'. (** ** Existence of colimits *) (** Every diagram has a colimit. It could be described as the following HIT << HIT Colimit {G : Graph} (D : Diagram G) : Type := | colim : forall i, D i -> Colimit D | colimp : forall i j (f : G i j) (x : D i) : colim j (D _f f x) = colim i x . >> but we instead describe it as the coequalizer of the source and target maps of the diagram. The source type in the coequalizer ought to be: << {x : sig D & {y : sig D & {f : G x.1 y.1 & D _f f x.2 = y.2}}} >> However we notice that the path type forms a contractible component, so we can use the more efficient: << {x : sig D & {j : G & G x.1 j}} >> *) Definition Colimit {G : Graph} (D : Diagram G) : Type := @Coeq {x : sig D & {j : G & G x.1 j}} (sig D) (fun t => t.1) (fun t => (t.2.1; D _f t.2.2 t.1.2)) . Definition colim {G : Graph} {D : Diagram G} (i : G) (x : D i) : Colimit D := coeq (i ; x). Definition colimp {G : Graph} {D : Diagram G} (i j : G) (f : G i j) (x : D i) : colim j (D _f f x) = colim i x := (cglue ((i; x); j; f))^. (** To obtain a path [colim j (D _f f x) = colim j (D _f f y)] from a path [x = y], one can either use [ap (D _f f)] followed by [ap (colim j)], or conjugate [ap (colim i)] by [colimp i j f]. These paths are equivalent. *) Definition ap_colim_homotopic {G : Graph} {D : Diagram G} {i j : G} (f : G i j) {x y : D i} (p : x = y) : ap (colim j) (ap (D _f f) p) = colimp i j f x @ ap (colim i) p @ (colimp i j f y)^. Proof. lhs_V nrapply ap_compose. exact (ap_homotopic (colimp _ _ _) p). Defined. Definition Colimit_ind {G : Graph} {D : Diagram G} (P : Colimit D -> Type) (q : forall i x, P (colim i x)) (pp_q : forall (i j : G) (g: G i j) (x : D i), (@colimp G D i j g x) # (q j (D _f g x)) = q i x) : forall w, P w. Proof. srapply Coeq_ind. - intros [x i]. exact (q x i). - intros [[i x] [j f]]. cbn in f; cbn. apply moveR_transport_p. symmetry. exact (pp_q _ _ _ _). Defined. Definition Colimit_ind_beta_colimp {G : Graph} {D : Diagram G} (P : Colimit D -> Type) (q : forall i x, P (colim i x)) (pp_q : forall (i j: G) (g: G i j) (x: D i), @colimp G D i j g x # q _ (D _f g x) = q _ x) (i j : G) (g : G i j) (x : D i) : apD (Colimit_ind P q pp_q) (colimp i j g x) = pp_q i j g x. Proof. refine (apD_V _ _ @ _). apply moveR_equiv_M. apply moveR_equiv_M. refine (Coeq_ind_beta_cglue _ _ _ _ @ _). symmetry. apply moveL_transport_p_V. Defined. Definition Colimit_rec {G : Graph} {D : Diagram G} (P : Type) (C : Cocone D P) : Colimit D -> P. Proof. srapply (Colimit_ind _ C). intros i j g x. refine (transport_const _ _ @ _). apply legs_comm. Defined. Definition Colimit_rec_beta_colimp {G : Graph} {D : Diagram G} (P : Type) (C : Cocone D P) (i j : G) (g: G i j) (x: D i) : ap (Colimit_rec P C) (colimp i j g x) = legs_comm C i j g x. Proof. rapply (cancelL (transport_const (colimp i j g x) _)). srapply ((apD_const (Colimit_ind (fun _ => P) C _) (colimp i j g x))^ @ _). srapply (Colimit_ind_beta_colimp (fun _ => P) C _ i j g x). Defined. Arguments colim : simpl never. Arguments colimp : simpl never. (** The natural cocone to the colimit. *) Definition cocone_colimit {G : Graph} (D : Diagram G) : Cocone D (Colimit D) := Build_Cocone colim colimp. (** Given a cocone [C] and [f : Colimit D -> P] inducing a "homotopic" cocone, [Colimit_rec P C] is homotopic to [f]. *) Definition Colimit_rec_homotopy {G : Graph} {D : Diagram G} (P : Type) (C : Cocone D P) (f : Colimit D -> P) (h_obj : forall i, legs C i == f o colim i) (h_comm : forall i j (g : G i j) x, legs_comm C i j g x @ h_obj i x = h_obj j ((D _f g) x) @ ap f (colimp i j g x)) : Colimit_rec P C == f. Proof. snrapply Colimit_ind. - simpl. exact h_obj. - cbn beta; intros i j g x. nrapply (transport_paths_FlFr' (colimp i j g x)). lhs nrapply (Colimit_rec_beta_colimp _ _ _ _ _ _ @@ 1). apply h_comm. Defined. (** "Homotopic" cocones induces homotopic maps. *) Definition Colimit_rec_homotopy' {G : Graph} {D : Diagram G} (P : Type) (C1 C2 : Cocone D P) (h_obj : forall i, legs C1 i == legs C2 i) (h_comm : forall i j (g : G i j) x, legs_comm C1 i j g x @ h_obj i x = h_obj j (D _f g x) @ legs_comm C2 i j g x) : Colimit_rec P C1 == Colimit_rec P C2. Proof. snrapply Colimit_rec_homotopy. - apply h_obj. - intros i j g x. rhs nrapply (1 @@ Colimit_rec_beta_colimp _ _ _ _ _ _). apply h_comm. Defined. (** [Colimit_rec] is an equivalence. *) Global Instance isequiv_colimit_rec `{Funext} {G : Graph} {D : Diagram G} (P : Type) : IsEquiv (Colimit_rec (D:=D) P). Proof. srapply isequiv_adjointify. - exact (cocone_postcompose (cocone_colimit D)). - intro f. apply path_forall. snrapply Colimit_rec_homotopy. 1: reflexivity. intros; cbn. apply concat_p1_1p. - intros []. srapply path_cocone. 1: reflexivity. intros; cbn. apply equiv_p1_1q. apply Colimit_rec_beta_colimp. Defined. Definition equiv_colimit_rec `{Funext} {G : Graph} {D : Diagram G} (P : Type) : Cocone D P <~> (Colimit D -> P) := Build_Equiv _ _ _ (isequiv_colimit_rec P). (** It follows that the HIT Colimit is an abstract colimit. *) Global Instance unicocone_colimit `{Funext} {G : Graph} (D : Diagram G) : UniversalCocone (cocone_colimit D). Proof. srapply Build_UniversalCocone; intro Y. (* The goal is to show that [cocone_postcompose (cocone_colimit D)] is an equivalence, but that's the inverse to the equivalence we just defined. *) exact (isequiv_inverse (equiv_colimit_rec Y)). Defined. Global Instance iscolimit_colimit `{Funext} {G : Graph} (D : Diagram G) : IsColimit D (Colimit D) := Build_IsColimit _ (unicocone_colimit D). (** ** Functoriality of concrete colimits *) (** We will capitalize [Colimit] in the identifiers to indicate that these definitions relate to the concrete colimit defined above. Below, we will also get functoriality for abstract colimits, without the capital C. However, to apply those results to the concrete colimit uses [iscolimit_colimit], which requires [Funext], so it is also useful to give direct proofs of some facts. *) (** We first work in a more general situation. Any diagram map [m : D1 => D2] induces a map between the canonical colimit of [D1] and any cocone over [D2]. We use "half" to indicate this situation. *) Definition functor_Colimit_half {G : Graph} {D1 D2 : Diagram G} (m : DiagramMap D1 D2) {Q} (HQ : Cocone D2 Q) : Colimit D1 -> Q. Proof. apply Colimit_rec. refine (cocone_precompose m HQ). Defined. Definition functor_Colimit_half_beta_colimp {G : Graph} {D1 D2 : Diagram G} (m : DiagramMap D1 D2) {Q} (HQ : Cocone D2 Q) (i j : G) (g : G i j) (x : D1 i) : ap (functor_Colimit_half m HQ) (colimp i j g x) = legs_comm (cocone_precompose m HQ) i j g x := Colimit_rec_beta_colimp _ _ _ _ _ _. (** Homotopic diagram maps induce homotopic maps. *) Definition functor_Colimit_half_homotopy {G : Graph} {D1 D2 : Diagram G} {m1 m2 : DiagramMap D1 D2} (h : DiagramMap_homotopy m1 m2) {Q} (HQ : Cocone D2 Q) : functor_Colimit_half m1 HQ == functor_Colimit_half m2 HQ. Proof. destruct h as [h_obj h_comm]. snrapply Colimit_rec_homotopy'. - intros i x; cbn. apply ap, h_obj. - intros i j g x; simpl. Open Scope long_path_scope. (* TODO: Most of the work here comes from a mismatch between the direction of the path in [DiagramMap_comm] and [legs_comm] in the [Cocone] record, causing a reversal in [cocone_precompose]. There is no reversal in [cocone_postcompose], so I think [Cocone] should change. If that is done, then this result wouldn't be needed at all, and one could directly use [Colimit_rec_homotopy']. *) rewrite ap_V. lhs nrapply concat_pp_p. apply moveR_Vp. rewrite ! concat_p_pp. rewrite <- 2 ap_pp. rewrite h_comm. rewrite concat_pp_V. rewrite <- ap_compose. exact (concat_Ap (legs_comm HQ i j g) (h_obj i x))^. Close Scope long_path_scope. Defined. (** Now we specialize to the case where the second cone is a colimiting cone. *) Definition functor_Colimit {G : Graph} {D1 D2 : Diagram G} (m : DiagramMap D1 D2) : Colimit D1 -> Colimit D2 := functor_Colimit_half m (cocone_colimit D2). (** A homotopy between diagram maps [m1, m2 : D1 => D2] gives a homotopy between the induced maps. *) Definition functor_Colimit_homotopy {G : Graph} {D1 D2 : Diagram G} {m1 m2 : DiagramMap D1 D2} (h : DiagramMap_homotopy m1 m2) : functor_Colimit m1 == functor_Colimit m2 := functor_Colimit_half_homotopy h _. (** Composition of diagram maps commutes with [functor_Colimit_half], provided the first map uses [functor_Colimit]. *) Definition functor_Colimit_half_compose {G : Graph} {A B C : Diagram G} (f : DiagramMap A B) (g : DiagramMap B C) {Q} (HQ : Cocone C Q) : functor_Colimit_half (diagram_comp g f) HQ == functor_Colimit_half g HQ o functor_Colimit f. Proof. snrapply Colimit_rec_homotopy. - reflexivity. - intros i j k x; cbn. apply equiv_p1_1q. unfold comm_square_comp. Open Scope long_path_scope. lhs nrapply (ap_V _ _ @@ 1). lhs nrapply (inverse2 (ap_pp (HQ j) _ _) @@ 1). lhs nrapply (inv_pp _ _ @@ 1). symmetry. lhs nrapply (ap_compose (functor_Colimit f)). lhs nrapply (ap _ (Colimit_rec_beta_colimp _ _ _ _ _ _)). (* [legs_comm] unfolds to a composite of paths, but the next line works best without unfolding it. *) lhs nrapply ap_pp. lhs nrefine (1 @@ _). 1: nrapply functor_Colimit_half_beta_colimp. simpl. lhs nrapply concat_p_pp. nrefine (_ @@ 1). apply ap011. 2: nrapply ap_V. lhs_V nrapply (ap_compose (colim j)); simpl. lhs nrapply (ap_V (HQ j o g j) _). apply ap, ap_compose. Close Scope long_path_scope. Defined. (** ** Functoriality of abstract colimits *) Section FunctorialityColimit. Context `{Funext} {G : Graph}. (** Colimits are preserved by composition with a (diagram) equivalence. *) Definition iscolimit_precompose_equiv {D1 D2 : Diagram G} (m : D1 ~d~ D2) {Q : Type} : IsColimit D2 Q -> IsColimit D1 Q. Proof. intros HQ. srapply (Build_IsColimit (cocone_precompose m HQ) _). apply cocone_precompose_equiv_universality, HQ. Defined. Definition iscolimit_postcompose_equiv {D: Diagram G} `(f: Q <~> Q') : IsColimit D Q -> IsColimit D Q'. Proof. intros HQ. srapply (Build_IsColimit (cocone_postcompose HQ f) _). apply cocone_postcompose_equiv_universality, HQ. Defined. (** A diagram map [m : D1 => D2] induces a map between any two colimits of [D1] and [D2]. *) Definition functor_colimit {D1 D2 : Diagram G} (m : DiagramMap D1 D2) {Q1 Q2} (HQ1 : IsColimit D1 Q1) (HQ2 : IsColimit D2 Q2) : Q1 -> Q2 := cocone_postcompose_inv HQ1 (cocone_precompose m HQ2). (** And this map commutes with diagram map. *) Definition functor_colimit_commute {D1 D2 : Diagram G} (m : DiagramMap D1 D2) {Q1 Q2} (HQ1 : IsColimit D1 Q1) (HQ2: IsColimit D2 Q2) : cocone_precompose m HQ2 = cocone_postcompose HQ1 (functor_colimit m HQ1 HQ2) := (eisretr (cocone_postcompose HQ1) _)^. (** Additional coherence with postcompose and precompose. *) Definition cocone_precompose_postcompose_comp {D1 D2 : Diagram G} (m : DiagramMap D1 D2) {Q1 Q2 : Type} (HQ1 : IsColimit D1 Q1) (HQ2 : IsColimit D2 Q2) {T : Type} (t : Q2 -> T) : cocone_postcompose HQ1 (t o functor_colimit m HQ1 HQ2) = cocone_precompose m (cocone_postcompose HQ2 t). Proof. lhs nrapply cocone_postcompose_comp. lhs_V exact (ap (fun x => cocone_postcompose x t) (functor_colimit_commute m HQ1 HQ2)). nrapply cocone_precompose_postcompose. Defined. (** In order to show that colimits are functorial, we show that this is true after precomposing with the cocone. *) Definition postcompose_functor_colimit_compose {D1 D2 D3 : Diagram G} (m : DiagramMap D1 D2) (n : DiagramMap D2 D3) {Q1 Q2 Q3} (HQ1 : IsColimit D1 Q1) (HQ2 : IsColimit D2 Q2) (HQ3 : IsColimit D3 Q3) : cocone_postcompose HQ1 (functor_colimit n HQ2 HQ3 o functor_colimit m HQ1 HQ2) = cocone_postcompose HQ1 (functor_colimit (diagram_comp n m) HQ1 HQ3). Proof. lhs nrapply cocone_precompose_postcompose_comp. lhs_V nrapply (ap _ (functor_colimit_commute n HQ2 HQ3)). lhs nrapply cocone_precompose_comp. nrapply functor_colimit_commute. Defined. Definition functor_colimit_compose {D1 D2 D3 : Diagram G} (m : DiagramMap D1 D2) (n : DiagramMap D2 D3) {Q1 Q2 Q3} (HQ1 : IsColimit D1 Q1) (HQ2 : IsColimit D2 Q2) (HQ3 : IsColimit D3 Q3) : functor_colimit n HQ2 HQ3 o functor_colimit m HQ1 HQ2 = functor_colimit (diagram_comp n m) HQ1 HQ3 := @equiv_inj _ _ (cocone_postcompose HQ1) (iscolimit_unicocone HQ1 Q3) _ _ (postcompose_functor_colimit_compose m n HQ1 HQ2 HQ3). (** ** Colimits of equivalent diagrams *) (** Now we have that two equivalent diagrams have equivalent colimits. *) Context {D1 D2 : Diagram G} (m : D1 ~d~ D2) {Q1 Q2} (HQ1 : IsColimit D1 Q1) (HQ2 : IsColimit D2 Q2). Definition functor_colimit_eissect : functor_colimit m HQ1 HQ2 o functor_colimit (diagram_equiv_inv m) HQ2 HQ1 == idmap. Proof. apply ap10. srapply (equiv_inj (cocone_postcompose HQ2) _). 1: apply HQ2. etransitivity. 2:symmetry; apply cocone_postcompose_identity. etransitivity. 1: apply cocone_postcompose_comp. rewrite eisretr, cocone_precompose_postcompose, eisretr. rewrite cocone_precompose_comp, diagram_inv_is_section. apply cocone_precompose_identity. Defined. Definition functor_colimit_eisretr : functor_colimit (diagram_equiv_inv m) HQ2 HQ1 o functor_colimit m HQ1 HQ2 == idmap. Proof. apply ap10. srapply (equiv_inj (cocone_postcompose HQ1) _). 1: apply HQ1. etransitivity. 2:symmetry; apply cocone_postcompose_identity. etransitivity. 1: apply cocone_postcompose_comp. rewrite eisretr, cocone_precompose_postcompose, eisretr. rewrite cocone_precompose_comp, diagram_inv_is_retraction. apply cocone_precompose_identity. Defined. Global Instance isequiv_functor_colimit : IsEquiv (functor_colimit m HQ1 HQ2) := isequiv_adjointify _ _ functor_colimit_eissect functor_colimit_eisretr. Definition equiv_functor_colimit : Q1 <~> Q2 := Build_Equiv _ _ _ isequiv_functor_colimit. End FunctorialityColimit. (** ** Unicity of colimits *) (** A particular case of the functoriality result is that all colimits of a diagram are equivalent (and hence equal in presence of univalence). *) Theorem colimit_unicity `{Funext} {G : Graph} {D : Diagram G} {Q1 Q2 : Type} (HQ1 : IsColimit D Q1) (HQ2 : IsColimit D Q2) : Q1 <~> Q2. Proof. srapply equiv_functor_colimit. srapply (Build_diagram_equiv (diagram_idmap D)). Defined. (** ** Colimits are left adjoint to constant diagram *) Theorem colimit_adjoint `{Funext} {G : Graph} {D : Diagram G} {C : Type} : (Colimit D -> C) <~> DiagramMap D (diagram_const C). Proof. symmetry. refine (equiv_colimit_rec C oE _). apply equiv_diagram_const_cocone. Defined. Coq-HoTT-9.0/theories/Colimits/Colimit_Coequalizer.v000066400000000000000000000045621474641544500225040ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.ParallelPair. Require Import Diagrams.Cocone. Require Import Colimits.Colimit. Require Import Colimits.Coeq. Generalizable All Variables. (** * Coequalizer as a colimit *) (** In this file, we define [Coequalizer] the coequalizer of two maps as the colimit of a particuliar diagram, and then show that it is equivalent to [Coeq] the primitive coequalizer defined as an HIT. *) (** ** [Coequalizer] *) Section Coequalizer. Context {A B : Type}. Definition IsCoequalizer (f g : B -> A) := IsColimit (parallel_pair f g). Definition Coequalizer (f g : B -> A) := Colimit (parallel_pair f g). (** ** Equivalence with [Coeq] *) Context {f g : B -> A}. Definition cocone_Coeq : Cocone (parallel_pair f g) (Coeq f g). Proof. srapply Build_Cocone. + intros []; [exact (coeq o g)| exact coeq]. + intros i j phi x; destruct i, j, phi; simpl; [ exact (cglue x) | reflexivity ]. Defined. Lemma iscoequalizer_Coeq `{Funext} : IsColimit (parallel_pair f g) (Coeq f g). Proof. srapply (Build_IsColimit cocone_Coeq). srapply Build_UniversalCocone. intros X. srapply isequiv_adjointify. - intros C. srapply Coeq_rec. + exact (legs C false). + intros b. etransitivity. * exact (legs_comm C true false true b). * exact (legs_comm C true false false b)^. - intros C. srapply path_cocone. + intros i x; destruct i; simpl. * exact (legs_comm C true false false x). * reflexivity. + intros i j phi x; destruct i, j, phi; simpl. * hott_simpl. match goal with | [|- ap (Coeq_rec ?a ?b ?c) _ @ _ = _ ] => rewrite (Coeq_rec_beta_cglue a b c) end. hott_simpl. * reflexivity. - intros F. apply path_forall. match goal with | [|- ?G == _ ] => simple refine (Coeq_ind (fun w => G w = F w) _ _) end. + reflexivity. + intros b; simpl. nrapply (transport_paths_FlFr' (g:=F)). apply equiv_p1_1q. refine (Coeq_rec_beta_cglue _ _ _ _ @ _). apply concat_p1. Defined. Definition equiv_Coeq_Coequalizer `{Funext} : Coeq f g <~> Coequalizer f g. Proof. srapply colimit_unicity. 3: eapply iscoequalizer_Coeq. eapply iscolimit_colimit. Defined. End Coequalizer. Coq-HoTT-9.0/theories/Colimits/Colimit_Flattening.v000066400000000000000000000175131474641544500223140ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Diagram. Require Import Diagrams.Graph. Require Import Diagrams.Cocone. Require Import Diagrams.DDiagram. Require Import Colimits.Colimit. Local Open Scope path_scope. (** * Flattening lemma *) (** This file provides a proof of the flattening lemma for colimits. This lemma describes the type [sig E'] when [E' : colimit D -> Type] is a type family defined by recursion on a colimit. The flattening lemma in the case of coequalizers is presented in section 6.12 of the HoTT book and is in Colimits/Coeq.v. *) (** TODO: See whether there's a straightforward way to deduce the flattening lemma for general colimits from the version for coequalizers. *) Section Flattening. (** ** Equifibered diagrams *) Context `{Univalence} {G : Graph} (D : Diagram G) (E : DDiagram D) `(Equifibered _ _ E). Let E_f {i j : G} (g : G i j) (x : D i) : E (i; x) -> E (j; (D _f g) x) := @arr _ E (i; x) (j; D _f g x) (g; 1). (** Now, given an equifibered diagram and using univalence, one can define a type family [E' : colimit D -> Type] by recursion on the colimit. *) Definition E' : Colimit D -> Type. Proof. apply Colimit_rec. simple refine (Build_Cocone _ _). - exact (fun i x => E (i; x)). - intros i j g x; cbn. symmetry. srapply (path_universe (E_f _ _)). Defined. (** ** Helper lemmas *) Definition transport_E' {i j : G} (g : G i j) (x : D i) (y : E (i; x)) : transport E' (colimp i j g x) (E_f g x y) = y. Proof. refine (transport_idmap_ap _ _ _ @ _). srefine (transport2 idmap _ _ @ _). 2: apply Colimit_rec_beta_colimp; cbn. apply (moveR_transport_V idmap). symmetry; apply transport_path_universe. Defined. Definition transport_E'_V {i j : G} (g : G i j) (x : D i) (y : E (i; x)) : transport E' (colimp i j g x)^ y = E_f g x y. Proof. apply moveR_transport_V. symmetry. apply transport_E'. Defined. Definition transport_E'_V_E' {i j : G} (g : G i j) (x : D i) (y : E (i; x)) : transport_E' g x y = ap (transport E' (colimp i j g x)) (transport_E'_V g x y)^ @ transport_pV E' (colimp i j g x) y. Proof. rewrite moveR_transport_V_V, inv_V. symmetry; apply ap_transport_transport_pV. Defined. (** ** Main result *) (** We define the cocone over the sigma diagram to [sig E']. *) Definition cocone_E' : Cocone (diagram_sigma E) (sig E'). Proof. srapply Build_Cocone; cbn. - intros i w. exists (colim i w.1); cbn. exact w.2. - intros i j g x; cbn. srapply path_sigma'. + apply colimp. + apply transport_E'. Defined. (** And we directly prove that it is universal. We break the proof into parts to slightly speed it up. *) Local Opaque path_sigma ap11. Local Definition cocone_extends Z: Cocone (diagram_sigma E) Z -> ((sig E') -> Z). Proof. intros [q qq]; cbn in *. intros [x y]; revert x y. srapply Colimit_ind; cbn. + intros i x y; exact (q i (x; y)). + intros i j g x; cbn. funext y. refine (transport_arrow_toconst _ _ _ @ _). refine (_ @ qq i j g (x; y)). cbn; f_ap. refine (path_sigma' _ 1 _); cbn. apply transport_E'_V. Defined. Local Definition cocone_isretr Z : cocone_postcompose cocone_E' o cocone_extends Z == idmap. Proof. intros [q qq]. srapply path_cocone. + intros i x; reflexivity. + intros i j g [x y]. rewrite concat_1p, concat_p1. cbn; rewrite ap_path_sigma. simpl. rewrite Colimit_ind_beta_colimp. rewrite ap10_path_forall. rewrite concat_pp_p, concat_V_pp. refine (_ @ concat_1p _). refine (concat_p_pp _ _ _ @ _). refine (_ @@ 1). match goal with |- ap _ ?X @ _ = _ => set (p := X) end. assert (r : transport_E'_V g x y = p^). { subst p. exact (moveL_transport_V_V E' _ _ _ _)^. } rewrite r; clear r. destruct p. reflexivity. Defined. (* 0.1s *) Local Definition cocone_issect Z : cocone_extends Z o cocone_postcompose cocone_E' == idmap. Proof. intro f. funext [x y]. revert x y. srapply Colimit_ind. + cbn; reflexivity. + intros i j g x; cbn. funext y. set (L := cocone_extends Z (cocone_postcompose cocone_E' f)). refine (transport_forall _ _ _ @ _). nrapply (transport_paths_FlFr' (f:=fun y0 => L (_; y0))). lhs nrapply concat_p1. lhs_V nrapply concat_1p. refine (_^ @@ 1). lhs rapply (transportD_is_transport E' (fun w => L w = f w)). nrapply transport_paths_FlFr'; apply equiv_p1_1q. rewrite ap_path_sigma. rewrite Colimit_ind_beta_colimp. rewrite ap10_path_forall. simpl. clear L. rewrite concat_pp_p, concat_V_pp. rewrite ap11_is_ap10_ap01. cbn. rewrite concat_1p. rewrite (ap_compose (fun y => (colim j ((D _f g) x); y)) f). rewrite (ap_compose (fun x0 : exists x0 : D j, E (j; x0) => (colim j (pr1 x0); pr2 x0)) f). rewrite <- ! (ap_pp f). apply (ap (ap f)). symmetry. refine (_ @ concat_pp_p _ _ _). match goal with |- _ = (ap ?ff ?pp1 @ ?pp2) @ ?pp3 => set (p1 := pp1) end. assert (p1eq : p1 = ap (transport E' (colimp i j g x)^) (transport_pV E' (colimp i j g x) y)^). { subst p1; clear. etransitivity. 1: srapply moveL_transport_V_1. etransitivity. 1: nrapply inverse2; snrapply transport_VpV. symmetry; apply ap_V. } rewrite p1eq; clear p1eq p1. rewrite <- ap_compose; cbn. rewrite (ap_path_sigma (fun x => E (j; x)) (fun x y => (colim j x; y))). cbn; rewrite !concat_p1, concat_pp_p, ap_V. apply moveL_Vp. match goal with |- ?pp1 @ _ = ?pp2 @ _ => set (p1 := pp1); change pp2 with (path_sigma' E' 1 (transport_E'_V g x (transport E' (colimp i j g x) (transport E' (colimp i j g x)^ y)))) end. assert (p1eq : p1 = path_sigma' E' 1 (transport_Vp _ _ _)). { subst p1. rewrite <- ap_exist. rewrite (ap_compose (transport E' (colimp i j g x)^) (fun v => (colim j ((D _f g) x); v))). f_ap; set (p := colimp i j g x). clear; symmetry. apply transport_VpV. } rewrite p1eq; clear p1eq p1. rewrite <- !path_sigma_pp_pp'; f_ap. rewrite concat_p1, concat_pp_p. refine (1 @@ _). apply moveL_Mp. rewrite <- ap_V, <- ap_pp. srefine (_ @ _). - refine (ap (transport E' (colimp i j g x)) _). refine ((transport_E'_V _ _ _)^ @ _). refine (ap _ (transport_pV _ _ _)). - f_ap. refine (1 @@ _). apply transport_VpV. - set (e := transport E' (colimp i j g x) (transport E' (colimp i j g x)^ y)). rewrite ap_pp, <- ap_compose. refine (_ @ (transport_E'_V_E' _ _ _)^). refine (1 @@ _). subst e. refine (_ @ (transport_pVp _ _ _)^). rewrite ap_compose. f_ap; symmetry. apply transport_VpV. Defined. (* TODO: a little slow, 0.40s *) Global Instance unicocone_cocone_E' : UniversalCocone cocone_E'. Proof. srapply Build_UniversalCocone. intro Z; srapply isequiv_adjointify. - exact (cocone_extends Z). - exact (cocone_isretr Z). - exact (cocone_issect Z). Defined. (** The flattening lemma follows by colimit unicity. *) Definition flattening_lemma : Colimit (diagram_sigma E) <~> sig E'. Proof. srapply colimit_unicity. 3: apply iscolimit_colimit. rapply Build_IsColimit. apply unicocone_cocone_E'. Defined. End Flattening. (* TODO: ending the section is a bit slow (0.2s). But simply removing the Section (and changing "Let" to "Local Definition") causes the whole file to be much slower. It should be possible to remove the section without making the whole file slower. *) Coq-HoTT-9.0/theories/Colimits/Colimit_Prod.v000066400000000000000000000025621474641544500211230ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Diagram. Require Import Colimits.Colimit. Require Import Colimits.Colimit_Sigma. Require Import Diagrams.Graph. (** * Colimit of product by a constant type *) (** Given a diagram [D], one of his colimits [Q] and a type [A], one can consider the diagram of the products of the types of [D] and [A]. Then, a colimit of such a diagram is [A * Q]. *) (** This is the constant case of the file [Colimit_Sigma] and we reuse its results. *) Section ColimitProd. Context `{Funext} {G : Graph} (D : Diagram G) (A : Type). Definition prod_diagram : Diagram G. Proof. srapply Build_Diagram. - exact (fun i => A * (D i)). - simpl; intros i j f x. exact (fst x, D _f f (snd x)). Defined. Definition diagram_equiv_prod_sigma : sigma_diagram (fun _ : A => D) ~d~ prod_diagram. Proof. unshelve econstructor. - srapply Build_DiagramMap; cbn. + intro i; apply equiv_sigma_prod0. + reflexivity. - intro i; cbn. apply equiv_sigma_prod0. Defined. Lemma iscolimit_prod {Q : Type} (HQ : IsColimit D Q) : IsColimit prod_diagram (A * Q). Proof. eapply iscolimit_postcompose_equiv. - apply equiv_sigma_prod0. - eapply iscolimit_precompose_equiv. + symmetry; apply diagram_equiv_prod_sigma. + by apply iscolimit_sigma. Defined. End ColimitProd. Coq-HoTT-9.0/theories/Colimits/Colimit_Pushout.v000066400000000000000000000164471474641544500216750ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Graph. Require Import Diagrams.Diagram. Require Import Diagrams.Span. Require Import Diagrams.Cocone. Require Import Colimits.Colimit. (* We require this now, but will import later. *) Require Colimits.Pushout. Local Open Scope path_scope. (** * Pushout as a colimit *) (** In this file, we define [PO] the pushout of two maps as the colimit of a particular diagram, and then show that it is equivalent to [pushout] the primitive pushout defined as an HIT. *) (** ** [PO] *) Section PO. Context {A B C : Type}. Definition Build_span_cocone {f : A -> B} {g : A -> C} {Z : Type} (inl' : B -> Z) (inr' : C -> Z) (pp' : inl' o f == inr' o g) : Cocone (span f g) Z. Proof. srapply Build_Cocone. - intros [|[]]; [ exact (inr' o g) | exact inl' | exact inr' ]. - intros [u|b] [u'|b'] []; cbn. destruct b'. + exact pp'. + reflexivity. Defined. Definition pol' {f : A -> B} {g : A -> C} {Z} (Co : Cocone (span f g) Z) : B -> Z := legs Co (inr true). Definition por' {f : A -> B} {g : A -> C} {Z} (Co : Cocone (span f g) Z) : C -> Z := legs Co (inr false). Definition popp' {f : A -> B} {g : A -> C} {Z} (Co : Cocone (span f g) Z) : pol' Co o f == por' Co o g := fun x => legs_comm Co (inl tt) (inr true) tt x @ (legs_comm Co (inl tt) (inr false) tt x)^. Definition is_PO (f : A -> B) (g : A -> C) := IsColimit (span f g). Definition PO (f : A -> B) (g : A -> C) := Colimit (span f g). Context {f : A -> B} {g : A -> C}. Definition pol : B -> PO f g := colim (D:=span f g) (inr true). Definition por : C -> PO f g := colim (D:=span f g) (inr false). Definition popp (a : A) : pol (f a) = por (g a) := colimp (D:=span f g) (inl tt) (inr true) tt a @ (colimp (D:=span f g) (inl tt) (inr false) tt a)^. (** We next define the eliminators [PO_ind] and [PO_rec]. To make later proof terms smaller, we define two things we'll need. *) Definition PO_ind_obj (P : PO f g -> Type) (l' : forall b, P (pol b)) (r' : forall c, P (por c)) : forall (i : span_graph) (x : obj (span f g) i), P (colim i x). Proof. intros [u|[]] x; cbn. - exact (@colimp _ (span f g) (inl u) (inr true) tt x # l' (f x)). - exact (l' x). - exact (r' x). Defined. Definition PO_ind_arr (P : PO f g -> Type) (l' : forall b, P (pol b)) (r' : forall c, P (por c)) (pp' : forall a, popp a # l' (f a) = r' (g a)) : forall (i j : span_graph) (e : span_graph i j) (ar : span f g i), transport P (colimp i j e ar) (PO_ind_obj P l' r' j (((span f g) _f e) ar)) = PO_ind_obj P l' r' i ar. Proof. intros [u|b] [u'|b'] []; cbn. destruct b'; cbn. 1: reflexivity. unfold popp in pp'. intro a. apply moveR_transport_p. rhs_V nrapply transport_pp. destruct u. symmetry; apply pp'. Defined. Definition PO_ind (P : PO f g -> Type) (l' : forall b, P (pol b)) (r' : forall c, P (por c)) (pp' : forall a, popp a # l' (f a) = r' (g a)) : forall w, P w := Colimit_ind P (PO_ind_obj P l' r') (PO_ind_arr P l' r' pp'). Definition PO_ind_beta_pp (P : PO f g -> Type) (l' : forall b, P (pol b)) (r' : forall c, P (por c)) (pp' : forall a, popp a # l' (f a) = r' (g a)) : forall x, apD (PO_ind P l' r' pp') (popp x) = pp' x. Proof. intro x. lhs nrapply apD_pp. rewrite (Colimit_ind_beta_colimp P _ _ (inl tt) (inr true) tt x). rewrite concat_p1, apD_V. rewrite (Colimit_ind_beta_colimp P _ _ (inl tt) (inr false) tt x). rewrite moveR_transport_p_V, moveR_moveL_transport_p. rewrite inv_pp, inv_V. apply concat_p_Vp. Defined. Definition PO_rec (P: Type) (l': B -> P) (r': C -> P) (pp': l' o f == r' o g) : PO f g -> P := Colimit_rec P (Build_span_cocone l' r' pp'). Definition PO_rec_beta_pp (P: Type) (l': B -> P) (r': C -> P) (pp': l' o f == r' o g) : forall x, ap (PO_rec P l' r' pp') (popp x) = pp' x. Proof. intro x. unfold popp. refine (ap_pp _ _ _ @ _ @ concat_p1 _). refine (_ @@ _). 1: exact (Colimit_rec_beta_colimp P (Build_span_cocone l' r' pp') (inl tt) (inr true) tt x). lhs nrapply ap_V. apply (inverse2 (q:=1)). exact (Colimit_rec_beta_colimp P (Build_span_cocone l' r' pp') (inl tt) (inr false) tt x). Defined. (** A nice property: the pushout of an equivalence is an equivalence. *) Global Instance PO_of_equiv (Hf : IsEquiv f) : IsEquiv por. Proof. srapply isequiv_adjointify. - srapply PO_rec. + exact (g o f^-1). + exact idmap. + intro x. apply ap, eissect. - srapply PO_ind; cbn. + intro. refine ((popp _)^ @ _). apply ap, eisretr. + reflexivity. + intro a; cbn. nrapply transport_paths_FFlr'. refine (concat_p1 _ @ _). rewrite PO_rec_beta_pp. rewrite eisadj. destruct (eissect f a); cbn. rewrite concat_p1. symmetry; apply concat_Vp. - cbn; reflexivity. Defined. End PO. (** ** Equivalence with [pushout] *) Section is_PO_pushout. Import Colimits.Pushout. Context `{Funext} {A B C : Type} {f : A -> B} {g : A -> C}. Definition is_PO_pushout : is_PO f g (Pushout f g). Proof. srapply Build_IsColimit. - srapply Build_span_cocone. + exact (push o inl). + exact (push o inr). + exact pglue. - srapply Build_UniversalCocone. intro Y; srapply isequiv_adjointify. + intro Co. srapply Pushout_rec. * exact (pol' Co). * exact (por' Co). * exact (popp' Co). + intros [Co Co']. srapply path_cocone. * intros [[]|[]] x; simpl. 1: apply (Co' (inl tt) (inr false) tt). all: reflexivity. * cbn beta. intros [u|b] [u'|b'] [] x. destruct u, b'; cbn. 2: reflexivity. rhs nrapply concat_1p. lhs refine (_ @@ 1). 1: nrapply Pushout_rec_beta_pglue. unfold popp', legs_comm. apply concat_pV_p. + intro h. apply path_forall. srapply Pushout_ind; cbn. 1,2: reflexivity. intro a; cbn beta. nrapply transport_paths_FlFr'; apply equiv_p1_1q. unfold popp'; cbn. rhs_V nrapply concat_p1. nrapply Pushout_rec_beta_pglue. Defined. Definition equiv_pushout_PO : Pushout f g <~> PO f g. Proof. srapply colimit_unicity. 3: eapply is_PO_pushout. eapply iscolimit_colimit. Defined. Definition equiv_pushout_PO_beta_pglue (a : A) : ap equiv_pushout_PO (pglue a) = popp a. Proof. cbn. refine (_ @ _). 1: nrapply Pushout_rec_beta_pglue. unfold popp'; cbn. rewrite 2 concat_1p. reflexivity. Defined. Definition Pushout_rec_PO_rec (P : Type) (pushb : B -> P) (pushc : C -> P) (pusha : forall a : A, pushb (f a) = pushc (g a)) : Pushout_rec P pushb pushc pusha == PO_rec P pushb pushc pusha o equiv_pushout_PO. Proof. snrapply Pushout_ind. 1, 2: reflexivity. intro a; cbn beta. nrapply transport_paths_FlFr'; apply equiv_p1_1q. lhs exact (Pushout_rec_beta_pglue P pushb pushc pusha a). symmetry. lhs nrapply (ap_compose equiv_pushout_PO _ (pglue a)). lhs nrapply (ap _ (equiv_pushout_PO_beta_pglue a)). nrapply PO_rec_beta_pp. Defined. End is_PO_pushout. Coq-HoTT-9.0/theories/Colimits/Colimit_Pushout_Flattening.v000066400000000000000000000051531474641544500240400ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Diagram. Require Import Diagrams.DDiagram. Require Import Diagrams.Span. Require Import Diagrams.Cocone. Require Import Colimits.Colimit. Require Import Colimits.Colimit_Pushout. Require Import Colimits.Colimit_Flattening. (** * Pushout case *) (** We deduce the flattening lemma for pushouts from the flattening lemma for general colimits. This pushout is defined as the colimit of a span and is not the pushout that appears elsewhere in the library. The flattening lemma for the pushout that appears elsewhere in the library is in Colimits/Pushout.v. *) Section POCase. Context `{Univalence} {A B C} {f: A -> B} {g: A -> C}. Context (A0 : A -> Type) (B0 : B -> Type) (C0 : C -> Type) (f0 : forall x, A0 x <~> B0 (f x)) (g0 : forall x, A0 x <~> C0 (g x)). Definition POCase_P : PO f g -> Type. Proof. simple refine (PO_rec Type B0 C0 _). cbn; intro x. eapply path_universe_uncurried. etransitivity. - symmetry. apply f0. - apply g0. Defined. Definition POCase_E : DDiagram (span f g). Proof. simple refine (Build_Diagram _ _ _); cbn. - intros [[] x]; revert x. + exact A0. + destruct b; assumption. - intros [[[]|[]] x] [[[]|[]] y]; cbn; intros [[] p]. + exact (fun y => p # (f0 x y)). + exact (fun y => p # (g0 x y)). Defined. Global Instance POCase_HE : Equifibered POCase_E. Proof. apply Build_Equifibered. intros [[]|[]] [[]|[]] [] x; compute. - exact (equiv_isequiv (f0 x)). - exact (equiv_isequiv (g0 x)). Defined. Definition PO_flattening : PO (functor_sigma f f0) (functor_sigma g g0) <~> exists x, POCase_P x. Proof. transitivity (Colimit (diagram_sigma POCase_E)). { apply equiv_path. unfold PO; apply ap. srapply path_diagram; cbn. - intros [|[]]; cbn. all: reflexivity. - intros [[]|[]] [[]|[]] [] x; cbn in *. all: reflexivity. } transitivity (exists x, E' (span f g) POCase_E POCase_HE x). - apply flattening_lemma. - apply equiv_functor_sigma_id. intro x. apply equiv_path. unfold E', POCase_P, PO_rec. f_ap. srapply path_cocone. + intros [[]|[]] y; cbn. 1: apply path_universe_uncurried; apply g0. all: reflexivity. + intros [[]|[]] [[]|[]] []; cbn. * intro y. simpl. rhs nrapply concat_1p. unfold path_universe. lhs nrapply (ap (fun x => x @ _) _^). 1: nrapply path_universe_V_uncurried. exact (path_universe_compose (f0 y)^-1 (g0 y))^. * intros; apply concat_Vp. Defined. End POCase. Coq-HoTT-9.0/theories/Colimits/Colimit_Sigma.v000066400000000000000000000116111474641544500212520ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Diagram. Require Import Diagrams.Graph. Require Import Diagrams.Cocone. Require Import Colimits.Colimit. (** * Colimit of the dependent sum of a family of diagrams *) (** Given a family of diagrams [D y], and a colimit [Q y] of each diagram, one can consider the diagram of the sigmas of the types of the [D y]s. Then, a colimit of such a diagram is the sigma of the [Q y]s. *) Section ColimitSigma. Context `{Funext} {G : Graph} {Y : Type} (D : Y -> Diagram G). (** The diagram of the sigmas. *) Definition sigma_diagram : Diagram G. Proof. srapply Build_Diagram. - exact (fun i => {y: Y & D y i}). - simpl; intros i j g x. exact (x.1; D x.1 _f g x.2). Defined. (** The embedding, for a particular [y], of [D(y)] in the sigma diagram. *) Definition sigma_diagram_map (y: Y) : DiagramMap (D y) sigma_diagram. Proof. srapply Build_DiagramMap. 1: exact (fun i x => (y; x)). reflexivity. Defined. Context {Q : Y -> Type}. (** The sigma of a family of cocones. *) Definition sigma_cocone (C : forall y, Cocone (D y) (Q y)) : Cocone sigma_diagram (sig Q). Proof. srapply Build_Cocone; simpl; intros i x. 1: exact (x.1; legs (C x.1) i x.2). simpl; intros g x'. srapply path_sigma'. 1: reflexivity. apply legs_comm. Defined. (** The main result: [sig Q] is a colimit of the diagram of sigma types. *) Lemma iscolimit_sigma (HQ : forall y, IsColimit (D y) (Q y)) : IsColimit sigma_diagram (sig Q). Proof. pose (SigmaC := sigma_cocone (fun y => HQ y)). srapply (Build_IsColimit SigmaC). srapply Build_UniversalCocone. intros X; srapply isequiv_adjointify. - intros CX x. srapply (cocone_postcompose_inv (HQ x.1) _ x.2). srapply (cocone_precompose _ CX). apply sigma_diagram_map. - intro CX. pose (CXy := fun y => cocone_precompose (sigma_diagram_map y) CX). change (cocone_postcompose SigmaC (fun x => cocone_postcompose_inv (HQ x.1) (CXy x.1) x.2) = CX). srapply path_cocone; simpl. + intros i x. change (legs (cocone_postcompose (HQ x.1) (cocone_postcompose_inv (HQ x.1) (CXy x.1))) i x.2 = CX i x). exact (ap10 (apD10 (ap legs (eisretr (cocone_postcompose (HQ x.1)) (CXy _))) i) x.2). + intros i j g [y x]; simpl. set (py := (eisretr (cocone_postcompose (HQ y)) (CXy y))). set (py1 := ap legs py). specialize (apD legs_comm py); intro py2. simpl in *. rewrite (path_forall _ _(transport_forall_constant _ _)) in py2. apply apD10 in py2; specialize (py2 i); simpl in py2. rewrite (path_forall _ _(transport_forall_constant _ _)) in py2. apply apD10 in py2; specialize (py2 j); simpl in py2. rewrite (path_forall _ _(transport_forall_constant _ _)) in py2. apply apD10 in py2; specialize (py2 g); simpl in py2. rewrite (path_forall _ _(transport_forall_constant _ _)) in py2. apply apD10 in py2; specialize (py2 x); simpl in py2. rewrite transport_paths_FlFr in py2. rewrite concat_1p, concat_pp_p in py2. apply moveL_Mp in py2. rewrite (ap_path_sigma_1p (fun x01 x02 => cocone_postcompose_inv (HQ x01) (CXy x01) x02)). (* Set Printing Coercions. (* to understand what happens *) *) subst py1. etransitivity. * etransitivity. 2:exact py2. apply ap. rewrite (ap_compose legs (fun x0 => x0 i x)). rewrite (ap_apply_lD2 _ i x). reflexivity. * apply ap10, ap. rewrite (ap_compose legs (fun x0 => x0 j _)). rewrite (ap_apply_lD2 _ j _). reflexivity. - intros f. apply path_forall; intros [y x]; simpl. rewrite <- cocone_precompose_postcompose. srapply (apD10 (g := fun x => f (y; x)) _ x). snrapply equiv_moveR_equiv_V. srapply path_cocone. 1: reflexivity. intros i j g x'; simpl. hott_simpl. exact (ap_compose _ _ _)^. Defined. End ColimitSigma. (** ** Sigma diagrams and diagram maps / equivalences *) Section SigmaDiagram. Context {G : Graph} {Y : Type} (D1 D2 : Y -> Diagram G). Definition sigma_diagram_functor (m : forall y, DiagramMap (D1 y) (D2 y)) : DiagramMap (sigma_diagram D1) (sigma_diagram D2). Proof. srapply Build_DiagramMap. - intros i. srapply (functor_sigma idmap _). intros y; apply m. - intros i j g x; simpl in *. srapply path_sigma'. 1: reflexivity. simpl. apply (DiagramMap_comm (m x.1)). Defined. Definition sigma_diag_functor_equiv (m : forall y, (D1 y) ~d~ (D2 y)) : (sigma_diagram D1) ~d~ (sigma_diagram D2). Proof. srapply (Build_diagram_equiv (sigma_diagram_functor m)). intros i. srapply isequiv_functor_sigma. intros y; apply m. Defined. End SigmaDiagram. Coq-HoTT-9.0/theories/Colimits/GraphQuotient.v000066400000000000000000000461431474641544500213340ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Equivalences. Require Import Types.Universe Types.Paths Types.Forall Types.Arrow Types.Sigma Cubical.DPath. Require Import Homotopy.IdentitySystems. (** * Quotient of a graph *) (** ** Definition *) (** The quotient of a graph is one of the simplest HITs that can be found in HoTT. It consists of a base type and a relation on it, and for every witness of a relation between two points of the type, a path. We use graph quotients to build up all our other non-recursive HITs. Their simplicity means that we can easily prove results about them and generalise them to other HITs. *) Local Unset Elimination Schemes. Module Export GraphQuotient. Section GraphQuotient. Universes i j u. Constraint i <= u, j <= u. Context {A : Type@{i}}. Private Inductive GraphQuotient (R : A -> A -> Type@{j}) : Type@{u} := | gq : A -> GraphQuotient R. Arguments gq {R} a. Context {R : A -> A -> Type@{j}}. Axiom gqglue : forall {a b : A}, R a b -> paths (@gq R a) (gq b). Definition GraphQuotient_ind (P : GraphQuotient R -> Type@{k}) (gq' : forall a, P (gq a)) (gqglue' : forall a b (s : R a b), gqglue s # gq' a = gq' b) : forall x, P x := fun x => match x with | gq a => fun _ => gq' a end gqglue'. (** Above we did a match with output type a function, and then outside of the match we provided the argument [gqglue']. If we instead end with [| gq a => gq' a end.], the definition will not depend on [gqglue'], which would be incorrect. This is the idiom referred to in ../../test/bugs/github1758.v and github1759.v. *) Axiom GraphQuotient_ind_beta_gqglue : forall (P : GraphQuotient R -> Type@{k}) (gq' : forall a, P (gq a)) (gqglue' : forall a b (s : R a b), gqglue s # gq' a = gq' b) (a b: A) (s : R a b), apD (GraphQuotient_ind P gq' gqglue') (gqglue s) = gqglue' a b s. End GraphQuotient. End GraphQuotient. Arguments gq {A R} a. Definition GraphQuotient_rec {A R P} (c : A -> P) (g : forall a b, R a b -> c a = c b) : GraphQuotient R -> P. Proof. srapply GraphQuotient_ind. 1: exact c. intros a b s. refine (transport_const _ _ @ g a b s). Defined. Definition GraphQuotient_rec_beta_gqglue {A R P} (c : A -> P) (g : forall a b, R a b -> c a = c b) (a b : A) (s : R a b) : ap (GraphQuotient_rec c g) (gqglue s) = g a b s. Proof. unfold GraphQuotient_rec. refine (cancelL _ _ _ _ ). refine ((apD_const _ _)^ @ _). rapply GraphQuotient_ind_beta_gqglue. Defined. (** ** Descent *) (** We study "equifibrant" type families over a graph [A], with edges indexed by [R]. By univalence, the descent property tells us that these type families correspond to type families over the graph quotient, and we obtain an induction principle for such type families. Dependent descent data over some particular descent data are "equifibrant" type families over this descent data. The "equifibrancy" is only taken over the graph [A] and [R], but there is an extra level of dependency coming from the descent data. In this case, we obtain an induction and recursion principle, but only with a computation rule for the recursion principle. The theory of descent is interesting to consider in itself. However, we will use it as a means to structure the code, and to obtain induction and recursion principles that are valuable in proving the flattening lemma, and characterizing path spaces. Thus we will gloss over the bigger picture, and not consider equivalences of descent data, nor homotopies of their sections. We will also not elaborate on uniqueness of the induced families. It's possible to prove the results in the Descent, Flattening and Paths Sections without univalence, by replacing all equivalences with paths, but in practice these results will be used with equivalences as input, making the form below more convenient. See https://github.com/HoTT/Coq-HoTT/pull/2147#issuecomment-2521570830 for further information. *) Section Descent. Context `{Univalence}. (** Descent data over a graph [A] and [R] is an "equifibrant" or "cartesian" type family [gqd_fam : A -> Type]. If [a b : A] are related by [r : R a b], then the fibers [gqd_fam a] and [gqd_fam b] are equivalent, witnessed by [gqd_e]. *) Record gqDescent {A : Type} {R : A -> A -> Type} := { gqd_fam (a : A) : Type; gqd_e {a b : A} (r : R a b) : gqd_fam a <~> gqd_fam b }. Global Arguments gqDescent {A} R. (** Let [A] and [R] be a graph. *) Context {A : Type} {R : A -> A -> Type}. (** Descent data induces a type family over [GraphQuotient R]. *) Definition fam_gqdescent (Pe : gqDescent R) : GraphQuotient R -> Type. Proof. snrapply (GraphQuotient_rec (gqd_fam Pe)). intros a b r. exact (path_universe_uncurried (gqd_e Pe r)). Defined. (** A type family over [GraphQuotient R] induces descent data. *) Definition gqdescent_fam (P : GraphQuotient R -> Type) : gqDescent R. Proof. snrapply Build_gqDescent. - exact (P o gq). - intros a b r. exact (equiv_transport P (gqglue r)). Defined. (** Transporting over [fam_gqdescent] along [gqglue r] is given by [gqd_e]. *) Definition transport_fam_gqdescent_gqglue (Pe : gqDescent R) {a b : A} (r : R a b) (pa : gqd_fam Pe a) : transport (fam_gqdescent Pe) (gqglue r) pa = gqd_e Pe r pa. Proof. nrapply transport_path_universe'. nrapply GraphQuotient_rec_beta_gqglue. Defined. (** A section on the descent data is a fiberwise section that respects the equivalences. *) Record gqDescentSection {Pe : gqDescent R} := { gqds_sect (a : A) : gqd_fam Pe a; gqds_e {a b : A} (r : R a b) : gqd_e Pe r (gqds_sect a) = gqds_sect b }. Global Arguments gqDescentSection Pe : clear implicits. (** A descent section induces a genuine section of [fam_gqdescent Pe]. *) Definition gqdescent_ind {Pe : gqDescent R} (f : gqDescentSection Pe) : forall (x : GraphQuotient R), fam_gqdescent Pe x. Proof. snrapply (GraphQuotient_ind _ (gqds_sect f)). intros a b r. exact (transport_fam_gqdescent_gqglue Pe r _ @ gqds_e f r). Defined. (** We record its computation rule *) Definition gqdescent_ind_beta_gqglue {Pe : gqDescent R} (f : gqDescentSection Pe) {a b : A} (r : R a b) : apD (gqdescent_ind f) (gqglue r) = transport_fam_gqdescent_gqglue Pe r _ @ gqds_e f r := GraphQuotient_ind_beta_gqglue _ (gqds_sect f) _ _ _ _. (** Dependent descent data over descent data [Pe : gqDescent R] consists of a type family [gqdd_fam : forall (a : A), gqd_fam Pe a -> Type] together with coherences [gqdd_e r pa]. *) Record gqDepDescent {Pe : gqDescent R} := { gqdd_fam (a : A) (pa : gqd_fam Pe a) : Type; gqdd_e {a b : A} (r : R a b) (pa : gqd_fam Pe a) : gqdd_fam a pa <~> gqdd_fam b (gqd_e Pe r pa) }. Global Arguments gqDepDescent Pe : clear implicits. (** A dependent type family over [fam_gqdescent Pe] induces dependent descent data over [Pe]. *) Definition gqdepdescent_fam {Pe : gqDescent R} (Q : forall (x : GraphQuotient R), (fam_gqdescent Pe) x -> Type) : gqDepDescent Pe. Proof. snrapply Build_gqDepDescent. - intro a; cbn. exact (Q (gq a)). - intros a b r pa. exact (equiv_transportDD (fam_gqdescent Pe) Q (gqglue r) (transport_fam_gqdescent_gqglue Pe r pa)). Defined. (** Dependent descent data over [Pe] induces a dependent type family over [fam_gqdescent Pe]. *) Definition fam_gqdepdescent {Pe : gqDescent R} (Qe : gqDepDescent Pe) : forall (x : GraphQuotient R), (fam_gqdescent Pe x) -> Type. Proof. snrapply GraphQuotient_ind. - exact (gqdd_fam Qe). - intros a b r. nrapply (moveR_transport_p _ (gqglue r)). funext pa. rhs nrapply transport_arrow_toconst. rhs nrefine (ap (gqdd_fam Qe b) _). + exact (path_universe (gqdd_e Qe r pa)). + lhs nrapply (ap (fun x => (transport _ x _)) (inv_V (gqglue r))). nrapply (transport_fam_gqdescent_gqglue _ _ _). Defined. (** A section of dependent descent data [Qe : gqDepDescent Pe] is a fiberwise section [gqdds_sect], together with coherences [gqdd_e]. *) Record gqDepDescentSection {Pe : gqDescent R} {Qe : gqDepDescent Pe} := { gqdds_sect (a : A) (pa : gqd_fam Pe a) : gqdd_fam Qe a pa; gqdds_e {a b : A} (r : R a b) (pa : gqd_fam Pe a) : gqdd_e Qe r pa (gqdds_sect a pa) = gqdds_sect b (gqd_e Pe r pa) }. Global Arguments gqDepDescentSection {Pe} Qe. (** A dependent descent section induces a genuine section over the total space of [fam_gqdescent Pe]. *) Definition gqdepdescent_ind {Pe : gqDescent R} {Q : forall (x : GraphQuotient R), (fam_gqdescent Pe) x -> Type} (f : gqDepDescentSection (gqdepdescent_fam Q)) : forall (x : GraphQuotient R) (px : fam_gqdescent Pe x), Q x px. Proof. nrapply (GraphQuotient_ind _ (gqdds_sect f) _). intros a b r. apply dpath_forall. intro pa. apply (equiv_inj (transport (Q (gq b)) (transport_fam_gqdescent_gqglue Pe r pa))). rhs nrapply (apD (gqdds_sect f b) (transport_fam_gqdescent_gqglue Pe r pa)). exact (gqdds_e f r pa). Defined. (** The data for a section into a constant type family. *) Record gqDepDescentConstSection {Pe : gqDescent R} {Q : Type} := { gqddcs_sect (a : A) (pa : gqd_fam Pe a) : Q; gqddcs_e {a b : A} (r : R a b) (pa : gqd_fam Pe a) : gqddcs_sect a pa = gqddcs_sect b (gqd_e Pe r pa) }. Global Arguments gqDepDescentConstSection Pe Q : clear implicits. (** The data for a section of a constant family induces a section over the total space of [fam_gqdescent Pe]. *) Definition gqdepdescent_rec {Pe : gqDescent R} {Q : Type} (f : gqDepDescentConstSection Pe Q) : forall (x : GraphQuotient R), fam_gqdescent Pe x -> Q. Proof. snrapply (GraphQuotient_ind _ (gqddcs_sect f)). intros a b r. nrapply dpath_arrow. intro pa. lhs nrapply transport_const. rhs nrapply (ap _ (transport_fam_gqdescent_gqglue Pe r pa)). exact (gqddcs_e f r pa). Defined. (** Here is the computation rule on paths. *) Definition gqdepdescent_rec_beta_gqglue {Pe : gqDescent R} {Q : Type} (f : gqDepDescentConstSection Pe Q) {a b : A} {pa : gqd_fam Pe a} {pb : gqd_fam Pe b} (r : R a b) (pr : gqd_e Pe r pa = pb) : ap (sig_rec (gqdepdescent_rec f)) (path_sigma _ (gq a; pa) (gq b; pb) (gqglue r) (transport_fam_gqdescent_gqglue Pe r pa @ pr)) = gqddcs_e f r pa @ ap (gqddcs_sect f b) pr. Proof. Open Scope long_path_scope. destruct pr. rhs nrapply concat_p1. lhs nrapply ap_sig_rec_path_sigma. lhs nrapply (ap (fun x => _ (ap10 x _) @ _)). 1: nrapply GraphQuotient_ind_beta_gqglue. do 3 lhs nrapply concat_pp_p. apply moveR_Vp. lhs nrefine (1 @@ (1 @@ (_ @@ 1))). 1: nrapply (ap10_dpath_arrow (fam_gqdescent Pe) (fun _ => Q) (gqglue r)). lhs nrefine (1 @@ _). { lhs nrapply (1 @@ concat_pp_p _ _ _). lhs nrapply (1 @@ concat_pp_p _ _ _). lhs nrapply concat_V_pp. lhs nrapply (1 @@ concat_pp_p _ _ _). rewrite concat_p1. nrapply (1 @@ (1 @@ concat_pV_p _ _)). } nrapply concat_V_pp. Close Scope long_path_scope. Defined. End Descent. (** ** The flattening lemma *) (** We saw above that given descent data [Pe] over a graph [A] and [R] we obtained a type family [fam_gqdescent Pe] over the graph quotient. The flattening lemma describes the total space [sig (fam_gqdescent Pe)] of this type family as a graph quotient of [sig (gqd_fam Pe)] by a certain relation. This follows from the work above, which shows that [sig (fam_gqdescent Pe)] has the same universal property as this graph quotient. *) Section Flattening. Context `{Univalence} {A : Type} {R : A -> A -> Type} (Pe : gqDescent R). (** We mimic the constructors of [GraphQuotient] for the total space. Here is the point constructor, in curried form. *) Definition flatten_gqd {a : A} (pa : gqd_fam Pe a) : sig (fam_gqdescent Pe) := (gq a; pa). (** And here is the path constructor. *) Definition flatten_gqd_glue {a b : A} (r : R a b) {pa : gqd_fam Pe a} {pb : gqd_fam Pe b} (pr : gqd_e Pe r pa = pb) : flatten_gqd pa = flatten_gqd pb. Proof. snrapply path_sigma. - by apply gqglue. - lhs nrapply transport_fam_gqdescent_gqglue. exact pr. Defined. (** Now that we've shown that [fam_gqdescent Pe] acts like a [GraphQuotient] of [sig (gqd_fam Pe)] by an appropriate relation, we can use this to prove the flattening lemma. The maps back and forth are very easy so this could almost be a formal consequence of the induction principle. *) Lemma equiv_gqd_flatten : sig (fam_gqdescent Pe) <~> GraphQuotient (fun a b => {r : R a.1 b.1 & gqd_e Pe r a.2 = b.2}). Proof. snrapply equiv_adjointify. - snrapply sig_rec. snrapply gqdepdescent_rec. snrapply Build_gqDepDescentConstSection. + exact (fun a x => gq (a; x)). + intros a b r pa. apply gqglue; exact (r; 1). - snrapply GraphQuotient_rec. + exact (fun '(a; x) => (gq a; x)). + intros [a x] [b y] [r pr]; cbn in r, pr; cbn. apply (flatten_gqd_glue r pr). - snrapply GraphQuotient_ind. 1: reflexivity. intros [a x] [b y] [r pr]; cbn in r, pr; cbn. destruct pr. nrapply transport_paths_FFlr'; apply equiv_p1_1q. rewrite GraphQuotient_rec_beta_gqglue. lhs nrapply gqdepdescent_rec_beta_gqglue. nrapply concat_p1. - intros [x px]; revert x px. snrapply gqdepdescent_ind. snrapply Build_gqDepDescentSection. + by intros a pa. + intros a b r pa; cbn. lhs nrapply transportDD_is_transport. nrapply transport_paths_FFlr'; apply equiv_p1_1q. rewrite <- (concat_p1 (transport_fam_gqdescent_gqglue _ _ _)). rewrite gqdepdescent_rec_beta_gqglue. (* This needs to be in the form [transport_fam_gqdescent_gqglue Pe r pa @ p] to work, and the other [@ 1] introduced comes in handy as well. *) lhs nrapply (ap _ (concat_p1 _)). nrapply (GraphQuotient_rec_beta_gqglue _ _ (a; pa) (b; _) (r; 1)). Defined. End Flattening. (** ** Characterization of path spaces*) (** A pointed type family over a graph quotient has an identity system structure precisely when its associated descent data satisfies Kraus and von Raumer's induction principle, https://arxiv.org/pdf/1901.06022. *) Section Paths. (** Let [A] and [R] be a graph, with a distinguished point [a0 : A]. Let [Pe : gqDescent R] be descent data over [A] and [R] with a distinguished point [p0 : gqd_fam Pe a0]. Assume that any dependent descent data [Qe : gqDepDescent Pe] with a distinguished point [q0 : gqdd_fam Qe a0 p0] has a section that respects the distinguished points. This is the induction principle provided by Kraus and von Raumer. *) Context `{Univalence} {A : Type} {R : A -> A -> Type} (a0 : A) (Pe : gqDescent R) (p0 : gqd_fam Pe a0) (based_gqdepdescent_ind : forall (Qe : gqDepDescent Pe) (q0 : gqdd_fam Qe a0 p0), gqDepDescentSection Qe) (based_gqdepdescent_ind_beta : forall (Qe : gqDepDescent Pe) (q0 : gqdd_fam Qe a0 p0), gqdds_sect (based_gqdepdescent_ind Qe q0) a0 p0 = q0). (** Under these hypotheses, we get an identity system structure on [fam_gqdescent Pe]. *) Local Instance idsys_flatten_gqdescent : @IsIdentitySystem _ (gq a0) (fam_gqdescent Pe) p0. Proof. snrapply Build_IsIdentitySystem. - intros Q q0 x p. snrapply gqdepdescent_ind. by apply based_gqdepdescent_ind. - intros Q q0; cbn. nrapply (based_gqdepdescent_ind_beta (gqdepdescent_fam Q)). Defined. (** It follows that the fibers [fam_gqdescent Pe x] are equivalent to path spaces [(gq a0) = x]. *) Definition fam_gqdescent_equiv_path (x : GraphQuotient R) : (gq a0) = x <~> fam_gqdescent Pe x := @equiv_transport_identitysystem _ (gq a0) (fam_gqdescent Pe) p0 _ x. End Paths. (** ** Functoriality of graph quotients *) Lemma functor_gq {A B : Type} (f : A -> B) {R : A -> A -> Type} {S : B -> B -> Type} (e : forall a b, R a b -> S (f a) (f b)) : GraphQuotient R -> GraphQuotient S. Proof. snrapply GraphQuotient_rec. 1: exact (fun x => gq (f x)). intros a b r. apply gqglue. apply e. exact r. Defined. Lemma functor_gq_idmap {A : Type} {R : A -> A -> Type} : functor_gq (A:=A) (B:=A) (S:=R) idmap (fun a b r => r) == idmap. Proof. snrapply GraphQuotient_ind. 1: reflexivity. intros a b r. nrapply (transport_paths_FlFr' (gqglue r)). apply equiv_p1_1q. rhs nrapply ap_idmap. nrapply GraphQuotient_rec_beta_gqglue. Defined. Lemma functor_gq_compose {A B C : Type} (f : A -> B) (g : B -> C) {R : A -> A -> Type} {S : B -> B -> Type} {T : C -> C -> Type} (e : forall a b, R a b -> S (f a) (f b)) (e' : forall a b, S a b -> T (g a) (g b)) : functor_gq g e' o (functor_gq f e) == functor_gq (g o f) (fun a b r => e' _ _ (e _ _ r)). Proof. snrapply GraphQuotient_ind. 1: reflexivity. intros a b s. nrapply (transport_paths_FlFr' (gqglue s)). apply equiv_p1_1q. lhs nrapply (ap_compose (functor_gq f e) (functor_gq g e') (gqglue s)). lhs nrapply ap. 1: apply GraphQuotient_rec_beta_gqglue. lhs nrapply GraphQuotient_rec_beta_gqglue. exact (GraphQuotient_rec_beta_gqglue _ _ _ _ s)^. Defined. Lemma functor2_gq {A B : Type} (f f' : A -> B) {R : A -> A -> Type} {S : B -> B -> Type} (e : forall a b, R a b -> S (f a) (f b)) (e' : forall a b, R a b -> S (f' a) (f' b)) (p : f == f') (q : forall a b r, transport011 S (p a) (p b) (e a b r) = e' a b r) : functor_gq f e == functor_gq f' e'. Proof. snrapply GraphQuotient_ind. - simpl; intro. apply ap. apply p. - intros a b s. nrapply (transport_paths_FlFr' (gqglue s)). rhs nrefine (1 @@ _). 2: apply GraphQuotient_rec_beta_gqglue. lhs nrefine (_ @@ 1). 1: apply GraphQuotient_rec_beta_gqglue. apply moveL_Mp. symmetry. destruct (q a b s). lhs nrapply (ap_transport011 _ _ (fun s _ => gqglue)). rhs nrapply concat_p_pp. nrapply transport011_paths. Defined. (** ** Equivalence of graph quotients *) Global Instance isequiv_functor_gq {A B : Type} (f : A -> B) `{IsEquiv _ _ f} {R : A -> A -> Type} {S : B -> B -> Type} (e : forall a b, R a b -> S (f a) (f b)) `{forall a b, IsEquiv (e a b)} : IsEquiv (functor_gq f e). Proof. srapply isequiv_adjointify. - nrapply (functor_gq f^-1). intros a b s. apply (e _ _)^-1. exact (transport011 S (eisretr f a)^ (eisretr f b)^ s). - intros x. lhs nrapply functor_gq_compose. rhs_V nrapply functor_gq_idmap. snrapply functor2_gq; cbn beta. 1: apply eisretr. intros a b s. rewrite (eisretr (e (f^-1 a) (f^-1 b))). lhs_V nrapply transport011_pp. by rewrite 2 concat_Vp. - intros x. lhs nrapply functor_gq_compose. rhs_V nrapply functor_gq_idmap. snrapply functor2_gq; cbn beta. 1: apply eissect. intros a b r. rewrite 2 eisadj. rewrite <- 2 ap_V. rewrite <- (transport011_compose S). rewrite <- (ap_transport011 (Q := fun x y => S (f x) (f y)) (eissect f a)^ (eissect f b)^ e). rewrite (eissect (e (f^-1 (f a)) (f^-1 (f b)))). lhs_V nrapply transport011_pp. by rewrite 2 concat_Vp. Defined. Definition equiv_functor_gq {A B : Type} (f : A <~> B) (R : A -> A -> Type) (S : B -> B -> Type) (e : forall a b, R a b <~> S (f a) (f b)) : GraphQuotient R <~> GraphQuotient S := Build_Equiv _ _ (functor_gq f e) _. Coq-HoTT-9.0/theories/Colimits/MappingCylinder.v000066400000000000000000000144121474641544500216210ustar00rootroot00000000000000(** * Mapping Cylinders *) Require Import HoTT.Basics Cubical.DPath Cubical.PathSquare. Require Import Colimits.Pushout. Local Open Scope path_scope. (** As in topology, the mapping cylinder of a function [f : A -> B] is a way to replace it with an equivalent cofibration (dually to how [hfiber] replaces it with an equivalent fibration). We can't talk *internally* in type theory about cofibrations, but we can say metatheoretically what they are: functions with the isomorphism extension property. So while we can't literally say "let [f] be a cofibration" we can do a mostly equivalent thing and say "let [f] be a map and consider its mapping cylinder". Replacing a map by a cofibration can be useful because it allows us to make more equalities true definitionally. *) (** ** Definitions *) (** We define the mapping cylinder as the pushout of [f] and an identity map. Peter Lumsdaine has given a definition of HIT mapping cylinders that are dependent on the codomain, so that the second factor is not just an equivalence but a trivial fibration. However, at the moment we don't have a need for that. *) Definition Cyl {A B : Type} (f : A -> B) : Type := Pushout idmap f. Section MappingCylinder. Context {A B : Type} {f : A -> B}. Definition cyl (a : A) : Cyl f := pushl a. Definition cyr (b : B) : Cyl f := pushr b. Definition cyglue (a : A) : cyl a = cyr (f a) := pglue a. Section CylInd. Context (P : Cyl f -> Type) (cyla : forall a, P (cyl a)) (cylb : forall b, P (cyr b)) (cylg : forall a, DPath P (cyglue a) (cyla a) (cylb (f a))). Definition Cyl_ind : forall c, P c := Pushout_ind _ cyla cylb cylg. Definition Cyl_ind_beta_cyglue (a : A) : apD Cyl_ind (cyglue a) = cylg a := Pushout_ind_beta_pglue _ _ _ _ _. End CylInd. Section CylRec. Context {P : Type} (cyla : A -> P) (cylb : B -> P) (cylg : cyla == cylb o f). Definition Cyl_rec : Cyl f -> P := Pushout_rec _ cyla cylb cylg. Definition Cyl_rec_beta_cyglue (a : A) : ap Cyl_rec (cyglue a) = cylg a := Pushout_rec_beta_pglue _ _ _ _ _. End CylRec. Definition pr_cyl : Cyl f <~> B. Proof. (** Rather than adjointifying, we give all parts of the equivalence explicitly, so we can be sure of retaining the computational behavior of [eissect] and [eisretr]. However, it's easier to prove [eisadj] on the other side, so we reverse the equivalence first. *) symmetry. srapply Build_Equiv. 1:apply cyr. srapply Build_IsEquiv. - srapply Cyl_rec. + exact f. + exact idmap. + reflexivity. - srapply Cyl_ind. + intros a; cbn. symmetry; apply cyglue. + intros b; reflexivity. + intros a; cbn. apply dp_paths_FFlr. rewrite Cyl_rec_beta_cyglue. apply concat_pV_p. - intros b; reflexivity. - intros b; reflexivity. Defined. Definition ap_pr_cyl_cyglue (a : A) : ap pr_cyl (cyglue a) = 1 := Cyl_rec_beta_cyglue _ _ _ a. (** The original map [f] factors definitionally through [Cyl f]. *) Definition pr_cyl_cyl (a : A) : pr_cyl (cyl a) = f a := 1. End MappingCylinder. (** Sometimes we have to specify the map explicitly. *) Definition cyl' {A B} (f : A -> B) : A -> Cyl f := cyl. Definition pr_cyl' {A B} (f : A -> B) : Cyl f -> B := pr_cyl. (** ** Functoriality *) Section FunctorCyl. Context {A B A' B': Type} {f : A -> B} {f' : A' -> B'} {ga : A -> A'} {gb : B -> B'} (g : f' o ga == gb o f). Definition functor_cyl : Cyl f -> Cyl f'. Proof. srapply Cyl_rec. - exact (cyl o ga). - exact (cyr o gb). - intros a. refine (_ @ ap cyr (g a)). exact (cyglue (ga a)). Defined. Definition ap_functor_cyl_cyglue (a : A) : ap functor_cyl (cyglue a) = cyglue (ga a) @ ap cyr (g a) := Cyl_rec_beta_cyglue _ _ _ a. (** The benefit of passing to the mapping cylinder is that it makes a square commute definitionally. *) Definition functor_cyl_cyl (a : A) : cyl (ga a) = functor_cyl (cyl a) := 1. (** The other square also commutes, though not definitionally. *) Definition pr_functor_cyl (c : Cyl f) : pr_cyl (functor_cyl c) = gb (pr_cyl c) := ap (pr_cyl o functor_cyl) (eissect pr_cyl c)^. Definition pr_functor_cyl_cyl (a : A) : pr_functor_cyl (cyl a) = g a. Proof. (** Here we need [eissect pr_cyl (cyl a)] to compute. *) refine (ap _ (inv_V _) @ _). refine (ap_compose functor_cyl pr_cyl (cyglue a) @ _). refine (ap _ (ap_functor_cyl_cyglue a) @ _). refine (ap_pp _ _ _ @ _). refine (whiskerR (ap_pr_cyl_cyglue (ga a)) _ @ concat_1p _ @ _). refine ((ap_compose cyr _ (g a))^ @ _). apply ap_idmap. Defined. End FunctorCyl. (** ** Coequalizers *) (** A particularly useful application is to replace a map of coequalizers with one where both squares commute definitionally. *) Section CylCoeq. Context {B A f g B' A' f' g'} {h : B -> B'} {k : A -> A'} (p : k o f == f' o h) (q : k o g == g' o h). Definition CylCoeq : Type := Coeq (functor_cyl p) (functor_cyl q). Definition cyl_cylcoeq : Coeq f g -> CylCoeq := functor_coeq cyl cyl (functor_cyl_cyl p) (functor_cyl_cyl q). Definition ap_cyl_cylcoeq_cglue (b : B) : ap cyl_cylcoeq (cglue b) = cglue (cyl b). Proof. etransitivity. 1:rapply functor_coeq_beta_cglue. exact (concat_p1 _ @ concat_1p _). Defined. Definition pr_cylcoeq : CylCoeq <~> Coeq f' g' := equiv_functor_coeq pr_cyl pr_cyl (pr_functor_cyl p) (pr_functor_cyl q). Definition ap_pr_cylcoeq_cglue (x : Cyl h) : PathSquare (ap pr_cylcoeq (cglue x)) (cglue (pr_cyl x)) (ap coeq (pr_functor_cyl p x)) (ap coeq (pr_functor_cyl q x)). Proof. apply sq_path. apply moveR_pM. rewrite <- (ap_V coeq). rapply functor_coeq_beta_cglue. Defined. Definition pr_cyl_cylcoeq : functor_coeq h k p q == pr_cylcoeq o cyl_cylcoeq. Proof. intros c. refine (_ @ functor_coeq_compose cyl cyl (functor_cyl_cyl p) (functor_cyl_cyl q) pr_cyl pr_cyl (pr_functor_cyl p) (pr_functor_cyl q) c). srapply functor_coeq_homotopy. 1-2:reflexivity. all:intros b; cbn. all:refine (concat_1p _ @ concat_1p _ @ _ @ (concat_p1 _)^). all:apply pr_functor_cyl_cyl. Defined. End CylCoeq. Coq-HoTT-9.0/theories/Colimits/Pushout.v000066400000000000000000001033631474641544500202070ustar00rootroot00000000000000Require Import Basics. Require Import Types.Paths Types.Forall Types.Arrow Types.Sigma Types.Sum Types.Universe. Require Export Colimits.Coeq. Require Import Homotopy.IdentitySystems. Local Open Scope path_scope. (** * Homotopy Pushouts *) (** We define pushouts in terms of coproducts and coequalizers. *) Definition Pushout@{i j k l} {A : Type@{i}} {B : Type@{j}} {C : Type@{k}} (f : A -> B) (g : A -> C) : Type@{l} := Coeq@{l l _} (inl o f) (inr o g). Definition push {A B C : Type} {f : A -> B} {g : A -> C} : B+C -> Pushout f g := @coeq _ _ (inl o f) (inr o g). Definition pushl {A B C} {f : A -> B} {g : A -> C} (b : B) : Pushout f g := push (inl b). Definition pushr {A B C} {f : A -> B} {g : A -> C} (c : C) : Pushout f g := push (inr c). Definition pglue {A B C : Type} {f : A -> B} {g : A -> C} (a : A) : pushl (f a) = pushr (g a) := @cglue A (B+C) (inl o f) (inr o g) a. (* Some versions with explicit parameters. *) Definition pushl' {A B C} (f : A -> B) (g : A -> C) (b : B) : Pushout f g := pushl b. Definition pushr' {A B C} (f : A -> B) (g : A -> C) (c : C) : Pushout f g := pushr c. Definition pglue' {A B C : Type} (f : A -> B) (g : A -> C) (a : A) : pushl (f a) = pushr (g a) := pglue a. Section PushoutInd. Context {A B C : Type} {f : A -> B} {g : A -> C} (P : Pushout f g -> Type) (pushb : forall b : B, P (pushl b)) (pushc : forall c : C, P (pushr c)) (pusha : forall a : A, (pglue a) # (pushb (f a)) = pushc (g a)). Definition Pushout_ind : forall (w : Pushout f g), P w := Coeq_ind P (sum_ind (P o push) pushb pushc) pusha. Definition Pushout_ind_beta_pushl (b:B) : Pushout_ind (pushl b) = pushb b := 1. Definition Pushout_ind_beta_pushr (c:C) : Pushout_ind (pushr c) = pushc c := 1. Definition Pushout_ind_beta_pglue (a:A) : apD Pushout_ind (pglue a) = pusha a := Coeq_ind_beta_cglue P (fun bc => match bc with inl b => pushb b | inr c => pushc c end) pusha a. End PushoutInd. (** But we want to allow the user to forget that we've defined pushouts in terms of coequalizers. *) Arguments Pushout : simpl never. Arguments push : simpl never. Arguments pglue : simpl never. Arguments Pushout_ind_beta_pglue : simpl never. (** However, we do allow [Pushout_ind] to simplify, as it computes on point constructors. *) Definition Pushout_rec {A B C} {f : A -> B} {g : A -> C} (P : Type) (pushb : B -> P) (pushc : C -> P) (pusha : forall a : A, pushb (f a) = pushc (g a)) : @Pushout A B C f g -> P := @Coeq_rec _ _ (inl o f) (inr o g) P (sum_rec P pushb pushc) pusha. Definition Pushout_rec_beta_pglue {A B C f g} (P : Type) (pushb : B -> P) (pushc : C -> P) (pusha : forall a : A, pushb (f a) = pushc (g a)) (a : A) : ap (Pushout_rec P pushb pushc pusha) (pglue a) = pusha a. Proof. nrapply Coeq_rec_beta_cglue. Defined. (** ** Universal property *) Definition pushout_unrec {A B C P} (f : A -> B) (g : A -> C) (h : Pushout f g -> P) : {psh : (B -> P) * (C -> P) & forall a, fst psh (f a) = snd psh (g a)}. Proof. exists (h o pushl, h o pushr). intros a; cbn. exact (ap h (pglue a)). Defined. Definition pushout_rec_unrec {A B C} (f : A -> B) (g : A -> C) P (e : Pushout f g -> P) : Pushout_rec P (e o pushl) (e o pushr) (fun a => ap e (pglue a)) == e. Proof. snrapply Pushout_ind. 1, 2: reflexivity. intro a; cbn beta. apply transport_paths_FlFr'. apply equiv_p1_1q. nrapply Pushout_rec_beta_pglue. Defined. Definition isequiv_Pushout_rec `{Funext} {A B C} (f : A -> B) (g : A -> C) P : IsEquiv (fun p : {psh : (B -> P) * (C -> P) & forall a, fst psh (f a) = snd psh (g a) } => Pushout_rec P (fst p.1) (snd p.1) p.2). Proof. srefine (isequiv_adjointify _ (pushout_unrec f g) _ _). - intro e. apply path_arrow. apply pushout_rec_unrec. - intros [[pushb pushc] pusha]; unfold pushout_unrec; cbn. snrapply path_sigma'. + reflexivity. + cbn. apply path_forall; intros a. apply Pushout_rec_beta_pglue. Defined. Definition equiv_Pushout_rec `{Funext} {A B C} (f : A -> B) (g : A -> C) P : {psh : (B -> P) * (C -> P) & forall a, fst psh (f a) = snd psh (g a) } <~> (Pushout f g -> P) := Build_Equiv _ _ _ (isequiv_Pushout_rec f g P). Definition equiv_pushout_unrec `{Funext} {A B C} (f : A -> B) (g : A -> C) P : (Pushout f g -> P) <~> {psh : (B -> P) * (C -> P) & forall a, fst psh (f a) = snd psh (g a) } := equiv_inverse (equiv_Pushout_rec f g P). (** ** Symmetry *) Definition pushout_sym_map {A B C} {f : A -> B} {g : A -> C} : Pushout f g -> Pushout g f := Pushout_rec (Pushout g f) pushr pushl (fun a : A => (pglue a)^). Lemma sect_pushout_sym_map {A B C f g} : (@pushout_sym_map A B C f g) o (@pushout_sym_map A C B g f) == idmap. Proof. srapply @Pushout_ind. - intros; reflexivity. - intros; reflexivity. - intro a. simpl. abstract (rewrite transport_paths_FFlr, Pushout_rec_beta_pglue, ap_V, Pushout_rec_beta_pglue; hott_simpl). Defined. Definition pushout_sym {A B C} {f : A -> B} {g : A -> C} : Pushout f g <~> Pushout g f := equiv_adjointify pushout_sym_map pushout_sym_map sect_pushout_sym_map sect_pushout_sym_map. (** ** Functoriality *) Definition functor_pushout {A B C} {f : A -> B} {g : A -> C} {A' B' C'} {f' : A' -> B'} {g' : A' -> C'} (h : A -> A') (k : B -> B') (l : C -> C') (p : k o f == f' o h) (q : l o g == g' o h) : Pushout f g -> Pushout f' g'. Proof. unfold Pushout; srapply functor_coeq. - exact h. - exact (functor_sum k l). - intros a; cbn. apply ap, p. - intros a; cbn. apply ap, q. Defined. Definition functor_pushout_beta_pglue {A B C} {f : A -> B} {g : A -> C} {A' B' C'} {f' : A' -> B'} {g' : A' -> C'} {h : A -> A'} {k : B -> B'} {l : C -> C'} {p : k o f == f' o h} {q : l o g == g' o h} (a : A) : ap (functor_pushout h k l p q) (pglue a) = ap pushl (p a) @ pglue (h a) @ ap pushr (q a)^. Proof. lhs nrapply functor_coeq_beta_cglue. symmetry. snrapply ap011. - apply whiskerR. unfold pushl. nrapply ap_compose. - unfold pushr. lhs nrapply ap_compose. apply ap. nrapply ap_V. Defined. Lemma functor_pushout_homotopic {A B C : Type} {f : A -> B} {g : A -> C} {A' B' C' : Type} {f' : A' -> B'} {g' : A' -> C'} {h h' : A -> A'} {k k' : B -> B'} {l l' : C -> C'} {p : k o f == f' o h} {q : l o g == g' o h} {p' : k' o f == f' o h'} {q' : l' o g == g' o h'} (t : h == h') (u : k == k') (v : l == l') (i : forall a, p a @ (ap f') (t a) = u (f a) @ p' a) (j : forall a, q a @ (ap g') (t a) = v (g a) @ q' a) : functor_pushout h k l p q == functor_pushout h' k' l' p' q'. Proof. srapply functor_coeq_homotopy. 1: exact t. 1: exact (functor_sum_homotopic u v). 1,2: intros b; simpl. 1,2: refine (_ @ ap_pp _ _ _ @ ap _ (ap_compose _ _ _)^). 1,2: refine ((ap_pp _ _ _)^ @ ap _ _^). 1: exact (i b). exact (j b). Defined. Definition functor_pushout_idmap {A B C : Type} {f : A -> B} {g : A -> C} : functor_pushout (f:=f) (g:=g) idmap idmap idmap (fun _ => 1) (fun _ => 1) == idmap. Proof. snrapply Pushout_ind. 1,2: reflexivity. simpl. intros a. nrapply transport_paths_Flr'. nrapply moveR_pM. nrapply functor_pushout_beta_pglue. Defined. Definition functor_pushout_compose {A B C f g A' B' C' f' g' A'' B'' C'' f'' g''} (u : A -> A') (v : B -> B') (w : C -> C') (u' : A' -> A'') (v' : B' -> B'') (w' : C' -> C'') (p : v o f == f' o u) (q : w o g == g' o u) (p' : v' o f' == f'' o u') (q' : w' o g' == g'' o u') : functor_pushout (u' o u) (v' o v) (w' o w) (fun x => ap v' (p x) @ p' (u x)) (fun x => ap w' (q x) @ q' (u x)) == functor_pushout u' v' w' p' q' o functor_pushout u v w p q. Proof. intros a. rhs_V nrapply functor_coeq_compose. snrapply functor_coeq_homotopy. 1: reflexivity. 1: apply functor_sum_compose. 1,2: intros x; simpl. 1,2: apply equiv_1p_q1. 1,2: lhs_V nrapply whiskerR. 1,3: nrapply ap_compose. 1,2: simpl. 1,2: lhs nrapply whiskerR. 1,3: nrapply ap_compose. 1,2: symmetry. 1,2: apply ap_pp. Defined. (** ** Equivalences *) (** Pushouts preserve equivalences. *) Section EquivPushout. Context {A B C f g A' B' C' f' g'} (eA : A <~> A') (eB : B <~> B') (eC : C <~> C') (p : eB o f == f' o eA) (q : eC o g == g' o eA). Lemma equiv_pushout : Pushout f g <~> Pushout f' g'. Proof. refine (equiv_functor_coeq' eA (equiv_functor_sum' eB eC) _ _). all:unfold pointwise_paths. all:intro; simpl; apply ap. + apply p. + apply q. Defined. Lemma equiv_pushout_pglue (a : A) : ap equiv_pushout (pglue a) = ap pushl (p a) @ pglue (eA a) @ ap pushr (q a)^. Proof. refine (functor_coeq_beta_cglue _ _ _ _ a @ _). refine (_ @@ 1 @@ _). - symmetry; refine (ap_compose inl coeq _). - refine (ap (ap coeq) (ap_V _ _)^ @ _). symmetry; refine (ap_compose inr coeq _). Defined. End EquivPushout. (** ** Contractibility *) (** The pushout of a span of contractible types is contractible *) Global Instance contr_pushout {A B C : Type} `{Contr A, Contr B, Contr C} (f : A -> B) (g : A -> C) : Contr (Pushout f g). Proof. apply (Build_Contr _ (pushl (center B))). srapply Pushout_ind. - intros b; apply ap, path_contr. - intros c. refine (_ @ pglue (center A) @ _). + apply ap, path_contr. + apply ap, path_contr. - intros a. rewrite transport_paths_r. assert (p := path_contr (center A) a). destruct p. refine ((concat_p1 _)^ @ _). apply whiskerL. change 1 with (ap (@pushr A B C f g) (idpath (g (center A)))). apply (ap (ap pushr)). apply path_contr. Defined. (** ** Sigmas *) (** Pushouts commute with sigmas *) Section EquivSigmaPushout. Context {X : Type} (A : X -> Type) (B : X -> Type) (C : X -> Type) (f : forall x, A x -> B x) (g : forall x, A x -> C x). Local Definition esp1 : { x : X & Pushout (f x) (g x) } -> Pushout (functor_sigma idmap f) (functor_sigma idmap g). Proof. intros [x p]. srefine (Pushout_rec _ _ _ _ p). + intros b. exact (pushl (x;b)). + intros c. exact (pushr (x;c)). + intros a; cbn. exact (pglue (x;a)). Defined. Local Definition esp1_beta_pglue (x : X) (a : A x) : ap esp1 (path_sigma' (fun x => Pushout (f x) (g x)) 1 (pglue a)) = pglue (x;a). Proof. rewrite (ap_path_sigma (fun x => Pushout (f x) (g x)) (fun x a => esp1 (x;a)) 1 (pglue a)); cbn. rewrite !concat_p1. unfold esp1; rewrite Pushout_rec_beta_pglue. reflexivity. Qed. Local Definition esp2 : Pushout (functor_sigma idmap f) (functor_sigma idmap g) -> { x : X & Pushout (f x) (g x) }. Proof. srefine (Pushout_rec _ _ _ _). + exact (functor_sigma idmap (fun x => @pushl _ _ _ (f x) (g x))). + exact (functor_sigma idmap (fun x => @pushr _ _ _ (f x) (g x))). + intros [x a]; unfold functor_sigma; cbn. srefine (path_sigma' _ 1 _); cbn. apply pglue. Defined. Local Definition esp2_beta_pglue (x : X) (a : A x) : ap esp2 (pglue (x;a)) = path_sigma' (fun x:X => Pushout (f x) (g x)) 1 (pglue a). Proof. unfold esp2. rewrite Pushout_rec_beta_pglue. reflexivity. Qed. Definition equiv_sigma_pushout : { x : X & Pushout (f x) (g x) } <~> Pushout (functor_sigma idmap f) (functor_sigma idmap g). Proof. srefine (equiv_adjointify esp1 esp2 _ _). - srefine (Pushout_ind _ _ _ _); cbn. + reflexivity. + reflexivity. + intros [x a]. refine (transport_paths_FFlr _ _ @ _). refine (concat_p1 _ @@ 1 @ _). apply moveR_Vp; symmetry. refine (concat_p1 _ @ _). refine (ap _ (esp2_beta_pglue _ _) @ _). apply esp1_beta_pglue. - intros [x a]; revert a. srefine (Pushout_ind _ _ _ _); cbn. + reflexivity. + reflexivity. + intros a. rewrite transport_paths_FlFr. rewrite concat_p1; apply moveR_Vp; rewrite concat_p1. rewrite (ap_compose (exist _ x) (esp2 o esp1)). rewrite (ap_compose esp1 esp2). rewrite (ap_exist (fun x => Pushout (f x) (g x)) x _ _ (pglue a)). rewrite esp1_beta_pglue, esp2_beta_pglue. reflexivity. Defined. End EquivSigmaPushout. (** ** Pushouts are associative *) Section PushoutAssoc. Context {A1 A2 B C D : Type} (f1 : A1 -> B) (g1 : A1 -> C) (f2 : A2 -> C) (g2 : A2 -> D). Definition pushout_assoc_left := Pushout (pushr' f1 g1 o f2) g2. Let pushll : B -> pushout_assoc_left := pushl' (pushr' f1 g1 o f2) g2 o pushl' f1 g1. Let pushlm : C -> pushout_assoc_left := pushl' (pushr' f1 g1 o f2) g2 o pushr' f1 g1. Let pushlr : D -> pushout_assoc_left := pushr' (pushr' f1 g1 o f2) g2. Let pgluell : forall a1, pushll (f1 a1) = pushlm (g1 a1) := fun a1 => ap (pushl' (pushr' f1 g1 o f2) g2) (pglue' f1 g1 a1). Let pgluelr : forall a2, pushlm (f2 a2) = pushlr (g2 a2) := fun a2 => pglue' (pushr' f1 g1 o f2) g2 a2. Definition pushout_assoc_left_ind (P : pushout_assoc_left -> Type) (pushb : forall b, P (pushll b)) (pushc : forall c, P (pushlm c)) (pushd : forall d, P (pushlr d)) (pusha1 : forall a1, (pgluell a1) # pushb (f1 a1) = pushc (g1 a1)) (pusha2 : forall a2, (pgluelr a2) # pushc (f2 a2) = pushd (g2 a2)) : forall x, P x. Proof. srefine (Pushout_ind _ _ pushd _). - srefine (Pushout_ind _ pushb pushc _). intros a1. exact (transport_compose P pushl _ _ @ pusha1 a1). - exact pusha2. Defined. Section Pushout_Assoc_Left_Rec. Context (P : Type) (pushb : B -> P) (pushc : C -> P) (pushd : D -> P) (pusha1 : forall a1, pushb (f1 a1) = pushc (g1 a1)) (pusha2 : forall a2, pushc (f2 a2) = pushd (g2 a2)). Definition pushout_assoc_left_rec : pushout_assoc_left -> P. Proof. srefine (Pushout_rec _ _ pushd _). - srefine (Pushout_rec _ pushb pushc pusha1). - exact pusha2. Defined. Definition pushout_assoc_left_rec_beta_pgluell a1 : ap pushout_assoc_left_rec (pgluell a1) = pusha1 a1. Proof. unfold pgluell. rewrite <- (ap_compose (pushl' (pushr' f1 g1 o f2) g2) pushout_assoc_left_rec). change (ap (Pushout_rec P pushb pushc pusha1) (pglue' f1 g1 a1) = pusha1 a1). apply Pushout_rec_beta_pglue. Defined. Definition pushout_assoc_left_rec_beta_pgluelr a2 : ap pushout_assoc_left_rec (pgluelr a2) = pusha2 a2. Proof. unfold pushout_assoc_left_rec, pgluelr. apply (Pushout_rec_beta_pglue (f := pushr' f1 g1 o f2) (g := g2)). Defined. End Pushout_Assoc_Left_Rec. Definition pushout_assoc_right := Pushout f1 (pushl' f2 g2 o g1). Let pushrl : B -> pushout_assoc_right := pushl' f1 (pushl' f2 g2 o g1). Let pushrm : C -> pushout_assoc_right := pushr' f1 (pushl' f2 g2 o g1) o pushl' f2 g2. Let pushrr : D -> pushout_assoc_right := pushr' f1 (pushl' f2 g2 o g1) o pushr' f2 g2. Let pgluerl : forall a1, pushrl (f1 a1) = pushrm (g1 a1) := fun a1 => pglue' f1 (pushl' f2 g2 o g1) a1. Let pgluerr : forall a2, pushrm (f2 a2) = pushrr (g2 a2) := fun a2 => ap (pushr' f1 (pushl' f2 g2 o g1)) (pglue' f2 g2 a2). Definition pushout_assoc_right_ind (P : pushout_assoc_right -> Type) (pushb : forall b, P (pushrl b)) (pushc : forall c, P (pushrm c)) (pushd : forall d, P (pushrr d)) (pusha1 : forall a1, (pgluerl a1) # pushb (f1 a1) = pushc (g1 a1)) (pusha2 : forall a2, (pgluerr a2) # pushc (f2 a2) = pushd (g2 a2)) : forall x, P x. Proof. srefine (Pushout_ind _ pushb _ _). - srefine (Pushout_ind _ pushc pushd _). intros a2. exact (transport_compose P pushr _ _ @ pusha2 a2). - exact pusha1. Defined. Section Pushout_Assoc_Right_Rec. Context (P : Type) (pushb : B -> P) (pushc : C -> P) (pushd : D -> P) (pusha1 : forall a1, pushb (f1 a1) = pushc (g1 a1)) (pusha2 : forall a2, pushc (f2 a2) = pushd (g2 a2)). Definition pushout_assoc_right_rec : pushout_assoc_right -> P. Proof. srefine (Pushout_rec _ pushb _ _). - srefine (Pushout_rec _ pushc pushd pusha2). - exact pusha1. Defined. Definition pushout_assoc_right_rec_beta_pgluerl a1 : ap pushout_assoc_right_rec (pgluerl a1) = pusha1 a1. Proof. unfold pushout_assoc_right_rec, pgluerl. apply (Pushout_rec_beta_pglue (f := f1) (g := pushl' f2 g2 o g1)). Defined. Definition pushout_assoc_right_rec_beta_pgluerr a2 : ap pushout_assoc_right_rec (pgluerr a2) = pusha2 a2. Proof. unfold pgluerr. rewrite <- (ap_compose (pushr' f1 (pushl' f2 g2 o g1)) pushout_assoc_right_rec). change (ap (Pushout_rec P pushc pushd pusha2) (pglue' f2 g2 a2) = pusha2 a2). apply Pushout_rec_beta_pglue. Defined. End Pushout_Assoc_Right_Rec. Definition equiv_pushout_assoc : Pushout (pushr' f1 g1 o f2) g2 <~> Pushout f1 (pushl' f2 g2 o g1). Proof. srefine (equiv_adjointify _ _ _ _). - exact (pushout_assoc_left_rec _ pushrl pushrm pushrr pgluerl pgluerr). - exact (pushout_assoc_right_rec _ pushll pushlm pushlr pgluell pgluelr). - abstract ( srefine (pushout_assoc_right_ind _ (fun _ => 1) (fun _ => 1) (fun _ => 1) _ _); intros; simpl; rewrite transport_paths_FlFr, ap_compose; [ rewrite pushout_assoc_right_rec_beta_pgluerl, pushout_assoc_left_rec_beta_pgluell | rewrite pushout_assoc_right_rec_beta_pgluerr, pushout_assoc_left_rec_beta_pgluelr ]; rewrite concat_p1, ap_idmap; apply concat_Vp ). - abstract ( srefine (pushout_assoc_left_ind _ (fun _ => 1) (fun _ => 1) (fun _ => 1) _ _); intros; simpl; rewrite transport_paths_FlFr, ap_compose; [ rewrite pushout_assoc_left_rec_beta_pgluell, pushout_assoc_right_rec_beta_pgluerl | rewrite pushout_assoc_left_rec_beta_pgluelr, pushout_assoc_right_rec_beta_pgluerr ]; rewrite concat_p1, ap_idmap; apply concat_Vp ). Defined. End PushoutAssoc. (** ** Pushouts of equvialences are equivalences *) Global Instance isequiv_pushout_isequiv {A B C} (f : A -> B) (g : A -> C) `{IsEquiv _ _ f} : IsEquiv (pushr' f g). Proof. srefine (isequiv_adjointify _ _ _ _). - srefine (Pushout_rec C (g o f^-1) idmap _). intros a; cbn; apply ap, eissect. - srefine (Pushout_ind _ _ _ _); cbn. + intros b; change (pushr' f g (g (f^-1 b)) = pushl b). transitivity (pushl' f g (f (f^-1 b))). * symmetry; apply pglue. * apply ap, eisretr. + intros c; reflexivity. + intros a. abstract ( rewrite transport_paths_FlFr, ap_compose, !concat_pp_p; apply moveR_Vp; apply moveR_Vp; rewrite Pushout_rec_beta_pglue, eisadj, ap_idmap, concat_p1; rewrite <- ap_compose, <- (ap_compose g (pushr' f g)); exact (concat_Ap (pglue' f g) (eissect f a)) ). - intros c; reflexivity. Defined. Global Instance isequiv_pushout_isequiv' {A B C} (f : A -> B) (g : A -> C) `{IsEquiv _ _ g} : IsEquiv (pushl' f g). Proof. srefine (isequiv_adjointify _ _ _ _). - srefine (Pushout_rec B idmap (f o g^-1) _). intros a; cbn. symmetry; apply ap, eissect. - srefine (Pushout_ind _ _ _ _); cbn. + intros b; reflexivity. + intros c; change (pushl' f g (f (g^-1 c)) = pushr c). transitivity (pushr' f g (g (g^-1 c))). * apply pglue. * apply ap, eisretr. + intros a. abstract ( rewrite transport_paths_FlFr, ap_compose, !concat_pp_p; apply moveR_Vp; rewrite Pushout_rec_beta_pglue, eisadj, ap_idmap, concat_1p, ap_V; apply moveL_Vp; rewrite <- !ap_compose; exact (concat_Ap (pglue' f g) (eissect g a)) ). - intros c; reflexivity. Defined. (** ** Descent *) (** We study "equifibrant" type families over a span [f : A -> B] and [g : A -> C]. By univalence, the descent property tells us that these type families correspond to type families over the pushout, and we obtain an induction principle for such type families. Dependent descent data over some particular descent data are "equifibrant" type families over this descent data. The "equifibrancy" is only taken over the span [f : A -> B] and [g : A -> C], but there is an extra level of dependency coming from the descent data. In this case, we obtain an induction and recursion principle, but only with a computation rule for the recursion principle. The theory of descent is interesting to consider in itself. However, we will use it as a means to structure the code, and to obtain induction and recursion principles that are valuable in proving the flattening lemma, and characterizing path spaces. Thus we will gloss over the bigger picture, and not consider equivalences of descent data, nor homotopies of their sections. We will also not elaborate on uniqueness of the induced families. It's possible to prove the results in the Descent, Flattening and Paths Sections without univalence, by replacing all equivalences with paths, but in practice these results will be used with equivalences as input, making the form below more convenient. See https://github.com/HoTT/Coq-HoTT/pull/2147#issuecomment-2521570830 for further information. *) Section Descent. Context `{Univalence}. (** Descent data over [f : A -> B] and [g : A -> C] are "equifibrant" or "cartesian" type families [pod_faml : B -> Type] and [pod_famr : C -> Type]. This means that if [a : A], then the fibers [pod_faml (f a)] and [pod_famr (g a)] are equivalent, witnessed by [pod_e]. *) Record poDescent {A B C : Type} {f : A -> B} {g : A -> C} := { pod_faml (b : B) : Type; pod_famr (c : C) : Type; pod_e (a : A) : pod_faml (f a) <~> pod_famr (g a) }. Global Arguments poDescent {A B C} f g. (** Let [A], [B], and [C] be types, with a morphisms [f : A -> B] and [g : A -> C]. *) Context {A B C : Type} {f : A -> B} {g : A -> C}. (** Descent data induces a type family over [Pushout f g]. *) Definition fam_podescent (Pe : poDescent f g) : Pushout f g -> Type. Proof. snrapply (Pushout_rec _ (pod_faml Pe) (pod_famr Pe)). intro a. exact (path_universe_uncurried (pod_e Pe a)). Defined. (** A type family over [Pushout f g] induces descent data. *) Definition podescent_fam (P : Pushout f g -> Type) : poDescent f g. Proof. snrapply Build_poDescent. - exact (P o pushl). - exact (P o pushr). - intro a. exact (equiv_transport P (pglue a)). Defined. (** Transporting over [fam_podescent] along [pglue a] is given by [pod_e]. *) Definition transport_fam_podescent_pglue (Pe : poDescent f g) (a : A) (pf : pod_faml Pe (f a)) : transport (fam_podescent Pe) (pglue a) pf = pod_e Pe a pf. Proof. nrapply transport_path_universe'. nrapply Pushout_rec_beta_pglue. Defined. (** A section on the descent data are fiberwise sections that respects the equivalences. *) Record poDescentSection {Pe : poDescent f g} := { pods_sectl (b : B) : pod_faml Pe b; pods_sectr (c : C) : pod_famr Pe c; pods_e (a : A) : pod_e Pe a (pods_sectl (f a)) = pods_sectr (g a) }. Global Arguments poDescentSection Pe : clear implicits. (** A descent section induces a genuine section of [fam_cdescent Pe]. *) Definition podescent_ind {Pe : poDescent f g} (s : poDescentSection Pe) : forall (x : Pushout f g), fam_podescent Pe x. Proof. snrapply (Pushout_ind _ (pods_sectl s) (pods_sectr s)). intro a. exact (transport_fam_podescent_pglue Pe a _ @ pods_e s a). Defined. (** We record its computation rule *) Definition podescent_ind_beta_pglue {Pe : poDescent f g} (s : poDescentSection Pe) (a : A) : apD (podescent_ind s) (pglue a) = transport_fam_podescent_pglue Pe a _ @ pods_e s a := Pushout_ind_beta_pglue _ (pods_sectl s) (pods_sectr s) _ _. (** Dependent descent data over descent data [Pe : poDescent f g] consists of a type families [podd_faml : forall (b : B), pod_faml Pe b -> Type] and [podd_famr : forall (c : C), pod_famr Pe c -> Type] together with coherences [podd_e a pf]. *) Record poDepDescent {Pe : poDescent f g} := { podd_faml (b : B) (pb : pod_faml Pe b) : Type; podd_famr (c : C) (pc : pod_famr Pe c) : Type; podd_e (a : A) (pf : pod_faml Pe (f a)) : podd_faml (f a) pf <~> podd_famr (g a) (pod_e Pe a pf) }. Global Arguments poDepDescent Pe : clear implicits. (** A dependent type family over [fam_podescent Pe] induces dependent descent data over [Pe]. *) Definition podepdescent_fam {Pe : poDescent f g} (Q : forall (x : Pushout f g), (fam_podescent Pe) x -> Type) : poDepDescent Pe. Proof. snrapply Build_poDepDescent. - intro b; cbn. exact (Q (pushl b)). - intros c; cbn. exact (Q (pushr c)). - intros a pf. exact (equiv_transportDD (fam_podescent Pe) Q (pglue a) (transport_fam_podescent_pglue Pe a pf)). Defined. (** Dependent descent data over [Pe] induces a dependent type family over [fam_podescent Pe]. *) Definition fam_podepdescent {Pe : poDescent f g} (Qe : poDepDescent Pe) : forall (x : Pushout f g), (fam_podescent Pe x) -> Type. Proof. snrapply Pushout_ind. - exact (podd_faml Qe). - exact (podd_famr Qe). - intro a. nrapply (moveR_transport_p _ (pglue a)). funext pf. rhs nrapply transport_arrow_toconst. rhs nrefine (ap (podd_famr _ _) _). + exact (path_universe (podd_e _ _ _)). + lhs nrapply (ap (fun x => (transport _ x _)) (inv_V (pglue _))). nrapply (transport_fam_podescent_pglue _ _ _). Defined. (** A section of dependent descent data [Qe : poDepDescent Pe] are fiberwise sections [podds_sectl] and [podds_sectr], together with coherences [pods_e]. *) Record poDepDescentSection {Pe : poDescent f g} {Qe : poDepDescent Pe} := { podds_sectl (b : B) (pb : pod_faml Pe b) : podd_faml Qe b pb; podds_sectr (c : C) (pc : pod_famr Pe c) : podd_famr Qe c pc; podds_e (a : A) (pf : pod_faml Pe (f a)) : podd_e Qe a pf (podds_sectl (f a) pf) = podds_sectr (g a) (pod_e Pe a pf) }. Global Arguments poDepDescentSection {Pe} Qe. (** A dependent descent section induces a genuine section over the total space of [induced_fam_pod Pe]. *) Definition podepdescent_ind {Pe : poDescent f g} {Q : forall (x : Pushout f g), (fam_podescent Pe) x -> Type} (s : poDepDescentSection (podepdescent_fam Q)) : forall (x : Pushout f g) (px : fam_podescent Pe x), Q x px. Proof. nrapply (Pushout_ind _ (podds_sectl s) (podds_sectr s) _). intro a. apply dpath_forall. intro pf. apply (equiv_inj (transport (Q (pushr (g a))) (transport_fam_podescent_pglue Pe a pf))). rhs nrapply (apD (podds_sectr s (g a)) (transport_fam_podescent_pglue Pe a pf)). exact (podds_e s a pf). Defined. (** The data for a section into a constant type family. *) Record poDepDescentConstSection {Pe : poDescent f g} {Q : Type} := { poddcs_sectl (b : B) (pb : pod_faml Pe b) : Q; poddcs_sectr (c : C) (pc : pod_famr Pe c) : Q; poddcs_e (a : A) (pf : pod_faml Pe (f a)) : poddcs_sectl (f a) pf = poddcs_sectr (g a) (pod_e Pe a pf) }. Global Arguments poDepDescentConstSection Pe Q : clear implicits. (** The data for a section of a constant family induces a section over the total space of [fam_podescent Pe]. *) Definition podepdescent_rec {Pe : poDescent f g} {Q : Type} (s : poDepDescentConstSection Pe Q) : forall (x : Pushout f g), fam_podescent Pe x -> Q. Proof. snrapply (Pushout_ind _ (poddcs_sectl s) (poddcs_sectr s)); cbn. intro a. nrapply dpath_arrow. intro pf. lhs nrapply transport_const. rhs nrapply (ap _ (transport_fam_podescent_pglue Pe a pf)). exact (poddcs_e s a pf). Defined. (** Here is the computation rule on paths. *) Definition podepdescent_rec_beta_pglue {Pe : poDescent f g} {Q : Type} (s : poDepDescentConstSection Pe Q) (a : A) {pf : pod_faml Pe (f a)} {pg : pod_famr Pe (g a)} (pa : pod_e Pe a pf = pg) : ap (sig_rec (podepdescent_rec s)) (path_sigma _ (pushl (f a); pf) (pushr (g a); pg) (pglue a) (transport_fam_podescent_pglue Pe a pf @ pa)) = poddcs_e s a pf @ ap (poddcs_sectr s (g a)) pa. Proof. Open Scope long_path_scope. destruct pa. rhs nrapply concat_p1. lhs nrapply ap_sig_rec_path_sigma. lhs nrapply (ap (fun x => _ (ap10 x _) @ _)). 1: nrapply Pushout_ind_beta_pglue. do 3 lhs nrapply concat_pp_p. apply moveR_Vp. lhs nrefine (1 @@ (1 @@ (_ @@ 1))). 1: nrapply (ap10_dpath_arrow (fam_podescent Pe) (fun _ => Q) (pglue a)). lhs nrefine (1 @@ _). { lhs nrapply (1 @@ concat_pp_p _ _ _). lhs nrapply (1 @@ concat_pp_p _ _ _). lhs nrapply concat_V_pp. lhs nrapply (1 @@ concat_pp_p _ _ _). rewrite concat_p1. nrapply (1 @@ (1 @@ concat_pV_p _ _)). } nrapply concat_V_pp. Close Scope long_path_scope. Defined. End Descent. (** ** The flattening lemma *) (** We saw above that given descent data [Pe] over a span [f : A -> B] and [g : A -> C], we obtained a type family [fam_podescent Pe] over the pushout. The flattening lemma describes the total space [sig (fam_podescent Pe)] of this type family as a pushout of [sig (pod_faml Pe)] and [sig (pod_famr Pe)] by a certain span. This follows from the work above, which shows that [sig (fam_podescent Pe)] has the same universal property as this pushout. *) Section Flattening. Context `{Univalence} {A B C : Type} {f : A -> B} {g : A -> C} (Pe : poDescent f g). (** We mimic the constructors of [Pushout] for the total space. Here are the point constructors, in curried form. *) Definition flatten_podl {b : B} (pb : pod_faml Pe b) : sig (fam_podescent Pe) := (pushl b; pb). Definition flatten_podr {c : C} (pc : pod_famr Pe c) : sig (fam_podescent Pe) := (pushr c; pc). (** And here is the path constructor. *) Definition flatten_pod_glue (a : A) {pf : pod_faml Pe (f a)} {pg : pod_famr Pe (g a)} (pa : pod_e Pe a pf = pg) : flatten_podl pf = flatten_podr pg. Proof. snrapply path_sigma. - by apply pglue. - lhs nrapply transport_fam_podescent_pglue. exact pa. Defined. (** Now that we've shown that [fam_podescent Pe] acts like a [Pushout] of [sig (pod_faml Pe)] and [sig (pod_famr Pe)] by an appropriate span, we can use this to prove the flattening lemma. The maps back and forth are very easy so this could almost be a formal consequence of the induction principle. *) Lemma equiv_pod_flatten : sig (fam_podescent Pe) <~> Pushout (functor_sigma f (fun _ => idmap)) (functor_sigma g (pod_e Pe)). Proof. snrapply equiv_adjointify. - snrapply sig_rec. snrapply podepdescent_rec. snrapply Build_poDepDescentConstSection. + exact (fun b pb => pushl (b; pb)). + exact (fun c pc => pushr (c; pc)). + intros a pf. cbn. apply (@pglue _ _ _ (functor_sigma f (fun _ => idmap)) (functor_sigma g (pod_e Pe)) (a; pf)). - snrapply Pushout_rec. + exact (fun '(b; pb) => (pushl b; pb)). + exact (fun '(c; pc) => (pushr c; pc)). + intros [a pf]; cbn. apply (flatten_pod_glue a 1). - snrapply Pushout_ind. 1, 2: reflexivity. intros [a pf]; cbn. nrapply transport_paths_FFlr'; apply equiv_p1_1q. rewrite Pushout_rec_beta_pglue. lhs nrapply podepdescent_rec_beta_pglue. nrapply concat_p1. - intros [x px]; revert x px. snrapply podepdescent_ind. snrapply Build_poDepDescentSection. + by intros b pb. + by intros c pc. + intros a pf; cbn. lhs nrapply transportDD_is_transport. nrapply transport_paths_FFlr'; apply equiv_p1_1q. rewrite <- (concat_p1 (transport_fam_podescent_pglue _ _ _)). rewrite podepdescent_rec_beta_pglue. (* This needs to be in the form [transport_fam_podescent_gqglue Pe r pa @ p] to work, and the other [@ 1] introduced comes in handy as well. *) lhs nrapply (ap _ (concat_p1 _)). nrapply (Pushout_rec_beta_pglue _ _ _ _ (a; pf)). Defined. End Flattening. (** ** Characterization of path spaces *) (** A pointed type family over a pushout has an identity system structure precisely when its associated descent data satisfies Kraus and von Raumer's induction principle, https://arxiv.org/pdf/1901.06022. *) Section Paths. (** Let [f : A -> B] and [g : A -> C] be a span, with a distinguished point [b0 : B]. We could let the distinguished point be in [C], but this is symmetric by exchanging the roles of [f] and [g]. Let [Pe : poDescent f g] be descent data over [f g] with a distinguished point [p0 : pod_faml Pe b0]. Assume that any dependent descent data [Qe : poDepDescent Pe] with a distinguished point [q0 : podd_faml Qe b0 p0] has a section that respects the distinguished points. This is the induction principle provided by Kraus and von Raumer. *) Context `{Univalence} {A B C : Type} {f : A -> B} {g : A -> C} (b0 : B) (Pe : poDescent f g) (p0 : pod_faml Pe b0) (based_podepdescent_ind : forall (Qe : poDepDescent Pe) (q0 : podd_faml Qe b0 p0), poDepDescentSection Qe) (based_podepdescent_ind_beta : forall (Qe : poDepDescent Pe) (q0 : podd_faml Qe b0 p0), podds_sectl (based_podepdescent_ind Qe q0) b0 p0 = q0). (** Under these hypotheses, we get an identity system structure on [fam_podescent Pe]. *) Local Instance idsys_flatten_podescent : @IsIdentitySystem _ (pushl b0) (fam_podescent Pe) p0. Proof. snrapply Build_IsIdentitySystem. - intros Q q0 x px. snrapply podepdescent_ind. by apply based_podepdescent_ind. - intros Q q0; cbn. nrapply (based_podepdescent_ind_beta (podepdescent_fam Q)). Defined. (** It follows that the fibers [fam_podescent Pe x] are equivalent to path spaces [(pushl a0) = x]. *) Definition fam_podescent_equiv_path (x : Pushout f g) : (pushl b0) = x <~> fam_podescent Pe x := @equiv_transport_identitysystem _ (pushl b0) (fam_podescent Pe) p0 _ x. End Paths. Coq-HoTT-9.0/theories/Colimits/Quotient.v000066400000000000000000000324411474641544500203460ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import HSet. Require Import TruncType. Require Import Colimits.GraphQuotient. Require Import Truncations.Core. Set Universe Minimization ToSet. Local Open Scope path_scope. (** * The set-quotient of a type by a relation We aim to model: << Inductive Quotient R : Type := | class_of R : A -> Quotient R | qglue : forall x y, (R x y) -> class_of R x = class_of R y | ishset_quotient : IsHSet (Quotient R) >> We do this by defining the quotient as a 0-truncated graph quotient. Some results require additional assumptions, for example, that the relation be hprop-valued, or that the relation be reflexive, transitive or symmetric. Throughout this file [a], [b] and [c] are elements of [A], [R] is a relation on [A], [x], [y] and [z] are elements of [Quotient R], [p] is a proof of [R a b]. *) Definition Quotient@{i j k} {A : Type@{i}} (R : Relation@{i j} A) : Type@{k} := Trunc@{k} 0 (GraphQuotient@{i j k} R). Definition class_of@{i j k} {A : Type@{i}} (R : Relation@{i j} A) : A -> Quotient@{i j k} R := tr o gq. Definition qglue@{i j k} {A : Type@{i}} {R : Relation@{i j} A} {a b : A} : R a b -> class_of@{i j k} R a = class_of R b := fun p => ap tr (gqglue p). Global Instance ishset_quotient {A : Type} (R : Relation A) : IsHSet (Quotient R) := _. Definition Quotient_ind@{i j k l} {A : Type@{i}} (R : Relation@{i j} A) (P : Quotient@{i j k} R -> Type@{l}) {sP : forall x, IsHSet (P x)} (pclass : forall a, P (class_of R a)) (peq : forall a b (H : R a b), qglue H # pclass a = pclass b) : forall x, P x. Proof. rapply Trunc_ind; srapply GraphQuotient_ind. - exact pclass. - intros a b p. lhs nrapply (transport_compose P). exact (peq a b p). Defined. Definition Quotient_ind_beta_qglue@{i j k l} {A : Type@{i}} (R : Relation@{i j} A) (P : Quotient@{i j k} R -> Type@{l}) {sP : forall x, IsHSet (P x)} (pclass : forall a, P (class_of R a)) (peq : forall a b (H : R a b), qglue H # pclass a = pclass b) (a b : A) (p : R a b) : apD (Quotient_ind@{i j k l} R P pclass peq) (qglue p) = peq a b p. Proof. lhs nrapply apD_compose'. unfold Quotient_ind. nrefine (ap _ (GraphQuotient_ind_beta_gqglue _ pclass (fun a b p0 => transport_compose P tr _ _ @ peq a b p0) _ _ _) @ _). rapply concat_V_pp. Defined. Definition Quotient_rec@{i j k l} {A : Type@{i}} (R : Relation@{i j} A) (P : Type@{l}) `{IsHSet P} (pclass : A -> P) (peq : forall a b, R a b -> pclass a = pclass b) : Quotient@{i j k} R -> P. Proof. srapply Trunc_rec; snrapply GraphQuotient_rec. - exact pclass. - exact peq. Defined. Definition Quotient_rec_beta_qglue @{i j k l} {A : Type@{i}} (R : Relation@{i j} A) (P : Type@{l}) `{IsHSet P} (pclass : A -> P) (peq : forall a b, R a b -> pclass a = pclass b) (a b : A) (p : R a b) : ap (Quotient_rec@{i j k l} R P pclass peq) (qglue p) = peq a b p. Proof. lhs_V nrapply (ap_compose tr). snrapply GraphQuotient_rec_beta_gqglue. Defined. Arguments Quotient : simpl never. Arguments class_of : simpl never. Arguments qglue : simpl never. Arguments Quotient_ind_beta_qglue : simpl never. Arguments Quotient_rec_beta_qglue : simpl never. Notation "A / R" := (Quotient (A:=A) R). (** Quotient induction into an hprop. *) Definition Quotient_ind_hprop {A : Type@{i}} (R : Relation@{i j} A) (P : A / R -> Type) `{forall x, IsHProp (P x)} (dclass : forall a, P (class_of R a)) : forall x, P x. Proof. srapply (Quotient_ind R P dclass). intros x y p; apply path_ishprop. Defined. Definition Quotient_ind2_hprop {A : Type@{i}} (R : Relation@{i j} A) (P : A / R -> A / R -> Type) `{forall x y, IsHProp (P x y)} (dclass : forall a b, P (class_of R a) (class_of R b)) : forall x y, P x y. Proof. intros x; srapply Quotient_ind_hprop; intros b. revert x; srapply Quotient_ind_hprop; intros a. exact (dclass a b). Defined. Definition Quotient_ind3_hprop {A : Type@{i}} (R : Relation@{i j} A) (P : A / R -> A / R -> A / R -> Type) `{forall x y z, IsHProp (P x y z)} (dclass : forall a b c, P (class_of R a) (class_of R b) (class_of R c)) : forall x y z, P x y z. Proof. intros x; srapply Quotient_ind2_hprop; intros b c. revert x; srapply Quotient_ind_hprop; intros a. exact (dclass a b c). Defined. Definition Quotient_ind2 {A : Type} (R : Relation A) (P : A / R -> A / R -> Type) `{forall x y, IsHSet (P x y)} (dclass : forall a b, P (class_of R a) (class_of R b)) (dequiv_l : forall a a' b (p : R a a'), transport (fun x => P x _) (qglue p) (dclass a b) = dclass a' b) (dequiv_r : forall a b b' (p : R b b'), qglue p # dclass a b = dclass a b') : forall x y, P x y. Proof. intro x. srapply Quotient_ind. - intro b. revert x. srapply Quotient_ind. + intro a. exact (dclass a b). + cbn beta. intros a a' p. by apply dequiv_l. - cbn beta. intros b b' p. revert x. srapply Quotient_ind_hprop; simpl. intro a; by apply dequiv_r. Defined. Definition Quotient_rec2 {A : Type} (R : Relation A) (B : Type) `{IsHSet B} (dclass : A -> A -> B) (dequiv_l : forall a a' b, R a a' -> dclass a b = dclass a' b) (dequiv_r : forall a b b', R b b' -> dclass a b = dclass a b') : A / R -> A / R -> B. Proof. srapply Quotient_ind2. - exact dclass. - intros; lhs nrapply transport_const. by apply dequiv_l. - intros; lhs nrapply transport_const. by apply dequiv_r. Defined. Section Equiv. Context `{Univalence} {A : Type} (R : Relation A) `{is_mere_relation _ R} `{Transitive _ R} `{Symmetric _ R} `{Reflexive _ R}. (** The proposition of being in a given class in a quotient. This requires [Univalence] so that we know that [HProp] is a set. *) Definition in_class : A / R -> A -> HProp. Proof. intros x b; revert x. srapply Quotient_rec. 1: intro a; exact (Build_HProp (R a b)). intros a c p; cbn beta. apply path_hprop. srapply equiv_iff_hprop; cbn. 1: apply (transitivity (symmetry _ _ p)). apply (transitivity p). Defined. (** Being in a class is decidable if the relation is decidable. *) Global Instance decidable_in_class `{forall a b, Decidable (R a b)} : forall x a, Decidable (in_class x a). Proof. by srapply Quotient_ind_hprop. Defined. (** If [a] is in a class [x], then the class of [a] is equal to [x]. *) Lemma path_in_class_of : forall x a, in_class x a -> x = class_of R a. Proof. srapply Quotient_ind. { intros a b p. exact (qglue p). } intros a b p. funext ? ?. apply hset_path2. Defined. Lemma related_quotient_paths (a b : A) : class_of R a = class_of R b -> R a b. Proof. intros p. change (in_class (class_of R a) b). destruct p^. cbv; reflexivity. Defined. (** Theorem 10.1.8. *) Theorem path_quotient (a b : A) : R a b <~> (class_of R a = class_of R b). Proof. apply equiv_iff_hprop. - apply qglue. - apply related_quotient_paths. Defined. (** The map [class_of : A -> A/R] is a surjection. *) Global Instance issurj_class_of : IsSurjection (class_of R). Proof. apply BuildIsSurjection. srapply Quotient_ind_hprop. intro a. apply tr. by exists a. Defined. (** The universal property of the quotient. This is Lemma 6.10.3. *) Theorem equiv_quotient_ump (B : Type) `{IsHSet B} : (A / R -> B) <~> {f : A -> B & forall a b, R a b -> f a = f b}. Proof. srapply equiv_adjointify. + intro f. exists (compose f (class_of R)). intros; f_ap. by apply qglue. + intros [f H']. apply (Quotient_rec _ _ _ H'). + intros [f Hf]. by apply equiv_path_sigma_hprop. + intros f. apply path_forall. srapply Quotient_ind_hprop. reflexivity. Defined. (** TODO: The equivalence with VVquotient [A//R]. 10.1.10. Equivalence Relations are effective and there is an equivalence [A/R<~>A//R]. This will need propositional resizing if we don't want to raise the universe level. *) (** The theory of canonical quotients is developed by C.Cohen: http://perso.crans.org/cohen/work/quotients/ *) End Equiv. Section Functoriality. (* TODO: Develop a notion of set with Relation and use that instead of manually adding Relation preserving conditions. *) Definition Quotient_functor {A : Type} (R : Relation A) {B : Type} (S : Relation B) (f : A -> B) (fresp : forall a b, R a b -> S (f a) (f b)) : Quotient R -> Quotient S. Proof. refine (Quotient_rec R _ (class_of S o f) _). intros a b p. apply qglue, fresp, p. Defined. Definition Quotient_functor_idmap {A : Type} {R : Relation A} : Quotient_functor R R idmap (fun x y => idmap) == idmap. Proof. by srapply Quotient_ind_hprop. Defined. Definition Quotient_functor_compose {A : Type} {R : Relation A} {B : Type} {S : Relation B} {C : Type} {T : Relation C} (f : A -> B) (fresp : forall a b, R a b -> S (f a) (f b)) (g : B -> C) (gresp : forall a b, S a b -> T (g a) (g b)) : Quotient_functor R T (g o f) (fun a b => (gresp _ _) o (fresp a b)) == Quotient_functor S T g gresp o Quotient_functor R S f fresp. Proof. by srapply Quotient_ind_hprop. Defined. Context {A : Type} (R : Relation A) {B : Type} (S : Relation B). Global Instance isequiv_quotient_functor (f : A -> B) (fresp : forall a b, R a b <-> S (f a) (f b)) `{IsEquiv _ _ f} : IsEquiv (Quotient_functor R S f (fun a b => fst (fresp a b))). Proof. srapply (isequiv_adjointify _ (Quotient_functor S R f^-1 _)). { intros a b s. apply (snd (fresp _ _)). abstract (do 2 rewrite eisretr; apply s). } all: srapply Quotient_ind. + intros b; simpl. apply ap, eisretr. + intros; apply path_ishprop. + intros a; simpl. apply ap, eissect. + intros; apply path_ishprop. Defined. Definition equiv_quotient_functor (f : A -> B) `{IsEquiv _ _ f} (fresp : forall a b, R a b <-> S (f a) (f b)) : Quotient R <~> Quotient S := Build_Equiv _ _ (Quotient_functor R S f (fun a b => fst (fresp a b))) _. Definition equiv_quotient_functor' (f : A <~> B) (fresp : forall a b, R a b <-> S (f a) (f b)) : Quotient R <~> Quotient S := equiv_quotient_functor f fresp. End Functoriality. Section Kernel. (** ** Quotients of kernels of maps to sets give a surjection/mono factorization. *) (** Because the statement uses nested Sigma types, we need several variables to serve as [max] and [u+1]. We write [ar] for [max(a,r)], [ar'] for [ar+1], etc. *) Universes a r ar ar' b ab abr. Constraint a <= ar, r <= ar, ar < ar', a <= ab, b <= ab, ab <= abr, ar <= abr. Context `{Funext}. (** A function we want to factor. *) Context {A : Type@{a}} {B : Type@{b}} `{IsHSet B} (f : A -> B). (** A mere Relation equivalent to its kernel. *) Context (R : Relation@{a r} A) (is_ker : forall x y, f x = f y <~> R x y). (** The factorization theorem. An advantage of stating it as one bundled result is that it is easier to state variations as we do below. Disadvantages are that it requires more universe variables and that each piece of the answer depends on [Funext] and all of the universe variables, even when these aren't needed for that piece. Below we will clean up the universe variables slightly, so we make this version [Local]. *) Local Definition quotient_kernel_factor_internal : exists (C : Type@{ar}) (e : A -> C) (m : C -> B), IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e). Proof. exists (Quotient R). exists (class_of R). srefine (_;_). { refine (Quotient_ind R (fun _ => B) f _). intros x y p. lhs nrapply transport_const. exact ((is_ker x y)^-1 p). } repeat split; try exact _. intro u. apply hprop_allpath. intros [x q] [y p']. apply path_sigma_hprop; simpl. revert x y q p'. srapply Quotient_ind. 2: intros; apply path_ishprop. intro a. srapply Quotient_ind. 2: intros; apply path_ishprop. intros a' p p'. apply qglue, is_ker. exact (p @ p'^). Defined. (** We clean up the universe variables here, using only those declared in this Section. *) Definition quotient_kernel_factor_general@{|} := Eval unfold quotient_kernel_factor_internal in quotient_kernel_factor_internal@{ar' ar abr abr ab abr abr}. End Kernel. (** A common special case of [quotient_kernel_factor] is when we define [R] to be [f x = f y]. Then universes [r] and [b] are unified. *) Definition quotient_kernel_factor@{a b ab ab' | a <= ab, b <= ab, ab < ab'} `{Funext} {A : Type@{a}} {B : Type@{b}} `{IsHSet B} (f : A -> B) : exists (C : Type@{ab}) (e : A -> C) (m : C -> B), IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e). Proof. exact (quotient_kernel_factor_general@{a b ab ab' b ab ab} f (fun a b => f a = f b) (fun x y => equiv_idmap)). Defined. (** If we use propositional resizing, we can replace [f x = f y] with a proposition [R x y] in universe [a], so that the universe of [C] is the same as the universe of [A]. *) Definition quotient_kernel_factor_small@{a a' b ab | a < a', a <= ab, b <= ab} `{Funext} `{PropResizing} {A : Type@{a}} {B : Type@{b}} `{IsHSet B} (f : A -> B) : exists (C : Type@{a}) (e : A -> C) (m : C -> B), IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e). Proof. exact (quotient_kernel_factor_general@{a a a a' b ab ab} f (fun a b => smalltype@{a b} (f a = f b)) (fun x y => (equiv_smalltype _)^-1%equiv)). Defined. Coq-HoTT-9.0/theories/Colimits/Quotient/000077500000000000000000000000001474641544500201535ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Colimits/Quotient/Choice.v000066400000000000000000000243611474641544500215420ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types HoTT.Universes.HSet HoTT.Truncations.Core HoTT.Colimits.Quotient HoTT.Projective. (** The following is an alternative (0,-1)-projectivity predicate on [A]. Given a family of quotient equivalence classes [f : forall x : A, B x / R x], for [R : forall x : A, Relation (B x)], we merely have a choice function [g : forall x, B x], factoring [f] as [f x = class_of (g x)]. *) Definition HasQuotientChoice (A : Type) := forall (B : A -> Type), (forall x, IsHSet (B x)) -> forall (R : forall x, Relation (B x)) (pR : forall x, is_mere_relation (B x) (R x)), (forall x, Reflexive (R x)) -> (forall x, Symmetric (R x)) -> (forall x, Transitive (R x)) -> forall (f : forall x : A, B x / R x), hexists (fun g : (forall x : A, B x) => forall x, class_of (R x) (g x) = f x). Section choose_has_quotient_choice. Context `{Univalence} {A : Type} {B : A -> Type} `{!forall x, IsHSet (B x)} (P : forall x, B x -> Type) `{!forall x (a : B x), IsHProp (P x a)}. Local Definition RelClassEquiv (x : A) (a : B x) (b : B x) : Type := P x a <~> P x b. Local Instance reflexive_relclass : forall x, Reflexive (RelClassEquiv x). Proof. intros a b. apply equiv_idmap. Qed. Local Instance symmetric_relclass : forall x, Symmetric (RelClassEquiv x). Proof. intros a b1 b2 p. apply (equiv_inverse p). Qed. Local Instance transitive_relclass : forall x, Transitive (RelClassEquiv x). Proof. intros a b1 b2 b3 p q. apply (equiv_compose q p). Qed. Local Instance hprop_choose_cod (a : A) : IsHProp {c : B a / RelClassEquiv a | forall b, in_class (RelClassEquiv a) c b <~> P a b}. Proof. apply ishprop_sigma_disjoint. refine (Quotient_ind_hprop _ _ _). intro b1. refine (Quotient_ind_hprop _ _ _). intros b2 f g. apply qglue. apply (f b2)^-1. apply g. apply reflexive_relclass. Qed. Local Definition prechoose (i : forall x, hexists (P x)) (a : A) : {c : B a / RelClassEquiv a | forall b : B a, in_class (RelClassEquiv a) c b <~> P a b}. Proof. specialize (i a). strip_truncations. destruct i as [b1 h]. exists (class_of _ b1). intro b2. apply equiv_iff_hprop. - intro f. exact (f h). - intro p. by apply equiv_iff_hprop. Defined. Local Definition choose (i : forall x, hexists (P x)) (a : A) : B a / RelClassEquiv a := (prechoose i a).1. End choose_has_quotient_choice. (** The following section derives [HasTrChoice 0 A] from [HasQuotientChoice A]. *) Section has_tr0_choice_quotientchoice. Context `{Funext} (A : Type) (qch : HasQuotientChoice A). Local Definition RelUnit (B : A -> Type) (a : A) (b1 b2 : B a) : HProp := Build_HProp Unit. Local Instance reflexive_relunit (B : A -> Type) (a : A) : Reflexive (RelUnit B a). Proof. done. Qed. Local Instance symmetric_relunit (B : A -> Type) (a : A) : Symmetric (RelUnit B a). Proof. done. Qed. Local Instance transitive_relunit (B : A -> Type) (a : A) : Transitive (RelUnit B a). Proof. done. Qed. Local Instance ishprop_quotient_relunit (B : A -> Type) (a : A) : IsHProp (B a / RelUnit B a). Proof. apply hprop_allpath. refine (Quotient_ind_hprop _ _ _). intro r. refine (Quotient_ind_hprop _ _ _). intro s. by apply qglue. Qed. Lemma has_tr0_choice_quotientchoice : HasTrChoice 0 A. Proof. intros B sB f. transparent assert (g : (forall a, B a / RelUnit B a)). - intro a. specialize (f a). strip_truncations. exact (class_of _ f). - specialize (qch B _ (RelUnit B) _ _ _ _ g). strip_truncations. apply tr. apply qch. Qed. End has_tr0_choice_quotientchoice. Lemma has_quotient_choice_tr0choice (A : Type) : HasTrChoice 0 A -> HasQuotientChoice A. Proof. intros ch B sB R pR rR sR tR f. set (P := fun a b => class_of (R a) b = f a). assert (forall a, merely ((fun x => {b | P x b}) a)) as g. - intro a. refine (Quotient_ind_hprop _ (fun c => merely {b | class_of (R a) b = c}) _ (f a)). intro b. apply tr. by exists b. - pose proof (ch (fun a => {b | P a b}) _ g) as h. strip_truncations. apply tr. exists (fun x => (h x).1). intro a. apply h. Qed. Global Instance isequiv_has_tr0_choice_to_has_quotient_choice `{Funext} (A : Type) : IsEquiv (has_quotient_choice_tr0choice A). Proof. srapply isequiv_iff_hprop. - apply istrunc_forall. - apply has_tr0_choice_quotientchoice. Qed. Definition equiv_has_tr0_choice_has_quotient_choice `{Funext} (A : Type) : HasTrChoice 0 A <~> HasQuotientChoice A := Build_Equiv _ _ (has_quotient_choice_tr0choice A) _. (** The next section uses [has_quotient_choice_tr0choice] to generalize [quotient_rec2], see [choose_quotient_ind] below. *) Section choose_quotient_ind. Context `{Univalence} {I : Type} `{!HasTrChoice 0 I} {A : I -> Type} `{!forall i, IsHSet (A i)} (R : forall i, Relation (A i)) `{!forall i, is_mere_relation (A i) (R i)} {rR : forall i, Reflexive (R i)} {sR : forall i, Symmetric (R i)} {tR : forall i, Transitive (R i)}. (** First generalize the [qglue] constructor. *) Lemma qglue_forall (f g : forall i, A i) (r : forall i, R i (f i) (g i)) : (fun i => class_of (R i) (f i)) = (fun i => class_of (R i) (g i)). Proof. funext s. by apply qglue. Defined. (** Given suitable preconditions, we will show that [ChooseProp P a g] is inhabited, rather than directly giving an inhabitant of [P g]. This turns out to be beneficial because [ChooseProp P a g] is a proposition. *) Local Definition ChooseProp (P : (forall i, A i / R i) -> Type) `{!forall g, IsHSet (P g)} (a : forall (f : forall i, A i), P (fun i => class_of (R i) (f i))) (g : forall i, A i / R i) : Type := {b : P g | merely (exists (f : forall i, A i) (q : g = fun i => class_of (R i) (f i)), forall (f' : forall i, A i) (r : forall i, R i (f i) (f' i)), qglue_forall f f' r # q # b = a f')}. Local Instance ishprop_choose_quotient_ind_chooseprop (P : (forall i, A i / R i) -> Type) `{!forall g, IsHSet (P g)} (a : forall (f : forall i, A i), P (fun i => class_of (R i) (f i))) (g : forall i, A i / R i) : IsHProp (ChooseProp P a g). Proof. apply ishprop_sigma_disjoint. intros x y h1 h2. strip_truncations. destruct h1 as [f1 [q1 p1]]. destruct h2 as [f2 [q2 p2]]. specialize (p1 f1 (fun i => rR i (f1 i))). set (pR := fun i => related_quotient_paths (R i) _ _ (ap (fun h => h i) q2^ @ ap (fun h => h i) q1)). specialize (p2 f1 pR). do 2 apply moveL_transport_V in p1. do 2 apply moveL_transport_V in p2. refine (p1 @ _ @ p2^). apply moveR_transport_p. rewrite inv_V. rewrite <- transport_pp. apply moveR_transport_p. rewrite inv_V. do 2 rewrite <- transport_pp. set (pa := (qglue_forall f2 f1 pR)^ @ (q2^ @ q1 @ qglue_forall f1 f1 _)). by induction (hset_path2 idpath pa). Qed. (* Since [ChooseProp P a g] is a proposition, we can apply [has_quotient_choice_tr0choice] and strip its truncation in order to derive [ChooseProp P a g]. *) Lemma chooseprop_quotient_ind (P : (forall i, A i / R i) -> Type) `{!forall g, IsHSet (P g)} (a : forall (f : forall i, A i), P (fun i => class_of (R i) (f i))) (E : forall (f f' : forall i, A i) (r : forall i, R i (f i) (f' i)), qglue_forall f f' r # a f = a f') (g : forall i, A i / R i) : ChooseProp P a g. Proof. pose proof (has_quotient_choice_tr0choice I _ A _ R _ _ _ _ g) as h. strip_truncations. destruct h as [h p]. apply path_forall in p. refine (transport _ p _). exists (a h). apply tr. exists h. exists 1. apply E. Defined. (** By projecting out of [chooseprop_quotient_ind] we obtain a generalization of [quotient_rec2]. *) Lemma choose_quotient_ind (P : (forall i, A i / R i) -> Type) `{!forall g, IsHSet (P g)} (a : forall (f : forall i, A i), P (fun i => class_of (R i) (f i))) (E : forall (f f' : forall i, A i) (r : forall i, R i (f i) (f' i)), qglue_forall f f' r # a f = a f') (g : forall i, A i / R i) : P g. Proof. exact (chooseprop_quotient_ind P a E g).1. Defined. (** A specialization of [choose_quotient_ind] to the case where [P g] is a proposition. *) Lemma choose_quotient_ind_prop (P : (forall i, A i / R i) -> Type) `{!forall g, IsHProp (P g)} (a : forall (f : forall i, A i), P (fun i => class_of (R i) (f i))) (g : forall i, A i / R i) : P g. Proof. refine (choose_quotient_ind P a _ g). intros. apply path_ishprop. Defined. (** The recursion principle derived from [choose_quotient_ind]. *) Definition choose_quotient_rec {B : Type} `{!IsHSet B} (a : (forall i, A i) -> B) (E : forall (f f' : forall i, A i), (forall i, R i (f i) (f' i)) -> a f = a f') (g : forall i, A i / R i) : B := choose_quotient_ind (fun _ => B) a (fun f f' r => transport_const _ _ @ E f f' r) g. (** The "beta-rule" of [choose_quotient_ind]. *) Lemma choose_quotient_ind_compute (P : (forall i, A i / R i) -> Type) `{!forall g, IsHSet (P g)} (a : forall (f : forall i, A i), P (fun i => class_of (R i) (f i))) (E : forall (f f' : forall i, A i) (r : forall i, R i (f i) (f' i)), qglue_forall f f' r # a f = a f') (f : forall i, A i) : choose_quotient_ind P a E (fun i => class_of (R i) (f i)) = a f. Proof. refine (Trunc_ind (fun a => (_ a).1 = _) _ _). cbn. intros [f' p]. rewrite transport_sigma. set (p' := fun x => related_quotient_paths (R x) _ _ (p x)). assert (p = (fun i => qglue (p' i))) as pE. - funext x. apply hset_path2. - rewrite pE. apply E. Qed. (** The "beta-rule" of [choose_quotient_rec]. *) Lemma choose_quotient_rec_compute {B : Type} `{!IsHSet B} (a : (forall i, A i) -> B) (E : forall (f f' : forall i, A i), (forall i, R i (f i) (f' i)) -> a f = a f') (f : forall i, A i) : choose_quotient_rec a E (fun i => class_of (R i) (f i)) = a f. Proof. apply (choose_quotient_ind_compute (fun _ => B)). Qed. End choose_quotient_ind. Coq-HoTT-9.0/theories/Colimits/Sequential.v000066400000000000000000000621071474641544500206520ustar00rootroot00000000000000(** * Sequential colimits *) (** We present a proof of the conjecture that sequential colimits in HoTT appropriately commute with Σ-types. As a corollary, we characterize the path space of a sequential colimit as a sequential colimit of path spaces. For the written account of these results see https://www.cs.cornell.edu/~ks858/papers/sequential_colimits_homotopy.pdf. *) Require Import Basics. Require Import Types. Require Import Diagrams.Diagram. Require Import Diagrams.Sequence. Require Import Diagrams.Cocone. Require Import Colimits.Colimit. Require Import Spaces.Nat.Core. Require Import Homotopy.IdentitySystems. Local Open Scope nat_scope. Local Open Scope path_scope. (** [coe] is [transport idmap : (A = B) -> (A -> B)], but is described as the underlying map of an equivalence so that Coq knows that it is an equivalence. *) Notation coe := (fun p => equiv_fun (equiv_path _ _ p)). Notation "a ^+" := (@arr sequence_graph _ _ _ 1 a). (** Mapping spaces into hprops from colimits of sequences can be characterized. *) Lemma equiv_colim_seq_rec `{Funext} (A : Sequence) (P : Type) `{IsHProp P} : (Colimit A -> P) <~> (forall n, A n -> P). Proof. symmetry. refine (equiv_colimit_rec P oE _). refine (issig_Cocone _ _ oE _). symmetry. srapply Build_Equiv. 1: exact pr1. exact _. Defined. (** If a sequential colimit has maps homotopic to a constant map then the colimit is contractible. *) Global Instance contr_colim_seq_into_prop {funext : Funext} (A : Sequence) (a : forall n, A n) (H : forall n, const (a n.+1) == A _f idpath) : Contr (Colimit A). Proof. transparent assert (B : Sequence). { srapply Build_Sequence. 1: exact A. intros n. exact (const (a n.+1)). } rapply contr_equiv'. 1: rapply equiv_functor_colimit. 1: rapply (equiv_sequence B A). 1: reflexivity. { intros n e. exists equiv_idmap. intros x. symmetry. exact (H _ (e x)). } srapply Build_Contr. 1: exact (colim (D:=B) 1%nat (a 1%nat)). srapply Colimit_ind. { intros i x. induction i. 1: exact (colimp (D:=B) _ _ idpath x). refine (IHi (a i) @ _). refine ((colimp (D:=B) _ _ idpath (a i))^ @ _). refine ((colimp (D:=B) _ _ idpath (a i.+1))^ @ _). exact (colimp (D:=B) _ _ idpath x). } intros n m [] x. rewrite transport_paths_FlFr. rewrite ap_const. rewrite ap_idmap. destruct n; simpl; hott_simpl. Qed. Definition seq_shift_from_zero_by {A : Sequence} (a : A 0) k : A k. Proof. induction k as [ | k q]. - exact a. - exact q^+. Defined. Notation "a ^+ k" := (seq_shift_from_zero_by a k). (** Shiftings; described in the paragraph after Lemma 3.7. *) Definition seq_pair_shift {A : Sequence} (x : sig A) : sig A. Proof. destruct x as [n a]; exact (n.+1; a^+). Defined. Definition seq_pair_shift_by {A : Sequence} (x : sig A) (k : nat) : sig A. Proof. induction k as [ | k y]. - exact x. - exact (seq_pair_shift y). Defined. Notation "x ^++" := (seq_pair_shift x). Notation "x ^++ k" := (seq_pair_shift_by x k). Definition seq_pair_shift_assoc {A : Sequence} (x : sig A) (k : nat) : (x^++)^++k = x^++(k.+1). Proof. induction k as [ | k q]. - reflexivity. - exact (ap seq_pair_shift q). Defined. Definition seq_shift_pair_from_zero {A : Sequence} (a : A 0) k : (0;a)^++k = (k;a^+k). Proof. induction k as [ | k q]. - reflexivity. - exact (ap seq_pair_shift q). Defined. Notation inj A := (@colim sequence_graph A). Notation glue A := (fun n => @colimp sequence_graph A n n.+1 1). (** The uniqueness principle for sequential colimits; Lemma 3.3. *) Definition seq_colimit_uniq {A : Sequence} E (F G : Colimit A -> E) (h : forall n, F o inj A n == G o inj A n) (H : forall n a, ap F (glue A n a) @ h n a = h n.+1 a^+ @ ap G (glue A n a)) : F == G. Proof. srapply (Colimit_ind _ h); intros n m p a; destruct p. generalize (H n a); generalize (h n a); destruct (glue A n a). intros p q; srefine ((concat_p1 _)^ @ _); srefine (_ @ (concat_1p _)); exact q^. Defined. (** The successor sequence from Lemma 3.6. *) Definition succ_seq (A : Sequence) : Sequence := Build_Sequence (fun k => A k.+1) (fun k a => a^+). (** The shifted sequence from Lemma 3.7. *) Definition shift_seq (A : Sequence) n : Sequence := Build_Sequence (fun k => A (k+n)%nat) (fun k a => a^+). (** The canonical equivalence between the colimit of the succesor sequence and the colimit of the original sequence; Lemma 3.6. *) Definition colim_succ_seq_to_colim_seq A : Colimit (succ_seq A) -> Colimit A. Proof. srapply Colimit_rec; srapply Build_Cocone. + exact (fun n a => inj _ n.+1 a). + intros n m p; destruct p; exact (glue A n.+1). Defined. Definition colim_succ_seq_to_colim_seq_beta_glue A n a : ap (colim_succ_seq_to_colim_seq A) (glue (succ_seq A) n a) = glue A (n.+1) a. Proof. srapply Colimit_rec_beta_colimp. Defined. Definition colim_succ_seq_to_colim_seq_ap_inj A n (a1 a2 : succ_seq A n) (p : a1 = a2) : ap (colim_succ_seq_to_colim_seq A) (ap (inj _ n) p) = ap (inj _ n.+1) p. Proof. destruct p; reflexivity. Defined. Global Instance isequiv_colim_succ_seq_to_colim_seq A : IsEquiv (colim_succ_seq_to_colim_seq A). Proof. srapply isequiv_adjointify. + srapply Colimit_rec; srapply Build_Cocone. * exact (fun n a => inj (succ_seq A) n a^+). * intros n m p a; destruct p; exact (glue (succ_seq A) n a^+). + srapply seq_colimit_uniq. * exact (fun n a => glue _ n a). * intros n a; rewrite ap_idmap, ap_compose, Colimit_rec_beta_colimp. rewrite colim_succ_seq_to_colim_seq_beta_glue; reflexivity. + srapply seq_colimit_uniq. * exact (fun n a => glue _ n a). * intros n a; rewrite ap_idmap, ap_compose, Colimit_rec_beta_colimp. rewrite (@Colimit_rec_beta_colimp _ A _ _ _ _ 1); reflexivity. Defined. Definition equiv_colim_succ_seq_to_colim_seq A : Colimit (succ_seq A) <~> Colimit A := Build_Equiv _ _ (colim_succ_seq_to_colim_seq A) _. (** The canonical equivalence between the colimit of the shifted sequence and the colimit of the original sequence; Lemma 3.6. *) Definition colim_shift_seq_to_colim_seq A n : Colimit (shift_seq A n) -> Colimit A. Proof. srapply Colimit_rec; srapply Build_Cocone. + exact (fun k a => inj A (k+n)%nat a). + intros k l p; destruct p; exact (glue A (k+n)%nat). Defined. Definition colim_shift_seq_to_colim_seq_beta_glue A n k a : ap (colim_shift_seq_to_colim_seq A n) (glue (shift_seq A n) k a) = glue A (k+n)%nat a. Proof. srapply Colimit_rec_beta_colimp. Defined. Definition colim_shift_seq_to_colim_seq_ap_inj A n k (a1 a2 : shift_seq A n k) (p : a1 = a2) : ap (colim_shift_seq_to_colim_seq A n) (ap (inj _ k) p) = ap (inj _ (k+n)%nat) p. Proof. destruct p; reflexivity. Defined. Local Definition J {X Y Z} {x1 x2 : X} {y} {I : forall x, Y x -> Z} (p : x2 = x1) : I x2 y = I x1 (coe (ap Y p) y). Proof. destruct p; reflexivity. Defined. Local Definition K {X Y} {x1 x2 : X} {y} F G (p : x1 = x2) : G x2 (coe (ap Y p) y) = coe (ap Y (ap F p)) (G x1 y). Proof. destruct p; reflexivity. Defined. Local Definition L {X Y Z} {x1 x2 : X} {y} {F G} {I : forall x, Y x -> Z} {p : x2 = x1} (Q : forall x y, I (F x) (G x y) = I x y) : Q x2 y @ J p = J (ap F p) @ (ap (I (F x1)) (K F G p)^ @ Q x1 (coe (ap Y p) y)). Proof. destruct p; cbn. apply equiv_p1_1q. symmetry; apply concat_1p. Defined. Global Instance isequiv_colim_shift_seq_to_colim_seq `{Funext} A n : IsEquiv (colim_shift_seq_to_colim_seq A n). Proof. induction n as [ | n e]; srapply isequiv_homotopic'. - srapply equiv_functor_colimit; srapply Build_diagram_equiv. + srapply Build_DiagramMap. * exact (fun k => coe (ap A (nat_add_zero_r k))). * intros k l p a; destruct p. srapply (K S (fun n a => a^+) _). + exact _. - symmetry; srapply seq_colimit_uniq. + intros k a; exact (J (nat_add_zero_r k)). + intros k a; rewrite !Colimit_rec_beta_colimp; srapply (L (glue A)). - transitivity (Colimit (succ_seq (shift_seq A n))). + srapply equiv_functor_colimit; srapply Build_diagram_equiv. * srapply Build_DiagramMap. { exact (fun k => coe (ap A (nat_add_succ_r k n))). } { intros k l p a; destruct p; rapply (K S (fun n a => a^+) (nat_add_succ_r k n)). } * exact _. + srefine (transitivity (equiv_colim_succ_seq_to_colim_seq _) (Build_Equiv _ _ _ e)). - symmetry; srapply seq_colimit_uniq. + intros k a; exact (J (nat_add_succ_r k n)). + intros k a; rewrite Colimit_rec_beta_colimp; simpl. rewrite 2(ap_compose' _ _ (glue _ k a)), Colimit_rec_beta_colimp, 2ap_pp. rewrite colim_succ_seq_to_colim_seq_ap_inj, colim_shift_seq_to_colim_seq_ap_inj. rewrite (colim_succ_seq_to_colim_seq_beta_glue (shift_seq A n)). rewrite colim_shift_seq_to_colim_seq_beta_glue; srapply (L (glue A)). Defined. Definition equiv_colim_shift_seq_to_colim_seq `{Funext} A n : Colimit (shift_seq A n) <~> Colimit A := Build_Equiv _ _ (colim_shift_seq_to_colim_seq A n) _. (** Corollary 7.7.1 for k := -2; implies Lemma 7.2. *) Definition contr_colim_contr_seq `{Funext} (A : Sequence) : (forall k, Contr (A k)) -> Contr (Colimit A). Proof. intro h_seqcontr; pose (unit_seq := Build_Sequence (fun _ => Unit) (fun _ _ => tt)). srapply (contr_equiv' (Colimit unit_seq)). - symmetry; srapply equiv_functor_colimit. srapply Build_diagram_equiv; srapply Build_DiagramMap. * exact (fun _ _ => tt). * intros n m p a; destruct p; reflexivity. - srapply (Build_Contr _ (inj unit_seq 0 tt)); intro y; symmetry; revert y. srapply seq_colimit_uniq. * intros n a; destruct a; induction n as [ | n r]. + reflexivity. + exact (glue unit_seq n tt @ r). * intro n; destruct a; rewrite ap_idmap, ap_const, concat_p1; reflexivity. Defined. (** Fibered sequences; Section 4. *) Record FibSequence (A : Sequence) := { fibSequence : sig A -> Type; fibSequenceArr x : fibSequence x -> fibSequence x^++ }. Coercion fibSequence : FibSequence >-> Funclass. Arguments fibSequence {A}. Arguments fibSequenceArr {A}. Notation "b ^+f" := (fibSequenceArr _ _ b). (** The Sigma of a fibered type sequence; Definition 4.3. *) Definition sig_seq {A} (B : FibSequence A) : Sequence. Proof. srapply Build_Sequence. - exact (fun n => {a : A n & B (n;a)}). - intros n [a b]; exact (a^+; b^+f). Defined. (** The canonical projection from the sequential colimit of Sigmas to the sequential colimit of the first component; Definition 4.3. *) Definition seq_colim_sum_to_seq_colim_fst {A} (B : FibSequence A) : Colimit (sig_seq B) -> Colimit A. Proof. srapply Colimit_rec; srapply Build_Cocone. - intros n [a _]; exact (inj _ n a). - intros n m p [a b]; destruct p; exact (glue _ n a). Defined. (** Given a sequence fibered over A, aach point x : sig A induces a new type sequence; Section 4. *) Definition fib_seq_to_seq {A} (B : FibSequence A) (x : sig A) : Sequence. Proof. srapply Build_Sequence; intro k; revert x; induction k as [ | k h]. * exact (fun x => B x). * exact (fun x => h x^++). * exact (fun x b => b^+f). * exact (fun x => h x^++). Defined. (** The induced sequence can be equivalently described by using shifting; Lemma 7.1. *) Definition fib_seq_to_seq' {A} (B : FibSequence A) (x : sig A) : Sequence := Build_Sequence (fun k => B x^++k) (fun k b => b^+f). Definition equiv_fib_seq_to_seq {A} (B : FibSequence A) (x : sig A) : fib_seq_to_seq B x ~d~ fib_seq_to_seq' B x. Proof. srapply Build_diagram_equiv. + srapply Build_DiagramMap. * intro n; revert x; induction n as [ | n e]. - exact (fun _ => idmap). - exact (fun x => coe (ap B (seq_pair_shift_assoc x n)) o e x^++). * intros n m p; destruct p; revert x; induction n as [ | n p]. - exact (fun _ _ => idpath). - exact (fun x b => K _ _ _ @ (ap _ (p (x^++) b))). + intro n; revert x; induction n as [ | n e]. * exact (fun _ => isequiv_idmap _). * intro x; srapply isequiv_compose. Defined. (** A fibered type sequence defines a type family; Section 4. *) Definition fib_seq_to_type_fam `{Univalence} {A} (B : FibSequence A) : Colimit A -> Type. Proof. srapply Colimit_rec; srapply Build_Cocone. - exact (fun n a => Colimit (fib_seq_to_seq B (n;a))). - intros n m p a; destruct p; apply path_universe_uncurried. exact (equiv_colim_succ_seq_to_colim_seq (fib_seq_to_seq B (n;a))). Defined. Definition fib_seq_to_type_fam_beta_glue `{Univalence} {A} B n a : coe (ap (fib_seq_to_type_fam B) (glue A n a))= colim_succ_seq_to_colim_seq (fib_seq_to_seq B (n;a)). Proof. srapply (ap _ (Colimit_rec_beta_colimp _ _ _ _ _ _) @ _). srapply (transport_idmap_path_universe_uncurried _). Defined. Local Definition Delta {X Y} {x1 x2 : X} {F} (p : x1 = x2) (psi : coe (ap Y p) = F) y : (x1;y) = (x2;F y). Proof. destruct p; destruct psi; reflexivity. Defined. Local Definition Delta_proj {X Y} {x1 x2 : X} {F} (p : x1 = x2) (psi : coe (ap Y p) = F) y : ap pr1 (Delta p psi y) = p. Proof. destruct p; destruct psi; reflexivity. Defined. (** The canonical map from the sequential colimit of Sigmas to the Sigma of sequential colimits; Definition 5.1. *) Definition seq_colim_sum_to_sum_seq_colim `{Univalence} {A} (B : FibSequence A) : Colimit (sig_seq B) -> sig (fib_seq_to_type_fam B). Proof. srapply Colimit_rec; srapply Build_Cocone. - intros n [a b]; exact (inj A n a; inj (fib_seq_to_seq _ _) 0 b). - intros n m p [a b]; destruct p; srefine (_ @ ap _ (glue (fib_seq_to_seq _ _) 0 b)). srapply (Delta _ (fib_seq_to_type_fam_beta_glue B n a)). Defined. Definition seq_colim_sum_to_sum_seq_colim_beta_glue `{Univalence} {A} B n a b : ap (seq_colim_sum_to_sum_seq_colim B) (glue (sig_seq B) n (a;b)) = Delta _ (fib_seq_to_type_fam_beta_glue B n a) (inj _ _ _) @ ap (exist _ (inj A n a)) (glue (fib_seq_to_seq _ _) 0 b). Proof. srapply Colimit_rec_beta_colimp. Defined. (** An alternative induction principle for the sum of colimits; Lemma 5.2 and Section 6. *) Section SeqColimitSumInd. Context `{Univalence} {A} (B : FibSequence A). Context (E : sig (fib_seq_to_type_fam B) -> Type). Context (e : forall n a b, E (seq_colim_sum_to_sum_seq_colim B (inj (sig_seq B) n (a;b)))). Context (t : forall n a b, ap (seq_colim_sum_to_sum_seq_colim B) (glue (sig_seq B) n (a;b)) # e n.+1 (a^+) (b^+f) = e n a b). (** The point-point case of the nested induction; corresponds to "h" in the paper. *) Local Definition Q k : forall n a b, E (inj _ n a; inj _ k b). Proof. induction k as [ | k h]. - exact e. - intros n a b; exact (Delta _ (fib_seq_to_type_fam_beta_glue B n a) _ # h n.+1 (a^+) b). Defined. (** The path-point case of the nested induction is just reflexivity; corresponds to "mu" in the paper. *) Local Definition Eta {X Y Z} {x : X} {y1 y2 : Y x} {z : sig Y} {p : y1 = y2} {q1 : z = (x;y1)} {q2 : z = (x;y2)} (theta : q2 = q1 @ ap _ p) : transport (Z o exist Y x) p o transport Z q1 == transport Z q2. Proof. symmetry in theta; destruct theta; destruct p; simpl; destruct q1. reflexivity. Defined. Local Definition Epsilon {X Y Z} {x1 x2 : X} {y1 y2} {F} (p : x1 = x2) {q : y1 = y2} {psi : coe (ap Y p) = F} {r : F y1 = F y2} (theta : ap F q = r) : transport (Z o exist Y x2) r o transport Z (Delta p psi y1) == transport Z (Delta p psi y2) o transport (Z o exist Y x1) q. Proof. destruct theta; destruct q; reflexivity. Defined. (** The point-path case of the nested induction; corresponds to "H" in the paper. *) Local Definition R k : forall n a b, transport (E o exist _ (inj A n a)) (glue _ k b) (Q k.+1 n a (b^+)) = Q k n a b. Proof. induction k as [ | k h]. - intros n a b; srapply (_ @ t n a b). srapply (Eta (seq_colim_sum_to_sum_seq_colim_beta_glue B n a b)). - intros n a b; srefine (_ @ ap _ (h n.+1 (a^+) b)). srapply (Epsilon (glue A n a) (colim_succ_seq_to_colim_seq_beta_glue _ _ _)). Defined. (** The point case of the nested induction; corresponds to "g" in the paper. *) Local Definition F n a : forall x, E (inj _ n a; x). Proof. srapply Colimit_ind. - exact (fun k => Q k n a). - intros k l p; destruct p; exact (R k n a). Defined. Local Definition F_beta_glue n a b : apD (F n a) (glue _ 0 b) = R 0 n a b. Proof. srapply Colimit_ind_beta_colimp. Defined. Local Definition Phi {X Y Z} {x1 x2 : X} {y1 y2} {F} (p : x1 = x2) {q : y1 = y2} {psi : coe (ap Y p) = F} {G1 : forall y, Z (x1;y)} {G2 : forall y, Z (x2;y)} {r : F y1 = F y2} (theta : ap F q = r) : forall u1 u2, apD G2 r @ u2 = ap (transport _ r) u1 @ Epsilon p theta (G1 y1) @ ap (transport Z (Delta p psi y2)) (apD G1 q) -> transport (fun y => G2 (F y) = Delta p psi y # G1 y) q u1 = u2. Proof. destruct theta; destruct q; intros u1 u2; rewrite ap_idmap, !concat_p1. simpl. intro s; destruct s; srefine (concat_1p _). Defined. (** The path case of the nested induction; corresponds to "omega" in the paper. *) Local Definition G n a : forall y, F n a _ = Delta _ (fib_seq_to_type_fam_beta_glue B n a) y # F n.+1 (a^+) y. Proof. srapply Colimit_ind. - exact (fun k b => idpath). - intros k l p b; destruct p. snrapply (Phi (glue A n a) (colim_succ_seq_to_colim_seq_beta_glue _ _ _)). rewrite (Colimit_ind_beta_colimp _ (fun k => Q k n a) _ _ _ idpath). rewrite (Colimit_ind_beta_colimp _ (fun k => Q k n.+1 a^+) _ _ _ idpath). rewrite concat_p1, concat_1p; reflexivity. Defined. Local Definition I {X Y Z} {x1 x2 : X} {p : x1 = x2} {F} (psi : coe (ap Y p) = F) {G1 G2} : transport (fun x => forall y, Z (x;y)) p G1 = G2 <~> forall y, G2 (F y) = Delta p psi y # G1 y. Proof. destruct p; destruct psi. srefine (transitivity (equiv_path_inverse _ _) (equiv_apD10 _ _ _)). Defined. (** The alternative induction rule in curried form; corresponds to curried "G" in the paper. *) Definition seq_colim_sum_ind_cur : forall x y, E (x;y). Proof. srapply (Colimit_ind _ F); intros n m p a; destruct p. exact ((I (fib_seq_to_type_fam_beta_glue B n a))^-1 (G n a)). Defined. (** The computation rule for the alternative induction rule in curried form. *) Definition seq_colim_sum_ind_cur_beta_glue n a : I (fib_seq_to_type_fam_beta_glue B n a) (apD seq_colim_sum_ind_cur (glue _ n a)) = G n a. Proof. apply moveR_equiv_M; srapply Colimit_ind_beta_colimp. Defined. (** The alternative induction rule; corresponds to "G" in the paper. *) Definition seq_colim_sum_ind : forall x, E x. Proof. intros [x y]; apply seq_colim_sum_ind_cur. Defined. Local Definition Xi {X Y Z} G {x : X} {y1 y2 : Y x} {z : sig Y} {p : y1 = y2} {q1 : z = (x;y1)} {q2 : z = (x;y2)} (theta : q2 = q1 @ ap _ p) : apD (G o exist Y x) p = ap (transport (Z o exist Y x) p) (apD G q1)^ @ Eta theta (G z) @ apD G q2. Proof. revert theta; srapply (equiv_ind (equiv_path_inverse _ _)). intro s; destruct s. revert q1; srapply (equiv_ind (equiv_path_inverse _ _)); intro s; destruct s. destruct p; reflexivity. Defined. Local Definition Mu {X Y Z} {x1 x2 : X} (p : x1 = x2) {F} (G : forall z, Z z) {psi : coe (ap Y p) = F} {q} (theta : I psi (apD (fun x y => G (x;y)) p) = q) y : apD G (Delta p psi y) = (q y)^. Proof. destruct p; destruct psi; destruct theta; reflexivity. Defined. (** The computation rule for the alternative induction rule. *) Definition seq_colim_sum_ind_beta_glue : forall n a b, apD seq_colim_sum_ind (ap (seq_colim_sum_to_sum_seq_colim B) (glue (sig_seq B) n _)) = t n a b. Proof. intros n a b; pose (h := F_beta_glue n a b). rewrite (Xi seq_colim_sum_ind (seq_colim_sum_to_sum_seq_colim_beta_glue B n a b)) in h. rewrite (Mu (glue _ n a) seq_colim_sum_ind (seq_colim_sum_ind_cur_beta_glue n a)) in h. rewrite concat_1p in h; exact (cancelL _ _ _ h). Defined. End SeqColimitSumInd. (** An alternative recursion principle for the sum of colimits; Lemma 5.3. *) Section SeqColimitSumRec. Context `{Univalence} {A} (B : FibSequence A). Context E (e : forall n a, B (n;a) -> E). Context (t : forall n a (b : B (n;a)), e n.+1 (a^+) (b^+f) = e n a b). Definition seq_colim_sum_rec : sig (fib_seq_to_type_fam B)-> E. Proof. exact (seq_colim_sum_ind B _ e (fun n a b => transport_const _ _ @ t n a b)). Defined. Definition seq_colim_sum_rec_beta_glue : forall n a b, ap seq_colim_sum_rec (ap (seq_colim_sum_to_sum_seq_colim B) (glue (sig_seq B) n (a;b))) = t n a b. Proof. intros n a b; srapply (cancelL _ _ _ ((apD_const _ _)^ @ _)). srapply seq_colim_sum_ind_beta_glue. Defined. End SeqColimitSumRec. (** Lemma 5.4. *) Definition seq_colimit_sum_uniq `{Univalence} {A} (B : FibSequence A) E (F G : sig (fib_seq_to_type_fam B) -> E) : F o (seq_colim_sum_to_sum_seq_colim B) == G o (seq_colim_sum_to_sum_seq_colim B) -> F == G. Proof. intro h; srapply (seq_colim_sum_ind B _ (fun _ _ _ => h _)); intros n a b. srapply ((transport_compose _ _ _ _)^ @ _); exact (apD h (glue (sig_seq B) n (a;b))). Defined. (** The canonical map from the sequential colimit of Sigmas to the Sigma of sequential colimits is an equivalence; Theorem 5.1. *) Global Instance isequiv_seq_colim_sum_to_sum_seq_colim `{Univalence} {A} (B : FibSequence A) : IsEquiv (seq_colim_sum_to_sum_seq_colim B). Proof. assert (L : {G : _ & G o seq_colim_sum_to_sum_seq_colim B == idmap}). - srapply (_;_). + srapply seq_colim_sum_rec. * exact (fun n a b => inj (sig_seq B) n (a;b)). * exact (fun n a b => glue (sig_seq B) n (a;b)). + srapply seq_colimit_uniq. * exact (fun n a => idpath). * intros n a; rewrite concat_1p, concat_p1, ap_compose, ap_idmap. rewrite seq_colim_sum_rec_beta_glue; reflexivity. - srapply (isequiv_adjointify _ L.1 _ L.2); srapply seq_colimit_sum_uniq. intro x; rewrite L.2; reflexivity. Defined. Definition equiv_seq_colim_sum_to_sum_seq_colim `{Univalence} {A} (B : FibSequence A) : Colimit (sig_seq B) <~> sig (fib_seq_to_type_fam B) := Build_Equiv _ _ _ (isequiv_seq_colim_sum_to_sum_seq_colim B). (** The canonical map from the sequential colimit of Sigmas to the Sigma of sequential colimits commutes with the first projection; Theorem 5.1. *) Definition seq_colim_sum_to_sum_seq_colim_fst `{Univalence} {A} (B : FibSequence A) : pr1 o (seq_colim_sum_to_sum_seq_colim B) == seq_colim_sum_to_seq_colim_fst B. Proof. srapply seq_colimit_uniq. - exact (fun n a => idpath). - intros n [a b]; rewrite concat_1p, concat_p1, ap_compose, !Colimit_rec_beta_colimp. rewrite ap_pp, (Delta_proj _ (fib_seq_to_type_fam_beta_glue B n a)). srapply (whiskerL _ _ @ concat_p1 _); rewrite (ap_compose _ _ _)^; simpl. rewrite ap_const; reflexivity. Defined. (** The characterization of path spaces in sequential colimits; Theorem 7.4, first part. *) Definition path_seq (A : Sequence) (a1 a2 : A 0) := Build_Sequence (fun k => a1^+k = a2^+k) (fun k p => ap (fun a => a^+) p). Definition equiv_path_colim_zero `{Univalence} {A : Sequence} (a1 a2 : A 0) : (inj A 0 a1 = inj A 0 a2) <~> Colimit (path_seq A a1 a2). Proof. pose (B := Build_FibSequence A (fun x => a1^+(x.1) = x.2) (fun x => ap (fun a => a^+))). transitivity (fib_seq_to_type_fam B (inj A 0 a2)). + symmetry; srapply equiv_path_from_contr. - exact (inj (fib_seq_to_seq B (0;a1)) 0 idpath). - srefine (contr_equiv _ (seq_colim_sum_to_sum_seq_colim B)). srapply contr_colim_contr_seq; intro k; srapply contr_basedpaths. + srapply equiv_functor_colimit; srefine (transitivity (equiv_fib_seq_to_seq B (0;a2)) _). srapply Build_diagram_equiv. * srapply Build_DiagramMap. - exact (fun n => coe (ap B (seq_shift_pair_from_zero a2 n))). - intros n m p b; destruct p; srapply (K _ _ (seq_shift_pair_from_zero a2 n)). * exact _. Defined. (** The characterization of path spaces in sequential colimits; Theorem 7.4, second part. *) Definition equiv_path_colim `{Univalence} {A : Sequence} n (a1 a2 : A n) : (inj A n a1 = inj A n a2) <~> Colimit (path_seq (shift_seq A n) a1 a2). Proof. srefine (transitivity _ (equiv_path_colim_zero _ _)); symmetry. srapply (@equiv_ap _ _ (colim_shift_seq_to_colim_seq A n)). Defined. Open Scope trunc_scope. (** Corollary 7.7.1, second part. *) Global Instance trunc_seq_colim `{Univalence} {A : Sequence} k : (forall n, IsTrunc k (A n)) -> IsTrunc k (Colimit A) | 100. Proof. revert A; induction k as [ | k IHk]. - srapply contr_colim_contr_seq. - intros A trH; apply istrunc_S; srapply Colimit_ind. + intro n; revert trH; revert A; induction n as [ | n IHn]. * intros A trH a; srapply Colimit_ind. { intros m b; revert b; revert a; revert trH; revert A; induction m as [ | m IHm]. { intros A trH a b. srefine (istrunc_equiv_istrunc _ (equiv_inverse (equiv_path_colim _ a b))). } { intros A trH a b. srefine (istrunc_equiv_istrunc _ (equiv_inverse (equiv_concat_l (glue A _ a) _))). srapply (@istrunc_equiv_istrunc _ _ _ k (IHm (succ_seq A) _ (@arr _ A 0%nat _ 1%path a) b)). srapply (equiv_ap (colim_succ_seq_to_colim_seq A)). }} { intros n m p b; snrapply path_ishprop; snrapply ishprop_istrunc; exact _. } * intros A trH a; srapply (functor_forall_equiv_pb (colim_succ_seq_to_colim_seq A)). intro x; srapply (@istrunc_equiv_istrunc _ _ _ k (IHn (succ_seq A) _ a x)); srapply equiv_ap. + intros n m p a; snrapply path_ishprop; snrapply istrunc_forall. intro x; srapply ishprop_istrunc. Defined. Coq-HoTT-9.0/theories/Colimits/SpanPushout.v000066400000000000000000000104321474641544500210230ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Colimits.Pushout. Require Import Types.Paths. (** * Pushouts of "dependent spans". *) Section SpanPushout. Context {X Y : Type} (Q : X -> Y -> Type). Definition SPushout := @Pushout@{up _ _ up} (sig@{up _} (fun (xy : X * Y) => Q (fst xy) (snd xy))) X Y (fst o pr1) (snd o pr1). Definition spushl : X -> SPushout := pushl. Definition spushr : Y -> SPushout := pushr. Definition spglue {x:X} {y:Y} : Q x y -> spushl x = spushr y := fun q => pglue ((x,y) ; q). Definition spushout_rec (R : Type) (spushl' : X -> R) (spushr' : Y -> R) (spglue' : forall x y (q : Q x y), spushl' x = spushr' y) : SPushout -> R. Proof. srapply (@Pushout_rec {xy:X * Y & Q (fst xy) (snd xy)} X Y (fst o pr1) (snd o pr1) R spushl' spushr'). intros [[x y] q]; cbn in *. apply spglue'; assumption. Defined. Definition spushout_rec_beta_spglue (R : Type) (spushl' : X -> R) (spushr' : Y -> R) (spglue' : forall x y (q : Q x y), spushl' x = spushr' y) (x:X) (y:Y) (q:Q x y) : ap (spushout_rec R spushl' spushr' spglue') (spglue q) = spglue' x y q := Pushout_rec_beta_pglue _ _ _ _ ((x, y); q). Definition spushout_ind (R : SPushout -> Type) (spushl' : forall x, R (spushl x)) (spushr' : forall y, R (spushr y)) (spglue' : forall x y (q : Q x y), transport R (spglue q) (spushl' x) = (spushr' y)) : forall p, R p. Proof. srapply (@Pushout_ind {xy:X * Y & Q (fst xy) (snd xy)} X Y (fst o pr1) (snd o pr1) R spushl' spushr'). intros [[x y] q]; cbn in *. apply spglue'; assumption. Defined. Definition spushout_ind_beta_spglue (R : SPushout -> Type) (spushl' : forall x, R (spushl x)) (spushr' : forall y, R (spushr y)) (spglue' : forall x y (q : Q x y), transport R (spglue q) (spushl' x) = (spushr' y)) (x:X) (y:Y) (q:Q x y) : apD (spushout_ind R spushl' spushr' spglue') (spglue q) = spglue' x y q := Pushout_ind_beta_pglue _ _ _ _ ((x,y);q). End SpanPushout. Definition functor_spushout {X Y Z W : Type} {Q : X -> Y -> Type} {Q' : Z -> W -> Type} (f : X -> Z) (g : Y -> W) (h : forall x y, Q x y -> Q' (f x) (g y)) : SPushout Q -> SPushout Q'. Proof. snrapply spushout_rec. - exact (fun x => spushl Q' (f x)). - exact (fun y => spushr Q' (g y)). - intros x y q. apply spglue. exact (h x y q). Defined. Definition functor_spushout_compose {X Y X' Y' X'' Y'' : Type} {Q : X -> Y -> Type} {Q' : X' -> Y' -> Type} {Q'' : X'' -> Y'' -> Type} (f : X -> X') (g : Y -> Y') (f' : X' -> X'') (g' : Y' -> Y'') (h : forall x y, Q x y -> Q' (f x) (g y)) (h' : forall x y, Q' x y -> Q'' (f' x) (g' y)) : functor_spushout f' g' h' o functor_spushout f g h == functor_spushout (f' o f) (g' o g) (fun x y => h' _ _ o h x y). Proof. snrapply spushout_ind. 1,2: reflexivity. intros x y q; cbn beta. snrapply transport_paths_FFlFr'. apply equiv_p1_1q. lhs nrapply ap. 1: nrapply spushout_rec_beta_spglue. lhs nrapply spushout_rec_beta_spglue. symmetry. nrapply (spushout_rec_beta_spglue Q). Defined. Definition functor_spushout_idmap {X Y : Type} {Q : X -> Y -> Type} : functor_spushout idmap idmap (fun x y (q : Q x y) => q) == idmap. Proof. snrapply spushout_ind. 1,2: reflexivity. intros x y q; cbn. snrapply transport_paths_Flr'. apply equiv_p1_1q. nrapply spushout_rec_beta_spglue. Defined. Definition functor_spushout_homotopic {X Y Z W : Type} {Q : X -> Y -> Type} {Q' : Z -> W -> Type} {f g : X -> Z} (h : f == g) {i j : Y -> W} (k : i == j) (l : forall x y, Q x y -> Q' (f x) (i y)) (m : forall x y, Q x y -> Q' (g x) (j y)) (H : forall x y q, spglue Q' (l x y q) @ ap (spushr Q') (k y) = ap (spushl Q') (h x) @ spglue Q' (m x y q)) : functor_spushout f i l == functor_spushout g j m. Proof. snrapply spushout_ind. - intros x; cbn. exact (ap (spushl Q') (h x)). - intros y; cbn. exact (ap (spushr Q') (k y)). - intros x y q. snrapply transport_paths_FlFr'. lhs nrapply whiskerR. 1: apply spushout_rec_beta_spglue. rhs nrapply whiskerL. 2: apply spushout_rec_beta_spglue. apply H. Defined. Coq-HoTT-9.0/theories/Constant.v000066400000000000000000000161411474641544500165430ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Extensions Factorization. Require Import Truncations.Core Modalities.Modality. Local Open Scope path_scope. Local Open Scope trunc_scope. (** * Varieties of constant function *) (** Recall that a function [f : X -> Y] is *weakly constant*, [WeaklyConstant f], if [forall x y, f x = f y]. We show, following Kraus, Escardo, Coquand, and Altenkirch, that the type of fixed points of a weakly constant endofunction is an hprop. However, to avoid potential confusion with [Coq.Init.Wf.Fix], instead of their notation [Fix], we denote this type by [FixedBy]. *) Definition FixedBy {X : Type} (f : X -> X) := {x : X & f x = x}. Global Instance ishprop_fix_wconst {X : Type} (f : X -> X) {wc : WeaklyConstant f} : IsHProp (FixedBy f). Proof. apply hprop_inhabited_contr; intros [x0 p0]. refine (contr_equiv' {x:X & f x0 = x} _); unfold FixedBy. apply equiv_functor_sigma_id. intros x. apply equiv_concat_l. apply wconst. Defined. (** It follows that if a type [X] admits a weakly constant endofunction [f], then [FixedBy f] is equivalent to [merely X]. *) Definition equiv_fix_merely {X : Type} (f : X -> X) {wc : WeaklyConstant f} : FixedBy f <~> merely X. Proof. apply equiv_iff_hprop. - intros [x p]; exact (tr x). - apply Trunc_rec; intros x. exists (f x). apply wconst. Defined. (** Therefore, a type is collapsible (admits a weakly constant endomap) if and only if [merely X -> X] (it has "split support"). *) Definition splitsupp_collapsible {X} `{Collapsible X} : merely X -> X. Proof. refine (_ o (equiv_fix_merely collapse)^-1). apply pr1. Defined. Definition collapsible_splitsupp {X} (s : merely X -> X) : Collapsible X. Proof. refine (Build_Collapsible _ (s o tr) _); intros x y. apply (ap s), path_ishprop. Defined. (** We say that [f] is *conditionally constant* if it factors through the propositional truncation [merely X], and *constant* if it factors through [Unit]. *) Definition ConditionallyConstant {X Y : Type} (f : X -> Y) := ExtensionAlong (@tr (-1) X) (fun _ => Y) f. (** We don't yet have a need for a predicate [Constant] on functions; we do already have the operation [const] which constructs the constant function at a given point. Every such constant function is, of course, conditionally constant. *) Definition cconst_const {X Y} (y : Y) : ConditionallyConstant (@const X Y y). Proof. exists (const y); intros x; reflexivity. Defined. (** The type of conditionally constant functions is equivalent to [merely X -> Y]. *) Definition equiv_cconst_from_merely `{Funext} (X Y : Type) : { f : X -> Y & ConditionallyConstant f } <~> (merely X -> Y). Proof. refine (_ oE (equiv_sigma_symm _)). refine (equiv_sigma_contr _). Defined. (** If a function factors through any hprop, it is conditionally constant. *) Definition cconst_factors_hprop {X Y : Type} (f : X -> Y) (P : Type) `{IsHProp P} (g : X -> P) (h : P -> Y) (p : h o g == f) : ConditionallyConstant f. Proof. pose (g' := Trunc_rec g : merely X -> P). exists (h o g'); intros x. apply p. Defined. (** Thus, if it factors through a type that [X] implies is contractible, then it is also conditionally constant. *) Definition cconst_factors_contr `{Funext} {X Y : Type} (f : X -> Y) (P : Type) {Pc : X -> Contr P} (g : X -> P) (h : P -> Y) (p : h o g == f) : ConditionallyConstant f. Proof. assert (merely X -> IsHProp P). { apply Trunc_rec. (** Uses funext *) intros x; pose (Pc x); apply istrunc_succ. } pose (g' := Trunc_ind (fun _ => P) g : merely X -> P). exists (h o g'); intros x. apply p. Defined. (** Any weakly constant function with collapsible domain is conditionally constant. *) Definition cconst_wconst_collapsible {X Y : Type} `{Collapsible X} (f : X -> Y) {wc : WeaklyConstant f} : ConditionallyConstant f. Proof. exists (f o splitsupp_collapsible); intros x. unfold splitsupp_collapsible; simpl. apply wconst. Defined. (** The image of a weakly constant function with hset codomain is an hprop. In fact, we just need to assume that [merely X -> IsHSet Y]. *) Local Instance hprop_image_wconst_hset_if_merely_domain {X Y : Type} (f : X -> Y) {Ys : merely X -> IsHSet Y} {wc: WeaklyConstant f} : IsHProp (image (-1) f). Proof. apply hprop_allpath. intros [b m] [b' m']. apply path_sigma_hprop; cbn. assert (Ys' : IsHSet Y). { apply Ys. strip_truncations. exact (tr m.1). } strip_truncations. destruct m as [x p], m' as [x' p']. exact (p^ @ wc x x' @ p'). Defined. (** When [merely X -> IsHSet Y], any weakly constant function [X -> Y] is conditionally constant. *) Definition cconst_wconst_hset_if_merely_domain {X Y : Type} (f : X -> Y) {Ys : merely X -> IsHSet Y} {wc: WeaklyConstant f} : ConditionallyConstant f. Proof. srapply (cconst_factors_hprop f (image (-1) f)). - apply factor1. - apply factor2. - apply fact_factors. Defined. (** The previous result will be most often used when we know [Y] is an hset, so we specialize to this case. *) Definition cconst_wconst_hset {X Y : Type} (f : X -> Y) {Ys : IsHSet Y} {wc : WeaklyConstant f} : ConditionallyConstant f := cconst_wconst_hset_if_merely_domain f (Ys:=fun _ => Ys). (** We can decompose this into an "induction principle" and its computation rule. *) Definition merely_rec_hset {X Y : Type} (f : X -> Y) {Ys : IsHSet Y} {wc : WeaklyConstant f} : merely X -> Y := (cconst_wconst_hset f).1. (** The computation rule is [(cconst_wconst_hset f).2 x], but that's reflexivity. *) Definition merely_rec_hset_beta {X Y : Type} (f : X -> Y) {Ys : IsHSet Y} {wc : WeaklyConstant f} (x : X) : merely_rec_hset f (tr x) = f x := idpath. (** If we assume [Funext], then we can weaken the hypothesis from [merely X -> IsHSet Y] to [X -> IsHSet Y], since with [Funext], we know that [IsHSet Y] is an hprop. *) Definition cconst_wconst_hset_if_domain `{Funext} {X Y : Type} (f : X -> Y) {Ys : X -> IsHSet Y} {wc : WeaklyConstant f} : ConditionallyConstant f := cconst_wconst_hset_if_merely_domain f (Ys:=Trunc_rec Ys). (** We record the corresponding induction principle, but not the computation principle, since it is again definitional. *) Definition merely_rec_hset_if_domain `{Funext} {X Y : Type} (f : X -> Y) {Ys : X -> IsHSet Y} {wc : WeaklyConstant f} : merely X -> Y := (cconst_wconst_hset_if_domain f).1. (** The type of weakly constant functions [X -> Y], when [Y] is a set, is equivalent to [merely X -> Y]. This uses [Funext] for the main argument, so we may as well state it with the more general assumption [X -> IsHSet Y]. *) Definition equiv_merely_rec_hset_if_domain `{Funext} (X Y : Type) {Ys : X -> IsHSet Y} : { f : X -> Y & WeaklyConstant f } <~> (merely X -> Y). Proof. pose proof (Ys' := Trunc_rec Ys : merely X -> IsHSet Y). snrapply equiv_adjointify. - intros [f wc]. exact (merely_rec_hset_if_domain f (wc:=wc)). - intro g. exists (g o tr). intros x y; apply (ap g), path_ishprop. - intros g; apply path_arrow; intros mx. pose proof (Ys' mx). strip_truncations; reflexivity. - intros [f wc]. snrapply path_sigma; cbn. + reflexivity. + cbn. funext x y. pose (Ys x); apply path_ishprop. Defined. Coq-HoTT-9.0/theories/Cubical/000077500000000000000000000000001474641544500161225ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Cubical/DPath.v000066400000000000000000000322331474641544500173140ustar00rootroot00000000000000Require Import Basics. Require Import Types.Paths Types.Sigma Types.Forall. Declare Scope dpath_scope. Delimit Scope dpath_scope with dpath. Local Open Scope dpath_scope. Definition DPath {A} (P : A -> Type) {a0 a1} (p : a0 = a1) (b0 : P a0) (b1 : P a1) : Type := transport P p b0 = b1. (** This allows DPaths to collapse to paths under cbn *) Arguments DPath _ / _ _ _ : simpl nomatch. Global Instance istrunc_dp {A : Type} {P : A -> Type} {n : trunc_index} {a0 a1} {p : a0 = a1} {b0 : P a0} {b1 : P a1} `{IsTrunc n.+1 (P a0)} `{IsTrunc n.+1 (P a1)} : IsTrunc n (DPath P p b0 b1) := _. Definition dp_ishprop {A : Type} (P : A -> Type) {a0 a1} {p : a0 = a1} {b0 : P a0} {b1 : P a1} `{IsHProp (P a0)} `{IsHProp (P a1)} : DPath P p b0 b1. Proof. apply path_ishprop. Defined. (** We have reflexivity for DPaths, this helps coq guess later *) Definition dp_id {A} {P : A -> Type} {a : A} {x : P a} : DPath P 1 x x := 1%path. (** Although [1%dpath] is definitionally [1%path], when [1%path] is used where a dependent path is expected, Coq sometimes has trouble interpreting this. So we make a custom notation for [1] in [dpath_scope]. *) Notation "1" := dp_id : dpath_scope. (** DPath induction *) Definition DPath_ind (A : Type) (P : A -> Type) (P0 : forall (a0 a1 : A) (p : a0 = a1) (b0 : P a0) (b1 : P a1), DPath P p b0 b1 -> Type) : (forall (x : A) (y : P x), P0 x x 1%path y y 1) -> forall (a0 a1 : A) (p : a0 = a1) (b0 : P a0) (b1 : P a1) (d : DPath P p b0 b1), P0 a0 a1 p b0 b1 d. Proof. intros X a0 a1 [] b0 b1 []; apply X. Defined. (** A DPath over a constant family is just a path *) Definition equiv_dp_const {A C} {a0 a1 : A} {p : a0 = a1} {x y} : (x = y) <~> DPath (fun _ => C) p x y. Proof. by destruct p. Defined. Notation dp_const := equiv_dp_const. (** dp_apD of a non-dependent map is just a constant DPath *) Definition dp_apD_const {A B} (f : A -> B) {a0 a1 : A} (p : a0 = a1) : apD f p = dp_const (ap f p). Proof. by destruct p. Defined. (** An alternate version useful for proving recursion computation rules from induction ones *) Definition dp_apD_const' {A B : Type} {f : A -> B} {a0 a1 : A} {p : a0 = a1} : dp_const^-1 (apD f p) = ap f p. Proof. apply moveR_equiv_V. apply dp_apD_const. Defined. (** Concatenation of dependent paths *) Definition dp_concat {A} {P : A -> Type} {a0 a1 a2} {p : a0 = a1} {q : a1 = a2} {b0 : P a0} {b1 : P a1} {b2 : P a2} : DPath P p b0 b1 -> DPath P q b1 b2 -> DPath P (p @ q) b0 b2. Proof. destruct p, q. exact concat. Defined. Notation "x '@Dp' y" := (dp_concat x y) : dpath_scope. (** Concatenation of dependent paths with non-dependent paths *) Definition dp_concat_r {A} {P : A -> Type} {a0 a1} {p : a0 = a1} {b0 : P a0} {b1 b2 : P a1} : DPath P p b0 b1 -> (b1 = b2) -> DPath P p b0 b2. Proof. destruct p; exact concat. Defined. Notation "x '@Dr' y" := (dp_concat_r x y) : dpath_scope. Definition dp_concat_l {A} {P : A -> Type} {a1 a2} {q : a1 = a2} {b0 b1 : P a1} {b2 : P a2} : (b0 = b1) -> DPath P q b1 b2 -> DPath P q b0 b2. Proof. destruct q; exact concat. Defined. Notation "x '@Dl' y" := (dp_concat_l x y) : dpath_scope. (** Inverse of dependent paths *) Definition dp_inverse {A} {P : A -> Type} {a0 a1} {p : a0 = a1} {b0 : P a0} {b1 : P a1} : DPath P p b0 b1 -> DPath P p^ b1 b0. Proof. destruct p. exact inverse. Defined. Notation "x '^D'" := (dp_inverse x) : dpath_scope. (** dp_apD distributes over concatenation *) Definition dp_apD_pp (A : Type) (P : A -> Type) (f : forall a, P a) {a0 a1 a2 : A} (p : a0 = a1) (q : a1 = a2) : apD f (p @ q) = (apD f p) @Dp (apD f q). Proof. by destruct p, q. Defined. (** dp_apD respects inverses *) Definition dp_apD_V (A : Type) (P : A -> Type) (f : forall a, P a) {a0 a1 : A} (p : a0 = a1) : apD f p^ = (apD f p)^D. Proof. by destruct p. Defined. (** [dp_const] preserves concatenation *) Definition dp_const_pp {A B : Type} {a0 a1 a2 : A} {p : a0 = a1} {q : a1 = a2} {x y z : B} (r : x = y) (s : y = z) : dp_const (p:=p @ q) (r @ s) = (dp_const (p:=p) r) @Dp (dp_const (p:=q) s). Proof. by destruct p,q. Defined. (** [dp_const] preserves inverses *) Definition dp_const_V {A B : Type} {a0 a1 : A} {p : a0 = a1} {x y : B} (r : x = y) : dp_const r^ = (dp_const (p:=p) r)^D. Proof. by destruct p. Defined. (** Horizontal composition and whiskering of dependent paths *) Definition dp_concat2 {A} {P : A -> Type} {a0 a1 a2} {p : a0 = a1} {q : a1 = a2} {b0 : P a0} {b1 : P a1} {b2 : P a2} {r r' : DPath P p b0 b1} {s s' : DPath P q b1 b2} (h : r = r') (k : s = s') : r @Dp s = r' @Dp s'. Proof. by destruct h, k. Defined. Definition dp_whiskerL {A: Type} {P : A -> Type} {a0 a1 a2 : A} {p : a0 = a1} {q : a1 = a2} {b0 : P a0} {b1 : P a1} {b2 : P a2} (r : DPath P p b0 b1) {s s' : DPath P q b1 b2} (h : s = s') : r @Dp s = r @Dp s' := dp_concat2 1 h. Definition dp_whiskerR {A: Type} {P : A -> Type} {a0 a1 a2 : A} {p : a0 = a1} {q : a1 = a2} {b0 : P a0} {b1 : P a1} {b2 : P a2} {r r' : DPath P p b0 b1} (s : DPath P q b1 b2) (h : r = r') : r @Dp s = r' @Dp s := dp_concat2 h 1. Section DGroupoid. Context {A} {P : A -> Type} {a0 a1} {p : a0 = a1} {b0 : P a0} {b1 : P a1} {dp : DPath P p b0 b1}. Definition dp_concat_p1 : DPath (fun t : a0 = a1 => DPath P t b0 b1) (concat_p1 p) (dp @Dp 1) dp. Proof. destruct p. apply concat_p1. Defined. Definition dp_concat_1p : DPath (fun t : a0 = a1 => DPath P t b0 b1) (concat_1p p) (1 @Dp dp) dp. Proof. destruct p. apply concat_1p. Defined. Definition dp_concat_Vp : DPath (fun t : a1 = a1 => DPath P t b1 b1) (concat_Vp p) (dp^D @Dp dp) 1. Proof. destruct p. apply concat_Vp. Defined. Definition dp_concat_pV : DPath (fun t : a0 = a0 => DPath P t b0 b0) (concat_pV p) (dp @Dp dp^D) 1. Proof. destruct p. apply concat_pV. Defined. Section Concat. Context {a2 a3} {q : a1 = a2} {r : a2 = a3} {b2 : P a2} {b3 : P a3} (dq : DPath P q b1 b2) (dr : DPath P r b2 b3). Definition dp_concat_pp_p : DPath (fun t : a0 = a3 => DPath P t b0 b3) (concat_pp_p p q r) ((dp @Dp dq) @Dp dr) (dp @Dp (dq @Dp dr)). Proof. destruct p, q, r. apply concat_pp_p. Defined. Definition dp_concat_p_pp : DPath (fun t : a0 = a3 => DPath P t b0 b3) (concat_p_pp p q r) (dp @Dp (dq @Dp dr)) ((dp @Dp dq) @Dp dr). Proof. destruct p, q, r. apply concat_p_pp. Defined. End Concat. End DGroupoid. (** Dependent paths over paths *) (** These can be found under names such as dp_paths_l akin to transport_paths_l *) Definition equiv_dp_paths_l {A : Type} {x1 x2 y : A} (p : x1 = x2) (q : x1 = y) r : p^ @ q = r <~> DPath (fun x => x = y) p q r. Proof. apply equiv_concat_l, transport_paths_l. Defined. Notation dp_paths_l := equiv_dp_paths_l. Definition equiv_dp_paths_r {A : Type} {x y1 y2 : A} (p : y1 = y2) (q : x = y1) r : q @ p = r <~> DPath (fun y => x = y) p q r. Proof. apply equiv_concat_l, transport_paths_r. Defined. Notation dp_paths_r := equiv_dp_paths_r. Definition equiv_dp_paths_lr {A : Type} {x1 x2 : A} (p : x1 = x2) (q : x1 = x1) r : (p^ @ q) @ p = r <~> DPath (fun x : A => x = x) p q r. Proof. apply equiv_concat_l, transport_paths_lr. Defined. Notation dp_paths_lr := equiv_dp_paths_lr. Definition equiv_dp_paths_Fl {A B} {f : A -> B} {x1 x2 : A} {y : B} (p : x1 = x2) (q : f x1 = y) r : (ap f p)^ @ q = r <~> DPath (fun x => f x = y) p q r. Proof. apply equiv_concat_l, transport_paths_Fl. Defined. Notation dp_paths_Fl := equiv_dp_paths_Fl. Definition equiv_dp_paths_Fr {A B} {g : A -> B} {y1 y2 : A} {x : B} (p : y1 = y2) (q : x = g y1) r : q @ ap g p = r <~> DPath (fun y : A => x = g y) p q r. Proof. apply equiv_concat_l, transport_paths_Fr. Defined. Notation dp_paths_Fr := equiv_dp_paths_Fr. Definition equiv_dp_paths_FFlr {A B} {f : A -> B} {g : B -> A} {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = x1) r : ((ap g (ap f p))^ @ q) @ p = r <~> DPath (fun x : A => g (f x) = x) p q r. Proof. apply equiv_concat_l, transport_paths_FFlr. Defined. Notation dp_paths_FFlr := equiv_dp_paths_FFlr. Definition equiv_dp_paths_FlFr {A B} {f g : A -> B} {x1 x2 : A} (p : x1 = x2) (q : f x1 = g x1) r : ((ap f p)^ @ q) @ ap g p = r <~> DPath (fun x : A => f x = g x) p q r. Proof. apply equiv_concat_l, transport_paths_FlFr. Defined. Notation dp_paths_FlFr := equiv_dp_paths_FlFr. Definition equiv_dp_paths_lFFr {A B} {f : A -> B} {g : B -> A} {x1 x2 : A} (p : x1 = x2) (q : x1 = g (f x1)) r : (p^ @ q) @ ap g (ap f p) = r <~> DPath (fun x : A => x = g (f x)) p q r. Proof. apply equiv_concat_l, transport_paths_lFFr. Defined. Notation dp_paths_lFFr := equiv_dp_paths_lFFr. Definition equiv_dp_paths_FlFr_D {A B} (f g : forall a : A, B a) {x1 x2 : A} (p : x1 = x2) (q : f x1 = g x1) (r : f x2 = g x2) : ((apD f p)^ @ ap (transport B p) q) @ apD g p = r <~> DPath (fun x : A => f x = g x) p q r. Proof. apply equiv_concat_l, transport_paths_FlFr_D. Defined. Notation dp_paths_FlFr_D := equiv_dp_paths_FlFr_D. Definition equiv_dp_compose' {A B} (f : A -> B) (P : B -> Type) {x y : A} {p : x = y} {q : f x = f y} (r : ap f p = q) {u : P (f x)} {v : P (f y)} : DPath (fun x => P (f x)) p u v <~> DPath P q u v. Proof. by destruct r, p. Defined. Notation dp_compose' := equiv_dp_compose'. Definition equiv_dp_compose {A B} (f : A -> B) (P : B -> Type) {x y : A} (p : x = y) {u : P (f x)} {v : P (f y)} : DPath (fun x => P (f x)) p u v <~> DPath P (ap f p) u v := dp_compose' f P (idpath (ap f p)). Notation dp_compose := equiv_dp_compose. Definition dp_apD_compose' {A B : Type} (f : A -> B) (P : B -> Type) {x y : A} {p : x = y} {q : f x = f y} (r : ap f p = q) (g : forall b:B, P b) : apD (g o f) p = (dp_compose' f P r)^-1 (apD g q). Proof. by destruct r, p. Defined. Definition dp_apD_compose {A B : Type} (f : A -> B) (P : B -> Type) {x y : A} (p : x = y) (g : forall b:B, P b) : apD (g o f) p = (dp_compose f P p)^-1 (apD g (ap f p)) := dp_apD_compose' f P (idpath (ap f p)) g. Definition dp_apD_compose_inv' {A B : Type} (f : A -> B) (P : B -> Type) {x y : A} {p : x = y} {q : f x = f y} (r : ap f p = q) (g : forall b:B, P b) : apD g q = (dp_compose' f P r) (apD (g o f) p). Proof. by destruct r, p. Defined. Definition dp_apD_compose_inv {A B : Type} (f : A -> B) (P : B -> Type) {x y : A} {p : x = y} (g : forall b:B, P b) : apD g (ap f p) = (dp_compose f P p) (apD (g o f) p) := dp_apD_compose_inv' f P (idpath (ap f p)) g. (** Type constructors *) (** Many of these lemmas exist already for transports but we prove them for DPaths anyway. If we change the definition of DPath to the transport, then these will no longer be needed. It is however, far more readable to keep such lemmas seperate, since it is difficult to otherwise search for a DPath lemma if they are all written using transports. *) (** A version of [equiv_path_sigma] for [DPath]s *) Definition equiv_path_sigma_dp {A P} {x x' : A} {y : P x} {y' : P x'} : {p : x = x' & DPath P p y y'} <~> (x; y) = (x'; y') := equiv_path_sigma P (x; y) (x'; y'). Notation path_sigma_dp := equiv_path_sigma_dp. Definition ap_pr1_path_sigma_dp {A : Type} {P : A -> Type} {x x' : A} {y : P x} {y' : P x'} (p : x = x') (q : DPath P p y y') : ap pr1 (path_sigma_dp (p; q)) = p. Proof. apply ap_pr1_path_sigma. Defined. (* DPath over a forall *) Definition equiv_dp_forall `{Funext} {A : Type} {B : A -> Type} {C : sig B -> Type} {a1 a2 : A} {p : a1 = a2} {f : forall x, C (a1; x)} {g : forall x, C (a2; x)} : (forall (x : B a1) (y : B a2) (q : DPath B p x y), DPath C (path_sigma_dp (p; q)) (f x) (g y)) <~> DPath (fun a => forall x, C (a; x)) p f g. Proof. symmetry. destruct p; cbn. refine (equiv_compose' _ (equiv_apD10 _ _ _)). apply equiv_functor_forall_id. intro a. srapply equiv_adjointify. + by intros ? ? []. + intro F; exact (F a 1). + repeat (intro; apply path_forall). by intros []. + by intro. Defined. Notation dp_forall := equiv_dp_forall. (* DPath over an arrow *) Definition equiv_dp_arrow `{Funext} {A : Type} {B C : A -> Type} {a1 a2 : A} {p : a1 = a2} {f : B a1 -> C a1} {g : B a2 -> C a2} : (forall x, DPath C p (f x) (g (p # x))) <~> DPath (fun x => B x -> C x) p f g. Proof. destruct p. apply equiv_path_forall. Defined. Notation dp_arrow := equiv_dp_arrow. (* Restricted version allowing us to pull the domain of a forall out *) Definition equiv_dp_forall_domain `{Funext} {D : Type} {A : Type} {B : D -> A -> Type} {t1 t2 : D} {d : t1 = t2} {f : forall x, B t1 x} {g : forall x, B t2 x} : (forall x, DPath (fun t => B t x) d (f x) (g x)) <~> DPath (fun t => forall x, B t x) d f g. Proof. destruct d. apply equiv_path_forall. Defined. Notation dp_forall_domain := equiv_dp_forall_domain. Definition equiv_dp_sigma {A : Type} {B : A -> Type} {C : sig B -> Type} {x1 x2 : A} {p : x1 = x2} (y1 : { y : B x1 & C (x1; y) }) (y2 : { y : B x2 & C (x2; y) }) : {n : DPath B p y1.1 y2.1 & DPath C (path_sigma_dp (p; n)) y1.2 y2.2} <~> DPath (fun x => { y : B x & C (x; y) }) p y1 y2. Proof. destruct p. refine (path_sigma_dp oE _). apply equiv_functor_sigma_id. cbn; intro q. destruct y1 as [y11 y12], y2 as [y21 y22]. cbn in *. by destruct q. Defined. Notation dp_sigma := equiv_dp_sigma. Coq-HoTT-9.0/theories/Cubical/DPathCube.v000066400000000000000000000220741474641544500201150ustar00rootroot00000000000000Require Import Basics. Require Import Cubical.DPath. Require Import Cubical.PathSquare. Require Import Cubical.DPathSquare. Require Import Cubical.PathCube. Declare Scope dcube_scope. Delimit Scope dcube_scope with dcube. (* In this file we define a dependent cube *) (* Dependent cubes *) Definition DPathCube {A} (B : A -> Type) {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} (cube : PathCube s0ii s1ii sii0 sii1 si0i si1i) {b000 : B x000} {b010 : B x010} {b100 : B x100} {b110 : B x110} {b001 : B x001} {b011 : B x011} {b101 : B x101} {b111 : B x111 } {bp0i0 : DPath B p0i0 b000 b010} {bp1i0 : DPath B p1i0 b100 b110} {bpi00 : DPath B pi00 b000 b100} {bpi10 : DPath B pi10 b010 b110} {bp0i1 : DPath B p0i1 b001 b011} {bp1i1 : DPath B p1i1 b101 b111} {bpi01 : DPath B pi01 b001 b101} {bpi11 : DPath B pi11 b011 b111} {bp00i : DPath B p00i b000 b001} {bp01i : DPath B p01i b010 b011} {bp10i : DPath B p10i b100 b101} {bp11i : DPath B p11i b110 b111} (bs0ii : DPathSquare B s0ii bp0i0 bp0i1 bp00i bp01i) (bs1ii : DPathSquare B s1ii bp1i0 bp1i1 bp10i bp11i) (bsii0 : DPathSquare B sii0 bp0i0 bp1i0 bpi00 bpi10) (bsii1 : DPathSquare B sii1 bp0i1 bp1i1 bpi01 bpi11) (bsi0i : DPathSquare B si0i bp00i bp10i bpi00 bpi01) (bsi1i : DPathSquare B si1i bp01i bp11i bpi10 bpi11) : Type. Proof. destruct cube. exact (PathCube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i). Defined. Definition equiv_dc_const' {A B : Type} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} {cube : PathCube s0ii s1ii sii0 sii1 si0i si1i} {b000 b010 b100 b110 b001 b011 b101 b111 : B} {bp0i0 : DPath (fun _ => B) p0i0 b000 b010} {bp1i0 : DPath (fun _ => B) p1i0 b100 b110} {bpi00 : DPath (fun _ => B) pi00 b000 b100} {bpi10 : DPath (fun _ => B) pi10 b010 b110} {bp0i1 : DPath (fun _ => B) p0i1 b001 b011} {bp1i1 : DPath (fun _ => B) p1i1 b101 b111} {bpi01 : DPath (fun _ => B) pi01 b001 b101} {bpi11 : DPath (fun _ => B) pi11 b011 b111} {bp00i : DPath (fun _ => B) p00i b000 b001} {bp01i : DPath (fun _ => B) p01i b010 b011} {bp10i : DPath (fun _ => B) p10i b100 b101} {bp11i : DPath (fun _ => B) p11i b110 b111} {bs0ii : DPathSquare (fun _ => B) s0ii bp0i0 bp0i1 bp00i bp01i} {bs1ii : DPathSquare (fun _ => B) s1ii bp1i0 bp1i1 bp10i bp11i} {bsii0 : DPathSquare (fun _ => B) sii0 bp0i0 bp1i0 bpi00 bpi10} {bsii1 : DPathSquare (fun _ => B) sii1 bp0i1 bp1i1 bpi01 bpi11} {bsi0i : DPathSquare (fun _ => B) si0i bp00i bp10i bpi00 bpi01} {bsi1i : DPathSquare (fun _ => B) si1i bp01i bp11i bpi10 bpi11} : PathCube (ds_const'^-1 bs0ii) (ds_const'^-1 bs1ii) (ds_const'^-1 bsii0) (ds_const'^-1 bsii1) (ds_const'^-1 bsi0i) (ds_const'^-1 bsi1i) <~> DPathCube (fun _ => B) cube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i. Proof. by destruct cube. Defined. Notation dc_const' := equiv_dc_const'. Definition equiv_dc_const {A B : Type} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} {cube : PathCube s0ii s1ii sii0 sii1 si0i si1i} {b000 b010 b100 b110 b001 b011 b101 b111 : B} {bp0i0 : b000 = b010} {bp1i0 : b100 = b110} {bpi00 : b000 = b100} {bpi10 : b010 = b110} {bp0i1 : b001 = b011} {bp1i1 : b101 = b111} {bpi01 : b001 = b101} {bpi11 : b011 = b111} {bp00i : b000 = b001} {bp01i : b010 = b011} {bp10i : b100 = b101} {bp11i : b110 = b111} {bs0ii : PathSquare bp0i0 bp0i1 bp00i bp01i} {bs1ii : PathSquare bp1i0 bp1i1 bp10i bp11i} {bsii0 : PathSquare bp0i0 bp1i0 bpi00 bpi10} {bsii1 : PathSquare bp0i1 bp1i1 bpi01 bpi11} {bsi0i : PathSquare bp00i bp10i bpi00 bpi01} {bsi1i : PathSquare bp01i bp11i bpi10 bpi11} : PathCube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i <~> DPathCube (fun _ => B) cube (ds_const bs0ii) (ds_const bs1ii) (ds_const bsii0) (ds_const bsii1) (ds_const bsi0i) (ds_const bsi1i). Proof. by destruct cube. Defined. Notation dc_const := equiv_dc_const. (** Dependent Kan fillers *) Section Kan. Context {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} (c : PathCube s0ii s1ii sii0 sii1 si0i si1i) {P : A -> Type} {y000 y010 y100 y110 y001 y011 y101 y111} {q0i0 : DPath P p0i0 y000 y010} {q1i0 : DPath P p1i0 y100 y110} {qi00 : DPath P pi00 y000 y100} {qi10 : DPath P pi10 y010 y110} {q0i1 : DPath P p0i1 y001 y011} {q1i1 : DPath P p1i1 y101 y111} {qi01 : DPath P pi01 y001 y101} {qi11 : DPath P pi11 y011 y111} {q00i : DPath P p00i y000 y001} {q01i : DPath P p01i y010 y011} {q10i : DPath P p10i y100 y101} {q11i : DPath P p11i y110 y111}. Definition dc_fill_left (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i) (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11) (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11) : {t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}. Proof. destruct c. apply cu_fill_left. Defined. Definition dc_fill_right (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11) (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11) : {t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}. Proof. destruct c. apply cu_fill_right. Defined. Definition dc_fill_top (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11) (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11) : {tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}. Proof. destruct c. apply cu_fill_top. Defined. Definition dc_fill_bottom (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i) (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11) : {tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}. Proof. destruct c. apply cu_fill_bottom. Defined. Definition dc_fill_front (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i) (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11) : {ti0i : DPathSquare P si0i q00i q10i qi00 qi01 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}. Proof. destruct c. apply cu_fill_front. Defined. Definition dc_fill_back (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i) (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11) (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) : {ti1i : DPathSquare P si1i q01i q11i qi10 qi11 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}. Proof. destruct c. apply cu_fill_back. Defined. End Kan. Coq-HoTT-9.0/theories/Cubical/DPathSquare.v000066400000000000000000000173211474641544500204760ustar00rootroot00000000000000Require Import Basics. Require Import Types.Paths. Require Import Cubical.DPath. Require Import Cubical.PathSquare. Declare Scope dsquare_scope. Delimit Scope dsquare_scope with dsquare. Local Open Scope dpath_scope. (* Dependent squares *) Definition DPathSquare {A} (P : A -> Type) {a00 a10 a01 a11} {px0 : a00 = a10} {px1 : a01 = a11} {p0x p1x} (s : PathSquare px0 px1 p0x p1x) {b00 b10 b01 b11} (qx0 : DPath P px0 b00 b10) (qx1 : DPath P px1 b01 b11) (q0x : DPath P p0x b00 b01) (q1x : DPath P p1x b10 b11) : Type. Proof. destruct s. exact (PathSquare qx0 qx1 q0x q1x). Defined. Definition ds_id {A} {P : A -> Type} {a00 b00} : DPathSquare P sq_id 1 1 1 1 (a00:=a00) (b00:=b00). Proof. apply sq_id. Defined. Notation "1" := ds_id : dsquare_scope. Section DPathSquareConstructors. (* Different ways of constructing dependent squares *) Context {A} {a0 a1 : A} {p : a0 = a1} {P : A -> Type} {b0 b1} (dp : DPath P p b0 b1). Definition ds_refl_h : DPathSquare P (sq_refl_h _) dp dp 1 1. Proof. destruct p. apply sq_refl_h. Defined. Definition ds_refl_v : DPathSquare P (sq_refl_v _) 1 1 dp dp. Proof. destruct p. apply sq_refl_v. Defined. End DPathSquareConstructors. (* DPathSquares can be given by 2-dimensional DPaths *) Definition equiv_ds_dpath {A} (P : A -> Type) {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} (s : px0 @ p1x = p0x @ px1) {b00 b10 b01 b11} {qx0 : DPath P px0 b00 b10} {qx1 : DPath P px1 b01 b11} {q0x : DPath P p0x b00 b01} {q1x : DPath P p1x b10 b11} : DPath (fun p => DPath P p b00 b11) s (qx0 @Dp q1x) (q0x @Dp qx1) <~> DPathSquare P (sq_path s) qx0 qx1 q0x q1x. Proof. set (s' := sq_path s). rewrite <- (eissect sq_path s : sq_path^-1 s' = s). clearbody s'; clear s. destruct s'; cbn. apply sq_path. Defined. Notation ds_dpath := equiv_ds_dpath. (* We have an apD for DPathSquares *) Definition ds_apD {A} {B : A -> Type} (f : forall a, B a) {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x p1x} (s : PathSquare px0 px1 p0x p1x) : DPathSquare B s (apD f px0) (apD f px1) (apD f p0x) (apD f p1x). Proof. by destruct s. Defined. (* A DPathSquare over a constant family is given by just a square *) Definition ds_const {A P : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {s : PathSquare px0 px1 p0x p1x} {b00 b10 b01 b11 : P} {qx0 : b00 = b10} {qx1 : b01 = b11} {q0x : b00 = b01} {q1x : b10 = b11} : PathSquare qx0 qx1 q0x q1x <~> DPathSquare (fun _ => P) s (dp_const qx0) (dp_const qx1) (dp_const q0x) (dp_const q1x). Proof. by destruct s. Defined. (* Sometimes we want the DPathSquare to be typed differently *) (* This could be achieved with some clever rewriting of squares and DPathSquares *) (* It seems that writing it like this might get in the way, Cube.v has some examples of this. *) Definition equiv_ds_const' {A P : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {s : PathSquare px0 px1 p0x p1x} {b00 b10 b01 b11 : P} {qx0 : DPath (fun _ => P) px0 b00 b10} {qx1 : DPath (fun _ => P) px1 b01 b11} {q0x : DPath (fun _ => P) p0x b00 b01} {q1x : DPath (fun _ => P) p1x b10 b11} : PathSquare (dp_const^-1 qx0) (dp_const^-1 qx1) (dp_const^-1 q0x) (dp_const^-1 q1x) <~> DPathSquare (fun _ => P) s qx0 qx1 q0x q1x. Proof. by destruct s. Defined. Notation ds_const' := equiv_ds_const'. (* dp_apD fits into a natural square *) Definition dp_apD_nat {A} {P : A -> Type} {f g : forall x, P x} {x y : A} (q : f == g) (p : x = y) : DPathSquare P (sq_refl_h _) (apD f p) (apD g p) (q x) (q y). Proof. destruct p. by apply sq_1G. Defined. Definition equiv_ds_G1 {A} (P : A -> Type) {a00 a10 } {px0 px1 : a00 = a10} {p : px0 = px1} {b00 b10} (qx0 : DPath P px0 b00 b10) (qx1 : DPath P px1 b00 b10) : DPath (fun x => DPath P x b00 b10) p qx0 qx1 <~> DPathSquare P (sq_G1 p) qx0 qx1 1 1. Proof. destruct p, px0. apply sq_G1. Defined. Notation ds_G1 := equiv_ds_G1. (** A DPath in a path-type is naturally a DPathSquare. *) Definition equiv_ds_dp {A : Type} {B : A -> Type} (f g : forall a : A, B a) {x1 x2 : A} (p : x1 = x2) (q1 : f x1 = g x1) (q2 : f x2 = g x2) : DPath (fun x : A => f x = g x) p q1 q2 <~> DPathSquare B (sq_refl_h p) (apD f p) (apD g p) q1 q2. Proof. destruct p. exact sq_1G. Defined. Notation ds_dp := equiv_ds_dp. (** Dependent Kan operations *) Section Kan. Context {A : Type} {P : A -> Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x p1x} (s : PathSquare px0 px1 p0x p1x) {b00 : P a00} {b10 : P a10} {b01 : P a01} {b11 : P a11}. Definition ds_fill_l (qx1 : DPath P px1 b01 b11) (q0x : DPath P p0x b00 b01) (q1x : DPath P p1x b10 b11) : {qx0 : DPath P px0 b00 b10 & DPathSquare P s qx0 qx1 q0x q1x}. Proof. destruct s; apply sq_fill_l. Defined. Definition ds_fill_l_uniq {qx1 : DPath P px1 b01 b11} {q0x : DPath P p0x b00 b01} {q1x : DPath P p1x b10 b11} {qx0 : DPath P px0 b00 b10} (t : DPathSquare P s qx0 qx1 q0x q1x) {qx0' : DPath P px0 b00 b10} (t' : DPathSquare P s qx0' qx1 q0x q1x) : qx0 = qx0'. Proof. destruct s. exact (sq_fill_l_uniq t t'). Defined. Definition ds_fill_r (qx0 : DPath P px0 b00 b10) (q0x : DPath P p0x b00 b01) (q1x : DPath P p1x b10 b11) : {qx1 : DPath P px1 b01 b11 & DPathSquare P s qx0 qx1 q0x q1x}. Proof. destruct s; apply sq_fill_r. Defined. Definition ds_fill_r_uniq {qx0 : DPath P px0 b00 b10} {q0x : DPath P p0x b00 b01} {q1x : DPath P p1x b10 b11} {qx1 : DPath P px1 b01 b11} (t : DPathSquare P s qx0 qx1 q0x q1x) {qx1' : DPath P px1 b01 b11} (t' : DPathSquare P s qx0 qx1' q0x q1x) : qx1 = qx1'. Proof. destruct s. exact (sq_fill_r_uniq t t'). Defined. Definition equiv_ds_fill_lr {q0x : DPath P p0x b00 b01} {q1x : DPath P p1x b10 b11} : (DPath P px0 b00 b10) <~> (DPath P px1 b01 b11). Proof. srapply equiv_adjointify. - intros qx0; exact (ds_fill_r qx0 q0x q1x).1. - intros qx1; exact (ds_fill_l qx1 q0x q1x).1. - intros qx1. exact (ds_fill_r_uniq (ds_fill_r _ q0x q1x).2 (ds_fill_l qx1 q0x q1x).2). - intros qx0. exact (ds_fill_l_uniq (ds_fill_l _ q0x q1x).2 (ds_fill_r qx0 q0x q1x).2). Defined. Definition ds_fill_t (qx0 : DPath P px0 b00 b10) (qx1 : DPath P px1 b01 b11) (q1x : DPath P p1x b10 b11) : {q0x : DPath P p0x b00 b01 & DPathSquare P s qx0 qx1 q0x q1x}. Proof. destruct s; apply sq_fill_t. Defined. Definition ds_fill_b (qx0 : DPath P px0 b00 b10) (qx1 : DPath P px1 b01 b11) (q0x : DPath P p0x b00 b01) : {q1x : DPath P p1x b10 b11 & DPathSquare P s qx0 qx1 q0x q1x}. Proof. destruct s; apply sq_fill_b. Defined. End Kan. (** Another equivalent formulation of a dependent square over reflexivity *) Definition equiv_ds_transport_dpath {A} {a0 a1 : A} {p : a0 = a1} {P : A -> Type} {b00 b10 b01 b11} (qx0 : DPath P p b00 b10) (qx1 : DPath P p b01 b11) (q0x : b00 = b01) (q1x : b10 = b11) : DPathSquare P (sq_refl_h p) qx0 qx1 q0x q1x <~> transport (fun y => DPath P p y b11) q0x (transport (fun y => DPath P p b00 y) q1x qx0) = qx1. Proof. destruct p; cbn. refine (_ oE sq_path^-1). refine (equiv_concat_l _ _ oE _). { apply transport_paths_l. } refine (equiv_moveR_Vp _ _ _ oE _). refine (equiv_concat_l _ _). apply transport_paths_r. Defined. Notation ds_transport_dpath := equiv_ds_transport_dpath. Coq-HoTT-9.0/theories/Cubical/PathCube.v000066400000000000000000000572621474641544500200200ustar00rootroot00000000000000Require Import Basics. Require Import Cubical.DPath. Require Import Cubical.PathSquare. Require Import Cubical.DPathSquare. Require Import Types.Paths Types.Prod. Declare Scope cube_scope. Delimit Scope cube_scope with cube. Local Unset Elimination Schemes. Generalizable All Variables. Local Open Scope square_scope. (* x001----pi01----x101 x001----pi01----x101 | \ \ | | \ | p00i ==si0i=> p10i | | p10i p0i1 \ \ p0i1 ==sii1=> p1i1 \ | x000----pi00----x100 | | x100 |s0ii | | ===> | | s1ii| x011 | | x011----pi11----x111 | \ p0i0 ==sii0=> p1i0 \ \ p1i0 p01i | | p01i ==si1i=> p11i | \ | | \ \ | x010----pi10----x110 x010----pi10----x110 *) (* Contents: * Definition of PathCube * PathCube reflexivity * PathCube face rewriting * PathCubes from paths between squares * PathCubes from squres * PathCube flipping * Kan fillers * PathCube concatenation * natural cubes from ap *) (* Homogeneous cubes *) (* PathCube left right top bottom front back *) Cumulative Inductive PathCube {A} : forall x000 {x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} (s0ii : PathSquare p0i0 p0i1 p00i p01i) (s1ii : PathSquare p1i0 p1i1 p10i p11i) (sii0 : PathSquare p0i0 p1i0 pi00 pi10) (sii1 : PathSquare p0i1 p1i1 pi01 pi11) (si0i : PathSquare p00i p10i pi00 pi01) (si1i : PathSquare p01i p11i pi10 pi11), Type := idcube : forall x, PathCube x 1 1 1 1 1 1. Arguments PathCube {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. Scheme PathCube_ind := Induction for PathCube Sort Type. Arguments PathCube_ind {A} P f {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. Scheme PathCube_rec := Minimality for PathCube Sort Type. Arguments PathCube_rec {A} P f {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. (* These notations make it easier to write our lemmas *) Local Notation hr := (sq_refl_h _). Local Notation vr := (sq_refl_v _). Local Notation tr := sq_tr. Local Notation fv := sq_flip_v. (* PathCubes form a path of squares up to retyping *) Definition equiv_cu_path {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} : sq_concat_h (tr (fv s0ii)) (sq_concat_h si0i (tr s1ii)) = sq_ccGG (moveL_Vp _ _ _ (sq_path^-1 sii0)) (moveL_Vp _ _ _ (sq_path^-1 sii1)) si1i <~> PathCube s0ii s1ii sii0 sii1 si0i si1i. Proof. srapply equiv_adjointify. { destruct sii0, sii1; cbn. rewrite (eisretr sq_G1 si0i)^, (eisretr sq_1G s0ii)^, (eisretr sq_1G s1ii)^. intro X. by destruct (sq_G1^-1 si0i), (sq_1G^-1 s0ii), (sq_1G^-1 s1ii), X, p00i. } 1,2: by intros []. destruct sii0, sii1. cbn. rewrite <- (eisretr sq_G1 si0i). rewrite <- (eisretr sq_1G s0ii). rewrite <- (eisretr sq_1G s1ii). destruct (@equiv_inv _ _ sq_G1 _ si0i). destruct (@equiv_inv _ _ sq_1G _ s0ii). destruct (@equiv_inv _ _ sq_1G _ s1ii). destruct p00i. intro X. by destruct X. Defined. Notation cu_path := equiv_cu_path. Section Reflexivity. (* PathCube reflexivity *) Context {A} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11}. (* Left right reflexivity *) Definition cu_refl_lr (s : PathSquare px0 px1 p0x p1x) : PathCube s s hr hr hr hr. Proof. by destruct s. Defined. (* Top bottom reflexivity *) Definition cu_refl_tb (s : PathSquare px0 px1 p0x p1x) : PathCube hr hr s s vr vr. Proof. by destruct s. Defined. (* Front back reflexivity *) Definition cu_refl_fb (s : PathSquare px0 px1 p0x p1x) : PathCube vr vr vr vr s s. Proof. by destruct s. Defined. End Reflexivity. (* Lemmas for rewriting faces of cubes *) Section PathCubeRewriting. Context {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11}. (* We write the most general version and derive special cases from this *) Definition equiv_cu_GGGGGG {s0ii' s1ii' sii0' sii1' si0i' si1i'} (t0ii : s0ii = s0ii') (t1ii : s1ii = s1ii') (tii0 : sii0 = sii0') (tii1 : sii1 = sii1') (ti0i : si0i = si0i') (ti1i : si1i = si1i') : PathCube s0ii s1ii sii0 sii1 si0i si1i <~> PathCube s0ii' s1ii' sii0' sii1' si0i' si1i'. Proof. by destruct t0ii, t1ii, tii0, tii1, ti0i, ti1i. Defined. Context {s0ii' s1ii' sii0' sii1' si0i' si1i'} (t0ii : s0ii = s0ii') (t1ii : s1ii = s1ii') (tii0 : sii0 = sii0') (tii1 : sii1 = sii1') (ti0i : si0i = si0i') (ti1i : si1i = si1i'). Definition equiv_cu_Gccccc := equiv_cu_GGGGGG t0ii 1 1 1 1 1. Definition equiv_cu_cGcccc := equiv_cu_GGGGGG 1 t1ii 1 1 1 1. Definition equiv_cu_ccGccc := equiv_cu_GGGGGG 1 1 tii0 1 1 1. Definition equiv_cu_cccGcc := equiv_cu_GGGGGG 1 1 1 tii1 1 1. Definition equiv_cu_ccccGc := equiv_cu_GGGGGG 1 1 1 1 ti0i 1. Definition equiv_cu_cccccG := equiv_cu_GGGGGG 1 1 1 1 1 ti1i. Definition equiv_cu_ccGGGG := equiv_cu_GGGGGG 1 1 tii0 tii1 ti0i ti1i. Definition equiv_cu_GGGGcc := equiv_cu_GGGGGG t0ii t1ii tii0 tii1 1 1. Definition equiv_cu_GGcccc := equiv_cu_GGGGGG t0ii t1ii 1 1 1 1. Definition equiv_cu_ccGGcc := equiv_cu_GGGGGG 1 1 tii0 tii1 1 1. Definition equiv_cu_ccccGG := equiv_cu_GGGGGG 1 1 1 1 ti0i ti1i. End PathCubeRewriting. Notation cu_GGGGGG := equiv_cu_GGGGGG. Notation cu_Gccccc := equiv_cu_Gccccc. Notation cu_cGcccc := equiv_cu_cGcccc. Notation cu_ccGccc := equiv_cu_ccGccc. Notation cu_cccGcc := equiv_cu_cccGcc. Notation cu_ccccGc := equiv_cu_ccccGc. Notation cu_cccccG := equiv_cu_cccccG. Notation cu_ccGGGG := equiv_cu_ccGGGG. Notation cu_GGGGcc := equiv_cu_GGGGcc. Notation cu_GGcccc := equiv_cu_GGcccc. Notation cu_ccGGcc := equiv_cu_ccGGcc. Notation cu_ccccGG := equiv_cu_ccccGG. (* Rotating top and bottom to front and back *) Definition equiv_cu_rot_tb_fb {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} : PathCube si0i si1i (sq_tr s0ii) (sq_tr s1ii) (sq_tr sii0) (sq_tr sii1) <~> PathCube s0ii s1ii sii0 sii1 si0i si1i. Proof. srapply equiv_adjointify. { intro cube. refine (cu_GGGGcc _ _ _ _ _). 1,2,3,4: exact (eissect tr _). revert cube. set (a := tr s0ii). set (b := tr s1ii). set (c := tr sii0). set (d := tr sii1). clearbody a b c d; clear s0ii s1ii sii0 sii1. intro cube. by destruct cube. } 1,2 : by intros []. rewrite <- (eissect tr s0ii). rewrite <- (eissect tr s1ii). rewrite <- (eissect tr sii0). rewrite <- (eissect tr sii1). set (a := tr s0ii). set (b := tr s1ii). set (c := tr sii0). set (d := tr sii1). clearbody a b c d; clear s0ii s1ii sii0 sii1. intro X. rewrite <- (eissect (cu_ccGGGG (eisretr tr _) (eisretr tr _) (eisretr tr _) (eisretr tr _)) X). set (e := cu_ccGGGG (eisretr tr _) (eisretr tr _) (eisretr tr _) (eisretr tr _) X). clearbody e; clear X. by destruct e. Defined. Notation cu_rot_tb_fb := equiv_cu_rot_tb_fb. (* Degnerate cubes formed from paths between squares *) (* The first case is easiest to prove and can be written as equivalences *) Definition equiv_cu_G11 {A} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {s s' : PathSquare px0 px1 p0x p1x} : s = s' <~> PathCube s s' hr hr hr hr. Proof. destruct s. refine (cu_path oE _). refine (equiv_concat_l (sq_concat_h_1s (sq_concat_h 1%square (tr s')) (p0y:=1) (p1y:=1)) _ oE _). refine (equiv_concat_l (sq_concat_h_1s (tr s') (p0y:=1) (p1y:=1)) _ oE _). refine (equiv_moveR_equiv_M (f:=tr) _ _ oE _). apply equiv_path_inverse. Defined. (* This case can be reduced to the first by rotating the cube and rewriting some faces *) Definition equiv_cu_1G1 {A} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {s s' : PathSquare px0 px1 p0x p1x} : s = s' <~> PathCube hr hr s s' vr vr. Proof. refine (cu_rot_tb_fb oE _). refine (cu_rot_tb_fb oE _). refine (cu_ccGGGG _ _ _ _ oE _). 1,2: exact sq_tr_refl_v^. 1,2: exact (eisretr tr _)^. refine (_ oE equiv_ap' tr _ _). apply equiv_cu_G11. Defined. (* Finally this is an even simpler rotation *) Definition equiv_cu_11G {A} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {s s' : PathSquare px0 px1 p0x p1x} : s = s' <~> PathCube vr vr vr vr s s'. Proof. refine (cu_rot_tb_fb oE _). refine (cu_ccGGGG _ _ _ _ oE _). 1-4: exact sq_tr_refl_v^. by apply equiv_cu_G11. Defined. Notation cu_G11 := equiv_cu_G11. Notation cu_1G1 := equiv_cu_1G1. Notation cu_11G := equiv_cu_11G. (* Degnerate cubes given by squares *) Section PathPathSquares. Context {A} {x y : A} {a00 a10 a01 a11 : x = y} (px0 : a00 = a10) (px1 : a01 = a11) (p0x : a00 = a01) (p1x : a10 = a11). Definition equiv_cu_GG1 : PathSquare px0 px1 p0x p1x <~> PathCube (sq_G1 px0) (sq_G1 px1) (sq_G1 p0x) (sq_G1 p1x) 1 1. Proof. destruct p0x, p1x, a00. refine (_ oE sq_G1^-1). refine (_ oE equiv_ap' sq_G1 _ _). exact cu_G11. Defined. Definition equiv_cu_1GG : PathSquare px0 px1 p0x p1x <~> PathCube 1 1 (sq_1G px0) (sq_1G px1) (sq_1G p0x) (sq_1G p1x). Proof. destruct px0, px1, a01. refine(_ oE sq_1G^-1). refine (_ oE equiv_ap' sq_1G _ _). exact cu_11G. Defined. Definition equiv_cu_G1G : PathSquare px0 px1 p0x p1x <~> PathCube (sq_1G px0) (sq_1G px1) 1 1 (sq_G1 p0x) (sq_G1 p1x). Proof. destruct p0x, p1x, a10. refine(_ oE sq_G1^-1). refine (_ oE equiv_ap' sq_1G _ _). exact cu_G11. Defined. End PathPathSquares. Notation cu_GG1 := equiv_cu_GG1. Notation cu_G1G := equiv_cu_G1G. Notation cu_1GG := equiv_cu_1GG. Arguments cu_GG1 {_ _ _ _ _ _ _ _ _ _ _}. Arguments cu_G1G {_ _ _ _ _ _ _ _ _ _ _}. Arguments cu_1GG {_ _ _ _ _ _ _ _ _ _ _}. (* PathCubes can be given by DPathSquares over Paths*) Definition equiv_cu_ds {A B} {f g : A -> B} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {s : PathSquare px0 px1 p0x p1x} {b00 : f a00 = g a00} {b01 : f a01 = g a01} {b10 : f a10 = g a10} {b11 : f a11 = g a11} {qx0 : DPath (fun x => f x = g x) px0 b00 b10} {qx1 : DPath (fun x => f x = g x) px1 b01 b11} {q0x : DPath (fun x => f x = g x) p0x b00 b01} {q1x : DPath (fun x => f x = g x) p1x b10 b11} : DPathSquare (fun x => f x = g x) s qx0 qx1 q0x q1x <~> PathCube (sq_dp qx0) (sq_dp qx1) (sq_dp q0x) (sq_dp q1x) (sq_ap f s) (sq_ap g s). Proof. destruct s. apply cu_GG1. Defined. Notation cu_ds := equiv_cu_ds. (* PathCubes can be given by DPaths over PathSquares *) Definition equiv_dp_cu {A B : Type} {x1 x2 : A} {a00 a01 a10 a11 : A -> B} {px0 : a00 == a10} {px1 : a01 == a11} {p0x : a00 == a01} {p1x : a10 == a11} {f1 : PathSquare (px0 x1) (px1 x1) (p0x x1) (p1x x1)} {f2 : PathSquare (px0 x2) (px1 x2) (p0x x2) (p1x x2)} {p : x1 = x2} : PathCube f1 f2 (sq_dp (apD px0 p)) (sq_dp (apD px1 p)) (sq_dp (apD p0x p)) (sq_dp (apD p1x p)) <~> DPath (fun x => PathSquare (px0 x) (px1 x) (p0x x) (p1x x)) p f1 f2. Proof. destruct p; symmetry; exact cu_G11. Defined. Notation dp_cu := equiv_dp_cu. (* Flipping a cube along the left right direction *) Definition equiv_cu_flip_lr {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} : PathCube s0ii s1ii sii0 sii1 si0i si1i <~> PathCube s1ii s0ii (sq_flip_h sii0) (sq_flip_h sii1) (sq_flip_h si0i) (sq_flip_h si1i). Proof. destruct si1i, si0i. refine (cu_GGcccc _ _ oE _). 1,2: exact (eisretr sq_G1 _). refine (cu_GG1 oE _). refine (sq_flip_h oE _). refine (cu_GG1^-1 oE _). refine (cu_GGGGcc _ _ _ _). all: exact (eisretr sq_G1 _)^. Defined. Notation cu_flip_lr := equiv_cu_flip_lr. (* PathCube Kan fillers ~ Every open crate has a lid *) Definition cu_fill_left {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} (s1ii : PathSquare p1i0 p1i1 p10i p11i) (sii0 : PathSquare p0i0 p1i0 pi00 pi10) (sii1 : PathSquare p0i1 p1i1 pi01 pi11) (si0i : PathSquare p00i p10i pi00 pi01) (si1i : PathSquare p01i p11i pi10 pi11) : {s0ii : PathSquare p0i0 p0i1 p00i p01i & PathCube s0ii s1ii sii0 sii1 si0i si1i}. Proof. destruct si0i, si1i. set (a := sq_G1^-1 s1ii). set (b := sq_G1^-1 sii0). set (c := sq_G1^-1 sii1). rewrite <- (eisretr sq_G1 s1ii). rewrite <- (eisretr sq_G1 sii0). rewrite <- (eisretr sq_G1 sii1). change (sq_G1^-1 s1ii) with a. change (sq_G1^-1 sii0) with b. change (sq_G1^-1 sii1) with c. clearbody a b c. clear s1ii sii0 sii1. refine (sq_G1 (b @ a @ c^); _). by destruct a, b, c, p0i1. Defined. Definition cu_fill_right {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} (s0ii : PathSquare p0i0 p0i1 p00i p01i) (sii0 : PathSquare p0i0 p1i0 pi00 pi10) (sii1 : PathSquare p0i1 p1i1 pi01 pi11) (si0i : PathSquare p00i p10i pi00 pi01) (si1i : PathSquare p01i p11i pi10 pi11) : {s1ii : PathSquare p1i0 p1i1 p10i p11i & PathCube s0ii s1ii sii0 sii1 si0i si1i}. Proof. refine (_;_). apply cu_flip_lr^-1. apply cu_fill_left. Defined. Definition cu_fill_top {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} (s0ii : PathSquare p0i0 p0i1 p00i p01i) (s1ii : PathSquare p1i0 p1i1 p10i p11i) (sii1 : PathSquare p0i1 p1i1 pi01 pi11) (si0i : PathSquare p00i p10i pi00 pi01) (si1i : PathSquare p01i p11i pi10 pi11) : {sii0 : PathSquare p0i0 p1i0 pi00 pi10 & PathCube s0ii s1ii sii0 sii1 si0i si1i}. Proof. refine (_;_). apply cu_rot_tb_fb. apply cu_rot_tb_fb. refine (cu_Gccccc (eisretr tr _)^ _). apply cu_fill_left. Defined. Definition cu_fill_bottom {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} (s0ii : PathSquare p0i0 p0i1 p00i p01i) (s1ii : PathSquare p1i0 p1i1 p10i p11i) (sii0 : PathSquare p0i0 p1i0 pi00 pi10) (si0i : PathSquare p00i p10i pi00 pi01) (si1i : PathSquare p01i p11i pi10 pi11) : {sii1 : PathSquare p0i1 p1i1 pi01 pi11 & PathCube s0ii s1ii sii0 sii1 si0i si1i}. Proof. refine (_;_). apply cu_rot_tb_fb. apply cu_rot_tb_fb. refine (cu_cGcccc (eisretr tr _)^ _). apply cu_fill_right. Defined. Definition cu_fill_front {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} (s0ii : PathSquare p0i0 p0i1 p00i p01i) (s1ii : PathSquare p1i0 p1i1 p10i p11i) (sii0 : PathSquare p0i0 p1i0 pi00 pi10) (sii1 : PathSquare p0i1 p1i1 pi01 pi11) (si1i : PathSquare p01i p11i pi10 pi11) : {si0i : PathSquare p00i p10i pi00 pi01 & PathCube s0ii s1ii sii0 sii1 si0i si1i}. Proof. refine (_;_). apply cu_rot_tb_fb. apply cu_fill_left. Defined. Definition cu_fill_back {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} (s0ii : PathSquare p0i0 p0i1 p00i p01i) (s1ii : PathSquare p1i0 p1i1 p10i p11i) (sii0 : PathSquare p0i0 p1i0 pi00 pi10) (sii1 : PathSquare p0i1 p1i1 pi01 pi11) (si0i : PathSquare p00i p10i pi00 pi01) : {si1i : PathSquare p01i p11i pi10 pi11 & PathCube s0ii s1ii sii0 sii1 si0i si1i}. Proof. refine (_;_). apply cu_rot_tb_fb. apply cu_fill_right. Defined. (** PathCube concatenation *) Section Concat. Context {A : Type} (* Main Cube *) {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} (ciii : PathCube s0ii s1ii sii0 sii1 si0i si1i). Definition cu_concat_lr {x201 x200 x210 x211 : A} {pj01 : x101 = x201} {pj11 : x111 = x211} {pj10 : x110 = x210} {pj00 : x100 = x200} {p2i1 : x201 = x211} {p2i0 : x200 = x210} {p20i : x200 = x201} {p21i : x210 = x211} {sji0 : PathSquare p1i0 p2i0 pj00 pj10} {sji1 : PathSquare p1i1 p2i1 pj01 pj11} {sj0i : PathSquare p10i p20i pj00 pj01} {sj1i : PathSquare p11i p21i pj10 pj11} {s2ii : PathSquare p2i0 p2i1 p20i p21i} (cjii : PathCube s1ii s2ii sji0 sji1 sj0i sj1i) : PathCube s0ii s2ii (sq_concat_h sii0 sji0) (sq_concat_h sii1 sji1) (sq_concat_h si0i sj0i) (sq_concat_h si1i sj1i). Proof. destruct cjii, pi00, pi01, pi10, pi11. exact ciii. Defined. Definition cu_concat_tb {x020 x021 x120 x121 : A} {p0j0 : x010 = x020} {p1j0 : x110 = x120} {p0j1 : x011 = x021} {p1j1 : x111 = x121} {p02i : x020 = x021} {p12i : x120 = x121} {pi20 : x020 = x120} {pi21 : x021 = x121} {s0ji : PathSquare p0j0 p0j1 p01i p02i} {s1ji : PathSquare p1j0 p1j1 p11i p12i} {sij0 : PathSquare p0j0 p1j0 pi10 pi20} {sij1 : PathSquare p0j1 p1j1 pi11 pi21} {si2i : PathSquare p02i p12i pi20 pi21} (ciji : PathCube s0ji s1ji sij0 sij1 si1i si2i) : PathCube (sq_concat_v s0ii s0ji) (sq_concat_v s1ii s1ji) (sq_concat_v sii0 sij0) (sq_concat_v sii1 sij1) si0i si2i. Proof. destruct ciji, p0i0, p1i0, p0i1, p1i1. exact ciii. Defined. Definition cu_concat_fb {x002 x012 x102 x112 : A} {p0i2 : x002 = x012} {p00j : x001 = x002} {p01j : x011 = x012} {p1i2 : x102 = x112} {p10j : x101 = x102} {p11j : x111 = x112} {pi02 : x002 = x102} {pi12 : x012 = x112} {s0ij : PathSquare p0i1 p0i2 p00j p01j} {s1ij : PathSquare p1i1 p1i2 p10j p11j} {si0j : PathSquare p00j p10j pi01 pi02} {si1j : PathSquare p01j p11j pi11 pi12} {sii2 : PathSquare p0i2 p1i2 pi02 pi12} (ciij : PathCube s0ij s1ij sii1 sii2 si0j si1j) : PathCube (sq_concat_h s0ii s0ij) (sq_concat_h s1ii s1ij) sii0 sii2 (sq_concat_v si0i si0j) (sq_concat_v si1i si1j). Proof. destruct ciij, p00i, p10i, p11i, p01i. exact ciii. Defined. End Concat. (* Notation for left right concatenation *) Notation "x '@lr' y" := (cu_concat_lr x y) : cube_scope. Local Notation apc := (ap_compose_sq _ _ _). (* sq_ap analogue for ap_compse *) Definition sq_ap_compose {A B C : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} (f : A -> B) (g : B -> C) (s : PathSquare px0 px1 p0x p1x) : PathCube (sq_ap (g o f) s) (sq_ap g (sq_ap f s)) apc apc apc apc. Proof. by destruct s. Defined. Local Notation api := (ap_idmap_sq _). (* sq_ap analogue for ap_idmap *) Definition sq_ap_idmap {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} (s : PathSquare px0 px1 p0x p1x) : PathCube (sq_ap idmap s) s api api api api. Proof. by destruct s. Defined. Local Notation apn := (ap_nat _ _). (* sq_ap analogue for ap_nat *) Definition sq_ap_nat {A B : Type} {a00 a10 a01 a11 : A} (f f' : A -> B) (h : f == f') {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} (s : PathSquare px0 px1 p0x p1x) : PathCube (sq_ap f s) (sq_ap f' s) (ap_nat h _) apn apn apn. Proof. destruct s as [x]; cbn; by destruct (h x). Defined. (* Uncurry a function in sq_ap2 *) Definition sq_ap_uncurry {A B C} (f : A -> B -> C) {a a' : A} (p : a = a') {b b' : B} (q : b = b') : PathCube (sq_ap (uncurry f) (sq_prod (hr, vr))) (sq_ap011 f p q) (sq_G1 (ap_uncurry _ _ _)) (sq_G1 (ap_uncurry _ _ _)) (sq_G1 (ap_uncurry _ _ _)) (sq_G1 (ap_uncurry _ _ _)). Proof. by destruct p, q. Defined. (* ap for cubes *) Definition cu_ap {A B} {x000 x010 x100 x110 x001 x011 x101 x111 : A} {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100} {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111} {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001} {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111} {s0ii : PathSquare p0i0 p0i1 p00i p01i} {s1ii : PathSquare p1i0 p1i1 p10i p11i} {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11} {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11} (f : A -> B) (c : PathCube s0ii s1ii sii0 sii1 si0i si1i) : PathCube (sq_ap f s0ii) (sq_ap f s1ii) (sq_ap f sii0) (sq_ap f sii1) (sq_ap f si0i) (sq_ap f si1i). Proof. by destruct c. Defined. Coq-HoTT-9.0/theories/Cubical/PathSquare.v000066400000000000000000000454441474641544500204010ustar00rootroot00000000000000Require Import Basics. Require Import Types.Paths Types.Prod. Require Import DPath. Declare Scope square_scope. Delimit Scope square_scope with square. Local Unset Elimination Schemes. (* Homogeneous squares *) (* x00 ----pi0---- x01 | | | | p0i ==> p1i | | | | x01-----pi1-----x11 *) (* Contents: * Definition of PathSquare * Degenerate PathSquares as paths between paths * Flipping squares horizontally and vertically * PathSquare transpose * PathSquare inverse * PathSquare rotations * Edge rewriting * Concatenation * Kan fillers * natural squares from ap *) (* Definition of PathSquare *) (* PathSquare left right up down *) Cumulative Inductive PathSquare {A} : forall a00 {a10 a01 a11 : A}, a00 = a10 -> a01 = a11 -> a00 = a01 -> a10 = a11 -> Type := sq_id : forall {x : A}, PathSquare x 1 1 1 1. Arguments sq_id {A x}. Arguments PathSquare {A _ _ _ _}. Notation "1" := sq_id : square_scope. Scheme PathSquare_ind := Induction for PathSquare Sort Type. Arguments PathSquare_ind {A} P f {_ _ _ _ _ _ _ _} _. Scheme PathSquare_rec := Minimality for PathSquare Sort Type. Arguments PathSquare_rec {A} P f {_ _ _ _ _ _ _ _} _. (* PathSquare_ind is an equivalence, similar to how paths_ind is *) Global Instance isequiv_PathSquare_ind `{Funext} {A} (P : forall (a00 a10 a01 a11 : A) (p : a00 = a10) (p0 : a01 = a11) (p1 : a00 = a01) (p2 : a10 = a11), PathSquare p p0 p1 p2 -> Type) : IsEquiv (PathSquare_ind P). Proof. srapply isequiv_adjointify. 1: intros X ?; apply X. 2: intro; reflexivity. intro. do 8 (apply path_forall; intro). apply path_forall. by intros []. Defined. (* PathSquares can be given by 2-dimensional paths *) Definition equiv_sq_path {A} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} : px0 @ p1x = p0x @ px1 <~> PathSquare px0 px1 p0x p1x. Proof. snrapply Build_Equiv. { destruct p0x, p1x. intro e. generalize (e @ concat_1p _). intro e'. destruct e', px0. exact sq_id. } srapply isequiv_adjointify; try by intros []. destruct p0x, p1x. intros e. pattern e. pose (e' := e @ concat_1p _). pose (e'' := e' @ (concat_1p _)^). refine (@transport _ _ e'' e _ _). - subst e' e''; hott_simpl. - clearbody e'; clear e. destruct e', px0. reflexivity. Defined. Notation sq_path := equiv_sq_path. (** Squares in (n+2)-truncated types are n-truncated *) Global Instance istrunc_sq n {A} `{!IsTrunc n.+2 A} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} : IsTrunc n (PathSquare px0 px1 p0x p1x). Proof. exact (istrunc_equiv_istrunc _ sq_path). Defined. (* We can give degenerate squares *) Section PathSquaresFromPaths. Context {A : Type} {a00 a10 a01 : A} {p p' : a00 = a10} {q q' : a00 = a01}. Definition equiv_sq_G1 : p = p' <~> PathSquare p p' 1 1 := sq_path oE equiv_p1_1q. Definition equiv_sq_1G : q = q' <~> PathSquare 1 1 q q' := sq_path oE equiv_1p_q1 oE equiv_path_inverse _ _. End PathSquaresFromPaths. Notation sq_G1 := equiv_sq_G1. Notation sq_1G := equiv_sq_1G. Local Open Scope equiv_scope. Local Open Scope path_scope. (* PathSquare horizontal reflexivity *) Definition sq_refl_h {A} {a0 a1 : A} (p : a0 = a1) : PathSquare p p 1 1 := sq_G1 1. (* PathSquare vertical reflexivity *) Definition sq_refl_v {A} {a0 a1 : A} (p : a0 = a1) : PathSquare 1 1 p p := sq_1G 1. (* Horizontal flip *) Definition equiv_sq_flip_h {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} : PathSquare px0 px1 p0x p1x <~> PathSquare px1 px0 p0x^ p1x^. Proof. destruct p0x, p1x. refine (sq_G1 oE _). refine (equiv_path_inverse _ _ oE _). apply sq_G1^-1. Defined. Notation sq_flip_h := equiv_sq_flip_h. (* Vertical flip *) Definition equiv_sq_flip_v {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} : PathSquare px0 px1 p0x p1x <~> PathSquare px0^ px1^ p1x p0x. Proof. destruct px0, px1. refine (sq_1G oE _). refine (equiv_path_inverse _ _ oE _). apply sq_1G^-1. Defined. Notation sq_flip_v := equiv_sq_flip_v. (* Transpose of a square *) (** We make a local definition that will never get unfolded *) Local Definition tr {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} : PathSquare px0 px1 p0x p1x -> PathSquare p0x p1x px0 px1. Proof. by intros []. Defined. Arguments tr : simpl never. Definition equiv_sq_tr {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} : PathSquare px0 px1 p0x p1x <~> PathSquare p0x p1x px0 px1. Proof. srapply (equiv_adjointify tr tr). 1,2: by intros []. Defined. Notation sq_tr := equiv_sq_tr. (* NOTE: sq_tr ought to be some sort of involution but it obviously isn't since it is not of the form A -> A. Perhaps there is a more general "involution" but between equivalent types? But then that very equivalence is given by sq_tr so it seems a bit circular... *) Definition sq_tr_refl_h {A} {a b : A} {p : a = b} : sq_tr (sq_refl_h p) = sq_refl_v p. Proof. by destruct p. Defined. Definition sq_tr_refl_v {A} {a b : A} {p : a = b} : sq_tr (sq_refl_v p) = sq_refl_h p. Proof. by destruct p. Defined. (* Operations on squares *) Section PathSquareOps. Context {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11}. (* Inverse square *) Definition equiv_sq_V : PathSquare px0 px1 p0x p1x <~> PathSquare px1^ px0^ p1x^ p0x^. Proof. refine (sq_path oE _ ). refine (equiv_concat_lr (inv_pp _ _)^ (inv_pp _ _) oE _). refine (equiv_ap _ _ _ oE _). refine (sq_path^-1 oE _). exact sq_tr. Defined. (* Left rotation : left right top bottom -> top bottom right left *) Definition equiv_sq_rot_l : PathSquare px0 px1 p0x p1x <~> PathSquare p0x^ p1x^ px1 px0. Proof. refine (sq_path oE _). refine (equiv_moveR_Vp _ _ _ oE _). refine (equiv_concat_r (concat_pp_p _ _ _) _ oE _). refine (equiv_moveL_pV _ _ _ oE _). exact sq_path^-1. Defined. (* Right rotation : left right top bottom -> bottom top left right *) Definition equiv_sq_rot_r : PathSquare px0 px1 p0x p1x -> PathSquare p1x p0x px0^ px1^. Proof. refine (sq_path oE _). refine (equiv_moveL_Vp _ _ _ oE _). refine (equiv_concat_l (concat_p_pp _ _ _) _ oE _). refine (equiv_moveR_pV _ _ _ oE _). exact sq_path^-1. Defined. End PathSquareOps. Notation sq_V := equiv_sq_V. Notation sq_rot_l:= equiv_sq_rot_l. Notation sq_rot_r := equiv_sq_rot_r. (* Lemmas for rewriting sides of squares *) Section PathSquareRewriting. Context {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11}. (* These are all special cases of the following "rewrite all sides" lemma which we prove is an equivalence giving us all special cases as equivalences too *) Definition equiv_sq_GGGG {px0' px1' p0x' p1x'} (qx0 : px0 = px0') (qx1 : px1 = px1') (q0x : p0x = p0x') (q1x : p1x = p1x') : PathSquare px0 px1 p0x p1x <~> PathSquare px0' px1' p0x' p1x'. Proof. by destruct qx0, qx1, q0x, q1x. Defined. Context {px0' px1' p0x' p1x'} (qx0 : px0 = px0') (qx1 : px1 = px1') (q0x : p0x = p0x') (q1x : p1x = p1x'). Definition equiv_sq_Gccc := equiv_sq_GGGG qx0 1 1 1. Definition equiv_sq_cGcc := equiv_sq_GGGG 1 qx1 1 1. Definition equiv_sq_ccGc := equiv_sq_GGGG 1 1 q0x 1. Definition equiv_sq_cccG := equiv_sq_GGGG 1 1 1 q1x. Definition equiv_sq_GGcc := equiv_sq_GGGG qx0 qx1 1 1. Definition equiv_sq_GcGc := equiv_sq_GGGG qx0 1 q0x 1. Definition equiv_sq_GccG := equiv_sq_GGGG qx0 1 1 q1x. Definition equiv_sq_cGGc := equiv_sq_GGGG 1 qx1 q0x 1. Definition equiv_sq_cGcG := equiv_sq_GGGG 1 qx1 1 q1x. Definition equiv_sq_ccGG := equiv_sq_GGGG 1 1 q0x q1x. Definition equiv_sq_GGGc := equiv_sq_GGGG qx0 qx1 q0x 1. Definition equiv_sq_cGGG := equiv_sq_GGGG 1 qx1 q0x q1x. End PathSquareRewriting. Notation sq_GGGG := equiv_sq_GGGG. Notation sq_Gccc := equiv_sq_Gccc. Notation sq_cGcc := equiv_sq_cGcc. Notation sq_ccGc := equiv_sq_ccGc. Notation sq_cccG := equiv_sq_cccG. Notation sq_GGcc := equiv_sq_GGcc. Notation sq_GcGc := equiv_sq_GcGc. Notation sq_GccG := equiv_sq_GccG. Notation sq_cGGc := equiv_sq_cGGc. Notation sq_cGcG := equiv_sq_cGcG. Notation sq_ccGG := equiv_sq_ccGG. Notation sq_GGGc := equiv_sq_GGGc. Notation sq_cGGG := equiv_sq_cGGG. Section MovePaths. Context {A : Type} {x x00 x20 x02 x22 : A} {f10 : x00 = x20} {f12 : x02 = x22} {f01 : x00 = x02} {f21 : x20 = x22}. (** Operations to move paths around a square. We define all these operations immediately as equvialences. The naming first number indicates in which argument the path that moves is on the left of the equivalence, and the second number where it is on the right. The equivalences are all set up so that on the right, there is no path inversion. For the [24] and [13] equivalences there is a path inverse on the left. The corresponding equivalences [42] and [31] are the symmetric versions of these, but the path inverse is in another place. *) Definition equiv_sq_move_23 {f12'' : x02 = x} {f12' : x = x22} : PathSquare f10 (f12'' @ f12') f01 f21 <~> PathSquare f10 f12' (f01 @ f12'') f21. Proof. clear f12. destruct f12''. refine (sq_cGcc (concat_1p _) oE _). refine (sq_ccGc (concat_p1 _)^). Defined. Definition equiv_sq_move_14 {f10'' : x00 = x} {f10' : x = x20} : PathSquare (f10'' @ f10') f12 f01 f21 <~> PathSquare f10'' f12 f01 (f10' @ f21). Proof. clear f10. destruct f10'. refine (sq_cccG (concat_1p _)^ oE _). refine (sq_Gccc (concat_p1 _)). Defined. Definition equiv_sq_move_24 {f12'' : x02 = x} {f12' : x22 = x} : PathSquare f10 (f12'' @ f12'^) f01 f21 <~> PathSquare f10 f12'' f01 (f21 @ f12'). Proof. clear f12. destruct f12'. refine (sq_cccG (concat_p1 _)^ oE _). refine (sq_cGcc (concat_p1 _)). Defined. Definition equiv_sq_move_42 {f12'' : x02 = x} {f12' : x = x22} : PathSquare f10 f12'' f01 (f21 @ f12'^) <~> PathSquare f10 (f12'' @ f12') f01 f21. Proof. clear f12. destruct f12'. refine (sq_cGcc (concat_p1 _)^ oE _). refine (sq_cccG (concat_p1 _)). Defined. Definition equiv_sq_move_13 {f10'' : x = x00} {f10' : x = x20} : PathSquare (f10''^ @ f10') f12 f01 f21 <~> PathSquare f10' f12 (f10'' @ f01) f21. Proof. clear f10. destruct f10''. refine (sq_ccGc (concat_1p _)^ oE _). refine (sq_Gccc (concat_1p _)). Defined. Definition equiv_sq_move_31 {f10'' : x00 = x} {f10' : x = x20} : PathSquare f10' f12 (f10''^ @ f01) f21 <~> PathSquare (f10'' @ f10') f12 f01 f21. Proof. clear f10. destruct f10''. refine (sq_Gccc (concat_1p _)^ oE _). refine (sq_ccGc (concat_1p _)). Defined. End MovePaths. Notation sq_move_23 := equiv_sq_move_23. Notation sq_move_14 := equiv_sq_move_14. Notation sq_move_24 := equiv_sq_move_24. Notation sq_move_42 := equiv_sq_move_42. Notation sq_move_13 := equiv_sq_move_13. Notation sq_move_31 := equiv_sq_move_31. (* Depdent path product definition of PathSquare *) Definition equiv_sq_dp_prod {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} : DPath (fun xy => fst xy = snd xy) (path_prod' p0x p1x) px0 px1 <~> PathSquare px0 px1 p0x p1x. Proof. refine (_ oE (dp_paths_FlFr _ _ _)^-1). refine (_ oE (equiv_concat_l (concat_pp_p _ _ _) _)^-1). refine (_ oE equiv_moveL_Mp _ _ _). refine (_ oE sq_path). exact (sq_ccGG (ap_fst_path_prod _ _) (ap_snd_path_prod _ _)). Defined. Notation sq_dp_prod := equiv_sq_dp_prod. (* Concatenation of squares *) Section PathSquareConcat. Context {A : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11}. (* Horizontal concatenation of squares *) Definition sq_concat_h {a02 a12 : A} {p0y : a01 = a02} {p1y : a11 = a12} {px2 : a02 = a12} : PathSquare px0 px1 p0x p1x -> PathSquare px1 px2 p0y p1y -> PathSquare px0 px2 (p0x @ p0y) (p1x @ p1y). Proof. intros a b. destruct b. refine (sq_ccGG _ _ a). 1,2: apply inverse, concat_p1. Defined. Infix "@@h" := sq_concat_h : square_scope. (* Vertical concatenation of squares *) Definition sq_concat_v {a20 a21 : A} {py0 : a10 = a20} {py1 : a11 = a21} {p2x : a20 = a21} : PathSquare px0 px1 p0x p1x -> PathSquare py0 py1 p1x p2x -> PathSquare (px0 @ py0) (px1 @ py1) p0x p2x. Proof. intros a b. destruct b. refine (sq_GGcc _ _ a). 1,2: apply inverse, concat_p1. Defined. Infix "@@v" := sq_concat_v : square_scope. End PathSquareConcat. (* Horizontal groupoid laws for concatenation *) Section GroupoidLawsH. (* There are many more laws to write, but it seems we don't really need them *) Context {A : Type} {a00 a10 a01 a11 a02 a12 a20 a21 a03 a13 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {px2 : a02 = a12} {p0y : a01 = a02} {p1y : a11 = a12} {px3 : a03 = a13} {p0z : a02 = a03} {p1z : a12 = a13} (s : PathSquare px0 px1 p0x p1x). Local Open Scope square_scope. Notation hr := (sq_refl_h _). Definition sq_concat_h_s1 : sq_concat_h s hr = sq_ccGG (concat_p1 _)^ (concat_p1 _)^ s. Proof. by destruct s. Defined. Definition sq_concat_h_1s : sq_concat_h hr s = sq_ccGG (concat_1p _)^ (concat_1p _)^ s. Proof. by destruct s. Defined. Context (t : PathSquare px1 px2 p0y p1y) (u : PathSquare px2 px3 p0z p1z). Definition sq_concat_h_ss_s : sq_concat_h (sq_concat_h s t) u = sq_ccGG (concat_p_pp _ _ _) (concat_p_pp _ _ _) (sq_concat_h s (sq_concat_h t u)). Proof. by destruct s, u, (sq_1G^-1 t), p0y. Defined. End GroupoidLawsH. (* PathSquare Kan fillers ~ Every open box has a lid *) Section Kan. (* These can be used to prove groupoid laws about paths *) Context {A : Type} {a00 a10 a01 a11 : A}. Definition sq_fill_l (px1 : a01 = a11) (p0x : a00 = a01) (p1x : a10 = a11) : {px0 : a00 = a10 & PathSquare px0 px1 p0x p1x}. Proof. exists (p0x @ px1 @ p1x^). by destruct px1, p0x, p1x. Defined. Definition sq_fill_l_uniq {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {px0 : a00 = a10} (s : PathSquare px0 px1 p0x p1x) {px0' : a00 = a10} (s' : PathSquare px0' px1 p0x p1x) : px0 = px0'. Proof. destruct s. apply sq_path^-1 in s'. exact (s'^ @ concat_p1 _). Defined. Definition sq_fill_r (px0 : a00 = a10) (p0x : a00 = a01) (p1x : a10 = a11) : {px1 : a01 = a11 & PathSquare px0 px1 p0x p1x}. Proof. exists (p0x^ @ px0 @ p1x). by destruct px0, p0x, p1x. Defined. Definition sq_fill_r_uniq {px0 : a00 = a10} {p0x : a00 = a01} {p1x : a10 = a11} {px1 : a01 = a11} (s : PathSquare px0 px1 p0x p1x) {px1' : a01 = a11} (s' : PathSquare px0 px1' p0x p1x) : px1 = px1'. Proof. destruct s. apply sq_path^-1 in s'. exact (s' @ concat_1p _). Defined. Definition equiv_sq_fill_lr (p0x : a00 = a01) (p1x : a10 = a11) : (a00 = a10) <~> (a01 = a11). Proof. srapply equiv_adjointify. - intros px0; exact (sq_fill_r px0 p0x p1x).1. - intros px1; exact (sq_fill_l px1 p0x p1x).1. - intros px1. exact (sq_fill_r_uniq (sq_fill_r _ p0x p1x).2 (sq_fill_l px1 p0x p1x).2). - intros px0. exact (sq_fill_l_uniq (sq_fill_l _ p0x p1x).2 (sq_fill_r px0 p0x p1x).2). Defined. Definition sq_fill_t (px0 : a00 = a10) (px1 : a01 = a11) (p1x : a10 = a11) : {p0x : a00 = a01 & PathSquare px0 px1 p0x p1x}. Proof. exists (px0 @ p1x @ px1^). by destruct px0, px1, p1x. Defined. Definition sq_fill_b (px0 : a00 = a10) (px1 : a01 = a11) (p0x : a00 = a01) : {p1x : a10 = a11 & PathSquare px0 px1 p0x p1x}. Proof. exists (px0^ @ p0x @ px1). by destruct px0, px1, p0x. Defined. End Kan. (* Apply a function to the sides of square *) Definition sq_ap {A B : Type} {a00 a10 a01 a11 : A} (f : A -> B) {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} : PathSquare px0 px1 p0x p1x -> PathSquare (ap f px0) (ap f px1) (ap f p0x) (ap f p1x). Proof. by intros []. Defined. (** This preserves reflexivity *) Definition sq_ap_refl_h {A B} (f : A -> B) {a0 a1 : A} (p : a0 = a1) : sq_ap f (sq_refl_h p) = sq_refl_h (ap f p). Proof. by destruct p. Defined. Definition sq_ap_refl_v {A B} (f : A -> B) {a0 a1 : A} (p : a0 = a1) : sq_ap f (sq_refl_v p) = sq_refl_v (ap f p). Proof. by destruct p. Defined. (* PathSquares respect products *) Definition equiv_sq_prod {A B : Type} {a00 a10 a01 a11 : A} {px0 : a00 = a10} {px1 : a01 = a11} {p0x : a00 = a01} {p1x : a10 = a11} {b00 b10 b01 b11 : B} {qx0 : b00 = b10} {qx1 : b01 = b11} {q0x : b00 = b01} {q1x : b10 = b11} : (PathSquare px0 px1 p0x p1x) * (PathSquare qx0 qx1 q0x q1x) <~> PathSquare (path_prod' px0 qx0) (path_prod' px1 qx1) (path_prod' p0x q0x) (path_prod' p1x q1x). Proof. refine (_ oE (equiv_functor_prod' sq_path sq_path)^-1%equiv). refine (_ oE equiv_path_prod (_,_) (_,_)). srefine (_ oE equiv_ap' _ _ _). 3: apply (equiv_path_prod (_,_) (_,_)). refine (_ oE equiv_concat_l _^ _). 2: apply (path_prod_pp (_,_) (_,_) (_,_)). refine (_ oE equiv_concat_r _ _). 2: apply (path_prod_pp (_,_) (_,_) (_,_)). apply sq_path. Defined. Notation sq_prod := equiv_sq_prod. (* The natural square from an ap *) Definition ap_nat {A B} {f f' : A -> B} (h : f == f') {x y : A} (p : x = y) : PathSquare (ap f p) (ap f' p) (h x) (h y). Proof. by destruct p; apply sq_1G. Defined. (* The transpose of the natural square *) Definition ap_nat' {A B} {f f' : A -> B} (h : f == f') {x y : A} (p : x = y) : PathSquare (h x) (h y) (ap f p) (ap f' p). Proof. by destruct p; apply sq_G1. Defined. (* ap_compose fits naturally into a square *) Definition ap_compose_sq {A B C} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : PathSquare (ap (g o f) p) (ap g (ap f p)) 1 1 := sq_G1 (ap_compose f g p). Definition ap_idmap_sq {A} {x y : A} (p : x = y) : PathSquare (ap idmap p) p 1 1 := sq_G1 (ap_idmap p). (* A DPath of a certain form can be turned into a square *) Definition equiv_sq_dp {A B : Type} {f g : A -> B} {a1 a2 : A} {p : a1 = a2} {q1 : f a1 = g a1} {q2 : f a2 = g a2} : DPath (fun x => f x = g x) p q1 q2 <~> PathSquare q1 q2 (ap f p) (ap g p). Proof. destruct p. exact sq_G1. Defined. Notation sq_dp := equiv_sq_dp. (* ap011 fits into a square *) Definition sq_ap011 {A B C} (f : A -> B -> C) {a a' : A} (p : a = a') {b b' : B} (q : b = b') : PathSquare (ap (fun x => f x b) p) (ap (fun x => f x b') p) (ap (f a) q) (ap (f a') q). Proof. apply sq_dp. exact (apD (fun y => ap (fun x => f x y) p) q). Defined. Coq-HoTT-9.0/theories/Diagrams/000077500000000000000000000000001474641544500163075ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Diagrams/Cocone.v000066400000000000000000000204761474641544500177150ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Graph. Require Import Diagrams.Diagram. Local Open Scope path_scope. Generalizable All Variables. (** * Cocones *) (** A Cocone over a diagram [D] to a type [X] is a family of maps from the types of [D] to [X] making the triangles formed with the arrows of [D] commuting. *) Class Cocone {G : Graph} (D : Diagram G) (X : Type) := { legs : forall i, D i -> X; legs_comm : forall i j (g : G i j), legs j o (D _f g) == legs i; }. Arguments Build_Cocone {G D X} legs legs_comm. Arguments legs {G D X} C i x : rename. Arguments legs_comm {G D X} C i j g x : rename. Coercion legs : Cocone >-> Funclass. Definition issig_Cocone {G : Graph} (D : Diagram G) (X : Type) : _ <~> Cocone D X := ltac:(issig). Section Cocone. Context `{Funext} {G : Graph} {D : Diagram G} {X : Type}. (** [path_cocone] says when two cocones are equal (up to funext). *) Definition path_cocone_naive {C1 C2 : Cocone D X} (P := fun q' => forall (i j : G) (g : G i j) (x : D i), q' j (D _f g x) = q' i x) (path_legs : legs C1 = legs C2) (path_legs_comm : transport P path_legs (legs_comm C1) = legs_comm C2) : C1 = C2 := match path_legs_comm in (_ = v1) return C1 = {|legs := legs C2; legs_comm := v1 |} with | idpath => match path_legs in (_ = v0) return C1 = {|legs := v0; legs_comm := path_legs # (legs_comm C1) |} with | idpath => 1 end end. Definition path_cocone {C1 C2 : Cocone D X} (path_legs : forall i, C1 i == C2 i) (path_legs_comm : forall i j g x, legs_comm C1 i j g x @ path_legs i x = path_legs j (D _f g x) @ legs_comm C2 i j g x) : C1 = C2. Proof. destruct C1 as [legs pp_q], C2 as [r pp_r]. refine (path_cocone_naive (path_forall _ _ (fun i => path_forall _ _ (path_legs i))) _). cbn; funext i j f x. rewrite 4 transport_forall_constant, transport_paths_FlFr. rewrite concat_pp_p; apply moveR_Vp. rewrite 2 (ap_apply_lD2 (path_forall _ _ (fun i => path_forall _ _ (path_legs i)))). rewrite 3 eisretr. apply path_legs_comm. Defined. (** Given a cocone [C] to [X] and a map from [X] to [Y], one can postcompose each map of [C] to get a cocone to [Y]. *) Definition cocone_postcompose (C : Cocone D X) {Y : Type} : (X -> Y) -> Cocone D Y. Proof. intros f. srapply Build_Cocone; intro i. 1: exact (f o C i). intros j g x. exact (ap f (legs_comm _ i j g x)). Defined. (** ** Universality of a cocone. *) (** A colimit will be the extremity of a universal cocone. *) (** A cocone [C] over [D] to [X] is said universal when for all [Y] the map [cocone_postcompose] is an equivalence. In particular, given another cocone [C'] over [D] to [X'] the inverse of the map allows to recover a map [h] : [X] -> [X'] such that [C'] is [C] postcomposed with [h]. The fact that [cocone_postcompose] is an equivalence is an elegant way of stating the usual "unique existence" of category theory. *) Class UniversalCocone (C : Cocone D X) := { is_universal : forall Y, IsEquiv (@cocone_postcompose C Y); }. (* Use :> and remove the two following lines, once Coq 8.16 is the minimum required version. *) #[export] Existing Instance is_universal. Coercion is_universal : UniversalCocone >-> Funclass. End Cocone. (** We now prove several functoriality results, first on cocone and then on colimits. *) Section FunctorialityCocone. Context `{Funext} {G: Graph}. (** ** Postcomposition for cocones *) (** Identity and associativity for the postcomposition of a cocone with a map. *) Definition cocone_postcompose_identity {D : Diagram G} `(C : Cocone _ D X) : cocone_postcompose C idmap = C. Proof. srapply path_cocone; intro i. 1: reflexivity. intros j g x; simpl. apply equiv_p1_1q, ap_idmap. Defined. Definition cocone_postcompose_comp {D : Diagram G} `(f : X -> Y) `(g : Y -> Z) (C : Cocone D X) : cocone_postcompose C (g o f) = cocone_postcompose (cocone_postcompose C f) g. Proof. srapply path_cocone; intro i. 1: reflexivity. intros j h x; simpl. apply equiv_p1_1q, ap_compose. Defined. (** ** Precomposition for cocones *) (** Given a cocone over [D2] and a Diagram map [m] : [D1] => [D2], one can precompose each map of the cocone by the corresponding one of [m] to get a cocone over [D1]. *) Definition cocone_precompose {D1 D2: Diagram G} (m : DiagramMap D1 D2) {X} : (Cocone D2 X) -> (Cocone D1 X). Proof. intro C. srapply Build_Cocone; intro i. 1: exact (C i o m i). intros j g x; simpl. etransitivity. + apply ap. symmetry. apply DiagramMap_comm. + apply legs_comm. Defined. (** Identity and associativity for the precomposition of a cocone with a diagram map. *) Definition cocone_precompose_identity (D : Diagram G) (X : Type) : cocone_precompose (X:=X) (diagram_idmap D) == idmap. Proof. intro C; srapply path_cocone; simpl. 1: reflexivity. intros; simpl. apply concat_p1. Defined. Definition cocone_precompose_comp {D1 D2 D3 : Diagram G} (m2 : DiagramMap D2 D3) (m1 : DiagramMap D1 D2) (X : Type) : (cocone_precompose (X:=X) m1) o (cocone_precompose m2) == cocone_precompose (diagram_comp m2 m1). Proof. intro C; simpl. srapply path_cocone. 1: reflexivity. intros i j g x; simpl. apply equiv_p1_1q. unfold CommutativeSquares.comm_square_comp. refine (concat_p_pp _ _ _ @ _). apply ap10, ap. rewrite 3 ap_V. refine ((inv_pp _ _)^ @ _). apply inverse2. rewrite ap_pp. apply ap. by rewrite ap_compose. Defined. (** Associativity of a precomposition and a postcomposition. *) Definition cocone_precompose_postcompose {D1 D2 : Diagram G} (m : DiagramMap D1 D2) `(f : X -> Y) (C : Cocone D2 X) : cocone_postcompose (cocone_precompose m C) f = cocone_precompose m (cocone_postcompose C f). Proof. srapply path_cocone; intro i. 1: reflexivity. intros j g x; simpl. apply equiv_p1_1q. etransitivity. + apply ap_pp. + apply ap10, ap. symmetry. apply ap_compose. Defined. (** The precomposition with a diagram equivalence is an equivalence. *) Global Instance cocone_precompose_equiv {D1 D2 : Diagram G} (m : D1 ~d~ D2) (X : Type) : IsEquiv (cocone_precompose (X:=X) m). Proof. srapply isequiv_adjointify. 1: apply (cocone_precompose (diagram_equiv_inv m)). + intros C. etransitivity. - apply cocone_precompose_comp. - rewrite diagram_inv_is_retraction. apply cocone_precompose_identity. + intros C. etransitivity. - apply cocone_precompose_comp. - rewrite diagram_inv_is_section. apply cocone_precompose_identity. Defined. (** The postcomposition with an equivalence is an equivalence. *) Global Instance cocone_postcompose_equiv {D : Diagram G} `(f : X <~> Y) : IsEquiv (fun C : Cocone D X => cocone_postcompose C f). Proof. srapply isequiv_adjointify. 1: exact (fun C => cocone_postcompose C f^-1). + intros C. etransitivity. - symmetry. apply cocone_postcompose_comp. - etransitivity. 2: apply cocone_postcompose_identity. apply ap. funext x; apply eisretr. + intros C. etransitivity. - symmetry. apply cocone_postcompose_comp. - etransitivity. 2: apply cocone_postcompose_identity. apply ap. funext x; apply eissect. Defined. (** ** Universality preservation *) (** Universality of a cocone is preserved by composition with a (diagram) equivalence. *) Global Instance cocone_precompose_equiv_universality {D1 D2 : Diagram G} (m: D1 ~d~ D2) {X} (C : Cocone D2 X) (_ : UniversalCocone C) : UniversalCocone (cocone_precompose (X:=X) m C). Proof. srapply Build_UniversalCocone; intro. rewrite (path_forall _ _ (fun f => cocone_precompose_postcompose m f C)). srapply isequiv_compose. Defined. Global Instance cocone_postcompose_equiv_universality {D: Diagram G} `(f: X <~> Y) (C : Cocone D X) (_ : UniversalCocone C) : UniversalCocone (cocone_postcompose C f). Proof. snrapply Build_UniversalCocone; intro. rewrite <- (path_forall _ _ (fun g => cocone_postcompose_comp f g C)). srapply isequiv_compose. Defined. End FunctorialityCocone. Coq-HoTT-9.0/theories/Diagrams/CommutativeSquares.v000066400000000000000000000075261474641544500223510ustar00rootroot00000000000000Require Import Basics.Overture Basics.PathGroupoids Basics.Tactics. (** * Comutative squares *) (** Commutative squares compose vertically. A --f--> B | // | h comm g | // | V // V C --f'-> D | // | h' comm' g' | // | V // V E --f''> F *) Lemma comm_square_comp {A B C D E F} {f : A -> B} {f': C -> D} {h : A -> C} {g : B -> D} (comm : f' o h == g o f) {f'': E -> F} {h' : C -> E} {g' : D -> F} (comm' : f'' o h' == g' o f') : f'' o (h' o h) == (g' o g) o f. Proof. intros x. path_via (g' (f' (h x))). apply ap, comm. Defined. (** Commutative squares compose horizontally. A --k--> B --l--> C | // | // | f comm g comm h | // | // | V // V // V X --i--> Y --j--> Z *) Lemma comm_square_comp' {A B C X Y Z : Type} {k : A -> B} {l : B -> C} {f : A -> X} {g : B -> Y} {h : C -> Z} {i : X -> Y} {j : Y -> Z} (H : i o f == g o k) (K : j o g == h o l) : (j o i) o f == h o (l o k). Proof. intros x. path_via (j (g (k x))). apply ap, H. Defined. (** Given any commutative square from [f] to [f'] whose verticals [wA, wB] are equivalences, the equiv_inv square from [f'] to [f] with verticals [wA ^-1, wB ^-1] also commutes. *) Lemma comm_square_inverse {A B : Type} {f : A -> B} {A' B' : Type} {f' : A' -> B'} {wA : A <~> A'} {wB : B <~> B'} (wf : f' o wA == wB o f) : f o (wA ^-1) == (wB ^-1) o f'. Proof. intros a'. path_via (wB ^-1 (wB (f (wA ^-1 a')))). - apply inverse, eissect. - apply ap, (concat (wf _)^). apply ap, eisretr. Defined. (** Up to naturality, the result of [comm_square_inverse] really is a retraction (aka left inverse); *) Lemma comm_square_inverse_is_sect {A B : Type} {f : A -> B} {A' B' : Type} {f' : A' -> B'} (wA : A <~> A') (wB : B <~> B') (wf : f' o wA == wB o f) (a : A) : comm_square_comp wf (comm_square_inverse wf) a @ eissect wB (f a) = ap f (eissect wA a). Proof. unfold comm_square_inverse, comm_square_comp; simpl. repeat apply (concat (concat_pp_p _ _ _)). apply moveR_Vp. transitivity (ap (wB ^-1 o wB) (ap f (eissect wA a)) @ eissect wB (f a)). 2: apply (concat (concat_Ap (eissect wB) _)). 2: apply ap, ap_idmap. apply (concat (concat_p_pp _ _ _)), whiskerR. apply (concat (ap_pp (wB ^-1) _ _)^), (concatR (ap_compose wB _ _)^). apply ap, (concat (concat_pp_p _ _ _)), moveR_Vp. path_via (ap (f' o wA) (eissect wA a) @ wf a). - apply whiskerR. apply (concatR (ap_compose wA f' _)^). apply ap, eisadj. - apply (concat (concat_Ap wf _)). apply whiskerL, (ap_compose f wB). Defined. (** and similarly, [comm_square_inverse] is a section (aka right equiv_inv). *) Lemma comm_square_inverse_is_retr {A B : Type} {f : A -> B} {A' B' : Type} {f' : A' -> B'} (wA : A <~> A') (wB : B <~> B') (wf : f' o wA == wB o f) (a : A') : comm_square_comp (comm_square_inverse wf) wf a @ eisretr wB (f' a) = ap f' (eisretr wA a). Proof. unfold comm_square_inverse, comm_square_comp; simpl. rewrite !ap_pp. rewrite <- !concat_pp_p. rewrite concat_pp_p. set (p := (ap wB (ap (wB ^-1) (ap f' (eisretr wA a))) @ eisretr wB (f' a))). path_via ((eisretr wB _)^ @ p). - apply whiskerR. apply moveR_pM. path_via ((eisretr wB (f' (wA (wA ^-1 a))))^ @ ap (wB o wB ^-1) (wf ((wA ^-1) a))). + rewrite ap_V, <- eisadj. transitivity (ap idmap (wf ((wA ^-1) a)) @ (eisretr wB (wB (f ((wA ^-1) a))))^). * apply whiskerR, inverse, ap_idmap. * apply (concat_Ap (fun b' => (eisretr wB b')^) _). + apply ap. rewrite ap_compose, !ap_V. apply inverse, inv_V. - apply moveR_Vp. subst p. rewrite <- ap_compose. path_via (eisretr wB _ @ ap idmap (ap f' (eisretr wA a))). + apply (concat_Ap (eisretr wB) _). + apply ap, ap_idmap. Defined. Coq-HoTT-9.0/theories/Diagrams/Cone.v000066400000000000000000000176501474641544500173730ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Graph. Require Import Diagrams.Diagram. Local Open Scope path_scope. Generalizable All Variables. (** * Cones *) (** A Cone over a diagram [D] to a type [X] is a family of maps from [X] to the types of [D] making the triangles formed with the arrows of [D] commuting. *) Class Cone (X : Type) {G : Graph} (D : Diagram G) := { legs : forall i, X -> D i; legs_comm : forall i j (g : G i j), (D _f g) o legs i == legs j; }. Arguments Build_Cone {X G D} legs legs_comm. Arguments legs {X G D} C i x : rename. Arguments legs_comm {X G D} C i j g x : rename. Coercion legs : Cone >-> Funclass. Section Cone. Context `{Funext} {X : Type} {G : Graph} {D : Diagram G}. (** [path_cone] says when two cones are equals (up to funext). *) Definition path_cocone_naive {C1 C2 : Cone X D} (P := fun q' => forall (i j : G) (g : G i j) (x : X), D _f g (q' i x) = q' j x) (path_legs : legs C1 = legs C2) (path_legs_comm : transport P path_legs (legs_comm C1) = legs_comm C2) : C1 = C2 := match path_legs_comm in (_ = v1) return C1 = {|legs := legs C2; legs_comm := v1 |} with | idpath => match path_legs in (_ = v0) return C1 = {|legs := v0; legs_comm := path_legs # (legs_comm C1) |} with | idpath => 1 end end. Definition path_cone {C1 C2 : Cone X D} (path_legs : forall i, C1 i == C2 i) (path_legs_comm : forall i j g x, legs_comm C1 i j g x @ path_legs j x = ap (D _f g) (path_legs i x) @ legs_comm C2 i j g x) : C1 = C2. Proof. destruct C1 as [legs pp_q], C2 as [r pp_r]. refine (path_cocone_naive (path_forall _ _ (fun i => path_forall _ _ (path_legs i))) _). cbn; funext i j f x. rewrite 4 transport_forall_constant, transport_paths_FlFr. rewrite concat_pp_p; apply moveR_Vp. rewrite ap_compose. rewrite 2 (ap_apply_lD2 (path_forall legs r (fun i => path_forall (legs i) (r i) (path_legs i)))). rewrite 3 eisretr. apply path_legs_comm. Defined. (** ** Precomposition for cones *) (** Given a cone [C] from [X] and a map from [Y] to [X], one can precompose each map of [C] to get a cone from [Y]. *) Definition cone_precompose (C : Cone X D) {Y : Type} (f : Y -> X) : Cone Y D. Proof. srapply Build_Cone; intro i. 1: exact (C i o f). intros j g x. apply legs_comm. Defined. (** ** Universality of a cone. *) (** A limit will be the extremity of an universal cone. *) (** A cone [C] over [D] from [X] is said universal when for all [Y] the map [cone_precompose] is an equivalence. In particular, given another cone [C'] over [D] from [X'] the inverse of the map allows us to recover a map [h] : [X] -> [X'] such that [C'] is [C] precomposed with [h]. The fact that [cone_precompose] is an equivalence is an elegant way of stating the usual "unique existence" of category theory. *) Class UniversalCone (C : Cone X D) := { is_universal : forall Y, IsEquiv (@cone_precompose C Y); }. (* Use :> and remove the two following lines, once Coq 8.16 is the minimum required version. *) #[export] Existing Instance is_universal. Coercion is_universal : UniversalCone >-> Funclass. End Cone. (** We now prove several functoriality results, first on cone and then on limits. *) Section FunctorialityCone. Context `{Funext} {G : Graph}. (** ** Precomposition for cones *) (** Identity and associativity for the precomposition of a cone with a map. *) Definition cone_precompose_identity {D : Diagram G} `(C : Cone X _ D) : cone_precompose C idmap = C. Proof. srapply path_cone; intro i. 1: reflexivity. intros j g x; simpl. apply concat_p1_1p. Defined. Definition cone_precompose_comp {D : Diagram G} `(f : Z -> Y) `(g : Y -> X) (C : Cone X D) : cone_precompose C (g o f) = cone_precompose (cone_precompose C g) f. Proof. srapply path_cone; intro i. 1: reflexivity. intros j h x; simpl. apply concat_p1_1p. Defined. (** ** Postcomposition for cones *) (** Given a cocone over [D2] and a Diagram map [m] : [D1] => [D2], one can postcompose each map of the cone by the corresponding one of [m] to get a cone over [D1]. *) Definition cone_postcompose {D1 D2 : Diagram G} (m : DiagramMap D1 D2) {X} : (Cone X D1) -> (Cone X D2). Proof. intro C. srapply Build_Cone; intro i. 1: exact (m i o C i). intros j g x; simpl. etransitivity. 1: apply DiagramMap_comm. apply ap, legs_comm. Defined. (** Identity and associativity for the postcomposition of a cone with a diagram map. *) Definition cone_postcompose_identity (D : Diagram G) (X : Type) : cone_postcompose (X:=X) (diagram_idmap D) == idmap. Proof. intro C; srapply path_cone; simpl. 1: reflexivity. intros; simpl. refine (_ @ (concat_1p _)^). refine (concat_p1 _ @ concat_1p _ @ ap_idmap _). Defined. Definition cone_postcompose_comp {D1 D2 D3 : Diagram G} (m2 : DiagramMap D2 D3) (m1 : DiagramMap D1 D2) (X : Type) : (cone_postcompose (X:=X) m2) o (cone_postcompose m1) == cone_postcompose (diagram_comp m2 m1). Proof. intro C; simpl. srapply path_cone. 1: reflexivity. intros i j g x; simpl. apply equiv_p1_1q. unfold CommutativeSquares.comm_square_comp. refine (_ @ concat_p_pp _ _ _). apply ap. rewrite ap_pp. apply ap. symmetry. by apply ap_compose. Defined. (** Associativity of a postcomposition and a precomposition. *) Definition cone_postcompose_precompose {D1 D2 : Diagram G} (m : DiagramMap D1 D2) `(f : Y -> X) (C : Cone X D1) : cone_precompose (cone_postcompose m C) f = cone_postcompose m (cone_precompose C f). Proof. srapply path_cone; intro i. 1: reflexivity. intros j g x; simpl. apply concat_p1_1p. Defined. (** The postcomposition with a diagram equivalence is an equivalence. *) Global Instance cone_precompose_equiv {D1 D2 : Diagram G} (m : D1 ~d~ D2) (X : Type) : IsEquiv (cone_postcompose (X:=X) m). Proof. srapply isequiv_adjointify. 1: apply (cone_postcompose (diagram_equiv_inv m)). + intros C. etransitivity. - apply cone_postcompose_comp. - rewrite diagram_inv_is_section. apply cone_postcompose_identity. + intros C. etransitivity. - apply cone_postcompose_comp. - rewrite diagram_inv_is_retraction. apply cone_postcompose_identity. Defined. (** The precomposition with an equivalence is an equivalence. *) Global Instance cone_postcompose_equiv {D : Diagram G} `(f : Y <~> X) : IsEquiv (fun C : Cone X D => cone_precompose C f). Proof. srapply isequiv_adjointify. 1: exact (fun C => cone_precompose C f^-1). + intros C. etransitivity. - symmetry. apply cone_precompose_comp. - etransitivity. 2: apply cone_precompose_identity. apply ap. funext x; apply eissect. + intros C. etransitivity. - symmetry. apply cone_precompose_comp. - etransitivity. 2: apply cone_precompose_identity. apply ap. funext x; apply eisretr. Defined. (** ** Universality preservation *) (** Universality of a cone is preserved by composition with a (diagram) equivalence. *) Global Instance cone_postcompose_equiv_universality {D1 D2 : Diagram G} (m: D1 ~d~ D2) {X} (C : Cone X D1) (_ : UniversalCone C) : UniversalCone (cone_postcompose (X:=X) m C). Proof. srapply Build_UniversalCone; intro. rewrite (path_forall _ _ (fun f => cone_postcompose_precompose m f C)). srapply isequiv_compose. Defined. Global Instance cone_precompose_equiv_universality {D: Diagram G} `(f: Y <~> X) (C : Cone X D) (_ : UniversalCone C) : UniversalCone (cone_precompose C f). Proof. srapply Build_UniversalCone; intro. rewrite <- (path_forall _ _ (fun g => cone_precompose_comp g f C)). srapply isequiv_compose. Defined. End FunctorialityCone. Coq-HoTT-9.0/theories/Diagrams/ConstantDiagram.v000066400000000000000000000036721474641544500215640ustar00rootroot00000000000000Require Import Basics Types.Paths. Require Import Cone. Require Import Cocone. Require Import Diagram. Require Import Graph. (** * Constant diagram *) Section ConstantDiagram. Context {G : Graph}. Definition diagram_const (C : Type) : Diagram G. Proof. srapply Build_Diagram. 1: exact (fun _ => C). intros i j k. exact idmap. Defined. Definition diagram_const_functor {A B : Type} (f : A -> B) : DiagramMap (diagram_const A) (diagram_const B). Proof. srapply Build_DiagramMap. 1: intro i; exact f. reflexivity. Defined. Definition diagram_const_functor_comp {A B C : Type} (f : A -> B) (g : B -> C) : diagram_const_functor (g o f) = diagram_comp (diagram_const_functor g) (diagram_const_functor f) := idpath. Definition diagram_const_functor_idmap {A : Type} : diagram_const_functor (idmap : A -> A) = diagram_idmap (diagram_const A) := idpath. Definition equiv_diagram_const_cocone `{Funext} (D : Diagram G) (X : Type) : DiagramMap D (diagram_const X) <~> Cocone D X. Proof. srapply equiv_adjointify. (* The two functions are defined in parallel: *) 1,2: intros [? w]; econstructor. (* This reversal is a defect in the definition of [Cocone]. *) 1,2: intros x y z z'; symmetry; revert x y z z'. 1,2: exact w. (* The two homotopies are proved in parallel: *) 1,2: intros []. 1: srapply path_cocone; cbn. 3: srapply path_DiagramMap; snrefine (_; _); cbn. 1,3: reflexivity. 1,2: intros; cbn. 1,2: apply equiv_p1_1q. 1,2: apply inv_V. Defined. Definition equiv_diagram_const_cone `{Funext} (X : Type) (D : Diagram G) : DiagramMap (diagram_const X) D <~> Cone X D. Proof. srapply equiv_adjointify. 1,2: intros [? w]; econstructor. 1,2: exact w. 1,2: intros[]. 1: srapply path_cone. 3: srapply path_DiagramMap. 1,3: reflexivity. all: cbn; intros; hott_simpl. Defined. End ConstantDiagram. Coq-HoTT-9.0/theories/Diagrams/DDiagram.v000066400000000000000000000022551474641544500201520ustar00rootroot00000000000000Require Import Basics. Require Import Diagrams.Graph. Require Import Diagrams.Diagram. (** We define here the Graph ∫D, also denoted G·D *) Definition integral {G : Graph} (D : Diagram G) : Graph. Proof. srapply Build_Graph. + exact {i : G & D i}. + intros i j. exact {g : G i.1 j.1 & D _f g i.2 = j.2}. Defined. (** Then, a dependent diagram E over D is just a diagram over ∫D. *) Definition DDiagram {G : Graph} (D : Diagram G) := Diagram (integral D). (** Given a dependent diagram, we c.an recover a diagram over G by considering the Σ types. *) Definition diagram_sigma {G : Graph} {D : Diagram G} (E : DDiagram D) : Diagram G. Proof. srapply Build_Diagram. - intro i. exact {x : D i & E (i; x)}. - intros i j g x. simpl in *. exists (D _f g x.1). exact (@arr _ E (i; x.1) (j; D _f g x.1) (g; idpath) x.2). Defined. (** A dependent diagram is said equifibered if all its fibers are equivalences. *) Class Equifibered {G : Graph} {D : Diagram G} (E : DDiagram D) := { isequifibered i j (g : G i j) (x : D i) : IsEquiv (@arr _ E (i; x) (j; D _f g x) (g; idpath)); }. #[export] Existing Instance isequifibered. Coq-HoTT-9.0/theories/Diagrams/Diagram.v000066400000000000000000000156071474641544500200530ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import HoTT.Tactics. Require Import Diagrams.CommutativeSquares. Require Import Diagrams.Graph. Local Open Scope path_scope. (** This file contains the definition of diagrams, diagram maps and equivalences of diagrams. *) (** * Diagrams *) (** A [Diagram] over a graph [G] associates a type to each point of the graph and a function to each arrow. *) Record Diagram (G : Graph) := { obj : G -> Type; arr {i j : G} : G i j -> obj i -> obj j }. Arguments obj [G] D i : rename. Arguments arr [G] D [i j] g x : rename. Coercion obj : Diagram >-> Funclass. Notation "D '_f' g" := (arr D g). Section Diagram. Context `{Funext} {G: Graph}. (** [path_diagram] says when two diagrams are equals (up to funext). *) Definition path_diagram_naive (D1 D2 : Diagram G) (P := fun D' => forall i j, G i j -> (D' i -> D' j)) (path_obj : obj D1 = obj D2) (path_arr : transport P path_obj (arr D1) = arr D2) : D1 = D2 := match path_arr in (_ = v1) return D1 = {|obj := obj D2; arr := v1 |} with | idpath => match path_obj in (_ = v0) return D1 = {|obj := v0; arr := path_obj # (arr D1) |} with | idpath => 1 end end. Definition path_diagram (D1 D2 : Diagram G) (path_obj : forall i, D1 i = D2 i) (path_arr : forall i j (g : G i j) x, transport idmap (path_obj j) (D1 _f g x) = D2 _f g (transport idmap (path_obj i) x)) : D1 = D2. Proof. srapply path_diagram_naive; funext i. 1: apply path_obj. funext j g x. rewrite 3 transport_forall_constant, transport_arrow. transport_path_forall_hammer. refine (_ @ path_arr i j g (transport idmap (path_obj i)^ x) @ _). { do 3 f_ap. rewrite <- path_forall_V. funext y. by transport_path_forall_hammer. } f_ap. exact (transport_pV idmap _ x). Defined. (** * Diagram map *) (** A map between two diagrams is a family of maps between the types of the diagrams making commuting the squares formed with the arrows. *) Record DiagramMap (D1 D2 : Diagram G) := { DiagramMap_obj :> forall i, D1 i -> D2 i; DiagramMap_comm : forall i j (g: G i j) x, D2 _f g (DiagramMap_obj i x) = DiagramMap_obj j (D1 _f g x) }. Global Arguments DiagramMap_obj [D1 D2] m i x : rename. Global Arguments DiagramMap_comm [D1 D2] m [i j] f x : rename. Global Arguments Build_DiagramMap [D1 D2] _ _. Definition DiagramMap_homotopy {D1 D2 : Diagram G} (m1 m2 : DiagramMap D1 D2) : Type := {h_obj : (forall i, m1 i == m2 i) & (forall i j (g : G i j) x, DiagramMap_comm m1 g x @ h_obj j (D1 _f g x) = ap (D2 _f g) (h_obj i x) @ DiagramMap_comm m2 g x)}. Global Instance reflexive_DiagramMap_homotopy {D1 D2 : Diagram G} : Reflexive (@DiagramMap_homotopy D1 D2). Proof. intros m. snrapply exist. - intro i; reflexivity. - intros i j g x; cbn. apply concat_p1_1p. Defined. (** [path_DiagramMap] says when two maps are equals (up to funext). *) Definition path_DiagramMap {D1 D2 : Diagram G} {m1 m2 : DiagramMap D1 D2} (h : DiagramMap_homotopy m1 m2) : m1 = m2. Proof. destruct m1 as [m1_obj m1_comm]. destruct m2 as [m2_obj m2_comm]. simpl in *. destruct h as [h_obj h_comm]. revert h_obj h_comm. set (E := (@equiv_functor_forall _ G (fun i => m1_obj i = m2_obj i) G (fun i => m1_obj i == m2_obj i) idmap _ (fun i => @apD10 _ _ (m1_obj i) (m2_obj i))) (fun i => isequiv_apD10 _ _ _ _)). equiv_intro E h_obj. revert h_obj. equiv_intro (@apD10 _ _ m1_obj m2_obj) h_obj. destruct h_obj; simpl. intros h_comm. assert (HH : m1_comm = m2_comm). { funext i j f x. apply (concatR (concat_1p _)). apply (concatR (h_comm _ _ _ _)). apply inverse, concat_p1. } destruct HH. reflexivity. Defined. (** ** Identity and composition for diagram maps. *) Definition diagram_idmap (D : Diagram G) : DiagramMap D D := Build_DiagramMap (fun _ => idmap) (fun _ _ _ _ => 1). Definition diagram_comp {D1 D2 D3 : Diagram G} (m2 : DiagramMap D2 D3) (m1 : DiagramMap D1 D2) : DiagramMap D1 D3. Proof. apply (Build_DiagramMap (fun i => m2 i o m1 i)). intros i j f. exact (comm_square_comp (DiagramMap_comm m1 f) (DiagramMap_comm m2 f)). Defined. (** * Diagram equivalences *) (** An equivalence of diagram is a diagram map whose functions are equivalences. *) Record diagram_equiv (D1 D2: Diagram G) := { diag_equiv_map :> DiagramMap D1 D2; diag_equiv_isequiv : forall i, IsEquiv (diag_equiv_map i) }. Global Arguments diag_equiv_map [D1 D2] e : rename. Global Arguments diag_equiv_isequiv [D1 D2] e i : rename. Global Arguments Build_diagram_equiv [D1 D2] m H : rename. (** Inverse, section and retraction of equivalences of diagrams. *) Lemma diagram_equiv_inv {D1 D2 : Diagram G} (w : diagram_equiv D1 D2) : DiagramMap D2 D1. Proof. apply (Build_DiagramMap (fun i => (Build_Equiv _ _ _ (diag_equiv_isequiv w i))^-1)). intros i j f. apply (@comm_square_inverse _ _ _ _ _ _ (Build_Equiv _ _ _ (diag_equiv_isequiv w i)) (Build_Equiv _ _ _ (diag_equiv_isequiv w j))). intros x; apply DiagramMap_comm. Defined. Lemma diagram_inv_is_section {D1 D2 : Diagram G} (w : diagram_equiv D1 D2) : diagram_comp w (diagram_equiv_inv w) = diagram_idmap D2. Proof. destruct w as [[w_obj w_comm] is_eq_w]. simpl in *. set (we i := Build_Equiv _ _ _ (is_eq_w i)). apply path_DiagramMap. exists (fun i => eisretr (we i)). simpl. intros i j f x. rhs nrapply concat_p1. apply (comm_square_inverse_is_retr (we i) (we j) _ x). Defined. Lemma diagram_inv_is_retraction {D1 D2 : Diagram G} (w : diagram_equiv D1 D2) : diagram_comp (diagram_equiv_inv w) w = diagram_idmap D1. Proof. destruct w as [[w_obj w_comm] is_eq_w]. simpl in *. set (we i := Build_Equiv _ _ _ (is_eq_w i)). apply path_DiagramMap. exists (fun i => eissect (we i)). simpl. intros i j f x. rhs nrapply concat_p1. apply (comm_square_inverse_is_sect (we i) (we j) _ x). Defined. (** The equivalence of diagram is an equivalence relation. *) (** Those instances allows to use the tactics reflexivity, symmetry and transitivity. *) Global Instance reflexive_diagram_equiv : Reflexive diagram_equiv | 1 := fun D => Build_diagram_equiv (diagram_idmap D) _. Global Instance symmetric_diagram_equiv : Symmetric diagram_equiv | 1 := fun D1 D2 m => Build_diagram_equiv (diagram_equiv_inv m) _. Global Instance transitive_diagram_equiv : Transitive diagram_equiv | 1. Proof. intros D1 D2 D3 m1 m2. nrapply (Build_diagram_equiv (diagram_comp m2 m1)). intros i. simpl. apply isequiv_compose'; [apply m1 | apply m2]. Defined. End Diagram. Notation "D1 ~d~ D2" := (diagram_equiv D1 D2). Coq-HoTT-9.0/theories/Diagrams/Graph.v000066400000000000000000000004671474641544500175460ustar00rootroot00000000000000Require Import Basics.Overture. (** * Graphs *) (** A [Graph] is a type [graph0] of points together with a type [graph1] of arrows between each points. *) Record Graph := { graph0 : Type; graph1 : graph0 -> graph0 -> Type; }. Coercion graph0 : Graph >-> Sortclass. Coercion graph1 : Graph >-> Funclass. Coq-HoTT-9.0/theories/Diagrams/ParallelPair.v000066400000000000000000000015231474641544500210470ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Graph. Require Import Diagrams.Diagram. Require Import Diagrams.Cocone. (** Parallel pairs *) Definition parallel_pair_graph : Graph. Proof. srapply (Build_Graph Bool). intros i j. exact (if i then if j then Empty else Bool else Empty). Defined. (** Parallel pair diagram *) Definition parallel_pair {A B : Type} (f g : A -> B) : Diagram parallel_pair_graph. Proof. srapply Build_Diagram. 1: intros []; [exact A | exact B]. intros [] [] []; [exact f | exact g]. Defined. (** Cones on [parallel_pair]s *) Definition Build_parallel_pair_cocone {A B Q} {f g : B -> A} `(q: A -> Q) (Hq: q o g == q o f) : Cocone (parallel_pair f g) Q. Proof. srapply Build_Cocone. 1: intros []; [exact (q o f) | exact q]. intros [] [] []; [reflexivity | exact Hq]. Defined.Coq-HoTT-9.0/theories/Diagrams/Sequence.v000066400000000000000000000022441474641544500202500ustar00rootroot00000000000000Require Import Basics. Require Import Diagrams.Graph. Require Import Diagrams.Diagram. Local Open Scope nat_scope. Local Open Scope path_scope. (** * Sequence *) (** A Sequence is a sequence of maps from [X(n)] to [X(n+1)]. *) Definition sequence_graph : Graph. Proof. srapply (Build_Graph nat). intros n m; exact (S n = m). Defined. Definition Sequence := Diagram sequence_graph. Definition Build_Sequence (X : nat -> Type) (f : forall n, X n -> X n.+1) : Sequence. Proof. srapply Build_Diagram. 1: exact X. intros ? ? p. destruct p. apply f. Defined. (** A useful lemma to show than two sequences are equivalent. *) Definition equiv_sequence (D1 D2 : Sequence) (H0 : (D1 0) <~> (D2 0)) (Hn: forall n (e: (D1 n) <~> (D2 n)), {e' : (D1 n.+1) <~> (D2 n.+1) & (D2 _f 1) o e == e' o (D1 _f 1)}) : D1 ~d~ D2. Proof. srapply (Build_diagram_equiv (Build_DiagramMap _ _)); intro n; simpl. - apply equiv_fun. induction n. + apply H0. + exact (Hn n IHn).1. - intros m q; destruct q. induction n; simpl. + exact (Hn 0 H0).2. + simple refine (Hn n.+1 _).2. - induction n; simpl. + apply H0. + apply (Hn n _ ).1. Defined. Coq-HoTT-9.0/theories/Diagrams/Span.v000066400000000000000000000013061474641544500173770ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Diagrams.Graph. Require Import Diagrams.Diagram. (** The underlying graph of a span. *) Definition span_graph : Graph. Proof. srapply (Build_Graph (Unit + Bool)). intros [i|i] [j|j]. 2: exact Unit. all: exact Empty. Defined. Section Span. Context {A B C : Type}. (** A span is a diagram: f g B <-- A --> C *) Definition span (f : A -> B) (g : A -> C) : Diagram span_graph. Proof. srapply Build_Diagram. - intros [i|i]. + exact A. + exact (if i then B else C). - intros [i|i] [j|j] u; cbn; try contradiction. destruct j. + exact f. + exact g. Defined. End Span.Coq-HoTT-9.0/theories/Equiv/000077500000000000000000000000001474641544500156515ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Equiv/BiInv.v000066400000000000000000000027641474641544500170600ustar00rootroot00000000000000Require Import Basics Types.Prod Types.Equiv. Local Open Scope path_scope. Generalizable Variables A B f. (** * Bi-invertible maps *) (** A map is "bi-invertible" if it has both a section and a retraction, not necessarily the same. This definition of equivalence was proposed by Andre Joyal. *) Definition BiInv `(f : A -> B) : Type := {g : B -> A & g o f == idmap} * {h : B -> A & f o h == idmap}. (** It seems that the easiest way to show that bi-invertibility is equivalent to being an equivalence is also to show that both are h-props and that they are logically equivalent. *) Definition isequiv_biinv `(f : A -> B) : BiInv f -> IsEquiv f. Proof. intros [[g s] [h r]]. exact (isequiv_adjointify f g (fun x => ap f (ap g (r x)^ @ s (h x)) @ r x) s). Defined. Definition biinv_isequiv `(f : A -> B) : IsEquiv f -> BiInv f. Proof. intros [g s r adj]. exact ((g; r), (g; s)). Defined. Definition iff_biinv_isequiv `(f : A -> B) : BiInv f <-> IsEquiv f. Proof. split. - apply isequiv_biinv. - apply biinv_isequiv. Defined. Global Instance ishprop_biinv `{Funext} `(f : A -> B) : IsHProp (BiInv f) | 0. Proof. apply hprop_inhabited_contr. intros bif; pose (fe := isequiv_biinv f bif). apply @contr_prod. (* For this, we've done all the work already. *) - by apply contr_retr_equiv. - by apply contr_sect_equiv. Defined. Definition equiv_biinv_isequiv `{Funext} `(f : A -> B) : BiInv f <~> IsEquiv f. Proof. apply equiv_iff_hprop_uncurried, iff_biinv_isequiv. Defined. Coq-HoTT-9.0/theories/Equiv/PathSplit.v000066400000000000000000000072031474641544500177520ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Local Open Scope nat_scope. Local Open Scope path_scope. Generalizable Variables A B f. Section AssumeFunext. Context `{Funext}. (** * n-Path-split maps. A map is n-path-split if its induced maps on the first n iterated path-spaces are split surjections. Thus every map is 0-path-split, the 1-path-split maps are the split surjections, and so on. It turns out that for n>1, being n-path-split is the same as being an equivalence. *) Fixpoint PathSplit (n : nat) `(f : A -> B) : Type := match n with | 0 => Unit | S n => (forall a, hfiber f a) * forall (x y : A), PathSplit n (@ap _ _ f x y) end. Definition isequiv_pathsplit (n : nat) `{f : A -> B} : PathSplit n.+2 f -> IsEquiv f. Proof. intros [g k]. pose (h := fun x y p => (fst (k x y) p).1). pose (hs := fun x y => (fun p => (fst (k x y) p).2) : (ap f) o (h x y) == idmap). clearbody hs; clearbody h; clear k. apply isequiv_contr_map; intros b. apply contr_inhabited_hprop. 2:exact (g b). apply hprop_allpath; intros [a p] [a' p']. refine (path_sigma' _ (h a a' (p @ p'^)) _). refine (transport_paths_Fl _ _ @ _). refine ((inverse2 (hs a a' (p @ p'^)) @@ 1) @ _). refine ((inv_pp p p'^ @@ 1) @ _). refine (concat_pp_p _ _ _ @ _). refine ((1 @@ concat_Vp _) @ _). exact ((inv_V p' @@ 1) @ concat_p1 _). Defined. Global Instance contr_pathsplit_isequiv (n : nat) `(f : A -> B) `{IsEquiv _ _ f} : Contr (PathSplit n f). Proof. generalize dependent B; revert A. simple_induction n n IHn; intros A B f ?. - exact _. - apply contr_prod. Defined. Global Instance ishprop_pathsplit (n : nat) `(f : A -> B) : IsHProp (PathSplit n.+2 f). Proof. apply hprop_inhabited_contr; intros ps. pose (isequiv_pathsplit n ps). exact _. Defined. Definition equiv_pathsplit_isequiv (n : nat) `(f : A -> B) : PathSplit n.+2 f <~> IsEquiv f. Proof. refine (equiv_iff_hprop _ _). - apply isequiv_pathsplit. - intros ?; refine (center _). Defined. (** Path-splitness transfers across commutative squares of equivalences. *) Lemma equiv_functor_pathsplit (n : nat) {A B C D} (f : A -> B) (g : C -> D) (h : A <~> C) (k : B <~> D) (p : g o h == k o f) : PathSplit n f <~> PathSplit n g. Proof. destruct n as [|n]. 1:apply equiv_idmap. destruct n as [|n]. - simpl. refine (_ *E equiv_contr_contr). refine (equiv_functor_forall' k^-1 _); intros d. unfold hfiber. refine (equiv_functor_sigma' h _); intros a. refine (equiv_concat_l (p a) d oE _). simpl; apply equiv_moveR_equiv_M. - refine (_ oE equiv_pathsplit_isequiv n f). refine ((equiv_pathsplit_isequiv n g)^-1 oE _). apply equiv_iff_hprop; intros e. + refine (isequiv_commsq f g h k (fun a => (p a)^)). + refine (isequiv_commsq' f g h k p). Defined. (** A map is oo-path-split if it is n-path-split for all n. This is also equivalent to being an equivalence. *) Definition ooPathSplit `(f : A -> B) : Type := forall n, PathSplit n f. Definition isequiv_oopathsplit `{f : A -> B} : ooPathSplit f -> IsEquiv f := fun ps => isequiv_pathsplit 0 (ps 2). Global Instance contr_oopathsplit_isequiv `(f : A -> B) `{IsEquiv _ _ f} : Contr (ooPathSplit f). Proof. apply contr_forall. Defined. Global Instance ishprop_oopathsplit `(f : A -> B) : IsHProp (ooPathSplit f). Proof. apply hprop_inhabited_contr; intros ps. pose (isequiv_oopathsplit ps). exact _. Defined. Definition equiv_oopathsplit_isequiv `(f : A -> B) : ooPathSplit f <~> IsEquiv f. Proof. refine (equiv_iff_hprop _ _). - apply isequiv_oopathsplit. - intros ?; refine (center _). Defined. End AssumeFunext. Coq-HoTT-9.0/theories/Equiv/Relational.v000066400000000000000000000043221474641544500201330ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Local Open Scope nat_scope. Local Open Scope path_scope. Generalizable Variables A B f. (** * Relational equivalences *) (** This definition is due to Peter LeFanu Lumsdaine on the HoTT mailing list. This definition gives more judgmental properties, though has the downside of jumping universe levels. *) Record RelEquiv A B := { equiv_rel : A -> B -> Type; relequiv_contr_f : forall a, Contr { b : B & equiv_rel a b }; relequiv_contr_g : forall b, Contr { a : A & equiv_rel a b } }. Arguments equiv_rel {A B} _ _ _. Global Existing Instance relequiv_contr_f. Global Existing Instance relequiv_contr_g. Definition issig_relequiv {A B} : { equiv_rel : A -> B -> Type | { f : forall a, Contr { b : B & equiv_rel a b } | forall b, Contr { a : A & equiv_rel a b } } } <~> RelEquiv A B. Proof. issig. Defined. Definition relequiv_of_equiv {A B} (e : A <~> B) : RelEquiv A B. Proof. refine {| equiv_rel a b := e a = b |}. (** The rest is found by typeclass inference! *) Defined. Definition equiv_of_relequiv {A B} (e : RelEquiv A B) : A <~> B. Proof. refine (equiv_adjointify (fun a => (center { b : B & equiv_rel e a b}).1) (fun b => (center { a : A & equiv_rel e a b}).1) _ _); intro x; cbn. { refine (ap pr1 (contr _) : _.1 = (x; _).1). exact (center {a : A & equiv_rel e a x}).2. } { refine (ap pr1 (contr _) : _.1 = (x; _).1). exact (center {b : B & equiv_rel e x b}).2. } Defined. Definition RelIsEquiv {A B} (f : A -> B) := { r : RelEquiv A B | forall x, (center { b : B & equiv_rel r x b }).1 = f x }. (** TODO: Prove [ishprop_relisequiv `{Funext} {A B} f : IsHProp (@RelIsEquiv A B f)] *) (** * Judgmental property *) Definition inverse_relequiv {A B} (e : RelEquiv A B) : RelEquiv B A := {| equiv_rel a b := equiv_rel e b a |}. Definition reinv_V {A B} (e : RelEquiv A B) : inverse_relequiv (inverse_relequiv e) = e := 1. (** TODO: Is there a definition of this that makes [inverse_relequiv (relequiv_idmap A)] be [relequiv_idmap A], judgmentally? *) Definition relequiv_idmap A : RelEquiv A A := {| equiv_rel a b := a = b |}. (** TODO: Define composition; we probably need truncation to do this? *) Coq-HoTT-9.0/theories/EquivGroupoids.v000066400000000000000000000147661474641544500177520ustar00rootroot00000000000000(** * The pregroupoid structure of [Equiv] *) Require Import Basics.Overture Basics.Equivalences Types.Equiv. Local Open Scope equiv_scope. (** See PathGroupoids.v for the naming conventions *) (** TODO: Consider using a definition of [IsEquiv] and [Equiv] for which more of these are judgmental, or at least don't require [Funext]. *) Section AssumeFunext. Context `{Funext}. (** ** The 1-dimensional groupoid structure. *) (** The identity equivalence is a right unit. *) Lemma ecompose_e1 {A B} (e : A <~> B) : e oE 1 = e. Proof. apply path_equiv; reflexivity. Defined. (** The identity is a left unit. *) Lemma ecompose_1e {A B} (e : A <~> B) : 1 oE e = e. Proof. apply path_equiv; reflexivity. Defined. (** Composition is associative. *) Definition ecompose_e_ee {A B C D} (e : A <~> B) (f : B <~> C) (g : C <~> D) : g oE (f oE e) = (g oE f) oE e. Proof. apply path_equiv; reflexivity. Defined. Definition ecompose_ee_e {A B C D} (e : A <~> B) (f : B <~> C) (g : C <~> D) : (g oE f) oE e = g oE (f oE e). Proof. apply path_equiv; reflexivity. Defined. (** The left inverse law. *) Lemma ecompose_eV {A B} (e : A <~> B) : e oE e^-1 = 1. Proof. apply path_equiv; apply path_forall; intro; apply eisretr. Defined. (** The right inverse law. *) Lemma ecompose_Ve {A B} (e : A <~> B) : e^-1 oE e = 1. Proof. apply path_equiv; apply path_forall; intro; apply eissect. Defined. (** Several auxiliary theorems about canceling inverses across associativity. These are somewhat redundant, following from earlier theorems. *) Definition ecompose_V_ee {A B C} (e : A <~> B) (f : B <~> C) : f^-1 oE (f oE e) = e. Proof. apply path_equiv; apply path_forall; intro; simpl; apply eissect. Defined. Definition ecompose_e_Ve {A B C} (e : A <~> B) (f : C <~> B) : e oE (e^-1 oE f) = f. Proof. apply path_equiv; apply path_forall; intro; simpl; apply eisretr. Defined. Definition ecompose_ee_V {A B C} (e : A <~> B) (f : B <~> C) : (f oE e) oE e^-1 = f. Proof. apply path_equiv; apply path_forall; intro; simpl; apply ap; apply eisretr. Defined. Definition ecompose_eV_e {A B C} (e : B <~> A) (f : B <~> C) : (f oE e^-1) oE e = f. Proof. apply path_equiv; apply path_forall; intro; simpl; apply ap; apply eissect. Defined. (** Inverse distributes over composition *) Definition einv_ee {A B C} (e : A <~> B) (f : B <~> C) : (f oE e)^-1 = e^-1 oE f^-1. Proof. apply path_equiv; reflexivity. Defined. Definition einv_Ve {A B C} (e : A <~> C) (f : B <~> C) : (f^-1 oE e)^-1 = e^-1 oE f. Proof. apply path_equiv; reflexivity. Defined. Definition einv_eV {A B C} (e : C <~> A) (f : C <~> B) : (f oE e^-1)^-1 = e oE f^-1. Proof. apply path_equiv; reflexivity. Defined. Definition einv_VV {A B C} (e : A <~> B) (f : B <~> C) : (e^-1 oE f^-1)^-1 = f oE e. Proof. apply path_equiv; reflexivity. Defined. (** Inverse is an involution. *) Definition einv_V {A B} (e : A <~> B) : (e^-1)^-1 = e. Proof. apply path_equiv; reflexivity. Defined. (** *** Theorems for moving things around in equations. *) Definition emoveR_Me {A B C} (e : B <~> A) (f : B <~> C) (g : A <~> C) : e = g^-1 oE f -> g oE e = f. Proof. intro h. refine (ap (fun e => g oE e) h @ ecompose_e_Ve _ _). Defined. Definition emoveR_eM {A B C} (e : B <~> A) (f : B <~> C) (g : A <~> C) : g = f oE e^-1 -> g oE e = f. Proof. intro h. refine (ap (fun g => g oE e) h @ ecompose_eV_e _ _). Defined. Definition emoveR_Ve {A B C} (e : B <~> A) (f : B <~> C) (g : C <~> A) : e = g oE f -> g^-1 oE e = f. Proof. intro h. refine (ap (fun e => g^-1 oE e) h @ ecompose_V_ee _ _). Defined. Definition emoveR_eV {A B C} (e : A <~> B) (f : B <~> C) (g : A <~> C) : g = f oE e -> g oE e^-1 = f. Proof. intro h. refine (ap (fun g => g oE e^-1) h @ ecompose_ee_V _ _). Defined. Definition emoveL_Me {A B C} (e : A <~> B) (f : A <~> C) (g : B <~> C) : g^-1 oE f = e -> f = g oE e. Proof. intro h. refine ((ecompose_e_Ve _ _)^ @ ap (fun e => g oE e) h). Defined. Definition emoveL_eM {A B C} (e : A <~> B) (f : A <~> C) (g : B <~> C) : f oE e^-1 = g -> f = g oE e. Proof. intro h. refine ((ecompose_eV_e _ _)^ @ ap (fun g => g oE e) h). Defined. Definition emoveL_Ve {A B C} (e : A <~> C) (f : A <~> B) (g : B <~> C) : g oE f = e -> f = g^-1 oE e. Proof. intro h. refine ((ecompose_V_ee _ _)^ @ ap (fun e => g^-1 oE e) h). Defined. Definition emoveL_eV {A B C} (e : A <~> B) (f : B <~> C) (g : A <~> C) : f oE e = g -> f = g oE e^-1. Proof. intro h. refine ((ecompose_ee_V _ _)^ @ ap (fun g => g oE e^-1) h). Defined. Definition emoveL_1M {A B} (e f : A <~> B) : e oE f^-1 = 1 -> e = f. Proof. intro h. refine ((ecompose_eV_e _ _)^ @ ap (fun ef => ef oE f) h @ ecompose_1e _). Defined. Definition emoveL_M1 {A B} (e f : A <~> B) : f^-1 oE e = 1 -> e = f. Proof. intro h. refine ((ecompose_e_Ve _ _)^ @ ap (fun fe => f oE fe) h @ ecompose_e1 _). Defined. Definition emoveL_1V {A B} (e : A <~> B) (f : B <~> A) : e oE f = 1 -> e = f^-1. Proof. intro h. refine ((ecompose_ee_V _ _)^ @ ap (fun ef => ef oE f^-1) h @ ecompose_1e _). Defined. Definition emoveL_V1 {A B} (e : A <~> B) (f : B <~> A) : f oE e = 1 -> e = f^-1. Proof. intro h. refine ((ecompose_V_ee _ _)^ @ ap (fun fe => f^-1 oE fe) h @ ecompose_e1 _). Defined. Definition emoveR_M1 {A B} (e f : A <~> B) : 1 = e^-1 oE f -> e = f. Proof. intro h. refine ((ecompose_e1 _)^ @ ap (fun ef => e oE ef) h @ ecompose_e_Ve _ _). Defined. Definition emoveR_1M {A B} (e f : A <~> B) : 1 = f oE e^-1 -> e = f. Proof. intro h. refine ((ecompose_1e _)^ @ ap (fun fe => fe oE e) h @ ecompose_eV_e _ _). Defined. Definition emoveR_1V {A B} (e : A <~> B) (f : B <~> A) : 1 = f oE e -> e^-1 = f. Proof. intro h. refine ((ecompose_1e _)^ @ ap (fun fe => fe oE e^-1) h @ ecompose_ee_V _ _). Defined. Definition emoveR_V1 {A B} (e : A <~> B) (f : B <~> A) : 1 = e oE f -> e^-1 = f. Proof. intro h. refine ((ecompose_e1 _)^ @ ap (fun ef => e^-1 oE ef) h @ ecompose_V_ee _ _). Defined. (** We could package these up into tactics, much the same as the [with_rassoc] and [rewrite_move*] of [PathGroupoids.v]. I have not done so yet because there is currently no place where we would use these tactics. If there is a use case, they are easy enough to copy from [PathGroupoids.v]. *) End AssumeFunext. Coq-HoTT-9.0/theories/ExcludedMiddle.v000066400000000000000000000032701474641544500176250ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. (** * The law of excluded middle *) Monomorphic Axiom ExcludedMiddle : Type0. Existing Class ExcludedMiddle. (** Mark this axiom as a "global axiom", which some of our tactics will automatically handle. *) Global Instance is_global_axiom_excludedmiddle : IsGlobalAxiom ExcludedMiddle := {}. Axiom LEM : forall `{ExcludedMiddle} (P : Type), IsHProp P -> P + ~P. Definition ExcludedMiddle_type := forall (P : Type), IsHProp P -> P + ~P. (** ** LEM means that all propositions are decidable *) Global Instance decidable_lem `{ExcludedMiddle} (P : Type) `{IsHProp P} : Decidable P := LEM P _. (** ** Double-negation elimination *) Definition DNE_type := forall P, IsHProp P -> ~~P -> P. Definition LEM_to_DNE : ExcludedMiddle -> DNE_type. Proof. intros lem P hp nnp. case (LEM P _). - auto. - intros np; elim (nnp np). Defined. (** This direction requires Funext. *) Definition DNE_to_LEM `{Funext} : DNE_type -> ExcludedMiddle_type. Proof. intros dn P hp. refine (dn (P + ~P) _ _). - apply ishprop_sum. + exact _. + exact _. + intros p np; exact (np p). - intros nlem. apply nlem. apply inr. intros p. apply nlem. apply inl. apply p. Defined. (** DNE is equivalent to "every proposition is a negation". *) Definition allneg_from_DNE (H : DNE_type) (P : Type) `{IsHProp P} : {Q : Type & P <-> ~Q}. Proof. exists (~P); split. - intros p np; exact (np p). - apply H; exact _. Defined. Definition DNE_from_allneg (H : forall P, IsHProp P -> {Q : Type & P <-> ~Q}) : DNE_type. Proof. intros P ? nnp. destruct (H P _) as [Q e]. apply e. intros q. apply nnp. intros p. exact (fst e p q). Defined. Coq-HoTT-9.0/theories/Extensions.v000066400000000000000000001030511474641544500171060ustar00rootroot00000000000000(** * Extensions and extendible maps *) Require Import HoTT.Basics HoTT.Types. Require Import Equiv.PathSplit Homotopy.IdentitySystems. Require Import Cubical.DPath Cubical.DPathSquare. Require Import Colimits.Coeq Colimits.MappingCylinder. Local Open Scope nat_scope. Local Open Scope path_scope. (** Given [C : B -> Type] and [f : A -> B], an extension of [g : forall a, C (f a)] along [f] is a section [h : forall b, C b] such that [h (f a) = g a] for all [a:A]. This is equivalently the existence of fillers for commutative squares, restricted to the case where the bottom of the square is the identity; type-theoretically, this approach is sometimes more convenient. In this file we study the type of such extensions. One of its crucial properties is that a path between extensions is equivalently an extension in a fibration of paths. This turns out to be useful for several reasons. For instance, by iterating it, we can to formulate universal properties without needing [Funext]. It also gives us a way to "quantify" a universal property by the connectedness of the type of extensions. *) Section Extensions. (* TODO: consider naming for [ExtensionAlong] and subsequent lemmas. As a name for the type itself, [Extension] or [ExtensionAlong] seems great; but resultant lemma names such as [path_extension] (following existing naming conventions) are rather misleading. *) (** This elimination rule (and others) can be seen as saying that, given a fibration over the codomain and a section of it over the domain, there is some *extension* of this to a section over the whole codomain. It can also be considered as an equivalent form of an [hfiber] of precomposition-with-[f] that replaces paths by pointwise paths, thereby avoiding [Funext]. *) Definition ExtensionAlong@{a b p m} {A : Type@{a}} {B : Type@{b}} (f : A -> B) (P : B -> Type@{p}) (d : forall x:A, P (f x)) := (* { s : forall y:B, P y & forall x:A, s (f x) = d x }. *) sig@{m m} (fun (s : forall y:B, P y) => forall x:A, s (f x) = d x). (** [ExtensionAlong] takes 4 universe parameters: - the size of A - the size of B - the size of P - >= max(A,B,P) *) (** It's occasionally useful to be able to modify those universes. For each of the universes [a], [b], [p], we give an initial one, a final one, and a "minimum" one smaller than both and where the type actually lives. *) Definition lift_extensionalong@{a1 a2 amin b1 b2 bmin p1 p2 pmin m1 m2} {A : Type@{amin}} {B : Type@{bmin}} (f : A -> B) (P : B -> Type@{pmin}) (d : forall x:A, P (f x)) : ExtensionAlong@{a1 b1 p1 m1} f P d -> ExtensionAlong@{a2 b2 p2 m2} f P d. Proof. intros ext. (** If we just give [ext], it will collapse the universes. (Anyone stepping through this proof should do [Set Printing Universes] and look at the universes to see that they're different in [ext] and in the goal.) So we decompose [ext] into two components and give them separately. *) assert (e2 := ext.2); set (e1 := ext.1) in e2. cbn in e2. (** Curiously, without this line we get a spurious universe inequality [p1 <= m2]. *) exact (e1;e2). Defined. (** We called it [lift_extensionalong], but in fact it doesn't require the new universes to be bigger than the old ones, only that they both satisfy the max condition. *) Definition equiv_path_extension `{Funext} {A B : Type} {f : A -> B} {P : B -> Type} {d : forall x:A, P (f x)} (ext ext' : ExtensionAlong f P d) : (ExtensionAlong f (fun y => pr1 ext y = pr1 ext' y) (fun x => pr2 ext x @ (pr2 ext' x)^)) <~> ext = ext'. Proof. revert ext'. srapply equiv_path_from_contr. { unfold ExtensionAlong; cbn. exists (fun y => 1%path). intros x; symmetry; apply concat_pV. } destruct ext as [g gd]; unfold ExtensionAlong; cbn. refine (contr_sigma_sigma (forall y:B, P y) (fun s => forall x:A, s (f x) = d x) (fun a => g == a) (fun a b c => forall x:A, c (f x) = gd x @ (b x)^) g (fun y:B => idpath (g y))). refine (contr_equiv' {p:g o f == d & gd == p} _). cbn. refine (equiv_functor_sigma_id _); intros p. refine (equiv_functor_forall_id _); intros x; cbn. refine (_ oE equiv_path_inverse _ _). symmetry; apply equiv_moveR_1M. Defined. Definition path_extension `{Funext} {A B : Type} {f : A -> B} {P : B -> Type} {d : forall x:A, P (f x)} (ext ext' : ExtensionAlong f P d) : (ExtensionAlong f (fun y => pr1 ext y = pr1 ext' y) (fun x => pr2 ext x @ (pr2 ext' x)^)) -> ext = ext' := equiv_path_extension ext ext'. Global Instance isequiv_path_extension `{Funext} {A B : Type} {f : A -> B} {P : B -> Type} {d : forall x:A, P (f x)} (ext ext' : ExtensionAlong f P d) : IsEquiv (path_extension ext ext') | 0 := equiv_isequiv _. (** Here is the iterated version. *) Fixpoint ExtendableAlong@{i j k l} (n : nat) {A : Type@{i}} {B : Type@{j}} (f : A -> B) (C : B -> Type@{k}) : Type@{l} := match n with | 0 => Unit | S n => (forall (g : forall a, C (f a)), ExtensionAlong@{i j k l} f C g) * forall (h k : forall b, C b), ExtendableAlong n f (fun b => h b = k b) end. (** [ExtendableAlong] takes 4 universe parameters: - size of A - size of B - size of C - size of result (>= A,B,C) *) Global Arguments ExtendableAlong n%_nat_scope {A B}%_type_scope (f C)%_function_scope. (** We can modify the universes, as with [ExtensionAlong]. *) Definition lift_extendablealong@{a1 a2 amin b1 b2 bmin p1 p2 pmin m1 m2} (n : nat) {A : Type@{amin}} {B : Type@{bmin}} (f : A -> B) (P : B -> Type@{pmin}) : ExtendableAlong@{a1 b1 p1 m1} n f P -> ExtendableAlong@{a2 b2 p2 m2} n f P. Proof. revert P; simple_induction n n IH; intros P. - intros _; exact tt. - intros ext; split. + intros g; exact (lift_extensionalong@{a1 a2 amin b1 b2 bmin p1 p2 pmin m1 m2} _ _ _ (fst ext g)). + intros h k. (** Unles we give the universe explicitly here, [kmin] gets collapsed to [k1]. *) pose (P' := (fun b => h b = k b) : B -> Type@{pmin}). exact (IH P' (snd ext h k)). Defined. Definition equiv_extendable_pathsplit `{Funext} (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) : ExtendableAlong n f C <~> PathSplit n (fun (g : forall b, C b) => g oD f). Proof. generalize dependent C; simple_induction n n IHn; intros C. 1:apply equiv_idmap. refine (_ *E _); simpl. - refine (equiv_functor_forall' 1 _); intros g; simpl. refine (equiv_functor_sigma' 1 _); intros rec. apply equiv_path_forall. - refine (equiv_functor_forall' 1 _); intros h. refine (equiv_functor_forall' 1 _); intros k; simpl. refine (_ oE IHn (fun b => h b = k b)). apply equiv_inverse. refine (equiv_functor_pathsplit n _ _ (equiv_apD10 _ _ _) (equiv_apD10 _ _ _) _). intros []; reflexivity. Defined. Definition isequiv_extendable `{Funext} (n : nat) {A B : Type} {C : B -> Type} {f : A -> B} : ExtendableAlong n.+2 f C -> IsEquiv (fun g => g oD f) := isequiv_pathsplit n o (equiv_extendable_pathsplit n.+2 C f). Global Instance ishprop_extendable `{Funext} (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) : IsHProp (ExtendableAlong n.+2 f C). Proof. exact (istrunc_equiv_istrunc _ (equiv_extendable_pathsplit n.+2 C f)^-1). Defined. Definition equiv_extendable_isequiv `{Funext} (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) : ExtendableAlong n.+2 f C <~> IsEquiv (fun (g : forall b, C b) => g oD f). Proof. etransitivity. - apply equiv_extendable_pathsplit. - apply equiv_pathsplit_isequiv. Defined. (* Without [Funext], we can prove a small part of the above equivalence. We suspect that the rest requires [Funext]. *) Definition extension_isequiv_precompose {A : Type} {B : Type} (f : A -> B) (C : B -> Type) : IsEquiv (fun (g : forall b, C b) => g oD f) -> forall g, ExtensionAlong f C g. Proof. intros E g. pose (e := Build_Equiv _ _ _ E). exists (e^-1 g). apply apD10. exact (eisretr e g). Defined. (** Postcomposition with a known equivalence. Note that this does not require funext to define, although showing that it is an equivalence would require funext. *) Definition extendable_postcompose' (n : nat) {A B : Type} (C D : B -> Type) (f : A -> B) (g : forall b, C b <~> D b) : ExtendableAlong n f C -> ExtendableAlong n f D. Proof. generalize dependent C; revert D. simple_induction n n IH; intros C D g; simpl. 1:apply idmap. refine (functor_prod _ _). - refine (functor_forall (functor_forall idmap (fun a => (g (f a))^-1)) _); intros h; simpl. refine (functor_sigma (functor_forall idmap g) _); intros k. refine (functor_forall idmap _); intros a; unfold functor_arrow, functor_forall, composeD; simpl. apply moveR_equiv_M. - refine (functor_forall (functor_forall idmap (fun b => (g b)^-1)) _); intros h. refine (functor_forall (functor_forall idmap (fun b => (g b)^-1)) _); intros k; simpl; unfold functor_forall. refine (IH _ _ _); intros b. apply equiv_inverse, equiv_ap; exact _. Defined. Definition extendable_postcompose (n : nat) {A B : Type} (C D : B -> Type) (f : A -> B) (g : forall b, C b -> D b) `{forall b, IsEquiv (g b)} : ExtendableAlong n f C -> ExtendableAlong n f D := extendable_postcompose' n C D f (fun b => Build_Equiv _ _ (g b) _). (** Composition of the maps we extend along. This also does not require funext. *) Definition extendable_compose (n : nat) {A B C : Type} (P : C -> Type) (f : A -> B) (g : B -> C) : ExtendableAlong n g P -> ExtendableAlong n f (fun b => P (g b)) -> ExtendableAlong n (g o f) P. Proof. revert P; simple_induction n n IHn; intros P extg extf; [ exact tt | split ]. - intros h. exists ((fst extg (fst extf h).1).1); intros a. refine ((fst extg (fst extf h).1).2 (f a) @ _). exact ((fst extf h).2 a). - intros h k. apply IHn. + exact (snd extg h k). + exact (snd extf (h oD g) (k oD g)). Defined. (** And cancellation *) Definition cancelL_extendable (n : nat) {A B C : Type} (P : C -> Type) (f : A -> B) (g : B -> C) : ExtendableAlong n g P -> ExtendableAlong n (g o f) P -> ExtendableAlong n f (fun b => P (g b)). Proof. revert P; simple_induction n n IHn; intros P extg extgf; [ exact tt | split ]. - intros h. exists ((fst extgf h).1 oD g); intros a. exact ((fst extgf h).2 a). - intros h k. pose (h' := (fst extg h).1). pose (k' := (fst extg k).1). refine (extendable_postcompose' n (fun b => h' (g b) = k' (g b)) (fun b => h b = k b) f _ _). + intros b. exact (equiv_concat_lr ((fst extg h).2 b)^ ((fst extg k).2 b)). + apply (IHn (fun c => h' c = k' c) (snd extg h' k') (snd extgf h' k')). Defined. Definition cancelR_extendable (n : nat) {A B C : Type} (P : C -> Type) (f : A -> B) (g : B -> C) : ExtendableAlong n.+1 f (fun b => P (g b)) -> ExtendableAlong n (g o f) P -> ExtendableAlong n g P. Proof. revert P; simple_induction n n IHn; intros P extf extgf; [ exact tt | split ]. - intros h. exists ((fst extgf (h oD f)).1); intros b. refine ((fst (snd extf ((fst extgf (h oD f)).1 oD g) h) _).1 b); intros a. apply ((fst extgf (h oD f)).2). - intros h k. apply IHn. + apply (snd extf (h oD g) (k oD g)). + apply (snd extgf h k). Defined. (** And transfer across homotopies *) Definition extendable_homotopic (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) {g : A -> B} (p : f == g) : ExtendableAlong n f C -> ExtendableAlong n g C. Proof. revert C; simple_induction n n IHn; intros C extf; [ exact tt | split ]. - intros h. exists ((fst extf (fun a => (p a)^ # h a)).1); intros a. refine ((apD ((fst extf (fun a => (p a)^ # h a)).1) (p a))^ @ _). apply moveR_transport_p. exact ((fst extf (fun a => (p a)^ # h a)).2 a). - intros h k. apply IHn, (snd extf h k). Defined. (** We can extend along equivalences *) Definition extendable_equiv (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) `{IsEquiv _ _ f} : ExtendableAlong n f C. Proof. revert C; simple_induction n n IHn; intros C; [ exact tt | split ]. - intros h. exists (fun b => eisretr f b # h (f^-1 b)); intros a. refine (transport2 C (eisadj f a) _ @ _). refine ((transport_compose C f _ _)^ @ _). exact (apD h (eissect f a)). - intros h k. apply IHn. Defined. (** And into contractible types *) Definition extendable_contr (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) `{forall b, Contr (C b)} : ExtendableAlong n f C. Proof. generalize dependent C; simple_induction n n IHn; intros C ?; [ exact tt | split ]. - intros h. exists (fun _ => center _); intros a. apply contr. - intros h k. apply IHn; exact _. Defined. (** This is inherited by types of homotopies. *) Definition extendable_homotopy (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) (h k : forall b, C b) : ExtendableAlong n.+1 f C -> ExtendableAlong n f (fun b => h b = k b). Proof. revert C h k; simple_induction n n IHn; intros C h k ext; [exact tt | split]. - intros p. exact (fst (snd ext h k) p). - intros p q. apply IHn, ext. Defined. (** And the oo-version. *) Definition ooExtendableAlong@{i j k l} {A : Type@{i}} {B : Type@{j}} (f : A -> B) (C : B -> Type@{k}) : Type@{l} := forall n : nat, ExtendableAlong@{i j k l} n f C. (** Universe parameters are the same as for [ExtendableAlong]. *) Global Arguments ooExtendableAlong {A B}%_type_scope (f C)%_function_scope. (** Universe modification. *) Definition lift_ooextendablealong@{a1 a2 amin b1 b2 bmin p1 p2 pmin m1 m2} {A : Type@{amin}} {B : Type@{bmin}} (f : A -> B) (P : B -> Type@{pmin}) : ooExtendableAlong@{a1 b1 p1 m1} f P -> ooExtendableAlong@{a2 b2 p2 m2} f P := fun ext n => lift_extendablealong@{a1 a2 amin b1 b2 bmin p1 p2 pmin m1 m2} n f P (ext n). (** We take part of the data from [ps 1] and part from [ps 2] so that the inverse chosen is the expected one. *) Definition isequiv_ooextendable `{Funext} {A B : Type} (C : B -> Type) (f : A -> B) : ooExtendableAlong f C -> IsEquiv (fun g => g oD f) := fun ps => isequiv_extendable 0 (fst (ps 1%nat), snd (ps 2)). Definition equiv_ooextendable_pathsplit `{Funext} {A B : Type} (C : B -> Type) (f : A -> B) : ooExtendableAlong f C <~> ooPathSplit (fun (g : forall b, C b) => g oD f). Proof. refine (equiv_functor_forall' 1 _); intros n. apply equiv_extendable_pathsplit. Defined. Global Instance ishprop_ooextendable `{Funext} {A B : Type} (C : B -> Type) (f : A -> B) : IsHProp (ooExtendableAlong f C). Proof. refine (istrunc_equiv_istrunc _ (equiv_ooextendable_pathsplit C f)^-1). Defined. Definition equiv_ooextendable_isequiv `{Funext} {A B : Type} (C : B -> Type) (f : A -> B) : ooExtendableAlong f C <~> IsEquiv (fun (g : forall b, C b) => g oD f) := equiv_oopathsplit_isequiv _ oE equiv_ooextendable_pathsplit _ _. Definition ooextendable_postcompose {A B : Type} (C D : B -> Type) (f : A -> B) (g : forall b, C b -> D b) `{forall b, IsEquiv (g b)} : ooExtendableAlong f C -> ooExtendableAlong f D := fun ppp n => extendable_postcompose n C D f g (ppp n). Definition ooextendable_postcompose' {A B : Type} (C D : B -> Type) (f : A -> B) (g : forall b, C b <~> D b) : ooExtendableAlong f C -> ooExtendableAlong f D := fun ppp n => extendable_postcompose' n C D f g (ppp n). Definition ooextendable_compose {A B C : Type} (P : C -> Type) (f : A -> B) (g : B -> C) : ooExtendableAlong g P -> ooExtendableAlong f (fun b => P (g b)) -> ooExtendableAlong (g o f) P := fun extg extf n => extendable_compose n P f g (extg n) (extf n). Definition cancelL_ooextendable {A B C : Type} (P : C -> Type) (f : A -> B) (g : B -> C) : ooExtendableAlong g P -> ooExtendableAlong (g o f) P -> ooExtendableAlong f (fun b => P (g b)) := fun extg extgf n => cancelL_extendable n P f g (extg n) (extgf n). Definition cancelR_ooextendable {A B C : Type} (P : C -> Type) (f : A -> B) (g : B -> C) : ooExtendableAlong f (fun b => P (g b)) -> ooExtendableAlong (g o f) P -> ooExtendableAlong g P := fun extf extgf n => cancelR_extendable n P f g (extf n.+1) (extgf n). Definition ooextendable_homotopic {A B : Type} (C : B -> Type) (f : A -> B) {g : A -> B} (p : f == g) : ooExtendableAlong f C -> ooExtendableAlong g C := fun extf n => extendable_homotopic n C f p (extf n). Definition ooextendable_equiv {A B : Type} (C : B -> Type) (f : A -> B) `{IsEquiv _ _ f} : ooExtendableAlong f C := fun n => extendable_equiv n C f. Definition ooextendable_contr {A B : Type} (C : B -> Type) (f : A -> B) `{forall b, Contr (C b)} : ooExtendableAlong f C := fun n => extendable_contr n C f. Definition ooextendable_homotopy {A B : Type} (C : B -> Type) (f : A -> B) (h k : forall b, C b) : ooExtendableAlong f C -> ooExtendableAlong f (fun b => h b = k b). Proof. intros ext n; apply extendable_homotopy, ext. Defined. (** Extendability of a family [C] along a map [f] can be detected by extendability of the constant family [C b] along the projection from the corresponding fiber of [f] to [Unit]. Note that this is *not* an if-and-only-if; the hypothesis can be genuinely stronger than the conclusion. *) Definition ooextendable_isnull_fibers {A B} (f : A -> B) (C : B -> Type) : (forall b, ooExtendableAlong (const_tt (hfiber f b)) (fun _ => C b)) -> ooExtendableAlong f C. Proof. intros orth n; revert C orth. induction n as [|n IHn]; intros C orth; [exact tt | split]. - intros g. exists (fun b => (fst (orth b 1%nat) (fun x => x.2 # g x.1)).1 tt). intros a. rewrite (path_unit tt (const_tt _ a)). exact ((fst (orth (f a) 1%nat) _).2 (a ; 1)). - intros h k. apply IHn; intros b. apply ooextendable_homotopy, orth. Defined. End Extensions. (** ** Extendability along cofibrations *) (** If a family is extendable along a cofibration (i.e. a mapping cylinder), it is extendable definitionally. *) Definition cyl_extension {A B} (f : A -> B) (C : Cyl f -> Type) (g : forall a, C (cyl a)) (ext : ExtensionAlong cyl C g) : ExtensionAlong cyl C g. Proof. srefine (Cyl_ind C g (ext.1 o cyr) _ ; _); intros a. + refine ((ext.2 a)^ @Dl _)%dpath. apply apD. + reflexivity. (** The point is that this equality is now definitional. *) Defined. Definition cyl_extendable (n : nat) {A B} (f : A -> B) (C : Cyl f -> Type) (ext : ExtendableAlong n cyl C) : ExtendableAlong n cyl C. Proof. revert C ext; simple_induction n n IH; intros C ext; [ exact tt | split ]. - intros g. apply cyl_extension. exact (fst ext g). - intros h k; apply IH. exact (snd ext h k). Defined. Definition cyl_ooextendable {A B} (f : A -> B) (C : Cyl f -> Type) (ext : ooExtendableAlong cyl C) : ooExtendableAlong cyl C := fun n => cyl_extendable n f C (ext n). Definition cyl_extension' {A B} (f : A -> B) (C : B -> Type) (g : forall a, C (pr_cyl (cyl a))) (ext : ExtensionAlong f C g) : ExtensionAlong cyl (C o pr_cyl) g. Proof. rapply cyl_extension. exists (ext.1 o pr_cyl). intros x; apply ext.2. Defined. Definition cyl_extendable' (n : nat) {A B} (f : A -> B) (C : B -> Type) (ext : ExtendableAlong n f C) : ExtendableAlong n cyl (C o (pr_cyl' f)). Proof. rapply cyl_extendable. refine (cancelL_extendable n C cyl pr_cyl _ ext). rapply extendable_equiv. Defined. Definition cyl_ooextendable' {A B} (f : A -> B) (C : B -> Type) (ext : ooExtendableAlong f C) : ooExtendableAlong cyl (C o (pr_cyl' f)) := fun n => cyl_extendable' n f C (ext n). (** ** Extendability along [functor_prod] *) Definition extension_functor_prod {A B A' B'} (f : A -> A') (g : B -> B') (P : A' * B' -> Type) (ef : forall b', ExtendableAlong 1 f (fun a' => P (a',b'))) (eg : forall a', ExtendableAlong 1 g (fun b' => P (a',b'))) (s : forall z, P (functor_prod f g z)) : ExtensionAlong (functor_prod f g) P s. Proof. srefine (_;_). - intros [a' b']; revert b'. refine ((fst (eg a') _).1). intros b; revert a'. refine ((fst (ef (g b)) _).1). intros a. exact (s (a,b)). - intros [a b]; cbn. refine ((fst (eg (f a)) _).2 b @ _). exact ((fst (ef (g b)) _).2 a). Defined. Definition extendable_functor_prod (n : nat) {A B A' B'} (f : A -> A') (g : B -> B') (P : A' * B' -> Type) (ef : forall b', ExtendableAlong n f (fun a' => P (a',b'))) (eg : forall a', ExtendableAlong n g (fun b' => P (a',b'))) : ExtendableAlong n (functor_prod f g) P. Proof. revert P ef eg; simple_induction n n IH; intros P ef eg; [ exact tt | split ]. - apply extension_functor_prod. + intros b'; exact (fst (ef b'), fun _ _ => tt). + intros a'; exact (fst (eg a'), fun _ _ => tt). - intros h k; apply IH. + intros b'; apply (snd (ef b')). + intros a'; apply (snd (eg a')). Defined. Definition ooextendable_functor_prod {A B A' B'} (f : A -> A') (g : B -> B') (P : A' * B' -> Type) (ef : forall b', ooExtendableAlong f (fun a' => P (a',b'))) (eg : forall a', ooExtendableAlong g (fun b' => P (a',b'))) : ooExtendableAlong (functor_prod f g) P := fun n => extendable_functor_prod n f g P (fun b' => ef b' n) (fun a' => eg a' n). (** ** Extendability along [functor_sigma] *) Definition extension_functor_sigma_id {A} {P Q : A -> Type} (f : forall a, P a -> Q a) (C : sig Q -> Type) (ef : forall a, ExtendableAlong 1 (f a) (fun v => C (a;v))) (s : forall z, C (functor_sigma idmap f z)) : ExtensionAlong (functor_sigma idmap f) C s. Proof. srefine (_;_). - intros [a v]; revert v. refine ((fst (ef a) _).1). intros u. exact (s (a;u)). - intros [a u]; cbn. exact ((fst (ef a) _).2 u). Defined. Definition extendable_functor_sigma_id n {A} {P Q : A -> Type} (f : forall a, P a -> Q a) (C : sig Q -> Type) (ef : forall a, ExtendableAlong n (f a) (fun v => C (a;v))) : ExtendableAlong n (functor_sigma idmap f) C. Proof. revert C ef; simple_induction n n IH; intros C ef; [ exact tt | split ]. - apply extension_functor_sigma_id. intros a; exact (fst (ef a) , fun _ _ => tt). - intros h k; apply IH. intros a; apply (snd (ef a)). Defined. Definition ooextendable_functor_sigma_id {A} {P Q : A -> Type} (f : forall a, P a -> Q a) (C : sig Q -> Type) (ef : forall a, ooExtendableAlong (f a) (fun v => C (a;v))) : ooExtendableAlong (functor_sigma idmap f) C := fun n => extendable_functor_sigma_id n f C (fun a => ef a n). (** Unfortunately, the technology of [ExtensionAlong] seems to be insufficient to state a general, funext-free version of [extension_functor_sigma] with a nonidentity map on the bases; the hypothesis on the fiberwise map would have to be the existence of an extension in a function-type "up to pointwise equality". With wild oo-groupoids we could probably manage it. For now, we say something a bit hacky. *) Definition HomotopyExtensionAlong {A B} {Q : B -> Type} (f : A -> B) (C : sig Q -> Type) (p : forall (a:A) (v:Q (f a)), C (f a;v)) := { q : forall (b:B) (v:Q b), C (b;v) & forall a v, q (f a) v = p a v }. Fixpoint HomotopyExtendableAlong (n : nat) {A B} {Q : B -> Type} (f : A -> B) (C : sig Q -> Type) : Type := match n with | 0 => Unit | S n => ((forall (p : forall (a:A) (v:Q (f a)), C (f a;v)), HomotopyExtensionAlong f C p) * (forall (h k : forall z, C z), HomotopyExtendableAlong n f (fun z => h z = k z))) end. Definition ooHomotopyExtendableAlong {A B} {Q : B -> Type} (f : A -> B) (C : sig Q -> Type) := forall n, HomotopyExtendableAlong n f C. Definition extension_functor_sigma {A B} {P : A -> Type} {Q : B -> Type} (f : A -> B) (g : forall a, P a -> Q (f a)) (C : sig Q -> Type) (ef : HomotopyExtendableAlong 1 f C) (eg : forall a, ExtendableAlong 1 (g a) (fun v => C (f a ; v))) (s : forall z, C (functor_sigma f g z)) : ExtensionAlong (functor_sigma f g) C s. Proof. srefine (_;_). - intros [b v]; revert b v. refine ((fst ef _).1). intros a. refine ((fst (eg a) _).1). intros u. exact (s (a;u)). - intros [a u]; cbn. refine ((fst ef _).2 _ _ @ _). exact ((fst (eg a) _).2 u). Defined. Definition extendable_functor_sigma (n : nat) {A B} {P : A -> Type} {Q : B -> Type} (f : A -> B) (g : forall a, P a -> Q (f a)) (C : sig Q -> Type) (ef : HomotopyExtendableAlong n f C) (eg : forall a, ExtendableAlong n (g a) (fun v => C (f a ; v))) : ExtendableAlong n (functor_sigma f g) C. Proof. revert C ef eg; simple_induction n n IH; intros C ef eg; [ exact tt | split ]. - apply extension_functor_sigma. + exact (fst ef, fun _ _ => tt). + intros a; exact (fst (eg a) , fun _ _ => tt). - intros h k; apply IH. + exact (snd ef h k). + intros a; apply (snd (eg a)). Defined. Definition ooextendable_functor_sigma {A B} {P : A -> Type} {Q : B -> Type} (f : A -> B) (g : forall a, P a -> Q (f a)) (C : sig Q -> Type) (ef : ooHomotopyExtendableAlong f C) (eg : forall a, ooExtendableAlong (g a) (fun v => C (f a ; v))) : ooExtendableAlong (functor_sigma f g) C := fun n => extendable_functor_sigma n f g C (ef n) (fun a => eg a n). (** ** Extendability along [functor_sum] *) Definition extension_functor_sum {A B A' B'} (f : A -> A') (g : B -> B') (P : A' + B' -> Type) (ef : ExtendableAlong 1 f (P o inl)) (eg : ExtendableAlong 1 g (P o inr)) (h : forall z, P (functor_sum f g z)) : ExtensionAlong (functor_sum f g) P h. Proof. srefine (sum_ind _ _ _ ; sum_ind _ _ _). + exact (fst ef (h o inl)).1. + exact (fst eg (h o inr)).1. + exact (fst ef (h o inl)).2. + exact (fst eg (h o inr)).2. Defined. Definition extendable_functor_sum (n : nat) {A B A' B'} (f : A -> A') (g : B -> B') (P : A' + B' -> Type) (ef : ExtendableAlong n f (P o inl)) (eg : ExtendableAlong n g (P o inr)) : ExtendableAlong n (functor_sum f g) P. Proof. revert P ef eg; induction n as [|n IH]; intros P ef eg; [ exact tt | split ]. - intros h; apply extension_functor_sum. + exact (fst ef, fun _ _ => tt). + exact (fst eg, fun _ _ => tt). - intros h k. apply IH. + exact (snd ef (h o inl) (k o inl)). + exact (snd eg (h o inr) (k o inr)). Defined. Definition ooextendable_functor_sum {A B A' B'} (f : A -> A') (g : B -> B') (P : A' + B' -> Type) (ef : ooExtendableAlong f (P o inl)) (eg : ooExtendableAlong g (P o inr)) : ooExtendableAlong (functor_sum f g) P. Proof. intros n; apply extendable_functor_sum; [ apply ef | apply eg ]. Defined. (** ** Extendability along [functor_coeq] *) (** The path algebra in these proofs is terrible on its own. But by replacing the maps with cofibrations so that many equalities hold definitionally, and modifying the extensions to also be strict, it becomes manageable with a bit of dependent-path technology. *) (** First we show that if we can extend in [C] along [k], and we can extend in appropriate path-types of [C] along [h], then we can extend in [C] along [functor_coeq]. This is where the hard work is. *) Definition extension_functor_coeq {B A f g B' A' f' g'} {h : B -> B'} {k : A -> A'} {p : k o f == f' o h} {q : k o g == g' o h} {C : Coeq f' g' -> Type} (ek : ExtendableAlong 1 k (C o coeq)) (eh : forall (u v : forall x : B', C (coeq (g' x))), ExtendableAlong 1 h (fun x => u x = v x)) (s : forall x, C (functor_coeq h k p q x)) : ExtensionAlong (functor_coeq h k p q) C s. Proof. (** We start by change the problem to involve [CylCoeq] with cofibrations. *) set (C' := C o pr_cylcoeq p q). set (s' x := pr_cyl_cylcoeq p q x # s x). assert (e : ExtensionAlong (cyl_cylcoeq p q) C' s'). 2:{ pose (ex := fst (extendable_equiv 1 C (pr_cylcoeq p q)) e.1). exists (ex.1); intros x. apply (equiv_inj (transport C (pr_cyl_cylcoeq p q x))). exact (apD _ (pr_cyl_cylcoeq p q x) @ ex.2 _ @ e.2 x). } (** We have to transfer the hypotheses along those equivalences too. We do it using [cyl_extendable] so that the resulting extensions compute definitionally. Note that this means we never need to refer to the [.2] parts of the extensions, since they are identity paths. *) pose (ea1 := fun u => (fst (cyl_extendable' 1 _ _ ek) u).1). assert (eb'' : forall u v, ExtendableAlong 1 cyl (fun x:Cyl h => DPath C' (cglue x) (u x) (v x))). { intros u v. rapply extendable_postcompose'. 2:{ rapply (cancelL_extendable 1 _ cyl pr_cyl). - rapply extendable_equiv. - exact (eh (fun x => cglue x # u (cyr x)) (v o cyr)). } intros x; subst C'. refine ((dp_compose (pr_cylcoeq p q) C _)^-1 oE _). symmetry; srapply equiv_ds_fill_lr. 3:rapply ap_pr_cylcoeq_cglue. all:srapply (transport (fun r => DPath C r _ _)). 3:exact (dp_inverse (dp_compose _ C _ (apD u (eissect pr_cyl x) : DPath _ _ _ _))). 4:exact (dp_inverse (dp_compose _ C _ (apD v (eissect pr_cyl x) : DPath _ _ _ _))). 1:change (fun y => pr_cylcoeq p q (coeq (functor_cyl p y))) with (fun y => coeq (f := f') (g := g') (pr_cyl (functor_cyl p y))). 2:change (fun y => pr_cylcoeq p q (coeq (functor_cyl q y))) with (fun y => coeq (f := f') (g := g') (pr_cyl (functor_cyl q y))). all:refine ((ap_V _ (eissect pr_cyl x))^ @ _). all: exact (ap_compose (fun x => pr_cyl (functor_cyl _ x)) coeq _). } pose (eb1 := fun u v w => (fst (cyl_extendable _ _ _ (eb'' u v)) w).1). (** Now we construct an extension using Coeq-induction, and prove that it *is* an extension also using Coeq-induction. *) srefine (_;_); srapply Coeq_ind. + exact (ea1 (s' o coeq)). + apply eb1; intros b. rapply (dp_compose' _ _ (ap_cyl_cylcoeq_cglue p q b)). exact (apD s' (cglue b)). + (** Since we're using cofibrations, this holds definitionally. *) intros a; reflexivity. + (** And this one is much simpler than it would be otherwise. *) intros b. apply ds_dp. rapply ds_G1. refine (dp_apD_compose' _ _ (ap_cyl_cylcoeq_cglue p q b) _ @ _). apply moveR_equiv_V. nrapply Coeq_ind_beta_cglue. Defined. (** Now we can easily iterate into higher extendability. *) Definition extendable_functor_coeq (n : nat) {B A f g B' A' f' g'} {h : B -> B'} {k : A -> A'} {p : k o f == f' o h} {q : k o g == g' o h} {C : Coeq f' g' -> Type} (ek : ExtendableAlong n k (C o coeq)) (eh : forall (u v : forall x : B', C (coeq (g' x))), ExtendableAlong n h (fun x => u x = v x)) : ExtendableAlong n (functor_coeq h k p q) C. Proof. revert C ek eh; simple_induction n n IH; intros C ek eh; [ exact tt | split ]. - apply extension_functor_coeq. + exact (fst ek , fun _ _ => tt). + exact (fun u v => (fst (eh u v) , fun _ _ => tt)). - intros u v; apply IH. + exact (snd ek (u o coeq) (v o coeq)). + exact (snd (eh (u o coeq o g') (v o coeq o g'))). Defined. Definition ooextendable_functor_coeq {B A f g B' A' f' g'} {h : B -> B'} {k : A -> A'} {p : k o f == f' o h} {q : k o g == g' o h} {C : Coeq f' g' -> Type} (ek : ooExtendableAlong k (C o coeq)) (eh : forall (u v : forall x : B', C (coeq (g' x))), ooExtendableAlong h (fun x => u x = v x)) : ooExtendableAlong (functor_coeq h k p q) C := fun n => extendable_functor_coeq n (ek n) (fun u v => eh u v n). (** Since extending at level [n.+1] into [C] implies extending at level [n] into path-types of [C], we get the following corollary. *) Definition extendable_functor_coeq' (n : nat) {B A f g B' A' f' g'} {h : B -> B'} {k : A -> A'} {p : k o f == f' o h} {q : k o g == g' o h} {C : Coeq f' g' -> Type} (ek : ExtendableAlong n k (C o coeq)) (eh : ExtendableAlong n.+1 h (C o coeq o g')) : ExtendableAlong n (functor_coeq h k p q) C. Proof. apply extendable_functor_coeq. 1:assumption. exact (snd eh). Defined. Definition ooextendable_functor_coeq' {B A f g B' A' f' g'} {h : B -> B'} {k : A -> A'} {p : k o f == f' o h} {q : k o g == g' o h} {C : Coeq f' g' -> Type} (ek : ooExtendableAlong k (C o coeq)) (eh : ooExtendableAlong h (C o coeq o g')) : ooExtendableAlong (functor_coeq h k p q) C := fun n => extendable_functor_coeq' n (ek n) (eh n.+1). Coq-HoTT-9.0/theories/Factorization.v000066400000000000000000000344021474641544500175660ustar00rootroot00000000000000(** * Factorizations and factorization systems. *) Require Import HoTT.Basics HoTT.Types. Require Import Extensions Homotopy.IdentitySystems. Local Open Scope path_scope. (** ** Factorizations *) Section Factorization. Universes ctxi. Context {class1 class2 : forall (X Y : Type@{ctxi}), (X -> Y) -> Type@{ctxi}} `{forall (X Y : Type@{ctxi}) (g:X->Y), IsHProp (class1 _ _ g)} `{forall (X Y : Type@{ctxi}) (g:X->Y), IsHProp (class2 _ _ g)} {A B : Type@{ctxi}} {f : A -> B}. (** A factorization of [f] into a first factor lying in [class1] and a second factor lying in [class2]. *) Record Factorization := { intermediate : Type@{ctxi} ; factor1 : A -> intermediate ; factor2 : intermediate -> B ; fact_factors : factor2 o factor1 == f ; inclass1 : class1 _ _ factor1 ; inclass2 : class2 _ _ factor2 }. Lemma issig_Factorization : { I : Type & { g : A -> I & { h : I -> B & { p : h o g == f & { gin1 : class1 _ _ g & class2 _ _ h }}}}} <~> Factorization. Proof. issig. Defined. (** A path between factorizations is equivalent to a structure of the following sort. *) Record PathFactorization {fact fact' : Factorization} := { path_intermediate : intermediate fact <~> intermediate fact' ; path_factor1 : path_intermediate o factor1 fact == factor1 fact' ; path_factor2 : factor2 fact == factor2 fact' o path_intermediate ; path_fact_factors : forall a, path_factor2 (factor1 fact a) @ ap (factor2 fact') (path_factor1 a) @ fact_factors fact' a = fact_factors fact a }. Arguments PathFactorization fact fact' : clear implicits. Lemma issig_PathFactorization (fact fact' : Factorization) : { path_intermediate : intermediate fact <~> intermediate fact' & { path_factor1 : path_intermediate o factor1 fact == factor1 fact' & { path_factor2 : factor2 fact == factor2 fact' o path_intermediate & forall a, path_factor2 (factor1 fact a) @ ap (factor2 fact') (path_factor1 a) @ fact_factors fact' a = fact_factors fact a }}} <~> PathFactorization fact fact'. Proof. issig. Defined. Definition equiv_path_factorization `{Univalence} (fact fact' : Factorization) : PathFactorization fact fact' <~> fact = fact'. Proof. refine (_ oE (issig_PathFactorization fact fact')^-1). revert fact fact'; apply (equiv_path_issig_contr issig_Factorization). { intros [I [f1 [f2 [ff [oc1 oc2]]]]]. exists (equiv_idmap I); cbn. exists (fun x:A => 1%path); cbn. exists (fun x:I => 1%path); cbn. intros; apply concat_1p. } intros [I [f1 [f2 [ff [oc1 oc2]]]]]. contr_sigsig I (equiv_idmap I); cbn. contr_sigsig f1 (fun x:A => idpath (f1 x)); cbn. contr_sigsig f2 (fun x:I => idpath (f2 x)); cbn. refine (contr_equiv' {ff' : f2 o f1 == f & ff == ff'} _). symmetry; srefine (equiv_functor_sigma' (equiv_sigma_contr _) _). { intros h; cbn. srefine (@istrunc_sigma _ _ _ _ _); [ | intros a]; apply contr_inhabited_hprop; try exact _; assumption. } intros [ff' [oc1' oc2']]; cbn. refine (equiv_functor_forall' (equiv_idmap _) _); intros a. refine (equiv_path_inverse _ _ oE _). apply equiv_concat_l; symmetry; apply concat_1p. Defined. Definition path_factorization `{Univalence} (fact fact' : Factorization) : PathFactorization fact fact' -> fact = fact' := equiv_path_factorization fact fact'. End Factorization. Arguments Factorization class1 class2 {A B} f. Arguments PathFactorization {class1 class2 A B f} fact fact'. (* This enables us to talk about "the image of a map" as a factorization but also as the intermediate object appearing in it, as is common in informal mathematics. *) Coercion intermediate : Factorization >-> Sortclass. (** ** Factorization Systems *) (** A ("unique" or "orthogonal") factorization system consists of a couple of classes of maps, closed under composition, such that every map admits a unique factorization. *) Record FactorizationSystem@{i j k} := { class1 : forall {X Y : Type@{i}}, (X -> Y) -> Type@{j} ; ishprop_class1 : forall {X Y : Type@{i}} (g:X->Y), IsHProp (class1 g) ; class1_isequiv : forall {X Y : Type@{i}} (g:X->Y) {geq:IsEquiv g}, class1 g ; class1_compose : forall {X Y Z : Type@{i}} (g:X->Y) (h:Y->Z), class1 g -> class1 h -> class1 (h o g) ; class2 : forall {X Y : Type@{i}}, (X -> Y) -> Type@{k} ; ishprop_class2 : forall {X Y : Type@{i}} (g:X->Y), IsHProp (class2 g) ; class2_isequiv : forall {X Y : Type@{i}} (g:X->Y) {geq:IsEquiv g}, class2 g ; class2_compose : forall {X Y Z : Type@{i}} (g:X->Y) (h:Y->Z), class2 g -> class2 h -> class2 (h o g) ; (** Morally, the uniqueness of factorizations says that [Factorization class1 class2 f] is contractible. However, in practice we always *prove* that by way of [path_factorization], and we frequently want to *use* the components of a [PathFactorization] as well. Thus, as data we store the canonical factorization and a [PathFactorization] between any two such, and prove in a moment that this implies contractibility of the space of factorizations. *) factor : forall {X Y : Type@{i}} (f:X->Y), Factorization@{i} (@class1) (@class2) f ; path_factor : forall {X Y : Type@{i}} (f:X->Y) (fact : Factorization@{i} (@class1) (@class2) f) (fact' : Factorization@{i} (@class1) (@class2) f), PathFactorization@{i} fact fact' }. Global Existing Instances ishprop_class1 ishprop_class2. (** The type of factorizations is, as promised, contractible. *) Theorem contr_factor `{Univalence} (factsys : FactorizationSystem) {X Y : Type} (f : X -> Y) : Contr (Factorization (@class1 factsys) (@class2 factsys) f). Proof. apply contr_inhabited_hprop. - apply hprop_allpath. intros fact fact'. apply path_factorization; try exact _. apply path_factor. - apply factor. Defined. Section FactSys. Context (factsys : FactorizationSystem). Definition Build_Factorization' {X Y} := @Build_Factorization (@class1 factsys) (@class2 factsys) X Y. Definition Build_PathFactorization' {X Y} := @Build_PathFactorization (@class1 factsys) (@class2 factsys) X Y. (** The left class is right-cancellable and the right class is left-cancellable. *) Definition cancelR_class1 `{Funext} {X Y Z} (f : X -> Y) (g : Y -> Z) : class1 factsys f -> class1 factsys (g o f) -> class1 factsys g. Proof. intros c1f c1gf. destruct (factor factsys g) as [I g1 g2 gf c1g1 c2g2]. pose (fact := Build_Factorization' (g o f) Z (g o f) (idmap) (fun x => 1) c1gf (class2_isequiv factsys idmap)). pose (fact' := Build_Factorization' (g o f) I (g1 o f) g2 (fun x => gf (f x)) (class1_compose factsys f g1 c1f c1g1) c2g2). destruct (path_factor factsys (g o f) fact' fact) as [q q1 q2 qf]; simpl in *. refine (transport (class1 factsys) (path_arrow _ _ gf) _). refine (class1_compose factsys g1 g2 c1g1 _). apply class1_isequiv. apply (isequiv_homotopic _ (fun i => (q2 i)^)). Defined. Definition cancelL_class2 `{Funext} {X Y Z} (f : X -> Y) (g : Y -> Z) : class2 factsys g -> class2 factsys (g o f) -> class2 factsys f. Proof. intros c2g c2gf. destruct (factor factsys f) as [I f1 f2 ff c1f1 c2f2]. pose (fact := Build_Factorization' (g o f) X (idmap) (g o f) (fun x => 1) (class1_isequiv factsys idmap) c2gf). pose (fact' := Build_Factorization' (g o f) I f1 (g o f2) (fun x => ap g (ff x)) c1f1 (class2_compose factsys f2 g c2f2 c2g)). destruct (path_factor factsys (g o f) fact fact') as [q q1 q2 qf]; simpl in *. refine (transport (class2 factsys) (path_arrow _ _ ff) _). refine (class2_compose factsys f1 f2 _ c2f2). apply class2_isequiv. apply (isequiv_homotopic _ q1). Defined. (** The two classes of maps are automatically orthogonal, i.e. any commutative square from a [class1] map to a [class2] map has a unique diagonal filler. For now, we only bother to define the lift; in principle we ought to show that the type of lifts is contractible. *) Universe ctxi. Context {A B X Y : Type@{ctxi}} (i : A -> B) (c1i : class1 factsys i) (p : X -> Y) (c2p : class2 factsys p) (f : A -> X) (g : B -> Y) (h : p o f == g o i). (** First we factor [f] *) Let C : Type := intermediate (factor factsys f). Let f1 : A -> C := factor1 (factor factsys f). Let f2 : C -> X := factor2 (factor factsys f). Let ff : f2 o f1 == f := fact_factors (factor factsys f). (** and [g] *) Let D : Type := intermediate (factor factsys g). Let g1 : B -> D := factor1 (factor factsys g). Let g2 : D -> Y := factor2 (factor factsys g). Let gf : g2 o g1 == g := fact_factors (factor factsys g). (** Now we observe that [p o f2] and [f1], and [g2] and [g1 o i], are both factorizations of the common diagonal of the commutative square (for which we use [p o f], but we could equally well use [g o i]. *) Let fact : Factorization (@class1 factsys) (@class2 factsys) (p o f) := Build_Factorization' (p o f) C f1 (p o f2) (fun a => ap p (ff a)) (inclass1 (factor factsys f)) (class2_compose factsys f2 p (inclass2 (factor factsys f)) c2p). Let fact' : Factorization (@class1 factsys) (@class2 factsys) (p o f) := Build_Factorization' (p o f) D (g1 o i) g2 (fun a => gf (i a) @ (h a)^) (class1_compose factsys i g1 c1i (inclass1 (factor factsys g))) (inclass2 (factor factsys g)). (** Therefore, by the uniqueness of factorizations, we have an equivalence [q] relating them. *) Let q : C <~> D := path_intermediate (path_factor factsys (p o f) fact fact'). Let q1 : q o f1 == g1 o i := path_factor1 (path_factor factsys (p o f) fact fact'). Let q2 : p o f2 == g2 o q := path_factor2 (path_factor factsys (p o f) fact fact'). (** Using this, we can define the lift. *) Definition lift_factsys : B -> X := f2 o q^-1 o g1. (** And the commutative triangles making it a lift *) Definition lift_factsys_tri1 : lift_factsys o i == f. Proof. intros x. refine (ap (f2 o q^-1) (q1 x)^ @ _). transitivity (f2 (f1 x)). + apply ap, eissect. + apply ff. Defined. Definition lift_factsys_tri2 : p o lift_factsys == g. Proof. intros x. refine (q2 _ @ _). transitivity (g2 (g1 x)). + apply ap, eisretr. + apply gf. Defined. (** And finally prove that these two triangles compose to the given commutative square. *) Definition lift_factsys_square (x : A) : ap p (lift_factsys_tri1 x)^ @ lift_factsys_tri2 (i x) = h x. Proof. unfold lift_factsys_tri1, lift_factsys_tri2. Open Scope long_path_scope. (* First we use the one aspect of the uniqueness of factorizations that we haven't mentioned yet. *) pose (r := path_fact_factors (path_factor factsys (p o f) fact fact') x : q2 (f1 x) @ ap g2 (q1 x) @ (gf (i x) @ (h x)^) = ap p (ff x)). rewrite concat_p_pp in r. apply moveL_pM, moveR_Vp in r. refine (_ @ r); clear r. (* Now we can cancel some whiskered paths on both sides. *) repeat rewrite inv_pp; repeat rewrite ap_pp; rewrite ap_V. repeat rewrite concat_pp_p; apply whiskerL. repeat rewrite concat_p_pp; apply whiskerR. (* Next we set up for a naturality. *) rewrite (ap_compose q^-1 f2), <- ap_pp, <- inv_pp. (* The next line appears to do nothing, but in fact it is necessary for the subsequent [rewrite] to succeed, because [lift_factsys] appears in the invisible implicit point-arguments of [paths]. One way to discover issues of that sort is to turn on printing of all implicit argumnets with [Set Printing All]; another is to use [Set Debug Tactic Unification] and inspect the output to see what [rewrite] is trying and failing to unify. *) unfold lift_factsys. rewrite <- ap_pp. rewrite <- ap_V, <- ap_compose. rewrite (concat_Ap q2). (* Now we can cancel another path *) rewrite concat_pp_p; apply whiskerL. (* And set up for an application of [ap]. *) rewrite ap_compose. rewrite <- ap_pp. apply ap. (* Now we apply the triangle identity [eisadj]. *) rewrite inv_pp, ap_pp, ap_V. rewrite <- eisadj. (* Finally, we rearrange and it becomes a naturality square. *) rewrite concat_pp_p; apply moveR_Vp. rewrite <- ap_V, inv_V, <- ap_compose. exact (concat_A1p (eisretr q) (q1 x)). Close Scope long_path_scope. Qed. End FactSys. Section FactsysExtensions. Context {factsys : FactorizationSystem}. (** We can deduce the lifting property in terms of extensions fairly easily from the version in terms of commutative squares. *) Definition extension_factsys {A B : Type} (f : A -> B) {c1f : class1 factsys f} (P : B -> Type) (c2P : class2 factsys (@pr1 B P)) (d : forall a:A, P (f a)) : ExtensionAlong f P d. Proof. pose (e := lift_factsys factsys f c1f pr1 c2P (fun a => (f a ; d a)) idmap (fun a => 1)). pose (e2 := lift_factsys_tri2 factsys f c1f pr1 c2P (fun a => (f a ; d a)) idmap (fun a => 1)). exists (fun a => (e2 a) # (e a).2). intros a. pose (e1 := lift_factsys_tri1 factsys f c1f pr1 c2P (fun a => (f a ; d a)) idmap (fun a => 1) a : e (f a) = (f a ; d a)). pose (e3 := moveL_M1 _ _ (((ap_V _ _)^ @@ 1) @ lift_factsys_square factsys f c1f pr1 c2P (fun a => (f a ; d a)) idmap (fun a => 1) a) : e2 (f a) = pr1_path e1). refine (ap (fun p => transport P p (e (f a)).2) e3 @ _). exact (pr2_path e1). Defined. End FactsysExtensions. Coq-HoTT-9.0/theories/Functorish.v000066400000000000000000000023171474641544500170760ustar00rootroot00000000000000Require Import HoTT.Basics Types.Universe. Local Open Scope path_scope. Section Functorish. Context `{Univalence}. (* We do not need composition to be preserved. *) Class Functorish (F : Type -> Type) := { fmap {A B} (f : A -> B) : F A -> F B ; fmap_idmap (A:Type) : fmap (idmap : A -> A) = idmap }. Global Arguments fmap F {FF} {A B} f _ : rename. Global Arguments fmap_idmap F {FF A} : rename. Context (F : Type -> Type). Context {FF : Functorish F}. Proposition isequiv_fmap {A B} (f : A -> B) `{IsEquiv _ _ f} : IsEquiv (fmap F f). Proof. refine (equiv_induction (fun A' e => IsEquiv (fmap F e)) _ _ (Build_Equiv _ _ f _)). refine (transport _ (fmap_idmap F)^ _); try apply isequiv_idmap. (* This line may not be needed in a new enough coq. *) Defined. Proposition fmap_agrees_with_univalence {A B} (f : A -> B) `{IsEquiv _ _ f} : fmap F f = equiv_path _ _ (ap F (path_universe f)). Proof. refine (equiv_induction (fun A' e => fmap F e = equiv_path _ _ (ap F (path_universe e))) _ _ (Build_Equiv _ _ f _)). transitivity (idmap : F A -> F A). - apply fmap_idmap. - change (equiv_idmap A) with (equiv_path A A 1). rewrite (@eta_path_universe _ A A 1). exact 1. Defined. End Functorish. Coq-HoTT-9.0/theories/HFiber.v000066400000000000000000000230771474641544500161170ustar00rootroot00000000000000Require Import Basics Types Diagrams.CommutativeSquares HSet. Local Open Scope equiv_scope. Local Open Scope path_scope. (** * Basic facts about fibrations *) (* ** Homotopy fibers *) (** Paths in homotopy fibers can be constructed using [path_sigma] and [transport_paths_Fl]. *) Definition equiv_path_hfiber {A B : Type} {f : A -> B} {y : B} (x1 x2 : hfiber f y) : { q : x1.1 = x2.1 & x1.2 = ap f q @ x2.2 } <~> (x1 = x2). Proof. refine (equiv_path_sigma _ _ _ oE _). apply equiv_functor_sigma_id. intros p; simpl. refine (_ oE equiv_moveR_Vp _ _ _). exact (equiv_concat_l (transport_paths_Fl _ _) _). Defined. Definition path_hfiber_uncurried {A B : Type} {f : A -> B} {y : B} {x1 x2 : hfiber f y} : { q : x1.1 = x2.1 & x1.2 = ap f q @ x2.2 } -> (x1 = x2) := equiv_path_hfiber x1 x2. Definition path_hfiber {A B : Type} {f : A -> B} {y : B} {x1 x2 : hfiber f y} (q : x1.1 = x2.1) (r : x1.2 = ap f q @ x2.2) : x1 = x2 := path_hfiber_uncurried (q;r). (** If we rearrange this a bit, then it characterizes the fibers of [ap]. *) Definition hfiber_ap {A B : Type} {f : A -> B} {x1 x2 : A} (p : f x1 = f x2) : hfiber (ap f) p <~> ((x1 ; p) = (x2 ; 1) :> hfiber f (f x2)). Proof. refine (equiv_path_hfiber (x1;p) (x2;1%path) oE _). unfold hfiber; simpl. apply equiv_functor_sigma_id; intros q. refine (_ oE equiv_path_inverse _ _). exact (equiv_concat_r (concat_p1 _)^ _). Defined. (** Homotopic maps have equivalent fibers. *) Definition equiv_hfiber_homotopic {A B : Type} (f g : A -> B) (h : f == g) (b : B) : hfiber f b <~> hfiber g b. Proof. refine (Build_Equiv _ _ (fun fx => (fx.1 ; (h fx.1)^ @ fx.2)) _). refine (isequiv_adjointify _ (fun gx => (gx.1 ; (h gx.1) @ gx.2)) _ _); intros [a p]; simpl; apply ap. - apply concat_V_pp. - apply concat_p_Vp. Defined. (** Commutative squares induce maps between fibers. *) Definition functor_hfiber {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) (b : B) : hfiber f b -> hfiber g (k b). Proof. snrapply @functor_sigma. - exact h. - intros a e; exact ((p a)^ @ ap k e). Defined. (** This doesn't need to be defined as an instance, since typeclass search can already find it, but we state it here for the reader's benefit. *) Definition isequiv_functor_hfiber {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} `{IsEquiv A C h} `{IsEquiv B D k} (p : k o f == g o h) (b : B) : IsEquiv (functor_hfiber p b) := _. Definition equiv_functor_hfiber {A B C D} {f : A -> B} {g : C -> D} {h : A <~> C} {k : B <~> D} (p : k o f == g o h) (b : B) : hfiber f b <~> hfiber g (k b) := Build_Equiv _ _ (functor_hfiber p b) _. (** A version of functor_hfiber which is functorial in both the function and the point *) Definition functor_hfiber2 {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) {b : B} {b' : D} (q : k b = b') : hfiber f b -> hfiber g b'. Proof. srapply functor_sigma. - exact h. - intros a e. exact ((p a)^ @ ap k e @ q). Defined. Global Instance isequiv_functor_hfiber2 {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} `{IsEquiv A C h} `{IsEquiv B D k} (p : k o f == g o h) {b : B} {b' : D} (q : k b = b') : IsEquiv (functor_hfiber2 p q). Proof. refine (isequiv_functor_sigma (f := h)); intros a. refine (isequiv_compose (f := fun e => (p a)^ @ ap k e) (g := fun e' => e' @ q)). Defined. Definition equiv_functor_hfiber2 {A B C D} {f : A -> B} {g : C -> D} {h : A <~> C} {k : B <~> D} (p : k o f == g o h) {b : B} {b' : D} (q : k b = b') : hfiber f b <~> hfiber g b' := Build_Equiv _ _ (functor_hfiber2 p q) _. Definition functor_hfiber_compose {A B C X Y Z : Type} {k : A -> B} {l : B -> C} {f : A -> X} {g : B -> Y} {h : C -> Z} {i : X -> Y} {j : Y -> Z} (H : i o f == g o k) (K : j o g == h o l) : forall x, functor_hfiber (comm_square_comp' H K) x == (functor_hfiber K (i x)) o (functor_hfiber H x : hfiber f x -> _). Proof. intros x [y p]. destruct p. apply (path_sigma' _ idpath). refine (concat_p1 _ @ _). refine (inv_pp _ _ @ ap _ _). refine ((ap_V _ _)^ @ ap _ _^). apply concat_p1. Defined. (** ** The 3x3 lemma for fibrations *) Definition hfiber_functor_hfiber {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) (b : B) (c : C) (q : g c = k b) : hfiber (functor_hfiber p b) (c;q) <~> hfiber (functor_hfiber (fun x => (p x)^) c) (b;q^). Proof. rapply (equiv_functor_sigma_id _ oE _ oE (equiv_functor_sigma_id _)^-1). 1,3:intros; rapply equiv_path_sigma. refine (equiv_sigma_assoc _ _ oE _ oE (equiv_sigma_assoc _ _)^-1). apply equiv_functor_sigma_id; intros a; cbn. refine (equiv_sigma_symm _ oE _). do 2 (apply equiv_functor_sigma_id; intro). refine ((equiv_ap inverse _ _)^-1 oE _). refine (equiv_concat_r (inv_V q)^ _ oE _). apply equiv_concat_l. abstract (rewrite !transport_paths_Fl, !inv_pp, !inv_V, concat_pp_p; reflexivity). Defined. (** ** Replacing a map with a fibration *) Definition equiv_fibration_replacement {B C} (f:C ->B) : C <~> {y:B & hfiber f y}. Proof. snrefine (Build_Equiv _ _ _ ( Build_IsEquiv C {y:B & {x:C & f x = y}} (fun c => (f c; (c; idpath))) (fun c => c.2.1) _ (fun c => idpath) _)). - intros [? [? []]]; reflexivity. - reflexivity. Defined. Definition hfiber_fibration {X} (x : X) (P:X->Type) : P x <~> @hfiber (sig P) X pr1 x. Proof. snrefine (Build_Equiv _ _ _ (Build_IsEquiv (P x) { z : sig P & z.1 = x } (fun Px => ((x; Px); idpath)) (fun Px => transport P Px.2 Px.1.2) _ (fun Px => idpath) _)). - intros [[] []]; reflexivity. - reflexivity. Defined. (** ** Exercise 4.4: The unstable octahedral axiom. *) Section UnstableOctahedral. Context (n : trunc_index) {A B C : Type} (f : A -> B) (g : B -> C). Definition hfiber_compose_map (c : C) : hfiber (g o f) c -> hfiber g c := fun x => (f x.1 ; x.2). Definition hfiber_hfiber_compose_map (b : B) : hfiber (hfiber_compose_map (g b)) (b;1) <~> hfiber f b. Proof. unfold hfiber, hfiber_compose_map. (** Once we "destruct" the equality in a sigma type, the rest is just shuffling of data and path induction. *) refine (_ oE equiv_functor_sigma_id (fun x => (equiv_path_sigma _ _ _)^-1)); cbn. make_equiv_contr_basedpaths. Defined. Definition hfiber_compose (c : C) : hfiber (g o f) c <~> { w : hfiber g c & hfiber f w.1 }. Proof. make_equiv_contr_basedpaths. Defined. Global Instance istruncmap_compose `{!IsTruncMap n g} `{!IsTruncMap n f} : IsTruncMap n (g o f). Proof. intros c. exact (istrunc_isequiv_istrunc _ (hfiber_compose c)^-1). Defined. End UnstableOctahedral. (** We characterize the fibers of [functor_forall], but only in the special case where the base map is [idmap]. This doesn't depend on anything else in this file, but can't be put in Types/Forall.v, because it requires results from Types/Sigma.v. *) Definition hfiber_functor_forall_id `{Funext} {A : Type} {P Q : A -> Type} (h : forall a, P a -> Q a) (g : forall a, Q a) : hfiber (functor_forall_id h) g <~> (forall a, hfiber (h a) (g a)). Proof. unfold hfiber, functor_forall_id, functor_forall. nrefine (equiv_sig_coind _ _ oE _). apply equiv_functor_sigma_id; intro f. apply equiv_apD10. Defined. (** ** Fibers of constant functions *) Definition hfiber_const A {B} (y y' : B) : hfiber (fun _ : A => y) y' <~> A * (y = y') := equiv_sigma_prod0 A (y = y'). Global Instance istruncmap_const n {A B} `{!IsTrunc n A} (y : B) `{!forall y', IsTrunc n (y = y')} : IsTruncMap n (fun _ : A => y) := fun y' => _. (** ** [IsTruncMap n.+1 f <-> IsTruncMap n (ap f)] *) Global Instance istruncmap_ap {A B} n (f:A -> B) `{!IsTruncMap n.+1 f} : forall x y, IsTruncMap n (@ap _ _ f x y) := fun x x' y => istrunc_equiv_istrunc _ (hfiber_ap y)^-1. Definition istruncmap_from_ap {A B} n (f:A -> B) `{!forall x y, IsTruncMap n (@ap _ _ f x y)} : IsTruncMap n.+1 f. Proof. intro y; apply istrunc_S. intros [a p] [b q]; destruct q; exact (istrunc_equiv_istrunc _ (hfiber_ap p)). Defined. Definition equiv_istruncmap_ap `{Funext} {A B} n (f:A -> B) : IsTruncMap n.+1 f <~> (forall x y, IsTruncMap n (@ap _ _ f x y)) := equiv_iff_hprop (@istruncmap_ap _ _ n f) (@istruncmap_from_ap _ _ n f). Global Instance isequiv_ap_isembedding {A B} (f : A -> B) `{!IsEmbedding f} : forall x y, IsEquiv (@ap _ _ f x y). Proof. intros x y. apply isequiv_contr_map,_. Defined. Definition equiv_ap_isembedding {A B} (f : A -> B) `{!IsEmbedding f} (x y : A) : (x = y) <~> (f x = f y) := Build_Equiv _ _ (ap f) _. Definition isembedding_isequiv_ap {A B} (f : A -> B) `{!forall x y, IsEquiv (@ap _ _ f x y)} : IsEmbedding f. Proof. rapply istruncmap_from_ap. Defined. Definition equiv_isequiv_ap_isembedding `{Funext} {A B} (f : A -> B) : IsEmbedding f <~> (forall x y, IsEquiv (@ap _ _ f x y)). Proof. exact (equiv_iff_hprop (@isequiv_ap_isembedding _ _ f) (@isembedding_isequiv_ap _ _ f)). Defined. (** It follows from [isembedding_isequiv_ap] and [isequiv_ap_equiv_fun] that [equiv_fun] is an embedding. *) Global Instance isembedding_equiv_fun `{Funext} {A B : Type} : IsEmbedding (@equiv_fun A B). Proof. rapply isembedding_isequiv_ap. Defined. Lemma ap_isinj_embedding_beta {X Y : Type} (f : X -> Y) {I : IsEmbedding f} {x0 x1 : X} : forall (p : f x0 = f x1), ap f (isinj_embedding f I x0 x1 p) = p. Proof. equiv_intro (equiv_ap_isembedding f x0 x1) q. induction q. cbn. exact (ap _ (isinj_embedding_beta f)). Defined. Coq-HoTT-9.0/theories/HIT/000077500000000000000000000000001474641544500152045ustar00rootroot00000000000000Coq-HoTT-9.0/theories/HIT/Flattening.v000066400000000000000000000155041474641544500174730ustar00rootroot00000000000000(** * The flattening lemma. *) Require Import HoTT.Basics. Require Import Types.Paths Types.Forall Types.Sigma Types.Arrow Types.Universe. Local Open Scope path_scope. Require Import HoTT.Colimits.Coeq. (** The base HIT [W] is just a homotopy coequalizer [Coeq]. *) (** TODO: Make the names in this file more usable, move it into [Coeq.v], and use it to derive corresponding flattening lemmas for [pushout], etc. *) (** Now we define the flattened HIT which will be equivalent to the total space of a fibration over [W]. *) Module Export FlattenedHIT. Private Inductive Wtil (A B : Type) (f g : B -> A) (C : A -> Type) (D : forall b, C (f b) <~> C (g b)) : Type := | cct : forall a, C a -> Wtil A B f g C D. Arguments cct {A B f g C D} a c. Axiom ppt : forall {A B f g C D} (b:B) (y:C (f b)), @cct A B f g C D (f b) y = cct (g b) (D b y). Definition Wtil_ind {A B f g C D} (Q : Wtil A B f g C D -> Type) (cct' : forall a x, Q (cct a x)) (ppt' : forall b y, (ppt b y) # (cct' (f b) y) = cct' (g b) (D b y)) : forall w, Q w := fun w => match w with cct a x => fun _ => cct' a x end ppt'. Axiom Wtil_ind_beta_ppt : forall {A B f g C D} (Q : Wtil A B f g C D -> Type) (cct' : forall a x, Q (cct a x)) (ppt' : forall b y, (ppt b y) # (cct' (f b) y) = cct' (g b) (D b y)) (b:B) (y : C (f b)), apD (Wtil_ind Q cct' ppt') (ppt b y) = ppt' b y. End FlattenedHIT. Definition Wtil_rec {A B f g C} {D : forall b, C (f b) <~> C (g b)} (Q : Type) (cct' : forall a (x : C a), Q) (ppt' : forall b (y : C (f b)), cct' (f b) y = cct' (g b) (D b y)) : Wtil A B f g C D -> Q := Wtil_ind (fun _ => Q) cct' (fun b y => transport_const _ _ @ ppt' b y). Definition Wtil_rec_beta_ppt {A B f g C} {D : forall b, C (f b) <~> C (g b)} (Q : Type) (cct' : forall a (x : C a), Q) (ppt' : forall (b:B) (y : C (f b)), cct' (f b) y = cct' (g b) (D b y)) (b:B) (y: C (f b)) : ap (@Wtil_rec A B f g C D Q cct' ppt') (ppt b y) = ppt' b y. Proof. unfold Wtil_rec. eapply (cancelL (transport_const (ppt (C:=C) b y) _)). refine ((apD_const (@Wtil_ind A B f g C D (fun _ => Q) cct' _) (ppt b y))^ @ _). refine (Wtil_ind_beta_ppt (fun _ => Q) _ _ _ _). Defined. (** Now we define the fibration over it that we will be considering the total space of. *) Section AssumeAxioms. Context `{Univalence}. Context {B A : Type} {f g : B -> A}. Context {C : A -> Type} {D : forall b, C (f b) <~> C (g b)}. Let W' := Coeq f g. Let P : W' -> Type := Coeq_rec Type C (fun b => path_universe (D b)). (** Now we give the total space the same structure as [Wtil]. *) Let sWtil := { w:W' & P w }. Let scct (a:A) (x:C a) : sWtil := (exist P (coeq a) x). Let sppt (b:B) (y:C (f b)) : scct (f b) y = scct (g b) (D b y) := path_sigma' P (cglue b) (transport_path_universe' P (cglue b) (D b) (Coeq_rec_beta_cglue Type C (fun b0 => path_universe (D b0)) b) y). (** Here is the dependent eliminator *) Definition sWtil_ind (Q : sWtil -> Type) (scct' : forall a x, Q (scct a x)) (sppt' : forall b y, (sppt b y) # (scct' (f b) y) = scct' (g b) (D b y)) : forall w, Q w. Proof. apply sig_ind. refine (Coeq_ind (fun w => forall x:P w, Q (w;x)) (fun a x => scct' a x) _). intros b. apply (dpath_forall P (fun a b => Q (a;b)) _ _ (cglue b) (scct' (f b)) (scct' (g b))). intros y. set (q := transport_path_universe' P (cglue b) (D b) (Coeq_rec_beta_cglue Type C (fun b0 : B => path_universe (D b0)) b) y). rewrite transportD_is_transport. refine (_ @ apD (scct' (g b)) q^). refine (moveL_transport_V (fun x => Q (scct (g b) x)) q _ _ _). rewrite transport_compose, <- transport_pp. refine (_ @ sppt' b y). apply ap10, ap. refine (whiskerL _ (ap_exist P (coeq (g b)) _ _ q) @ _). exact ((path_sigma_p1_1p' _ _ _)^). Defined. (** The eliminator computes on the point constructor. *) Definition sWtil_ind_beta_cct (Q : sWtil -> Type) (scct' : forall a x, Q (scct a x)) (sppt' : forall b y, (sppt b y) # (scct' (f b) y) = scct' (g b) (D b y)) (a:A) (x:C a) : sWtil_ind Q scct' sppt' (scct a x) = scct' a x := 1. (** This would be its propositional computation rule on the path constructor... *) (** << Definition sWtil_ind_beta_ppt (Q : sWtil -> Type) (scct' : forall a x, Q (scct a x)) (sppt' : forall b y, (sppt b y) # (scct' (f b) y) = scct' (g b) (D b y)) (b:B) (y:C (f b)) : apD (sWtil_ind Q scct' sppt') (sppt b y) = sppt' b y. Proof. unfold sWtil_ind. (** ... but it's a doozy! *) Abort. >> *) (** Fortunately, it turns out to be enough to have the computation rule for the *non-dependent* eliminator! *) (** We could define that in terms of the dependent one, as usual... << Definition sWtil_rec (P : Type) (scct' : forall a (x : C a), P) (sppt' : forall b (y : C (f b)), scct' (f b) y = scct' (g b) (D b y)) : sWtil -> P := sWtil_ind (fun _ => P) scct' (fun b y => transport_const _ _ @ sppt' b y). >> *) (** ...but if we define it diindly, then it's easier to reason about. *) Definition sWtil_rec (Q : Type) (scct' : forall a (x : C a), Q) (sppt' : forall b (y : C (f b)), scct' (f b) y = scct' (g b) (D b y)) : sWtil -> Q. Proof. apply sig_ind. refine (Coeq_ind (fun w => P w -> Q) (fun a x => scct' a x) _). intros b. refine (dpath_arrow P (fun _ => Q) _ _ _ _). intros y. refine (transport_const _ _ @ _). refine (sppt' b _ @ ap _ _). refine ((transport_path_universe' P (cglue b) (D b) _ _)^). exact (Coeq_rec_beta_cglue _ _ _ _). Defined. Open Scope long_path_scope. Definition sWtil_rec_beta_ppt (Q : Type) (scct' : forall a (x : C a), Q) (sppt' : forall b (y : C (f b)), scct' (f b) y = scct' (g b) (D b y)) (b:B) (y: C (f b)) : ap (sWtil_rec Q scct' sppt') (sppt b y) = sppt' b y. Proof. unfold sWtil_rec, sppt. refine (@ap_sig_rec_path_sigma W' P Q _ _ (cglue b) _ _ _ _ @ _); simpl. rewrite (@Coeq_ind_beta_cglue B A f g). rewrite (ap10_dpath_arrow P (fun _ => Q) (cglue b) _ _ _ y). repeat rewrite concat_p_pp. (** Now everything cancels! *) rewrite ap_V, concat_pV_p, concat_pV_p, concat_pV_p, concat_Vp. by apply concat_1p. Qed. Close Scope long_path_scope. (** Woot! *) Definition equiv_flattening : Wtil A B f g C D <~> sWtil. Proof. (** The maps back and forth are obtained easily from the non-dependent eliminators. *) refine (equiv_adjointify (Wtil_rec _ scct sppt) (sWtil_rec _ cct ppt) _ _). (** The two homotopies are completely symmetrical, using the *dependent* eliminators, but only the computation rules for the non-dependent ones. *) - refine (sWtil_ind _ (fun a x => 1) _). intros b y. apply dpath_path_FFlr. rewrite concat_1p, concat_p1. rewrite sWtil_rec_beta_ppt. by symmetry; apply (@Wtil_rec_beta_ppt A B f g C D). - refine (Wtil_ind _ (fun a x => 1) _). intros b y. apply dpath_path_FFlr. rewrite concat_1p, concat_p1. rewrite Wtil_rec_beta_ppt. by symmetry; apply sWtil_rec_beta_ppt. Defined. End AssumeAxioms. Coq-HoTT-9.0/theories/HIT/FreeIntQuotient.v000066400000000000000000000103421474641544500204600ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Spaces.Int Spaces.Circle. Require Import Colimits.Coeq HIT.Flattening Truncations.Core Truncations.Connectedness. Local Open Scope path_scope. (** * Quotients by free actions of [Int] *) (** We will show that if [Int] acts freely on a set, then the set-quotient of that action can be defined without a 0-truncation, giving it a universal property for mapping into all types. *) Section FreeIntAction. Context `{Univalence}. Context (R : Type) `{IsHSet R}. (** A free action by [Int] is the same as a single autoequivalence [f] (the action of [1]) whose iterates are all pointwise distinct. *) Context (f : R <~> R) (f_free : forall (r : R) (n m : Int), (int_iter f n r = int_iter f m r) -> (n = m)). (** We can then define the quotient to be the coequalizer of [f] and the identity map. This gives it the desired universal property for all types; it remains to show that this definition gives a set. *) Let RmodZ := Coeq f idmap. (** Together, [R] and [f] define a fibration over [Circle]. By the flattening lemma, its total space is equivalent to the quotient. *) Global Instance isset_RmodZ : IsHSet RmodZ. Proof. nrefine (istrunc_equiv_istrunc { z : Circle & Circle_rec Type R (path_universe f) z} (_ oE (@equiv_flattening _ Unit Unit idmap idmap (fun _ => R) (fun _ => f))^-1 oE _)); try exact _. - unshelve rapply equiv_adjointify. + simple refine (Wtil_rec _ _ _). * intros u r; exact (coeq r). * intros u r; cbn. exact ((cglue r)^). + simple refine (Coeq_rec _ _ _). * exact (cct tt). * intros r; exact ((ppt tt r)^). + refine (Coeq_ind _ (fun a => 1) _); cbn; intros b. rewrite transport_paths_FlFr, concat_p1, ap_idmap. apply moveR_Vp; rewrite concat_p1. rewrite ap_compose. rewrite (Coeq_rec_beta_cglue (Wtil Unit Unit idmap idmap (unit_name R) (unit_name f)) (cct tt) (fun r => (ppt tt r)^) b). rewrite ap_V; symmetry. refine (inverse2 (Wtil_rec_beta_ppt RmodZ (unit_name (fun r => coeq r)) (unit_name (fun r => (cglue r)^)) tt b) @ inv_V _). + simple refine (Wtil_ind _ _ _); cbn. { intros [] ?; reflexivity. } intros [] r; cbn. rewrite transport_paths_FlFr, concat_p1, ap_idmap. apply moveR_Vp; rewrite concat_p1. rewrite ap_compose. refine (_ @ ap (ap _) (Wtil_rec_beta_ppt RmodZ (unit_name (fun r => coeq r)) (unit_name (fun r => (cglue r)^)) tt r)^). rewrite ap_V. rewrite (Coeq_rec_beta_cglue (Wtil Unit Unit idmap idmap (unit_name R) (unit_name f)) (cct tt) (fun r0 : R => (ppt tt r0)^) r). symmetry; apply inv_V. - apply equiv_functor_sigma_id; intros x. apply equiv_path. revert x; refine (Circle_ind _ 1 _); cbn. rewrite transport_paths_FlFr, concat_p1. apply moveR_Vp; rewrite concat_p1. rewrite Circle_rec_beta_loop. unfold loop. exact (Coeq_rec_beta_cglue _ _ _ _). - apply istrunc_S. intros xu yv. nrefine (istrunc_equiv_istrunc (n := -1) _ (equiv_path_sigma _ xu yv)). destruct xu as [x u], yv as [y v]; cbn. apply hprop_allpath. intros [p r] [q s]. set (P := Circle_rec Type R (path_universe f)) in *. assert (forall z, IsHSet (P z)). { simple refine (Circle_ind _ _ _); cbn beta. - exact _. - apply path_ishprop. } apply path_sigma_hprop; cbn. assert (t := r @ s^); clear r s. assert (xb := merely_path_is0connected Circle base x). assert (yb := merely_path_is0connected Circle base y). strip_truncations. destruct xb, yb. revert p q t. equiv_intro (equiv_loopCircle_int^-1) n. equiv_intro (equiv_loopCircle_int^-1) m. subst P. rewrite !Circle_action_is_iter. intros p. apply ap. exact (f_free u n m p). Qed. (** TODO: Prove that this [RmodZ] is equivalent to the set-quotient of [R] by a suitably defined equivalence relation. *) End FreeIntAction. Coq-HoTT-9.0/theories/HIT/Interval.v000066400000000000000000000025261474641544500171640ustar00rootroot00000000000000(** * Theorems about the homotopical interval. *) Require Import Basics.Overture Basics.PathGroupoids. Require Import Types.Paths. Local Open Scope path_scope. Module Export Interval. Private Inductive interval : Type0 := | zero : interval | one : interval. Axiom seg : zero = one. Definition interval_ind (P : interval -> Type) (a : P zero) (b : P one) (p : seg # a = b) : forall x:interval, P x := fun x => (match x return _ -> P x with | zero => fun _ => a | one => fun _ => b end) p. Axiom interval_ind_beta_seg : forall (P : interval -> Type) (a : P zero) (b : P one) (p : seg # a = b), apD (interval_ind P a b p) seg = p. End Interval. Definition interval_rec (P : Type) (a b : P) (p : a = b) : interval -> P := interval_ind (fun _ => P) a b (transport_const _ _ @ p). Definition interval_rec_beta_seg (P : Type) (a b : P) (p : a = b) : ap (interval_rec P a b p) seg = p. Proof. refine (cancelL (transport_const seg a) _ _ _). refine ((apD_const (interval_ind (fun _ => P) a b _) seg)^ @ _). refine (interval_ind_beta_seg (fun _ => P) _ _ _). Defined. (** ** The interval is contractible. *) Global Instance contr_interval : Contr interval | 0. Proof. apply (Build_Contr _ zero). refine (interval_ind _ 1 seg _). refine (transport_paths_r _ _ @ concat_1p _). Defined. Coq-HoTT-9.0/theories/HIT/README.txt000066400000000000000000000003601474641544500167010ustar00rootroot00000000000000The files in this directory use "private inductive types" in order to implement higher inductive types (HITs). Many of the files which use HITs are currently segregated into this directory, but they can also be found in other directories. Coq-HoTT-9.0/theories/HIT/SetCone.v000066400000000000000000000006041474641544500167330ustar00rootroot00000000000000Require Import HoTT.Basics Types.Unit. Require Import Colimits.Pushout. Require Import Truncations.Core. (** * Cones of HSets *) Section SetCone. Context {A B : HSet} (f : A -> B). Definition setcone := Trunc 0 (Pushout@{_ _ Set _} f (const_tt A)). Global Instance istrunc_setcone : IsHSet setcone := _. Definition setcone_point : setcone := tr (push (inr tt)). End SetCone. Coq-HoTT-9.0/theories/HIT/V.v000066400000000000000000000713731474641544500156130ustar00rootroot00000000000000(** * The cumulative hierarchy [V]. *) Require Import HoTT.Basics HoTT.Types. Require Import HSet TruncType. Require Import Colimits.SpanPushout. Require Import HoTT.Truncations.Core Colimits.Quotient. Local Open Scope nat_scope. Local Open Scope path_scope. (** Bitotal relation *) Definition bitotal {A B : Type} (R : A -> B -> HProp) := (forall a : A, hexists (fun (b : B) => R a b)) * (forall b : B, hexists (fun (a : A) => R a b)). (** ** The cumulative hierarchy V *) Module Export CumulativeHierarchy. Private Inductive V@{U' U | U < U'} : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V. Axiom setext : forall {A B : Type} (R : A -> B -> HProp) (bitot_R : bitotal R) (h : SPushout R -> V), set (h o (spushl R)) = set (h o (spushr R)). Axiom ishset_V : IsHSet V. Global Existing Instance ishset_V. (** The induction principle. Annotating the universes here greatly reduces the number of universe variables later in the file. For example, [function] below went from 279 to 3. If [V_ind] needs to be generalized in the future, check [function] to make sure things haven't exploded again. *) Fixpoint V_ind@{U' U u | U < U'} (P : V@{U' U} -> Type@{u}) (H_0trunc : forall v : V@{U' U}, IsTrunc 0 (P v)) (H_set : forall (A : Type@{U}) (f : A -> V) (H_f : forall a : A, P (f a)), P (set f)) (H_setext : forall (A B : Type@{U}) (R : A -> B -> HProp@{U}) (bitot_R : bitotal R) (h : SPushout R -> V) (H_h : forall x : SPushout R, P (h x)), transport@{U' u} _ (setext R bitot_R h) (H_set A (h o spushl R) (H_h oD spushl R)) = H_set B (h o spushr R) (H_h oD spushr R) ) (v : V) : P v := (match v with | set A f => fun _ _ => H_set A f (fun a => V_ind P H_0trunc H_set H_setext (f a)) end) H_setext H_0trunc. (** We don't need to axiomatize the computation rule because we get it for free thanks to 0-truncation *) End CumulativeHierarchy. Definition V_comp_setext (P : V -> Type) (H_0trunc : forall v : V, IsTrunc 0 (P v)) (H_set : forall (A : Type) (f : A -> V) (H_f : forall a : A, P (f a)), P (set f)) (H_setext : forall (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R) (h : SPushout R -> V) (H_h : forall x : SPushout R, P (h x)), (setext R bitot_R h) # (H_set A (h o spushl R) (H_h oD spushl R)) = H_set B (h o spushr R) (H_h oD spushr R) ) (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R) (h : SPushout R -> V) : apD (V_ind P H_0trunc H_set H_setext) (setext R bitot_R h) = H_setext A B R bitot_R h ((V_ind P H_0trunc H_set H_setext) oD h). Proof. apply path_ishprop. Defined. (** The non-dependent eliminator *) Definition V_rec (P : Type) (H_0trunc : IsTrunc 0 P) (H_set : forall (A : Type), (A -> V) -> (A -> P) -> P) (H_setext : forall (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R) (h : SPushout R -> V) (H_h : SPushout R -> P), H_set A (h o spushl R) (H_h o spushl R) = H_set B (h o spushr R) (H_h o spushr R) ) : V -> P. Proof. refine (V_ind _ _ H_set _). intros. exact (transport_const _ _ @ H_setext A B R bitot_R h H_h). Defined. Definition V_comp_nd_setext (P : Type) (H_0trunc : IsTrunc 0 P) (H_set : forall (A : Type), (A -> V) -> (A -> P) -> P) (H_setext : forall (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R) (h : SPushout R -> V) (H_h : SPushout R -> P), H_set A (h o spushl R) (H_h o spushl R) = H_set B (h o spushr R) (H_h o spushr R) ) (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R) (h : SPushout R -> V) : ap (V_rec P H_0trunc H_set H_setext) (setext R bitot_R h) = H_setext A B R bitot_R h ((V_rec P H_0trunc H_set H_setext) o h). Proof. apply path_ishprop. Defined. (** ** Alternative induction principle (This is close to the one from the book) *) Definition equal_img {A B C : Type} (f : A -> C) (g : B -> C) := (forall a : A, hexists (fun (b : B) => f a = g b)) * (forall b : B, hexists (fun (a : A) => f a = g b)). Definition setext' {A B : Type} (f : A -> V) (g : B -> V) (eq_img : equal_img f g) : set f = set g. Proof. pose (R := fun a b => Build_HProp (f a = g b)). pose (h := spushout_rec R V f g (fun _ _ r => r)). exact (setext R eq_img h). Defined. Definition V_rec' (P : Type) (H_0trunc : IsTrunc 0 P) (H_set : forall (A : Type), (A -> V) -> (A -> P) -> P) (H_setext' : forall (A B : Type) (f : A -> V) (g : B -> V), (equal_img f g) -> forall (H_f : A -> P) (H_g : B -> P), (equal_img H_f H_g) -> (H_set A f H_f) = (H_set B g H_g) ) : V -> P. Proof. refine (V_rec _ _ H_set _). intros A B R bitot_R h H_h. apply H_setext'. - split. + intro a. generalize (fst bitot_R a). apply (Trunc_functor (-1)). intros [b r]. exists b. exact (ap h (spglue R r)). + intro b. generalize (snd bitot_R b). apply (Trunc_functor (-1)). intros [a r]. exists a. exact (ap h (spglue R r)). - split. + intro a. generalize (fst bitot_R a). apply (Trunc_functor (-1)). intros [b r]. exists b. exact (ap H_h (spglue R r)). + intro b. generalize (snd bitot_R b). apply (Trunc_functor (-1)). intros [a r]. exists a. exact (ap H_h (spglue R r)). Defined. (** Note that the hypothesis H_setext' differs from the one given in section 10.5 of the HoTT book. *) Definition V_ind' (P : V -> Type) (H_0trunc : forall v : V, IsTrunc 0 (P v)) (H_set : forall (A : Type) (f : A -> V) (H_f : forall a : A, P (f a)), P (set f)) (H_setext' : forall (A B : Type) (f : A -> V) (g : B -> V) (eq_img: equal_img f g) (H_f : forall a : A, P (f a)) (H_g : forall b : B, P (g b)) (H_eqimg : (forall a : A, hexists (fun (b : B) => hexists (fun (p:f a = g b) => p # (H_f a) = H_g b))) * (forall b : B, hexists (fun (a : A) => hexists (fun (p:f a = g b) => p # (H_f a) = H_g b))) ), (setext' f g eq_img) # (H_set A f H_f) = (H_set B g H_g) ) : forall v : V, P v. Proof. apply V_ind with H_set; try assumption. intros A B R bitot_R h H_h. pose (f := h o spushl R : A -> V ). pose (g := h o spushr R : B -> V ). pose (H_f := H_h oD spushl R : forall a : A, P (f a)). pose (H_g := H_h oD spushr R : forall b : B, P (g b)). assert (eq_img : equal_img f g). { split. - intro a. generalize (fst bitot_R a). apply (Trunc_functor (-1)). intros [b r]. exists b. exact (ap h (spglue R r)). - intro b. generalize (snd bitot_R b). apply (Trunc_functor (-1)). intros [a r]. exists a. exact (ap h (spglue R r)). } transitivity (transport P (setext' (h o spushl R) (h o spushr R) eq_img) (H_set A (h o spushl R) (H_h oD spushl R))). { apply (ap (fun p => transport P p (H_set A (h o spushl R) (H_h oD spushl R)))). apply path_ishprop. } apply (H_setext' A B f g eq_img H_f H_g). split. - intro a. set (truncb := fst bitot_R a). generalize truncb. apply (Trunc_functor (-1)). intros [b Rab]. exists b. apply tr. exists (ap h (spglue R Rab)). apply (concatR (apD H_h (spglue R Rab))). apply inverse. unfold f, g. apply transport_compose. - intros b. set (trunca := snd bitot_R b). generalize trunca. apply (Trunc_functor (-1)). intros [a Rab]. exists a. apply tr. exists (ap h (spglue R Rab)). apply (concatR (apD H_h (spglue R Rab))). apply inverse. unfold f, g. apply transport_compose. Defined. (** Simpler induction principle when the goal is an hprop *) Definition V_ind_hprop (P : V -> Type) (H_set : forall (A : Type) (f : A -> V) (H_f : forall a : A, P (f a)), P (set f)) (isHProp_P : forall v : V, IsHProp (P v)) : forall v : V, P v. Proof. refine (V_ind _ _ H_set _). intros. apply path_ishprop. Defined. Section AssumingUA. Context `{ua : Univalence}. (** ** Membership relation *) Definition mem (x : V) : V -> HProp. Proof. simple refine (V_rec' _ _ _ _). - intros A f _. exact (hexists (fun a : A => f a = x)). - simpl. intros A B f g eqimg _ _ _. apply path_iff_hprop; simpl. + intro H. refine (Trunc_rec _ H). intros [a p]. generalize (fst eqimg a). apply (Trunc_functor (-1)). intros [b p']. exists b. transitivity (f a); auto with path_hints. + intro H. refine (Trunc_rec _ H). intros [b p]. generalize (snd eqimg b). apply (Trunc_functor (-1)). intros [a p']. exists a. transitivity (g b); auto with path_hints. Defined. Declare Scope set_scope. Notation "x ∈ v" := (mem x v) : set_scope. Open Scope set_scope. (** ** Subset relation *) Definition subset (x : V) (y : V) : HProp := Build_HProp (forall z : V, z ∈ x -> z ∈ y). Notation "x ⊆ y" := (subset x y) : set_scope. (** ** Bisimulation relation *) (** The equality in V lives in Type@{U'}. We define the bisimulation relation which is a U-small resizing of the equality in V: it must live in HProp_U : Type{U'}, hence the codomain is HProp@{U}. We then prove that bisimulation is equality (bisim_equals_id), then use it to prove the key lemma monic_set_present. *) (* We define bisimulation by double induction on V. We first fix the first argument as set(A,f) and define bisim_aux : V -> HProp, by induction. This is the inner of the two inductions. *) Local Definition bisim_aux (A : Type) (f : A -> V) (H_f : A -> V -> HProp) : V -> HProp. Proof. apply V_rec' with (fun B g _ => Build_HProp ( (forall a, hexists (fun b => H_f a (g b))) * forall b, hexists (fun a => H_f a (g b)) ) ). - exact _. - intros B B' g g' eq_img H_g H_g' H_img; simpl. apply path_iff_hprop; simpl. + intros [H1 H2]; split. * intro a. refine (Trunc_rec _ (H1 a)). intros [b H3]. generalize (fst eq_img b). unfold hexists. refine (@Trunc_functor (-1) {b0 : B' & g b = g' b0} {b0 : B' & H_f a (g' b0)} _). intros [b' p]. exists b'. exact (transport (fun x => H_f a x) p H3). * intro b'. refine (Trunc_rec _ (snd eq_img b')). intros [b p]. generalize (H2 b). apply (Trunc_functor (-1)). intros [a H3]. exists a. exact (transport (fun x => H_f a x) p H3). + intros [H1 H2]; split. * intro a. refine (Trunc_rec _ (H1 a)). intros [b' H3]. generalize (snd eq_img b'). apply (Trunc_functor (-1)). intros [b p]. exists b. exact (transport (fun x => H_f a x) p^ H3). * intro b. refine (Trunc_rec _ (fst eq_img b)). intros [b' p]. generalize (H2 b'). apply (Trunc_functor (-1)). intros [a H3]. exists a. exact (transport (fun x => H_f a x) p^ H3). Defined. (* Then we define bisim : V -> (V -> HProp) by induction again *) Definition bisimulation : V@{U' U} -> V@{U' U} -> HProp@{U}. Proof. refine (V_rec' (V -> HProp) _ bisim_aux _). intros A B f g eq_img H_f H_g H_img. apply path_forall. refine (V_ind_hprop _ _ _). intros C h _; simpl. apply path_iff_hprop; simpl. - intros [H1 H2]; split. + intro b. refine (Trunc_rec _ (snd H_img b)). intros [a p]. generalize (H1 a). apply (Trunc_functor (-1)). intros [c H3]. exists c. exact ((ap10 p (h c)) # H3). + intro c. refine (Trunc_rec _ (H2 c)). intros [a H3]. generalize (fst H_img a). apply (Trunc_functor (-1)). intros [b p]. exists b. exact ((ap10 p (h c)) # H3). - intros [H1 H2]; split. + intro a. refine (Trunc_rec _ (fst H_img a)). intros [b p]. generalize (H1 b). apply (Trunc_functor (-1)). intros [c H3]. exists c. exact ((ap10 p^ (h c)) # H3). + intro c. refine (Trunc_rec _ (H2 c)). intros [b H3]. generalize (snd H_img b). apply (Trunc_functor (-1)). intros [a p]. exists a. exact ((ap10 p^ (h c)) # H3). Defined. Notation "u ~~ v" := (bisimulation u v) : set_scope. Global Instance reflexive_bisimulation : Reflexive bisimulation. Proof. refine (V_ind_hprop _ _ _). intros A f H_f; simpl. split. - intro a; apply tr; exists a; auto. - intro a; apply tr; exists a; auto. Defined. Lemma bisimulation_equiv_id : forall u v : V, (u = v) <~> (u ~~ v). Proof. intros u v. apply equiv_iff_hprop. - intro p; exact (transport (fun x => u ~~ x) p (reflexive_bisimulation u)). - generalize u v. refine (V_ind_hprop _ _ _); intros A f H_f. refine (V_ind_hprop _ _ _); intros B g _. simpl; intros [H1 H2]. apply setext'. split. + intro a. generalize (H1 a). apply (Trunc_functor (-1)). intros [b h]. exists b; exact (H_f a (g b) h). + intro b. generalize (H2 b). apply (Trunc_functor (-1)). intros [a h]. exists a; exact (H_f a (g b) h). Defined. (** ** Canonical presentation of V-sets (Lemma 10.5.6) *) (** Using the regular kernel would lead to a universe inconsistency in the monic_set_present lemma later. *) Definition ker_bisim {A} (f : A -> V) (x y : A) := (f x ~~ f y). Definition ker_bisim_is_ker {A} (f : A -> V) : forall (x y : A), f x = f y <~> ker_bisim f x y. Proof. intros; apply bisimulation_equiv_id. Defined. Section MonicSetPresent_Uniqueness. (** Given u : V, we want to show that the representation u = @set Au mu, where Au is an hSet and mu is monic, is unique. *) Context {u : V} {Au Au': Type} {h : IsHSet Au} {h' : IsHSet Au'} {mu : Au -> V} {mono : IsEmbedding mu} {mu' : Au' -> V} {mono' : IsEmbedding mu'} {p : u = set mu} {p' : u = set mu'}. Lemma eq_img_untrunc : (forall a : Au, {a' : Au' & mu' a' = mu a}) * (forall a' : Au', {a : Au & mu a = mu' a'}). Proof. split. - intro a. exact (@untrunc_istrunc (-1) _ (mono' (mu a)) (transport (fun x => mu a ∈ x) (p^ @ p') (tr (a; 1)))). - intro a'. exact (@untrunc_istrunc (-1) _ (mono (mu' a')) (transport (fun x => mu' a' ∈ x) (p'^ @ p) (tr (a'; 1)))). Defined. Let e : Au -> Au' := fun a => pr1 (fst eq_img_untrunc a). Let inv_e : Au' -> Au := fun a' => pr1 (snd eq_img_untrunc a'). Let hom1 : e o inv_e == idmap. Proof. intro a'. apply (isinj_embedding mu' mono'). transitivity (mu (inv_e a')). - exact (pr2 (fst eq_img_untrunc (inv_e a'))). - exact (pr2 (snd eq_img_untrunc a')). Defined. Let hom2 : inv_e o e == idmap. Proof. intro a. apply (isinj_embedding mu mono). transitivity (mu' (e a)). - exact (pr2 (snd eq_img_untrunc (e a))). - exact (pr2 (fst eq_img_untrunc a)). Defined. Let path : Au' = Au. Proof. apply path_universe_uncurried. apply (equiv_adjointify inv_e e hom2 hom1). Defined. Lemma mu_eq_mu' : transport (fun A : Type => A -> V) path^ mu = mu'. Proof. apply path_forall. intro a'. transitivity (transport (fun X => V) path^ (mu (transport (fun X : Type => X) path^^ a'))). - apply (@transport_arrow Type (fun X : Type => X) (fun X => V) Au Au' path^ mu a'). - transitivity (mu (transport idmap path^^ a')). + apply transport_const. + transitivity (mu (inv_e a')). 2: apply (pr2 (snd eq_img_untrunc a')). refine (ap mu _). transitivity (transport idmap path a'). * exact (ap (fun x => transport idmap x a') (inv_V path)). * apply transport_path_universe. Defined. Lemma monic_set_present_uniqueness : (Au; (mu; (h, mono, p))) = (Au'; (mu'; (h', mono', p'))) :> {A : Type & {m : A -> V & IsHSet A * IsEmbedding m * (u = set m)}}. Proof. apply path_sigma_uncurried; simpl. exists path^. transitivity (path^ # mu; transportD (fun A => A -> V) (fun A m => IsHSet A * IsEmbedding m * (u = set m)) path^ mu (h, mono, p)). - apply (@transport_sigma Type (fun A => A -> V) (fun A m => IsHSet A * IsEmbedding m * (u = set m)) Au Au' path^ (mu; (h, mono, p))). - apply path_sigma_hprop; simpl. exact mu_eq_mu'. Defined. End MonicSetPresent_Uniqueness. (** This lemma actually says a little more than 10.5.6, i.e., that Au is a hSet *) Lemma monic_set_present : forall u : V, exists (Au : Type) (m : Au -> V), (IsHSet Au) * (IsEmbedding m) * (u = set m). Proof. apply V_ind_hprop. - intros A f _. destruct (quotient_kernel_factor_general f (ker_bisim f) (ker_bisim_is_ker f)) as [Au [eu [mu (((hset_Au, epi_eu), mono_mu), factor)]]]. exists Au, mu. split;[exact (hset_Au, mono_mu)|]. apply setext'; split. + intro a. apply tr; exists (eu a). exact (ap10 factor a). + intro a'. generalize (epi_eu a'). intro IC; refine (Trunc_functor (-1) _ (@center _ IC)). intros [a p]. exists a. transitivity (mu (eu a)). * exact (ap10 factor a). * exact (ap mu p). - intro v. apply hprop_allpath. intros [Au [mu ((hset, mono), p)]]. intros [Au' [mu' ((hset', mono'), p')]]. apply monic_set_present_uniqueness. Defined. Definition type_of_members (u : V) : Type := pr1 (monic_set_present u). Notation "[ u ]" := (type_of_members u) : set_scope. Definition func_of_members {u : V} : [u] -> V := pr1 (pr2 (monic_set_present u)) : [u] -> V. Definition is_hset_typeofmembers {u : V} : IsHSet ([u]) := fst (fst (pr2 (pr2 (monic_set_present u)))). Definition IsEmbedding_funcofmembers {u : V} : IsEmbedding func_of_members := snd (fst (pr2 (pr2 (monic_set_present u)))). Definition is_valid_presentation (u : V) : u = set func_of_members := snd (pr2 (pr2 (monic_set_present u))). (** ** Lemmas 10.5.8 (i) & (vii), we put them here because they are useful later *) Lemma extensionality : forall {x y : V}, (x ⊆ y * y ⊆ x) <-> x = y. Proof. refine (V_ind_hprop _ _ _). intros A f _. refine (V_ind_hprop _ _ _). intros B g _. split. - intros [H1 H2]. apply setext'. split. + intro. refine (Trunc_rec _ (H1 (f a) (tr (a;1)))). intros [b p]. apply tr. exists b. exact p^. + intro. apply (H2 (g b)). apply tr; exists b; reflexivity. - intro p; split. + intros z Hz. apply (transport (fun x => z ∈ x) p Hz). + intros z Hz. apply (transport (fun x => z ∈ x) p^ Hz). Qed. Lemma mem_induction (C : V -> HProp) : (forall v, (forall x, x ∈ v -> C x) -> C v) -> forall v, C v. Proof. intro H. refine (V_ind_hprop _ _ _). intros A f H_f. apply H. intros x Hx. generalize Hx; apply Trunc_rec. intros [a p]. exact (transport C p (H_f a)). Defined. (** ** Two useful lemmas *) Global Instance irreflexive_mem : Irreflexive mem. Proof. assert (forall v, IsHProp (complement (fun x x0 : V => x ∈ x0) v v)). (* https://coq.inria.fr/bugs/show_bug.cgi?id=3854 *) { intro. unfold complement. exact _. } refine (mem_induction (fun x => Build_HProp (~ x ∈ x)) _); simpl in *. intros v H. intro Hv. exact (H v Hv Hv). Defined. Lemma path_V_eqimg {A B} {f : A -> V} {g : B -> V} : set f = set g -> equal_img f g. Proof. intro p. split. - intro a. assert (H : f a ∈ set g). { apply (snd extensionality p). apply tr; exists a; reflexivity. } generalize H; apply (Trunc_functor (-1)). intros [b p']. exists b; exact p'^. - intro b. assert (H : g b ∈ set f). { apply (snd extensionality p^). apply tr; exists b; reflexivity. } generalize H; apply (Trunc_functor (-1)). intros [a p']. exists a; exact p'. Defined. (** ** Definitions of particular sets in V *) (** The empty set *) Definition V_empty : V := set (Empty_ind (fun _ => V)). (** The singleton {u} *) Definition V_singleton (u : V) : V@{U' U} := set (Unit_ind u). Global Instance isequiv_ap_V_singleton {u v : V} : IsEquiv (@ap _ _ V_singleton u v). Proof. simple refine (Build_IsEquiv _ _ _ _ _ _ _); try solve [ intro; apply path_ishprop ]. { intro H. specialize (path_V_eqimg H). intros (H1, H2). refine (Trunc_rec _ (H1 tt)). intros [t p]. destruct t; exact p. } Defined. (** The pair {u,v} *) Definition V_pair (u : V) (v : V) : V@{U' U} := set (fun b : Bool => if b then u else v). Lemma path_pair {u v u' v' : V@{U' U}} : (u = u') * (v = v') -> V_pair u v = V_pair u' v'. Proof. intros (H1, H2). apply setext'. split. + apply Bool_ind. * apply tr; exists true. assumption. * apply tr; exists false; assumption. + apply Bool_ind. * apply tr; exists true; assumption. * apply tr; exists false; assumption. Defined. Lemma pair_eq_singleton {u v w : V} : V_pair u v = V_singleton w <-> (u = w) * (v = w). Proof. split. + intro H. destruct (path_V_eqimg H) as (H1, H2). refine (Trunc_rec _ (H1 true)). intros [t p]; destruct t. refine (Trunc_rec _ (H1 false)). intros [t p']; destruct t. split; [exact p| exact p']. + intros (p1, p2). apply setext'; split. * intro a; apply tr; exists tt. destruct a; [exact p1 | exact p2]. * intro t; apply tr; exists true. destruct t; exact p1. Defined. (** The ordered pair (u,v) *) Definition V_pair_ord (u : V) (v : V) : V := V_pair (V_singleton u) (V_pair u v). Notation " [ u , v ] " := (V_pair_ord u v) : set_scope. Lemma path_pair_ord {a b c d : V} : [a, b] = [c, d] <-> (a = c) * (b = d). Proof. split. - intro p. assert (p1 : a = c). + assert (H : V_singleton a ∈ [c, d]). { apply (snd extensionality p). simpl. apply tr; exists true; reflexivity. } refine (Trunc_rec _ H). intros [t p']; destruct t. * apply ((ap V_singleton)^-1 p'^). * symmetry; apply (fst pair_eq_singleton p'). + split. * exact p1. * assert (H : hor (b = c) (b = d)). { assert (H' : V_pair a b ∈ [c, d]). { apply (snd extensionality p). apply tr; exists false; reflexivity. } refine (Trunc_rec _ H'). intros [t p']; destruct t. - apply tr; left. apply (fst pair_eq_singleton p'^). - destruct (path_V_eqimg p') as (H1, H2). generalize (H2 false); apply (Trunc_functor (-1)). intros [t p'']; destruct t. + left; exact p''^. + right; exact p''^. } refine (Trunc_rec _ H). intro case; destruct case as [p'| p']. 2: assumption. assert (H' : [a, b] = V_singleton (V_singleton b)). { apply (snd pair_eq_singleton). split. - apply ap; exact (p1 @ p'^). - apply (snd pair_eq_singleton). split; [exact (p1 @ p'^) | reflexivity]. } assert (H'' : V_pair c d = V_singleton b) by apply (fst pair_eq_singleton (p^ @ H')). symmetry; apply (fst pair_eq_singleton H''). - intros (p, p'). apply path_pair. split. + apply ap; exact p. + apply path_pair. split; assumption; assumption. Defined. (** The cartesian product a × b *) Definition V_cart_prod (a : V) (b : V) : V := set (fun x : [a] * [b] => [func_of_members (fst x), func_of_members (snd x)]). Notation " a × b " := (V_cart_prod a b) : set_scope. (** f is a function with domain a and codomain b *) Definition V_is_func (a : V) (b : V) (f : V) := f ⊆ (a × b) * (forall x, x ∈ a -> hexists (fun y => y ∈ b * [x,y] ∈ f)) * (forall x y y', [x,y] ∈ f * [x,y'] ∈ f -> y = y'). (** The set of functions from a to b *) Definition V_func (a : V) (b : V) : V := @set ([a] -> [b]) (fun f => set (fun x => [func_of_members x, func_of_members (f x)] )). (** The union of a set Uv *) Definition V_union (v : V) := @set ({x : [v] & [func_of_members x]}) (fun z => func_of_members (pr2 z)). (** The ordinal successor x ∪ {x} *) Definition V_succ : V -> V. Proof. simple refine (V_rec' _ _ _ _). - intros A f _. exact (set (fun (x : A + Unit) => match x with inl a => f a | inr tt => set f end)). - simpl; intros A B f g eq_img _ _ _. apply setext'. split. + intro. destruct a. * generalize (fst eq_img a). apply (Trunc_functor (-1)). intros [b p]. exists (inl b); exact p. * apply tr; exists (inr tt). destruct u. apply setext'; auto. + intro. destruct b. * generalize (snd eq_img b). apply (Trunc_functor (-1)). intros [a p]. exists (inl a); exact p. * apply tr; exists (inr tt). destruct u. apply setext'; auto. Defined. (** The set of finite ordinals *) Definition V_omega : V := set (fix I n := match n with 0 => V_empty | S n => V_succ (I n) end). (** ** Axioms of set theory (theorem 10.5.8) *) Lemma not_mem_Vempty : forall x, ~ (x ∈ V_empty). Proof. intros x Hx. generalize Hx; apply Trunc_rec. intros [ff _]. exact ff. Qed. Lemma pairing : forall u v, hexists (fun w => forall x, x ∈ w <-> hor (x = u) (x = v)). Proof. intros u v. apply tr. exists (V_pair u v). intro; split; apply (Trunc_functor (-1)). - intros [[|] p]; [left|right]; exact p^. - intros [p | p]; [exists true | exists false]; exact p^. Qed. Lemma infinity : (V_empty ∈ V_omega) * (forall x, x ∈ V_omega -> V_succ x ∈ V_omega). Proof. split. - apply tr; exists 0; auto. - intro. apply (Trunc_functor (-1)). intros [n p]. exists (S n). rewrite p; auto. Qed. Lemma union : forall v, hexists (fun w => forall x, x ∈ w <-> hexists (fun u => x ∈ u * u ∈ v)). Proof. intro v. apply tr; exists (V_union v). intro x; split. - intro H. simpl in H. generalize H; apply (Trunc_functor (-1)). intros [[u' x'] p]; simpl in p. exists (func_of_members u'); split. + refine (transport (fun z => x ∈ z) (is_valid_presentation (func_of_members u'))^ _). simpl. apply tr; exists x'. exact p. + refine (transport (fun z => func_of_members u' ∈ z) (is_valid_presentation v)^ _). simpl. apply tr; exists u'; reflexivity. - apply Trunc_rec. intros [u (Hx, Hu)]. generalize (transport (fun z => u ∈ z) (is_valid_presentation v) Hu). apply Trunc_rec. intros [u' pu]. generalize (transport (fun z => x ∈ z) (is_valid_presentation (func_of_members u')) (transport (fun z => x ∈ z) pu^ Hx)). apply Trunc_rec. intros [x' px]. apply tr. exists (u'; x'). exact px. Qed. Lemma function : forall u v, hexists (fun w => forall x, x ∈ w <-> V_is_func u v x). Proof. intros u v. apply tr; exists (V_func u v). assert (memb_u : u = set (@func_of_members u)) by exact (is_valid_presentation u). assert (memb_v : v = set (@func_of_members v)) by exact (is_valid_presentation v). intro phi; split. - intro H. split;[split|]. + intros z Hz. simpl in *. generalize H. apply Trunc_rec. intros [h p_phi]. generalize (transport (fun x => z ∈ x) p_phi^ Hz). apply (Trunc_functor (-1)). intros [a p]. exists (a, h a). assumption. + intros x Hx. generalize (transport (fun y => x ∈ y) memb_u Hx). apply Trunc_rec. intros [a p]. generalize H; apply (Trunc_functor (-1)). intros [h p_phi]. exists (func_of_members (h a)). split. * exact (transport (fun z => func_of_members (h a) ∈ z) memb_v^ (tr (h a; 1))). * apply (transport (fun y => [x, func_of_members (h a)] ∈ y) p_phi). apply tr; exists a. rewrite p; reflexivity. + intros x y y' (Hy, Hy'). generalize H; apply Trunc_rec. intros [h p_phi]. generalize (transport (fun z => [x, y] ∈ z) p_phi^ Hy). apply Trunc_rec. intros [a p]. generalize (transport (fun z => [x, y'] ∈ z) p_phi^ Hy'). apply Trunc_rec. intros [a' p']. destruct (fst path_pair_ord p) as (px, py). destruct (fst path_pair_ord p') as (px', py'). transitivity (func_of_members (h a)); auto with path_hints. transitivity (func_of_members (h a'));auto with path_hints. refine (ap func_of_members _). refine (ap h _). apply (isinj_embedding func_of_members IsEmbedding_funcofmembers a a' (px @ px'^)). - intros ((H1, H2), H3). simpl. assert (h : forall a : [u], {b : [v] & [func_of_members a, func_of_members b] ∈ phi}). { intro a. pose (x := func_of_members a). transparent assert (H : {y : V & y ∈ v * [x, y] ∈ phi}). - refine (@untrunc_istrunc (-1) {y : V & y ∈ v * [x, y] ∈ phi} _ (H2 x (transport (fun z => x ∈ z) memb_u^ (tr (a; 1))))). apply hprop_allpath. intros [y (H1_y, H2_y)] [y' (H1_y', H2_y')]. apply path_sigma_uncurried; simpl. exists (H3 x y y' (H2_y, H2_y')). apply path_ishprop. - destruct H as [y (H1_y, H2_y)]. destruct (@untrunc_istrunc (-1) _ (IsEmbedding_funcofmembers y) (transport (fun z => y ∈ z) memb_v H1_y)) as [b Hb]. exists b. exact (transport (fun z => [x, z] ∈ phi) Hb^ H2_y). } apply tr; exists (fun a => pr1 (h a)). apply extensionality. split. + intros z Hz. generalize Hz; apply Trunc_rec. intros [a Ha]. exact (transport (fun w => w ∈ phi) Ha (pr2 (h a))). + intros z Hz. simpl. generalize (H1 z Hz). apply (Trunc_functor (-1)). intros [(a,b) p]. simpl in p. exists a. transitivity ([func_of_members a, func_of_members b]); auto with path_hints. apply ap. apply H3 with (func_of_members a). split. * exact (pr2 (h a)). * exact (transport (fun w => w ∈ phi) p^ Hz). Qed. Lemma replacement : forall (r : V -> V) (x : V), hexists (fun w => forall y, y ∈ w <-> hexists (fun z => z ∈ x * (r z = y))). Proof. intro r. refine (V_ind_hprop _ _ _). intros A f _. apply tr. exists (set (r o f)). split. - apply (Trunc_functor (-1)). intros [a p]. exists (f a). split. + apply tr; exists a; auto. + assumption. - apply Trunc_rec. intros [z [h p]]. generalize h. apply (Trunc_functor (-1)). intros [a p']. exists a. transitivity (r z); auto with path_hints. exact (ap r p'). Qed. Lemma separation (C : V -> HProp) : forall a : V, hexists (fun w => forall x, x ∈ w <-> x ∈ a * (C x)). Proof. refine (V_ind_hprop _ _ _). intros A f _. apply tr. exists (set (fun z : {a : A & C (f a)} => f (pr1 z))). split. - apply Trunc_rec. intros [[a h] p]. split. + apply tr; exists a; assumption. + exact (transport C p h). - intros [H1 H2]. generalize H1. apply (Trunc_functor (-1)). intros [a p]. exists (a; transport C p^ H2). exact p. Qed. End AssumingUA. Coq-HoTT-9.0/theories/HIT/epi.v000066400000000000000000000137471474641544500161640ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import TruncType. Require Import ReflectiveSubuniverse. Require Import Colimits.Pushout Truncations.Core HIT.SetCone. Local Open Scope path_scope. Section AssumingUA. Context `{ua:Univalence}. (** We will now prove that for sets, epis and surjections are equivalent.*) Definition isepi {X Y} `(f:X->Y) := forall Z: HSet, forall g h: Y -> Z, g o f = h o f -> g = h. Definition isepi_funext {X Y : Type} (f : X -> Y) := forall Z : HSet, forall g0 g1 : Y -> Z, g0 o f == g1 o f -> g0 == g1. Definition isepi' {X Y} `(f : X -> Y) := forall (Z : HSet) (g : Y -> Z), Contr { h : Y -> Z | g o f = h o f }. Lemma equiv_isepi_isepi' {X Y} f : @isepi X Y f <~> @isepi' X Y f. Proof. unfold isepi, isepi'. apply (@equiv_functor_forall' _ _ _ _ _ (equiv_idmap _)); intro Z. apply (@equiv_functor_forall' _ _ _ _ _ (equiv_idmap _)); intro g. unfold equiv_idmap; simpl. refine (transitivity (@equiv_sig_ind _ (fun h : Y -> Z => g o f = h o f) (fun h => g = h.1)) _). (** TODO(JasonGross): Can we do this entirely by chaining equivalences? *) apply equiv_iff_hprop. { intro hepi. nrapply (Build_Contr _ (g; idpath)). intro xy; specialize (hepi xy). apply path_sigma_uncurried. exists hepi. apply path_ishprop. } { intros hepi xy. exact (ap pr1 ((contr (g; 1))^ @ contr xy)). } Defined. Definition equiv_isepi_isepi_funext {X Y : Type} (f : X -> Y) : isepi f <~> isepi_funext f. Proof. apply equiv_iff_hprop. - intros e ? g0 g1 h. apply equiv_path_arrow. apply e. by apply path_arrow. - intros e ? g0 g1 p. apply path_arrow. apply e. by apply equiv_path_arrow. Defined. Section cones. Lemma isepi'_contr_cone `{Funext} {A B : HSet} (f : A -> B) : isepi' f -> Contr (setcone f). Proof. intros hepi. apply (Build_Contr _ (setcone_point _)). pose (alpha1 := @pglue A B Unit f (const_tt _)). pose (tot:= { h : B -> setcone f & tr o push o inl o f = h o f }). transparent assert (l : tot). { simple refine (tr o _ o inl; _). { refine push. } { refine idpath. } } pose (r := (@const B (setcone f) (setcone_point _); (ap (fun f => @tr 0 _ o f) (path_forall _ _ alpha1))) : tot). subst tot. assert (X : l = r). { let lem := constr:(fun X push' => hepi (Build_HSet (setcone f)) (tr o push' o @inl _ X)) in pose (lem _ push). refine (path_contr l r). } subst l r. pose (I0 b := ap10 (X ..1) b). refine (Trunc_ind _ _). pose (fun a : B + Unit => (match a as a return setcone_point _ = tr (push a) with | inl a' => (I0 a')^ | inr tt => idpath end)) as I0f. refine (Pushout_ind _ (fun a' => I0f (inl a')) (fun u => (I0f (inr u))) _). simpl. subst alpha1. intros. unfold setcone_point. subst I0. simpl. pose (X..2) as p. simpl in p. rewrite (transport_precompose f _ _ X..1) in p. assert (H':=concat (ap (fun x => ap10 x a) p) (ap10_ap_postcompose tr (path_arrow (pushl o f) (pushr o const_tt _) pglue) _)). rewrite ap10_path_arrow in H'. clear p. (** Apparently [pose; clearbody] is only ~.8 seconds, while [pose proof] is ~4 seconds? *) pose (concat (ap10_ap_precompose f (X ..1) a)^ H') as p. clearbody p. simpl in p. rewrite p. rewrite transport_paths_Fr. apply concat_Vp. Qed. End cones. Lemma issurj_isepi {X Y} (f:X->Y): IsSurjection f -> isepi f. Proof. intros sur ? ? ? ep. apply path_forall. intro y. specialize (sur y). pose (center (merely (hfiber f y))). apply (Trunc_rec (n:=-1) (A:=(sig (fun x : X => f x = y)))); try assumption. intros [x p]. set (p0:=apD10 ep x). transitivity (g (f x)). - by apply ap. - transitivity (h (f x));auto with path_hints. by apply ap. Qed. Corollary issurj_isepi_funext {X Y} (f:X->Y) : IsSurjection f -> isepi_funext f. Proof. intro s. apply equiv_isepi_isepi_funext. by apply issurj_isepi. Defined. (** Old-style proof using polymorphic Omega. Needs resizing for the isepi proof to live in the same universe as X and Y (the Z quantifier is instantiated with an HSet at a level higher) << Lemma isepi_issurj {X Y} (f:X->Y): isepi f -> issurj f. Proof. intros epif y. set (g :=fun _:Y => Unit_hp). set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))). assert (X1: g o f = h o f ). - apply path_forall. intro x. apply path_equiv_biimp_rec;[|done]. intros _ . apply min1. exists tt. by (exists x). - specialize (epif _ g h). specialize (epif X1). clear X1. set (p:=apD10 epif y). apply (@minus1Trunc_map (sig (fun _ : Unit => sig (fun x : X => y = f x)))). + intros [ _ [x eq]]. exists x. by symmetry. + apply (transport hproptype p tt). Defined. >> *) Section isepi_issurj. Context {X Y : HSet} (f : X -> Y) (Hisepi : isepi f). Definition epif := equiv_isepi_isepi' _ Hisepi. Definition fam (c : setcone f) : HProp. Proof. pose (fib y := hexists (fun x : X => f x = y)). apply (fun f => @Trunc_rec _ _ HProp _ f c). refine (Pushout_rec HProp fib (fun _ => Unit_hp) (fun x => _)). (** Prove that the truncated sigma is equivalent to Unit *) pose (contr_inhabited_hprop (fib (f x)) (tr (x; idpath))) as i. apply path_hprop. simpl. simpl in i. apply (equiv_contr_unit). Defined. Lemma isepi_issurj : IsSurjection f. Proof. intros y. pose (i := isepi'_contr_cone _ epif). assert (X0 : forall x : setcone f, fam x = fam (setcone_point f)). { intros. apply contr_dom_equiv. apply i. } specialize (X0 (tr (push (inl y)))). simpl in X0. unfold IsConnected. refine (transport (fun A => Contr A) (ap trunctype_type X0)^ _); exact _. Defined. End isepi_issurj. Lemma isepi_isequiv X Y (f : X -> Y) `{IsEquiv _ _ f} : isepi f. Proof. intros ? g h H'. apply ap10 in H'. apply path_forall. intro x. transitivity (g (f (f^-1 x))). - by rewrite eisretr. - transitivity (h (f (f^-1 x))). * apply H'. * by rewrite eisretr. Qed. End AssumingUA. Coq-HoTT-9.0/theories/HIT/iso.v000066400000000000000000000020061474641544500161630ustar00rootroot00000000000000Require Import HoTT.Basics. Require Import Types.Universe. Require Import HSet. Require Import HIT.epi HIT.unique_choice. Local Open Scope path_scope. (** We prove that [epi + mono <-> IsEquiv] *) Section iso. Context `{Univalence}. Variables X Y : HSet. Variable f : X -> Y. Lemma atmost1P_isinj (injf : IsInjective f) : forall y : Y, atmost1P (fun x => f x = y). Proof. intros y x x' p q. apply (injective f). exact (p @ q^). Defined. Definition isequiv_isepi_ismono (epif : isepi f) (monof : ismono f) : IsEquiv f. Proof. pose proof (@isepi_issurj _ _ _ f epif) as surjf. pose proof (isinj_ismono _ monof) as injf. pose proof (unique_choice (fun y x => f x = y) _ (fun y => (@center _ (surjf y), atmost1P_isinj injf y))) as H_unique_choice. apply (isequiv_adjointify _ H_unique_choice.1). - intro. apply H_unique_choice.2. - intro. apply injf. apply H_unique_choice.2. Defined. End iso. Coq-HoTT-9.0/theories/HIT/quotient.v000066400000000000000000000263551474641544500172560ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HSet TruncType. Require Import Truncations.Core. Local Open Scope path_scope. (** * The set-quotient of a type by an hprop-valued relation We aim to model: << Inductive quotient : Type := | class_of : A -> quotient | related_classes_eq : forall x y, (R x y), class_of x = class_of y | quotient_set : IsHSet quotient >> *) (** TODO: This development should be further connected with the sections in the book; see below. And it should be merged with Colimits.Quotient. Currently this file is only used in Classes/implementations/natpair_integers.v and Classes/implementations/field_of_fractions.v, so it shouldn't be too hard to switch to Colimits.Quotient. *) Module Export Quotient. Section Domain. Universes i j u. Constraint i <= u, j <= u. Context {A : Type@{i}} (R : Relation@{i j} A) {sR: is_mere_relation _ R}. (** We choose to let the definition of quotient depend on the proof that [R] is a set-relations. Alternatively, we could have defined it for all relations and only develop the theory for set-relations. The former seems more natural. We do not require [R] to be an equivalence relation, but implicitly consider its transitive-reflexive closure. *) (** This definition has a parameter [sR] that shadows the ambient one in the Context in order to ensure that it actually ends up depending on everything in the Context when the section is closed, since its definition doesn't actually refer to any of them. *) Private Inductive quotient {sR: is_mere_relation _ R} : Type@{u} := | class_of : A -> quotient. (** The path constructors. *) Axiom related_classes_eq : forall {x y : A}, R x y -> class_of x = class_of y. Axiom quotient_set : IsHSet (@quotient sR). Global Existing Instance quotient_set. Definition quotient_ind (P : (@quotient sR) -> Type) {sP : forall x, IsHSet (P x)} (dclass : forall x, P (class_of x)) (dequiv : (forall x y (H : R x y), (related_classes_eq H) # (dclass x) = dclass y)) : forall q, P q := fun q => match q with class_of a => fun _ _ => dclass a end sP dequiv. Definition quotient_ind_compute {P sP} dclass dequiv x : @quotient_ind P sP dclass dequiv (class_of x) = dclass x. Proof. reflexivity. Defined. (** Again equality of paths needs to be postulated *) Axiom quotient_ind_compute_path : forall P sP dclass dequiv, forall x y (H : R x y), apD (@quotient_ind P sP dclass dequiv) (related_classes_eq H) = dequiv x y H. End Domain. End Quotient. Section Equiv. Context `{Univalence}. Context {A : Type} (R : Relation A) {sR: is_mere_relation _ R} {Htrans : Transitive R} {Hsymm : Symmetric R}. Lemma quotient_path2 : forall {x y : quotient R} (p q : x=y), p=q. Proof. apply @hset_path2. apply _. Defined. Definition in_class : quotient R -> A -> HProp. Proof. refine (quotient_ind R (fun _ => A -> HProp) (fun a b => Build_HProp (R a b)) _). intros. eapply concat;[apply transport_const|]. apply path_forall. intro z. apply path_hprop; simpl. apply @equiv_iff_hprop; eauto. Defined. Context {Hrefl : Reflexive R}. Lemma in_class_pr : forall x y, (in_class (class_of R x) y : Type) = R x y. Proof. reflexivity. Defined. Lemma quotient_ind_prop (P : quotient R -> Type) `{forall x, IsHProp (P x)} : forall dclass : forall x, P (class_of R x), forall q, P q. Proof. intros. apply (quotient_ind R P dclass). intros. apply path_ishprop. Defined. Global Instance decidable_in_class `{forall x y, Decidable (R x y)} : forall x a, Decidable (in_class x a). Proof. refine (quotient_ind_prop _ _). intros a b; exact (transport Decidable (in_class_pr a b) _). Defined. Lemma class_of_repr : forall q x, in_class q x -> q = class_of R x. Proof. apply (quotient_ind R (fun q : quotient R => forall x, in_class q x -> q = class_of _ x) (fun x y H => related_classes_eq R H)). intros. apply path_forall. intro z. apply path_forall;intro H'. apply quotient_path2. Defined. Lemma classes_eq_related : forall x y, class_of R x = class_of R y -> R x y. Proof. intros x y H'. pattern (R x y). eapply transport. - apply in_class_pr. - pattern (class_of R x). apply (transport _ (H'^)). apply Hrefl. Defined. (** Thm 10.1.8 *) Theorem sets_exact : forall x y, (class_of R x = class_of R y) <~> R x y. intros ??. apply equiv_iff_hprop. - apply classes_eq_related. - apply related_classes_eq. Defined. Definition quotient_rec {B : Type} {sB : IsHSet B} (dclass : (forall x : A, B)) (dequiv : (forall x y, R x y -> dclass x = dclass y)) : quotient R -> B. Proof. apply (quotient_ind R (fun _ : quotient _ => B)) with dclass. intros ?? H'. destruct (related_classes_eq R H'). by apply dequiv. Defined. Definition quotient_rec2 {B : HSet} {dclass : (A -> A -> B)}: forall dequiv : (forall x x', R x x' -> forall y y', R y y' -> dclass x y = dclass x' y'), quotient R -> quotient R -> B. Proof. intro. assert (dequiv0 : forall x x0 y : A, R x0 y -> dclass x x0 = dclass x y) by (intros ? ? ? Hx; apply dequiv;[apply Hrefl|done]). refine (quotient_rec (fun x => quotient_rec (dclass x) (dequiv0 x)) _). intros x x' Hx. apply path_forall. red. assert (dequiv1 : forall y : A, quotient_rec (dclass x) (dequiv0 x) (class_of _ y) = quotient_rec (dclass x') (dequiv0 x') (class_of _ y)) by (intros; by apply dequiv). refine (quotient_ind R (fun q => quotient_rec (dclass x) (dequiv0 x) q = quotient_rec (dclass x') (dequiv0 x') q) dequiv1 _). intros. apply path_ishprop. Defined. Definition quotient_ind_prop' : forall P : quotient R -> Type, forall (Hprop' : forall x, IsHProp (P (class_of _ x))), (forall x, P (class_of _ x)) -> forall y, P y. Proof. intros ? ? dclass. apply quotient_ind with dclass. - simple refine (quotient_ind R (fun x => IsHSet (P x)) _ _); cbn beta; try exact _. intros; apply path_ishprop. - intros. apply path_ishprop. Defined. (** From Ch6 *) Theorem quotient_surjective: IsSurjection (class_of R). Proof. apply BuildIsSurjection. apply (quotient_ind_prop (fun y => merely (hfiber (class_of R) y))); try exact _. intro x. apply tr. by exists x. Defined. (** From Ch10 *) Definition quotient_ump' (B:HSet): (quotient R -> B) -> (sig (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))). intro f. exists (compose f (class_of R) ). intros. f_ap. by apply related_classes_eq. Defined. Definition quotient_ump'' (B:HSet): (sig (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))) -> quotient R -> B. intros [f H']. apply (quotient_rec _ H'). Defined. Theorem quotient_ump (B:HSet): (quotient R -> B) <~> (sig (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))). Proof. refine (equiv_adjointify (quotient_ump' B) (quotient_ump'' B) _ _). - intros [f Hf]. by apply equiv_path_sigma_hprop. - intros f. apply path_forall. red. apply quotient_ind_prop';[apply _|reflexivity]. Defined. (** Missing The equivalence with VVquotient [A//R]. This should lead to the unnamed theorem: 10.1.10. Equivalence relations are effective and there is an equivalence [A/R<~>A//R]. *) (** The theory of canonical quotients is developed by C.Cohen: http://perso.crans.org/cohen/work/quotients/ *) End Equiv. Section Functoriality. Definition quotient_functor {A : Type} (R : Relation A) {sR: is_mere_relation _ R} {B : Type} (S : Relation B) {sS: is_mere_relation _ S} (f : A -> B) (fresp : forall x y, R x y -> S (f x) (f y)) : quotient R -> quotient S. Proof. refine (quotient_rec R (class_of S o f) _). intros x y r. apply related_classes_eq, fresp, r. Defined. Context {A : Type} (R : Relation A) {sR: is_mere_relation _ R} {B : Type} (S : Relation B) {sS: is_mere_relation _ S}. Global Instance quotient_functor_isequiv (f : A -> B) (fresp : forall x y, R x y <-> S (f x) (f y)) `{IsEquiv _ _ f} : IsEquiv (quotient_functor R S f (fun x y => fst (fresp x y))). Proof. simple refine (isequiv_adjointify _ (quotient_functor S R f^-1 _) _ _). - intros u v s. apply (snd (fresp _ _)). abstract (do 2 rewrite eisretr; apply s). - intros x; revert x; simple refine (quotient_ind S _ _ _). + intros b; simpl. apply ap, eisretr. + intros; apply path_ishprop. - intros x; revert x; simple refine (quotient_ind R _ _ _). + intros a; simpl. apply ap, eissect. + intros; apply path_ishprop. Defined. Definition quotient_functor_equiv (f : A -> B) (fresp : forall x y, R x y <-> S (f x) (f y)) `{IsEquiv _ _ f} : quotient R <~> quotient S := Build_Equiv _ _ (quotient_functor R S f (fun x y => fst (fresp x y))) _. Definition quotient_functor_equiv' (f : A <~> B) (fresp : forall x y, R x y <-> S (f x) (f y)) : quotient R <~> quotient S := quotient_functor_equiv f fresp. End Functoriality. Section Kernel. (** ** Quotients of kernels of maps to sets give a surjection/mono factorization. *) Context {fs : Funext}. (** A function we want to factor. *) Context {A B : Type} `{IsHSet B} (f : A -> B). (** A mere relation equivalent to its kernel. *) Context (R : Relation A) {sR : is_mere_relation _ R}. Context (is_ker : forall x y, f x = f y <~> R x y). Theorem quotient_kernel_factor : exists (C : Type) (e : A -> C) (m : C -> B), IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e). Proof. pose (C := quotient R). (* We put this explicitly in the context so that typeclass resolution will pick it up. *) assert (IsHSet C) by (unfold C; apply _). exists C. pose (e := class_of R). exists e. transparent assert (m : (C -> B)). { apply quotient_ind with f; try exact _. intros x y H. transitivity (f x). - apply transport_const. - exact ((is_ker x y) ^-1 H). } exists m. split;[split;[split|]|]. - assumption. - apply quotient_surjective. - intro u. apply hprop_allpath. assert (H : forall (x y : C) (p : m x = u) (p' : m y = u), x = y). { simple refine (quotient_ind R _ _ _). - intro a. simple refine (quotient_ind R _ _ _). + intros a' p p'; fold e in p, p'. * apply related_classes_eq. refine (is_ker a a' _). change (m (e a) = m (e a')). exact (p @ p'^). + intros; apply path_ishprop. - intros; apply path_ishprop. } intros [x p] [y p']. apply path_sigma_hprop; simpl. exact (H x y p p'). - reflexivity. Defined. End Kernel. Coq-HoTT-9.0/theories/HIT/surjective_factor.v000066400000000000000000000021601474641544500211130ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Truncations.Core Modalities.Modality. (** Definition by factoring through a surjection. *) Section surjective_factor. Context `{Funext}. Context {A B C} `{IsHSet C} `(f : A -> C) `(g : A -> B) {Esurj : IsSurjection g}. Variable (Eg : forall x y, g x = g y -> f x = f y). Lemma ishprop_surjective_factor_aux : forall b, IsHProp (exists c : C, forall a, g a = b -> f a = c). Proof. intros. apply Sigma.ishprop_sigma_disjoint. intros c1 c2 E1 E2. generalize (@center _ (Esurj b)); apply (Trunc_ind _). intros [a p];destruct p. path_via (f a). Qed. Definition surjective_factor_aux := @conn_map_elim _ _ _ _ Esurj (fun b => exists c : C, forall a, g a = b -> f a = c) ishprop_surjective_factor_aux (fun a => exist (fun c => forall a, _ -> _ = c) (f a) (fun a' => Eg a' a)). Definition surjective_factor : B -> C := fun b => (surjective_factor_aux b).1. Lemma surjective_factor_pr : f == compose surjective_factor g. Proof. intros a. apply (surjective_factor_aux (g a)).2. trivial. Qed. End surjective_factor. Coq-HoTT-9.0/theories/HIT/unique_choice.v000066400000000000000000000016421474641544500202160ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Truncations.Core. Definition atmost1 X:=(forall x1 x2:X, (x1 = x2)). Definition atmost1P {X} (P:X->Type):= (forall x1 x2:X, P x1 -> P x2 -> (x1 = x2)). Definition hunique {X} (P:X->Type):=(hexists P) * (atmost1P P). Lemma atmost {X} {P : X -> Type}: (forall x, IsHProp (P x)) -> (atmost1P P) -> atmost1 (sig P). intros H H0 [x p] [y q]. specialize (H0 x y p q). induction H0. assert (H0: (p =q)) by apply path_ishprop. by induction H0. Qed. Lemma iota {X} (P:X-> Type): (forall x, IsHProp (P x)) -> (hunique P) -> sig P. Proof. intros H1 [H H0]. apply (@Trunc_rec (-1) (sig P) );auto. by apply hprop_allpath, atmost. Qed. Lemma unique_choice {X Y} (R:X->Y->Type) : (forall x y, IsHProp (R x y)) -> (forall x, (hunique (R x))) -> {f : X -> Y & forall x, (R x (f x))}. intros X0 X1. exists (fun x:X => (pr1 (iota _ (X0 x) (X1 x)))). intro x. apply (pr2 (iota _ (X0 x) (X1 x))). Qed. Coq-HoTT-9.0/theories/HoTT.v000066400000000000000000000150721474641544500155720ustar00rootroot00000000000000(** A convenience file that loads most of the HoTT library. You can use it with "Require Import HoTT" in your files. But please do not use it in the HoTT library itself, or you are likely going to create a dependency loop. *) Require Export HoTT.Basics. Require Export HoTT.Types. Require Export HoTT.WildCat. Require Export HoTT.Cubical.DPath. Require Export HoTT.Cubical.PathSquare. Require Export HoTT.Cubical.DPathSquare. Require Export HoTT.Cubical.PathCube. Require Export HoTT.Cubical.DPathCube. Require Export HoTT.Pointed. Require Export HoTT.Truncations. Require Export HoTT.HFiber. Require Export HoTT.Projective. Require Export HoTT.EquivGroupoids. Require Export HoTT.Equiv.BiInv. Require Export HoTT.Equiv.PathSplit. Require Export HoTT.Equiv.Relational. Require Export HoTT.Extensions. Require Export HoTT.Functorish. Require Export HoTT.Factorization. Require Export HoTT.Constant. Require Export HoTT.Universes.Smallness. Require Export HoTT.Universes.TruncType. Require Export HoTT.Universes.ObjectClassifier. Require Export HoTT.Universes.DProp. Require Export HoTT.Universes.HProp. Require Export HoTT.Universes.HSet. Require Export HoTT.Universes.Automorphisms. Require Export HoTT.Universes.BAut. Require Export HoTT.Universes.Rigid. Require Export HoTT.Idempotents. Require Export HoTT.ExcludedMiddle. Require Export HoTT.BoundedSearch. Require Export HoTT.HIT.Interval. Require Export HoTT.HIT.Flattening. Require Export HoTT.HIT.FreeIntQuotient. Require Export HoTT.HIT.SetCone. Require Export HoTT.HIT.epi. Require Export HoTT.HIT.unique_choice. Require Export HoTT.HIT.iso. Require Export HoTT.HIT.quotient. Require Export HoTT.HIT.surjective_factor. Require Export HoTT.HIT.V. Require Export HoTT.Diagrams.Graph. Require Export HoTT.Diagrams.Diagram. Require Export HoTT.Diagrams.Cone. Require Export HoTT.Diagrams.Cocone. Require Export HoTT.Diagrams.DDiagram. Require Export HoTT.Diagrams.ConstantDiagram. Require Export HoTT.Diagrams.CommutativeSquares. Require Export HoTT.Diagrams.Sequence. Require Export HoTT.Diagrams.Span. Require Export HoTT.Diagrams.ParallelPair. Require Export HoTT.Limits.Pullback. Require Export HoTT.Limits.Equalizer. Require Export HoTT.Limits.Limit. Require Export HoTT.Colimits.GraphQuotient. Require Export HoTT.Colimits.Coeq. Require Export HoTT.Colimits.Pushout. Require Export HoTT.Colimits.SpanPushout. Require Export HoTT.Colimits.Quotient. Require Export HoTT.Colimits.Quotient.Choice. Require Export HoTT.Colimits.MappingCylinder. Require Export HoTT.Colimits.Sequential. Require Export HoTT.Colimits.Colimit. Require Export HoTT.Colimits.Colimit_Pushout. Require Export HoTT.Colimits.Colimit_Coequalizer. Require Export HoTT.Colimits.Colimit_Flattening. Require Export HoTT.Colimits.Colimit_Prod. Require Export HoTT.Colimits.Colimit_Pushout_Flattening. Require Export HoTT.Colimits.Colimit_Sigma. Require Export HoTT.Modalities.ReflectiveSubuniverse. Require Export HoTT.Modalities.Modality. Require Export HoTT.Modalities.Accessible. Require Export HoTT.Modalities.Notnot. Require Export HoTT.Modalities.Identity. Require Export HoTT.Modalities.Localization. Require Export HoTT.Modalities.Nullification. Require Export HoTT.Modalities.Descent. Require Export HoTT.Modalities.Separated. Require Export HoTT.Modalities.Lex. Require Export HoTT.Modalities.Topological. Require Export HoTT.Modalities.Open. Require Export HoTT.Modalities.Closed. Require Export HoTT.Modalities.Fracture. Require Export HoTT.Modalities.Meet. Require Export HoTT.Modalities.CoreflectiveSubuniverse. Require Export HoTT.Spaces.Nat. Require Export HoTT.Spaces.BinInt. Require Export HoTT.Spaces.Pos. Require Export HoTT.Spaces.List.Core. Require Export HoTT.Spaces.List.Theory. Require Export HoTT.Spaces.List.Paths. Require Export HoTT.Spaces.Cantor. Require Export HoTT.Spaces.Circle. Require Export HoTT.Spaces.TwoSphere. Require Export HoTT.Spaces.Spheres. Require Export HoTT.Spaces.BAut.Cantor. Require Export HoTT.Spaces.BAut.Bool. Require Export HoTT.Spaces.BAut.Bool.IncoherentIdempotent. Require Export HoTT.Spaces.Finite. Require Export HoTT.Spaces.Card. Require Export HoTT.Spaces.No. Require Export HoTT.Spaces.Torus.Torus. Require Export HoTT.Spaces.Torus.TorusEquivCircles. Require Export HoTT.Spaces.Torus.TorusHomotopy. Require Export HoTT.Algebra.ooGroup. Require Export HoTT.Algebra.Aut. Require Export HoTT.Algebra.ooAction. Require Export HoTT.Algebra.AbGroups. Require Export HoTT.Algebra.AbSES. Require Export HoTT.Algebra.Groups. Require Export HoTT.Algebra.Rings. Require Export HoTT.Algebra.Universal.Algebra. Require Export HoTT.Algebra.Universal.Congruence. Require Export HoTT.Algebra.Universal.Homomorphism. Require Export HoTT.Algebra.Universal.Operation. Require Export HoTT.Algebra.Universal.TermAlgebra. Require Export HoTT.Analysis.Locator. Require Export HoTT.Homotopy.HomotopyGroup. Require Export HoTT.Homotopy.PinSn. Require Export HoTT.Homotopy.WhiteheadsPrinciple. Require Export HoTT.Homotopy.BlakersMassey. Require Export HoTT.Homotopy.Freudenthal. Require Export HoTT.Homotopy.Suspension. Require Export HoTT.Homotopy.Smash. Require Export HoTT.Homotopy.Wedge. Require Export HoTT.Homotopy.Join. Require Export HoTT.Homotopy.HSpace. Require Export HoTT.Homotopy.ClassifyingSpace. Require Export HoTT.Homotopy.CayleyDickson. Require Export HoTT.Homotopy.EMSpace. Require Export HoTT.Homotopy.HSpaceS1. Require Export HoTT.Homotopy.Bouquet. Require Export HoTT.Homotopy.EncodeDecode. Require Export HoTT.Homotopy.Syllepsis. Require Export HoTT.Homotopy.Hopf. Require Export HoTT.Homotopy.IdentitySystems. Require Export HoTT.Homotopy.NullHomotopy. Require Export HoTT.Spectra.Spectrum. Require Export HoTT.Tactics. Require Export HoTT.Tactics.BinderApply. Require Export HoTT.Tactics.EquivalenceInduction. Require Export HoTT.Tactics.EvalIn. Require Export HoTT.Tactics.Nameless. Require Export HoTT.Tactics.RewriteModuloAssociativity. Require Export HoTT.Sets.AC. Require Export HoTT.Sets.GCH. Require Export HoTT.Sets.GCHtoAC. Require Export HoTT.Sets.Hartogs. Require Export HoTT.Sets.Ordinals. Require Export HoTT.Sets.Powers. (** We do _not_ export [UnivalenceAxiom], [FunextAxiom], or any of the files in [Metatheory] from this file. Thus, importing this file does not prevent you from tracking usage of [Univalence] and [Funext] theorem-by-theorem in the same way that the library does. If you want any of those files, you should import them separately. *) (** We check that UnivalenceAxiom, FunextAxiom aren't being leaked. This is so that these can be imported seperately. *) Fail Check HoTT.UnivalenceAxiom.univalence_axiom. Fail Check HoTT.FunextAxiom.funext_axiom. Coq-HoTT-9.0/theories/Homotopy/000077500000000000000000000000001474641544500163765ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Homotopy/BlakersMassey.v000066400000000000000000000570031474641544500213370ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Colimits.Pushout. Require Import Colimits.SpanPushout. Require Import Homotopy.Join.Core. Require Import Truncations. (** * The Generalized Blakers-Massey Theorem *) (** ** Path algebra helper lemma *) (** Here is a strange-looking path algebra helper lemma that is easier to prove by lifting to a general case and doing a path-induction blast. It says something about what happens when we transport from the center of a based path-space to some other point, assuming we know a particular way to "compute" the action of the type family in question. *) Definition transport_singleton `{Univalence} {A : Type} {x : A} (B : forall (y : A), (x = y) -> Type) {y : A} (p : x = y) (u : B x idpath) (f : forall (q:x=x), B x q <~> B y (q @ p)) (ev : ap10 (apD B p) p = transport_arrow_toconst p (B x) p @ path_universe_uncurried (@equiv_transport _ (B y) ((p @ p^) @ p) p (concat_pV_p p p) oE (f (p @ p^)) oE @equiv_transport _ (B x) (transport (fun y => x = y) p^ p) (p @ p^) (transport_paths_r p^ p))) : transport (fun yp:{y:A & x=y} => B yp.1 yp.2) (path_contr (A := {y:A & x=y}) (x;idpath) (y;p)) u = transport (B y) (concat_1p _) (f idpath u). Proof. destruct p; cbn in *. apply (fun e => e @ concat_1p _) in ev. apply moveR_equiv_V in ev. apply (ap equiv_fun) in ev. apply ap10 in ev. specialize (ev u). cbn in ev. exact ev. Defined. (** ** Setup *) Section GBM. Context {X Y : Type} (Q : X -> Y -> Type). (** Here's the hypothesis of ABFJ generalized Blakers-Massey. It works for any reflective subuniverse, not only modalities! *) Context (O : ReflectiveSubuniverse). Context (isconnected_cogap : forall (x1 x3 : X) (y2 y4 : Y) (q12 : Q x1 y2) (q32 : Q x3 y2) (q34 : Q x3 y4), IsConnected O (Join ((x1;q12) = (x3;q32) :> {x:X & Q x y2}) ((y2;q32) = (y4;q34) :> {y:Y & Q x3 y}))). Let P := SPushout Q. Local Notation left := (spushl Q). Local Notation right := (spushr Q). Local Notation glue := (spglue Q). (** Here's a lemma that's a sort of "singleton contractibility" equivalence, but expressed in a particularly strange way. As we'll see, this form of the lemma comes up naturally *twice* in the proof, and proving it once here to use in both places is crucial so that the two uses can be identified later on. *) Local Definition frobnicate {x0 x1 : X} (r : left x0 = left x1) (s : x0 = x1) (y : Y) (q1 : Q x1 y) : {q0 : Q x0 y & {w : transport (fun x => Q x y) s q0 = q1 & glue q0 @ (glue q1)^ = r } } <~> ap left s = r. Proof. refine (_ oE equiv_sigma_assoc' _ _). refine (_ oE equiv_functor_sigma' (Q := fun qt => glue qt.1 @ (glue q1)^ = r) (equiv_functor_sigma_id (fun q0 : Q x0 y => equiv_moveL_transport_V (fun x => Q x y) s q0 q1)) (fun qt => equiv_idmap)). refine (_ oE equiv_contr_sigma _); cbn. rewrite (ap_transport s^ (fun x q => glue q) q1). rewrite (transport_paths_FlFr s^ (glue q1)). rewrite ap_V, inv_V, ap_const, concat_p1. exact (equiv_concat_l (concat_pp_V _ _)^ _). (** Although we proved this lemma with [rewrite], we make it transparent, not so that *we* can reason about it, but so that Coq can evaluate it. *) Defined. (* But except in one place, we don't want it to try (otherwise things get really slow). *) Opaque frobnicate. (** ** Codes *) (** *** Right-hand codes *) (** The right-hand codes family is easy. *) Definition coderight {x0 : X} {y : Y} (r : left x0 = right y) : Type := O (hfiber glue r). (** *** Left-hand codes *) (** We enhance the HFLL and ABFJ theorems by defining a version of code-left that doesn't depend on one map being surjective. *) Section CodeLeft. Context {x0 x1 : X} (r : left x0 = left x1). (** The left codes are themselves a pushout, of what is morally also a dependent span, but we formulate it as an ordinary pushout of projections between iterated Sigma-types, most of which we express as records for performance reasons. The span is [codeleft1] <- [codeleft0] -> [codeleft2]. *) Definition codeleft1 : Type := { s : x0 = x1 & (* v : *) ap left s = r}. Record codeleft2 := { codeleft2_y0 : Y ; codeleft2_q00 : Q x0 codeleft2_y0 ; codeleft2_q10 : Q x1 codeleft2_y0 ; codeleft2_u : glue codeleft2_q00 @ (glue codeleft2_q10)^ = r }. Record codeleft0 := { codeleft0_s : x0 = x1 ; codeleft0_y0 : Y ; codeleft0_v : ap left codeleft0_s = r ; codeleft0_q00 : Q x0 codeleft0_y0 ; codeleft0_q10 : Q x1 codeleft0_y0 ; codeleft0_w : transport (fun x => Q x codeleft0_y0) codeleft0_s codeleft0_q00 = codeleft0_q10 ; codeleft0_u : glue codeleft0_q00 @ (glue codeleft0_q10)^ = r ; (** Note the first use of frobnicate here. *) codeleft0_d : frobnicate r codeleft0_s codeleft0_y0 codeleft0_q10 (codeleft0_q00 ; codeleft0_w ; codeleft0_u) = codeleft0_v }. Definition codeleft01 : codeleft0 -> codeleft1. Proof. intros [s y0 v q00 q10 w u d]. exact (s;v). Defined. Definition codeleft02 : codeleft0 -> codeleft2. Proof. intros [s y0 v q00 q10 w u d]. exact (Build_codeleft2 y0 q00 q10 u). Defined. Definition codeleft : Type := O (Pushout codeleft01 codeleft02). (** *** Codes for glue *) Section CodeGlue. Context {y1 : Y} (q11 : Q x1 y1). (** We prove that codes respect glue as a chain of equivalences between types built from pushouts and double-pushouts. The first step is to add the data of our hypothesized-to-be-connected type inside [codeleft2]. *) Definition codeleft2plus := {yqqu : codeleft2 & Join ((x0; codeleft2_q00 yqqu) = (x1; codeleft2_q10 yqqu) :> {x:X & Q x (codeleft2_y0 yqqu)}) ((codeleft2_y0 yqqu; codeleft2_q10 yqqu) = (y1; q11) :> {y:Y & Q x1 y})}. (** Since this connected type is itself a join, hence a pushout, the second step is to distribute this and reexpress the whole thing as another pushout of iterated Sigma-types (again mostly expressed as records for performance reasons). *) Record Ocodeleft2b := { Ocodeleft2b_s : x0 = x1 ; Ocodeleft2b_y0 : Y ; Ocodeleft2b_q00 : Q x0 Ocodeleft2b_y0 ; Ocodeleft2b_q10 : Q x1 Ocodeleft2b_y0 ; Ocodeleft2b_w : transport (fun x => Q x Ocodeleft2b_y0) Ocodeleft2b_s Ocodeleft2b_q00 = Ocodeleft2b_q10 ; Ocodeleft2b_u : glue Ocodeleft2b_q00 @ (glue Ocodeleft2b_q10)^ = r }. Definition Ocodeleft2c := { q01 : Q x0 y1 & (* u: *) glue q01 @ (glue q11)^ = r }. Record Ocodeleft2a := { Ocodeleft2a_s : x0 = x1 ; Ocodeleft2a_q01 : Q x0 y1 ; Ocodeleft2a_w : transport (fun x => Q x y1) Ocodeleft2a_s Ocodeleft2a_q01 = q11 ; Ocodeleft2a_u : glue Ocodeleft2a_q01 @ (glue q11)^ = r }. Definition Ocodeleft2ab : Ocodeleft2a -> Ocodeleft2b. Proof. intros [s q01 w u]. exact (Build_Ocodeleft2b s y1 q01 q11 w u). Defined. Definition Ocodeleft2ac : Ocodeleft2a -> Ocodeleft2c. Proof. intros [s q01 w u]. exact (q01;u). Defined. (** This proof is basically just rearranging Sigma-types/records and paths in Sigma-types and contracting based path spaces. *) Definition equiv_Ocodeleft2plus : Pushout Ocodeleft2ab Ocodeleft2ac <~> codeleft2plus. Proof. refine ((equiv_sigma_pushout _ _ _ _ _)^-1 oE _). srefine (equiv_pushout _ _ _ _ _). - srefine (equiv_functor_sigma_id _ oE _). 2:intro; refine (equiv_functor_prod' _ _); apply equiv_path_sigma. make_equiv_contr_basedpaths. - srefine (equiv_functor_sigma_id _ oE _). 2:intro; apply equiv_path_sigma. make_equiv. - srefine (equiv_functor_sigma_id _ oE _). 2:intro; apply equiv_path_sigma. make_equiv_contr_basedpaths. - intros; reflexivity. - intros; reflexivity. Defined. (** Now we combine this equivalence with the insertion of our connected type. *) Definition equiv_Ocodeleft2 : O (Pushout Ocodeleft2ab Ocodeleft2ac) <~> O codeleft2. Proof. refine ((equiv_O_functor O (equiv_sigma_contr (fun yqqu : codeleft2 => O (Join ((x0; codeleft2_q00 yqqu) = (x1; codeleft2_q10 yqqu)) ((codeleft2_y0 yqqu ; codeleft2_q10 yqqu) = (y1; q11)))))) oE _). refine ((equiv_O_sigma_O O _)^-1 oE _). apply equiv_O_functor. apply equiv_Ocodeleft2plus. Defined. (** The next step is to reassociate the resulting double-pushout and "contract" both of them, one after the other, because they are pushouts along equivalences. In order to do this, we need first of all to know that the resulting map from [codeleft0] to the above pushout factors through [Ocodeleft2b] via an equivalence. Here's the equivalence: *) Definition Ocodeleft02b : codeleft0 <~> Ocodeleft2b. Proof. make_equiv_contr_basedpaths. Defined. Definition Ocodeleft02 (c : codeleft0) : Pushout Ocodeleft2ab Ocodeleft2ac := pushl' Ocodeleft2ab Ocodeleft2ac (Ocodeleft02b c). Definition Ocodeleft02plus_02b (c : codeleft0) : (equiv_Ocodeleft2plus (Ocodeleft02 c)).1 = codeleft02 c. Proof. destruct c; reflexivity. Qed. (** And here we show that this equivalence is indeed a factor of the relevant map in the original pushout. *) Definition Ocodeleft02_02b (c : codeleft0) : equiv_Ocodeleft2 (to O _ (Ocodeleft02 c)) = to O _ (codeleft02 c). Proof. destruct c. unfold equiv_Ocodeleft2. Opaque equiv_Ocodeleft2plus. cbn. refine (ap _ (ap _ (to_O_natural _ _ _)) @ _). refine (ap _ (to_O_natural _ _ _) @ _). refine (to_O_natural _ _ _ @ _). apply ap. rapply Ocodeleft02plus_02b. Qed. (** Thus, our pushout in which one vertex is itself a pushout can be written as a "double pushout" [codeleft1] <- [codeleft0] -> [codeleft2b] <- [codeleft2a] -> [codeleft2c]. Since the map [codeleft0] -> [codeleft2b] is an equivalence, the pushout of the left-hand span is equivalent to [codeleft1], and thus the whole thing is equivalent to a pushout [codeleft1] <- [codeleft2a] -> [codeleft2c] Now we claim that the left-hand map of this span is also an equivalence. Rather than showing this directly, it seems to be much easier to first construct *an* equivalence from [codeleft2a] to [codeleft1] and then show that it is equal (as a function) to the induced one. Here's the equivalence: *) Definition Ocodeleft2a1 : Ocodeleft2a <~> codeleft1. Proof. etransitivity. 2:{ rapply equiv_functor_sigma_id; intros s. (** Here's frobnicate showing up again! *) apply frobnicate. } make_equiv. Defined. (** And now we check that the two are equal. Because we used the same proof of [frobnicate] in two places, this equality becomes definitional after simply decomposing up a Sigma-type! *) Definition Ocodeleft2a1_through_2b0 : Ocodeleft2a1 == codeleft01 o Ocodeleft02b^-1 o Ocodeleft2ab. Proof. intros; reflexivity. Defined. (** Now we're finally ready to prove the glue equivalence. Since later on we'll have to compute its action on inputs from [codeleft1], we decompose it into seven steps, each of which with a corresponding computation lemma. (These lemmas seem to be much easier to prove step-by-step than all at once if we proved the whole equivalence in a big shebang.) *) Definition codeglue1 : codeleft <~> O (Pushout (O_functor O codeleft01) (O_functor O codeleft02)) := equiv_O_pushout O _ _. Definition codeglue1_pushl (s : x0 = x1) (v : ap left s = r) : codeglue1 (to O _ (pushl (s;v))) = to O _ (pushl (to O _ (s; v))) := equiv_O_pushout_to_O_pushl _ _ _ _. Definition codeglue2 : O (Pushout (O_functor O codeleft01) (O_functor O codeleft02)) <~> O (Pushout (O_functor O codeleft01) (O_functor O Ocodeleft02)). Proof. srefine (equiv_O_functor O (equiv_inverse (equiv_pushout (f := O_functor O codeleft01) (g := O_functor O Ocodeleft02) 1%equiv 1%equiv equiv_Ocodeleft2 _ _))). - intros x; reflexivity. - apply O_indpaths; intros x. abstract (rewrite !to_O_natural; apply Ocodeleft02_02b). Defined. Definition codeglue2_pushl (s : x0 = x1) (v : ap left s = r) : codeglue2 (to O _ (pushl (to O _ (s;v)))) = to O _ (pushl (to O _ (s;v))) := to_O_equiv_natural _ _ _. Definition codeglue3 : O (Pushout (O_functor O codeleft01) (O_functor O Ocodeleft02)) <~> O (Pushout codeleft01 Ocodeleft02) := equiv_inverse (equiv_O_pushout O _ _). Definition codeglue3_pushl (s : x0 = x1) (v : ap left s = r) : codeglue3 (to O _ (pushl (to O _ (s;v)))) = to O _ (pushl (s;v)) := inverse_equiv_O_pushout_to_O_pushl _ _ _ _. Definition codeglue4 : O (Pushout codeleft01 Ocodeleft02) <~> O (Pushout (fun x : Ocodeleft2a => pushr' codeleft01 Ocodeleft02b (Ocodeleft2ab x)) Ocodeleft2ac) := equiv_O_functor O (equiv_inverse (equiv_pushout_assoc _ _ _ _)). Definition codeglue4_pushl (s : x0 = x1) (v : ap left s = r) : codeglue4 (to O _ (pushl (s;v))) = to O _ (pushl (pushl (s;v))) := to_O_equiv_natural _ _ _. Definition codeglue5 : O (Pushout (fun x : Ocodeleft2a => pushr' codeleft01 Ocodeleft02b (Ocodeleft2ab x)) Ocodeleft2ac) <~> O (Pushout Ocodeleft2a1 Ocodeleft2ac). Proof. srefine (equiv_O_functor O (equiv_inverse (equiv_pushout (f := Ocodeleft2a1) (g := Ocodeleft2ac) 1%equiv _ 1%equiv _ _))). - exact (Build_Equiv _ _ (pushl' codeleft01 Ocodeleft02b) _). - intros x. refine (ap _ (Ocodeleft2a1_through_2b0 x) @ _). refine (pglue' codeleft01 Ocodeleft02b _ @ _). apply ap, eisretr. - intros x; reflexivity. Defined. Definition codeglue5_pushl (s : x0 = x1) (v : ap left s = r) : codeglue5 (to O _ (pushl (pushl (s;v)))) = to O _ (pushl (s;v)) := to_O_equiv_natural _ _ _. Definition codeglue6 : O (Pushout Ocodeleft2a1 Ocodeleft2ac) <~> O Ocodeleft2c := equiv_O_functor O (equiv_inverse (Build_Equiv _ _ (pushr' Ocodeleft2a1 Ocodeleft2ac) _)). Definition codeglue6_pushl (s : x0 = x1) (v : ap left s = r) : codeglue6 (to O _ (pushl (s;v))) = let z := (frobnicate r s y1 q11)^-1 v in to O Ocodeleft2c (Ocodeleft2ac (Build_Ocodeleft2a s z.1 z.2.1 z.2.2)) := to_O_equiv_natural _ _ _. Definition codeglue7 : O Ocodeleft2c <~> coderight (r @ glue q11). Proof. unfold coderight, Ocodeleft2c. apply equiv_O_functor. apply equiv_functor_sigma_id; intros q01. apply equiv_moveL_pM. Defined. Definition codeglue7_to_O (q01 : Q x0 y1) (u : glue q01 @ (glue q11)^ = r) : codeglue7 (to O _ (q01;u)) = to O (hfiber glue (r @ glue q11)) (q01 ; moveL_pM (glue q11) (glue q01) r u) := to_O_equiv_natural _ _ _. Definition codeglue : codeleft <~> coderight (r @ glue q11) := codeglue7 oE codeglue6 oE codeglue5 oE codeglue4 oE codeglue3 oE codeglue2 oE codeglue1. End CodeGlue. End CodeLeft. (** *** Completion of codes *) Context `{Univalence}. Context (x0 : X). (** The equivalence [codeglue] requires a bit of massaging to put it into the form needed by the actual definition of [code] from pushout-induction and univalence. *) Definition ap_code_glue (x1 : X) (y1 : Y) (q11 : Q x1 y1) : transport (fun p : SPushout Q => left x0 = p -> Type) (glue q11) codeleft = coderight. Proof. apply path_arrow; intros z. refine ((transport_arrow_toconst _ _ _) @ _). apply path_universe_uncurried. refine (_ oE equiv_transport codeleft (transport_paths_r _ _)). refine (_ oE codeglue _ q11). refine (equiv_transport coderight _). refine (concat_pV_p z (glue q11)). Defined. (** Here's the final definition of [code]. *) Definition code (p : P) (r : left x0 = p) : Type := spushout_ind Q (fun p => left x0 = p -> Type) (@codeleft x0) (@coderight x0) ap_code_glue p r. (** When we compute with [code], we'll need to extract from it the actual behavior of the function [codeglue]. Here's the mess of path algebra that we "naturally" get out when we try to do that; later we'll see how to deal with it. *) Definition code_beta_glue (x1 : X) (y1 : Y) (q11 : Q x1 y1) (r : left x0 = right y1) : ap10 (apD code (glue q11)) r = transport_arrow_toconst (glue q11) codeleft r @ path_universe_uncurried (@equiv_transport _ coderight ((r @ (glue q11)^) @ glue q11) r (concat_pV_p r (glue q11)) oE (codeglue (r @ (glue q11)^) q11) oE @equiv_transport _ codeleft (transport (fun y : SPushout Q => left x0 = y) (glue q11)^ r) (r @ (glue q11)^) (transport_paths_r (glue q11)^ r)). Proof. refine (ap (fun h => ap10 h r) (spushout_ind_beta_spglue Q (fun p => left x0 = p -> Type) (@codeleft x0) (@coderight x0) ap_code_glue x1 y1 q11) @ _). refine (ap10_path_arrow _ _ _ _). Defined. (** ** Contractibility of codes *) (** To construct a center for every type of codes, we construct one in an easy case and transport it around. *) Definition center_code1 : code (left x0) 1. Proof. change (codeleft (idpath (left x0))). unfold codeleft. apply to, pushl. unfold codeleft1. exact (idpath; idpath). Defined. Definition center_code (p : P) (r : left x0 = p) : code p r := transport (fun (pr : {p : P & left x0 = p}) => code pr.1 pr.2) (path_contr (A := {p : P & left x0 = p}) (left x0; idpath) (p;r)) center_code1. (** As in HFLL, we first construct a contraction in the "partially general" case of an arbitrary path from left to right. *) Definition contraction_code_right (y1 : Y) (r : left x0 = right y1) (c : code (right y1) r) : center_code (right y1) r = c. Proof. change (coderight r) in c. unfold coderight in c. revert c; refine (O_indpaths _ _ _); intros [q01 t]. unfold center_code, center_code1. (** Here's how we use the apparently-unmanageable [code_beta_glue]. First we destruct the path [t] to make things simpler. *) destruct t. (** Then we notice that if we tried rewriting with [code_beta_glue] here, the unmanageable-looking result is actually fully general over the path [glue q01], so we can prove by path induction that it equals the nicer expression we'd like to see. This is the purpose of the lemma [transport_singleton]. *) rewrite (transport_singleton code (glue q01) _ (fun r => @codeglue x0 x0 r y1 q01) (code_beta_glue x0 y1 q01 (glue q01))). unfold codeglue. (** Now we evaluate [codeglue] step by step using our lemmas. *) do 6 change_apply_equiv_compose. rewrite codeglue1_pushl, codeglue2_pushl, codeglue3_pushl, codeglue4_pushl, codeglue5_pushl, codeglue6_pushl, codeglue7_to_O. rewrite <- (ap_transport (concat_1p (glue q01)) (fun r => to O (hfiber glue r)) _). apply ap; unfold hfiber; rewrite transport_sigma'. apply ap; rewrite transport_paths_r. (** Finally, we have another terrible-looking thing involving [frobnicate]. However, there are enough identity paths that [frobnicate] evaluates to... something that's almost fully path-general! So with just a little bit of further work, we can reduce it also to something we can prove with path-induction. *) Transparent frobnicate. cbn. Opaque frobnicate. rewrite (transport_compose (fun q => glue q @ (glue q01)^ = 1%path) pr1). unfold path_sigma'; rewrite ap_V, ap_pr1_path_sigma, transport_1. destruct (glue q01); reflexivity. Qed. (** It should be possible to prove an analogous [contraction_code_left] directly, but for now we follow HFLL and ABFJ by introducing a surjectivity assumption. *) Definition contraction_code {y0 : Y} (q00 : Q x0 y0) (pr : { p : P & left x0 = p }) (c : code pr.1 pr.2) : center_code pr.1 pr.2 = c. Proof. revert c. srefine (transport (fun pr' => forall c, center_code pr'.1 pr'.2 = c) (path_contr (right y0 ; glue q00) pr) _). clear pr; cbn; intros c. apply contraction_code_right. Defined. Definition contr_code_inhab (inh : merely { y0 : Y & Q x0 y0 }) (p : P) (r : left x0 = p) : Contr (code p r). Proof. strip_truncations. destruct inh as [y0 q00]. exact (Build_Contr _ (center_code p r) (contraction_code q00 (p;r))). Defined. (** This version is sufficient for the classical Blakers-Massey theorem, as we'll see below, since its leg-wise connectivity hypothesis implies the above surjectivity assumption. ABFJ have a different method for eliminating the surjectivity assumption using a lemma about pushouts of monos also being pullbacks, though it seems to only work for coderight. *) End GBM. (** ** The classical Blakers-Massey Theorem *) Global Instance blakers_massey `{Univalence} (m n : trunc_index) {X Y : Type} (Q : X -> Y -> Type) `{forall y, IsConnected m.+1 { x : X & Q x y } } `{forall x, IsConnected n.+1 { y : Y & Q x y } } (x : X) (y : Y) : IsConnMap (m +2+ n) (@spglue X Y Q x y). Proof. intros r. snrefine (contr_code_inhab Q (m +2+ n) _ x (merely_isconnected n _) (spushr Q y) r). 1: intros; apply isconnected_join. all: exact _. Defined. Coq-HoTT-9.0/theories/Homotopy/Bouquet.v000066400000000000000000000057371474641544500202250ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed WildCat. Require Import Algebra.Groups. Require Import Modalities.ReflectiveSubuniverse Truncations.Core. Require Import Homotopy.Suspension. Require Import Homotopy.ClassifyingSpace. Require Import Homotopy.HomotopyGroup. Local Open Scope trunc_scope. Local Open Scope pointed_scope. Import ClassifyingSpaceNotation. (** In this file we show that the fundamental group of a bouquet of circles indexed by a type S is the free group on that type S. We begin by defining S-indexed wedges of circles as the suspension of the pointification of S. *) Section AssumeUnivalence. Context `{Univalence}. (** An S-indexed wedge of circles a.k.a a bouquet can be defined as the suspension of the pointification of S. *) Definition Bouquet (S : Type) : pType := psusp (pointify S). Global Instance isconnected_bouquet (S : Type) : IsConnected 0 (Bouquet S). Proof. rapply isconnected_susp. Defined. (** We can directly prove that it satisfies the desired equivalence together with naturality in the second argument. *) Lemma natequiv_pi1bouquet_rec (S : Type) : NatEquiv (opyon (Pi 1 (Bouquet S))) (opyon S o group_type). Proof. (** Pointify *) nrefine (natequiv_compose _ _). 1: refine (natequiv_prewhisker (natequiv_pointify_r S) ptype_group). (** Post-compose with [pequiv_loops_bg_g] *) nrefine (natequiv_compose _ _). 1: rapply (natequiv_postwhisker _ (natequiv_inverse natequiv_g_loops_bg)). (** Loop-susp adjoint *) nrefine (natequiv_compose _ _). 1: refine (natequiv_prewhisker (natequiv_loop_susp_adjoint_r (pointify S)) B). (** Pi1-BG adjunction *) rapply natequiv_bg_pi1_adjoint. Defined. (** For the rest of this file, we don't need to unfold this. *) Local Opaque natequiv_pi1bouquet_rec. Theorem equiv_pi1bouquet_rec (S : Type) (G : Group) : (Pi 1 (Bouquet S) $-> G) <~> (S -> G). Proof. apply natequiv_pi1bouquet_rec. Defined. Global Instance is1natural_equiv_pi1bouquet_rec (S : Type) : Is1Natural (opyon (Pi 1 (Bouquet S))) (opyon S o group_type) (fun G => equiv_pi1bouquet_rec S G). Proof. rapply (is1natural_natequiv (natequiv_pi1bouquet_rec _)). Defined. (** We can define the inclusion map by using the previous equivalence on the identity group homomorphism. *) Definition pi1bouquet_incl (S : Type) : S -> Pi 1 (Bouquet S). Proof. rapply equiv_pi1bouquet_rec. apply grp_homo_id. Defined. (** The fundemental group of an S-bouquet is the free group on S. *) Global Instance isfreegroupon_pi1bouquet (S : Type) : IsFreeGroupOn S (Pi 1 (Bouquet S)) (pi1bouquet_incl S). Proof. apply equiv_isfreegroupon_isequiv_precomp. intro G. snrapply isequiv_homotopic'. 1: apply equiv_pi1bouquet_rec. intros f. refine (_ @ @is1natural_equiv_pi1bouquet_rec S _ _ f grp_homo_id). simpl; f_ap; symmetry. rapply (cat_idr_strong f). Defined. End AssumeUnivalence. Coq-HoTT-9.0/theories/Homotopy/CayleyDickson.v000066400000000000000000000243761474641544500213420ustar00rootroot00000000000000Require Import Types.Paths. Require Import Classes.interfaces.abstract_algebra. Require Import Cubical.DPath Cubical.PathSquare. Require Import Pointed.Core Pointed.pSusp. Require Import Homotopy.HSpace.Core. Require Import Homotopy.Suspension. Require Import Homotopy.Join.Core. Local Open Scope pointed_scope. Local Open Scope mc_mult_scope. (** The Cayley-Dickson Construction *) (** The Cayley-Dickson construction in homotopy type theory due to Buchholtz and Rijke https://arxiv.org/abs/1610.01134 is a method to construct an H-space strucure on the join of two suspensions of a type [A]. As a special case, this gives a way to construct an H-space structure on [S^3] leading to the quarternionic hopf fibration. The construction works by replicating the classical Cayley-Dickson construction on convolution algebras ([*]-algebras), which can produce the complex numbers, quaternions, octonions, etc. starting with the real numbers. We cannot replicate this directly in HoTT since such algebras have a contractible underlying vector space, therefore the construction here attempts to axiomatize the properties of the units of those algebras instead. This is done by postulating a structure called a "Cayley-Dickson imaginaroid" on a type [A] and showing that [Join (Susp A) (Susp A)] is an H-space. An open problem is to show that this space itself is also an imaginaroid given further, yet unspecified, coherences on [A]. *) (** ** Cayley-Dickson spheroids *) (** A Cayley-Dickson Spheroid is a pointed type X which is an H-space, with two operations called negation and conjugation, satisfying the following seven laws: 1. [--x = x] 2. [x** = x] 3. [1* = 1] 4. [(-x)* = -x*] 5. [x(-y) = -(xy)] 6. [(xy)* = y* x*] 7. [x* x = 1] Note that the above laws are written in pseudocode since we cannot define multiplication by juxtaposition in Coq, and * is used to denote conjugation. *) Class CayleyDicksonSpheroid (X : pType) := { cds_hspace : IsHSpace X; cds_negate : Negate X; cds_conjug : Conjugate X; cds_negate_inv : Involutive cds_negate; cds_conjug_inv : Involutive cds_conjug; cds_conjug_unit_pres : IsUnitPreserving cds_conjug; cds_conjug_left_inv : LeftInverse (.*.) cds_conjug mon_unit; cds_conjug_distr : DistrOpp (.*.) cds_conjug; cds_swapop : SwapOp (-) cds_conjug; cds_factorneg_r : FactorNegRight (-) (.*.); }. #[export] Existing Instances cds_hspace cds_negate cds_conjug cds_negate_inv cds_conjug_inv cds_conjug_unit_pres cds_conjug_left_inv cds_conjug_distr cds_swapop cds_factorneg_r. Section CayleyDicksonSpheroid_Properties. Context {X : pType} `(CayleyDicksonSpheroid X). Local Instance isequiv_cds_conjug : IsEquiv cds_conjug := isequiv_adjointify cds_conjug cds_conjug cds_conjug_inv cds_conjug_inv. Global Instance cds_factorneg_l : FactorNegLeft (-) (.*.). Proof. intros x y. rapply (equiv_inj conj). lhs rapply distropp. rhs rapply swapop. rhs rapply (ap _ (distropp _ _)). rhs_V rapply factorneg_r. nrapply ap. apply swapop. Defined. Global Instance cds_conjug_right_inv : RightInverse (.*.) cds_conjug mon_unit. Proof. intro x. lhs_V rapply (ap (.* conj x) (involutive x)). rapply left_inverse. Defined. End CayleyDicksonSpheroid_Properties. (** ** Negation and conjugation on suspensions *) Global Instance conjugate_susp (A : Type) `(Negate A) : Conjugate (Susp A) := functor_susp (-). Global Instance negate_susp (A : Type) `(Negate A) : Negate (Susp A) := susp_neg _ o conjugate_susp A (-). (** [conjugate_susp A] and [negate_susp A] commute. *) Global Instance swapop_conjugate_susp {A} `(Negate A) : SwapOp (negate_susp A (-)) (conjugate_susp A (-)). Proof. intros x. symmetry. nrapply susp_neg_natural. Defined. (** [conjugate_susp A] is involutive, since any functor applied to an involution gives an involution. *) Global Instance involutive_conjugate_susp {A} `(Negate A, !Involutive (-)) : Involutive (conjugate_susp A (-)). Proof. intros x. lhs_V nrapply functor_susp_compose. rhs_V nrapply functor_susp_idmap. nrapply functor2_susp. rapply involutive. Defined. (** [conjugate_susp A] is involutive as any composite of commuting involutions is an involution. *) Global Instance involutive_negate_susp {A} `(Negate A, !Involutive (-)) : Involutive (negate_susp A (-)). Proof. intros x. unfold negate_susp. lhs nrapply ap. 1: nrapply swapop_conjugate_susp. lhs rapply susp_neg_inv. rapply involutive. Defined. (** ** Cayley-Dickson imaginaroids *) Class CayleyDicksonImaginaroid (A : Type) := { cdi_negate : Negate A; cdi_negate_involutive : Involutive cdi_negate; cdi_susp_hspace : IsHSpace (psusp A); cdi_susp_factorneg_r : FactorNegRight (negate_susp A cdi_negate) hspace_op; cdi_susp_conjug_left_inv : LeftInverse hspace_op (conjugate_susp A cdi_negate) mon_unit; cdi_susp_conjug_distr : DistrOpp hspace_op (conjugate_susp A cdi_negate); }. #[export] Existing Instances cdi_negate cdi_negate_involutive cdi_susp_hspace cdi_susp_factorneg_r cdi_susp_conjug_left_inv cdi_susp_conjug_distr. Global Instance isunitpreserving_conjugate_susp {A} `(CayleyDicksonImaginaroid A) : @IsUnitPreserving _ _ pt pt (conjugate_susp A cdi_negate) := idpath. (** Every suspension of a Cayley-Dickson imaginaroid gives a Cayley-Dickson spheroid. *) Global Instance cds_susp_cdi {A} `(CayleyDicksonImaginaroid A) : CayleyDicksonSpheroid (psusp A) := {}. Global Instance cdi_conjugate_susp_left_inverse {A} `(CayleyDicksonImaginaroid A) : LeftInverse hspace_op (conjugate_susp A cdi_negate) mon_unit. Proof. srapply cds_conjug_left_inv. Defined. Global Instance cdi_conjugate_susp_right_inverse {A} `(CayleyDicksonImaginaroid A) : RightInverse hspace_op (conjugate_susp A cdi_negate) mon_unit. Proof. srapply cds_conjug_right_inv. Defined. Global Instance cdi_susp_left_identity {A} `(CayleyDicksonImaginaroid A) : LeftIdentity hspace_op mon_unit := _. Global Instance cdi_susp_right_identity {A} `(CayleyDicksonImaginaroid A) : RightIdentity hspace_op mon_unit := _. Global Instance cdi_negate_susp_factornegleft {A} `(CayleyDicksonImaginaroid A) : FactorNegLeft (negate_susp A cdi_negate) hspace_op. Proof. srapply cds_factorneg_l. Defined. (** A Cayley-Dickson imaginaroid [A] whose multiplciation on the suspension is associative gives rise to an H-space structure on the join of the suspension of [A] with itself. *) Section ImaginaroidHSpace. (** Let [A] be a Cayley-Dickson imaginaroid with associative H-space multiplication on [Susp A]. *) Context {A} `(CayleyDicksonImaginaroid A) `(!Associative hspace_op). (** Declaring these as local instances so that they can be found *) Local Instance hspace_op' : SgOp (Susp A) := hspace_op. Local Instance hspace_unit' : MonUnit (Susp A) := hspace_mon_unit. (** First we make some observations with the context we have. *) Section Lemmata. Context (a b c d : Susp A). Local Definition f := (fun x => a * (c * -x)). Local Definition g := (fun y => c * (y * b)). Lemma lemma1 : f (- mon_unit) = a * c. Proof. unfold f; apply ap. exact (hspace_right_identity c). Defined. Lemma lemma2 : f (conj c * conj a * d * conj b) = (-d) * conj b. Proof. unfold f. rewrite 2 factorneg_r. rewrite 3 simple_associativity. rewrite <- distropp. rewrite (right_inverse (a * c)). rewrite (left_identity d). symmetry. apply factorneg_l. Defined. Lemma lemma3 : g mon_unit = c * b. Proof. unfold g; apply ap. apply left_identity. Defined. Lemma lemma4 : g (conj c * conj a * d * conj b) = conj a * d. Proof. unfold g. rewrite 2 simple_associativity. rewrite <- simple_associativity. rewrite left_inverse. rewrite right_identity. rewrite 2 simple_associativity. rewrite right_inverse. rewrite <- simple_associativity. apply left_identity. Defined. End Lemmata. Arguments f {_ _}. Arguments g {_ _}. (** Here is the multiplication map in algebraic form: [(a,b) * (c,d) = (a * c - d * b*, a* * d + c * b)]. The following is the spherical form. *) Global Instance cd_op : SgOp (pjoin (psusp A) (psusp A)). Proof. snrapply Join_rec2. - exact (fun a b => joinl (a * b)). - exact (fun a b => joinr (conj a * b)). - exact (fun a b => joinr (b * a)). - exact (fun a b => joinl ((- b) * conj a)). - intros; apply jglue. - intros; symmetry; apply jglue. - intros; apply jglue. - intros; symmetry; apply jglue. - intros a b c d; cbn beta. symmetry. apply sq_path. rewrite <- (lemma1 a c). rewrite <- (lemma2 a b c d). rewrite <- (lemma3 b c). rewrite <- (lemma4 a b c d). refine (sq_GGGG _ _ _ _ _). 2,4: apply ap. 1,2,3,4: srapply (Join_rec_beta_jglue _ _ (fun a b => jglue (f a) (g b))). refine (sq_cGcG _ _ _). 1,2: exact (ap_V _ (jglue _ _ )). refine (@sq_ap _ _ _ _ _ _ _ (jglue _ _) (jglue _ _)^ (jglue _ _) (jglue _ _)^ _). change (PathSquare (jglue (- mon_unit) mon_unit) (jglue (conj c * conj a * d * conj b) (conj c * conj a * d * conj b))^ (jglue (- mon_unit) (conj c * conj a * d * conj b)) (jglue (conj c * conj a * d * conj b) mon_unit)^). generalize (conj c * conj a * d * conj b). clear a b c d. change (forall s : Susp A, Diamond (-mon_unit) s (mon_unit) s). srapply Susp_ind; hnf. 1: by apply diamond_v_sq. 1: by apply diamond_h_sq. intro a. apply diamond_twist. Defined. Global Instance cd_op_left_identity : LeftIdentity cd_op pt. Proof. snrapply Join_ind_Flr. 1,2: exact (fun _ => ap _ (hspace_left_identity _)). intros a b. lhs nrapply whiskerR. 1: nrapply (Join_rec_beta_jglue _ _ _ a b). symmetry. apply join_natsq. Defined. Global Instance cd_op_right_identity : RightIdentity cd_op pt. Proof. snrapply Join_ind_Flr. 1: exact (fun _ => ap joinl (hspace_right_identity _)). 1: exact (fun _ => ap joinr (hspace_left_identity _)). intros a b. lhs nrapply whiskerR. 1: nrapply (Join_rec_beta_jglue _ _ _ a b). simpl; symmetry. apply join_natsq. Defined. Global Instance hspace_cdi_susp_assoc : IsHSpace (pjoin (psusp A) (psusp A)) := {}. End ImaginaroidHSpace. Coq-HoTT-9.0/theories/Homotopy/ClassifyingSpace.v000066400000000000000000000441761474641544500220300ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed WildCat. Require Import Cubical.DPath Cubical.PathSquare Cubical.DPathSquare. Require Import Algebra.AbGroups. Require Import Homotopy.HSpace.Core. Require Import TruncType. Require Import Truncations.Core Truncations.Connectedness. Require Import Homotopy.HomotopyGroup. Require Import Homotopy.WhiteheadsPrinciple. Local Open Scope pointed_scope. Local Open Scope mc_mult_scope. Local Open Scope path_scope. (** * We define the Classifying space of a group to be the following HIT: HIT ClassifyingSpace (G : Group) : 1-Type | bbase : ClassifyingSpace | bloop : X -> bbase = bbase | bloop_pp : forall x y, bloop (x * y) = bloop x @ bloop y. We implement this is a private inductive type. *) Module Export ClassifyingSpace. Section ClassifyingSpace. Private Inductive ClassifyingSpace (G : Group) := | bbase : ClassifyingSpace G. Context {G : Group}. Axiom bloop : G -> bbase G = bbase G. Global Arguments bbase {_}. Axiom bloop_pp : forall x y, bloop (x * y) = bloop x @ bloop y. Global Instance istrunc_ClassifyingSpace : IsTrunc 1 (ClassifyingSpace G). Proof. Admitted. End ClassifyingSpace. Arguments bloop {G} _%_mc_mult_scope. (** Now we can state the expected dependent elimination principle, and derive other versions of the elimination principle from it. *) Section ClassifyingSpace_ind. Local Open Scope dpath_scope. Context {G : Group}. (** Note that since our classifying space is 1-truncated, we can only eliminate into 1-truncated type families. *) Definition ClassifyingSpace_ind (P : ClassifyingSpace G -> Type) `{forall b, IsTrunc 1 (P b)} (bbase' : P bbase) (bloop' : forall x, DPath P (bloop x) bbase' bbase') (bloop_pp' : forall x y, DPathSquare P (sq_G1 (bloop_pp x y)) (bloop' (x * y)) ((bloop' x) @Dp (bloop' y)) 1 1) (b : ClassifyingSpace G) : P b := match b with bbase => (fun _ _ => bbase') end bloop' bloop_pp'. (** Here we state the computation rule for [ClassifyingSpace_ind] over [bloop] as an axiom. We don't need one for [bloop_pp] since we have a 1-type. We leave this as admitted since the computation rule is an axiom. **) Definition ClassifyingSpace_ind_beta_bloop (P : ClassifyingSpace G -> Type) `{forall b, IsTrunc 1 (P b)} (bbase' : P bbase) (bloop' : forall x, DPath P (bloop x) bbase' bbase') (bloop_pp' : forall x y, DPathSquare P (sq_G1 (bloop_pp x y)) (bloop' (x * y)) ((bloop' x) @Dp (bloop' y)) 1 1) (x : G) : apD (ClassifyingSpace_ind P bbase' bloop' bloop_pp') (bloop x) = bloop' x. Proof. Admitted. End ClassifyingSpace_ind. End ClassifyingSpace. (** Other eliminators *) Section Eliminators. Context {G : Group}. (** The non-dependent eliminator *) Definition ClassifyingSpace_rec (P : Type) `{IsTrunc 1 P} (bbase' : P) (bloop' : G -> bbase' = bbase') (bloop_pp' : forall x y : G, bloop' (x * y) = bloop' x @ bloop' y) : ClassifyingSpace G -> P. Proof. srefine (ClassifyingSpace_ind (fun _ => P) bbase' _ _). 1: intro x; apply dp_const, bloop', x. intros x y. apply ds_const'. rapply sq_GGcc. 2: refine (_ @ ap _ (dp_const_pp _ _)). 1,2: symmetry; apply eissect. by apply sq_G1. Defined. (** Computation rule for non-dependent eliminator *) Definition ClassifyingSpace_rec_beta_bloop (P : Type) `{IsTrunc 1 P} (bbase' : P) (bloop' : G -> bbase' = bbase') (bloop_pp' : forall x y : G, bloop' (x * y) = bloop' x @ bloop' y) (x : G) : ap (ClassifyingSpace_rec P bbase' bloop' bloop_pp') (bloop x) = bloop' x. Proof. rewrite <- dp_apD_const'. unfold ClassifyingSpace_rec. rewrite ClassifyingSpace_ind_beta_bloop. apply eissect. Qed. (** Sometimes we want to induct into a set which means we can ignore the bloop_pp arguments. Since this is a routine argument, we turn it into a special case of our induction principle. *) Definition ClassifyingSpace_ind_hset (P : ClassifyingSpace G -> Type) `{forall b, IsTrunc 0 (P b)} (bbase' : P bbase) (bloop' : forall x, DPath P (bloop x) bbase' bbase') : forall b, P b. Proof. refine (ClassifyingSpace_ind P bbase' bloop' _). intros. apply ds_G1. apply path_ishprop. Defined. Definition ClassifyingSpace_rec_hset (P : Type) `{IsTrunc 0 P} (bbase' : P) (bloop' : G -> bbase' = bbase') : ClassifyingSpace G -> P. Proof. srapply (ClassifyingSpace_rec P bbase' bloop' _). intros; apply path_ishprop. Defined. (** Similarly, when eliminating into an hprop, we only have to handle the basepoint. *) Definition ClassifyingSpace_ind_hprop (P : ClassifyingSpace G -> Type) `{forall b, IsTrunc (-1) (P b)} (bbase' : P bbase) : forall b, P b. Proof. refine (ClassifyingSpace_ind_hset P bbase' _). intros; rapply dp_ishprop. Defined. End Eliminators. (** The classifying space is 0-connected. *) Global Instance isconnected_classifyingspace {G : Group} : IsConnected 0 (ClassifyingSpace G). Proof. apply (Build_Contr _ (tr bbase)). srapply Trunc_ind. srapply ClassifyingSpace_ind_hprop; reflexivity. Defined. (** The classifying space of a group is pointed. *) Global Instance ispointed_classifyingspace (G : Group) : IsPointed (ClassifyingSpace G) := bbase. Definition pClassifyingSpace (G : Group) := [ClassifyingSpace G, bbase]. (** To use the [B G] notation for [pClassifyingSpace] import this module. *) Module Import ClassifyingSpaceNotation. Definition B G := pClassifyingSpace G. End ClassifyingSpaceNotation. (** [bloop] takes the unit of the group to reflexivity. *) Definition bloop_id {G : Group} : bloop (mon_unit : G) = idpath. Proof. symmetry. apply (cancelL (bloop mon_unit)). refine (_ @ bloop_pp _ _). refine (_ @ ap _ (left_identity _)^). apply concat_p1. Defined. (** [bloop] "preserves inverses" by taking inverses in [G] to inverses of paths in [BG]. *) Definition bloop_inv {G : Group} (x : G) : bloop x^ = (bloop x)^. Proof. refine (_ @ concat_p1 _). apply moveL_Vp. refine (_ @ bloop_id). refine ((bloop_pp _ _)^ @ _). apply ap, right_inverse. Defined. (** The underlying pointed map of [pequiv_g_loops_bg]. *) Definition pbloop {G : Group} : G ->* loops (B G). Proof. srapply Build_pMap. 1: exact bloop. apply bloop_id. Defined. (* This says that [B] is left adjoint to the loop space functor from pointed 1-types to groups. *) Definition pClassifyingSpace_rec {G : Group} (P : pType) `{IsTrunc 1 P} (bloop' : G -> loops P) (bloop_pp' : forall x y : G, bloop' (x * y) = bloop' x @ bloop' y) : B G ->* P := Build_pMap (B G) P (ClassifyingSpace_rec P (point P) bloop' bloop_pp') idpath. (* And this is one of the standard facts about adjoint functors: (R h') o eta = h, where h : G -> R P, h' : L G -> P is the adjunct, and eta (bloop) is the unit. *) Definition pClassifyingSpace_rec_beta_bloop {G : Group} (P : pType) `{IsTrunc 1 P} (bloop' : G -> loops P) (bloop_pp' : forall x y : G, bloop' (x * y) = bloop' x @ bloop' y) : fmap loops (pClassifyingSpace_rec P bloop' bloop_pp') o bloop == bloop'. Proof. intro x; simpl. refine (concat_1p _ @ concat_p1 _ @ _). apply ClassifyingSpace_rec_beta_bloop. Defined. (** Here we prove that [BG] is a delooping of [G], i.e. that [loops BG <~> G]. *) Section EncodeDecode. Context `{Univalence} {G : Group}. Local Definition codes : B G -> HSet. Proof. srapply ClassifyingSpace_rec. + srapply (Build_HSet G). + intro x. apply path_trunctype. exact (Build_Equiv _ _ (fun t => t * x) _). + intros x y; cbn beta. refine (_ @ path_trunctype_pp _ _). apply ap, path_equiv, path_forall. intro; cbn. apply associativity. Defined. Local Definition encode : forall b, bbase = b -> codes b. Proof. intros b p. exact (transport codes p mon_unit). Defined. Local Definition codes_transport : forall x y : G, transport codes (bloop x) y = y * x. Proof. intros x y. rewrite transport_idmap_ap. rewrite ap_compose. rewrite ClassifyingSpace_rec_beta_bloop. rewrite ap_trunctype. by rewrite transport_path_universe_uncurried. Qed. Local Definition decode : forall (b : B G), codes b -> bbase = b. Proof. srapply ClassifyingSpace_ind_hset. + exact bloop. + intro x. apply dp_arrow. intro y; cbn in *. apply dp_paths_r. refine ((bloop_pp _ _)^ @ _). symmetry. apply ap, codes_transport. Defined. Local Lemma decode_encode : forall b p, decode b (encode b p) = p. Proof. intros b p. destruct p. apply bloop_id. Defined. Global Instance isequiv_bloop : IsEquiv (@bloop G). Proof. srapply isequiv_adjointify. + exact (encode _). + rapply decode_encode. + intro x. refine (codes_transport _ _ @ _). apply left_identity. Defined. (** The defining property of BG. *) Definition equiv_g_loops_bg : G <~> loops (B G) := Build_Equiv _ _ bloop _. (** Pointed version of the defining property. *) Definition pequiv_g_loops_bg : G <~>* loops (B G) := Build_pEquiv _ _ pbloop _. Definition pequiv_loops_bg_g := pequiv_g_loops_bg^-1*%equiv. (** We also have that the equivalence is a group isomorphism. *) (** First we show that the loop space of a pointed 1-type is a group. *) Definition LoopGroup (X : pType) `{IsTrunc 1 X} : Group := Build_Group (loops X) concat idpath inverse (Build_IsGroup _ _ _ _ (Build_IsMonoid _ _ _ (Build_IsSemiGroup _ _ _ concat_p_pp) concat_1p concat_p1) concat_Vp concat_pV). Definition grp_iso_g_loopgroup_bg : GroupIsomorphism G (LoopGroup (B G)). Proof. snrapply Build_GroupIsomorphism'. 1: exact equiv_g_loops_bg. intros x y. apply bloop_pp. Defined. Definition grp_iso_g_pi1_bg : GroupIsomorphism G (Pi1 (B G)). Proof. snrapply (transitive_groupisomorphism _ _ _ grp_iso_g_loopgroup_bg). snrapply Build_GroupIsomorphism'. - rapply equiv_tr. - intros x y; reflexivity. Defined. (* We also record this fact. *) Definition grp_homo_loops {X Y : pType} `{IsTrunc 1 X} `{IsTrunc 1 Y} : (X ->** Y) ->* [LoopGroup X $-> LoopGroup Y, grp_homo_const]. Proof. snrapply Build_pMap. - intro f. snrapply Build_GroupHomomorphism. + exact (fmap loops f). + nrapply fmap_loops_pp. - cbn beta. apply equiv_path_grouphomomorphism. exact (pointed_htpy fmap_loops_pconst). Defined. End EncodeDecode. (** When [G] is an abelian group, [BG] is an H-space. *) Section HSpace_bg. Context {G : AbGroup}. Definition bg_mul : B G -> B G -> B G. Proof. intro b. snrapply ClassifyingSpace_rec. 1: exact _. 1: exact b. { intro x. revert b. snrapply ClassifyingSpace_ind_hset. 1: exact _. 1: exact (bloop x). cbn; intro y. apply dp_paths_lr. refine (concat_pp_p _ _ _ @ _). apply moveR_Vp. refine ((bloop_pp _ _)^ @ _ @ bloop_pp _ _). apply ap, commutativity. } intros x y. revert b. srapply ClassifyingSpace_ind_hprop. exact (bloop_pp x y). Defined. Definition bg_mul_symm : forall x y, bg_mul x y = bg_mul y x. Proof. intros x. srapply ClassifyingSpace_ind_hset. { simpl. revert x. srapply ClassifyingSpace_ind_hset. 1: reflexivity. intros x. apply sq_dp^-1, sq_1G. refine (ap_idmap _ @ _^). nrapply ClassifyingSpace_rec_beta_bloop. } intros y; revert x. simpl. snrapply ClassifyingSpace_ind_hprop. 1: exact _. simpl. nrapply (transport_paths_FFlr' (g := idmap)). apply equiv_p1_1q. lhs nrapply ap_idmap. nrapply ClassifyingSpace_rec_beta_bloop. Defined. Definition bg_mul_left_id : forall b : B G, bg_mul bbase b = b. Proof. apply bg_mul_symm. Defined. Definition bg_mul_right_id : forall b : B G, bg_mul b bbase = b. Proof. reflexivity. Defined. Global Instance ishspace_bg : IsHSpace (B G) := Build_IsHSpace _ bg_mul bg_mul_left_id bg_mul_right_id. End HSpace_bg. (** Functoriality of B(-) *) Global Instance is0functor_pclassifyingspace : Is0Functor B. Proof. apply Build_Is0Functor. intros G H f. snrapply pClassifyingSpace_rec. - exact _. - exact (bloop o f). - intros x y. refine (ap bloop (grp_homo_op f x y) @ _). apply bloop_pp. Defined. Definition bloop_natural (G H : Group) (f : G $-> H) : fmap loops (fmap B f) o bloop == bloop o f. Proof. nrapply pClassifyingSpace_rec_beta_bloop. Defined. Lemma pbloop_natural (G K : Group) (f : G $-> K) : fmap loops (fmap B f) o* pbloop ==* pbloop o* f. Proof. srapply phomotopy_homotopy_hset. apply bloop_natural. Defined. Definition natequiv_g_loops_bg `{Univalence} : NatEquiv ptype_group (loops o B). Proof. snrapply Build_NatEquiv. 1: intros G; rapply pequiv_g_loops_bg. snrapply Build_Is1Natural. intros X Y f. symmetry. apply pbloop_natural. Defined. Global Instance is1functor_pclassifyingspace : Is1Functor B. Proof. apply Build_Is1Functor. (** Action on 2-cells *) - intros G H f g p. snrapply Build_pHomotopy. { snrapply ClassifyingSpace_ind_hset. 1: exact _. 1: reflexivity. intro x. rapply equiv_sq_dp^-1. simpl. rewrite 2 ClassifyingSpace_rec_beta_bloop. apply sq_1G. apply ap. exact (p x). } reflexivity. (** Preservation of identity *) - intros G. snrapply Build_pHomotopy. { snrapply ClassifyingSpace_ind_hset. 1: exact _. 1: reflexivity. intro x. rapply equiv_sq_dp^-1. simpl. rewrite ClassifyingSpace_rec_beta_bloop. apply sq_1G. symmetry. apply ap_idmap. } reflexivity. (** Preservation of composition *) - intros G H K g f. snrapply Build_pHomotopy. { snrapply ClassifyingSpace_ind_hset. 1: exact _. 1: reflexivity. intro x. rapply equiv_sq_dp^-1. simpl. rapply sq_ccGG. 1,2: symmetry. 2: refine (ap_compose (ClassifyingSpace_rec _ _ _ (fun x y => ap bloop (grp_homo_op g x y) @ bloop_pp (g x) (g y))) _ (bloop x) @ ap _ _ @ _). 1-3: nrapply ClassifyingSpace_rec_beta_bloop. apply sq_1G. reflexivity. } reflexivity. Defined. (** Interestingly, [fmap B] is an equivalence *) Global Instance isequiv_fmap_pclassifyingspace `{U : Univalence} (G H : Group) : IsEquiv (fmap B (a := G) (b := H)). Proof. snrapply isequiv_adjointify. { intros f. refine (grp_homo_compose (grp_iso_inverse _) (grp_homo_compose _ _)). 1,3: rapply grp_iso_g_loopgroup_bg. exact (grp_homo_loops f). } { intros f. rapply equiv_path_pforall. snrapply Build_pHomotopy. { snrapply ClassifyingSpace_ind_hset. 1: exact _. { cbn; symmetry. rapply (point_eq f). } { intro g. rapply equiv_sq_dp^-1. rewrite ClassifyingSpace_rec_beta_bloop. simpl. rapply sq_ccGc. 1: symmetry; rapply decode_encode. apply equiv_sq_path. rewrite concat_pp_p. rewrite concat_pp_V. reflexivity. } } symmetry; apply concat_1p. } intros f. rapply equiv_path_grouphomomorphism. intro x. rapply (moveR_equiv_V' equiv_g_loops_bg). nrapply pClassifyingSpace_rec_beta_bloop. Defined. (** Hence we have that group homomorphisms are equivalent to pointed maps between their deloopings. *) Theorem equiv_grp_homo_pmap_bg `{U : Univalence} (G H : Group) : (G $-> H) <~> (B G $-> B H). Proof. snrapply Build_Equiv. 2: apply isequiv_fmap_pclassifyingspace. Defined. Global Instance is1natural_grp_homo_pmap_bg_r {U : Univalence} (G : Group) : Is1Natural (opyon G) (opyon (B G) o B) (equiv_grp_homo_pmap_bg G). Proof. snrapply Build_Is1Natural. intros K H f h. apply path_hom. rapply (fmap_comp B h f). Defined. Theorem natequiv_grp_homo_pmap_bg `{U : Univalence} (G : Group) : NatEquiv (opyon G) (opyon (B G) o B). Proof. rapply Build_NatEquiv. Defined. (** [B(Pi 1 X) <~>* X] for a 0-connected 1-truncated [X]. *) Theorem pequiv_pclassifyingspace_pi1 `{Univalence} (X : pType) `{IsConnected 0 X} `{IsTrunc 1 X} : B (Pi1 X) <~>* X. Proof. (** The pointed map [f] is the adjunct to the inverse of the natural map [loops X -> Pi1 X]. We define it first, to make the later goals easier to read. *) transparent assert (f : (B (Pi1 X) ->* X)). { snrapply pClassifyingSpace_rec. 1: exact _. 1: exact (equiv_tr 0 _)^-1%equiv. intros x y. strip_truncations. reflexivity. } snrapply (Build_pEquiv _ _ f). (** [f] is an equivalence since [loops_functor f o bloop == tr^-1], and the other two maps are equivalences. *) apply isequiv_is0connected_isequiv_loops. snrapply (cancelR_isequiv bloop). 1: exact _. rapply isequiv_homotopic'; symmetry. nrapply pClassifyingSpace_rec_beta_bloop. Defined. Lemma natequiv_bg_pi1_adjoint `{Univalence} (X : pType) `{IsConnected 0 X} : NatEquiv (opyon (Pi1 X)) (opyon X o B). Proof. nrefine (natequiv_compose (G := opyon (Pi1 (pTr 1 X))) _ _). 2: exact (natequiv_opyon_equiv (A:=Group) (grp_iso_inverse (grp_iso_pi_Tr 0 X))). refine (natequiv_compose _ (natequiv_grp_homo_pmap_bg _)). refine (natequiv_compose (G := opyon (pTr 1 X) o B) _ _); revgoals. { refine (natequiv_prewhisker _ _). refine (natequiv_opyon_equiv _^-1$). rapply pequiv_pclassifyingspace_pi1. } snrapply Build_NatEquiv. 1: intro; exact pequiv_ptr_rec. rapply is1natural_prewhisker. Defined. (** The classifying space functor and the fundamental group functor form an adjunction (pType needs to be restricted to the subcategory of 0-connected pTypes). Note that the full adjunction should also be natural in X, but this was not needed yet. *) Theorem equiv_bg_pi1_adjoint `{Univalence} (X : pType) `{IsConnected 0 X} (G : Group) : (Pi 1 X $-> G) <~> (X $-> B G). Proof. rapply natequiv_bg_pi1_adjoint. Defined. Lemma is1natural_equiv_bg_pi1_adjoint_r `{Univalence} (X : pType) `{IsConnected 0 X} : Is1Natural (opyon (Pi1 X)) (opyon X o B) (equiv_bg_pi1_adjoint X). Proof. rapply (is1natural_natequiv (natequiv_bg_pi1_adjoint X)). (** Why so slow? Fixed by making this opaque. *) Opaque equiv_bg_pi1_adjoint. Defined. Transparent equiv_bg_pi1_adjoint. Coq-HoTT-9.0/theories/Homotopy/Cover.v000066400000000000000000000101601474641544500176410ustar00rootroot00000000000000Require Import Basics Types HFiber Truncations.Core Truncations.SeparatedTrunc Pointed Modalities.ReflectiveSubuniverse. Local Open Scope pointed_scope. (** * [O]-connected covers *) (** Given a reflective subuniverse [O], for any type [X] and [x : O X], the [O]-connected cover of [X] at [x] is the fibre of [to O X] at [x]. *) Definition O_cover@{u} `{O : ReflectiveSubuniverse@{u}} (X : Type@{u}) (x : O X) : Type@{u} := hfiber (to O _) x. (** The "[O]-connected" cover is in fact [O]-connected when [O] is a modality, using [isconnected_hfiber_conn_map]. Since Coq can infer this using typeclasses, we don't restate it here. *) (** Characterization of paths in [O_cover] is given by [equiv_path_hfiber]. *) (* If [x] is an actual point of [X], then the connected cover is pointed. *) Definition O_pcover@{u} (O : ReflectiveSubuniverse@{u}) (X : Type@{u}) (x : X) : pType@{u} := pfiber@{u u u} (pto O [X,x]). (** Covers commute with products *) Definition O_pcover_prod `{O : ReflectiveSubuniverse} {X Y : pType@{u}} : O_pcover O (X * Y) pt <~>* [(O_pcover O X pt) * (O_pcover O Y pt), _]. Proof. srapply Build_pEquiv'. { refine (_ oE equiv_functor_sigma_id _). 2: intro; nrapply equiv_path_O_prod. nrapply equiv_sigma_prod_prod. } nrapply path_prod; cbn. all: snrapply path_sigma'. 1,3: exact idpath. all: cbn. all: by rewrite concat_p1, concat_Vp. Defined. (** ** Functoriality of [O_cover] *) (** Given [X] and [x : O X], any map [f : X -> Y] out of [X] induces a map [O_cover X x -> O_cover Y (O_functor O f x)]. *) Definition functor_O_cover@{u v} `{O : ReflectiveSubuniverse} {X Y : Type@{u}} (f : X -> Y) (x : O X) : O_cover@{u} X x -> O_cover@{u} Y (O_functor O f x) := functor_hfiber (f:=to O _) (g:=to O _) (h:=f) (k:=O_functor O f) (to_O_natural O f) x. Definition equiv_functor_O_cover `{O : ReflectiveSubuniverse} {X Y : Type} (f : X -> Y) `{IsEquiv _ _ f} (x : O X) : O_cover X x <~> O_cover Y (O_functor O f x) := Build_Equiv _ _ (functor_O_cover f x) _. (** *** Pointed functoriality *) Definition pfunctor_O_pcover `{O : ReflectiveSubuniverse} {X Y : pType} (f : X ->* Y) : O_pcover O X pt ->* O_pcover O Y pt := functor_pfiber (pto_O_natural O f). Definition pequiv_pfunctor_O_pcover `{O : ReflectiveSubuniverse} {X Y : pType} (f : X ->* Y) `{IsEquiv _ _ f} : O_pcover O X pt <~>* O_pcover O Y pt := Build_pEquiv _ _ (pfunctor_O_pcover f) _. (** In the case of truncations, [ptr_natural] gives a better proof of pointedness. *) Definition pfunctor_pTr_pcover `{n : trunc_index} {X Y : pType} (f : X ->* Y) : O_pcover (Tr n) X pt ->* O_pcover (Tr n) Y pt := functor_pfiber (ptr_natural n f). Definition pequiv_pfunctor_pTr_pcover `{n : trunc_index} {X Y : pType} (f : X ->* Y) `{IsEquiv _ _ f} : O_pcover (Tr n) X pt <~>* O_pcover (Tr n) Y pt := Build_pEquiv _ _ (pfunctor_pTr_pcover f) _. (** * Components *) (** Path components are given by specializing to [O] being set-truncation. *) Definition comp := O_cover (O:=Tr 0). Definition pcomp := O_pcover (Tr 0). Definition pfunctor_pcomp {X Y : pType} := @pfunctor_pTr_pcover (-1) X Y. Definition pequiv_pfunctor_pcomp {X Y : pType} := @pequiv_pfunctor_pTr_pcover (-1) X Y. (** If a property holds at a given point, then it holds for the whole component. This yields equivalences like the following: *) Definition equiv_comp_property `{Univalence} {X : Type} (x : X) (P : X -> Type) `{forall x, IsHProp (P x)} (Px : P x) : comp (sig P) (tr (x; Px)) <~> comp X (tr x). Proof. unfold comp, O_cover, hfiber. simpl. refine (_ oE (equiv_sigma_assoc _ _)^-1). apply equiv_functor_sigma_id; intro y. apply equiv_iff_hprop. - intros [py q]. exact (ap (Trunc_functor _ pr1) q). - refine (equiv_ind (equiv_path_Tr _ _) _ _). apply Trunc_rec; intros p; induction p. exact (Px; idpath). Defined. (** For example, we may take components of equivalences among underlying maps. *) Definition equiv_comp_equiv_map `{Univalence} {A B : Type} (e : A <~> B) : comp (A <~> B) (tr e) <~> comp (A -> B) (tr (equiv_fun e)). Proof. refine (_ oE equiv_functor_O_cover (issig_equiv _ _)^-1 _); cbn. rapply equiv_comp_property. Defined. Coq-HoTT-9.0/theories/Homotopy/EMSpace.v000066400000000000000000000114221474641544500200420ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed. Require Import Cubical.DPath. Require Import Algebra.AbGroups. Require Import Homotopy.Suspension. Require Import Homotopy.ClassifyingSpace. Require Import Homotopy.HSpace.Coherent. Require Import Homotopy.HomotopyGroup. Require Import Homotopy.Hopf. Require Import Truncations.Core Truncations.Connectedness. Require Import WildCat. (** * Eilenberg-Mac Lane spaces *) Local Open Scope pointed_scope. Local Open Scope nat_scope. Local Open Scope mc_mult_scope. (** The definition of the Eilenberg-Mac Lane spaces. Note that while we allow [G] to be non-abelian for [n > 1], later results will need to assume that [G] is abelian. *) Fixpoint EilenbergMacLane (G : Group) (n : nat) : pType := match n with | 0 => G | 1 => pClassifyingSpace G | m.+1 => pTr m.+1 (psusp (EilenbergMacLane G m)) end. Notation "'K(' G , n )" := (EilenbergMacLane G n). Section EilenbergMacLane. Context `{Univalence}. Global Instance istrunc_em {G : Group} {n : nat} : IsTrunc n K(G, n). Proof. destruct n as [|[]]; exact _. Defined. (** This is subsumed by the next result, but Coq doesn't always find the next result when it should. *) Global Instance isconnected_em {G : Group} (n : nat) : IsConnected n K(G, n.+1). Proof. induction n; exact _. Defined. Global Instance isconnected_em' {G : Group} (n : nat) : IsConnected n.-1 K(G, n). Proof. destruct n. 1: exact (is_minus_one_connected_pointed _). apply isconnected_em. Defined. Global Instance is0connected_em {G : Group} (n : nat) : IsConnected 0 K(G, n.+1). Proof. rapply (is0connected_isconnected n.-2). Defined. Local Open Scope trunc_scope. (** This is a variant of [pequiv_ptr_loop_psusp] from pSusp.v. All we are really using is that [n.+2 <= n +2+ n], but because of the use of [isconnmap_pred_add], the proof is a bit more specific to this case. *) Local Lemma pequiv_ptr_loop_psusp' (X : pType) (n : nat) `{IsConnected n.+1 X} : pTr n.+2 X <~>* pTr n.+2 (loops (psusp X)). Proof. snrapply Build_pEquiv. 1: rapply (fmap (pTr _) (loop_susp_unit _)). nrapply O_inverts_conn_map. nrapply (isconnmap_pred_add n.-2). rewrite 2 trunc_index_add_succ. apply (conn_map_loop_susp_unit n X). Defined. Lemma pequiv_loops_em_em (G : AbGroup) (n : nat) : K(G, n) <~>* loops K(G, n.+1). Proof. destruct n. 1: apply pequiv_g_loops_bg. change (K(G, n.+1) <~>* loops (pTr n.+2 (psusp (K(G, n.+1))))). refine (ptr_loops _ _ o*E _). destruct n. 1: srapply (licata_finster (m:=-2)). refine (_ o*E pequiv_ptr (n:=n.+2)). rapply pequiv_ptr_loop_psusp'. Defined. Definition pequiv_loops_em_g (G : AbGroup) (n : nat) : G <~>* iterated_loops n K(G, n). Proof. induction n. - reflexivity. - refine ((unfold_iterated_loops' _ _)^-1* o*E _ o*E IHn). exact (emap (iterated_loops n) (pequiv_loops_em_em _ _)). Defined. (** For positive indices, we in fact get a group isomorphism. *) Definition equiv_g_pi_n_em (G : AbGroup) (n : nat) : GroupIsomorphism G (Pi n.+1 K(G, n.+1)). Proof. induction n. - apply grp_iso_g_pi1_bg. - nrefine (grp_iso_compose _ IHn). nrefine (grp_iso_compose _ (groupiso_pi_functor _ (pequiv_loops_em_em _ _))). symmetry; apply (groupiso_pi_loops _ _). Defined. Definition iscohhspace_em {G : AbGroup} (n : nat) : IsCohHSpace K(G, n). Proof. nrapply iscohhspace_equiv_cohhspace. 2: apply pequiv_loops_em_em. apply iscohhspace_loops. Defined. (** If [G] and [G'] are isomorphic, then [K(G,n)] and [K(G',n)] are equivalent. TODO: We should show that [K(-,n)] is a functor, which implies this. *) Definition pequiv_em_group_iso {G G' : Group} (n : nat) (e : G $<~> G') : K(G, n) <~>* K(G', n). Proof. by destruct (equiv_path_group e). Defined. (** Every pointed (n-1)-connected n-type is an Eilenberg-Mac Lane space. *) Definition pequiv_em_connected_truncated (X : pType) (n : nat) `{IsConnected n X} `{IsTrunc n.+1 X} : K(Pi n.+1 X, n.+1) <~>* X. Proof. generalize dependent X; induction n; intros X isC isT. 1: rapply pequiv_pclassifyingspace_pi1. (* The equivalence will be the composite << K( (Pi n.+2 X) n.+2) <~>* K( (Pi n.+1 (loops X)), n.+2) = pTr n.+2 (psusp K( (Pi n.+1 (loops X)), n.+1)) [by definition] <~>* pTr n.+2 (psusp (loops X)) <~>* pTr n.+2 X <~>* X >> and we'll work from right to left. *) refine ((pequiv_ptr (n:=n.+2))^-1* o*E _). refine (pequiv_ptr_psusp_loops X n o*E _). change (K(?G, n.+2)) with (pTr n.+2 (psusp K( G, n.+1 ))). refine (emap (pTr n.+2 o psusp) _). refine ((IHn (loops X) _ _) o*E _). apply pequiv_em_group_iso. apply groupiso_pi_loops. Defined. End EilenbergMacLane. Coq-HoTT-9.0/theories/Homotopy/EncodeDecode.v000066400000000000000000000040401474641544500210640ustar00rootroot00000000000000Require Import Basics Pointed. Require Import Truncations.Core. (** ** Encode-decode method of characterizing identity types *) (** See Homotopy/IdentitySystems.v for a related characterization of identity types. *) Definition encode_decode (A : Type) (a0 : A) (code : A -> Type) (c0 : code a0) (decode : forall x, code x -> a0 = x) (s : forall (c : code a0), decode _ c # c0 = c) (r : decode _ c0 = idpath) (a1 : A) : a0 = a1 <~> code a1. Proof. srapply equiv_adjointify. - exact (fun p => p # c0). - apply decode. - intro p. destruct (decode _ p) in p. apply s. - intros []. exact r. Defined. (** Encode-decode for truncated identity-types *) Definition encode_decode_trunc n (A : Type) (a0 : A) (code : A -> Type) `{forall a, IsTrunc n (code a)} (c0 : code a0) (decode : forall x, code x -> Tr n (a0 = x)) (s : forall (c : code a0), Trunc_rec (fun p => p # c0) (decode _ c) = c) (r : decode _ c0 = tr idpath) (a1 : A) : Tr n (a0 = a1) <~> code a1. Proof. srapply equiv_adjointify. - apply (Trunc_rec (fun p => p # c0)). - apply decode. - intro p. pose (decode _ p) as p'. clearbody p'. strip_truncations. destruct p' in p. apply s. - intros p. strip_truncations. destruct p. exact r. Defined. (** Encode-decode for loop spaces *) Definition encode_decode_loops (A : pType) (code : pFam A) (decode : forall x, code x -> point A = x) (s : forall (c : code (point A)), decode _ c # (dpoint code) = c) (r : decode _ (dpoint code) = idpath) : loops A <~> code (point A) := encode_decode _ _ code (dpoint code) decode s r _. (** Encode-decode for truncated loop spaces *) Definition encode_decode_trunc_loops n (A : pType) (code : pFam A) `{forall a, IsTrunc n (code a)} (decode : forall x, code x -> Tr n (point A = x)) (s : forall (c : code (point A)), Trunc_rec (fun (p : loops A) => p # (dpoint code)) (decode _ c) = c) (r : decode _ (dpoint code) = tr idpath) : pTr n (loops A) <~> code (point A) := encode_decode_trunc _ _ _ code (dpoint code) decode s r _. Coq-HoTT-9.0/theories/Homotopy/EvaluationFibration.v000066400000000000000000000016641474641544500225410ustar00rootroot00000000000000From HoTT Require Import Basics Types Truncations.Core Pointed.Core Homotopy.Cover. Local Open Scope pointed_scope. Local Open Scope trunc_scope. (** * Evaluation fibrations and self-maps *) (* The type of unpointed self maps of A, pointed at the identity map. *) Definition selfmaps (A : Type) : pType := [A -> A, idmap]. (** The unrestricted evaluation map. *) Definition ev (A : pType) : selfmaps A ->* A := Build_pMap _ _ (fun f : selfmaps A => f pt) idpath. (** The evaluation fibration of an unpointed map [X -> A]. *) Definition evfib {X : pType} {A : Type} (f : X -> A) : comp (X -> A) (tr f) -> A := fun g => g.1 pt. (** If [f] is pointed, then the evaluation fibration of [f] is too. *) Definition pevfib {A X : pType} (f : X ->* A) : pcomp (X -> A) f ->* A := Build_pMap _ _ (fun g : pcomp (X -> A) f => g.1 pt) (point_eq f). (* The evaluation map of the identity. *) Definition ev1 (A : pType) := pevfib (A:=A) pmap_idmap. Coq-HoTT-9.0/theories/Homotopy/ExactSequence.v000066400000000000000000000471511474641544500213320ustar00rootroot00000000000000Require Import Basics Types. Require Import SuccessorStructure. Require Import WildCat. Require Import Pointed. Require Import Modalities.Identity Modalities.Descent. Require Import Truncations. Require Import HFiber. Require Import ObjectClassifier. Local Open Scope succ_scope. Open Scope pointed_scope. (** * Exact sequences *) (** ** Very short complexes *) (** A (very short) complex is a pair of pointed maps whose composite is the zero map. *) Definition IsComplex {F X Y} (i : F ->* X) (f : X ->* Y) := (f o* i ==* pconst). (** This induces a map from the domain of [i] to the fiber of [f]. *) Definition cxfib {F X Y : pType} {i : F ->* X} {f : X ->* Y} (cx : IsComplex i f) : F ->* pfiber f. Proof. srapply Build_pMap. - exact (fun x => (i x; cx x)). - cbn. refine (path_sigma' _ (point_eq i) _); cbn. refine (transport_paths_Fl _ _ @ _). apply moveR_Vp. exact ((concat_p1 _)^ @ point_htpy cx). Defined. (** ...whose composite with the projection [pfib : pfiber i -> X] is [i]. *) Definition pfib_cxfib {F X Y : pType} {i : F ->* X} {f : X ->* Y} (cx : IsComplex i f) : pfib f o* cxfib cx ==* i. Proof. srapply Build_pHomotopy. - reflexivity. - cbn. rewrite ap_pr1_path_sigma; hott_simpl. Defined. (** Truncation preserves complexes. *) Definition iscomplex_ptr (n : trunc_index) {F X Y : pType} (i : F ->* X) (f : X ->* Y) (cx : IsComplex i f) : IsComplex (fmap (pTr n) i) (fmap (pTr n) f). Proof. refine ((fmap_comp (pTr n) i f)^* @* _). refine (_ @* ptr_functor_pconst n). rapply (fmap2 (pTr _)); assumption. Defined. (** Loop spaces preserve complexes. *) Definition iscomplex_loops {F X Y : pType} (i : F ->* X) (f : X ->* Y) (cx : IsComplex i f) : IsComplex (fmap loops i) (fmap loops f). Proof. refine ((fmap_comp loops i f)^$ $@ _ $@ fmap_zero_morphism _). rapply (fmap2 loops); assumption. Defined. Definition iscomplex_iterated_loops {F X Y : pType} (i : F ->* X) (f : X ->* Y) (cx : IsComplex i f) (n : nat) : IsComplex (fmap (iterated_loops n) i) (fmap (iterated_loops n) f). Proof. induction n as [|n IHn]; [ exact cx | ]. apply iscomplex_loops; assumption. Defined. (** Passage across homotopies preserves complexes. *) Definition iscomplex_homotopic_i {F X Y : pType} {i i' : F ->* X} (ii : i' ==* i) (f : X ->* Y) (cx : IsComplex i f) : IsComplex i' f := pmap_postwhisker f ii @* cx. Definition iscomplex_homotopic_f {F X Y : pType} (i : F ->* X) {f f' : X ->* Y} (ff : f' ==* f) (cx : IsComplex i f) : IsComplex i f' := pmap_prewhisker i ff @* cx. Definition iscomplex_cancelL {F X Y Y' : pType} (i : F ->* X) (f : X ->* Y) (e : Y <~>* Y') (cx : IsComplex i (e o* f)) : IsComplex i f. Proof. refine (_ @* precompose_pconst e^-1*). refine ((compose_V_hh e (f o* i))^$ $@ _). refine (cat_postwhisker e^-1* _). refine ((cat_assoc _ _ _)^$ $@ _). exact cx. Defined. (** And likewise passage across squares with equivalences *) Definition iscomplex_equiv_i {F F' X X' Y : pType} (i : F ->* X) (i' : F' ->* X') (g : F' <~>* F) (h : X' <~>* X) (p : h o* i' ==* i o* g) (f : X ->* Y) (cx: IsComplex i f) : IsComplex i' (f o* h). Proof. refine (pmap_compose_assoc _ _ _ @* _). refine (pmap_postwhisker f p @* _). refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker g cx @* _). apply postcompose_pconst. Defined. (** A special version with only an equivalence on the fiber. *) Definition iscomplex_equiv_fiber {F F' X Y : pType} (i : F ->* X) (f : X ->* Y) (phi : F' <~>* F) `{cx : IsComplex i f} : IsComplex (i o* phi) f. Proof. refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker _ cx @* _). apply postcompose_pconst. Defined. (** Any pointed map induces a trivial complex. *) Definition iscomplex_trivial {X Y : pType} (f : X ->* Y) : IsComplex (@pconst pUnit X) f. Proof. srapply Build_pHomotopy. - intro x; cbn. exact (point_eq f). - cbn; symmetry. exact (concat_p1 _ @ concat_1p _). Defined. (** If Y is a set, then IsComplex is an HProp. *) Global Instance ishprop_iscomplex_hset `{Funext} {F X Y : pType} `{IsHSet Y} (i : F ->* X) (f : X ->* Y) : IsHProp (IsComplex i f) := _. (** ** Very short exact sequences and fiber sequences *) (** A complex is [n]-exact if the induced map [cxfib] is [n]-connected. *) Cumulative Class IsExact (n : Modality) {F X Y : pType} (i : F ->* X) (f : X ->* Y) := { cx_isexact : IsComplex i f ; conn_map_isexact : IsConnMap n (cxfib cx_isexact) }. Global Existing Instance conn_map_isexact. Definition issig_isexact (n : Modality) {F X Y : pType} (i : F ->* X) (f : X ->* Y) : _ <~> IsExact n i f := ltac:(issig). (** If Y is a set, then IsExact is an HProp. *) Global Instance ishprop_isexact_hset `{Univalence} {F X Y : pType} `{IsHSet Y} (n : Modality) (i : F ->* X) (f : X ->* Y) : IsHProp (IsExact n i f). Proof. rapply (transport (fun A => IsHProp A) (x := { cx : IsComplex i f & IsConnMap n (cxfib cx) })). 2: exact _. apply path_universe_uncurried; issig. Defined. (** With exactness we can choose preimages. *) Lemma isexact_preimage (O : Modality) {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact O _ _ _ i f} (x : X) (p : f x = point Y) : O (hfiber i x). Proof. rapply (O_functor O (A:=hfiber (cxfib cx_isexact) (x; p))). - intros [z q]. exact (z; ap pr1 q). - apply center, conn_map_isexact. Defined. (** Bundled version of the above. *) Lemma isexact_preimage_hfiber (O : Modality) {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact O _ _ _ i f} (x : hfiber f pt) : O (hfiber i x.1). Proof. srapply isexact_preimage; exact x.2. Defined. (** If the base is contractible, then [i] is [O]-connected. *) Definition isconnmap_O_isexact_base_contr (O : Modality@{u}) {F X Y : pType} `{Contr Y} (i : F ->* X) (f : X ->* Y) `{IsExact@{_ _ u u u} O _ _ _ i f} : IsConnMap O i := conn_map_compose@{u _ u _} O (cxfib@{u u _ _} cx_isexact) pr1. (** Passage across homotopies preserves exactness. *) Definition isexact_homotopic_i n {F X Y : pType} {i i' : F ->* X} (ii : i' ==* i) (f : X ->* Y) `{IsExact n F X Y i f} : IsExact n i' f. Proof. exists (iscomplex_homotopic_i ii f cx_isexact). refine (conn_map_homotopic n (cxfib cx_isexact) _ _ _). intros u; cbn. refine (path_sigma' _ (ii u)^ _). exact (transport_paths_Fl _ _ @ ((inverse2 (ap_V _ _) @ inv_V _) @@ 1)). Defined. Definition isexact_homotopic_f n {F X Y : pType} (i : F ->* X) {f f' : X ->* Y} (ff : f' ==* f) `{IsExact n F X Y i f} : IsExact n i f'. Proof. exists (iscomplex_homotopic_f i ff cx_isexact). pose (e := equiv_hfiber_homotopic _ _ ff pt). nrefine (cancelL_isequiv_conn_map n _ e). 1: apply equiv_isequiv. refine (conn_map_homotopic n (cxfib (cx_isexact)) _ _ _). intro u. simpl. srapply path_hfiber. 1: reflexivity. refine (concat_1p _ @ concat_V_pp _ _)^. Defined. (** And also passage across squares with equivalences. *) Definition isexact_equiv_i n {F F' X X' Y : pType} (i : F ->* X) (i' : F' ->* X') (g : F' <~>* F) (h : X' <~>* X) (p : h o* i' ==* i o* g) (f : X ->* Y) `{IsExact n F X Y i f} : IsExact n i' (f o* h). Proof. exists (iscomplex_equiv_i i i' g h p f cx_isexact); cbn. snrefine (cancelL_equiv_conn_map n (C := pfiber f) _ _). - exact (@equiv_functor_hfiber _ _ _ _ (f o h) f h equiv_idmap (fun x => 1%path) (point Y)). - cbn; unfold functor_hfiber, functor_sigma; cbn. refine (conn_map_homotopic n (@cxfib _ _ _ i f cx_isexact o g) _ _ _). intros u; cbn. refine (path_sigma' _ (p u)^ _). abstract ( rewrite transport_paths_Fl, ap_V, inv_V, !concat_1p, concat_p1, ap_idmap; reflexivity ). Defined. (** In particular, we can transfer exactness across equivalences of the total space. *) Definition moveL_isexact_equiv n {F X X' Y : pType} (i : F ->* X) (f : X' ->* Y) (phi : X <~>* X') `{IsExact n _ _ _ (phi o* i) f} : IsExact n i (f o* phi). Proof. rapply (isexact_equiv_i _ _ _ pequiv_pmap_idmap phi); cbn. exact (pmap_precompose_idmap _)^*. Defined. (** Similarly, we can cancel equivalences on the fiber. *) Definition isexact_equiv_fiber n {F F' X Y : pType} (i : F ->* X) (f : X ->* Y) (phi : F' <~>* F) `{E : IsExact n _ _ _ i f} : IsExact n (i o* phi) f. Proof. snrapply Build_IsExact. 1: apply iscomplex_equiv_fiber, cx_isexact. apply (conn_map_homotopic _ (cxfib cx_isexact o* phi)). { intro x; cbn. by rewrite concat_p1, concat_1p. } exact _. Defined. (** An equivalence of short sequences preserves exactness. *) Definition isexact_square_if n {F F' X X' Y Y' : pType} {i : F ->* X} {i' : F' ->* X'} {f : X ->* Y} {f' : X' ->* Y'} (g : F' <~>* F) (h : X' <~>* X) (k : Y' <~>* Y) (p : h o* i' ==* i o* g) (q : k o* f' ==* f o* h) `{IsExact n F X Y i f} : IsExact n i' f'. Proof. pose (I := isexact_equiv_i n i i' g h p f). pose (I2 := isexact_homotopic_f n i' q). exists (iscomplex_cancelL i' f' k cx_isexact). epose (e := (pequiv_pfiber pequiv_pmap_idmap k (pmap_precompose_idmap (k o* f'))^* : pfiber f' <~>* pfiber (k o* f'))). nrefine (cancelL_isequiv_conn_map n _ e). 1: apply pointed_isequiv. refine (conn_map_homotopic n (cxfib (cx_isexact)) _ _ _). intro u. srapply path_hfiber. { reflexivity. } cbn. unfold moveR_equiv_V. rewrite !concat_1p, !concat_p1, ap_pp_p, ap_pp, (ap_pp k _ (eissect k (point Y'))), ap_V, <- !eisadj. rewrite <- !ap_compose, concat_pp_p. rewrite (concat_A1p (eisretr k)), concat_pV_p. rewrite (concat_A1p (eisretr k)), concat_V_pp. reflexivity. Defined. (** If a complex [F -> E -> B] is [O]-exact, the map [F -> B] is [O]-local, and path types in [Y] are [O]-local, then the induced map [cxfib] is an equivalence. *) Global Instance isequiv_cxfib {O : Modality} {F X Y : pType} {i : F ->* X} {f : X ->* Y} `{forall y y' : Y, In O (y = y')} `{MapIn O _ _ i} (ex : IsExact O i f) : IsEquiv (cxfib cx_isexact). Proof. rapply isequiv_conn_ino_map. 1: apply ex. rapply (cancelL_mapinO _ _ pr1). Defined. Definition equiv_cxfib {O : Modality} {F X Y : pType} {i : F ->* X} {f : X ->* Y} `{forall y y' : Y, In O (y = y')} `{MapIn O _ _ i} (ex : IsExact O i f) : F <~>* pfiber f := Build_pEquiv _ _ _ (isequiv_cxfib ex). Proposition equiv_cxfib_beta {F X Y : pType} {i : F ->* X} {f : X ->* Y} `{forall y y' : Y, In O (y = y')} `{MapIn O _ _ i} (ex : IsExact O i f) : i o pequiv_inverse (equiv_cxfib ex) == pfib _. Proof. rapply equiv_ind. 1: exact (isequiv_cxfib ex). intro x. exact (ap (fun g => i g) (eissect _ x)). Defined. (** A purely exact sequence is [O]-exact for any modality [O]. *) Definition isexact_purely_O {O : Modality} {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact purely _ _ _ i f} : IsExact O i f. Proof. srapply Build_IsExact. 1: apply cx_isexact. exact _. Defined. (** When [n] is the identity modality [purely], so that [cxfib] is an equivalence, we get simply a fiber sequence. In particular, the fiber of a given map yields an purely-exact sequence. *) Definition iscomplex_pfib {X Y} (f : X ->* Y) : IsComplex (pfib f) f. Proof. srapply Build_pHomotopy. - intros [x p]; exact p. - cbn. exact (concat_p1 _ @ concat_1p _)^. Defined. Global Instance isexact_pfib {X Y} (f : X ->* Y) : IsExact purely (pfib f) f. Proof. exists (iscomplex_pfib f). exact _. Defined. (** Fiber sequences can alternatively be defined as an equivalence to the fiber of some map. *) Definition FiberSeq (F X Y : pType) := { f : X ->* Y & F <~>* pfiber f }. Definition i_fiberseq {F X Y} (fs : FiberSeq F X Y) : F ->* X := pfib fs.1 o* fs.2. Global Instance isexact_purely_fiberseq {F X Y : pType} (fs : FiberSeq F X Y) : IsExact purely (i_fiberseq fs) fs.1. Proof. srapply Build_IsExact; [ srapply Build_pHomotopy | ]. - intros u; cbn. exact ((fs.2 u).2). - apply moveL_pV. cbn. refine (concat_p1 _ @ _). apply moveL_Mp. refine (_ @ (point_eq fs.2)..2). refine (_ @ (transport_paths_Fl _ _)^). apply whiskerR, inverse2, ap, concat_p1. - intros [x p]. apply contr_map_isequiv. change (IsEquiv fs.2); exact _. Defined. Definition pequiv_cxfib {F X Y : pType} {i : F ->* X} {f : X ->* Y} `{IsExact purely F X Y i f} : F <~>* pfiber f := Build_pEquiv _ _ (cxfib cx_isexact) _. Definition fiberseq_isexact_purely {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : FiberSeq F X Y := (f; pequiv_cxfib). (** It's easier to show that [loops] preserves fiber sequences than that it preserves purely-exact sequences. *) Definition fiberseq_loops {F X Y} (fs : FiberSeq F X Y) : FiberSeq (loops F) (loops X) (loops Y). Proof. (** TODO: doesn't work?! *) (* exists (fmap loops fs.1). *) refine (fmap loops fs.1; _). refine (_ o*E emap loops fs.2). exact (pfiber_fmap_loops fs.1)^-1*. Defined. (** Now we can deduce that [loops] preserves purely-exact sequences. The hardest part is modifying the first map back to [fmap loops i]. *) Global Instance isexact_loops {F X Y} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : IsExact purely (fmap loops i) (fmap loops f). Proof. refine (@isexact_homotopic_i purely _ _ _ _ (fmap loops i) _ (fmap loops f) (isexact_purely_fiberseq (fiberseq_loops (fiberseq_isexact_purely i f)))). transitivity (fmap loops (pfib f) o* fmap loops (cxfib cx_isexact)). - refine (_ @* fmap_comp loops _ _). rapply (fmap2 loops). symmetry; apply pfib_cxfib. - refine (_ @* pmap_compose_assoc _ _ _). refine (pmap_prewhisker (fmap loops (cxfib cx_isexact)) _). apply moveR_pequiv_fV. apply pr1_pfiber_fmap_loops. Defined. Global Instance isexact_iterated_loops {F X Y} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} (n : nat) : IsExact purely (fmap (iterated_loops n) i) (fmap (iterated_loops n) f). Proof. induction n as [|n IHn]; [ assumption | apply isexact_loops; assumption ]. Defined. (** (n.+1)-truncation preserves n-exactness. *) Global Instance isexact_ptr `{Univalence} (n : trunc_index) {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact (Tr n) F X Y i f} : IsExact (Tr n) (fmap (pTr n.+1) i) (fmap (pTr n.+1) f). Proof. exists (iscomplex_ptr n.+1 i f cx_isexact). srefine (cancelR_conn_map (Tr n) (@tr n.+1 F) (@cxfib _ _ _ (fmap (pTr n.+1) i) (fmap (pTr n.+1) f) _)). { intros x; rapply isconnected_pred. } nrapply conn_map_homotopic. 2:nrapply (conn_map_compose _ (cxfib _) (functor_hfiber (fun y => (to_O_natural (Tr n.+1) f y)^) (point Y))). 3:pose @O_lex_leq_Tr; rapply (OO_conn_map_functor_hfiber_to_O). - intros x; refine (path_sigma' _ 1 _); cbn. (* This is even simpler than it looks, because for truncations [to_O_natural n.+1 := 1], [to n.+1 := tr], and [cx_const := H]. *) exact (1 @@ (concat_p1 _)^). - exact _. Defined. (** In particular, (n.+1)-truncation takes fiber sequences to n-exact ones. *) Global Instance isexact_ptr_purely `{Univalence} (n : trunc_index) {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : IsExact (Tr n) (fmap (pTr n.+1) i) (fmap (pTr n.+1) f). Proof. rapply isexact_ptr. exists cx_isexact. intros z; apply isconnected_contr. exact (conn_map_isexact (f := f) (i := i) z). Defined. (** ** Connecting maps *) (** It's useful to see [pfib_cxfib] as a degenerate square. *) Definition square_pfib_pequiv_cxfib {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : pequiv_pmap_idmap o* i ==* pfib f o* pequiv_cxfib. Proof. unfold Square. refine (pmap_postcompose_idmap _ @* _). symmetry; apply pfib_cxfib. Defined. (** The connecting maps for the long exact sequence of loop spaces, defined as an extension to a fiber sequence. *) Definition connect_fiberseq {F X Y} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : FiberSeq (loops Y) F X. Proof. exists i. exact (((pfiber2_loops f) o*E (pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f)))^-1*). Defined. Definition connecting_map {F X Y} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : loops Y ->* F := i_fiberseq (connect_fiberseq i f). Global Instance isexact_connect_R {F X Y} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : IsExact purely (fmap loops f) (connecting_map i f). Proof. refine (isexact_equiv_i (Y := F) purely (pfib (pfib i)) (fmap loops f) (((loops_inv X) o*E (pfiber2_loops (pfib f)) o*E (pequiv_pfiber _ _ (square_pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f))))^-1*) (((pfiber2_loops f) o*E (pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f)))^-1*) _ (pfib i)). refine (vinverse ((loops_inv X) o*E (pfiber2_loops (pfib f)) o*E (pequiv_pfiber _ _ (square_pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f)))) ((pfiber2_loops f) o*E (pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f))) _). refine (vconcat (f03 := loops_inv X o* pfiber2_loops (pfib f)) (f01 := pequiv_pfiber _ _ (square_pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f))) (f23 := pfiber2_loops f) (f21 := pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f)) _ _). - exact (square_pequiv_pfiber _ _ (square_pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f))). - exact (pfiber2_fmap_loops f). Defined. (** The connecting map associated to a pointed family. *) Definition connecting_map_family {Y : pType} (P : pFam Y) : loops Y ->* [P pt, dpoint P]. Proof. srapply Build_pMap. - intro l. apply (transport P l). apply P. - reflexivity. Defined. (** ** Long exact sequences *) Record LongExactSequence (k : Modality) (N : SuccStr) : Type := { les_carrier : N -> pType; les_fn : forall n, les_carrier n.+1 ->* les_carrier n; les_isexact : forall n, IsExact k (les_fn n.+1) (les_fn n) }. Coercion les_carrier : LongExactSequence >-> Funclass. Arguments les_fn {k N} S n : rename. Global Existing Instance les_isexact. (** Long exact sequences are preserved by truncation. *) Definition trunc_les `{Univalence} (k : trunc_index) {N : SuccStr} (S : LongExactSequence purely N) : LongExactSequence (Tr k) N := Build_LongExactSequence (Tr k) N (fun n => pTr k.+1 (S n)) (fun n => fmap (pTr k.+1) (les_fn S n)) _. (** ** LES of loop spaces and homotopy groups *) Definition loops_carrier (F X Y : pType) (n : N3) : pType := match n with | (n, inl (inl (inl x))) => Empty_ind _ x | (n, inl (inl (inr tt))) => iterated_loops n Y | (n, inl (inr tt)) => iterated_loops n X | (n, inr tt) => iterated_loops n F end. (** Starting from a fiber sequence, we can obtain a long purely-exact sequence of loop spaces. *) Definition loops_les {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : LongExactSequence purely (N3). Proof. srefine (Build_LongExactSequence purely (N3) (loops_carrier F X Y) _ _). all:intros [n [[[[]|[]]|[]]|[]]]; cbn. { exact (fmap (iterated_loops n) f). } { exact (fmap (iterated_loops n) i). } { exact (connecting_map (fmap (iterated_loops n) i) (fmap (iterated_loops n) f)). } all:exact _. Defined. (** And from that, a long exact sequence of homotopy groups (though for now it is just a sequence of pointed sets). *) Definition Pi_les `{Univalence} {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : LongExactSequence (Tr (-1)) (N3) := trunc_les (-1) (loops_les i f). (** * Classifying fiber sequences *) (** Fiber sequences correspond to pointed maps into the universe. *) Definition classify_fiberseq `{Univalence} {Y F : pType@{u}} : (Y ->* [Type@{u}, F]) <~> { X : pType@{u} & FiberSeq F X Y }. Proof. refine (_ oE _). (** To apply [equiv_sigma_pfibration] we need to invert the equivalence on the fiber. *) { do 2 (rapply equiv_functor_sigma_id; intro). apply equiv_pequiv_inverse. } exact ((equiv_sigma_assoc _ _)^-1 oE equiv_sigma_pfibration). Defined. Coq-HoTT-9.0/theories/Homotopy/Freudenthal.v000066400000000000000000000030061474641544500210250ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Colimits.Pushout. Require Import Colimits.SpanPushout. Require Import HoTT.Truncations. Require Import Homotopy.Suspension. Require Import Homotopy.BlakersMassey. (** * The Freudenthal Suspension Theorem *) (** The Freudenthal suspension theorem is a fairly trivial corollary of the Blakers-Massey theorem. The only real work is to relate the span-pushout that we used for Blakers-Massey to the naive pushout that we used to define suspension. *) Local Definition freudenthal' `{Univalence} (n : trunc_index) (X : Type) `{IsConnected n.+1 X} : IsConnMap (n +2+ n) (@merid X). Proof. snrapply cancelL_equiv_conn_map. 2: { refine (equiv_ap' (B:=SPushout (fun (u v : Unit) => X)) _ North South). exact (equiv_pushout (equiv_contr_sigma (fun _ : Unit * Unit => X))^-1 (equiv_idmap Unit) (equiv_idmap Unit) (fun x : X => idpath) (fun x : X => idpath)). } refine (conn_map_homotopic _ _ _ _ (blakers_massey n n (fun (u v:Unit) => X) tt tt)). intros x. refine (_ @ (equiv_pushout_pglue (equiv_contr_sigma (fun _ : Unit * Unit => X))^-1 (equiv_idmap Unit) (equiv_idmap Unit) (fun x : X => idpath) (fun x : X => idpath) x)^). exact ((concat_p1 _ @ concat_1p _)^). Defined. Definition freudenthal@{u v | u < v} := Eval unfold freudenthal' in @freudenthal'@{u u u u u v u u u u u}. Global Existing Instance freudenthal. Coq-HoTT-9.0/theories/Homotopy/HSpace.v000066400000000000000000000001731474641544500177310ustar00rootroot00000000000000Require Export HSpace.Core. Require Export HSpace.Coherent. Require Export HSpace.Pointwise. Require Export HSpace.Moduli. Coq-HoTT-9.0/theories/Homotopy/HSpace/000077500000000000000000000000001474641544500175415ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Homotopy/HSpace/Coherent.v000066400000000000000000000027071474641544500215050ustar00rootroot00000000000000Require Import Basics HSpace.Core Pointed.Core Pointed.Loops. Local Open Scope mc_mult_scope. Local Open Scope pointed_scope. (** ** Coherent H-space structures *) (** An H-space is coherent when the left and right identities agree at the base point. *) Class IsCoherent (X : pType) `{IsHSpace X} := iscoherent : left_identity pt = right_identity pt. Record IsCohHSpace (A : pType) := { ishspace_cohhspace : IsHSpace A; iscoherent_cohhspace : IsCoherent A; }. #[export] Existing Instances ishspace_cohhspace iscoherent_cohhspace. Definition issig_iscohhspace (A : pType) : { hspace_op : SgOp A & { hspace_left_identity : LeftIdentity hspace_op pt & { hspace_right_identity : RightIdentity hspace_op pt & hspace_left_identity pt = hspace_right_identity pt } } } <~> IsCohHSpace A := ltac:(make_equiv). (** A type equivalent to a coherent H-space is a coherent H-space. *) Definition iscohhspace_equiv_cohhspace {X Y : pType} `{IsCohHSpace Y} (f : X <~>* Y) : IsCohHSpace X. Proof. snrapply Build_IsCohHSpace. - rapply (ishspace_equiv_hspace f). apply ishspace_cohhspace; assumption. - unfold IsCoherent; cbn. refine (_ @@ 1). refine (ap (ap f^-1) _). pelim f. refine (1 @@ _). apply iscoherent. Defined. (** Every loop space is a coherent H-space. *) Definition iscohhspace_loops {X : pType} : IsCohHSpace (loops X). Proof. snrapply Build_IsCohHSpace. - apply ishspace_loops. - reflexivity. Defined. Coq-HoTT-9.0/theories/Homotopy/HSpace/Core.v000066400000000000000000000201641474641544500206230ustar00rootroot00000000000000Require Export Classes.interfaces.canonical_names (SgOp, sg_op, MonUnit, mon_unit, LeftIdentity, left_identity, RightIdentity, right_identity, Negate, negate, Associative, simple_associativity, associativity, LeftInverse, left_inverse, RightInverse, right_inverse, Commutative, commutativity). Export canonical_names.BinOpNotations. Require Import Basics Types Pointed WildCat.Core. Require Import Truncations.Core Truncations.Connectedness. Local Open Scope pointed_scope. Local Open Scope trunc_scope. Local Open Scope mc_mult_scope. Local Open Scope path_scope. (** * H-spaces *) (** A (noncoherent) H-space [X] is a pointed type with a binary operation for which the base point is a both a left and a right identity. (See Coherent.v for the notion of a coherent H-space.) We say [X] is left-invertible if left multiplication by any element is an equivalence, and dually for right-invertible. *) Class IsHSpace (X : pType) := { hspace_op : SgOp X; hspace_left_identity : LeftIdentity hspace_op pt; hspace_right_identity : RightIdentity hspace_op pt; }. #[export] Existing Instances hspace_left_identity hspace_right_identity hspace_op. Global Instance hspace_mon_unit {X : pType} `{IsHSpace X} : MonUnit X := pt. Definition issig_ishspace {X : pType} : { mu : X -> X -> X & prod (forall x, mu pt x = x) (forall x, mu x pt = x) } <~> IsHSpace X := ltac:(make_equiv). (** Left and right multiplication by the base point is always an equivalence. *) Global Instance isequiv_hspace_left_op_pt {X : pType} `{IsHSpace X} : IsEquiv (pt *.). Proof. apply (isequiv_homotopic idmap); intro x. exact (left_identity x)^. Defined. Global Instance isequiv_hspace_right_op_pt {X : pType} `{IsHSpace X} : IsEquiv (.* pt). Proof. apply (isequiv_homotopic idmap); intro x. exact (right_identity x)^. Defined. Definition equiv_hspace_left_op {X : pType} `{IsHSpace X} (x : X) `{IsEquiv _ _ (x *.)} : X <~> X := Build_Equiv _ _ (x *.) _. Definition equiv_hspace_right_op {X : pType} `{IsHSpace X} (x : X) `{IsEquiv _ _ (.* x)} : X <~> X := Build_Equiv _ _ (.* x) _. (** Any element of an H-space defines a pointed self-map by left multiplication, in the following sense. *) Definition pmap_hspace_left_op {X : pType} `{IsHSpace X} (x : X) : X ->* [X, x] := Build_pMap X [X,x] (x *.) (right_identity x). (** We make [(x *.)] into a pointed equivalence (when possible). In particular, this makes [(pt *.)] into a pointed self-equivalence. We could have also used the left identity to make [(pt *.)] into a pointed self-equivalence, and then we would get a map that's equal to the identity as a pointed map; but without coherence (see Coherent.v) this is not necessarily the case for this map. *) Definition pequiv_hspace_left_op {X : pType} `{IsHSpace X} (x : X) `{IsEquiv _ _ (x *.)} : X <~>* [X,x] := Build_pEquiv' (B:=[X,x]) (equiv_hspace_left_op x) (right_identity x). (** ** Connected H-spaces *) (** For connected H-spaces, left and right multiplication by an element is an equivalence. This is because left and right multiplication by the base point is one, and being an equivalence is a proposition. *) Global Instance isequiv_hspace_left_op `{Univalence} {A : pType} `{IsHSpace A} `{IsConnected 0 A} : forall (a : A), IsEquiv (a *.). Proof. nrapply conn_point_elim; exact _. Defined. Global Instance isequiv_hspace_right_op `{Univalence} {A : pType} `{IsHSpace A} `{IsConnected 0 A} : forall (a : A), IsEquiv (.* a). Proof. nrapply conn_point_elim; exact _. Defined. (** ** Left-invertible H-spaces are homogeneous *) (** A homogeneous structure on a pointed type [A] gives, for any point [a : A], a self-equivalence of [A] sending the base point to [a]. (This is the same data as a left-invertible right-unital binary operation.) *) Class IsHomogeneous (A : pType) := ishomogeneous : forall a, A <~>* [A, a]. (** Any homogeneous structure can be modified so that the base point is mapped to the pointed identity map. *) Definition homogeneous_pt_id {A : pType} `{IsHomogeneous A} : forall a, A <~>* [A,a] := fun a => ishomogeneous a o*E (ishomogeneous (point A))^-1*. Definition homogeneous_pt_id_beta {A : pType} `{IsHomogeneous A} : homogeneous_pt_id (point A) ==* pequiv_pmap_idmap := peisretr _. Definition homogeneous_pt_id_beta' `{Funext} {A : pType} `{IsHomogeneous A} : homogeneous_pt_id (point A) = pequiv_pmap_idmap := ltac:(apply path_pequiv, peisretr). (** This modified structure makes any homogeneous type into a (left-invertible) H-space. *) Definition ishspace_homogeneous {A : pType} `{IsHomogeneous A} : IsHSpace A. Proof. snrapply Build_IsHSpace. - exact (fun a b => homogeneous_pt_id a b). - intro a; cbn. apply eisretr. - intro a. exact (point_eq (homogeneous_pt_id a)). Defined. (** Left-invertible H-spaces are homogeneous, giving a logical equivalence between left-invertible H-spaces and homogeneous types. (In fact, the type of homogeneous types with the base point sent to the pointed identity map is equivalent to the type of left-invertible coherent H-spaces, but we don't prove that here.) See [equiv_iscohhspace_ptd_action] for a closely related result. *) Global Instance ishomogeneous_hspace {A : pType} `{IsHSpace A} `{forall a, IsEquiv (a *.)} : IsHomogeneous A := (fun a => pequiv_hspace_left_op a). (** ** Promoting unpointed homotopies to pointed homotopies *) (** Two pointed maps [f g : Y ->* X] into an H-space are equal if and only if they are equal as unpointed maps. (Note: This is a logical "iff", not an equivalence of types.) This was first observed by Evan Cavallo for homogeneous types. Below we show a generalization due to Egbert Rijke, which we then specialize to H-spaces. Notably, the specialization does not require left-invertibility. This appears as Lemma 2.6 in https://arxiv.org/abs/2301.02636v1 *) (** First a version that assumes an equality of the unpointed maps. *) Definition phomotopy_from_path_arrow {A B : pType} (m : forall (a : A), (point A) = (point A) -> a = a) (q : m pt == idmap) {f g : B ->* A} (K : pointed_fun f = pointed_fun g) : f ==* g. Proof. nrapply issig_phomotopy. destruct f as [f fpt], g as [g gpt]; cbn in *. induction K. destruct A as [A a0]; cbn in *. induction fpt. exists (fun b => m (f b) (idpath @ gpt^)). apply q. Defined. (** Assuming [Funext], we may take [K] to be a homotopy. With a more elaborate proof, [Funext] could be avoided here and therefore in the next result as well. *) Definition phomotopy_from_homotopy `{Funext} {A B : pType} (m : forall (a : A), (point A) = (point A) -> a = a) (q : m pt == idmap) {f g : B ->* A} (K : f == g) : f ==* g := (phomotopy_from_path_arrow m q (path_forall _ _ K)). (** We specialize to H-spaces. *) Definition hspace_phomotopy_from_homotopy `{Funext} {A B : pType} `{IsHSpace A} {f g : B ->* A} (K : f == g) : f ==* g. Proof. snrapply (phomotopy_from_homotopy _ _ K). - intro a. exact (fmap loops (pmap_hspace_left_op a o* (pequiv_hspace_left_op pt)^-1*)). - lazy beta. transitivity (fmap (b:=A) loops pmap_idmap). 2: rapply (fmap_id loops). rapply (fmap2 loops). nrapply peisretr. Defined. (** A version with actual paths. *) Definition hspace_path_pforall_from_path_arrow `{Funext} {A B : pType} `{IsHSpace A} {f g : B ->* A} (K : pointed_fun f = pointed_fun g) : f = g. Proof. apply path_pforall, hspace_phomotopy_from_homotopy. apply (path_arrow _ _)^-1. exact K. Defined. (** A type equivalent to an H-space is an H-space. *) Definition ishspace_equiv_hspace {X Y : pType} `{IsHSpace Y} (f : X <~>* Y) : IsHSpace X. Proof. snrapply Build_IsHSpace. - exact (fun a b => f^-1 (f a * f b)). - intro b. rhs_V nrapply (eissect f b). apply ap. lhs nrapply (ap (.* f b) (point_eq f)). apply left_identity. - intro a. rhs_V nrapply (eissect f a). apply ap. lhs nrapply (ap (f a *.) (point_eq f)). apply right_identity. Defined. (** Every loop space is an H-space. Making this an instance breaks CayleyDickson.v because Coq finds this instance rather than the expected one. *) Definition ishspace_loops {X : pType} : IsHSpace (loops X). Proof. snrapply Build_IsHSpace. - exact concat. - exact concat_1p. - exact concat_p1. Defined. Coq-HoTT-9.0/theories/Homotopy/HSpace/Moduli.v000066400000000000000000000222321474641544500211620ustar00rootroot00000000000000Require Import Basics Types HSpace.Core HSpace.Coherent HSpace.Pointwise Pointed Homotopy.EvaluationFibration. Local Open Scope pointed_scope. Local Open Scope mc_mult_scope. Local Open Scope path_scope. (** * The moduli type of coherent H-space structures *) (** When [A] is a left-invertible coherent H-space, we construct an equivalence between the ("moduli") type of coherent H-space structures on [A] and the type [A ->* (A ->** A)]. By the smash-hom adjunction for pointed types, due to Floris van Doorn in HoTT, the latter is also equivalent to the type [Smash A A ->* A]. This equivalence generalizes a formula of Arkowitz--Curjel and Copeland for spaces, and appears as Theorem 2.27 in https://arxiv.org/abs/2301.02636v1 *) (** ** Paths between H-space structures *) (** Paths between H-space structures correspond to homotopies between the underlying binary operations which respect the identities. This is the type of the latter. *) Definition path_ishspace_type {X : pType} (mu nu : IsHSpace X) : Type. Proof. destruct mu as [mu mu_lid mu_rid], nu as [nu nu_lid nu_rid]. refine { h : forall x0 x1, mu x0 x1 = nu x0 x1 & prod (forall x:X, _) (forall x:X, _) }. - exact (mu_lid x = h pt x @ nu_lid x). - exact (mu_rid x = h x pt @ nu_rid x). Defined. (** Transport of left and right identities of binary operations along paths between the underlying functions. *) Local Definition transport_binop_lr_id `{Funext} {X : Type} {x : X} {mu nu : X -> X -> X} `{mu_lid : forall y, mu x y = y} `{mu_rid : forall y, mu y x = y} (p : mu = nu) : transport (fun m : X -> X -> X => (forall y, m x y = y) * (forall y, m y x = y)) p (mu_lid, mu_rid) = (fun y => (ap100 p _ _)^ @ mu_lid y, fun y => (ap100 p _ _)^ @ mu_rid y). Proof. induction p; cbn. apply path_prod'; funext y. all: exact (concat_1p _)^. Defined. (** Characterization of paths between H-space structures. *) Definition equiv_path_ishspace `{Funext} {X : pType} (mu nu : IsHSpace X) : path_ishspace_type mu nu <~> (mu = nu). Proof. destruct mu as [mu mu_lid mu_rid], nu as [nu nu_lid nu_rid]; unfold path_ishspace_type. nrefine (equiv_ap_inv' issig_ishspace _ _ oE _). nrefine (equiv_path_sigma _ _ _ oE _); cbn. apply (equiv_functor_sigma' (equiv_path_arrow2 _ _)); intro h; cbn. nrefine (equiv_concat_l _ _ oE _). 1: apply transport_binop_lr_id. nrefine (equiv_path_prod _ _ oE _); cbn. apply equiv_functor_prod'; nrefine (equiv_path_forall _ _ oE _); apply equiv_functor_forall_id; intro x. all: nrefine (equiv_moveR_Vp _ _ _ oE _); apply equiv_concat_r; apply whiskerR; symmetry; apply ap100_path_arrow2. Defined. (** ** Sections of evaluation fibrations *) (** We first show that coherent H-space structures on a pointed type correspond to pointed sections of the evaluation fibration [ev A]. *) Definition equiv_iscohhspace_psect `{Funext} (A : pType) : IsCohHSpace A <~> pSect (ev A). Proof. refine (issig_psect (ev A) oE _^-1%equiv oE (issig_iscohhspace A)^-1%equiv). unfold SgOp, LeftIdentity, RightIdentity. apply equiv_functor_sigma_id; intro mu. apply (equiv_functor_sigma' (equiv_apD10 _ _ _)); intro H1; cbn. apply equiv_functor_sigma_id; intro H2; cbn. refine (equiv_path_inverse _ _ oE _). apply equiv_concat_r. apply concat_p1. Defined. (** Our next goal is to see that when [A] is a left-invertible H-space, then the fibration [ev A] is trivial. *) (** This lemma says that the family [fun a => A ->* [A,a]] is trivial. *) Lemma equiv_pmap_hspace `{Funext} {A : pType} (a : A) `{IsHSpace A} `{!IsEquiv (hspace_op a)} : (A ->* A) <~> (A ->* [A,a]). Proof. nrapply pequiv_pequiv_postcompose. rapply pequiv_hspace_left_op. Defined. (** The lemma gives us an equivalence on the total spaces (domains) of [ev A] and [psnd] (the projection out of the displayed product). *) Proposition equiv_map_pmap_hspace `{Funext} {A : pType} `{IsHSpace A} `{forall a:A, IsEquiv (a *.)} : (A ->* A) * A <~> (A -> A). Proof. transitivity {a : A & {f : A -> A & f pt = a}}. 2: exact (equiv_sigma_contr _ oE (equiv_sigma_symm _)^-1%equiv). refine (_ oE (equiv_sigma_prod0 _ _)^-1%equiv oE equiv_prod_symm _ _). apply equiv_functor_sigma_id; intro a. exact ((issig_pmap A [A,a])^-1%equiv oE equiv_pmap_hspace a). Defined. (** The above is a pointed equivalence. *) Proposition pequiv_map_pmap_hspace `{Funext} {A : pType} `{IsHSpace A} `{forall a:A, IsEquiv (a *.)} : [(A ->* A) * A, (pmap_idmap, pt)] <~>* selfmaps A. Proof. snrapply Build_pEquiv'. 1: exact equiv_map_pmap_hspace. cbn. apply path_forall, hspace_left_identity. Defined. (** When [A] is coherent, the pointed equivalence [pequiv_map_pmap_hspace] is a pointed equivalence over [A], i.e., a trivialization of [ev A]. *) Proposition hspace_ev_trivialization `{Funext} {A : pType} `{IsCoherent A} `{forall a:A, IsEquiv (a *.)} : ev A o* pequiv_map_pmap_hspace ==* psnd (A:=[A ->* A, pmap_idmap]). Proof. snrapply Build_pHomotopy. { intros [f x]; cbn. exact (ap _ (dpoint_eq f) @ hspace_right_identity _). } cbn. refine (concat_1p _ @ _^). refine (concat_p1 _ @ concat_p1 _ @ _). refine (ap10_path_forall _ _ _ _ @ _). apply iscoherent. Defined. (** ** The equivalence [IsCohHSpace A <~> (A ->* (A ->** A))] *) Theorem equiv_cohhspace_ppmap `{Funext} {A : pType} `{IsCoherent A} `{forall a:A, IsEquiv (hspace_op a)} : IsCohHSpace A <~> (A ->* (A ->** A)). Proof. refine (_ oE equiv_iscohhspace_psect A). refine (_ oE (equiv_pequiv_pslice_psect _ _ _ hspace_ev_trivialization^*)^-1%equiv). refine (_ oE equiv_psect_psnd (A:=[A ->* A, pmap_idmap])). refine (pequiv_pequiv_postcompose _); symmetry. rapply pequiv_hspace_left_op. Defined. (** Here is a third characterization of the type of coherent H-space structures. It simply involves shuffling the data around and using [Funext]. *) Definition equiv_iscohhspace_ptd_action `{Funext} (A : pType) : IsCohHSpace A <~> { act : forall a, A ->* [A,a] & act pt ==* pmap_idmap }. Proof. refine (_ oE (issig_iscohhspace A)^-1). unfold IsPointed. (* First we shuffle the data on the LHS to be of this form: *) equiv_via {s : {act : A -> (A -> A) & forall a, act a pt = a} & {h : s.1 pt == idmap & h pt = s.2 pt}}. 1: make_equiv. (* Then we break up [->*] and [==*] on the RHS using issig lemmas, and handle a trailing [@ 1]. *) snrapply equiv_functor_sigma'. - refine (equiv_functor_forall_id (fun a => issig_pmap A [A,a]) oE _). unfold IsPointed. nrapply equiv_sig_coind. - cbn. intros [act p]; simpl. refine (issig_phomotopy _ _ oE _); cbn. apply equiv_functor_sigma_id; intro q. apply equiv_concat_r; symmetry; apply concat_p1. Defined. (** It follows that any homogeneous type is a coherent H-space. This generalizes [ishspace_homogeneous]. *) Definition iscohhspace_homogeneous `{Funext} {A : pType} `{IsHomogeneous A} : IsCohHSpace A. Proof. apply (equiv_iscohhspace_ptd_action A)^-1. exists homogeneous_pt_id. apply homogeneous_pt_id_beta. Defined. (** One can also show directly that the H-space structure defined by [ishspace_homogeneous] is coherent. This also avoids [Funext]. *) Definition iscoherent_homogeneous {A : pType} `{IsHomogeneous A} : @IsCoherent A (ishspace_homogeneous). Proof. unfold IsCoherent; cbn. set (f := ishomogeneous pt). change (eisretr f pt = ap f (moveR_equiv_V pt pt (point_eq f)^) @ point_eq f). rewrite <- (point_eq f). unfold moveR_equiv_V; simpl. rhs nrapply concat_p1. lhs nrapply (eisadj f). apply ap. symmetry; apply concat_1p. Defined. (** Using either of these, we can "upgrade" any left-invertible H-space structure to a coherent one. This one has a prime because the direct proof below computes better. *) Definition iscohhspace_hspace' (A : pType) `{IsHSpace A} `{forall a, IsEquiv (a *.)} : IsCohHSpace A. Proof. snrapply Build_IsCohHSpace. { nrapply ishspace_homogeneous. apply ishomogeneous_hspace. } apply iscoherent_homogeneous. Defined. (** The new multiplication is homotopic to the original one. Relative to this, we expect that one of the identity laws also agrees, but that the other does not. *) Definition iscohhspace_hspace'_beta_mu `{Funext} (A : pType) {m : IsHSpace A} `{forall a, IsEquiv (a *.)} : @hspace_op A (@ishspace_cohhspace A (iscohhspace_hspace' A)) = @hspace_op A m. Proof. cbn. (* [*], [sg_op] and [hspace_op] all denote the original operation. *) funext a b. refine (ap (a *.) _). apply moveR_equiv_V. symmetry; apply left_identity. Defined. (** Here's a different proof that directly upgrades an H-space structure, leaving the multiplication and left-identity definitionally the same, but changing the right-identity. *) Definition iscohhspace_hspace (A : pType) {m : IsHSpace A} `{forall a, IsEquiv (a *.)} : IsCohHSpace A. Proof. snrapply Build_IsCohHSpace. 1: snrapply Build_IsHSpace. - exact (@hspace_op A m). - exact (@hspace_left_identity A m). - intro a. lhs nrapply (ap (a *.) (hspace_right_identity pt))^. lhs nrapply (ap (a *.) (hspace_left_identity pt)). exact (hspace_right_identity a). - unfold IsCoherent; cbn. apply moveL_Vp. lhs nrapply concat_A1p. refine (_ @@ 1). apply (cancelR _ _ (hspace_left_identity pt)). symmetry; apply concat_A1p. Defined. Coq-HoTT-9.0/theories/Homotopy/HSpace/Pointwise.v000066400000000000000000000072011474641544500217110ustar00rootroot00000000000000Require Import Basics Types Pointed HSpace.Core HSpace.Coherent. Local Open Scope pointed_scope. Local Open Scope mc_mult_scope. Local Open Scope path_scope. (** * Pointwise H-space structures *) (** Whenever [X] is an H-space, so is the type of maps into [X]. *) Global Instance ishspace_map `{Funext} (X : pType) (Y : Type) `{IsHSpace X} : IsHSpace [Y -> X, const pt]. (* Note: When writing [f * g], Coq only finds this instance if [f] is explicitly in the pointed type [[Y -> X, const pt]]. *) Proof. snrapply Build_IsHSpace. - exact (fun f g y => (f y) * (g y)). - intro g; funext y. apply hspace_left_identity. - intro f; funext y. apply hspace_right_identity. Defined. (** If [X] is coherent, so is [[Y -> X, const pt]]. *) Global Instance iscoherent_ishspace_map `{Funext} (X : pType) (Y : Type) `{IsCoherent X} : IsCoherent [Y -> X, const pt]. Proof. hnf; cbn. refine (ap _ _). funext y; apply iscoherent. Defined. (** If [X] is left-invertible, so is [[Y -> X, const pt]]. *) Global Instance isleftinvertible_hspace_map `{Funext} (X : pType) (Y : Type) `{IsHSpace X} `{forall x, IsEquiv (x *.)} : forall f : [Y -> X, const pt], IsEquiv (f *.). Proof. intro f; cbn. (** Left multiplication by [f] unifies with [functor_forall]. *) exact (isequiv_functor_forall (P:=const X) (f:=idmap) (g:=fun y gy => (f y) * gy)). Defined. (** For the type of pointed maps [Y ->** X], coherence of [X] is needed even to get a noncoherent H-space structure on [Y ->** X]. *) Global Instance ishspace_pmap `{Funext} (X Y : pType) `{IsCoherent X} : IsHSpace (Y ->** X). Proof. snrapply Build_IsHSpace. - intros f g. snrapply Build_pMap. + exact (fun y => hspace_op (f y) (g y)). + cbn. refine (ap _ (point_eq g) @ _); cbn. refine (ap (.* pt) (point_eq f) @ _). apply hspace_left_identity. - intro g. apply path_pforall. snrapply Build_pHomotopy. + intro y; cbn. apply hspace_left_identity. + cbn. apply moveL_pV. exact (1 @@ concat_1p _ @ concat_A1p _ _)^. - intro f. apply path_pforall. snrapply Build_pHomotopy. + intro y; cbn. apply hspace_right_identity. + pelim f; cbn. symmetry. lhs nrapply (concat_p1 _ @ concat_1p _ @ concat_1p _). apply iscoherent. Defined. Global Instance iscoherent_hspace_pmap `{Funext} (X Y : pType) `{IsCoherent X} : IsCoherent (Y ->** X). Proof. (* Note that [pt] sometimes means the constant map [Y ->* X]. *) unfold IsCoherent. (* Both identities are created using [path_pforall]. *) refine (ap path_pforall _). apply path_pforall. snrapply Build_pHomotopy. - intro y; cbn. apply iscoherent. - cbn. generalize iscoherent as isc. unfold left_identity, right_identity. (* The next line is essentially the same as [generalize], but for some reason that tactic doesn't work here. *) set (p := hspace_left_identity pt); clearbody p. intros []. induction p. reflexivity. Defined. (** If the H-space structure on [X] is left-invertible, so is the one induced on [Y ->** X]. *) Global Instance isleftinvertible_hspace_pmap `{Funext} (X Y : pType) `{IsCoherent X} `{forall x, IsEquiv (x *.)} : forall f : Y ->** X, IsEquiv (f *.). Proof. intro f. srefine (isequiv_homotopic (equiv_functor_pforall_id _ _) _). - exact (fun a => equiv_hspace_left_op (f a)). - cbn. exact (right_identity _ @ point_eq f). - intro g. apply path_pforall; snrapply Build_pHomotopy. + intro y; cbn. reflexivity. + cbn. apply (moveR_1M _ _)^-1. apply whiskerL. refine (whiskerL _ iscoherent @ _). exact (concat_A1p right_identity (point_eq f)). Defined. Coq-HoTT-9.0/theories/Homotopy/HSpaceS1.v000066400000000000000000000055301474641544500201370ustar00rootroot00000000000000Require Import Classes.interfaces.canonical_names. Require Import Cubical.DPath Cubical.PathSquare. Require Import Homotopy.Suspension. Require Import Homotopy.HSpace.Core. Require Import Homotopy.HSpace.Coherent. Require Import Spaces.Spheres. (** H-space structure on circle. *) Section HSpace_S1. Context `{Univalence}. Definition Sph1_ind (P : Sphere 1 -> Type) (b : P North) (p : DPath P (merid North @ (merid South)^) b b) : forall x : Sphere 1, P x. Proof. srapply Susp_ind. 1: exact b. 1: exact (merid South # b). srapply Susp_ind; hnf. { apply moveL_transport_p. refine ((transport_pp _ _ _ _)^ @ _). apply p. } 1: reflexivity. apply Empty_ind. Defined. Definition Sph1_rec (P : Type) (b : P) (p : b = b) : Sphere 1 -> P. Proof. srapply Susp_rec. 1,2: exact b. simpl. srapply Susp_rec. 1: exact p. 1: reflexivity. apply Empty_rec. Defined. Definition Sph1_rec_beta_loop (P : Type) (b : P) (p : b = b) : ap (Sph1_rec P b p) (merid North @ (merid South)^) = p. Proof. rewrite ap_pp. rewrite ap_V. rewrite 2 Susp_rec_beta_merid. apply concat_p1. Defined. Definition s1_turn : forall x : Sphere 1, x = x. Proof. srapply Sph1_ind. + exact (merid North @ (merid South)^). + apply dp_paths_lr. by rewrite concat_Vp, concat_1p. Defined. Global Instance sgop_s1 : SgOp (psphere 1) := fun x y => Sph1_rec _ y (s1_turn y) x. Global Instance leftidentity_s1 : LeftIdentity sgop_s1 (point (psphere 1)). Proof. srapply Sph1_ind. 1: reflexivity. apply dp_paths_lr. rewrite concat_p1. apply concat_Vp. Defined. Global Instance rightidentity_s1 : RightIdentity sgop_s1 (point (psphere 1)). Proof. srapply Sph1_ind. 1: reflexivity. apply dp_paths_FlFr. rewrite concat_p1. rewrite ap_idmap. rewrite Sph1_rec_beta_loop. apply concat_Vp. Defined. Global Instance hspace_s1 : IsHSpace (psphere 1) := {}. Global Instance iscoherent_s1 : IsCoherent (psphere 1) := idpath. Definition iscohhspace_s1 : IsCohHSpace (psphere 1) := Build_IsCohHSpace _ _ _. Global Instance associative_sgop_s1 : Associative sgop_s1. Proof. intros x y z. revert x. srapply Sph1_ind. 1: reflexivity. apply sq_dp^-1. revert y. srapply Sph1_ind. { apply (sq_flip_v (px0:=1) (px1:=1)). exact (ap_nat' (fun a => ap (fun b => sgop_s1 b z) (rightidentity_s1 a)) (merid North @ (merid South)^)). } apply path_ishprop. Defined. Global Instance commutative_sgop_s1 : Commutative sgop_s1. Proof. intros x y. revert x. srapply Sph1_ind. 1: cbn; symmetry; apply right_identity. apply sq_dp^-1. revert y. srapply Sph1_ind. 1: exact (ap_nat' rightidentity_s1 _). srapply dp_ishprop. Defined. End HSpace_S1. Coq-HoTT-9.0/theories/Homotopy/HomotopyGroup.v000066400000000000000000000323561474641544500214310ustar00rootroot00000000000000Require Import Basics Types Pointed HSet. Require Import Modalities.Modality. Require Import Truncations.Core Truncations.SeparatedTrunc. Require Import Algebra.AbGroups. Require Import WildCat. Local Open Scope nat_scope. Local Open Scope pointed_scope. Local Open Scope path_scope. (** The type that the nth homotopy group will have. *) Definition HomotopyGroup_type (n : nat) : Type := match n with | 0 => pType | n.+1 => Group end. (* Every homotopy group is, in particular, a pointed type. *) Definition HomotopyGroup_type_ptype (n : nat) : HomotopyGroup_type n -> pType := match n return HomotopyGroup_type n -> pType with | 0 => fun X => X (* This works because [ptype_group] is already a coercion. *) | n.+1 => fun G => G end. Coercion HomotopyGroup_type_ptype : HomotopyGroup_type >-> pType. (** We construct the wildcat structure on HomotopyGroup_type in the obvious way. *) Global Instance isgraph_homotopygroup_type (n : nat) : IsGraph (HomotopyGroup_type n) := ltac:(destruct n; exact _). Global Instance is2graph_homotopygroup_type (n : nat) : Is2Graph (HomotopyGroup_type n) := ltac:(destruct n; exact _). Global Instance is01cat_homotopygroup_type (n : nat) : Is01Cat (HomotopyGroup_type n) := ltac:(destruct n; exact _). Global Instance is1cat_homotopygroup_type (n : nat) : Is1Cat (HomotopyGroup_type n) := ltac:(destruct n; exact _). Global Instance is0functor_homotopygroup_type_ptype (n : nat) : Is0Functor (HomotopyGroup_type_ptype n) := ltac:(destruct n; exact _). Global Instance is1functor_homotopygroup_type_ptype (n : nat) : Is1Functor (HomotopyGroup_type_ptype n) := ltac:(destruct n; exact _). (** We first define [Pi 1 X], and use this to define [Pi n X]. The reason is to make it easier for Coq to see that [Pi (n.+1) X] is definitionally equal to [Pi 1 (iterated_loops n X)] *) Definition Pi1 (X : pType) : Group. Proof. srapply (Build_Group (Tr 0 (loops X))); repeat split. (** Operation *) + intros x y. strip_truncations. exact (tr (x @ y)). (** Unit *) + exact (tr 1). (** Inverse *) + srapply Trunc_rec; intro x. exact (tr x^). (** IsHSet *) + exact _. (** Associativity *) + intros x y z. strip_truncations. cbn; apply ap. apply concat_p_pp. (** Left identity *) + intro x. strip_truncations. cbn; apply ap. apply concat_1p. (** Right identity *) + intro x. strip_truncations. cbn; apply ap. apply concat_p1. (** Left inverse *) + intro x. strip_truncations. apply (ap tr). apply concat_Vp. (** Right inverse *) + intro x. strip_truncations. apply (ap tr). apply concat_pV. Defined. (** Definition of the nth homotopy group *) Definition Pi (n : nat) (X : pType) : HomotopyGroup_type n. Proof. destruct n. 1: exact (pTr 0 X). exact (Pi1 (iterated_loops n X)). Defined. (** See [pi_loops] below for an alternate unfolding. *) Definition pi_succ n X : Pi n.+1 X $<~> Pi 1 (iterated_loops n X) := grp_iso_id. Module PiUtf8. Notation "'π'" := Pi. End PiUtf8. Global Instance ishset_pi {n : nat} {X : pType} : IsHSet (Pi n X) := ltac:(destruct n; exact _). (** When n >= 2 we have that the nth homotopy group is an abelian group. Note that we don't actually define it as an abelian group but merely show that it is one. This would cause lots of complications with the typechecker. *) Global Instance commutative_pi (n : nat) (X : pType) : Commutative (A:=Pi n.+2 X) sg_op. Proof. intros x y. strip_truncations. cbn; apply (ap tr). apply eckmann_hilton. Defined. (** For the same reason as above, we make [Pi1] a functor before making [Pi] a functor. *) Global Instance is0functor_pi1 : Is0Functor Pi1. Proof. apply Build_Is0Functor. intros X Y f. snrapply Build_GroupHomomorphism. { rapply (fmap (Tr 0)). rapply (fmap loops). assumption. } (** Note: we don't have to be careful about which paths we choose here since we are trying to inhabit a proposition. *) intros x y. strip_truncations. apply (ap tr); cbn. rewrite 2 concat_pp_p. apply whiskerL. rewrite 2 concat_p_pp. rewrite (concat_pp_p (ap f x)). rewrite concat_pV, concat_p1. rewrite concat_p_pp. apply whiskerR. apply ap_pp. Defined. Global Instance is0functor_pi (n : nat) : Is0Functor (Pi n) := ltac:(destruct n; exact _). Definition fmap_pi_succ {X Y : pType} (f : X $-> Y) (n : nat) : fmap (Pi n.+1) f $== fmap (Pi 1) (fmap (iterated_loops n) f). Proof. reflexivity. Defined. Global Instance is1functor_pi1 : Is1Functor Pi1. Proof. (** The conditions for [Pi1] to be a 1-functor only involve equalities of maps between groups, which reduce to equalities of maps between types. Type inference shows that [Tr 0 o loops] is a 1-functor, and so it follows that [Pi1] is a 1-functor. *) assert (is1f : Is1Functor (Tr 0 o loops)) by exact _. apply Build_Is1Functor; intros; [ by rapply (fmap2 _ (is1functor_F := is1f)) | by rapply (fmap_id _ (is1functor_F := is1f)) | by rapply (fmap_comp _ (is1functor_F := is1f)) ]. Defined. Global Instance is1functor_pi (n : nat) : Is1Functor (Pi n) := ltac:(destruct n; exact _). (** Sometimes it is convenient to regard [Pi n] as landing in pointed types. On objects, this is handled by the coercion [HomotopyGroup_type_ptype], but on morphisms it doesn't seem possible to define a coercion. So we explicitly name the composite functor. *) Definition pPi (n : nat) : pType -> pType := HomotopyGroup_type_ptype n o Pi n. Global Instance is0functor_ppi (n : nat) : Is0Functor (pPi n) := _. Global Instance is1functor_ppi (n : nat) : Is1Functor (pPi n) := _. (** [pPi] is equal to a more explicit map. These are definitional for [n = 0] and [n] a successor; it would be nice to make them definitional for generic [n]. *) Definition ppi_ptr_iterated_loops (n : nat) : pPi n = pTr 0 o iterated_loops n := ltac:(destruct n; reflexivity). (** Here is the associated object-wise equivalence, which is the identity map for [0] and successors. *) Definition pequiv_ppi_ptr_iterated_loops (n : nat) (X : pType) : pPi n X <~>* pTr 0 (iterated_loops n X) := ltac:(destruct n; exact pequiv_pmap_idmap). (** These equivalences are natural. Put another way, we can compute [fmap Pi] in terms of the composite functor, up to the equivalences above. For [n = 0] or [n] a successor, we can omit the equivalences; for [n = 0], the induced maps are definitionally equal as pointed maps; for [n] a successfor the underlying unpointed maps are definitionally equal, but the pointedness proofs are not, and this is handled by [phomotopy_homotopy_hset]. *) Definition fmap_ppi_ptr_iterated_loops (n : nat) {X Y : pType} (f : X ->* Y) : pequiv_ppi_ptr_iterated_loops n Y o* fmap (pPi n) f ==* fmap (pTr 0) (fmap (iterated_loops n) f) o* pequiv_ppi_ptr_iterated_loops n X. Proof. destruct n; unfold pequiv_ppi_ptr_iterated_loops. 1: refine (pmap_postcompose_idmap _ @* (pmap_precompose_idmap _)^*). refine (pmap_postcompose_idmap _ @* _ @* (pmap_precompose_idmap _)^*). srapply phomotopy_homotopy_hset; reflexivity. Defined. (** [Pi n.+1] sends equivalences to group isomorphisms. *) Definition groupiso_pi_functor (n : nat) {X Y : pType} (e : X <~>* Y) : Pi n.+1 X $<~> Pi n.+1 Y := emap (Pi n.+1) e. (** The homotopy groups of a loop space are those of the space shifted. *) Definition pi_loops n X : Pi n.+1 X <~>* Pi n (loops X). Proof. destruct n. 1: reflexivity. rapply (emap (pTr 0 o loops)). apply unfold_iterated_loops'. Defined. (** Except in the lowest case, this can be expressed as an isomorphism of groups. *) Definition groupiso_pi_loops n X : Pi n.+2 X $<~> Pi n.+1 (loops X). Proof. snrapply (groupiso_pi_functor 0). apply unfold_iterated_loops'. Defined. (** Naturality of [pi_loops]. *) Definition fmap_pi_loops (n : nat) {X Y : pType} (f : X ->* Y) : (pi_loops n Y) o* (fmap (Pi n.+1) f) ==* (fmap (pPi n o loops) f) o* (pi_loops n X). Proof. destruct n; srapply phomotopy_homotopy_hset; intros x. 1: reflexivity. refine ((O_functor_compose 0 _ _ _)^ @ _ @ (O_functor_compose 0 _ _ _)). apply O_functor_homotopy. exact (pointed_htpy (unfold_iterated_fmap_loops n.+1 f)). Defined. (** Homotopy groups preserve products. This is a direct proof, but below we give a second proof whose underlying map is the natural one. *) Definition pi_prod' {n : nat} (X Y : pType) : pPi n (X * Y) <~>* (pPi n X) * (pPi n Y). Proof. (* First we re-express this in terms of the composite [pTr 0 o iterated_loops n]. *) refine (_ o*E pequiv_ppi_ptr_iterated_loops _ _). refine ((equiv_functor_pprod (pequiv_ppi_ptr_iterated_loops _ _) (pequiv_ppi_ptr_iterated_loops _ _))^-1* o*E _). (* For this composite, the proof is straightforward. *) refine (_ o*E pequiv_ptr_functor 0 _). 1: nrapply iterated_loops_prod. snrapply Build_pEquiv'; cbn. - refine (equiv_O_prod_cmp 0 _ _). - reflexivity. Defined. (** The pointed map from left-to-right below, coming from functoriality, is an equivalence. *) Definition pi_prod {n : nat} (X Y : pType) : pPi n (X * Y) <~>* (pPi n X) * (pPi n Y). Proof. snrapply Build_pEquiv. (* This describes the natural map. *) - rapply (equiv_pprod_coind (pfam_const _) (pfam_const _)); split. + exact (fmap (pPi n) (@pfst X Y)). + exact (fmap (pPi n) (@psnd X Y)). (* To see that it is an equivalence, we show that it is homotopic to [pi_prod']. *) - snrapply (isequiv_homotopic' (pi_prod' X Y)). intro xy. destruct n; strip_truncations. + apply path_prod; reflexivity. + apply path_prod. 1,2: apply (ap tr). (* Not obvious, but unfolding makes things cluttered. *) * exact (pfst_iterated_loops_prod X Y (n:=n.+1) xy). * exact (psnd_iterated_loops_prod X Y (n:=n.+1) xy). Defined. (** For positive [n], this equivalence is an isomorphism of groups. *) Lemma grp_iso_pi_prod {n : nat} (X Y : pType) : GroupIsomorphism (Pi n.+1 (X * Y)) (grp_prod (Pi n.+1 X) (Pi n.+1 Y)). Proof. snrapply Build_GroupIsomorphism. (* The underlying map is the natural one, so it is automatically a group homomorphism. *) - apply grp_prod_corec. + exact (fmap (Pi n.+1) (@pfst X Y)). + exact (fmap (Pi n.+1) (@psnd X Y)). (* This is also the underlying map of [pi_prod], so we can reuse the proof that it is an equivalence. *) - exact (equiv_isequiv (pi_prod X Y (n:=n.+1))). Defined. (** Homotopy groups of truncations *) (** An [n]-connected map induces an equivalence on the nth homotopy group. We first state this for [pTr 0 o iterated_loops n], since the proof works for general [n], and then we deduce the result for [pPi n] afterwards. *) Definition isequiv_pi_connmap' `{Univalence} (n : nat) {X Y : pType} (f : X ->* Y) `{!IsConnMap n f} : IsEquiv (fmap (pTr 0) (fmap (iterated_loops n) f)). Proof. rapply O_inverts_conn_map. rapply isconnected_iterated_fmap_loops. rewrite 2 trunc_index_inc'_succ. rewrite <- trunc_index_inc_agree. assumption. Defined. (** The same holds for [pPi n]. *) Global Instance isequiv_pi_connmap `{Univalence} (n : nat) {X Y : pType} (f : X ->* Y) `{!IsConnMap n f} : IsEquiv (fmap (pPi n) f). Proof. (* For [n = 0] and [n] a successor, [fmap (pPi n) f] is definitionally equal to the map in the previous result as a map of types. *) destruct n; rapply isequiv_pi_connmap'. Defined. Definition pequiv_pi_connmap `{Univalence} (n : nat) {X Y : pType} (f : X ->* Y) `{!IsConnMap n f} : Pi n X <~>* Pi n Y := Build_pEquiv _ _ (fmap (pPi n) f) _. (** For positive [n], it is a group isomorphism. *) Definition grp_iso_pi_connmap `{Univalence} (n : nat) {X Y : pType} (f : X ->* Y) `{!IsConnMap n.+1 f} : GroupIsomorphism (Pi n.+1 X) (Pi n.+1 Y) := Build_GroupIsomorphism _ _ (fmap (Pi n.+1) f) (isequiv_pi_connmap n.+1 f). (** As a consequence, the truncation map [ptr : X -> pTr n X] induces an equivalence on [Pi n]. We don't make this an instance, since it is found by typeclass search. *) Definition isequiv_pi_Tr `{Univalence} (n : nat) (X : pType) : IsEquiv (fmap (pPi n) ptr : Pi n X -> Pi n (pTr n X)) := _. Definition pequiv_pi_Tr `{Univalence} (n : nat) (X : pType) : Pi n X <~>* Pi n (pTr n X) := Build_pEquiv _ _ (fmap (pPi n) ptr) _. (** For positive [n], it is a group isomorphism. *) Definition grp_iso_pi_Tr `{Univalence} (n : nat) (X : pType) : GroupIsomorphism (Pi n.+1 X) (Pi n.+1 (pTr n.+1 X)) := grp_iso_pi_connmap n ptr. (** An [n]-connected map induces a surjection on [n+1]-fold loop spaces and [Pi (n+1)]. *) Definition issurj_iterated_loops_connmap `{Univalence} (n : nat) {X Y : pType} (f : X ->* Y) {C : IsConnMap n f} : IsSurjection (fmap (iterated_loops (n.+1)) f). Proof. apply isconnected_iterated_fmap_loops. cbn. rewrite trunc_index_inc'_0n; assumption. Defined. Definition issurj_pi_connmap `{Univalence} (n : nat) {X Y : pType} (f : X ->* Y) {C : IsConnMap n f} : IsConnMap (Tr (-1)) (fmap (pPi n.+1) f). Proof. rapply conn_map_O_functor_strong_leq. by apply issurj_iterated_loops_connmap. Defined. (** Pointed sections induce embeddings on homotopy groups. *) Proposition isembedding_pi_psect {n : nat} {X Y : pType} (s : X ->* Y) (r : Y ->* X) (k : r o* s ==* pmap_idmap) : IsEmbedding (fmap (pPi n) s). Proof. apply isembedding_isinj_hset. rapply (isinj_section (r:=fmap (pPi n) r)). intro x. lhs_V rapply (fmap_comp (pPi n) s r x). lhs rapply (fmap2 (pPi n) k x). exact (fmap_id (pPi n) X x). Defined. Coq-HoTT-9.0/theories/Homotopy/Hopf.v000066400000000000000000000203631474641544500174650ustar00rootroot00000000000000Require Import Types Basics Pointed Truncations. Require Import HSpace Suspension ExactSequence HomotopyGroup. Require Import WildCat.Core WildCat.Universe WildCat.Equiv Modalities.ReflectiveSubuniverse Modalities.Descent. Require Import HSet Spaces.Nat.Core. Require Import Homotopy.Join Colimits.Pushout. Local Open Scope pointed_scope. Local Open Scope trunc_scope. Local Open Scope mc_mult_scope. (** * The Hopf construction *) (** We define the Hopf construction associated to a left-invertible H-space, and use it to prove that H-spaces satisfy a strengthened version of Freudenthal's theorem (see [freudenthal_hspace] below). *) (** The Hopf construction associated to a left-invertible H-space (Definition 8.5.6 in the HoTT book). *) Definition hopf_construction `{Univalence} (X : pType) `{IsHSpace X} `{forall a, IsEquiv (a *.)} : pFam (psusp X). Proof. srapply Build_pFam. - apply (Susp_rec (Y:=Type) X X). exact (fun x => path_universe (x *.)). - simpl. exact pt. Defined. (** *** Total space of the Hopf construction *) (** The total space of the Hopf construction on [Susp X] is the join of [X] with itself. Note that we need both left and right multiplication to be equivalences. This is true when [X] is a 0-connected H-space for example. (This is lemma 8.5.7 in the HoTT book). *) Definition pequiv_hopf_total_join `{Univalence} (X : pType) `{IsHSpace X} `{forall a, IsEquiv (a *.)} `{forall a, IsEquiv (.* a)} : psigma (hopf_construction X) <~>* pjoin X X. Proof. snrapply Build_pEquiv'. { refine (_ oE equiv_pod_flatten (f := const_tt X) (g := const_tt X) (@Build_poDescent _ _ _ (const_tt X) (const_tt X) (Unit_ind (pointed_type X)) (Unit_ind (pointed_type X)) (fun x => Build_Equiv _ _ (x *.) (H1 x)))). snrapply equiv_pushout. (* The equivalence [{x : X & X} <~> X * X] that we need sends [(x; y) to (y, x*y)]. *) { cbn. refine (equiv_sigma_prod0 _ _ oE _ oE equiv_sigma_symm0 _ _). snrapply equiv_functor_sigma_id. intros x. exact (Build_Equiv _ _ (.* x) _). } 1,2: rapply (equiv_contr_sigma (Unit_ind (pointed_type X))). 1,2: reflexivity. } reflexivity. Defined. (** ** Miscellaneous lemmas and corollaries about the Hopf construction *) Lemma transport_hopf_construction `{Univalence} {X : pType} `{IsHSpace X} `{forall a, IsEquiv (a *.)} : forall x y : X, transport (hopf_construction X) (merid x) y = x * y. Proof. intros x y. transport_to_ap. refine (ap (fun z => transport idmap z y) _ @ _). 1: apply Susp_rec_beta_merid. apply transport_path_universe. Defined. (** The connecting map associated to the Hopf construction of [X] is a retraction of [loop_susp_unit X] (Proposition 2.19 in https://arxiv.org/abs/2301.02636v1). *) Proposition hopf_retraction `{Univalence} (X : pType) `{IsHSpace X} `{forall a, IsEquiv (a *.)} : connecting_map_family (hopf_construction X) o* loop_susp_unit X ==* pmap_idmap. Proof. nrapply hspace_phomotopy_from_homotopy. 1: assumption. intro x; cbn. refine (transport_pp _ _ _ _ @ _); unfold dpoint. apply moveR_transport_V. refine (transport_hopf_construction _ _ @ _ @ (transport_hopf_construction _ _)^). exact (right_identity _ @ (left_identity _)^). Defined. (** It follows from [hopf_retraction] and Freudenthal's theorem that [loop_susp_unit] induces an equivalence on [Pi (2n+1)] for [n]-connected H-spaces (with n >= 0). Note that [X] is automatically left-invertible. *) Proposition isequiv_Pi_connected_hspace `{Univalence} {n : nat} (X : pType) `{IsConnected n X} `{IsHSpace X} : IsEquiv (fmap (pPi (n + n).+1) (loop_susp_unit X)). Proof. nrapply isequiv_surj_emb. - apply issurj_pi_connmap. destruct n. + by apply (conn_map_loop_susp_unit (-1)). + rewrite <- trunc_index_add_nat_add. by apply (conn_map_loop_susp_unit). - pose (is0connected_isconnected n.-2 _). nrapply isembedding_pi_psect. apply hopf_retraction. Defined. (** By Freudenthal, [loop_susp_unit] induces an equivalence on lower homotopy groups as well, so it is a (2n+1)-equivalence. We formalize it below with [m = n-1], and allow [n] to start at [-1]. We prove it using a more general result about reflective subuniverses, [OO_inverts_conn_map_factor_conn_map], but one could also use homotopy groups and the truncated Whitehead theorem. *) Definition freudenthal_hspace' `{Univalence} {m : trunc_index} (X : pType) `{IsConnected m.+1 X} `{IsHSpace X} `{forall a, IsEquiv (a *.)} : O_inverts (Tr (m +2+ m).+1) (loop_susp_unit X). Proof. set (r:=connecting_map_family (hopf_construction X)). nrapply (OO_inverts_conn_map_factor_conn_map _ (m +2+ m) _ r). 2, 4: exact _. 1: apply O_lex_leq_Tr. rapply (conn_map_homotopic _ equiv_idmap (r o loop_susp_unit X)). symmetry. nrapply hopf_retraction. Defined. (** Note that we don't really need the assumption that [X] is left-invertible in the previous result; for [m >= -1], it follows from connectivity. And for [m = -2], the conclusion is trivial. Here we state the version for [m >= -1] without left-invertibility. *) Definition freudenthal_hspace `{Univalence} {m : trunc_index} (X : pType) `{IsConnected m.+2 X} `{IsHSpace X} : O_inverts (Tr (m.+1 +2+ m.+1).+1) (loop_susp_unit X). Proof. pose (is0connected_isconnected m _). exact (freudenthal_hspace' (m:=m.+1) X). Defined. (** Here we give a generalization of a result from Eilenberg-MacLane Spaces in Homotopy Type Theory, Dan Licata and Eric Finster. Their version corresponds to [m = -2] in our version. Their encode-decode proof was formalized in this library in EMSpace.v until this shorter and more general approach was found. *) Definition licata_finster `{Univalence} {m : trunc_index} (X : pType) `{IsConnected m.+2 X} (k := (m.+1 +2+ m.+1).+1) `{IsHSpace X} `{IsTrunc k X} : X <~>* pTr k (loops (psusp X)). Proof. refine (_ o*E pequiv_ptr (n:=k)). nrefine (pequiv_O_inverts k (loop_susp_unit X)). rapply freudenthal_hspace. Defined. (** Since [loops X] is an H-space, the Hopf construction provides a map [Join (loops X) (loops X) -> Susp (loops X)]. We show that this map is equivalent to the fiber of [loop_susp_counit X : Susp (loops X) -> X] over the base point, up to the automorphism of [Susp (loops X)] induced by inverting loops. *) Definition pequiv_pfiber_loops_susp_counit_join `{Univalence} (X : pType) : pfiber (loop_susp_counit X) <~>* pjoin (loops X) (loops X). Proof. snrefine (pequiv_hopf_total_join (loops X) o*E _). 2: rapply ishspace_loops. 2,3: exact _. snrapply Build_pEquiv'. { snrapply equiv_functor_sigma'. 1: exact (emap psusp (equiv_path_inverse _ _)). snrapply Susp_ind; hnf. 1,2: reflexivity. intros p. nrapply path_equiv. funext q. simpl. lhs rapply (transport_equiv (merid p) _ q). simpl. lhs nrapply ap. { lhs nrapply transport_paths_Fl. nrapply whiskerR. { lhs nrapply (ap inverse (ap_V _ _)). lhs rapply inv_V. apply Susp_rec_beta_merid. } } lhs nrapply (transport_idmap_ap _ (merid p)). lhs nrapply (transport2 idmap). { lhs nrapply ap_compose. lhs nrapply ap. 1: apply functor_susp_beta_merid. apply Susp_rec_beta_merid. } lhs nrapply transport_path_universe. apply concat_V_pp. } reflexivity. Defined. (** As a corollary we get 2n-connectivity of [loop_susp_counit X] for an n-connected [X]. *) Global Instance conn_map_loop_susp_counit `{Univalence} {n : trunc_index} (X : pType) `{IsConnected n.+1 X} : IsConnMap (n +2+ n) (loop_susp_counit X). Proof. destruct n. - intro x; hnf; exact _. - snrapply (conn_point_elim (-1)). + exact (isconnected_pred_add' n 0 _). + exact _. + nrapply (isconnected_equiv' _ _ (pequiv_pfiber_loops_susp_counit_join X)^-1). nrapply isconnected_join; exact _. Defined. (** In particular, we get the following result. All we are really using is that [n.+2 <= n +2+ n], but because of the use of [isconnmap_pred_add], the proof is a bit more specific to this case. *) Definition pequiv_ptr_psusp_loops `{Univalence} (X : pType) (n : nat) `{IsConnected n.+1 X} : pTr n.+2 (psusp (loops X)) <~>* pTr n.+2 X. Proof. snrapply Build_pEquiv. 1: rapply (fmap (pTr _) (loop_susp_counit _)). nrapply O_inverts_conn_map. nrapply (isconnmap_pred_add n.-2). rewrite 2 trunc_index_add_succ. rapply (conn_map_loop_susp_counit X). Defined. Coq-HoTT-9.0/theories/Homotopy/IdentitySystems.v000066400000000000000000000262251474641544500217550ustar00rootroot00000000000000Require Import Basics. Require Import Types.Sigma Types.Equiv Types.Paths. Require Import HoTT.Tactics. (** * Characterization of identity types by identity systems *) (** See Homotopy/EncodeDecode.v for a related characterization of identity types. *) (** To avoid dependencies coming from Pointed.Core, we will write out some of the definitions found there. Let [A : Type], together with a distinguished base point [a0 : A]. A pointed type family is a type family [R : A -> Type], together with a distinguished point [r0 : R a0]. A pointed type family [(R; r0)] is called an identity system if it satisfies the J-rule. Given a pointed type family [(R; r0)], the fundamental theorem of identity systems (Theorem 5.8.2 from the HoTT Book) tells us that the following are equivalent: (i) an identity system structure on [(R; r0)], (ii) homotopy contractibility of the space of pointed type family maps from [(R; r0)] to any pointed type family [(S; s0)], (iii) transport along [R] being an equivalence, and (iv) the total space of [R] being contractible. *) Class IsIdentitySystem {A : Type} {a0 : A} (R : A -> Type) (r0 : R a0) := { idsys_ind (D : forall a : A, R a -> Type) (d : D a0 r0) (a : A) (r : R a) : D a r; idsys_ind_beta (D : forall a : A, R a -> Type) (d : D a0 r0) : idsys_ind D d a0 r0 = d }. (** The mapping space between two pointed type families over the same pointed type is a family of maps that preserves the distinguished points. *) Definition pfamMap {A : Type} {a0 : A} (R S : A -> Type) (r0 : R a0) (s0 : S a0) := {f : forall a : A, R a -> S a & f a0 r0 = s0}. (** A pointed homotopy between maps of pointed type families is a family of homotopies that is pointed in the fiber over [a0]. *) Definition pfammap_homotopy {A : Type} {a0 : A} {R S : A -> Type} {r0 : R a0} {s0 : S a0} (f g : pfamMap R S r0 s0) := { p : forall a : A, pr1 f a == pr1 g a & p a0 r0 = pr2 f @ (pr2 g)^}. Global Instance reflexive_pfammap_homotopy {A : Type} {a0 : A} {R S : A -> Type} {r0 : R a0} {s0 : S a0} : Reflexive (pfammap_homotopy (r0:=r0) (s0:=s0)). Proof. intro g. snrefine (_;_). - exact (fun _ _ => idpath). - cbn; symmetry. exact (concat_pV _). Defined. (** We weaken part (ii) of Theorem 5.8.2. Instead of requiring that the mapping space is contractible, we will only require it to be homotopy contractible, i.e. it is inhabited and there is a homotopy between every map and the chosen map. This allows us to avoid function extensionality. Given that a pointed type family [(R; r0)] is an identity system, then the mapping space of pointed type families from [(R; r0)] to any [(S; s0)] is homotopy contractible. This is a weak form of Theorem 5.8.2, (i) implies (ii). *) Definition homocontr_pfammap_identitysystem {A : Type} {a0 : A} (R : A -> Type) (r0 : R a0) `{!IsIdentitySystem R r0} (S : A -> Type) (s0 : S a0) : exists f : pfamMap R S r0 s0, forall g, pfammap_homotopy f g. Proof. pose (to_S := idsys_ind (fun a _ => S a) s0). pose proof (to_S_beta := idsys_ind_beta (fun a _ => S a) s0). snrefine ((to_S; to_S_beta); _). intro g. exists (idsys_ind (fun a r => to_S a r = pr1 g a r) (to_S_beta @ (pr2 g)^)). snrapply idsys_ind_beta. Defined. (** If a pointed type family [(R; r0)] has homotopy contractible mapping spaces in the sense above, then [fun p => transport R p r0] is a fiberwise equivalence. This is a strong form of Theorem 5.8.2, (ii) implies (iii). *) Definition equiv_path_homocontr_pfammap {A : Type} {a0 : A} (R : A -> Type) (r0 : R a0) (H : forall S : A -> Type, forall s0 : S a0, exists f : pfamMap R S r0 s0, forall g, pfammap_homotopy f g) (a : A) : IsEquiv (fun p : a0 = a => transport R p r0). Proof. pose (inv := (H (fun a => a0 = a) 1).1.1). pose proof (inv_beta := (H (fun a => a0 = a) 1).1.2); cbn in inv_beta. snrapply (isequiv_adjointify _ (inv a)); cbn. - destruct (H R r0) as [[f fp] h]. pose proof (h' := fun g => (h g).1 a); cbn in h'; clear h fp. (* Both sides are the underlying maps of [pfammap]s, so [h'] says that both are homotopic to [f a]. *) transitivity (f a). + symmetry. nrefine (h' (fun _ _ => transport R (inv _ _) r0; _)). exact (ap (fun x => transport R x r0) inv_beta). + exact (h' (_; idpath)). - by intros []. Defined. (** Given that some type family [R] is fiberwise equivalent to identity types based at [a0], then the total space [sig R] is contractible. This is a stronger form of Theorem 5.8.2, (iii) implies (iv). *) Definition contr_sigma_equiv_path {A : Type} {a0 : A} (R : A -> Type) (f : forall a, (a0 = a) <~> R a) : Contr (sig R). Proof. rapply contr_equiv'. 1: exact (equiv_functor_sigma_id f). apply contr_basedpaths. Defined. (** Any pointed type family [(R; r0)] with contractible total space is an identity system. This is Theorem 5.8.2, (iv) implies (i). *) Definition identitysystem_contr_sigma {A : Type} {a0 : A} (R : A -> Type) (r0 : R a0) {C : Contr (sig R)} : IsIdentitySystem R r0. Proof. snrapply Build_IsIdentitySystem. - intros D d0 a r. exact (transport (fun ar : sig R => D (pr1 ar) (pr2 ar)) (path_contr (a0; r0) (a; r)) d0). - intros D d0; cbn; unfold path_contr. nrapply (transport2 _ (concat_Vp _)). Defined. (** Assuming function extensionality, pointed homotopy contractible fiberwise mapping spaces of pointed type families are contractible. We thus obtain the proper statement of Theorem 5.8.2. *) Definition contr_pfammap_homocontr `{Funext} {A : Type} {a0 : A} (R : A -> Type) (r0 : R a0) (S : A -> Type) (s0 : S a0) (fH : exists f : pfamMap R S r0 s0, forall g, pfammap_homotopy f g) : Contr (pfamMap R S r0 s0). Proof. snrapply Build_Contr. - exact fH.1. - intro g. snrapply path_sigma; cbn. + funext a. nrapply path_forall. exact ((fH.2 g).1 a). + transport_path_forall_hammer. lhs nrapply transport_paths_l. nrapply moveR_Vp. nrapply moveL_pM. symmetry. exact (fH.2 g).2. Defined. (** The fiberwise mapping spaces of pointed type families are pointed homotopy contractible if they are contractible. *) Definition homocontr_pfammap_contr {A : Type} {a0 : A} (R : A -> Type) (r0 : R a0) (S : A -> Type) (s0 : S a0) (cp : Contr (pfamMap R S r0 s0)) : exists f : pfamMap R S r0 s0, forall g, pfammap_homotopy f g. Proof. snrefine (_;_). - exact (@center _ cp). - intro g. by destruct (@contr _ cp g). Defined. (** The fundamental theorem of identity systems is now proven. It is useful to write down some of the composite implications. Given an identity system [(R; r0)], transporting the point [r0] induces a fiberwise equivalence between the based path type [a0 = x] and [R x]. This is Theorem 5.8.2 (i) implies (iii). *) Global Instance isequiv_transport_identitysystem {A : Type} {a0 : A} (R : A -> Type) (r0 : R a0) `{!IsIdentitySystem _ r0} (a : A) : IsEquiv (fun p : a0 = a => transport R p r0). Proof. nrapply equiv_path_homocontr_pfammap. by nrapply homocontr_pfammap_identitysystem. Defined. Definition equiv_transport_identitysystem {A : Type} {a0 : A} (R : A -> Type) (r0 : R a0) `{!IsIdentitySystem _ r0} (a : A) : (a0 = a) <~> R a := Build_Equiv _ _ (fun p => transport R p r0) _. (** A more general version of Theorem 5.8.2 (iii) implies (i) is proven in Basics/Equivalences.v as [equiv_path_ind]. The original statement is recovered if [e] is assumed to be [fun p => transport R p r0]. *) (** Theorem 5.8.2, (iv) implies (iii), can be proven with a nice method due to Rijke. *) Definition equiv_path_from_contr {A : Type} (a : A) (P : A -> Type) (Prefl : P a) (cp : Contr {y:A & P y} ) (b : A) : P b <~> a = b. Proof. apply equiv_inverse. srefine (Build_Equiv _ _ _ _). { intros []; apply Prefl. } revert b; apply isequiv_from_functor_sigma. rapply isequiv_contr_contr. Defined. (** This is another result for characterizing the path types of [A] when given an equivalence [e : B <~> A], such as an [issig] lemma for [A]. It can help Coq to deduce the type family [P] if [revert] is used to move [a0] and [a1] into the goal, if needed. *) Definition equiv_path_along_equiv {A B : Type} {P : A -> A -> Type} (e : B <~> A) (K : forall b0 b1 : B, P (e b0) (e b1) <~> b0 = b1) : forall a0 a1 : A, P a0 a1 <~> a0 = a1. Proof. equiv_intros e b0 b1. nrefine (_ oE K b0 b1). apply equiv_ap'. Defined. (** This simply combines the two previous results, a common idiom. Again, it can help Coq to deduce the type family [P] if [revert] is used to move [a0] and [a1] into the goal, if needed. *) Definition equiv_path_issig_contr {A B : Type} {P : A -> A -> Type} (e : B <~> A) (Prefl : forall b, P (e b) (e b)) (cp : forall b1, Contr {b2 : B & P (e b1) (e b2)}) : forall a0 a1 : A, P a0 a1 <~> a0 = a1. Proof. apply (equiv_path_along_equiv e). intro a0. srapply equiv_path_from_contr. apply Prefl. Defined. (** After [equiv_path_issig_contr], we are left showing the contractibility of a sigma-type whose base and fibers are large nested sigma-types of the same depth. Moreover, we expect that the types appearing in those two large nested sigma-types "pair up" to form contractible based "path-types". The following lemma "peels off" the first such pair, whose contractibility can often be found with typeclass search. The remaining contractibility goal is then simplified by substituting the center of contraction of that first based "path-type", or more precisely a *specific* center that may or may not be the one given by the contractibility instance; the latter freedom sometimes makes things faster and simpler. *) Definition contr_sigma_sigma (A : Type) (B : A -> Type) (C : A -> Type) (D : forall a, B a -> C a -> Type) {cac : Contr {x:A & C x} } (a : A) (c : C a) {ccd : Contr {y:B a & D a y c } } : Contr {ab : {x:A & B x} & {y:C ab.1 & D ab.1 ab.2 y} }. Proof. pose (d := (center {y:B a & D a y c}).2). set (b := (center {y:B a & D a y c}).1) in *. apply (Build_Contr _ ((a;b);(c;d))). intros [[a' b'] [c' d']]; cbn in *. pose (ac' := (a';c')). pose (bd' := (b';d') : {y:B ac'.1 & D ac'.1 y ac'.2}). change (((a;b);(c;d)) = ((ac'.1;bd'.1);(ac'.2;bd'.2)) :> {ab : {x:A & B x} & {y:C ab.1 & D ab.1 ab.2 y} }). clearbody ac' bd'; clear a' b' c' d'. destruct (@path_contr {x:A & C x} _ (a;c) ac'). destruct (@path_contr {y:B a & D a y c} _ (b;d) bd'). reflexivity. Defined. (** This tactic just applies the previous lemma, using a match to figure out the appropriate type families so the user doesn't have to specify them. *) Ltac contr_sigsig a c := match goal with | [ |- Contr (@sig (@sig ?A ?B) (fun ab => @sig (@?C ab) (@?D ab))) ] => (* The lemma only applies when C depends only on the first component of ab, so we need to factor it somehow through pr1. *) let C' := fresh in transparent assert (C' : {C' : A -> Type & forall ab, C' ab.1 = C ab}); [ eexists; intros ab; reflexivity | nrefine (contr_sigma_sigma A B C'.1 (fun a b => D (a;b)) a c); (** In practice, usually the first [Contr] hypothesis can be found by typeclass search, so we try that. But we don't try on the second one, since often it can't be, and trying can be slow. *) [ try exact _ | subst C' ] ] end. (** For examples of the use of this tactic, see for instance [Factorization] and [Idempotents]. *) Coq-HoTT-9.0/theories/Homotopy/InjectiveTypes/000077500000000000000000000000001474641544500213435ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Homotopy/InjectiveTypes/InjectiveSigma.v000066400000000000000000000173141474641544500244410ustar00rootroot00000000000000(** * Injectivity of Sigma types *) (** Here we characterize the condition for which a sigma type over an injective type is itself injective, and we also provide some examples. Many proofs guided by original Agda formalization in the Type Topology Library which can be found at: https://martinescardo.github.io/TypeTopology/InjectiveTypes.Sigma and InjectiveTypes.MathematicalStructuresMoreGeneral. *) Require Import Basics. Require Import Types.Forall Types.Sigma Types.Universe. Require Import Modalities.ReflectiveSubuniverse. Require Import Truncations.Core. Require Import InjectiveTypes.InjectiveTypes InjectiveTypes.TypeFamKanExt. Section AlgFlabSigma. Context {X : Type} (A : X -> Type) (Xaf : IsAlgebraicFlabbyType X). (** The condition for a sigma type over an algebraically flabby type to be algebraically flabby can be described as the existence of a section to the following map for every [P] and [f]. *) Definition alg_flab_map (P : HProp) (f : P -> X) : (A (center_af f)) -> (forall h, A (f h)) := fun a h => contr_af f h # a. (** Here is the condition. (It would in fact be enough to assume that [s] is section up to homotopies in its domain.) *) Definition alg_flab_sigma_condition := forall P f, {s : _ & alg_flab_map P f o s == idmap}. (** A sigma type over an algebraically flabby type is also algebraically flabby, and thus algebraically injective, when the above condition holds. *) Definition alg_flab_sigma (cond : alg_flab_sigma_condition) : IsAlgebraicFlabbyType {x : X & A x}. Proof. snrapply Build_IsAlgebraicFlabbyType; intros P f. all: pose (C := cond P (pr1 o f)). - (* We need to give a point in [{x : X * A x}]. Since [X] is algebraically flabby, we get a point in [X]: *) exists (center_af (pr1 o f)). (* For the point in [A (above)], we use the section component of [cond P (pr1 o f)]: *) exact (C.1 (pr2 o f)). - intros h; cbn. change (cond P (fun x : P => (f x).1)) with C. (* We need to show that the point we gave is equal to [f h]. *) snrapply path_sigma; cbn. + nrapply contr_af. + exact (apD10 (C.2 (pr2 o f)) h). Defined. Definition alg_inj_sigma (cond : alg_flab_sigma_condition) : IsAlgebraicInjectiveType {x : X & A x} := alg_inj_alg_flab (alg_flab_sigma cond). End AlgFlabSigma. (** Taking our algebraically flabby type [X] to be [Type], we introduce our primary examples (the types of pointed types, monoids, etc.), and give a few simplifying lemmas. *) Section AlgFlabUniverse. (** [T] is a version of transport in the type family [A]. It could be defined to be transport combined with univalence, but we allow the user to choose different "implementations" of transport that might be more convenient. *) Context (A : Type -> Type) (T : forall {X Y}, X <~> Y -> A X -> A Y) (Trefl : forall X, (T (equiv_idmap X) == idmap)). Arguments T {X Y} _ _. (* This is needed, despite the braces above. *) (** When studying the sigma type [{X : Type & A X}], the map [alg_flab_map] can be exchanged for either of these simpler maps. This first one will turn out to be homotopic to [alg_flab_map] when [Type] is given its "forall" flabiness structure. *) Definition alg_flab_map_forall `{Funext} (P : HProp) (f : P -> Type) : A (forall h, f h) -> (forall h, A (f h)). Proof. intros a h. srefine (T _ a). apply (@equiv_contr_forall _ _ (contr_inhabited_hprop _ _)). Defined. (** And this one is homotopic to [alg_flab_map] when [Type] is given its "sigma" flabiness structure. *) Definition alg_flab_map_sigma (P : HProp) (f : P -> Type) : A {h : P & f h} -> (forall h, A (f h)). Proof. intros a h. srefine (T _ a). apply (@equiv_contr_sigma _ _ (contr_inhabited_hprop _ _)). Defined. (** The following conditions can be thought of as closure conditions under pi or sigma types for the type family [A]. *) Definition alg_flab_sigma_condition_forall `{Funext} := forall P f, {s : _ & alg_flab_map_forall P f o s == idmap}. Definition alg_flab_sigma_condition_sigma := forall P f, {s : _ & alg_flab_map_sigma P f o s == idmap}. Definition homotopic_alg_flab_map_alg_flab_map_forall `{Univalence} (P : HProp) (f : P -> Type) : alg_flab_map_forall P f == alg_flab_map A alg_flab_Type_forall P f. Proof. intros a. funext h. srefine (homotopic_trequiv A (@T) (@univalent_transport H A) Trefl _ _ a). apply univalent_transport_idequiv. Defined. Definition homotopic_alg_flab_map_alg_flab_map_sigma `{Univalence} (P : HProp) (f : P -> Type) : alg_flab_map_sigma P f == alg_flab_map A alg_flab_Type_sigma P f. Proof. intros s. funext h. srefine (homotopic_trequiv A (@T) (@univalent_transport H A) Trefl _ _ s). apply univalent_transport_idequiv. Defined. (** The original [sigma_condition] is implied by our reformulated conditions [alg_flab_sigma_condition_forall] and [alg_flab_sigma_condition_sigma]. *) Definition sigma_condition_sigma_condition_forall `{Univalence} (condf : alg_flab_sigma_condition_forall) : alg_flab_sigma_condition A _. Proof. intros P f. destruct (condf _ f) as [s J]. exists s. intro g. lhs_V nrapply (homotopic_alg_flab_map_alg_flab_map_forall P f (s g)). apply J. Defined. Definition alg_flab_sigma_forall `{Univalence} (condf : alg_flab_sigma_condition_forall) : IsAlgebraicFlabbyType {X : Type & A X}. Proof. nrapply alg_flab_sigma. exact (sigma_condition_sigma_condition_forall condf). Defined. Definition sigma_condition_sigma_condition_sigma `{Univalence} (condf : alg_flab_sigma_condition_sigma) : alg_flab_sigma_condition A alg_flab_Type_sigma. Proof. intros P f. destruct (condf _ f) as [s J]. exists s. intro g. lhs_V nrapply (homotopic_alg_flab_map_alg_flab_map_sigma P f (s g)). apply J. Defined. Definition alg_flab_sigma_sigma `{Univalence} (conds : alg_flab_sigma_condition_sigma) : IsAlgebraicFlabbyType {X : Type & A X}. Proof. nrapply alg_flab_sigma. exact (sigma_condition_sigma_condition_sigma conds). Defined. End AlgFlabUniverse. (** The type of pointed types is algebraically flabby. *) Definition alg_flab_pType `{Univalence} : IsAlgebraicFlabbyType {X : Type & X}. Proof. rapply (alg_flab_sigma_forall _ (@equiv_fun)). - reflexivity. - intros P f. exists idmap. reflexivity. Defined. (** The following results are adapted from section 7 of Injective Types in Univalent Mathematics by Martin Escardo, using the above results. *) (** For a subuniverse, the flabbiness condition is equivalent to closure under proposition indexed pi types (or sigma types), so using this we can state a simpler theorem for proving flabbiness of subuniverses. *) Definition alg_flab_subuniverse_forall `{Univalence} (O : Subuniverse) (condForall : forall (P : HProp) A, (forall h : P, In O (A h)) -> In O (forall h : P, A h)) : IsAlgebraicFlabbyType@{u su} (Type_ O). Proof. rapply (alg_flab_sigma_forall _ (fun X Y f H => @inO_equiv_inO' O X Y H f)). - intros X A. apply path_ishprop. - intros P A. exists _. intros s. apply path_ishprop. Defined. Definition alg_flab_subuniverse_sigma `{Univalence} (O : Subuniverse) (condSigma : forall (P : HProp) A, (forall h : P, In O (A h)) -> In O {h : P & A h}) : IsAlgebraicFlabbyType@{u su} (Type_ O). Proof. rapply (alg_flab_sigma_sigma _ (fun X Y f H => @inO_equiv_inO' O X Y H f)). - intros X A. apply path_ishprop. - intros P A. exists _. intros s. apply path_ishprop. Defined. (** As an immediate corollary, we get that reflective subuniverses are algebraically flabby. *) Definition alg_flab_reflective_subuniverse `{Univalence} (O : ReflectiveSubuniverse) : IsAlgebraicFlabbyType@{u su} (Type_ O) := alg_flab_subuniverse_forall _ _. Coq-HoTT-9.0/theories/Homotopy/InjectiveTypes/InjectiveTypes.v000066400000000000000000000435611474641544500245100ustar00rootroot00000000000000(** * Injective Types *) (** Formalization of the paper: Injective Types in Univalent Mathematics by Martin Escardo (with some extra results). *) Require Import Basics Types. Require Import Truncations.Core. Require Import Modalities.Modality. Require Import HFiber. Require Import Universes.HProp. Require Import Constant. Require Import ExcludedMiddle. Require Import InjectiveTypes.TypeFamKanExt. (** ** Definitions of injectivity and first examples *) (** Since the universe levels are important to many of the results here, we keep track of them explicitly as much as possible. Due to our inability to use the max and successor operations within proofs, we instead construct these universes and their associated posetal relations in the arguments of the functions. In universe declarations, we use [u], [v], [w], etc. as our typical universe variables. Our convention for the max of two universes [u] and [v] is [uv], and the successor of a universe [u] is [su]. Occasionally we write [T] for a top universe which is strictly larger than all other provided universes. We hope that later versions of Coq will allow us access to the max and successor operations and much of the cumbersome universe handing here can be greatly reduced. *) Section UniverseStructure. Universes u v w uv uw vw. Constraint u <= uv, v <= uv, u <= uw, w <= uw, v <= vw, w <= vw. (** A type [D] is said to be injective if for every embedding [j : X -> Y] and every function [f : X -> D], there merely exists a [f' : Y -> D] such that [f' o j == f]. *) Definition IsInjectiveType@{uvw | uv <= uvw, uw <= uvw, vw <= uvw} (D : Type@{w}) := forall (X : Type@{u}) (Y : Type@{v}) (j : X -> Y) (isem : IsEmbedding@{u v uv} j) (f : X -> D), merely@{uvw} (sig@{vw uw} (fun f' => f' o j == f)). (** A type is then algebraically injective if the same is true, but without the propositional truncation. We use a class here instead of just a sigma type to make proofs more readable. *) Class IsAlgebraicInjectiveType@{} (D : Type@{w}) := { lift_ai {X : Type@{u}} {Y : Type@{v}} (j : X -> Y) {isem : IsEmbedding@{u v uv} j} (f : X -> D) : Y -> D; is_ext_ai {X : Type@{u}} {Y : Type@{v}} (j : X -> Y) {isem} f : lift_ai j f o j == f; }. (** Contractible types are algebraically injective. *) Global Instance alg_inj_contr@{} (D : Type@{w}) (cD : Contr D) : IsAlgebraicInjectiveType@{} D. Proof. snrapply Build_IsAlgebraicInjectiveType; intros X Y j isem f. - exact (const (center D)). - intros x. exact (contr _). Defined. (** [Empty] is not algebraically injective. *) Definition not_alg_inj_empty@{} : IsAlgebraicInjectiveType@{} Empty -> Empty. Proof. intros Eai. refine (lift_ai (Empty_rec@{v}) idmap tt). apply istruncmap_mapinO_tr. rapply mapinO_between_inO@{uv u v uv}. Defined. End UniverseStructure. (** [Type@{uv}] is algebraically [u],[v]-injective in at least two ways. *) Definition alg_inj_Type_sigma@{u v uv suv | u <= uv, v <= uv, uv < suv} `{Univalence} : IsAlgebraicInjectiveType@{u v suv uv suv suv} Type@{uv}. Proof. snrapply Build_IsAlgebraicInjectiveType; intros X Y j isem f. - exact (f <| j). - intros x. rapply isext_leftkanfam. Defined. Global Instance alg_inj_Type_forall@{u v uv suv | u <= uv, v <= uv, uv < suv} `{Univalence} : IsAlgebraicInjectiveType@{u v suv uv suv suv} Type@{uv}. Proof. snrapply Build_IsAlgebraicInjectiveType; intros X Y j isem f. - exact (f |> j). - intros x. rapply isext_rightkanfam. Defined. (** ** Constructions with algebraically injective types *) (** Retracts of algebraically injective types are algebraically injective. *) Definition alg_inj_retract @{u v w w' uv uw vw uw' vw' | u <= uv, v <= uv, u <= uw, w <= uw, v <= vw, w <= vw, u <= uw', v <= vw', w' <= uw', w' <= vw'} {D' : Type@{w'}} {D : Type@{w}} (r : D -> D') {s : D' -> D} (retr : r o s == idmap) (Dai : IsAlgebraicInjectiveType@{u v w uv uw vw} D) : IsAlgebraicInjectiveType@{u v w' uv uw' vw'} D'. Proof. snrapply Build_IsAlgebraicInjectiveType; intros X Y j isem f. - exact (r o lift_ai _ (s o f)). - intros x. rhs_V apply (retr (f x)). exact (ap r (is_ext_ai _ (s o f) x)). Defined. Section UniverseStructure. Universes u v w t uv uw vw tw utw vtw. Constraint u <= uv, u <= uw, v <= vw, v <= uv, w <= uw, w <= vw, w <= tw, t <= tw, uw <= utw, vw <= vtw, tw <= utw, tw <= vtw. (** Dependent products are algebraically injective when all their factors are. *) Global Instance alg_inj_forall@{} `{Funext} {A : Type@{t}} (D : A -> Type@{w}) (Dai : forall a, IsAlgebraicInjectiveType@{u v w uv uw vw} (D a)) : IsAlgebraicInjectiveType@{u v tw uv utw vtw} (forall a, D a). Proof. snrapply Build_IsAlgebraicInjectiveType; intros X Y j isem f. - exact (fun y a => lift_ai _ (fun x => f x a) y). - intros x. funext a. exact (is_ext_ai _ (fun x => f x a) x). Defined. (** In particular, exponentials of algebraically injective types are algebraically injective. *) Definition alg_inj_arrow@{} `{Funext} {A : Type@{t}} {D : Type@{w}} (Dai : IsAlgebraicInjectiveType@{u v w uv uw vw} D) : IsAlgebraicInjectiveType@{u v tw uv utw vtw} (A -> D) := _. End UniverseStructure. (** Algebraically injective types are retracts of any type that they embed into. *) Definition retract_alg_inj_embedding@{v w vw | v <= vw, w <= vw} (D : Type@{w}) {Y : Type@{v}} (j : D -> Y) (isem : IsEmbedding j) (Dai : IsAlgebraicInjectiveType@{w v w vw w vw} D) : { r : Y -> D & r o j == idmap } := (lift_ai _ idmap; is_ext_ai _ idmap). (** Any algebraically [u],[su]-injective type [X : Type@{u}], is a retract of [X -> Type@{u}]. *) Definition retract_power_universe_alg_usuinj@{u su | u < su} `{Univalence} (D : Type@{u}) (Dai : IsAlgebraicInjectiveType@{u su u su u su} D) : { r : (D -> Type@{u}) -> D & r o (@paths D) == idmap } := retract_alg_inj_embedding D (@paths D) isembedding_paths Dai. (** ** Algebraic flabbiness and resizing constructions *) (** If [D : Type@{u}] is algebraically [u],[su]-injective, then it is algebraically [u],[u]-injective. *) Definition alg_uuinj_alg_usu_inj @{u w su uw suw | u < su, u <= uw, w <= uw, su <= suw, w <= suw} (D : Type@{w}) (Dai : IsAlgebraicInjectiveType@{u su w su uw suw} D) : IsAlgebraicInjectiveType@{u u w u uw uw} D. Proof. snrapply Build_IsAlgebraicInjectiveType. - exact (@lift_ai D Dai). - exact (@is_ext_ai D Dai). Defined. (** Note that this proof is easy because of cumulativity of [Type] (which is not assumed in the original paper). *) (** Algebraic flabbiness is a variant of algebraic injectivity, but only ranging over embeddings of propositions into the unit type. *) Class IsAlgebraicFlabbyType@{u w} (D : Type@{w}) := { center_af {P : HProp@{u}} (f : P -> D) : D; contr_af {P : HProp@{u}} (f : P -> D) (p : P) : center_af f = f p; }. (** Algebraic flabbiness of a type [D] is equivalent to the statement that all conditionally constant functions [X -> D] are constant. First we give the condition, and then the two implications. *) Definition cconst_is_const_cond@{u w uw | u <= uw, w <= uw} (D : Type@{w}) := forall (X : Type@{u}) (f : X -> D), ConditionallyConstant@{u w uw} f -> sig@{uw uw} (fun d => forall x, d = f x). Definition alg_flab_cconst_is_const@{u w uw | u <= uw, w <= uw} (D : Type@{w}) (ccond : cconst_is_const_cond@{u w uw} D) : IsAlgebraicFlabbyType@{u w} D. Proof. snrapply Build_IsAlgebraicFlabbyType; intros P f. - apply (ccond P f). apply (cconst_factors_hprop _ _ idmap f). reflexivity. - apply (ccond P f). Defined. Definition cconst_is_const_alg_flab@{u w uw | u <= uw, w <= uw} (D : Type@{w}) (Daf : IsAlgebraicFlabbyType@{u w} D) : cconst_is_const_cond@{u w uw} D. Proof. intros X f [f' e]. srefine (center_af f'; _). intros x. exact (contr_af f' (tr x) @ e x). Defined. (** Algebraic flabbiness is equivalent to algebraic injectivity, with appropriate choices of universes. *) Section UniverseStructure. Universes u v w uv uw vw. Constraint u <= uv, v <= uv, u <= uw, w <= uw, v <= vw, w <= vw. (** Algebraically [u],[v]-injective types are algebraically [u]-flabby. *) Definition alg_flab_alg_inj@{} {D : Type@{w}} (Dai : IsAlgebraicInjectiveType@{u v w uv uw vw} D) : IsAlgebraicFlabbyType@{u w} D. Proof. snrapply Build_IsAlgebraicFlabbyType; intros P f. - srapply (lift_ai _ f tt). - apply is_ext_ai. Defined. (** Algebraically [uv]-flabby types are algebraically [u],[v]-injective. *) Definition alg_inj_alg_flab@{} {D : Type@{w}} (Daf : IsAlgebraicFlabbyType@{uv w} D) : IsAlgebraicInjectiveType@{u v w uv uw vw} D. Proof. snrapply Build_IsAlgebraicInjectiveType; intros X Y j isem f. - intros y. exact (center_af (fun x : Build_HProp (hfiber j y) => f x.1)). - intros x. exact (contr_af _ (x; idpath (j x))). Defined. End UniverseStructure. (** By combining the above, we see that if [D] is algebraically [ut],[v]-injective, then it is algebraically [u],[t]-injective. *) Definition resize_alg_inj @{u v w t ut uw vw tw uvt utw | u <= ut, u <= uw, v <= vw, v <= uvt, w <= uw, w <= vw, w <= tw, t <= ut, t <= tw, ut <= uvt, ut <= utw, uw <= utw, tw <= utw} {D : Type@{w}} (Dai : IsAlgebraicInjectiveType@{ut v w uvt utw vw} D) : IsAlgebraicInjectiveType@{u t w ut uw tw} D. Proof. apply alg_inj_alg_flab. exact (alg_flab_alg_inj Dai). Defined. (** We include two direct proofs of the algebraic flabbiness of [Type], instead of combining [alg_inj_alg_flab] with the previous proofs of algebraic injectivity, for better computations later. *) Definition alg_flab_Type_sigma@{u su | u < su} `{Univalence} : IsAlgebraicFlabbyType@{u su} Type@{u}. Proof. snrapply Build_IsAlgebraicFlabbyType; intros P A. - exact (sig@{u u} (fun p => A p)). - intros p. apply path_universe_uncurried. exact (@equiv_contr_sigma _ _ (contr_inhabited_hprop _ _)). Defined. Global Instance alg_flab_Type_forall@{u su | u < su} `{Univalence} : IsAlgebraicFlabbyType@{u su} Type@{u}. Proof. snrapply Build_IsAlgebraicFlabbyType; intros P A. - exact (forall p : P, A p). - intros p. apply path_universe_uncurried. exact (@equiv_contr_forall _ _ (contr_inhabited_hprop _ _) _). Defined. (** ** Algebraic flabbiness with resizing axioms *) Section AssumePropResizing. Context `{PropResizing}. (** Algebraic flabbiness is independent of universes under propositional resizing. *) Definition universe_independent_alg_flab@{v u w} {D : Type@{w}} (Daf : IsAlgebraicFlabbyType@{v w} D) : IsAlgebraicFlabbyType@{u w} D. Proof. snrapply Build_IsAlgebraicFlabbyType; intros P f; pose (e := (equiv_smalltype@{v u} P)); pose (PropQ := (@istrunc_equiv_istrunc _ _ e^-1 (-1) _)). - exact (center_af (f o e)). - intros p. lhs apply (contr_af (f o e) (e^-1 p)). apply ap. apply eisretr. Defined. (** Algebraic injectivity is independent of universes under propositional resizing. *) Definition universe_independent_alg_inj @{u v w u' v' uv uw vw u'v' u'w v'w | u <= uv, v <= uv, u <= uw, w <= uw, v <= vw, w <= vw, u' <= u'v', v' <= u'v', u' <= u'w, w <= u'w, v' <= v'w, w <= v'w} {D : Type@{w}} (Dai : IsAlgebraicInjectiveType@{u v w uv uw vw} D) : IsAlgebraicInjectiveType@{u' v' w u'v' u'w v'w} D. Proof. apply alg_inj_alg_flab. apply universe_independent_alg_flab@{u u'v' w}. exact (alg_flab_alg_inj Dai). Defined. (** Any algebraically injective type [D : Type@{u}] is a retract of [X -> Type@{u}] with [X : Type@{u}]. This is a universe independent version of [retract_power_universe_alg_usuinj]. *) Definition retract_power_universe_alg_inj@{u su | u < su} `{Univalence} {D : Type@{u}} (Dai : IsAlgebraicInjectiveType@{u u u u u u} D) : exists (X : Type@{u}) (s : D -> (X -> Type@{u})) (r : (X -> Type@{u}) -> D), r o s == idmap. Proof. refine (D; _). refine (@paths D; _). apply (retract_power_universe_alg_usuinj D). exact (universe_independent_alg_inj@{u u u u su u u u su u su} Dai). Defined. End AssumePropResizing. (** Any retract of a type family [X -> Type@{u}] is algebraically injective. This is the opposite result as above, classifying algebraically injective types, independent of universes. It should be noted that this direction of the if and only if does not depend on propositional resizing. *) Definition alg_inj_retract_power_universe@{u su | u < su} `{Univalence} (D : Type@{u}) {X : Type@{u}} {s : D -> (X -> Type@{u})} (r : (X -> Type@{u}) -> D) (retr : r o s == idmap) : IsAlgebraicInjectiveType@{u u u u u u} D. Proof. apply (alg_inj_retract r retr). rapply alg_inj_arrow. Defined. (** ** Injectivity in terms of algebraic injectivity in the absence of resizing *) Section UniverseStructure. Universes u v w uv uw vw uvw. Constraint u <= uv, v <= uv, u <= uw, w <= uw, v <= vw, w <= vw, uv <= uvw, uw <= uvw, vw <= uvw. (** Algebraically injective types are injective. *) Definition inj_alg_inj@{} (D : Type@{w}) (Dai : IsAlgebraicInjectiveType@{u v w uv uw vw} D) : IsInjectiveType@{u v w uv uw vw uvw} D. Proof. intros X Y j isem f. apply tr. exact (lift_ai _ _; is_ext_ai _ f). Defined. (** The propositional truncation of algebraic injectivity implies injectivity. *) Definition inj_merely_alg_inj@{T | uvw < T} `{Funext} {D : Type@{w}} (mDai : merely@{T} (IsAlgebraicInjectiveType@{u v w uv uw vw} D)) : ((IsInjectiveType@{u v w uv uw vw uvw} D) : Type@{T}). Proof. revert mDai. nrapply Trunc_rec@{T T}. (* Manually stripping truncations so as to control universe variables. *) - repeat (nrapply istrunc_forall@{T T T}; intro). apply istrunc_truncation. - intro Dai. exact (inj_alg_inj@{} D Dai). Defined. (** A retract of an injective type is injective. *) Definition inj_retract @{w' uw' vw' uvw' T | u <= uw', v <= vw', w' <= uw', w' <= vw', uv <= uvw', uw' <= uvw', vw' <= uvw', uvw < T, uvw' < T} `{Funext} {D' : Type@{w'}} {D : Type@{w}} (r : D -> D') {s : D' -> D} (retr : r o s == idmap) (Di : IsInjectiveType@{u v w uv uw vw uvw} D) : IsInjectiveType@{u v w' uv uw' vw' uvw'} D'. Proof. intros X Y j isem f. specialize (Di X Y j isem (s o f)). revert Di. rapply Trunc_rec@{T T}. intros [g e]. apply tr. snrefine (r o g; _). intros x. rhs_V apply (retr (f x)). exact (ap r (e x)). Defined. End UniverseStructure. (** Injective types are retracts of any type that they embed into, in an unspecified way. *) Definition merely_retract_inj_embedding@{v w vw svw | v <= vw, w <= vw, vw < svw} (D : Type@{w}) {Y : Type@{v}} (j : D -> Y) (isem : IsEmbedding j) (Di : IsInjectiveType@{w v w vw w vw vw} D) : merely@{svw} { r : Y -> D & r o j == idmap } := Di _ _ _ _ idmap. (** The power of an injective type is injective. *) Definition inj_arrow @{u v w t uv ut vt tw uvt utw vtw utvw | u <= uv, v <= uv, u <= ut, t <= ut, v <= vt, t <= vt, t <= tw, w <= tw, uv <= uvt, ut <= uvt, vt <= uvt, ut <= utw, tw <= utw, vt <= vtw, tw <= vtw, uvt <= utvw, utw <= utvw, vtw <= utvw} `{Funext} {A : Type@{t}} (D : Type@{w}) (Di : IsInjectiveType@{ut vt w uvt utw vtw utvw} D) : IsInjectiveType@{u v tw uv utw vtw utvw} (A -> D). Proof. intros X Y j isem f. assert (embId : IsEmbedding (fun a : A => a)) by rapply istruncmap_mapinO_tr. pose proof (mD := Di (X * A) (Y * A) (functor_prod j equiv_idmap) (istruncmap_functor_prod@{u v t t ut vt uvt uvt uv t} _ _ _) (uncurry f)). revert mD. rapply Trunc_rec@{utvw utvw}. intros [g e]. apply tr. refine (fun y a => g (y, a); _). intros x. funext a. exact (e (x, a)). Defined. (** Any [u],[su]-injective type [X : Type@{u}], is a retract of [X -> Type@{u}] in an unspecified way. *) Definition merely_retract_power_universe_inj@{u su ssu | u < su, su < ssu} `{Univalence} (D : Type@{u}) (Di : IsInjectiveType@{u su u su u su su} D) : merely@{su} (sig@{su su} (fun r => r o (@paths D) == idmap)) := merely_retract_inj_embedding D (@paths D) isembedding_paths Di. (** Inverse of [inj_merely_alg_inj] modulo universes. *) Definition merely_alg_inj_inj@{u su ssu | u < su, su < ssu} `{Univalence} (D : Type@{u}) (Di : IsInjectiveType@{u su u su u su su} D) : merely@{su} (IsAlgebraicInjectiveType@{u u u u u u} D). Proof. srefine (Trunc_functor (-1) _ (merely_retract_power_universe_inj D Di)). intros [r retr]. exact (alg_inj_retract_power_universe D r retr). Defined. (** ** The equivalence of excluded middle with the (algebraic) injectivity of pointed types *) (** Assuming excluded middle, all pointed types are algebraically flabby (and thus algebraically injective). *) Definition alg_flab_pointed_lem@{u w} `{ExcludedMiddle} {D : Type@{w}} (d : D) : IsAlgebraicFlabbyType@{u w} D. Proof. snrapply Build_IsAlgebraicFlabbyType; intros P f. - destruct (LEM P _) as [p | np]. + exact (f p). + exact d. - cbn. intros q. destruct (LEM P _) as [p | np]. + exact (ap f (path_ishprop _ _)). + exact (Empty_rec (np q)). Defined. (** If the type [P + ~P + Unit] is algebraically flabby for [P] a proposition, then [P] is decidable. *) Definition decidable_alg_flab_hprop@{w} `{Funext} (P : HProp@{w}) (Paf : IsAlgebraicFlabbyType@{w w} ((P + ~P) + (Unit : Type@{w}))) : Decidable P. Proof. pose (inl' := inl : P + ~P -> (P + ~P) + (Unit : Type@{w})). assert (l : {d : (P + ~P) + (Unit : Type@{w}) & forall z, d = inl' z}). { refine (center_af _; contr_af inl'). rapply ishprop_decidable_hprop@{w w}. } destruct l as [[s | u] l2]. - exact s. - assert (np := fun p => inl_ne_inr _ _ (l2 (inl p))^). assert (nnp := fun np' => inl_ne_inr _ _ (l2 (inr np'))^). exact (Empty_rec (nnp np)). Defined. (** If all pointed types are algebraically flabby, then excluded middle holds. *) Definition lem_pointed_types_alg_flab@{w} `{Funext} (ptaf: forall (D : Type@{w}), D -> IsAlgebraicFlabbyType@{w w} D) : ExcludedMiddle_type@{w}. Proof. intros P PropP. apply (decidable_alg_flab_hprop (Build_HProp P)). apply ptaf. exact (inr tt). Defined. Coq-HoTT-9.0/theories/Homotopy/InjectiveTypes/TypeFamKanExt.v000066400000000000000000000320001474641544500242050ustar00rootroot00000000000000(** * Kan extensions of type families *) (** This is part of the formalization of section 4 of the paper: Injective Types in Univalent Mathematics by Martin Escardo. Many proofs are guided by Martin Escardo's original Agda formalization of this paper which can be found at: https://www.cs.bham.ac.uk/~mhe/TypeTopology/InjectiveTypes.Article.html. *) Require Import Basics. Require Import Types.Sigma Types.Unit Types.Arrow Types.Forall Types.Empty Types.Universe Types.Equiv Types.Paths. Require Import HFiber. Require Import Truncations.Core. Require Import Modalities.ReflectiveSubuniverse Modalities.Modality. (** We are careful about universe variables for these first few definitions because they are used in the rest of the paper. We use [u], [v], [w], etc. as our typical universe variables. Our convention for the max of two universes [u] and [v] is [uv]. *) Section UniverseStructure. Universes u v w uv uw vw uvw. Constraint u <= uv, v <= uv, u <= uw, w <= uw, v <= vw, w <= vw, uv <= uvw, uw <= uvw, vw <= uvw. Definition LeftKanFam@{} {X : Type@{u}} {Y : Type@{v}} (P : X -> Type@{w}) (j : X -> Y) : Y -> Type@{uvw} := fun y => sig@{uv w} (fun (w : hfiber j y) => P (w.1)). Definition RightKanFam@{} {X : Type@{u}} {Y : Type@{v}} (P : X -> Type@{w}) (j : X -> Y) : Y -> Type@{uvw} := fun y => forall (w : hfiber j y), P (w.1). (** Below we will introduce notations [P <| j] and [P |> j] for these Kan extensions. *) (** If [j] is an embedding, then [P <| j] and [P |> j] are extensions in the following sense: [(P <| j o j) x <~> P x <~> (P |> j o j) x]. So, with univalence, we get that they are extensions. *) Definition isext_equiv_leftkanfam@{} {X : Type@{u}} {Y : Type@{v}} (P : X -> Type@{w}) (j : X -> Y) (isem : IsEmbedding@{u v uv} j) (x : X) : Equiv@{uvw w} (LeftKanFam@{} P j (j x)) (P x). Proof. rapply (@equiv_contr_sigma (hfiber j (j x)) _ _). Defined. Definition isext_equiv_rightkanfam@{} `{Funext} {X : Type@{u}} {Y : Type@{v}} (P : X -> Type@{w}) (j : X -> Y) (isem : IsEmbedding@{u v uv} j) (x : X) : Equiv@{uvw w} (RightKanFam@{} P j (j x)) (P x). Proof. rapply (@equiv_contr_forall _ (hfiber j (j x)) _ _). Defined. Definition isext_leftkanfam@{suvw | uvw < suvw} `{Univalence} {X : Type@{u}} {Y : Type@{v}} (P : X -> Type@{w}) (j : X -> Y) (isem : IsEmbedding@{u v uv} j) (x : X) : @paths@{suvw} Type@{uvw} (LeftKanFam@{} P j (j x)) (P x) := path_universe_uncurried (isext_equiv_leftkanfam _ _ _ _). Definition isext_rightkanfam@{suvw | uvw < suvw} `{Univalence} {X : Type@{u}} {Y : Type@{v}} (P : X -> Type@{w}) (j : X -> Y) (isem : IsEmbedding@{u v uv} j) (x : X) : @paths@{suvw} Type@{uvw} (RightKanFam@{} P j (j x)) (P x) := path_universe_uncurried (isext_equiv_rightkanfam _ _ _ _). End UniverseStructure. Notation "P <| j" := (LeftKanFam P j) : function_scope. Notation "P |> j" := (RightKanFam P j) : function_scope. (** For [y : Y] not in the image of [j], [(P <| j) y] is empty and [(P |> j) y] is contractible. *) Definition isempty_leftkanfam {X : Type} {Y : Type} (P : X -> Type) (j : X -> Y) (y : Y) (ynin : forall x : X, j x <> y) : (P <| j) y -> Empty := fun '((x; p); _) => ynin x p. Definition contr_rightkanfam `{Funext} {X : Type} {Y : Type} (P : X -> Type@{w}) (j : X -> Y) (y : Y) (ynin : forall x : X, j x <> y) : Contr ((P |> j) y). Proof. snrapply contr_forall. intros [x p]. apply (Empty_rec (ynin x p)). Defined. (** The following equivalences tell us that [{ y : Y & (P <| j) y}] and [forall y : Y, (P |> j) y] can be thought of as just different notation for the sum and product of a type family. *) Definition equiv_leftkanfam {X : Type} {Y : Type} (P : X -> Type) (j : X -> Y) : {x : X & P x} <~> {y : Y & (P <| j) y}. Proof. snrapply equiv_adjointify. - exact (fun w : {x : X & P x} => (j w.1; (w.1; idpath); w.2)). - exact (fun '((y; ((x; p); y')) : {y : Y & (P <| j) y}) => (x; y')). - by intros [y [[x []] y']]. - reflexivity. Defined. Definition equiv_rightkanfam `{Funext} {X : Type} {Y : Type} (P : X -> Type@{w}) (j : X -> Y) : (forall x, P x) <~> (forall y, (P |> j) y). Proof. snrapply equiv_adjointify. - intros g y w. exact (g w.1). - exact (fun h x => h (j x) (x; idpath)). - intros h. by funext y [x []]. - intros g. by apply path_forall. Defined. (** Here we are taking the perspective of a type family [P : X -> Type] as an oo-presheaf, considering the interpretation of [X] as an oo-groupoid and [Type] as a universe of spaces i.e. an appropriate generalization of the category of sets. It is easy to see that a type family [P] is functorial if we define its action on paths with [transport]. Functoriality then reduces to known lemmas about the [transport] function. *) (** With this in mind, we define the type of transformations between two type families. [concat_Ap] says that these transformations are automatically natural. *) Definition MapFam {X : Type} (P : X -> Type) (R : X -> Type) := forall x, P x -> R x. Notation "P >=> R" := (MapFam P R) : function_scope. (** Composition of transformations. *) Definition compose_mapfam {X} {P R Q : X -> Type} (b : R >=> Q) (a : P >=> R) : P >=> Q := fun x => (b x) o (a x). (** If [j] is an embedding then [(P <| j) =< (P |> j)]. *) Definition transform_leftkanfam_rightkanfam {X Y : Type} (P : X -> Type) (j : X -> Y) (isem : IsEmbedding j) : (P <| j) >=> (P |> j). Proof. intros y [w' z] w. snrapply (transport (fun a => P a.1) _ z). srapply path_ishprop. Defined. (** Under this interpretation, we can think of the maps [P <| j] and [P |> j] as left and right Kan extensions of [P : X -> Type] along [j : X -> Y]. To see this we can construct the (co)unit transformations of our extensions. *) Definition unit_leftkanfam {X Y : Type} (P : X -> Type) (j : X -> Y) : P >=> ((P <| j) o j) := fun x A => ((x; idpath); A). Definition counit_rightkanfam {X Y : Type} (P : X -> Type) (j : X -> Y) : ((P |> j) o j) >=> P := fun x A => A (x; idpath). Definition counit_leftkanfam {X Y : Type} (R : Y -> Type) (j : X -> Y) : ((R o j) <| j) >=> R. Proof. intros y [[x p] C]. exact (transport R p C). Defined. Definition unit_rightkanfam {X Y : Type} (R : Y -> Type) (j : X -> Y) : R >=> ((R o j) |> j). Proof. intros y C [x p]. exact (transport R p^ C). Defined. (** Universal property of the Kan extensions. *) Definition univ_property_leftkanfam {X Y} {j : X -> Y} {P : X -> Type} {R : Y -> Type} (a : P >=> R o j) : { b : P <| j >=> R & compose_mapfam (b o j) (unit_leftkanfam P j) == a}. Proof. snrefine (_; _). - intros y [[x p] A]. exact (p # a x A). - intros x. reflexivity. Defined. Definition contr_univ_property_leftkanfam `{Funext} {X Y} {j : X -> Y} {P : X -> Type} {R : Y -> Type} {a : P >=> R o j} : Contr { b : P <| j >=> R | compose_mapfam (b o j) (unit_leftkanfam P j) == a}. Proof. apply (Build_Contr _ (univ_property_leftkanfam a)). intros [b F]. symmetry. (* Do now to avoid inversion in the first subgoal. *) srapply path_sigma. - funext y. funext [[w []] c]. srefine (ap10 (F w) c). - simpl. funext x. lhs nrapply transport_forall_constant. lhs nrapply transport_paths_Fl. apply moveR_Vp. rhs nrapply concat_p1. unfold compose_mapfam, unit_leftkanfam. symmetry. pose (i := fun px: P x => ((x; 1); px) : (P <| j) (j x)). lhs nrapply (ap_compose (fun k : (P <| j) >=> R => k (j x)) (fun ka => ka o i)). (* [ap (fun k => k (j x))] is exactly [apD10], so it cancels the first [path_forall]. *) lhs nrefine (ap _ (apD10_path_forall _ _ _ _)). lhs rapply (ap_precompose _ i). unfold path_forall, ap10. rewrite (eisretr apD10); cbn. apply eissect. Defined. Definition univ_property_rightkanfam {X Y} {j : X -> Y} {P : X -> Type} {R : Y -> Type} (a : R o j >=> P) : { b : R >=> P |> j & compose_mapfam (counit_rightkanfam P j) (b o j) == a}. Proof. snrefine (_; _). - intros y A [x p]. exact (a x (p^ # A)). - intro x. reflexivity. Defined. Definition contr_univ_property_rightkanfam `{Funext} {X Y} {j : X -> Y} {P : X -> Type} {R : Y -> Type} (a : R o j >=> P) : Contr { b : R >=> P |> j & compose_mapfam (counit_rightkanfam P j) (b o j) == a}. Proof. apply (Build_Contr _ (univ_property_rightkanfam a)). intros [b F]. symmetry. (* Do now to avoid inversion in the first subgoal. *) srapply path_sigma. - funext y. funext C. funext [x p]. destruct p. srefine (ap10 (F x) C). - simpl. funext x. lhs nrapply transport_forall_constant. lhs nrapply transport_paths_Fl. apply moveR_Vp. symmetry. lhs nrapply concat_p1. unfold compose_mapfam. lhs nrapply (ap_compose (fun k : R >=> (P |> j) => k (j x)) (fun ka => _ o ka)). (* [ap (fun k => k (j x))] is exactly [apD10], so it cancels the first [path_forall]. *) lhs nrefine (ap _ (apD10_path_forall _ _ _ _)). lhs nrapply ap_postcompose. unfold path_forall, ap10. rewrite (eisretr apD10). change (ap _ ?p) with (apD10 p (x; 1)). nrapply moveR_equiv_V. funext r. exact (apD10_path_forall _ _ _ (x; _)). Defined. (** The above (co)unit constructions are special cases of the following, which tells us that these extensions are adjoint to restriction by [j] *) Definition leftadjoint_leftkanfam `{Funext} {X Y : Type} (P : X -> Type) (R : Y -> Type) (j : X -> Y) : ((P <| j) >=> R) <~> (P >=> R o j). Proof. snrapply equiv_adjointify. - intros a x B. exact (a (j x) ((x; idpath); B)). - intros b y [[x p] C]. exact (p # (b x C)). - intros b. by funext x C. - intros a. by funext y [[x []] C]. Defined. Definition rightadjoint_rightkanfam `{Funext} {X Y : Type} (P : X -> Type) (R : Y -> Type) (j : X -> Y) : (R >=> (P |> j)) <~> (R o j >=> P). Proof. snrapply equiv_adjointify. - intros a x C. exact (a (j x) C (x; idpath)). - intros a y C [x p]. apply (a x). exact (p^ # C). - intros a. by funext x C. - intros b. funext y C [x p]. destruct p; cbn. reflexivity. Defined. (** This section is all set up for the proof that the left Kan extension of an embedding is an embedding of type families. *) Section EmbedProofLeft. Context `{Univalence} {X Y : Type} (j : X -> Y) (isem : IsEmbedding j). (** The counit transformation of a type family of the form [P <| j] has each of its components an equivalence. In other words, the type family [P <| j] is the left Kan extension of its restriction along [j]. *) Definition isequiv_counit_leftkanfam_leftkanfam (P : X -> Type) {y : Y} : IsEquiv (counit_leftkanfam (P <| j) j y). Proof. snrapply isequiv_adjointify. - exact (fun '(((x; p); C) : (P <| j) y) => ((x; p); ((x; idpath); C))). - by intros [[x []] C]. - intros [[x []] [[x' p'] C]]; cbn; cbn in C, p'. revert p'; apply (equiv_ind (ap j)). by intros []. Defined. (** We now use the above fact to show that type families over [X] are equivalent to type families over [Y] such that the counit map is a natural isomorphism. *) Definition leftkanfam_counit_equiv (P : X -> Type) : { R : Y -> Type & forall y, IsEquiv (counit_leftkanfam R j y) }. Proof. exists (P <| j). rapply isequiv_counit_leftkanfam_leftkanfam. Defined. Global Instance isequiv_leftkanfam_counit_equiv : IsEquiv leftkanfam_counit_equiv. Proof. snrapply isequiv_adjointify. - intros [R e]. exact (R o j). - intros [R e]. srapply path_sigma_hprop; cbn. funext y. exact (path_universe _ (feq:=e y)). - intros P. funext x. rapply isext_leftkanfam. Defined. (** Using these facts we can show that the map [_ <| j] is an embedding if [j] is an embedding. *) Definition isembed_leftkanfam_ext : IsEmbedding (fun P => P <| j) := mapinO_compose (O:=-1) leftkanfam_counit_equiv pr1. End EmbedProofLeft. (** Dual proof for the right Kan extension. *) Section EmbedProofRight. Context `{Univalence} {X Y : Type} (j : X -> Y) (isem : IsEmbedding j). Definition isequiv_unit_rightkanfam_rightkanfam (P : X -> Type) {y : Y} : IsEquiv (unit_rightkanfam (P |> j) j y). Proof. snrapply isequiv_adjointify. - intros C [x p]. exact (C (x; p) (x; idpath)). - intros C. funext [x p]. destruct p. funext w. rapply (@transport _ (fun t => C t (t.1; idpath) = C (x; idpath) t) _ w (center _ (isem (j x) (x; idpath) w)) idpath). - intros a. funext [x p]. destruct p. reflexivity. Defined. Definition rightkanfam_unit_equiv (P : X -> Type) : {R : Y -> Type & forall y, IsEquiv (unit_rightkanfam R j y)}. Proof. exists (P |> j). rapply isequiv_unit_rightkanfam_rightkanfam. Defined. Global Instance isequiv_rightkanfam_unit_equiv : IsEquiv rightkanfam_unit_equiv. Proof. snrapply isequiv_adjointify. - intros [R e]. exact (R o j). - intros [R e]. srapply path_sigma_hprop; cbn. funext y. symmetry; exact (path_universe _ (feq:=e y)). - intros P. funext x. rapply isext_rightkanfam. Defined. (** The map [_ |> j] is an embedding if [j] is an embedding. *) Definition isembed_rightkanfam_ext : IsEmbedding (fun P => P |> j) := mapinO_compose (O:=-1) rightkanfam_unit_equiv pr1. End EmbedProofRight. Coq-HoTT-9.0/theories/Homotopy/Join.v000066400000000000000000000001641474641544500174650ustar00rootroot00000000000000Require Export Join.Core. Require Export Join.TriJoin. Require Export Join.JoinAssoc. Require Export Join.JoinSusp. Coq-HoTT-9.0/theories/Homotopy/Join/000077500000000000000000000000001474641544500172755ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Homotopy/Join/Core.v000066400000000000000000001032261474641544500203600ustar00rootroot00000000000000Require Import Basics Types. Require Import Cubical.DPath Cubical.PathSquare. Require Import Homotopy.NullHomotopy. Require Import Extensions. Require Import Colimits.Pushout. Require Import Truncations.Core Truncations.Connectedness. Require Import Pointed.Core. Require Import WildCat. Require Import Spaces.Nat.Core. Local Open Scope pointed_scope. Local Open Scope path_scope. (** * Joins *) (** The join is the pushout of two types under their product. *) Section Join. Definition Join (A : Type@{i}) (B : Type@{j}) := Pushout@{k i j k} (@fst A B) (@snd A B). Definition joinl {A B} : A -> Join A B := fun a => @pushl (A*B) A B fst snd a. Definition joinr {A B} : B -> Join A B := fun b => @pushr (A*B) A B fst snd b. Definition jglue {A B} a b : joinl a = joinr b := @pglue (A*B) A B fst snd (a , b). Definition Join_ind {A B : Type} (P : Join A B -> Type) (P_A : forall a, P (joinl a)) (P_B : forall b, P (joinr b)) (P_g : forall a b, transport P (jglue a b) (P_A a) = (P_B b)) : forall (x : Join A B), P x. Proof. apply (Pushout_ind P P_A P_B). exact (fun ab => P_g (fst ab) (snd ab)). Defined. Definition Join_ind_beta_jglue {A B : Type} (P : Join A B -> Type) (P_A : forall a, P (joinl a)) (P_B : forall b, P (joinr b)) (P_g : forall a b, transport P (jglue a b) (P_A a) = (P_B b)) a b : apD (Join_ind P P_A P_B P_g) (jglue a b) = P_g a b := Pushout_ind_beta_pglue _ _ _ _ _. (** A version of [Join_ind] specifically for proving that two functions defined on a [Join] are homotopic. *) Definition Join_ind_FlFr {A B P : Type} (f g : Join A B -> P) (Hl : forall a, f (joinl a) = g (joinl a)) (Hr : forall b, f (joinr b) = g (joinr b)) (Hglue : forall a b, ap f (jglue a b) @ Hr b = Hl a @ ap g (jglue a b)) : f == g. Proof. snrapply (Join_ind _ Hl Hr). intros a b. nrapply transport_paths_FlFr'. apply Hglue. Defined. Definition Join_ind_Flr {A B : Type} (f : Join A B -> Join A B) (Hl : forall a, f (joinl a) = joinl a) (Hr : forall b, f (joinr b) = joinr b) (Hglue : forall a b, ap f (jglue a b) @ Hr b = Hl a @ jglue a b) : forall x, f x = x. Proof. snrapply (Join_ind _ Hl Hr). intros a b. nrapply transport_paths_Flr'. apply Hglue. Defined. (** And a version for showing that a composite is homotopic to the identity. *) Definition Join_ind_FFlr {A B P : Type} (f : Join A B -> P) (g : P -> Join A B) (Hl : forall a, g (f (joinl a)) = joinl a) (Hr : forall b, g (f (joinr b)) = joinr b) (Hglue : forall a b, ap g (ap f (jglue a b)) @ Hr b = Hl a @ jglue a b) : forall x, g (f x) = x. Proof. snrapply (Join_ind _ Hl Hr). intros a b. nrapply transport_paths_FFlr'. apply Hglue. Defined. Definition Join_ind_FFlFr {A B C P : Type} (f : Join A B -> C) (g : C -> P) (h : Join A B -> P) (Hl : forall a, g (f (joinl a)) = h (joinl a)) (Hr : forall b, g (f (joinr b)) = h (joinr b)) (Hglue : forall a b, ap g (ap f (jglue a b)) @ Hr b = Hl a @ ap h (jglue a b)) : g o f == h. Proof. snrapply (Join_ind _ Hl Hr). intros a b; cbn beta. nrapply transport_paths_FFlFr'. apply Hglue. Defined. Definition Join_ind_FlFFr {A B C P : Type} (f : Join A B -> C) (g : C -> P) (h : Join A B -> P) (Hl : forall a, h (joinl a) = g (f (joinl a))) (Hr : forall b, h (joinr b) = g (f (joinr b))) (Hglue : forall a b, ap h (jglue a b) @ Hr b = Hl a @ ap g (ap f (jglue a b))) : h == g o f. Proof. snrapply (Join_ind _ Hl Hr). intros a b; cbn beta. nrapply transport_paths_FlFFr'. apply Hglue. Defined. Definition Join_ind_FFlFFr {A B C D P : Type} (f : Join A B -> C) (g : C -> P) (h : Join A B -> D) (i : D -> P) (Hl : forall a, i (h (joinl a)) = g (f (joinl a))) (Hr : forall b, i (h (joinr b)) = g (f (joinr b))) (Hglue : forall a b, ap i (ap h (jglue a b)) @ Hr b = Hl a @ ap g (ap f (jglue a b))) : i o h == g o f. Proof. snrapply (Join_ind _ Hl Hr). intros a b; cbn beta. nrapply transport_paths_FFlFFr'. apply Hglue. Defined. Definition Join_rec {A B P : Type} (P_A : A -> P) (P_B : B -> P) (P_g : forall a b, P_A a = P_B b) : Join A B -> P. Proof. apply (Pushout_rec P P_A P_B). exact (fun ab => P_g (fst ab) (snd ab)). Defined. Definition Join_rec_beta_jglue {A B P : Type} (P_A : A -> P) (P_B : B -> P) (P_g : forall a b, P_A a = P_B b) a b : ap (Join_rec P_A P_B P_g) (jglue a b) = P_g a b. Proof. snrapply Pushout_rec_beta_pglue. Defined. (** If [A] is ipointed, so is [Join A B]. *) Definition pjoin (A : pType) (B : Type) : pType := [Join A B, joinl pt]. End Join. Arguments joinl {A B}%_type_scope _ , [A] B _. Arguments joinr {A B}%_type_scope _ , A [B] _. (** * [Join_rec] gives an equivalence of 0-groupoids We now prove many things about [Join_rec], for example, that it is an equivalence of 0-groupoids from the [JoinRecData] that we define next. The framework we use is a bit elaborate, but it parallels the framework used in TriJoin.v, where careful organization is essential. *) Record JoinRecData {A B P : Type} := { jl : A -> P; jr : B -> P; jg : forall a b, jl a = jr b; }. Arguments JoinRecData : clear implicits. Arguments Build_JoinRecData {A B P}%_type_scope (jl jr jg)%_function_scope. (** We use the name [join_rec] for the version of [Join_rec] defined on this data. *) Definition join_rec {A B P : Type} (f : JoinRecData A B P) : Join A B $-> P := Join_rec (jl f) (jr f) (jg f). Definition join_rec_beta_jg {A B P : Type} (f : JoinRecData A B P) (a : A) (b : B) : ap (join_rec f) (jglue a b) = jg f a b := Join_rec_beta_jglue _ _ _ a b. (** We're next going to define a map in the other direction. We do it via showing that [JoinRecData] is a 0-coherent 1-functor to [Type]. We'll later show that it is a 1-functor to 0-groupoids. *) Definition joinrecdata_fun {A B P Q : Type} (g : P -> Q) (f : JoinRecData A B P) : JoinRecData A B Q. Proof. snrapply Build_JoinRecData. - exact (g o jl f). - exact (g o jr f). - exact (fun a b => ap g (jg f a b)). Defined. (** The join itself has canonical [JoinRecData]. *) Definition joinrecdata_join (A B : Type) : JoinRecData A B (Join A B) := Build_JoinRecData joinl joinr jglue. (** Combining these gives a function going in the opposite direction to [join_rec]. *) Definition join_rec_inv {A B P : Type} (f : Join A B -> P) : JoinRecData A B P := joinrecdata_fun f (joinrecdata_join A B). (** Under [Funext], [join_rec] and [join_rec_inv] should be inverse equivalences. We'll avoid [Funext] and show that they are equivalences of 0-groupoids, where we choose the path structures carefully. *) (** ** The graph structure on [JoinRecData A B P] Under [Funext], this type will be equivalent to the identity type. But without [Funext], this definition will be more useful. *) Record JoinRecPath {A B P : Type} {f g : JoinRecData A B P} := { hl : forall a, jl f a = jl g a; hr : forall b, jr f b = jr g b; hg : forall a b, jg f a b @ hr b = hl a @ jg g a b; }. Arguments JoinRecPath {A B P} f g. (** In the special case where the first two components of [f] and [g] agree definitionally, [hl] and [hr] can be identity paths, and [hg] simplifies slightly. *) Definition bundle_joinrecpath {A B P : Type} {jl' : A -> P} {jr' : B -> P} {f g : forall a b, jl' a = jr' b} (h : forall a b, f a b = g a b) : JoinRecPath (Build_JoinRecData jl' jr' f) (Build_JoinRecData jl' jr' g). Proof. snrapply Build_JoinRecPath. 1, 2: reflexivity. intros; apply equiv_p1_1q, h. Defined. (** A tactic that helps us apply the previous result. *) Ltac bundle_joinrecpath := hnf; match goal with |- JoinRecPath ?F ?G => refine (bundle_joinrecpath (f:=jg F) (g:=jg G) _) end. (** Using [JoinRecPath], we can restate the beta rule for [join_rec]. This says that [join_rec_inv] is split surjective. *) Definition join_rec_beta {A B P : Type} (f : JoinRecData A B P) : JoinRecPath (join_rec_inv (join_rec f)) f := bundle_joinrecpath (join_rec_beta_jg f). (** [join_rec_inv] is essentially injective, as a map between 0-groupoids. *) Definition isinj_join_rec_inv {A B P : Type} {f g : Join A B -> P} (h : JoinRecPath (join_rec_inv f) (join_rec_inv g)) : f == g := Join_ind_FlFr _ _ (hl h) (hr h) (hg h). (** ** Lemmas and tactics about intervals and squares We now introduce several lemmas and tactics that will dispense with some routine goals. The idea is that a generic interval can be assumed to be trivial on the first vertex, and a generic square can be assumed to be the identity on the domain edge. In order to apply the [paths_ind] and [square_ind] lemmas that make this precise, we need to generalize various terms in the goal. *) (** This destructs a three component term [f], generalizes each piece evaluated appropriately, and clears all pieces. *) Ltac generalize_three f a b := let fg := fresh in let fr := fresh in let fl := fresh in destruct f as [fl fr fg]; cbn; generalize (fg a b); clear fg; generalize (fr b); clear fr; generalize (fl a); clear fl. (** For [f : JoinRecData A B P], if we have [a] and [b] and are trying to prove a statement only involving [jl f a], [jr f b] and [jg f a b], we can assume [jr f b] is [jl f a] and that [jg f a b] is reflexivity. This is just path induction, but it requires generalizing the goal appropriately. *) Ltac interval_ind f a b := generalize_three f a b; intro f; (* We really only wanted two of them generalized here, so we intro one. *) apply paths_ind. (** Similarly, for [h : JoinRecPath f g], if we have [a] and [b] and are trying to prove a goal only involving [h] and [g] evaluated at those points, we can assume that [g] is [f] and that [h] is "reflexivity". For this, we first define a lemma that is like "path induction on h", and then a tactic that uses it. *) Definition square_ind {P : Type} (a b : P) (ab : a = b) (Q : forall (a' b' : P) (ab' : a' = b') (ha : a = a') (hb : b = b') (k : ab @ hb = ha @ ab'), Type) (s : Q a b ab idpath idpath (equiv_p1_1q idpath)) : forall a' b' ab' ha hb k, Q a' b' ab' ha hb k. Proof. intros. destruct ha, hb. revert k; equiv_intro (equiv_p1_1q (p:=ab) (q:=ab')) k'; destruct k'. destruct ab. exact s. Defined. (* [g] should be the codomain of [h]. *) Global Ltac square_ind g h a b := generalize_three h a b; generalize_three g a b; apply square_ind. (** ** Use the WildCat library to organize things *) (** We begin by showing that [JoinRecData A B P] is a 0-groupoid, one piece at a time. *) Global Instance isgraph_joinrecdata (A B P : Type) : IsGraph (JoinRecData A B P) := {| Hom := JoinRecPath |}. Global Instance is01cat_joinrecdata (A B P : Type) : Is01Cat (JoinRecData A B P). Proof. apply Build_Is01Cat. - intro f. bundle_joinrecpath. reflexivity. - intros f1 f2 f3 h2 h1. snrapply Build_JoinRecPath; intros; cbn beta. + exact (hl h1 a @ hl h2 a). + exact (hr h1 b @ hr h2 b). + (* Some simple path algebra works as well. *) square_ind f3 h2 a b. square_ind f2 h1 a b. by interval_ind f1 a b. Defined. Global Instance is0gpd_joinrecdata (A B P : Type) : Is0Gpd (JoinRecData A B P). Proof. apply Build_Is0Gpd. intros f g h. snrapply Build_JoinRecPath; intros; cbn beta. + exact (hl h a)^. + exact (hr h b)^. + (* Some simple path algebra works as well. *) square_ind g h a b. by interval_ind f a b. Defined. Definition joinrecdata_0gpd (A B P : Type) : ZeroGpd := Build_ZeroGpd (JoinRecData A B P) _ _ _. (** ** [joinrecdata_0gpd A B] is a 1-functor from [Type] to [ZeroGpd] It's a 1-functor that lands in [ZeroGpd], and the morphisms of [ZeroGpd] are 0-functors, so it's easy to get confused about the levels. *) (** First we need to show that the induced map is a morphism in [ZeroGpd], i.e. that it is a 0-functor. *) Global Instance is0functor_joinrecdata_fun {A B P Q : Type} (g : P -> Q) : Is0Functor (@joinrecdata_fun A B P Q g). Proof. apply Build_Is0Functor. intros f1 f2 h. snrapply Build_JoinRecPath; intros; cbn. - exact (ap g (hl h a)). - exact (ap g (hr h b)). - square_ind f2 h a b. by interval_ind f1 a b. Defined. (** [joinrecdata_0gpd A B] is a 0-functor from [Type] to [ZeroGpd] (one level up). *) Global Instance is0functor_joinrecdata_0gpd (A B : Type) : Is0Functor (joinrecdata_0gpd A B). Proof. apply Build_Is0Functor. intros P Q g. snrapply Build_Morphism_0Gpd. - exact (joinrecdata_fun g). - apply is0functor_joinrecdata_fun. Defined. (** [joinrecdata_0gpd A B] is a 1-functor from [Type] to [ZeroGpd]. *) Global Instance is1functor_joinrecdata_0gpd (A B : Type) : Is1Functor (joinrecdata_0gpd A B). Proof. apply Build_Is1Functor. (* If [g1 g2 : P -> Q] are homotopic, then the induced maps are homotopic: *) - intros P Q g1 g2 h f; cbn in *. snrapply Build_JoinRecPath; intros; cbn. 1, 2: apply h. interval_ind f a b; cbn. apply concat_1p_p1. (* The identity map [P -> P] is sent to a map homotopic to the identity. *) - intros P f; cbn. bundle_joinrecpath; intros; cbn. apply ap_idmap. (* It respects composition. *) - intros P Q R g1 g2 f; cbn. bundle_joinrecpath; intros; cbn. apply ap_compose. Defined. Definition joinrecdata_0gpd_fun (A B : Type) : Fun11 Type ZeroGpd := Build_Fun11 _ _ (joinrecdata_0gpd A B). (** By the Yoneda lemma, it follows from [JoinRecData] being a 1-functor that given [JoinRecData] in [J], we get a map [(J -> P) $-> (JoinRecData A B P)] of 0-groupoids which is natural in [P]. Below we will specialize to the case where [J] is [Join A B] with the canonical [JoinRecData]. *) Definition join_nattrans_recdata {A B J : Type} (f : JoinRecData A B J) : NatTrans (opyon_0gpd J) (joinrecdata_0gpd_fun A B). Proof. snrapply Build_NatTrans. 1: rapply opyoneda_0gpd. 2: exact _. exact f. Defined. (** Thus we get a map [(Join A B -> P) $-> (JoinRecData A B P)] of 0-groupoids, natural in [P]. The underlying map is [join_rec_inv A B P]. *) Definition join_rec_inv_nattrans (A B : Type) : NatTrans (opyon_0gpd (Join A B)) (joinrecdata_0gpd_fun A B) := join_nattrans_recdata (joinrecdata_join A B). (** This natural transformation is in fact a natural equivalence of 0-groupoids. *) Definition join_rec_inv_natequiv (A B : Type) : NatEquiv (opyon_0gpd (Join A B)) (joinrecdata_0gpd_fun A B). Proof. snrapply Build_NatEquiv'. 1: apply join_rec_inv_nattrans. intro P. apply isequiv_0gpd_issurjinj. apply Build_IsSurjInj. - intros f; cbn in f. exists (join_rec f). apply join_rec_beta. - exact (@isinj_join_rec_inv A B P). Defined. (** It will be handy to name the inverse natural equivalence. *) Definition join_rec_natequiv (A B : Type) := natequiv_inverse (join_rec_inv_natequiv A B). (** [join_rec_natequiv A B P] is an equivalence of 0-groupoids whose underlying function is definitionally [join_rec]. *) Local Definition join_rec_natequiv_check (A B P : Type) : equiv_fun_0gpd (join_rec_natequiv A B P) = @join_rec A B P := idpath. (** It follows that [join_rec A B P] is a 0-functor. *) Global Instance is0functor_join_rec (A B P : Type) : Is0Functor (@join_rec A B P). Proof. change (Is0Functor (equiv_fun_0gpd (join_rec_natequiv A B P))). exact _. Defined. (** And that [join_rec A B] is natural. The [$==] in the statement is just [==], but we use WildCat notation so that we can invert and compose these with WildCat notation. *) Definition join_rec_nat (A B : Type) {P Q : Type} (g : P -> Q) (f : JoinRecData A B P) : join_rec (joinrecdata_fun g f) $== g o join_rec f. Proof. exact (isnat (join_rec_natequiv A B) g f). Defined. (** * Various types of equalities between paths in joins *) (** Naturality squares for given paths in [A] and [B]. *) Section JoinNatSq. Definition join_natsq {A B : Type} {a a' : A} {b b' : B} (p : a = a') (q : b = b') : (ap joinl p) @ (jglue a' b') = (jglue a b) @ (ap joinr q). Proof. destruct p, q. apply concat_1p_p1. Defined. Definition join_natsq_v {A B : Type} {a a' : A} {b b' : B} (p : a = a') (q : b = b') : PathSquare (ap joinl p) (ap joinr q) (jglue a b) (jglue a' b'). Proof. destruct p, q. apply sq_refl_v. Defined. Definition join_natsq_h {A B : Type} {a a' : A} {b b' : B} (p : a = a') (q : b = b') : PathSquare (jglue a b) (jglue a' b') (ap joinl p) (ap joinr q). Proof. destruct p, q. apply sq_refl_h. Defined. End JoinNatSq. (** The triangles that arise when one of the given paths is reflexivity. *) Section Triangle. Context {A B : Type}. Definition triangle_h {a a' : A} (b : B) (p : a = a') : ap joinl p @ (jglue a' b) = jglue a b. Proof. destruct p. apply concat_1p. Defined. Definition triangle_h' {a a' : A} (b : B) (p : a = a') : jglue a b @ (jglue a' b)^ = ap joinl p. Proof. destruct p. apply concat_pV. Defined. Definition triangle_v (a : A) {b b' : B} (p : b = b') : jglue a b @ ap joinr p = jglue a b'. Proof. destruct p. apply concat_p1. Defined. Definition triangle_v' (a : A) {b b' : B} (p : b = b') : (jglue a b)^ @ jglue a b' = ap joinr p. Proof. destruct p. apply concat_Vp. Defined. (** For just one of the above, we give a rule for how it behaves on inverse paths. *) Definition triangle_v_V (a : A) {b b' : B} (p : b = b') : triangle_v a p^ = (1 @@ ap_V joinr p) @ moveR_pV _ _ _ (triangle_v a p)^. Proof. destruct p; cbn. rhs nrapply concat_1p. symmetry; apply concat_pV_p. Defined. End Triangle. (** Diamond lemmas for Join *) Section Diamond. Context {A B : Type}. Definition Diamond (a a' : A) (b b' : B) := PathSquare (jglue a b) (jglue a' b')^ (jglue a b') (jglue a' b)^. Definition diamond_h {a a' : A} (b b' : B) (p : a = a') : jglue a b @ (jglue a' b)^ = jglue a b' @ (jglue a' b')^. Proof. destruct p. exact (concat_pV _ @ (concat_pV _)^). Defined. Definition diamond_h_sq {a a' : A} (b b' : B) (p : a = a') : Diamond a a' b b'. Proof. by apply sq_path, diamond_h. Defined. Definition diamond_v (a a' : A) {b b' : B} (p : b = b') : jglue a b @ (jglue a' b)^ = jglue a b' @ (jglue a' b')^. Proof. by destruct p. Defined. Definition diamond_v_sq (a a' : A) {b b' : B} (p : b = b') : Diamond a a' b b'. Proof. by apply sq_path, diamond_v. Defined. Lemma diamond_symm (a : A) (b : B) : diamond_v_sq a a 1 = diamond_h_sq b b 1. Proof. unfold diamond_v_sq, diamond_h_sq, diamond_v, diamond_h. symmetry; apply ap, concat_pV. Defined. End Diamond. Definition diamond_twist {A : Type} {a a' : A} (p : a = a') : DPath (fun x => Diamond a' x a x) p (diamond_v_sq a' a 1) (diamond_h_sq a a' 1). Proof. destruct p. apply diamond_symm. Defined. (** * Functoriality of Join. *) Section FunctorJoin. (** In some cases, we'll need to refer to the recursion data that defines [functor_join], so we make it a separate definition. *) Definition functor_join_recdata {A B C D} (f : A -> C) (g : B -> D) : JoinRecData A B (Join C D) := {| jl := joinl o f; jr := joinr o g; jg := fun a b => jglue (f a) (g b); |}. Definition functor_join {A B C D} (f : A -> C) (g : B -> D) : Join A B -> Join C D := join_rec (functor_join_recdata f g). Definition functor_join_beta_jglue {A B C D : Type} (f : A -> C) (g : B -> D) (a : A) (b : B) : ap (functor_join f g) (jglue a b) = jglue (f a) (g b) := join_rec_beta_jg _ a b. Definition functor_join_compose {A B C D E F} (f : A -> C) (g : B -> D) (h : C -> E) (i : D -> F) : functor_join (h o f) (i o g) == functor_join h i o functor_join f g. Proof. snrapply Join_ind_FlFFr. 1,2: reflexivity. intros a b. simpl. apply equiv_p1_1q. lhs nrapply functor_join_beta_jglue; symmetry. lhs nrefine (ap _ (functor_join_beta_jglue _ _ _ _)). nrapply (functor_join_beta_jglue _ _ (f a) (g b)). Defined. Definition functor_join_idmap {A B} : functor_join idmap idmap == (idmap : Join A B -> Join A B). Proof. snrapply Join_ind_FlFr. 1,2: reflexivity. intros a b. simpl. apply equiv_p1_1q. lhs nrapply functor_join_beta_jglue. symmetry; apply ap_idmap. Defined. Definition functor2_join {A B C D} {f f' : A -> C} {g g' : B -> D} (h : f == f') (k : g == g') : functor_join f g == functor_join f' g'. Proof. srapply Join_ind_FlFr. - simpl; intros; apply ap, h. - simpl; intros; apply ap, k. - intros a b; cbn beta. lhs nrapply (functor_join_beta_jglue _ _ _ _ @@ 1). symmetry. lhs nrapply (1 @@ functor_join_beta_jglue _ _ _ _). apply join_natsq. Defined. Global Instance isequiv_functor_join {A B C D} (f : A -> C) `{!IsEquiv f} (g : B -> D) `{!IsEquiv g} : IsEquiv (functor_join f g). Proof. snrapply isequiv_adjointify. - apply (functor_join f^-1 g^-1). - etransitivity. 1: symmetry; apply functor_join_compose. etransitivity. 1: exact (functor2_join (eisretr f) (eisretr g)). apply functor_join_idmap. - etransitivity. 1: symmetry; apply functor_join_compose. etransitivity. 1: exact (functor2_join (eissect f) (eissect g)). apply functor_join_idmap. Defined. Definition equiv_functor_join {A B C D} (f : A <~> C) (g : B <~> D) : Join A B <~> Join C D := Build_Equiv _ _ (functor_join f g) _. Global Instance is0bifunctor_join : Is0Bifunctor Join. Proof. snrapply Build_Is0Bifunctor'. 1,2: exact _. apply Build_Is0Functor. intros A B [f g]. exact (functor_join f g). Defined. Global Instance is1bifunctor_join : Is1Bifunctor Join. Proof. snrapply Build_Is1Bifunctor'. nrapply Build_Is1Functor. - intros A B f g [p q]. exact (functor2_join p q). - intros A; exact functor_join_idmap. - intros A B C [f g] [h k]. exact (functor_join_compose f g h k). Defined. End FunctorJoin. (** * Symmetry of Join We'll use the recursion equivalence above to prove the symmetry of Join, using the Yoneda lemma. The idea is that [Join A B -> P] is equivalent (as a 0-groupoid) to [JoinRecData A B P], and the latter is very symmetrical by construction, which makes it easy to show that it is equivalent to [JoinRecData B A P]. Going back along the first equivalence gets us to [Join B A -> P]. These equivalences are natural in [P], so the symmetry equivalence follows from the Yoneda lemma. This is mainly meant as a warmup to proving the associativity of the join. *) Section JoinSym. Definition joinrecdata_sym (A B P : Type) : joinrecdata_0gpd A B P $-> joinrecdata_0gpd B A P. Proof. snrapply Build_Morphism_0Gpd. (* The map of types [JoinRecData A B P -> JoinRecData B A P]: *) - intros [fl fr fg]. snrapply (Build_JoinRecData fr fl). intros b a; exact (fg a b)^. (* It respects the paths. *) - apply Build_Is0Functor. intros f g h; simpl. snrapply Build_JoinRecPath; simpl. 1, 2: intros; apply h. intros b a. square_ind g h a b. by interval_ind f a b. Defined. (** This map is its own inverse in the 1-category of 0-groupoids. *) Definition joinrecdata_sym_inv (A B P : Type) : joinrecdata_sym B A P $o joinrecdata_sym A B P $== Id _. Proof. intro f; simpl. bundle_joinrecpath. intros a b; simpl. apply inv_V. Defined. (** We get the symmetry natural equivalence on [TriJoinRecData]. *) Definition joinrecdata_sym_natequiv (A B : Type) : NatEquiv (joinrecdata_0gpd_fun A B) (joinrecdata_0gpd_fun B A). Proof. snrapply Build_NatEquiv. (* An equivalence of 0-groupoids for each [P]: *) - intro P. snrapply cate_adjointify. 1, 2: apply joinrecdata_sym. 1, 2: apply joinrecdata_sym_inv. (* Naturality: *) - snrapply Build_Is1Natural. intros P Q g f; simpl. bundle_joinrecpath. intros b a; simpl. symmetry; apply ap_V. Defined. (** Combining with the recursion equivalence [join_rec_inv_natequiv] and its inverse gives the symmetry natural equivalence between the representable functors. *) Definition joinrecdata_fun_sym (A B : Type) : NatEquiv (opyon_0gpd (Join A B)) (opyon_0gpd (Join B A)) := natequiv_compose (join_rec_natequiv B A) (natequiv_compose (joinrecdata_sym_natequiv A B) (join_rec_inv_natequiv A B)). (** The Yoneda lemma for 0-groupoid valued functors therefore gives us an equivalence between the representing objects. We mark this with a prime, since we'll use a homotopic map with a slightly simpler definition. *) Definition equiv_join_sym' (A B : Type) : Join A B <~> Join B A. Proof. rapply (opyon_equiv_0gpd (A:=Type)). apply joinrecdata_fun_sym. Defined. (** It has the nice property that the underlying function of the inverse is again [equiv_join_sym'], with arguments permuted. *) Local Definition equiv_join_sym_check1 (A B : Type) : (equiv_join_sym' A B)^-1 = equiv_fun (equiv_join_sym' B A) := idpath. (** The definition we end up with is almost the same as the obvious one, but has an extra [ap idmap] in it. *) Local Definition equiv_join_sym_check2 (A B : Type) : equiv_fun (equiv_join_sym' A B) = Join_rec (fun a : A => joinr a) (fun b : B => joinl b) (fun (a : A) (b : B) => (ap idmap (jglue b a))^) := idpath. (** The next two give the obvious definition. *) Definition join_sym_recdata (A B : Type) : JoinRecData A B (Join B A) := Build_JoinRecData joinr joinl (fun a b => (jglue b a)^). Definition join_sym (A B : Type) : Join A B -> Join B A := join_rec (join_sym_recdata A B). Definition join_sym_beta_jglue {A B} (a : A) (b : B) : ap (join_sym A B) (jglue a b) = (jglue b a)^ := Join_rec_beta_jglue _ _ _ _ _. (** The obvious definition is homotopic to the definition via the Yoneda lemma. *) Definition join_sym_homotopic (A B : Type) : join_sym A B == equiv_join_sym' A B. Proof. symmetry. (** Both sides are [join_rec] applied to [JoinRecData]: *) rapply (fmap join_rec). bundle_joinrecpath; intros; cbn. refine (ap inverse _). apply ap_idmap. Defined. (** Therefore the obvious definition is also an equivalence, and the inverse function can also be chosen to be [join_sym]. *) Definition equiv_join_sym (A B : Type) : Join A B <~> Join B A := equiv_homotopic_inverse (equiv_join_sym' A B) (join_sym_homotopic A B) (join_sym_homotopic B A). Global Instance isequiv_join_sym A B : IsEquiv (join_sym A B) := equiv_isequiv (equiv_join_sym A B). (** It's also straightforward to directly prove that [join_sym] is an equivalence. The above approach is meant to illustrate the Yoneda lemma. In the case of [equiv_trijoin_twist], the Yoneda approach seems to be more straightforward. *) Definition join_sym_inv A B : join_sym A B o join_sym B A == idmap. Proof. snrapply (Join_ind_FFlr (join_sym B A)). - reflexivity. - reflexivity. - intros a b; cbn beta. apply equiv_p1_1q. refine (ap _ (join_rec_beta_jg _ a b) @ _); cbn. refine (ap_V _ (jglue b a) @ _). refine (ap inverse (join_rec_beta_jg _ b a) @ _). apply inv_V. Defined. (** Finally, one can also prove that the join is symmetric using [pushout_sym] and [equiv_prod_symm], but this results in an equivalence whose inverse isn't of the same form. *) (** We give a direct proof that [join_sym] is natural. *) Definition join_sym_nat {A B A' B'} (f : A -> A') (g : B -> B') : join_sym A' B' o functor_join f g == functor_join g f o join_sym A B. Proof. snrapply Join_ind_FFlFFr. 1, 2: reflexivity. intros a b; cbn beta. apply equiv_p1_1q. lhs nrefine (ap _ (functor_join_beta_jglue _ _ _ _)). lhs nrapply join_sym_beta_jglue. symmetry. lhs nrefine (ap _ (join_sym_beta_jglue a b)). refine (ap_V _ (jglue b a) @ ap inverse _). apply functor_join_beta_jglue. Defined. End JoinSym. (** * Other miscellaneous results about joins *) (** Relationship to truncation levels and connectedness. *) Section JoinTrunc. (** Joining with a contractible type produces a contractible type *) Global Instance contr_join A B `{Contr A} : Contr (Join A B). Proof. apply (Build_Contr _ (joinl (center A))). snrapply Join_ind. - intros a; apply ap, contr. - intros b; apply jglue. - intros a b; cbn. lhs nrapply transport_paths_r. apply triangle_h. Defined. (** The join of hprops is an hprop *) Global Instance ishprop_join `{Funext} A B `{IsHProp A} `{IsHProp B} : IsHProp (Join A B). Proof. apply hprop_inhabited_contr. snrapply Join_rec. - intros a; apply contr_join. exact (contr_inhabited_hprop A a). - intros b; refine (contr_equiv (Join B A) (equiv_join_sym B A)). apply contr_join. exact (contr_inhabited_hprop B b). (* The two proofs of contractibility are equal because [Contr] is an [HProp]. This uses [Funext]. *) - intros a b; apply path_ishprop. Defined. Lemma equiv_into_hprop `{Funext} {A B P : Type} `{IsHProp P} (f : A -> P) : (Join A B -> P) <~> (B -> P). Proof. apply equiv_iff_hprop. 1: exact (fun f => f o joinr). intros g. snrapply Join_rec. 1,2: assumption. intros a b. apply path_ishprop. Defined. (** And coincides with their disjunction *) Definition equiv_join_hor `{Funext} A B `{IsHProp A} `{IsHProp B} : Join A B <~> hor A B. Proof. apply equiv_iff_hprop. - exact (Join_rec (fun a => tr (inl a)) (fun b => tr (inr b)) (fun _ _ => path_ishprop _ _)). - apply Trunc_rec, push. Defined. (** Joins add connectivity *) Global Instance isconnected_join `{Funext} {m n : trunc_index} (A B : Type) `{IsConnected m A} `{IsConnected n B} : IsConnected (m +2+ n) (Join A B). Proof. apply isconnected_from_elim; intros C ? k. pose @istrunc_inO_tr. pose proof (istrunc_extension_along_conn (fun b:B => tt) (fun _ => C) (k o joinr)). unfold ExtensionAlong in *. transparent assert (f : (A -> {s : Unit -> C & forall x, s tt = k (joinr x)})). { intros a; exists (fun _ => k (joinl a)); intros b. exact (ap k (jglue a b)). } assert (h := isconnected_elim m {s : Unit -> C & forall x : B, s tt = k (joinr x)} f). unfold NullHomotopy in *; destruct h as [[c g] h]. exists (c tt). snrapply Join_ind. - intros a; cbn. exact (ap10 (h a)..1 tt). - intros b; cbn. exact ((g b)^). - intros a b. rewrite transport_paths_FlFr, ap_const, concat_p1; cbn. subst f; set (ha := h a); clearbody ha; clear h; assert (ha2 := ha..2); set (ha1 := ha..1) in *; clearbody ha1; clear ha; cbn in *. rewrite <- (inv_V (ap10 ha1 tt)). rewrite <- inv_pp. apply inverse2. refine (_ @ apD10 ha2 b); clear ha2. rewrite transport_forall_constant, transport_paths_FlFr. rewrite ap_const, concat_p1. reflexivity. Defined. End JoinTrunc. (** Join with Empty *) Section JoinEmpty. Definition equiv_join_empty_right A : Join A Empty <~> A. Proof. snrapply equiv_adjointify. - apply join_rec; snrapply (Build_JoinRecData idmap); contradiction. - exact joinl. - reflexivity. - snrapply Join_ind; [reflexivity| |]; contradiction. Defined. Definition equiv_join_empty_left A : Join Empty A <~> A := equiv_join_empty_right _ oE equiv_join_sym _ _. Global Instance join_right_unitor : RightUnitor Join Empty. Proof. snrapply Build_NatEquiv. - apply equiv_join_empty_right. - snrapply Build_Is1Natural. intros A B f. cbn -[equiv_join_empty_right]. snrapply Join_ind_FlFr. + intro a. reflexivity. + intros []. + intros a []. Defined. Global Instance join_left_unitor : LeftUnitor Join Empty. Proof. snrapply Build_NatEquiv. - apply equiv_join_empty_left. - snrapply Build_Is1Natural. intros A B f x. cbn -[equiv_join_empty_right]. rhs_V rapply (isnat_natequiv join_right_unitor). cbn -[equiv_join_empty_right]. apply ap, join_sym_nat. Defined. End JoinEmpty. Arguments equiv_join_empty_right : simpl never. (** Iterated Join powers of a type. *) Section JoinPower. (** The join of [n.+1] copies of a type. This is convenient because it produces [A] definitionally when [n] is [0]. We annotate the universes to reduce universe variables. *) Definition iterated_join (A : Type@{u}) (n : nat) : Type@{u} := nat_iter n (Join A) A. (** The join of [n] copies of a type. This is sometimes convenient for proofs by induction as it gives a trivial base case. *) Definition join_power (A : Type@{u}) (n : nat) : Type@{u} := nat_iter n (Join A) (Empty : Type@{u}). Definition equiv_join_powers (A : Type) (n : nat) : join_power A n.+1 <~> iterated_join A n. Proof. induction n as [|n IHn]; simpl. - exact (equiv_join_empty_right A). - exact (equiv_functor_join equiv_idmap IHn). Defined. End JoinPower. (** ** Doulbe recursion for Join *) Section Rec2. Context {A B C D : Type} (P : Type) (P_AC : A -> C -> P) (P_AD : A -> D -> P) (P_BC : B -> C -> P) (P_BD : B -> D -> P) (P_gAx : forall a c d, P_AC a c = P_AD a d) (P_gBx : forall b c d, P_BC b c = P_BD b d) (P_gxC : forall c a b, P_AC a c = P_BC b c) (P_gxD : forall d a b, P_AD a d = P_BD b d) (P_g : forall a b c d, P_gAx a c d @ P_gxD d a b = P_gxC c a b @ P_gBx b c d). Definition Join_rec2 : Join A B -> Join C D -> P. Proof. intros x y; revert x. snrapply Join_rec. 1: intros a; exact (Join_rec (P_AC a) (P_AD a) (P_gAx a) y). 1: intros b; exact (Join_rec (P_BC b) (P_BD b) (P_gBx b) y). intros a b. revert y. snrapply Join_ind_FlFr. 1: intros c; exact (P_gxC c a b). 1: intros d; exact (P_gxD d a b). intros c d. simpl. lhs nrapply whiskerR. 1: apply Join_rec_beta_jglue. rhs nrapply whiskerL. 2: apply Join_rec_beta_jglue. exact (P_g a b c d). Defined. End Rec2. Coq-HoTT-9.0/theories/Homotopy/Join/JoinAssoc.v000066400000000000000000000460021474641544500213560ustar00rootroot00000000000000Require Import Basics Types WildCat Join.Core Join.TriJoin Spaces.Nat.Core. (** * The associativity of [Join] We use the recursion principle for the triple join (from TriJoin.v) to prove the associativity of Join. We'll use the common technique of combining symmetry and a twist equivalence. Temporarily writing * for Join, symmetry says that [A * B <~> B * A] and the twist says that [A * (B * C) <~> B * (A * C)]. From these we get a composite equivalence [A * (B * C) <~> A * (C * B) <~> C * (A * B) <~> (A * B) * C]. One advantage of this approach is that both symmetry and the twist are their own inverses, so there are fewer maps to define and fewer composites to prove are homotopic to the identity. Symmetry is proved in Join/Core.v. *) (** ** The twist equivalence [TriJoin A B C <~> TriJoin B A C] We prove the twist equivalence using the Yoneda lemma. The idea is that [TriJoin A B C -> P] is equivalent (as a 0-groupoid) to [TriJoinRecData A B C P], and the latter is very symmetrical by construction, which makes it easy to show that it is equivalent to [TriJoinRecData B A C P]. Going back along the first equivalence gets us to [TriJoin B A C -> P]. These equivalences are natural in [P], so the twist equivalence follows from the Yoneda lemma. *) (** First we define a map of 0-groupoids that will underlie the natural equivalence. *) Definition trijoinrecdata_twist (A B C P : Type) : trijoinrecdata_0gpd A B C P $-> trijoinrecdata_0gpd B A C P. Proof. snrapply Build_Morphism_0Gpd. (* The map of types [TriJoinRecData A B C P -> TriJoinRecData B A C P]: *) - cbn. intros [f1 f2 f3 f12 f13 f23 f123]. snrapply (Build_TriJoinRecData f2 f1 f3). + intros b a; exact (f12 a b)^. + exact f23. + exact f13. + intros a b c; cbn beta. apply moveR_Vp. symmetry; apply f123. (* It respects the paths. *) - apply Build_Is0Functor. intros f g h; cbn in *. snrapply Build_TriJoinRecPath; intros; simpl. 1, 2, 3, 5, 6: apply h. + cbn zeta. prism_ind_two g h b a _X_; cbn beta. apply concat_p1_1p. + cbn beta zeta. prism_ind g h b a c; cbn beta. by triangle_ind f b a c. Defined. (** This map is its own inverse in the 1-category of 0-groupoids. *) Definition trijoinrecdata_twist_inv (A B C P : Type) : trijoinrecdata_twist B A C P $o trijoinrecdata_twist A B C P $== Id _. Proof. intro f; simpl. bundle_trijoinrecpath. all: intros; cbn. - apply inv_V. - reflexivity. - reflexivity. - by triangle_ind f a b c. Defined. (** We get the twist natural equivalence on [TriJoinRecData]. *) Definition trijoinrecdata_twist_natequiv (A B C : Type) : NatEquiv (trijoinrecdata_0gpd_fun A B C) (trijoinrecdata_0gpd_fun B A C). Proof. snrapply Build_NatEquiv. (* An equivalence of 0-groupoids for each [P]: *) - intro P. snrapply cate_adjointify. 1, 2: apply trijoinrecdata_twist. 1, 2: apply trijoinrecdata_twist_inv. (* Naturality: *) - snrapply Build_Is1Natural. intros P Q g f; simpl. bundle_trijoinrecpath. all: intros; cbn. + symmetry; apply ap_V. + reflexivity. + reflexivity. + by triangle_ind f b a c. Defined. (** Combining with the recursion equivalence [trijoin_rec_inv_natequiv] and its inverse gives the twist natural equivalence between the representable functors. *) Definition trijoinrecdata_fun_twist (A B C : Type) : NatEquiv (opyon_0gpd (TriJoin A B C)) (opyon_0gpd (TriJoin B A C)) := natequiv_compose (trijoin_rec_natequiv B A C) (natequiv_compose (trijoinrecdata_twist_natequiv A B C) (trijoin_rec_inv_natequiv A B C)). (** The Yoneda lemma for 0-groupoid valued functors therefore gives us an equivalence between the representing objects. We mark this with a prime, since we'll use a homotopic map with a slightly simpler definition. *) Definition equiv_trijoin_twist' (A B C : Type) : TriJoin A B C <~> TriJoin B A C. Proof. rapply (opyon_equiv_0gpd (A:=Type)). apply trijoinrecdata_fun_twist. Defined. (** It has the nice property that the underlying function of the inverse is again [equiv_trijoin_twist'], with arguments permuted. *) Local Definition trijoin_twist_check1 (A B C : Type) : (equiv_trijoin_twist' A B C)^-1 = equiv_fun (equiv_trijoin_twist' B A C) := idpath. (** The definition we end up with is almost the same as the obvious one, but has some extra [ap idmap]s in it. *) Local Definition twijoin_twist_check2 (A B C : Type) : equiv_fun (equiv_trijoin_twist' A B C) = trijoin_rec {| j1 := join2; j2 := join1; j3 := join3; j12 := fun (b : A) (a : B) => (ap idmap (join12 a b))^; j13 := fun (b : A) (c : C) => ap idmap (join23 b c); j23 := fun (a : B) (c : C) => ap idmap (join13 a c); j123 := fun (a : A) (b : B) (c : C) => moveR_Vp _ _ _ (ap_triangle idmap (join123 b a c))^ |} := idpath. (** The next two give the obvious definition. *) Definition trijoin_twist_recdata (A B C : Type) : TriJoinRecData A B C (TriJoin B A C) := Build_TriJoinRecData join2 join1 join3 (fun a b => (join12 b a)^) join23 join13 (fun a b c => moveR_Vp _ _ _ (join123 b a c)^). Definition trijoin_twist (A B C : Type) : TriJoin A B C -> TriJoin B A C := trijoin_rec (trijoin_twist_recdata A B C). (** As an aside, note that [trijoin_twist] computes nicely on [joinr]. *) Local Definition trijoin_twist_joinr (A B C : Type) : trijoin_twist A B C o joinr = functor_join idmap joinr := idpath. (** The obvious definition is homotopic to the definition via the Yoneda lemma. *) Definition trijoin_twist_homotopic (A B C : Type) : trijoin_twist A B C == equiv_trijoin_twist' A B C. Proof. symmetry. (** Both sides are [trijoin_rec] applied to [TriJoinRecData]: *) rapply (fmap trijoin_rec). bundle_trijoinrecpath; intros; cbn. 1: refine (ap inverse _). 1, 2, 3: apply ap_idmap. generalize (join123 b a c). generalize (join23 (A:=B) a c). generalize (join13 (B:=A) b c). generalize (join12 (C:=C) b a). generalize (join3 (A:=B) (B:=A) c). generalize (join2 (A:=B) (C:=C) a). generalize (join1 (B:=A) (C:=C) b). intros k1 k2 k3 k12 k13 k23 k123. induction k12, k23, k123. reflexivity. Defined. (** Therefore the obvious definition is also an equivalence, and the inverse function can also be chosen to be [trijoin_twist]. *) Definition equiv_trijoin_twist (A B C : Type) : TriJoin A B C <~> TriJoin B A C := equiv_homotopic_inverse (equiv_trijoin_twist' A B C) (trijoin_twist_homotopic A B C) (trijoin_twist_homotopic B A C). (** ** The associativity of [Join] *) (** [trijoin_twist] corresponds to the permutation (1,2). The equivalence corresponding to the permutation (2,3) also plays a key role, so we name it here. *) Definition trijoin_id_sym A B C : TriJoin A B C <~> TriJoin A C B := equiv_functor_join equiv_idmap (equiv_join_sym B C). Arguments trijoin_id_sym : simpl never. Definition join_assoc A B C : Join A (Join B C) <~> Join (Join A B) C. Proof. refine (_ oE trijoin_id_sym _ _ _). refine (_ oE equiv_trijoin_twist _ _ _). apply equiv_join_sym. Defined. Arguments join_assoc : simpl never. (** As a consequence, we get associativity of powers. *) Corollary join_join_power A n m : Join (join_power A n) (join_power A m) <~> join_power A (n + m)%nat. Proof. induction n as [|n IHn]. 1: exact (equiv_join_empty_left _). simpl. refine (_ oE (join_assoc _ _ _)^-1%equiv). exact (equiv_functor_join equiv_idmap IHn). Defined. (** ** Naturality of [trijoin_twist] *) (** Our goal is to prove that [trijoin_twist A' B' C' o functor_join f (functor_join g h)] is homotopic to [functor_join g (functor_join f h) o trijoin_twist A B C]. *) (** We first give a way to write anything of the form [trijoin_rec f o trijoin_twist A B C] as [trijoin_rec] applied to some [TriJoinRecData]. *) Definition trijoin_rec_trijoin_twist {A B C P} (f : TriJoinRecData B A C P) : trijoin_rec f o trijoin_twist A B C == trijoin_rec (trijoinrecdata_twist _ _ _ _ f). Proof. (* We first replace [trijoin_twist] with [equiv_trijoin_twist']. *) transitivity (trijoin_rec f o equiv_trijoin_twist' A B C). 1: exact (fun x => ap (trijoin_rec f) (trijoin_twist_homotopic A B C x)). (* The LHS is now the twist natural transformation applied to [Id], followed by postcomposition; naturality states that that is the same as the natural trans applied to [trijoin_rec f]. *) refine ((isnat_natequiv (trijoinrecdata_fun_twist B A C) (trijoin_rec f) _)^$ $@ _). (* The LHS simplifies to [trijoinrecdata_fun_twist] applied to [trijoin_rec f]. The former is a composite of [trijoin_rec], [trijoinrecdata_twist] and [trijoin_rec_inv], so we can write the LHS as: *) change (?L $== ?R) with (trijoin_rec (trijoinrecdata_twist B A C P (trijoin_rec_inv (trijoin_rec f))) $== R). refine (fmap trijoin_rec _). refine (fmap (trijoinrecdata_twist B A C P) _). apply trijoin_rec_beta. Defined. (** Naturality of [trijoin_twist]. This version uses [functor_trijoin] and simply combines previous results. *) Definition trijoin_twist_nat' {A B C A' B' C'} (f : A -> A') (g : B -> B') (h : C -> C') : trijoin_twist A' B' C' o functor_trijoin f g h == functor_trijoin g f h o trijoin_twist A B C. Proof. intro x. rhs nrapply trijoin_rec_trijoin_twist. nrapply trijoin_rec_functor_trijoin. Defined. (** And now a version using [functor_join]. *) Definition trijoin_twist_nat {A B C A' B' C'} (f : A -> A') (g : B -> B') (h : C -> C') : trijoin_twist A' B' C' o functor_join f (functor_join g h) == functor_join g (functor_join f h) o trijoin_twist A B C. Proof. intro x. lhs nrefine (ap _ (functor_trijoin_as_functor_join f g h x)). rhs nrapply functor_trijoin_as_functor_join. apply trijoin_twist_nat'. Defined. (** ** Naturality of [trijoin_id_sym] *) (** Naturality of [trijoin_id_sym], using [functor_join]. In this case, it's easier to do this version first. *) Definition trijoin_id_sym_nat {A B C A' B' C'} (f : A -> A') (g : B -> B') (h : C -> C') : trijoin_id_sym A' B' C' o functor_join f (functor_join g h) == functor_join f (functor_join h g) o trijoin_id_sym A B C. Proof. intro x; simpl. lhs_V nrapply functor_join_compose. rhs_V nrapply functor_join_compose. apply functor2_join. - reflexivity. - apply join_sym_nat. Defined. (** Naturality of [trijoin_id_sym], using [functor_trijoin]. *) Definition trijoin_id_sym_nat' {A B C A' B' C'} (f : A -> A') (g : B -> B') (h : C -> C') : trijoin_id_sym A' B' C' o functor_trijoin f g h == functor_trijoin f h g o trijoin_id_sym A B C. Proof. intro x. lhs_V nrefine (ap _ (functor_trijoin_as_functor_join f g h x)). rhs_V nrapply functor_trijoin_as_functor_join. apply trijoin_id_sym_nat. Defined. (** ** Naturality of [join_assoc] *) (** Since [join_assoc] is a composite of [join_sym], [trijoin_twist] and [trijoin_id_sym], we just use their naturality. *) Definition join_assoc_nat {A B C A' B' C'} (f : A -> A') (g : B -> B') (h : C -> C') : join_assoc A' B' C' o functor_join f (functor_join g h) == functor_join (functor_join f g) h o join_assoc A B C. Proof. (* We'll work from right to left, as it is easier to work near the head of a term. *) intro x. unfold join_assoc; cbn. (* First we pass the [functor_joins]s through the outer [join_sym]. *) rhs_V nrapply join_sym_nat. (* Strip off the outer [join_sym]. *) apply (ap _). (* Next we pass the [functor_join]s through [trijoin_twist]. *) rhs_V nrapply trijoin_twist_nat. (* Strip off the [trijoin_twist]. *) apply (ap _). (* Finally, we pass the [functor_join]s through [trijoin_id_sym]. *) apply trijoin_id_sym_nat. Defined. Global Instance join_associator : Associator Join. Proof. snrapply Build_Associator; simpl. - exact join_assoc. - snrapply Build_Is1Natural. intros [[A B] C] [[A' B'] C'] [[f g] h]; cbn. apply join_assoc_nat. Defined. (** ** The Triangle Law *) (** The unitors were defined in Join/Core.v, since they do not require associativity. *) (** Here's a version of the triangle law expressed using [trijoin_twist] instead of [join_assoc], and only using the right unitor. Since the left unitor is defined using [join_sym], the usual triangle law follows. *) Definition join_trianglelaw' A B : join_sym B A o functor_join idmap (equiv_join_empty_right A) o trijoin_twist A B Empty == functor_join idmap (equiv_join_empty_right B). Proof. (* A direct proof with [Join_ind] three times is not hard, but the path algebra is slightly simpler if we manipulate things ahead of time using [functor_join_join_rec] and [trijoin_rec_trijoin_twist]. *) intro x. rapply moveR_equiv_M. unfold equiv_join_empty_right at 1; cbn. lhs nrapply functor_join_join_rec; cbn. lhs nrapply trijoin_rec_trijoin_twist. revert x. apply moveR_trijoin_rec. snrapply Build_TriJoinRecPath; intros; cbn. 3, 5, 6, 7: by destruct c. - reflexivity. - reflexivity. - apply equiv_p1_1q. symmetry. lhs nrapply (ap_compose (functor_join idmap _) _ (join12 a b)). lhs nrapply ap. 1: apply functor_join_beta_jglue. apply join_sym_beta_jglue. Defined. Definition join_trianglelaw : TriangleIdentity Join Empty. Proof. intros A B x; cbn. lhs nrapply (functor_join_compose idmap _ idmap _). lhs_V nrapply join_trianglelaw'. unfold join_assoc; cbn. apply join_sym_nat. Defined. (** ** The hexagon axiom *) (** For the hexagon, we'll need to know how to compose [trijoin_id_sym] with something of the form [trijoin_rec f]. For some reason, the proof is harder than it was for [trijoin_twist]. *) (** This describes the transformation on [TriJoinRecData] corresponding to precomposition with [trijoin_id_sym], as in the next result. *) Definition trijoinrecdata_id_sym {A B C P} (f : TriJoinRecData A B C P) : TriJoinRecData A C B P. Proof. snrapply (Build_TriJoinRecData (j1 f) (j3 f) (j2 f)); intros. - apply (j13 f). - apply (j12 f). - symmetry; apply (j23 f). - cbn beta. apply moveR_pV; symmetry. apply (j123 f). Defined. (** This is analogous to [trijoin_rec_trijoin_twist] above, with [trijoin_twist] replaced by [trijoin_id_sym]. *) Definition trijoin_rec_id_sym {A B C P} (f : TriJoinRecData A C B P) : trijoin_rec f o trijoin_id_sym A B C == trijoin_rec (trijoinrecdata_id_sym f). Proof. (* First we use [functor_join_join_rec] on the LHS. *) etransitivity. { refine (cat_postwhisker (A:=Type) (trijoin_rec f) _). apply functor_join_join_rec. } unfold join_sym_recdata, jl, jr, jg. (* And now we use naturality of the second [trijoin_rec] on the LHS. *) refine ((trijoin_rec_nat A B C (trijoin_rec f) _)^$ $@ _). refine (fmap trijoin_rec _). (* Finally, we provide the needed [TriJoinRecPath]. *) bundle_trijoinrecpath; intros; cbn. - apply trijoin_rec_beta_join13. - apply trijoin_rec_beta_join12. - lhs refine (ap _ (ap_V _ _)). lhs refine (ap_V (trijoin_rec f) _). apply (ap inverse). apply trijoin_rec_beta_join23. - unfold prism'. rewrite ap_trijoin_V. rewrite trijoin_rec_beta_join123. set (f' := f). destruct f as [f1 f2 f3 f12 f13 f23 f123]; cbn. generalize (f123 a c b). generalize (trijoin_rec_beta_join23 f' c b); cbn. generalize (f23 c b). generalize (trijoin_rec_beta_join13 f' a b); cbn. generalize (f13 a b). generalize (trijoin_rec_beta_join12 f' a c); cbn. generalize (f12 a c); cbn. intros p12 beta12 p13 beta13 p23 beta23 p123. induction beta12, beta13, beta23; cbn. rewrite 3 concat_p1, concat_1p. reflexivity. Defined. (** Here is our first hexagon law. This is not the usual hexagon axiom, but we will see that it is equivalent, and is itself useful. This law states that the following diagram commutes, where we write [*] for [Join]: << A * (B * C) -> A * (C * B) -> C * (A * B) | | v v B * (A * C) -> B * (C * A) -> C * (B * A) >> Here every arrow is either [trijoin_twist _ _ _] or [trijoin_id_sym _ _ _], and they alternate as you go around. These correspond to the permutations (1,2) and (2,3) in the symmetric group on three letters. We already know that they are their own inverses, i.e., they have order two. The above says that the composite (1,2)(2,3) has order three. These are the only relations in this presentation of [S_3]. Note also that every object in this diagram is parenthesized in the same way. That will be important in our proof. *) Definition hexagon_join_twist_sym A B C : trijoin_id_sym C A B o trijoin_twist A C B o trijoin_id_sym A B C == trijoin_twist B C A o trijoin_id_sym B A C o trijoin_twist A B C. Proof. (* It's enough to show that both sides induces the same natural transformation under the covariant Yoneda embedding, i.e., after postcomposing with a general function [f]. *) rapply (opyon_faithful_0gpd (A:=Type)). intros P f. (* We replace [f] by [trijoin_rec t] for generic [t]. This will allow induction later. *) pose proof (p := issect_trijoin_rec_inv f). intro x; refine ((p _)^ @ _ @ p _); clear p. generalize (trijoin_rec_inv f) as t. intro t; clear f. (* Now we use how these various maps postcompose with [trijoin_rec foo]. *) lhs rapply trijoin_rec_id_sym. lhs rapply trijoin_rec_trijoin_twist. lhs rapply trijoin_rec_id_sym. rhs rapply trijoin_rec_trijoin_twist. rhs rapply trijoin_rec_id_sym. rhs rapply trijoin_rec_trijoin_twist. revert x; refine (fmap trijoin_rec _). bundle_trijoinrecpath; intros; cbn. 1, 2, 3: reflexivity. by triangle_ind t c b a. Defined. (** Next we paste on a naturality square for [join_sym] on the right of the diagram: << A * (B * C) -> A * (C * B) -> C * (A * B) -> (A * B) * C | | | v v v B * (A * C) -> B * (C * A) -> C * (B * A) -> (B * A) * C >> The new horizontal maps are [join_sym _ _] and the new vertical map is [functor_join (join_sym A B) idmap]. This makes both horizontal composites definitionally equal to [join_assoc _ _ _], so the statement is about a square. *) Definition square_join_sym_assoc_twist A B C : functor_join (join_sym A B) idmap o join_assoc A B C == join_assoc B A C o trijoin_twist A B C. Proof. unfold join_assoc; cbn. intro x; lhs_V rapply join_sym_nat. apply ap. apply hexagon_join_twist_sym. Defined. (** Finally, we paste on the defining square for [join_assoc] on the left to get the hexagon axiom for the symmetric monoidal structure: << A * (C * B) -> A * (B * C) -> (A * B) * C | | | v v v (A * C) * B -> B * (A * C) -> (B * A) * C >> The right-hand square is a horizontally-compressed version of the rectangle from the previous result, whose horizontal arrows are associativity. In the left-hand square, the new vertical map is [join_assoc A C B] and the horizontal maps are [trijoin_id_sym A C B] and [join_sym (Join A C) B]. *) Definition hexagon_join_assoc_sym A B C : functor_join (join_sym A B) idmap o join_assoc A B C o trijoin_id_sym A C B == join_assoc B A C o join_sym (Join A C) B o join_assoc A C B. Proof. intro x. refine (square_join_sym_assoc_twist A B C _ @ _). apply ap. simpl. symmetry. exact (eissect (equiv_join_sym B (Join A C)) _). Defined. Coq-HoTT-9.0/theories/Homotopy/Join/JoinSusp.v000066400000000000000000000046751474641544500212520ustar00rootroot00000000000000Require Import Basics Types. Require Import Join.Core Join.JoinAssoc Suspension Spaces.Spheres. Require Import WildCat. Require Import Spaces.Nat.Core. (** * [Join Bool A] is equivalent to [Susp A] We give a direct proof of this fact. It is also possible to give a proof using [opyon_equiv_0gpd]; see PR#1769. *) Definition join_to_susp (A : Type) : Join Bool A -> Susp A. Proof. srapply Join_rec. - exact (fun b => if b then North else South). - exact (fun a => South). - intros [|] a. + exact (merid a). + reflexivity. Defined. Definition susp_to_join (A : Type) : Susp A -> Join Bool A. Proof. srapply (Susp_rec (joinl true) (joinl false)). intros a. exact (jglue _ a @ (jglue _ a)^). Defined. Global Instance isequiv_join_to_susp (A : Type) : IsEquiv (join_to_susp A). Proof. snrapply (isequiv_adjointify _ (susp_to_join A)). - snrapply Susp_ind. 1,2: reflexivity. intros a. apply (transport_paths_FFlr' (f:=susp_to_join A)). apply equiv_p1_1q. lhs nrapply (ap _ _); [nrapply Susp_rec_beta_merid | ]. lhs nrapply (ap_pp _ _ (jglue false a)^). lhs nrefine (_ @@ _). 1: lhs nrapply ap_V; nrapply (ap inverse). 1,2: nrapply Join_rec_beta_jglue. apply concat_p1. - srapply (Join_ind_FFlr (join_to_susp A)); cbn beta. 1: intros [|]; reflexivity. 1: intros a; apply jglue. intros b a; cbn beta. lhs nrefine (ap _ _ @@ 1). 1: nrapply Join_rec_beta_jglue. destruct b. all: rhs nrapply concat_1p. + lhs nrefine (_ @@ 1); [nrapply Susp_rec_beta_merid | ]. apply concat_pV_p. + apply concat_1p. Defined. Definition equiv_join_susp (A : Type) : Join Bool A <~> Susp A := Build_Equiv _ _ (join_to_susp A) _. (** It follows that the join powers of [Bool] are spheres. These are sometimes a convenient alternative to working with spheres, so we give them a name. *) Definition bool_pow (n : nat) := join_power Bool n. Definition equiv_bool_pow_sphere (n : nat): bool_pow n <~> Sphere (n.-1). Proof. induction n as [|n IHn]. - reflexivity. - simpl. refine (_ oE equiv_join_susp _). exact (emap Susp IHn). Defined. (** It follows that joins of spheres are spheres, starting in dimension -1. *) Definition equiv_join_sphere (n m : nat) : Join (Sphere n.-1) (Sphere m.-1) <~> Sphere (n + m)%nat.-1. Proof. refine (_ oE equiv_functor_join _ _). 2,3: symmetry; exact (equiv_bool_pow_sphere _). refine (equiv_bool_pow_sphere _ oE _). apply join_join_power. Defined. Coq-HoTT-9.0/theories/Homotopy/Join/TriJoin.v000066400000000000000000001136361474641544500210540ustar00rootroot00000000000000Require Import Basics Types.Paths WildCat Join.Core HoTT.Tactics. (** * Induction and recursion principles for the triple join We show that the triple join satisfies symmetrical induction and recursion principles and prove that the recursion principle gives an equivalence of 0-groupoids. We use this in JoinAssoc.v to prove that the join is associative. Our approach parallels what is done in the two-variable case in Join/Core.v, especially starting with [TriJoinRecData] here and [JoinRecData] there. That case is much simpler, so should be read first. *) Section TriJoinStructure. Context {A B C : Type}. Definition TriJoin := Join A (Join B C). Definition join1 : A -> TriJoin := joinl. Definition join2 : B -> TriJoin := fun b => (joinr (joinl b)). Definition join3 : C -> TriJoin := fun c => (joinr (joinr c)). Definition join12 : forall a b, join1 a = join2 b := fun a b => jglue a (joinl b). Definition join13 : forall a c, join1 a = join3 c := fun a c => jglue a (joinr c). Definition join23 : forall b c, join2 b = join3 c := fun b c => ap joinr (jglue b c). Definition join123 : forall a b c, join12 a b @ join23 b c = join13 a c := fun a b c => triangle_v a (jglue b c). End TriJoinStructure. Arguments TriJoin A B C : clear implicits. (** ** [ap_trijoin] and [ap_trijoin_transport] *) (** Functions send triangles to triangles. *) Definition ap_triangle {X Y} (f : X -> Y) {a b c : X} {ab : a = b} {bc : b = c} {ac : a = c} (abc : ab @ bc = ac) : ap f ab @ ap f bc = ap f ac := (ap_pp f ab bc)^ @ ap (ap f) abc. (** This general result abstracts away the situation where [J] is [TriJoin A B C], [a] is [joinl a'] for some [a'], [jr] is [joinr : Join B C -> J], [jg] is [fun w => jglue a' w], and [p] is [jglue b c]. By working in this generality, we can do induction on [p]. This also allows us to inline the proof of [triangle_v]. *) Definition ap_trijoin_general {J W P : Type} (f : J -> P) (a : J) (jr : W -> J) (jg : forall w, a = jr w) {b c : W} (p : b = c) : ap f (jg b) @ ap f (ap jr p) = ap f (jg c). Proof. apply ap_triangle. induction p. apply concat_p1. Defined. (** Functions send the canonical triangles in triple joins to triangles. *) Definition ap_trijoin {A B C P : Type} (f : TriJoin A B C -> P) (a : A) (b : B) (c : C) : ap f (join12 a b) @ ap f (join23 b c) = ap f (join13 a c). Proof. nrapply ap_trijoin_general. Defined. Definition ap_trijoin_general_transport {J W P : Type} (f : J -> P) (a : J) (jr : W -> J) (jg : forall w, a = jr w) {b c : W} (p : b = c) : ap_trijoin_general f a jr jg p = (1 @@ ap_compose _ f _)^ @ (transport_paths_Fr _ _)^ @ apD (fun x => ap f (jg x)) p. Proof. induction p. unfold ap_trijoin_general; simpl. induction (jg b). reflexivity. Defined. Definition ap_trijoin_transport {A B C P : Type} (f : TriJoin A B C -> P) (a : A) (b : B) (c : C) : ap_trijoin f a b c = (1 @@ ap_compose _ f _)^ @ (transport_paths_Fr _ _)^ @ apD (fun x => ap f (jglue a x)) (jglue b c). Proof. nrapply ap_trijoin_general_transport. Defined. Definition ap_trijoin_general_V {J W P : Type} (f : J -> P) (a : J) (jr : W -> J) (jg : forall w, a = jr w) {b c : W} (p : b = c) : ap_trijoin_general f a jr jg p^ = (1 @@ (ap (ap f) (ap_V jr p) @ ap_V f _)) @ moveR_pV _ _ _ (ap_trijoin_general f a jr jg p)^. Proof. induction p. unfold ap_trijoin_general; cbn. by induction (jg b). Defined. Definition ap_trijoin_V {A B C P : Type} (f : TriJoin A B C -> P) (a : A) (b : B) (c : C) : ap_triangle f (triangle_v a (jglue b c)^) = (1 @@ (ap (ap f) (ap_V joinr _) @ ap_V f _)) @ moveR_pV _ _ _ (ap_trijoin f a b c)^. Proof. nrapply ap_trijoin_general_V. Defined. (** ** The induction principle for the triple join *) (** A lemma that handles the path algebra in the final step. *) Local Definition trijoin_ind_helper {A BC : Type} (P : Join A BC -> Type) (a : A) (b c : BC) (bc : b = c) (j1' : P (joinl a)) (j2' : P (joinr b)) (j3' : P (joinr c)) (j12' : jglue a b # j1' = j2') (j13' : jglue a c # j1' = j3') (j23' : (ap joinr bc) # j2' = j3') (j123' : transport_pp _ (jglue a b) (ap joinr bc) j1' @ ap (transport _ (ap joinr bc)) j12' @ j23' = transport2 _ (triangle_v a bc) _ @ j13') : ((apD (fun x : BC => transport P (jglue a x) j1') bc)^ @ ap (transport (fun x : BC => P (joinr x)) bc) j12') @ ((transport_compose P joinr bc j2') @ j23') = j13'. Proof. induction bc; simpl. rewrite transport_pp_1 in j123'. cbn in *. unfold transport; unfold transport in j123'. rewrite ap_idmap; rewrite ap_idmap in j123'. rewrite concat_pp_p in j123'. apply cancelL in j123'. rewrite 2 concat_1p. exact j123'. Qed. (** An induction principle for the triple join. Note that the hypotheses are phrased completely in terms of the "constructors" of [TriJoin A B C]. *) Definition trijoin_ind (A B C : Type) (P : TriJoin A B C -> Type) (join1' : forall a, P (join1 a)) (join2' : forall b, P (join2 b)) (join3' : forall c, P (join3 c)) (join12' : forall a b, join12 a b # join1' a = join2' b) (join13' : forall a c, join13 a c # join1' a = join3' c) (join23' : forall b c, join23 b c # join2' b = join3' c) (join123' : forall a b c, transport_pp _ (join12 a b) (join23 b c) (join1' a) @ ap (transport _ (join23 b c)) (join12' a b) @ join23' b c = transport2 _ (join123 a b c) _ @ join13' a c) : forall x, P x. Proof. snrapply Join_ind. - exact join1'. - snrapply Join_ind. + exact join2'. + exact join3'. + intros b c. lhs rapply (transport_compose P). apply join23'. - intro a. snrapply Join_ind. + simpl. exact (join12' a). + simpl. exact (join13' a). + intros b c; cbn beta zeta. lhs nrapply (transport_paths_FlFr_D (jglue b c)). lhs nrapply (1 @@ _). 1: nrapply Join_ind_beta_jglue. apply trijoin_ind_helper, join123'. Defined. (** ** The recursion principle for the triple join, and many results about it *) (** We'll bundle up the arguments into a record. *) Record TriJoinRecData {A B C P : Type} := { j1 : A -> P; j2 : B -> P; j3 : C -> P; j12 : forall a b, j1 a = j2 b; j13 : forall a c, j1 a = j3 c; j23 : forall b c, j2 b = j3 c; j123 : forall a b c, j12 a b @ j23 b c = j13 a c; }. Arguments TriJoinRecData : clear implicits. Arguments Build_TriJoinRecData {A B C P}%_type_scope (j1 j2 j3 j12 j13 j23 j123)%_function_scope. Definition trijoin_rec {A B C P : Type} (f : TriJoinRecData A B C P) : TriJoin A B C $-> P. Proof. snrapply Join_rec. - exact (j1 f). - snrapply Join_rec. + exact (j2 f). + exact (j3 f). + exact (j23 f). - intro a. snrapply Join_ind; cbn beta. + exact (j12 f a). + exact (j13 f a). + intros b c. lhs nrapply transport_paths_Fr. exact (1 @@ Join_rec_beta_jglue _ _ _ _ _ @ j123 f a b c). Defined. (** Beta rules for the recursion principle. *) Definition trijoin_rec_beta_join12 {A B C P : Type} (f : TriJoinRecData A B C P) (a : A) (b : B) : ap (trijoin_rec f) (join12 a b) = j12 f a b := Join_rec_beta_jglue _ _ _ _ _. Definition trijoin_rec_beta_join13 {A B C P : Type} (f : TriJoinRecData A B C P) (a : A) (c : C) : ap (trijoin_rec f) (join13 a c) = j13 f a c := Join_rec_beta_jglue _ _ _ _ _. Definition trijoin_rec_beta_join23 {A B C P : Type} (f : TriJoinRecData A B C P) (b : B) (c : C) : ap (trijoin_rec f) (join23 b c) = j23 f b c. Proof. unfold trijoin_rec, join23. lhs_V nrapply (ap_compose joinr); simpl. apply Join_rec_beta_jglue. Defined. Local Lemma trijoin_rec_beta_join123_helper {A : Type} {x y z : A} {u0 u1 : x = y} {p0 p1 r1 : y = z} {q0 s1 t1 : x = z} (p : p0 = p1) (q : q0 = u0 @ p0) (r : p0 = r1) (s : u1 @ r1 = s1) (t : s1 = t1) (u : u0 = u1) : ((1 @@ p)^ @ q^) @ (((q @ (u @@ 1)) @ ((1 @@ r) @ s)) @ t) = ((u @@ (p^ @ r)) @ s) @ t. Proof. induction u, t, s, r, p. revert q0 q; by apply paths_ind_r. Defined. Definition trijoin_rec_beta_join123 {A B C P : Type} (f : TriJoinRecData A B C P) (a : A) (b : B) (c : C) : ap_trijoin (trijoin_rec f) a b c = (trijoin_rec_beta_join12 f a b @@ trijoin_rec_beta_join23 f b c) @ j123 f a b c @ (trijoin_rec_beta_join13 f a c)^. Proof. (* Expand the LHS: *) lhs nrapply ap_trijoin_transport. rewrite (apD_homotopic (Join_rec_beta_jglue _ _ _ _) (jglue b c)). rewrite Join_ind_beta_jglue. (* Change [ap (transport __) _] on LHS. *) rewrite (concat_p_pp _ (transport_paths_Fr (jglue b c) (j12 f a b)) _). rewrite (concat_Ap (transport_paths_Fr (jglue b c))). (* Everything that remains is pure path algebra. *) (* [trijoin_rec_beta_join23] expands to something of the form [p^ @ r], so that's what is in the lemma. One can unfold it to see this, but the [Qed] is a bit faster without this: *) (* unfold trijoin_rec_beta_join23. *) (* Note that one of the [ap]s on the LHS computes to [u @@ 1], so that's what is in the lemma: *) (* change (ap (fun q => q @ ?x) ?u) with (u @@ @idpath _ x). *) nrapply trijoin_rec_beta_join123_helper. Qed. (** We're next going to define a map in the other direction. We do it via showing that [TriJoinRecData] is a 0-coherent 1-functor to [Type]. We'll later show that it is a 1-functor to 0-groupoids. *) Definition trijoinrecdata_fun {A B C P Q : Type} (g : P -> Q) (f : TriJoinRecData A B C P) : TriJoinRecData A B C Q. Proof. snrapply Build_TriJoinRecData. - exact (g o j1 f). - exact (g o j2 f). - exact (g o j3 f). - exact (fun a b => ap g (j12 f a b)). - exact (fun a c => ap g (j13 f a c)). - exact (fun b c => ap g (j23 f b c)). - intros a b c; cbn beta. exact (ap_triangle g (j123 f a b c)). (* The last four goals above can also be handled by the induction tactics below, but it's useful to be concrete. *) Defined. (** The triple join itself has canonical [TriJoinRecData]. *) Definition trijoinrecdata_trijoin (A B C : Type) : TriJoinRecData A B C (Join A (Join B C)) := Build_TriJoinRecData join1 join2 join3 join12 join13 join23 join123. (** Combining these gives a function going in the opposite direction to [trijoin_rec]. *) Definition trijoin_rec_inv {A B C P : Type} (f : TriJoin A B C -> P) : TriJoinRecData A B C P := trijoinrecdata_fun f (trijoinrecdata_trijoin A B C). (** Under [Funext], [trijoin_rec] and [trijoin_rec_inv] should be inverse equivalences. We'll avoid [Funext] and show that they are equivalences of 0-groupoids, where we choose the path structures carefully. *) (** ** The graph structure on [TriJoinRecData A B C P] *) (** The type of fillers for a triangular prism with five 2d faces [abc], [abc'], [k12], [k13], [k23]. *) Definition prism {P : Type} {a b c : P} {ab : a = b} {ac : a = c} {bc : b = c} (abc : ab @ bc = ac) {a' b' c' : P} {ab' : a' = b'} {ac' : a' = c'} {bc' : b' = c'} (abc' : ab' @ bc' = ac') {k1 : a = a'} {k2 : b = b'} {k3 : c = c'} (k12 : ab @ k2 = k1 @ ab') (k13 : ac @ k3 = k1 @ ac') (k23 : bc @ k3 = k2 @ bc') := concat_p_pp _ _ _ @ whiskerR abc k3 @ k13 = whiskerL ab k23 @ concat_p_pp _ _ _ @ whiskerR k12 bc' @ concat_pp_p _ _ _ @ whiskerL k1 abc'. (** The "identity" filler is slightly non-trivial, because the fillers for the squares, e.g. [ab @ 1 = 1 @ ab], must be non-trivial. *) Definition prism_id {P : Type} {a b c : P} {ab : a = b} {ac : a = c} {bc : b = c} (abc : ab @ bc = ac) : prism abc abc (equiv_p1_1q idpath) (equiv_p1_1q idpath) (equiv_p1_1q idpath). Proof. induction ab, bc, abc; simpl. reflexivity. Defined. (** The paths between elements of [TriJoinRecData A B C P]. Under [Funext], this type will be equivalent to the identity type. But without [Funext], this definition will be more useful. *) Record TriJoinRecPath {A B C P : Type} {f g : TriJoinRecData A B C P} := { h1 : forall a, j1 f a = j1 g a; h2 : forall b, j2 f b = j2 g b; h3 : forall c, j3 f c = j3 g c; h12 : forall a b, j12 f a b @ h2 b = h1 a @ j12 g a b; h13 : forall a c, j13 f a c @ h3 c = h1 a @ j13 g a c; h23 : forall b c, j23 f b c @ h3 c = h2 b @ j23 g b c; h123 : forall a b c, prism (j123 f a b c) (j123 g a b c) (h12 a b) (h13 a c) (h23 b c); }. Arguments TriJoinRecPath {A B C P} f g. (** We also define data for [trijoin_rec] that unbundles the first three components. This lets us talk about paths between two such when the first three components are definitionally equal. This is a common special case, and this set-up greatly simplifies a lot of path algebra in later proofs. *) Record TriJoinRecData' {A B C P : Type} {j1' : A -> P} {j2' : B -> P} {j3' : C -> P} := { j12' : forall a b, j1' a = j2' b; j13' : forall a c, j1' a = j3' c; j23' : forall b c, j2' b = j3' c; j123' : forall a b c, j12' a b @ j23' b c = j13' a c; }. Arguments TriJoinRecData' {A B C P} j1' j2' j3'. Arguments Build_TriJoinRecData' {A B C P}%_type_scope (j1' j2' j3' j12' j13' j23' j123')%_function_scope. Definition prism' {P : Type} {a b c : P} {ab : a = b} {ac : a = c} {bc : b = c} (abc : ab @ bc = ac) {ab' : a = b} {ac' : a = c} {bc' : b = c} (abc' : ab' @ bc' = ac') (k12 : ab = ab') (k13 : ac = ac') (k23 : bc = bc') := abc @ k13 = (k12 @@ k23) @ abc'. Record TriJoinRecPath' {A B C P : Type} {j1' : A -> P} {j2' : B -> P} {j3' : C -> P} {f g : TriJoinRecData' j1' j2' j3'} := { h12' : forall a b, j12' f a b = j12' g a b; h13' : forall a c, j13' f a c = j13' g a c; h23' : forall b c, j23' f b c = j23' g b c; h123' : forall a b c, prism' (j123' f a b c) (j123' g a b c) (h12' a b) (h13' a c) (h23' b c); }. Arguments TriJoinRecPath' {A B C P} {j1' j2' j3'} f g. (** We can bundle and unbundle these types of data. For unbundling, we just handle [TriJoinRecData] for now. *) Definition bundle_trijoinrecdata {A B C P : Type} {j1' : A -> P} {j2' : B -> P} {j3' : C -> P} (f : TriJoinRecData' j1' j2' j3') : TriJoinRecData A B C P := Build_TriJoinRecData j1' j2' j3' (j12' f) (j13' f) (j23' f) (j123' f). Definition unbundle_trijoinrecdata {A B C P : Type} (f : TriJoinRecData A B C P) : TriJoinRecData' (j1 f) (j2 f) (j3 f) := Build_TriJoinRecData' (j1 f) (j2 f) (j3 f) (j12 f) (j13 f) (j23 f) (j123 f). (** The proof by induction that is easily available to us here is what saves work in more complicated contexts. *) Definition bundle_prism {P : Type} {a b c : P} {ab : a = b} {ac : a = c} {bc : b = c} (abc : ab @ bc = ac) {ab' : a = b} {ac' : a = c} {bc' : b = c} (abc' : ab' @ bc' = ac') (k12 : ab = ab') (k13 : ac = ac') (k23 : bc = bc') (k123 : prism' abc abc' k12 k13 k23) : prism abc abc' (equiv_p1_1q k12) (equiv_p1_1q k13) (equiv_p1_1q k23). Proof. induction ab. induction bc. induction abc. induction k12. induction k23. induction k13. unfold prism' in k123. induction (moveR_Vp _ _ _ k123); clear k123. simpl. reflexivity. Defined. Definition bundle_trijoinrecpath {A B C P : Type} {j1' : A -> P} {j2' : B -> P} {j3' : C -> P} {f g : TriJoinRecData' j1' j2' j3'} (h : TriJoinRecPath' f g) : TriJoinRecPath (bundle_trijoinrecdata f) (bundle_trijoinrecdata g). Proof. snrapply Build_TriJoinRecPath. 1, 2, 3: reflexivity. 1, 2, 3: intros; apply equiv_p1_1q. - apply (h12' h). - apply (h13' h). - apply (h23' h). - cbn beta zeta. intros a b c. apply bundle_prism, (h123' h). Defined. (** A tactic that helps us apply the previous result. *) Ltac bundle_trijoinrecpath := hnf; match goal with |- TriJoinRecPath ?F ?G => refine (bundle_trijoinrecpath (f:=unbundle_trijoinrecdata F) (g:=unbundle_trijoinrecdata G) _) end; snrapply Build_TriJoinRecPath'. (** Using these paths, we can restate the beta rule for [trijoin_rec]. The statement using [TriJoinRecPath'] typechecks only because [trijoin_rec] computes definitionally on the path constructors. *) Definition trijoin_rec_beta' {A B C P : Type} (f : TriJoinRecData A B C P) : TriJoinRecPath' (unbundle_trijoinrecdata (trijoin_rec_inv (trijoin_rec f))) (unbundle_trijoinrecdata f). Proof. snrapply Build_TriJoinRecPath'; cbn. - apply trijoin_rec_beta_join12. - apply trijoin_rec_beta_join13. - apply trijoin_rec_beta_join23. - intros a b c. unfold prism'. apply moveR_pM. nrapply trijoin_rec_beta_join123. Defined. (** We can upgrade this to an unprimed path. This says that [trijoin_rec_inv] is split surjective. *) Definition trijoin_rec_beta {A B C P : Type} (f : TriJoinRecData A B C P) : TriJoinRecPath (trijoin_rec_inv (trijoin_rec f)) f := bundle_trijoinrecpath (trijoin_rec_beta' f). (** ** [trijoin_rec_inv] is an injective map between 0-groupoids *) (** We begin with a general purpose lemma. *) Definition triangle_ind {P : Type} (a : P) (Q : forall (b c : P) (ab : a = b) (ac : a = c) (bc : b = c) (abc : ab @ bc = ac), Type) (s : Q a a idpath idpath idpath idpath) : forall b c ab ac bc abc, Q b c ab ac bc abc. Proof. intros. induction ab. induction bc. induction abc. apply s. Defined. (** This lemma handles the path algebra in the last goal of the next result. *) Local Definition isinj_trijoin_rec_inv_helper {J P : Type} {f g : J -> P} {a b c : J} {ab : a = b} {ac : a = c} {bc : b = c} {abc : ab @ bc = ac} {H1 : f a = g a} {H2 : f b = g b} {H3 : f c = g c} {H12 : ap f ab @ H2 = H1 @ ap g ab} {H13 : ap f ac @ H3 = H1 @ ap g ac} {H23 : ap f bc @ H3 = H2 @ ap g bc} (H123 : prism (ap_triangle f abc) (ap_triangle g abc) H12 H13 H23) : (transport_pp (fun x => f x = g x) ab bc H1 @ ap (transport (fun x => f x = g x) bc) (transport_paths_FlFr' ab H1 H2 H12)) @ transport_paths_FlFr' bc H2 H3 H23 = transport2 (fun x => f x = g x) abc H1 @ transport_paths_FlFr' ac H1 H3 H13. Proof. revert b c ab ac bc abc H2 H3 H12 H13 H23 H123. nrapply triangle_ind; cbn. unfold ap_triangle, transport_paths_FlFr', transport; cbn -[concat_pp_p]. generalize dependent (f a); intro fa; clear f. generalize dependent (g a); intro ga; clear g a. intros H1 H2 H3 H12 H13 H23. rewrite ap_idmap. revert H12; equiv_intro (equiv_1p_q1 (p:=H2) (q:=H1)) H12'; induction H12'. revert H13; equiv_intro (equiv_1p_q1 (p:=H3) (q:=H2)) H13'; induction H13'. induction H3. intro H123. unfold prism in H123. rewrite whiskerL_1p_1 in H123. cbn in *. rewrite ! concat_p1 in H123. induction H123. reflexivity. Qed. (** [trijoin_rec_inv] is essentially injective, as a map between 0-groupoids. *) Definition isinj_trijoin_rec_inv {A B C P : Type} {f g : TriJoin A B C -> P} (h : TriJoinRecPath (trijoin_rec_inv f) (trijoin_rec_inv g)) : f == g. Proof. snrapply trijoin_ind. 1: apply (h1 h). 1: apply (h2 h). 1: apply (h3 h). 1, 2, 3: intros; nrapply transport_paths_FlFr'. 1: apply (h12 h). 1: apply (h13 h). 1: apply (h23 h). intros a b c; cbn beta. apply isinj_trijoin_rec_inv_helper. exact (h123 h a b c). Defined. (** ** Lemmas and tactics about triangles and prisms We now introduce several lemmas and tactics that will dispense with some routine goals. The idea is that a generic triangle can be assumed to be trivial on the first vertex, and a generic prism can be assumed to be the identity on the domain. In order to apply the [triangle_ind] and [prism_ind] lemmas that make this precise, we need to generalize various terms in the goal. *) (** This destructs a seven component term [f], tries to generalize each piece evaluated appropriately, and clears all pieces. If called with [a], [b] and [c] all valid terms, we expect all seven components to be generalized. But one can also call it with one of [a], [b] and [c] a dummy value (e.g. [_X_]) that causes four of the [generalize] tactics to fail. In this case, four components will be simply cleared, and three will be generalized and cleared, so this applies when the goal only depends on three of the seven components. *) Ltac generalize_some f a b c := let f1 := fresh in let f2 := fresh in let f3 := fresh in let f12 := fresh in let f13 := fresh in let f23 := fresh in let f123 := fresh in destruct f as [f1 f2 f3 f12 f13 f23 f123]; cbn; try generalize (f123 a b c); clear f123; try generalize (f23 b c); clear f23; try generalize (f13 a c); clear f13; try generalize (f12 a b); clear f12; try generalize (f3 c); clear f3; try generalize (f2 b); clear f2; try generalize (f1 a); clear f1. (* No easy way to skip the "last" one, since we don't know which will be the last to be generalized. *) (** Use this with [f : TriJoinRecData A B C P], [a : A], [b : B], [c : C]. *) Ltac triangle_ind f a b c := generalize_some f a b c; intro f; (* [generalize_some] goes one step too far, so intro the last variable. *) apply triangle_ind. (** Use this with [f : TriJoinRecData A B C P]. Two of the arguments [a], [b] and [c] should be elements of [A], [B] and [C], respectively, and the third should be a dummy value (e.g. [_X_]) that causes the generalize tactic to fail. It applies to goals that only depend on the components of [f] involving just two of [A], [B] and [C]. *) Ltac triangle_ind_two f a b c := generalize_some f a b c; intro f; (* [generalize_some] goes one step too far, so intro the last variable. *) apply paths_ind. (** The prism analog of the function [triangle_ind] from earlier in the file. To prove something about all prisms, it's enough to prove it for the "identity" prism. Note that we don't specialize to a prism concentrated on a single vertex, since sometimes we have to deal with a composite of two prisms. *) Definition prism_ind {P : Type} (a b c : P) (ab : a = b) (ac : a = c) (bc : b = c) (abc : ab @ bc = ac) (Q : forall (a' b' c' : P) (ab' : a' = b') (ac' : a' = c') (bc' : b' = c') (abc' : ab' @ bc' = ac') (k1 : a = a') (k2 : b = b') (k3 : c = c') (k12 : ab @ k2 = k1 @ ab') (k13 : ac @ k3 = k1 @ ac') (k23 : bc @ k3 = k2 @ bc') (k123 : prism abc abc' k12 k13 k23), Type) (s : Q a b c ab ac bc abc idpath idpath idpath (equiv_p1_1q idpath) (equiv_p1_1q idpath) (equiv_p1_1q idpath) (prism_id abc)) : forall a' b' c' ab' ac' bc' abc' k1 k2 k3 k12 k13 k23 k123, Q a' b' c' ab' ac' bc' abc' k1 k2 k3 k12 k13 k23 k123. Proof. intros. induction k1, k2, k3. revert k123. revert k12; equiv_intro (equiv_p1_1q (p:=ab) (q:=ab')) k12'; induction k12'. revert k13; equiv_intro (equiv_p1_1q (p:=ac) (q:=ac')) k13'; induction k13'. revert k23; equiv_intro (equiv_p1_1q (p:=bc) (q:=bc')) k23'; induction k23'. induction ab, bc, abc; simpl in *. unfold prism; simpl. equiv_intro (equiv_concat_r (concat_1p (whiskerL 1 abc') @ whiskerL_1p_1 abc')^ idpath) k123'. induction k123'. simpl. exact s. Defined. (** Use this with [f g : TriJoinRecData A B C P], [h : TriJoinRecPath f g] (so [g] is the *co*domain of [h]), [a : A], [b : B], [c : C]. *) Ltac prism_ind g h a b c := generalize_some h a b c; generalize_some g a b c; apply prism_ind. (** Use this with [f g : TriJoinRecData A B C P], [h : TriJoinRecPath f g] (so [g] is the *co*domain of [h]). Two of the arguments [a], [b] and [c] should be elements of [A], [B] and [C], respectively, and the third should be a dummy value (e.g. [_X_]) that causes the generalize tactic to fail. It applies to goals that only depend on the components of [g] and [h] involving just two of [A], [B] and [C]. So it is dealing with one square face of the prism. *) Ltac prism_ind_two g h a b c := generalize_some h a b c; generalize_some g a b c; apply square_ind. (* From Join/Core.v *) (** ** Use the WildCat library to organize things *) (** We begin by showing that [TriJoinRecData A B C P] is a 0-groupoid, one piece at a time. *) Global Instance isgraph_trijoinrecdata (A B C P : Type) : IsGraph (TriJoinRecData A B C P) := {| Hom := TriJoinRecPath |}. Global Instance is01cat_trijoinrecdata (A B C P : Type) : Is01Cat (TriJoinRecData A B C P). Proof. apply Build_Is01Cat. - intro f. bundle_trijoinrecpath. 1, 2, 3: reflexivity. intros a b c; cbn beta. (* Can finish with: [by triangle_ind f a b c.] *) unfold prism'. cbn. apply concat_p1_1p. - intros f1 f2 f3 k2 k1. snrapply Build_TriJoinRecPath; intros; cbn beta. + exact (h1 k1 a @ h1 k2 a). + exact (h2 k1 b @ h2 k2 b). + exact (h3 k1 c @ h3 k2 c). + (* Some simple path algebra works as well. *) prism_ind_two f3 k2 a b _X_. prism_ind_two f2 k1 a b _X_. by triangle_ind_two f1 a b _X_. + prism_ind_two f3 k2 a _X_ c. prism_ind_two f2 k1 a _X_ c. by triangle_ind_two f1 a _X_ c. + prism_ind_two f3 k2 _X_ b c. prism_ind_two f2 k1 _X_ b c. by triangle_ind_two f1 _X_ b c. + cbn beta. prism_ind f3 k2 a b c. prism_ind f2 k1 a b c. by triangle_ind f1 a b c. Defined. Global Instance is0gpd_trijoinrecdata (A B C P : Type) : Is0Gpd (TriJoinRecData A B C P). Proof. apply Build_Is0Gpd. intros f g h. snrapply Build_TriJoinRecPath; intros; cbn beta. + exact (h1 h a)^. + exact (h2 h b)^. + exact (h3 h c)^. + (* Some simple path algebra works as well. *) prism_ind_two g h a b _X_. by triangle_ind_two f a b _X_. + prism_ind_two g h a _X_ c. by triangle_ind_two f a _X_ c. + prism_ind_two g h _X_ b c. by triangle_ind_two f _X_ b c. + prism_ind g h a b c. by triangle_ind f a b c. Defined. Definition trijoinrecdata_0gpd (A B C P : Type) : ZeroGpd := Build_ZeroGpd (TriJoinRecData A B C P) _ _ _. (** ** [trijoinrecdata_0gpd A B C] is a 1-functor from [Type] to [ZeroGpd] It's a 1-functor that lands in [ZeroGpd], and the morphisms of [ZeroGpd] are 0-functors, so it's easy to get confused about the levels. *) (** First we need to show that the induced map is a morphism in [ZeroGpd], i.e. that it is a 0-functor. *) Global Instance is0functor_trijoinrecdata_fun {A B C P Q : Type} (g : P -> Q) : Is0Functor (@trijoinrecdata_fun A B C P Q g). Proof. apply Build_Is0Functor. intros f1 f2 h. snrapply Build_TriJoinRecPath; intros; cbn. 1, 2, 3: apply (ap g). 1: apply (h1 h). 1: apply (h2 h). 1: apply (h3 h). 1, 2, 3: refine ((ap_pp g _ _)^ @ _ @ ap_pp g _ _); apply (ap (ap g)). 1: apply (h12 h). (* Or: prism_ind_12 f2 h a b. triangle_ind_12 f1 a b. reflexivity. *) 1: apply (h13 h). 1: apply (h23 h). prism_ind f2 h a b c. triangle_ind f1 a b c; cbn. reflexivity. Defined. (** [trijoinrecdata_0gpd A B C] is a 0-functor from [Type] to [ZeroGpd] (one level up). *) Global Instance is0functor_trijoinrecdata_0gpd (A B C : Type) : Is0Functor (trijoinrecdata_0gpd A B C). Proof. apply Build_Is0Functor. intros P Q g. snrapply Build_Morphism_0Gpd. - exact (trijoinrecdata_fun g). - apply is0functor_trijoinrecdata_fun. Defined. (** [trijoinrecdata_0gpd A B C] is a 1-functor from [Type] to [ZeroGpd]. *) Global Instance is1functor_trijoinrecdata_0gpd (A B C : Type) : Is1Functor (trijoinrecdata_0gpd A B C). Proof. apply Build_Is1Functor. (* If [g1 g2 : P -> Q] are homotopic, then the induced maps are homotopic: *) - intros P Q g1 g2 h f; cbn in *. snrapply Build_TriJoinRecPath; intros; cbn. 1, 2, 3: apply h. 1, 2, 3: apply concat_Ap. triangle_ind f a b c; cbn. by induction (h f). (* The identity map [P -> P] is sent to a map homotopic to the identity. *) - intros P f; cbn. bundle_trijoinrecpath; intros; cbn. 1, 2, 3: apply ap_idmap. by triangle_ind f a b c. (* It respects composition. *) - intros P Q R g1 g2 f; cbn. bundle_trijoinrecpath; intros; cbn. 1, 2, 3: apply ap_compose. by triangle_ind f a b c. Defined. Definition trijoinrecdata_0gpd_fun (A B C : Type) : Fun11 Type ZeroGpd := Build_Fun11 _ _ (trijoinrecdata_0gpd A B C). (** By the Yoneda lemma, it follows from [TriJoinRecData] being a 1-functor that given [TriJoinRecData] in [J], we get a map [(J -> P) $-> (TriJoinRecData A B C P)] of 0-groupoids which is natural in [P]. Below we will specialize to the case where [J] is [TriJoin A B C] with the canonical [TriJoinRecData]. *) Definition trijoin_nattrans_recdata {A B C J : Type} (f : TriJoinRecData A B C J) : NatTrans (opyon_0gpd J) (trijoinrecdata_0gpd_fun A B C). Proof. snrapply Build_NatTrans. - rapply opyoneda_0gpd; exact f. - exact _. Defined. (** Thus we get a map [(TriJoin A B C -> P) $-> (TriJoinRecData A B C P)] of 0-groupoids, natural in [P]. The underlying map is [trijoin_rec_inv A B C P]. *) Definition trijoin_rec_inv_nattrans (A B C : Type) : NatTrans (opyon_0gpd (TriJoin A B C)) (trijoinrecdata_0gpd_fun A B C) := trijoin_nattrans_recdata (trijoinrecdata_trijoin A B C). (** This natural transformation is in fact a natural equivalence of 0-groupoids. *) Definition trijoin_rec_inv_natequiv (A B C : Type) : NatEquiv (opyon_0gpd (TriJoin A B C)) (trijoinrecdata_0gpd_fun A B C). Proof. snrapply Build_NatEquiv'. 1: apply trijoin_rec_inv_nattrans. intro P. apply isequiv_0gpd_issurjinj. apply Build_IsSurjInj. - intros f; cbn in f. exists (trijoin_rec f). apply trijoin_rec_beta. - exact (@isinj_trijoin_rec_inv A B C P). Defined. (** It will be handy to name the inverse natural equivalence. *) Definition trijoin_rec_natequiv (A B C : Type) := natequiv_inverse (trijoin_rec_inv_natequiv A B C). (** [trijoin_rec_natequiv A B C P] is an equivalence of 0-groupoids whose underlying function is definitionally [trijoin_rec]. *) Local Definition trijoin_rec_natequiv_check (A B C P : Type) : equiv_fun_0gpd (trijoin_rec_natequiv A B C P) = @trijoin_rec A B C P := idpath. (** It follows that [trijoin_rec A B C P] is a 0-functor. *) Global Instance is0functor_trijoin_rec (A B C P : Type) : Is0Functor (@trijoin_rec A B C P). Proof. change (Is0Functor (equiv_fun_0gpd (trijoin_rec_natequiv A B C P))). exact _. Defined. (** And that [trijoin_rec A B C] is natural. The [$==] in the statement is just [==], but we use WildCat notation so that we can invert and compose these with WildCat notation. *) Definition trijoin_rec_nat (A B C : Type) {P Q : Type} (g : P -> Q) (f : TriJoinRecData A B C P) : trijoin_rec (trijoinrecdata_fun g f) $== g o trijoin_rec f. Proof. exact (isnat (trijoin_rec_natequiv A B C) g f). Defined. (** It is also useful to record this. *) Definition issect_trijoin_rec_inv {A B C P : Type} (f : TriJoin A B C -> P) : trijoin_rec (trijoin_rec_inv f) $== f := cate_issect (trijoin_rec_inv_natequiv A B C P) f. (** This comes up a lot as well, and if you inline the proof, you get an ugly goal. *) Definition moveR_trijoin_rec {A B C P : Type} {f : TriJoinRecData A B C P} {g : TriJoin A B C -> P} (p : f $== trijoin_rec_inv g) : trijoin_rec f == g. Proof. exact (moveR_equiv_V_0gpd (trijoin_rec_inv_natequiv A B C P) _ _ p). Defined. (** * Functoriality of the triple join *) (** ** Precomposition of [TriJoinRecData] *) (** First observe that we can precompose [k : TriJoinRecData] with a triple of maps. *) Definition trijoinrecdata_tricomp {A B C A' B' C' P} (k : TriJoinRecData A B C P) (f : A' -> A) (g : B' -> B) (h : C' -> C) : TriJoinRecData A' B' C' P := {| j1 := j1 k o f; j2 := j2 k o g; j3 := j3 k o h; j12 := fun a b => j12 k (f a) (g b); j13 := fun a c => j13 k (f a) (h c); j23 := fun b c => j23 k (g b) (h c); j123 := fun a b c => j123 k (f a) (g b) (h c); |}. (** Precomposition with a triple respects paths. *) Definition trijoinrecdata_tricomp_0fun {A B C A' B' C' P} {k l : TriJoinRecData A B C P} (p : k $== l) (f : A' -> A) (g : B' -> B) (h : C' -> C) : trijoinrecdata_tricomp k f g h $== trijoinrecdata_tricomp l f g h. Proof. (* This line is not needed, but clarifies the proof. *) unfold trijoinrecdata_tricomp; destruct p. snrapply Build_TriJoinRecPath; intros; cbn; apply_hyp. (* E.g., the first goal is [j1 k (f a) = j1 l (f a)], and this is solved by [h1 p (f a)]. We just precompose all fields of [p] with [f], [g] and [h]. *) Defined. (** Homotopies between the triple are also respected. *) Definition trijoinrecdata_tricomp2 {A B C A' B' C' P} (k : TriJoinRecData A B C P) {f f' : A' -> A} {g g' : B' -> B} {h h' : C' -> C} (p : f == f') (q : g == g') (r : h == h') : trijoinrecdata_tricomp k f g h $== trijoinrecdata_tricomp k f' g' h'. Proof. snrapply Build_TriJoinRecPath; intros; cbn. - apply ap, p. - apply ap, q. - apply ap, r. - induction (p a), (q b); by apply equiv_p1_1q. - induction (p a), (r c); by apply equiv_p1_1q. - induction (q b), (r c); by apply equiv_p1_1q. - induction (p a), (q b), (r c); apply prism_id. Defined. (** ** Functoriality of [TriJoin] via [functor_trijoin] *) (** To define [functor_trijoin], we simply precompose the canonical [TriJoinRecData] with [f], [g] and [h]. For example, this has [j1 := join1 o f] and [j12 := fun a b => join12 (f a) (g b)]. *) Definition functor_trijoin {A B C A' B' C'} (f : A -> A') (g : B -> B') (h : C -> C') : TriJoin A B C -> TriJoin A' B' C' := trijoin_rec (trijoinrecdata_tricomp (trijoinrecdata_trijoin A' B' C') f g h). (** We use [functor_trijoin] to express a partial functoriality of [trijoin_rec] in [A], [B] and [C]. *) Definition trijoin_rec_functor_trijoin {A B C A' B' C' P} (k : TriJoinRecData A' B' C' P) (f : A -> A') (g : B -> B') (h : C -> C') : trijoin_rec k o functor_trijoin f g h == trijoin_rec (trijoinrecdata_tricomp k f g h). Proof. (* On the LHS, we use naturality of the [trijoin_rec] inside [functor_trijoin]: *) refine ((trijoin_rec_nat _ _ _ _ _)^$ $@ _). refine (fmap trijoin_rec _). (* Just to clarify to the reader what is going on: *) change (?L $-> ?R) with (trijoinrecdata_tricomp (trijoin_rec_inv (trijoin_rec k)) f g h $-> R). exact (trijoinrecdata_tricomp_0fun (trijoin_rec_beta k) f g h). Defined. (** Now we have all of the tools to efficiently prove functoriality. *) Definition functor_trijoin_compose {A B C A' B' C' A'' B'' C''} (f : A -> A') (g : B -> B') (h : C -> C') (f' : A' -> A'') (g' : B' -> B'') (h' : C' -> C'') : functor_trijoin (f' o f) (g' o g) (h' o h) == functor_trijoin f' g' h' o functor_trijoin f g h. Proof. symmetry. nrapply trijoin_rec_functor_trijoin. Defined. Definition functor_trijoin_idmap {A B C} : functor_trijoin idmap idmap idmap == (idmap : TriJoin A B C -> TriJoin A B C). Proof. apply moveR_trijoin_rec. change (trijoinrecdata_trijoin A B C $== trijoinrecdata_fun idmap (trijoinrecdata_trijoin A B C)). symmetry. exact (fmap_id (trijoinrecdata_0gpd A B C) _ (trijoinrecdata_trijoin A B C)). Defined. Definition functor2_trijoin {A B C A' B' C'} {f f' : A -> A'} {g g' : B -> B'} {h h' : C -> C'} (p : f == f') (q : g == g') (r : h == h') : functor_trijoin f g h == functor_trijoin f' g' h'. Proof. unfold functor_trijoin. rapply (fmap trijoin_rec). apply (trijoinrecdata_tricomp2 _ p q r). Defined. Global Instance isequiv_functor_trijoin {A B C A' B' C'} (f : A -> A') `{!IsEquiv f} (g : B -> B') `{!IsEquiv g} (h : C -> C') `{!IsEquiv h} : IsEquiv (functor_trijoin f g h). Proof. (* This proof is almost identical to the proof of [isequiv_functor_join]. *) snrapply isequiv_adjointify. - apply (functor_trijoin f^-1 g^-1 h^-1). - etransitivity. 1: symmetry; apply functor_trijoin_compose. etransitivity. 1: exact (functor2_trijoin (eisretr f) (eisretr g) (eisretr h)). apply functor_trijoin_idmap. - etransitivity. 1: symmetry; apply functor_trijoin_compose. etransitivity. 1: exact (functor2_trijoin (eissect f) (eissect g) (eissect h)). apply functor_trijoin_idmap. Defined. Definition equiv_functor_trijoin {A B C A' B' C'} (f : A <~> A') (g : B <~> B') (h : C <~> C') : TriJoin A B C <~> TriJoin A' B' C' := Build_Equiv _ _ (functor_trijoin f g h) _. (** ** The relationship between [functor_trijoin] and [functor_join]. *) (** While [functor_trijoin] is convenient to work with, we want to know that [functor_trijoin f g h] is homotopic to [functor_join f (functor_join g h)]. This is worked out using the next three results. *) (** A lemma that handles the path algebra in the next result. [BC] here is [Join B C] there, [bc] here is [jglue b c] there, [bc'] here is [jg g b c] there, and [beta_jg] here is [Join_rec_beta_jglue _ _ _ b c] there. *) Local Lemma ap_triangle_functor_join {A BC A' P} (f : A -> A') (g : BC -> P) (a : A) {b c : BC} (bc : b = c) (bc' : g b = g c) (beta_jg : ap g bc = bc') : ap_triangle (functor_join f g) (triangle_v a bc) @ functor_join_beta_jglue f g a c = (functor_join_beta_jglue f g a b @@ ((ap_compose joinr (functor_join f g) bc)^ @ (ap_compose g joinr bc @ ap (ap joinr) beta_jg))) @ triangle_v (f a) bc'. Proof. induction bc, beta_jg; simpl. transitivity (concat_p1 _ @ functor_join_beta_jglue f g a b). - refine (_ @@ 1). unfold ap_triangle. apply moveR_Vp; symmetry. exact (ap_pp_concat_p1 (functor_join f g) (jglue a b)). - apply moveR_Mp; symmetry. exact (concat_p_pp _ _ _ @ whiskerR_p1 _). Defined. (** We'll generalize the situation a bit to keep things less verbose. [join_rec g] here will be [functor_join g h] in the next result. Maybe this extra generality will also be useful sometime? *) Definition functor_join_join_rec {A B C A' P} (f : A -> A') (g : JoinRecData B C P) : functor_join f (join_rec g) == trijoin_rec {| j1 := joinl o f; j2 := joinr o jl g; j3 := joinr o jr g; j12 := fun a b => jglue (f a) (jl g b); j13 := fun a c => jglue (f a) (jr g c); j23 := fun b c => ap joinr (jg g b c); j123 := fun a b c => triangle_v (f a) (jg g b c); |}. Proof. (* Recall that [trijoin_rec] is defined to be the inverse of [trijoin_rec_inv_natequiv ...]. *) refine (moveL_equiv_V_0gpd (trijoin_rec_inv_natequiv A B C _) _ _ _). (* The next two lines aren't needed, but clarify the goal. *) unfold trijoin_rec_inv_natequiv, equiv_fun_0gpd; simpl. unfold trijoinrecdata_fun, trijoinrecdata_trijoin; simpl. bundle_trijoinrecpath; intros; cbn. - exact (functor_join_beta_jglue f _ a (joinl b)). - exact (functor_join_beta_jglue f _ a (joinr c)). - unfold join23. refine ((ap_compose joinr _ _)^ @ _). simpl. refine (ap_compose _ joinr (jglue b c) @ _). refine (ap (ap joinr) _). apply join_rec_beta_jg. - unfold prism'. change (join123 a b c) with (triangle_v a (jglue b c)). exact (ap_triangle_functor_join f (join_rec g) a (jglue b c) (jg g b c) (Join_rec_beta_jglue _ _ _ b c)). Defined. Definition functor_trijoin_as_functor_join {A B C A' B' C'} (f : A -> A') (g : B -> B') (h : C -> C') : functor_join f (functor_join g h) == functor_trijoin f g h := functor_join_join_rec f (functor_join_recdata g h). Coq-HoTT-9.0/theories/Homotopy/NullHomotopy.v000066400000000000000000000045601474641544500212430ustar00rootroot00000000000000Require Import HoTT.Basics. Require Import Types.Sigma. Local Open Scope path_scope. (** * Null homotopies of maps *) Section NullHomotopy. Context `{Funext}. (** Geometrically, a nullhomotopy of a map [f : X -> Y] is an extension of [f] to a map [Cone X -> Y]. One might more simply call it e.g. [Constant f], but that is a little ambiguous: it could also reasonably mean e.g. a factorisation of [f] through [ Trunc -1 X ]. (Should the unique map [0 -> Y] be constant in one way, or in [Y]-many ways?) *) Definition NullHomotopy {X Y : Type} (f : X -> Y) := {y : Y & forall x:X, f x = y}. Lemma istrunc_nullhomotopy {n : trunc_index} {X Y : Type} (f : X -> Y) `{IsTrunc n Y} : IsTrunc n (NullHomotopy f). Proof. apply @istrunc_sigma; auto. intros y. apply (@istrunc_forall _). intros x. apply istrunc_paths'. Defined. Definition nullhomotopy_homotopic {X Y : Type} {f g : X -> Y} (p : f == g) : NullHomotopy f -> NullHomotopy g. Proof. intros [y e]. exists y. intros x; exact ((p x)^ @ e x). Defined. Definition nullhomotopy_composeR {X Y Z : Type} (f : X -> Y) (g : Y -> Z) : NullHomotopy g -> NullHomotopy (g o f). Proof. intros [z e]. exists z. intros x; exact (e (f x)). Defined. Definition nullhomotopy_composeL {X Y Z : Type} (f : X -> Y) (g : Y -> Z) : NullHomotopy f -> NullHomotopy (g o f). Proof. intros [y e]. exists (g y). intros x; exact (ap g (e x)). Defined. Definition cancelL_nullhomotopy_equiv {X Y Z : Type} (f : X -> Y) (g : Y -> Z) `{IsEquiv _ _ g} : NullHomotopy (g o f) -> NullHomotopy f. Proof. intros [z e]. exists (g^-1 z). intros x; apply moveL_equiv_V, e. Defined. Definition cancelR_nullhomotopy_equiv {X Y Z : Type} (f : X -> Y) (g : Y -> Z) `{IsEquiv _ _ f} : NullHomotopy (g o f) -> NullHomotopy g. Proof. intros [z e]. exists z. intros y; transitivity (g (f (f^-1 y))). - symmetry; apply ap, eisretr. - apply e. Defined. Definition nullhomotopy_ap {X Y : Type} (f : X -> Y) (x1 x2 : X) : NullHomotopy f -> NullHomotopy (@ap _ _ f x1 x2). Proof. intros [y e]. unshelve eexists. - exact (e x1 @ (e x2)^). - intros p. apply moveL_pV. refine (concat_Ap e p @ _). refine (_ @ concat_p1 _); apply ap. apply ap_const. Defined. End NullHomotopy. Coq-HoTT-9.0/theories/Homotopy/PinSn.v000066400000000000000000000050331474641544500176150ustar00rootroot00000000000000Require Import Basics Types. Require Import WildCat. Require Import Pointed. Require Import Truncations.Core Truncations.Connectedness. Require Import Spaces.Int Spaces.Circle Spaces.Spheres. Require Import Algebra.AbGroups. Require Import Homotopy.HomotopyGroup. Require Import Homotopy.HSpaceS1. Require Import Homotopy.Hopf. (** * We show that the nth homotopy group of the n-sphere is the integers, for n >= 1. *) Local Open Scope wc_iso_scope. Local Open Scope pointed_scope. (** The fundamental group of the 1-sphere / circle. *) Section Pi1S1. Context `{Univalence}. Local Open Scope pointed_scope. Theorem pi1_circle : Pi 1 [Circle, base] ≅ abgroup_Z. Proof. (** We give the isomorphism backwards, so we check the operation is preserved coming from the integer side. *) symmetry. srapply Build_GroupIsomorphism'. { equiv_via (base = base). 2: exact (equiv_tr 0 (loops [Circle, base])). symmetry. exact equiv_loopCircle_int. } intros a b. cbn; apply ap. apply loopexp_add. Defined. Theorem pi1_s1 : Pi 1 (psphere 1) ≅ abgroup_Z. Proof. etransitivity. 2: apply pi1_circle. apply groupiso_pi_functor. apply pequiv_S1_Circle. Defined. End Pi1S1. (** The second homotopy group of the 2-sphere is the integers. *) Section Pi2S2. Definition ptr_loops_s2_s1 `{Univalence} : pTr 1 (loops (psphere 2)) <~>* psphere 1 := (licata_finster (psphere 1))^-1*. Definition pi2_s2 `{Univalence} : Pi 2 (psphere 2) $<~> abgroup_Z. Proof. refine (pi1_s1 $oE _). change (Pi 2 ?X) with (Pi 1 (loops X)). refine (compose_cate (b:=Pi 1 (pTr 1 (loops (psphere 2)))) _ _). 1: exact (emap (Pi 1) ptr_loops_s2_s1). apply grp_iso_pi_Tr. Defined. End Pi2S2. (** For n >= 1, the nth homotopy group of the n-sphere is the integers. *) Section PinSn. Definition pin_sn `{Univalence} (n : nat) : Pi n.+1 (psphere n.+1) $<~> abgroup_Z. Proof. destruct n. 1: exact pi1_s1. induction n as [|n IHn]. 1: exact pi2_s2. refine (_ $oE groupiso_pi_loops n.+1 (psphere n.+3)). refine (IHn $oE _). symmetry. snrapply (grp_iso_pi_connmap _ (loop_susp_unit (psphere n.+2))). (* The (n+2)-sphere is (n+1)-connected, so [loop_susp_unit] is [n +2+ n]-connected. Since [n.+2 <= n +2+ n], we're done, after some [trunc_index] juggling. *) apply (isconnmap_pred_add n.-2). rewrite 2 trunc_index_add_succ. change (IsConnMap (Tr (n +2+ n)) (loop_susp_unit (psphere n.+2))). exact _. (* [conn_map_loop_susp_unit] *) Defined. End PinSn. Coq-HoTT-9.0/theories/Homotopy/Smash.v000066400000000000000000000333261474641544500176470ustar00rootroot00000000000000Require Import Basics.Overture Basics.PathGroupoids Basics.Tactics Basics.Equivalences. Require Import Types.Sum Types.Bool Types.Paths Types.Forall. Require Import WildCat.Core WildCat.Bifunctor WildCat.Equiv. Require Import Colimits.Pushout. Require Import Cubical.DPath. Require Import Pointed.Core. Local Open Scope pointed_scope. Local Open Scope dpath_scope. Local Open Scope path_scope. (* Definition of smash product *) Definition sum_to_prod (X Y : pType) : X + Y -> X * Y := sum_ind _ (fun x => (x, point Y)) (fun y => (point X, y)). Definition sum_to_bool X Y : X + Y -> Bool := sum_ind _ (fun _ => false) (fun _ => true). Definition Smash@{u v w | u <= w, v <= w} (X : pType@{u}) (Y : pType@{v}) : pType@{w} := [Pushout@{w w w w} (sum_to_prod@{w w w} X Y) (sum_to_bool@{u v w} X Y), pushl (point X, point Y)]. Section Smash. Context {X Y : pType}. Definition sm (x : X) (y : Y) : Smash X Y := pushl (x, y). Definition auxl : Smash X Y := pushr false. Definition auxr : Smash X Y := pushr true. Definition gluel (x : X) : sm x pt = auxl := pglue (f:=sum_to_prod X Y) (g:=sum_to_bool X Y) (inl x). Definition gluer (y : Y) : sm pt y = auxr := pglue (f:=sum_to_prod X Y) (g:=sum_to_bool X Y) (inr y). Definition gluel' (x x' : X) : sm x pt = sm x' pt := gluel x @ (gluel x')^. Definition gluer' (y y' : Y) : sm pt y = sm pt y' := gluer y @ (gluer y')^. Definition glue (x : X) (y : Y) : sm x pt = sm pt y := gluel' x pt @ gluer' pt y. Definition glue_pt_left (y : Y) : glue pt y = gluer' pt y. Proof. refine (_ @ concat_1p _). apply whiskerR, concat_pV. Defined. Definition glue_pt_right (x : X) : glue x pt = gluel' x pt. Proof. refine (_ @ concat_p1 _). apply whiskerL, concat_pV. Defined. Definition ap_sm_left {x x' : X} (p : x = x') : ap (fun t => sm t pt) p = gluel' x x'. Proof. destruct p. symmetry. apply concat_pV. Defined. Definition ap_sm_right {y y' : Y} (p : y = y') : ap (sm pt) p = gluer' y y'. Proof. destruct p. symmetry. apply concat_pV. Defined. Definition Smash_ind {P : Smash X Y -> Type} (Psm : forall a b, P (sm a b)) (Pl : P auxl) (Pr : P auxr) (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl) (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) : forall x : Smash X Y, P x. Proof. srapply Pushout_ind. + intros [a b]. apply Psm. + apply (Bool_ind _ Pr Pl). + srapply sum_ind. - apply Pgl. - apply Pgr. Defined. Definition Smash_ind_beta_gluel {P : Smash X Y -> Type} {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr} (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl) (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a : X) : apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a := Pushout_ind_beta_pglue P _ _ _ (inl a). Definition Smash_ind_beta_gluer {P : Smash X Y -> Type} {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr} (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl) (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (b : Y) : apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b := Pushout_ind_beta_pglue P _ _ _ (inr b). Definition Smash_ind_beta_gluel' {P : Smash X Y -> Type} {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr} (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl) (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a b : X) : apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel' a b) = (Pgl a) @Dp ((Pgl b)^D). Proof. lhs nrapply dp_apD_pp. apply ap011. 1: apply Smash_ind_beta_gluel. lhs nrapply dp_apD_V. apply ap. apply Smash_ind_beta_gluel. Defined. Definition Smash_ind_beta_gluer' {P : Smash X Y -> Type} {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr} (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl) (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a b : Y) : apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer' a b) = (Pgr a) @Dp ((Pgr b)^D). Proof. lhs nrapply dp_apD_pp. apply ap011. 1: apply Smash_ind_beta_gluer. lhs nrapply dp_apD_V. apply ap. apply Smash_ind_beta_gluer. Defined. Definition Smash_ind_beta_glue {P : Smash X Y -> Type} {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr} (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl) (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a : X) (b : Y) : apD (Smash_ind Psm Pl Pr Pgl Pgr) (glue a b) = ((Pgl a) @Dp ((Pgl pt)^D)) @Dp ((Pgr pt) @Dp ((Pgr b)^D)). Proof. lhs nrapply dp_apD_pp. apply ap011. - apply Smash_ind_beta_gluel'. - apply Smash_ind_beta_gluer'. Defined. Definition Smash_rec {P : Type} (Psm : X -> Y -> P) (Pl Pr : P) (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) : Smash X Y -> P := Smash_ind Psm Pl Pr (fun x => dp_const (Pgl x)) (fun x => dp_const (Pgr x)). (* Version of smash_rec that forces (Pgl pt) and (Pgr pt) to be idpath *) Definition Smash_rec' {P : Type} {Psm : X -> Y -> P} (Pgl : forall a, Psm a pt = Psm pt pt) (Pgr : forall b, Psm pt b = Psm pt pt) (ql : Pgl pt = 1) (qr : Pgr pt = 1) : Smash X Y -> P := Smash_rec Psm (Psm pt pt) (Psm pt pt) Pgl Pgr. Definition Smash_rec_beta_gluel {P : Type} {Psm : X -> Y -> P} {Pl Pr : P} (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a : X) : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a. Proof. rhs_V nrapply (eissect dp_const). apply moveL_equiv_V. lhs_V nrapply dp_apD_const. nrapply Smash_ind_beta_gluel. Defined. Definition Smash_rec_beta_gluer {P : Type} {Psm : X -> Y -> P} {Pl Pr : P} (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (b : Y) : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b. Proof. rhs_V nrapply (eissect dp_const). apply moveL_equiv_V. lhs_V nrapply dp_apD_const. nrapply Smash_ind_beta_gluer. Defined. Definition Smash_rec_beta_gluel' {P : Type} {Psm : X -> Y -> P} {Pl Pr : P} (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a b : X) : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluel' a b) = Pgl a @ (Pgl b)^. Proof. lhs nrapply ap_pp. f_ap. 1: apply Smash_rec_beta_gluel. lhs nrapply ap_V. apply inverse2. apply Smash_rec_beta_gluel. Defined. Definition Smash_rec_beta_gluer' {P : Type} {Psm : X -> Y -> P} {Pl Pr : P} (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a b : Y) : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluer' a b) = Pgr a @ (Pgr b)^. Proof. lhs nrapply ap_pp. f_ap. 1: apply Smash_rec_beta_gluer. lhs nrapply ap_V. apply inverse2. apply Smash_rec_beta_gluer. Defined. Definition Smash_rec_beta_glue {P : Type} {Psm : X -> Y -> P} {Pl Pr : P} (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a : X) (b : Y) : ap (Smash_rec Psm Pl Pr Pgl Pgr) (glue a b) = ((Pgl a) @ (Pgl pt)^) @ (Pgr pt @ (Pgr b)^). Proof. lhs nrapply ap_pp. f_ap. - apply Smash_rec_beta_gluel'. - apply Smash_rec_beta_gluer'. Defined. End Smash. Arguments sm : simpl never. Arguments auxl : simpl never. Arguments gluel : simpl never. Arguments gluer : simpl never. (** ** Miscellaneous lemmas about Smash *) (** A version of [Smash_ind] specifically for proving that two functions from a [Smash] are homotopic. *) Definition Smash_ind_FlFr {A B : pType} {P : Type} (f g : Smash A B -> P) (Hsm : forall a b, f (sm a b) = g (sm a b)) (Hl : f auxl = g auxl) (Hr : f auxr = g auxr) (Hgluel : forall a, ap f (gluel a) @ Hl = Hsm a pt @ ap g (gluel a)) (Hgluer : forall b, ap f (gluer b) @ Hr = Hsm pt b @ ap g (gluer b)) : f == g. Proof. snrapply (Smash_ind Hsm Hl Hr). - intros a. nrapply transport_paths_FlFr'. exact (Hgluel a). - intros b. nrapply transport_paths_FlFr'. exact (Hgluer b). Defined. (** A version of [Smash_ind]j specifically for proving that the composition of two functions is the identity map. *) Definition Smash_ind_FFlr {A B : pType} {P : Type} (f : Smash A B -> P) (g : P -> Smash A B) (Hsm : forall a b, g (f (sm a b)) = sm a b) (Hl : g (f auxl) = auxl) (Hr : g (f auxr) = auxr) (Hgluel : forall a, ap g (ap f (gluel a)) @ Hl = Hsm a pt @ gluel a) (Hgluer : forall b, ap g (ap f (gluer b)) @ Hr = Hsm pt b @ gluer b) : g o f == idmap. Proof. snrapply (Smash_ind Hsm Hl Hr). - intros a. nrapply (transport_paths_FFlr' (f := f) (g := g)). exact (Hgluel a). - intros b. nrapply (transport_paths_FFlr' (f := f) (g := g)). exact (Hgluer b). Defined. (** ** Functoriality of the smash product *) Definition functor_smash {A B X Y : pType} (f : A $-> X) (g : B $-> Y) : Smash A B $-> Smash X Y. Proof. srapply Build_pMap. - snrapply (Smash_rec (fun a b => sm (f a) (g b)) auxl auxr). + intro a; cbn beta. rhs_V nrapply (gluel (f a)). exact (ap011 _ 1 (point_eq g)). + intro b; cbn beta. rhs_V nrapply (gluer (g b)). exact (ap011 _ (point_eq f) 1). - exact (ap011 _ (point_eq f) (point_eq g)). Defined. Definition functor_smash_idmap (X Y : pType) : functor_smash (@pmap_idmap X) (@pmap_idmap Y) $== pmap_idmap. Proof. snrapply Build_pHomotopy. { snrapply Smash_ind_FlFr. 1-3: reflexivity. - intros x. apply equiv_p1_1q. rhs nrapply ap_idmap. lhs nrapply Smash_rec_beta_gluel. apply concat_1p. - intros y. apply equiv_p1_1q. rhs nrapply ap_idmap. lhs nrapply Smash_rec_beta_gluer. apply concat_1p. } reflexivity. Defined. Definition functor_smash_compose {X Y A B C D : pType} (f : X $-> A) (g : Y $-> B) (h : A $-> C) (k : B $-> D) : functor_smash (h $o f) (k $o g) $== functor_smash h k $o functor_smash f g. Proof. pointed_reduce. snrapply Build_pHomotopy. { snrapply Smash_ind_FlFr. 1-3: reflexivity. - intros x. apply equiv_p1_1q. lhs nrapply Smash_rec_beta_gluel. symmetry. lhs nrapply (ap_compose (functor_smash _ _) _ (gluel x)). lhs nrapply ap. 2: nrapply Smash_rec_beta_gluel. lhs nrapply Smash_rec_beta_gluel. apply concat_1p. - intros y. apply equiv_p1_1q. lhs nrapply Smash_rec_beta_gluer. symmetry. lhs nrapply (ap_compose (functor_smash _ _) _ (gluer y)). lhs nrapply ap. 2: nrapply Smash_rec_beta_gluer. lhs nrapply Smash_rec_beta_gluer. apply concat_1p. } reflexivity. Defined. Definition functor_smash_homotopic {X Y A B : pType} {f h : X $-> A} {g k : Y $-> B} (p : f $== h) (q : g $== k) : functor_smash f g $== functor_smash h k. Proof. pointed_reduce. snrapply Build_pHomotopy. { snrapply Smash_ind_FlFr. 1: exact (fun x y => ap011 _ (p x) (q y)). 1,2: reflexivity. - intros x. lhs nrapply concat_p1. lhs nrapply Smash_rec_beta_gluel. rhs nrapply whiskerL. 2: nrapply Smash_rec_beta_gluel. simpl; induction (p x); simpl. rhs_V nrapply concat_pp_p. apply whiskerR. nrapply ap_pp. - intros y. lhs nrapply concat_p1. lhs nrapply Smash_rec_beta_gluer. rhs nrapply whiskerL. 2: nrapply Smash_rec_beta_gluer. simpl; induction (q y); simpl. rhs_V nrapply concat_pp_p. apply whiskerR. nrapply (ap011_pp _ _ _ 1 1). } exact (ap022 _ (concat_p1 (p pt))^ (concat_p1 (q pt))^ @ (concat_p1 _)^). Defined. Global Instance is0bifunctor_smash : Is0Bifunctor Smash. Proof. snrapply Build_Is0Bifunctor'. 1,2: exact _. nrapply Build_Is0Functor. intros [X Y] [A B] [f g]. exact (functor_smash f g). Defined. Global Instance is1bifunctor_smash : Is1Bifunctor Smash. Proof. snrapply Build_Is1Bifunctor'. snrapply Build_Is1Functor. - intros [X Y] [A B] [f g] [h i] [p q]. exact (functor_smash_homotopic p q). - intros [X Y]. exact (functor_smash_idmap X Y). - intros [X Y] [A B] [C D] [f g] [h i]. exact (functor_smash_compose f g h i). Defined. (** ** Symmetry of the smash product *) Definition pswap (X Y : pType) : Smash X Y $-> Smash Y X := Build_pMap _ _ (Smash_rec (flip sm) auxr auxl gluer gluel) 1. Definition pswap_pswap {X Y : pType} : pswap X Y $o pswap Y X $== pmap_idmap. Proof. snrapply Build_pHomotopy. - snrapply Smash_ind_FFlr. 1-3: reflexivity. + intros y. apply equiv_p1_1q. lhs nrapply ap. 1: apply Smash_rec_beta_gluel. nrapply Smash_rec_beta_gluer. + intros x. apply equiv_p1_1q. lhs nrapply ap. 1: apply Smash_rec_beta_gluer. nrapply Smash_rec_beta_gluel. - reflexivity. Defined. Definition pequiv_pswap {X Y : pType} : Smash X Y $<~> Smash Y X. Proof. snrapply cate_adjointify. 1,2: exact (pswap _ _). 1,2: exact pswap_pswap. Defined. Definition pswap_natural {A B X Y : pType} (f : A $-> X) (g : B $-> Y) : pswap X Y $o functor_smash f g $== functor_smash g f $o pswap A B. Proof. pointed_reduce. snrapply Build_pHomotopy. - snrapply Smash_ind_FlFr. 1-3: reflexivity. + intros a. apply equiv_p1_1q. rhs nrapply (ap_compose (pswap _ _) _ (gluel a)). rhs nrapply ap. 2: apply Smash_rec_beta_gluel. rhs nrapply Smash_rec_beta_gluer. lhs nrapply (ap_compose (functor_smash _ _) (pswap _ _) (gluel a)). lhs nrapply ap. 1: apply Smash_rec_beta_gluel. simpl. lhs nrapply ap. 1: apply concat_1p. rhs nrapply concat_1p. nrapply Smash_rec_beta_gluel. + intros b. apply equiv_p1_1q. rhs nrapply (ap_compose (pswap _ _) (functor_smash _ _) (gluer b)). rhs nrapply ap. 2: apply Smash_rec_beta_gluer. rhs nrapply Smash_rec_beta_gluel. lhs nrapply (ap_compose (functor_smash _ _) (pswap _ _) (gluer b)). lhs nrapply ap. 1: apply Smash_rec_beta_gluer. lhs nrapply ap. 1: apply concat_1p. rhs nrapply concat_1p. nrapply Smash_rec_beta_gluer. - reflexivity. Defined. Coq-HoTT-9.0/theories/Homotopy/SuccessorStructure.v000066400000000000000000000157211474641544500224650ustar00rootroot00000000000000Require Import Basics. Require Import Nat.Core. Require Import Spaces.Int. Require Import Spaces.Finite.Fin. Require Import WildCat.Core. Local Set Universe Minimization ToSet. (** * Successor Structures. *) (** A successor structure is just a type with a endofunctor on it, called 'successor'. Typical examples include either the integers or natural numbers with the successor (or predecessor) operation. *) Record SuccStr : Type := { ss_carrier :> Type ; ss_succ : ss_carrier -> ss_carrier ; }. Declare Scope succ_scope. Local Open Scope nat_scope. Local Open Scope type_scope. Local Open Scope succ_scope. Delimit Scope succ_scope with succ. Arguments ss_succ {_} _. Notation "x .+1" := (ss_succ x) : succ_scope. (** Successor structure of naturals *) Definition NatSucc : SuccStr := Build_SuccStr nat nat_succ. (** Successor structure of integers *) Definition BinIntSucc : SuccStr := Build_SuccStr Int int_succ. Notation "'+N'" := NatSucc : succ_scope. Notation "'+Z'" := BinIntSucc : succ_scope. (** Stratified successor structures *) (** If [N] has a successor structure, then so does the product [N * Fin n]. The successor operation increases the second factor, and if it wraps around, it also increases the first factor. *) Definition StratifiedType (N : SuccStr) (n : nat) := N * Fin n. Definition stratified_succ (N : SuccStr) (n : nat) (x : StratifiedType N n) : StratifiedType N n. Proof. constructor. + destruct n. - exact (Empty_rec _ (snd x)). - destruct (dec (snd x = inr tt)). * exact (ss_succ (fst x)). * exact (fst x). + exact (fsucc_mod (snd x)). Defined. Definition Stratified (N : SuccStr) (n : nat) : SuccStr := Build_SuccStr (StratifiedType N n) (stratified_succ N n). (** Addition in successor structures *) Definition ss_add {N : SuccStr} (n : N) (k : nat) : N := nat_iter k ss_succ n. Infix "+" := ss_add : succ_scope. Definition ss_add_succ {N : SuccStr} (n : N) (k : nat) : n + k.+1 = n.+1 + k := nat_iter_succ_r k ss_succ n. Definition ss_add_sum {N : SuccStr} (n : N) (k l : nat) : n + (k + l) = (n + l) + k := nat_iter_add k l ss_succ n. (** Nat and Int segmented by triples *) Notation "'N3'" := (Stratified (+N) 3) : succ_scope. Notation "'Z3'" := (Stratified (+Z) 3) : succ_scope. (** ** Category of successor structures *) (** Inspired by the construction of the wildcat structure on pType, we can give SuccStr a wildcat structure in a similar manner (all the way up). *) Record ssFam (A : SuccStr) := { ss_fam :> A -> Type; dss_succ {x} : ss_fam x -> ss_fam (x.+1); }. Arguments ss_fam {_ _} _. Arguments dss_succ {_ _ _}. Record ssForall {A : SuccStr} (B : ssFam A) := { ss_fun :> forall x, B x; ss_fun_succ : forall x, ss_fun x.+1 = dss_succ (ss_fun x); }. Arguments ss_fun {_ _} _ _. Arguments ss_fun_succ {_ _} _ _. Definition ssfam_const {A : SuccStr} (B : SuccStr) : ssFam A := Build_ssFam A (fun _ => B) (fun _ => ss_succ). Definition ssfam_sshomotopy {A : SuccStr} {P : ssFam A} (f g : ssForall P) : ssFam A. Proof. snrapply Build_ssFam. 1: exact (fun x => f x = g x). cbn; intros x p. refine (ss_fun_succ f x @ ap dss_succ p @ (ss_fun_succ g x)^). Defined. Definition ssHomotopy {A : SuccStr} {P : ssFam A} (f g : ssForall P) := ssForall (ssfam_sshomotopy f g). Global Instance isgraph_ss : IsGraph SuccStr. Proof. snrapply Build_IsGraph. intros X Y. exact (@ssForall X (ssfam_const Y)). Defined. Global Instance isgraph_ssforall {A : SuccStr} (P : ssFam A) : IsGraph (ssForall P). Proof. snrapply Build_IsGraph. exact ssHomotopy. Defined. Global Instance is2graph_ssforall {A : SuccStr} (P : ssFam A) : Is2Graph (ssForall P) := {}. Global Instance is2graph_ss : Is2Graph SuccStr := {}. Global Instance is3graph_ss : Is3Graph SuccStr := {}. Ltac sselim_elim eq x := match type of (eq x) with | ?lhs = _ => generalize dependent (eq x); generalize dependent lhs | _ => fail "sselim: no lhs found" end. Ltac sselim f := let eq := fresh "eq" in destruct f as [f eq]; cbn in *; match type of eq with | forall x : ?X, _ = _ => multimatch goal with | x : X |- _ => sselim_elim eq x | f : ?Y -> X |- _ => match goal with | y : Y |- _ => sselim_elim eq (f y) | g : ?Z -> Y |- _ => match goal with | z : Z |- _ => sselim_elim eq (f (g z)) end end | _ => fail "sselim: no hyp found" end | _ => fail "sselim: no eq found" end; nrapply paths_ind_r; try clear eq; try clear f. Tactic Notation "sselim" constr(x0) := sselim x0. Tactic Notation "sselim" constr(x0) constr(x1) := sselim x0; sselim x1. Tactic Notation "sselim" constr(x0) constr(x1) constr(x2) := sselim x0; sselim x1 x2. Tactic Notation "sselim" constr(x0) constr(x1) constr(x2) constr(x3) := sselim x0; sselim x1 x2 x3. Tactic Notation "sselim" constr(x0) constr(x1) constr(x2) constr(x3) constr(x4) := sselim x0; sselim x1 x2 x3 x4. Tactic Notation "sselim" constr(x0) constr(x1) constr(x2) constr(x3) constr(x4) constr(x5) := sselim x0; sselim x1 x2 x3 x4 x5. Tactic Notation "sselim" constr(x0) constr(x1) constr(x2) constr(x3) constr(x4) constr(x5) constr(x6) := sselim x0; sselim x1 x2 x3 x4 x5 x6. Global Instance is01cat_ss : Is01Cat SuccStr. Proof. snrapply Build_Is01Cat. - intro X. snrapply Build_ssForall. + exact (fun x => x). + reflexivity. - intros X Y Z f g. snrapply Build_ssForall. + intro x. exact (f (g x)). + intro x. exact (ap f (ss_fun_succ g x) @ ss_fun_succ f (g x)). Defined. Global Instance is01cat_ssforall {A : SuccStr} (P : ssFam A) : Is01Cat (ssForall P). Proof. snrapply Build_Is01Cat. - intro f. snrapply Build_ssForall. + reflexivity. + intro x; simpl. by destruct (ss_fun_succ f x). - intros f g h p q. snrapply Build_ssForall. + intro x. exact (q x @ p x). + intro x; cbn. sselim p q f g h. simpl. by destruct (p x), (q x). Defined. Global Instance is0gpd_ssforall {A : SuccStr} (P : ssFam A) : Is0Gpd (ssForall P). Proof. snrapply Build_Is0Gpd. intros f g p. snrapply Build_ssForall. - intro x. exact (p x)^. - intro x; cbn. sselim p f g. by destruct (p x). Defined. Global Instance is1cat_ss : Is1Cat SuccStr. Proof. snrapply Build_Is1Cat'. 1,2: exact _. - intros X Y Z g. snrapply Build_Is0Functor. intros f h p. snrapply Build_ssForall. + intro x. exact (ap g (p x)). + intro x; cbn. sselim p f h. destruct (p x); clear p; simpl. sselim g. by destruct (eq (f x)). - intros X Y Z g. snrapply Build_Is0Functor. intros f h q. snrapply Build_ssForall. + intros x. apply q. + intros x; cbn. by sselim g q f h. - intros X Y Z W f g h. srapply Build_ssForall. + intro x. reflexivity. + intro x; cbn. by sselim f g h. - intros X Y f. srapply Build_ssForall. 1: reflexivity. intros x. by sselim f. - intros X Y f. srapply Build_ssForall. 1: reflexivity. intros x. by sselim f. Defined. Coq-HoTT-9.0/theories/Homotopy/Suspension.v000066400000000000000000000532121474641544500207360ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Cubical.DPath Cubical.DPathSquare. Require Import WildCat. Require Import Colimits.Pushout. Require Import Homotopy.NullHomotopy. Require Import Truncations.Core. Require Import Modalities.Modality. Require Import Extensions. (** * The suspension of a type *) Generalizable Variables X A B f g n. Local Open Scope path_scope. (* ** Definition of suspension *) (** We define the suspension of a type X as the pushout of 1 <- X -> 1 *) Definition Susp (X : Type) := Pushout@{_ Set Set _} (const_tt X) (const_tt X). Definition North {X} : Susp X := pushl tt. Definition South {X} : Susp X := pushr tt. Definition merid {X} (x : X) : North = South := pglue x. (** We think of this as the HIT with two points [North] and [South] and a path [merid] between them *) (** We can derive an induction principle for the suspension *) Definition Susp_ind {X : Type} (P : Susp X -> Type) (H_N : P North) (H_S : P South) (H_merid : forall x:X, (merid x) # H_N = H_S) : forall (y : Susp X), P y. Proof. srapply Pushout_ind. - exact (Unit_ind H_N). - exact (Unit_ind H_S). - exact (H_merid). Defined. (** We can also derive the computation rule *) Definition Susp_ind_beta_merid {X : Type} (P : Susp X -> Type) (H_N : P North) (H_S : P South) (H_merid : forall x:X, (merid x) # H_N = H_S) (x : X) : apD (Susp_ind P H_N H_S H_merid) (merid x) = H_merid x. Proof. srapply Pushout_ind_beta_pglue. Defined. (** We want to allow the user to forget that we've defined suspension as a pushout and make it look like it was defined directly as a HIT. This has the advantage of not having to assume any new HITs but allowing us to have conceptual clarity. *) Arguments Susp : simpl never. Arguments North : simpl never. Arguments South : simpl never. Arguments merid : simpl never. Arguments Susp_ind_beta_merid : simpl never. (** A version of [Susp_ind] specifically for proving that two functions defined on a suspension are homotopic. *) Definition Susp_ind_FlFr {X Y : Type} (f g : Susp X -> Y) (HN : f North = g North) (HS : f South = g South) (Hmerid : forall x, ap f (merid x) @ HS = HN @ ap g (merid x)) : f == g. Proof. snrapply (Susp_ind _ HN HS). intros x. nrapply transport_paths_FlFr'. exact (Hmerid x). Defined. (** A version of [Susp_ind] specifically for proving that the composition of two functions to and from a suspension are homotopic to the identity map. *) Definition Susp_ind_FFlr {X Y : Type} (f : Susp X -> Y) (g : Y -> Susp X) (HN : g (f North) = North) (HS : g (f South) = South) (Hmerid : forall x, ap g (ap f (merid x)) @ HS = HN @ merid x) : g o f == idmap. Proof. snrapply (Susp_ind _ HN HS). intros x. snrapply (transport_paths_FFlr' (f:=f) (g:=g)). exact (Hmerid x). Defined. Definition Susp_ind_FFlFr {X Y Z : Type} (f : Susp X -> Y) (g : Y -> Z) (h : Susp X -> Z) (HN : g (f North) = h North) (HS : g (f South) = h South) (Hmerid : forall x, ap g (ap f (merid x)) @ HS = HN @ ap h (merid x)) : g o f == h. Proof. snrapply (Susp_ind _ HN HS). intros x. snrapply (transport_paths_FFlFr' (f:=f) (g:=g) (h:=h)). exact (Hmerid x). Defined. (** A version of [Susp_ind] specifically for proving a composition square from a suspension. *) Definition Susp_ind_FFlFFr {X Y Y' Z : Type} (f : Susp X -> Y) (f' : Susp X -> Y') (g : Y -> Z) (g' : Y' -> Z) (HN : g (f North) = g' (f' North)) (HS : g (f South) = g' (f' South)) (Hmerid : forall x, ap g (ap f (merid x)) @ HS = HN @ ap g' (ap f' (merid x))) : g o f == g' o f'. Proof. snrapply (Susp_ind _ HN HS). intros x. snrapply (transport_paths_FFlFFr' (f:=f) (f':=f') (g:=g) (g':=g')). exact (Hmerid x). Defined. (* ** Non-dependent eliminator. *) Definition Susp_rec {X Y : Type} (H_N H_S : Y) (H_merid : X -> H_N = H_S) : Susp X -> Y := Pushout_rec (f:=const_tt X) (g:=const_tt X) Y (Unit_ind H_N) (Unit_ind H_S) H_merid. Global Arguments Susp_rec {X Y}%_type_scope H_N H_S H_merid%_function_scope _. Definition Susp_rec_beta_merid {X Y : Type} {H_N H_S : Y} {H_merid : X -> H_N = H_S} (x:X) : ap (Susp_rec H_N H_S H_merid) (merid x) = H_merid x. Proof. srapply Pushout_rec_beta_pglue. Defined. (** ** Eta-rule. *) (** The eta-rule for suspension states that any function out of a suspension is equal to one defined by [Susp_ind] in the obvious way. We give it first in a weak form, producing just a pointwise equality, and then turn this into an actual equality using [Funext]. *) Definition Susp_ind_eta_homotopic {X : Type} {P : Susp X -> Type} (f : forall y, P y) : f == Susp_ind P (f North) (f South) (fun x => apD f (merid x)). Proof. unfold pointwise_paths. refine (Susp_ind _ 1 1 _). intros x. refine (transport_paths_FlFr_D (g := Susp_ind P (f North) (f South) (fun x : X => apD f (merid x))) _ _ @ _); simpl. apply moveR_pM. apply equiv_p1_1q. apply ap, inverse. refine (Susp_ind_beta_merid _ _ _ _ _). Defined. Definition Susp_rec_eta_homotopic {X Y : Type} (f : Susp X -> Y) : f == Susp_rec (f North) (f South) (fun x => ap f (merid x)). Proof. snrapply Susp_ind_FlFr. 1, 2: reflexivity. intro x. apply equiv_p1_1q. exact (Susp_rec_beta_merid _)^. Defined. Definition Susp_ind_eta `{Funext} {X : Type} {P : Susp X -> Type} (f : forall y, P y) : f = Susp_ind P (f North) (f South) (fun x => apD f (merid x)) := path_forall _ _ (Susp_ind_eta_homotopic f). Definition Susp_rec_eta `{Funext} {X Y : Type} (f : Susp X -> Y) : f = Susp_rec (f North) (f South) (fun x => ap f (merid x)) := path_forall _ _ (Susp_rec_eta_homotopic f). (** ** Functoriality *) Definition functor_susp {X Y : Type} (f : X -> Y) : Susp X -> Susp Y. Proof. srapply Susp_rec. - exact North. - exact South. - intros x; exact (merid (f x)). Defined. Definition functor_susp_beta_merid {X Y : Type} (f : X -> Y) (x : X) : ap (functor_susp f) (merid x) = merid (f x). Proof. srapply Susp_rec_beta_merid. Defined. Definition functor_susp_compose {X Y Z} (f : X -> Y) (g : Y -> Z) : functor_susp (g o f) == functor_susp g o functor_susp f. Proof. snrapply Susp_ind_FlFr. 1,2: reflexivity. intro x. apply equiv_p1_1q. lhs nrapply functor_susp_beta_merid; symmetry. lhs nrefine (ap_compose (functor_susp f) _ (merid x)). lhs nrefine (ap _ (functor_susp_beta_merid _ _)). apply functor_susp_beta_merid. Defined. Definition functor_susp_idmap {X} : functor_susp idmap == (idmap : Susp X -> Susp X). Proof. snrapply Susp_ind_FlFr. 1,2: reflexivity. intro x. apply equiv_p1_1q. lhs nrapply functor_susp_beta_merid. symmetry; apply ap_idmap. Defined. Definition functor2_susp {X Y} {f g : X -> Y} (h : f == g) : functor_susp f == functor_susp g. Proof. srapply Susp_ind_FlFr. 1, 2: reflexivity. intro x. apply equiv_p1_1q. lhs nrapply (functor_susp_beta_merid f). rhs nrapply (functor_susp_beta_merid g). apply ap, h. Defined. Global Instance is0functor_susp : Is0Functor Susp := Build_Is0Functor _ _ _ _ Susp (@functor_susp). Global Instance is1functor_susp : Is1Functor Susp := Build_Is1Functor _ _ _ _ _ _ _ _ _ _ Susp _ (@functor2_susp) (@functor_susp_idmap) (@functor_susp_compose). (** ** Universal property *) Definition equiv_Susp_rec `{Funext} (X Y : Type) : (Susp X -> Y) <~> { NS : Y * Y & X -> fst NS = snd NS }. Proof. snrapply equiv_adjointify. - intros f. exists (f North, f South). intros x; exact (ap f (merid x)). - intros [[N S] m]. exact (Susp_rec N S m). - intros [[N S] m]. apply ap, path_arrow. intros x; apply Susp_rec_beta_merid. - intros f. symmetry; apply Susp_rec_eta. Defined. (** Using wild 0-groupoids, the universal property can be proven without funext. A simple equivalence of 0-groupoids between [Susp X -> Y] and [{ NS : Y * Y & X -> fst NS = snd NS }] would not carry all the higher-dimensional information, but if we generalize it to dependent functions, then it does suffice. *) Section UnivProp. Context (X : Type) (P : Susp X -> Type). (** Here is the domain of the equivalence: sections of [P] over [Susp X]. *) Definition Susp_ind_type := forall z:Susp X, P z. (** [isgraph_paths] is not a global instance, so we define this by hand. The fact that this is a 01cat and a 0gpd is obtained using global instances. *) Local Instance isgraph_Susp_ind_type : IsGraph Susp_ind_type. Proof. apply isgraph_forall; intros; apply isgraph_paths. Defined. (** The codomain is a sigma-groupoid of this family, consisting of input data for [Susp_ind]. *) Definition Susp_ind_data' (NS : P North * P South) := forall x:X, DPath P (merid x) (fst NS) (snd NS). (** Again, the rest of the wild category structure is obtained using global instances. *) Local Instance isgraph_Susp_ind_data' NS : IsGraph (Susp_ind_data' NS). Proof. apply isgraph_forall; intros; apply isgraph_paths. Defined. (** Here is the codomain itself. This is a 01cat and a 0gpd via global instances. *) Definition Susp_ind_data := sig Susp_ind_data'. (** Here is the functor. *) Definition Susp_ind_inv : Susp_ind_type -> Susp_ind_data. Proof. intros f. exists (f North,f South). intros x. exact (apD f (merid x)). Defined. Local Instance is0functor_susp_ind_inv : Is0Functor Susp_ind_inv. Proof. constructor; unfold Susp_ind_type; cbn. intros f g p. unshelve econstructor. - apply path_prod; apply p. - intros x. rewrite transport_path_prod, !transport_forall_constant; cbn. apply ds_transport_dpath. exact (dp_apD_nat p (merid x)). Defined. (** And now we can prove that it's an equivalence of 0-groupoids, using the definition from WildCat/EquivGpd. *) Definition issurjinj_Susp_ind_inv : IsSurjInj Susp_ind_inv. Proof. constructor. - intros [[n s] g]. exists (Susp_ind P n s g); cbn. exists idpath. intros x; cbn. apply Susp_ind_beta_merid. - intros f g [p q]; cbn in *. srapply Susp_ind; cbn. 1: exact (ap fst p). 1: exact (ap snd p). intros x; specialize (q x). apply ds_dp. apply ds_transport_dpath. rewrite transport_forall_constant in q. rewrite <- (eta_path_prod p) in q. rewrite transport_path_prod in q. exact q. Defined. End UnivProp. (** The full non-funext version of the universal property should be formulated with respect to a notion of "wild hom-oo-groupoid", which we don't currently have. However, we can deduce statements about full higher universal properties that we do have, for instance the statement that a type is local for [functor_susp f] -- expressed in terms of [ooExtendableAlong] -- if and only if all its identity types are local for [f]. (We will use this in [Modalities.Localization] for separated subuniverses.) To prove this, we again generalize it to the case of dependent types, starting with naturality of the above 0-dimensional universal property. *) Section UnivPropNat. (** We will show that [Susp_ind_inv] for [X] and [Y] commute with precomposition with [f] and [functor_susp f]. *) Context {X Y : Type} (f : X -> Y) (P : Susp Y -> Type). (** We recall these instances from the previous section. *) Local Existing Instances isgraph_Susp_ind_type isgraph_Susp_ind_data'. (** Here is an intermediate family of groupoids that we have to use, since precomposition with [f] doesn't land in quite the right place. *) Definition Susp_ind_data'' (NS : P North * P South) := forall x:X, DPath P (merid (f x)) (fst NS) (snd NS). (** This is a 01cat and a 0gpd via global instances. *) Local Instance isgraph_Susp_ind_data'' NS : IsGraph (Susp_ind_data'' NS). Proof. apply isgraph_forall; intros; apply isgraph_paths. Defined. (** We decompose "precomposition with [f]" into a functor_sigma of two fiberwise functors. Here is the first. *) Definition functor_Susp_ind_data'' (NS : P North * P South) : Susp_ind_data' Y P NS -> Susp_ind_data'' NS := fun g x => g (f x). Local Instance is0functor_functor_Susp_ind_data'' NS : Is0Functor (functor_Susp_ind_data'' NS). Proof. constructor. intros g h p a. exact (p (f a)). Defined. (** And here is the second. This one is actually a fiberwise equivalence of types at each [x]. *) Definition equiv_Susp_ind_data' (NS : P North * P South) (x : X) : DPath P (merid (f x)) (fst NS) (snd NS) <~> DPath (P o functor_susp f) (merid x) (fst NS) (snd NS). Proof. etransitivity. - nrapply (equiv_transport (fun p => DPath P p (fst NS) (snd NS))). symmetry; apply functor_susp_beta_merid. - symmetry. apply (dp_compose (functor_susp f) P (merid x)). Defined. Definition functor_Susp_ind_data' (NS : P North * P South) : Susp_ind_data'' NS -> Susp_ind_data' X (P o functor_susp f) NS. Proof. srapply (functor_forall idmap); intros x. apply equiv_Susp_ind_data'. Defined. Local Instance is0functor_functor_Susp_ind_data' NS : Is0Functor (functor_Susp_ind_data' NS). Proof. constructor. intros g h q x. cbn; apply ap, ap. exact (q x). Defined. (** And therefore a fiberwise equivalence of 0-groupoids. *) Local Instance issurjinj_functor_Susp_ind_data' NS : IsSurjInj (functor_Susp_ind_data' NS). Proof. constructor. - intros g. unshelve econstructor. + intros x. apply ((equiv_Susp_ind_data' NS x)^-1). exact (g x). + intros x. apply eisretr. - intros g h p x. apply (equiv_inj (equiv_Susp_ind_data' NS x)). exact (p x). Defined. (** Now we put them together. *) Definition functor_Susp_ind_data : Susp_ind_data Y P -> Susp_ind_data X (P o functor_susp f) := fun NSg => (NSg.1 ; (functor_Susp_ind_data' NSg.1 o (functor_Susp_ind_data'' NSg.1)) NSg.2). Local Instance is0functor_functor_Susp_ind_data : Is0Functor functor_Susp_ind_data. Proof. refine (is0functor_sigma _ _ (fun NS => functor_Susp_ind_data' NS o functor_Susp_ind_data'' NS)). Defined. (** Here is the "precomposition with [functor_susp f]" functor. *) Definition functor_Susp_ind_type : Susp_ind_type Y P -> Susp_ind_type X (P o functor_susp f) := fun g => g o functor_susp f. Local Instance is0functor_functor_Susp_ind_type : Is0Functor functor_Susp_ind_type. Proof. constructor. intros g h p a. exact (p (functor_susp f a)). Defined. (** And here is the desired naturality square. *) Definition Susp_ind_inv_nat : (Susp_ind_inv X (P o functor_susp f)) o functor_Susp_ind_type $=> functor_Susp_ind_data o (Susp_ind_inv Y P). Proof. intros g; exists idpath; intros x. change (apD (fun x0 : Susp X => g (functor_susp f x0)) (merid x) = (functor_Susp_ind_data (Susp_ind_inv Y P g)).2 x). refine (dp_apD_compose (functor_susp f) P (merid x) g @ _). cbn; apply ap. apply (moveL_transport_V (fun p => DPath P p (g North) (g South))). exact (apD (apD g) (functor_susp_beta_merid f x)). Defined. (** From this we can deduce a equivalence between extendability, which is definitionally equal to split essential surjectivity of a functor between forall 0-groupoids. *) Definition extension_iff_functor_susp : (forall g, ExtensionAlong (functor_susp f) P g) <-> (forall NS g, ExtensionAlong f (fun x => DPath P (merid x) (fst NS) (snd NS)) g). Proof. (** The proof is by chaining logical equivalences. *) transitivity (SplEssSurj functor_Susp_ind_type). { reflexivity. } etransitivity. { refine (isesssurj_iff_commsq Susp_ind_inv_nat); try exact _. all:apply issurjinj_Susp_ind_inv. } etransitivity. { refine (isesssurj_iff_sigma _ _ (fun NS => functor_Susp_ind_data' NS o functor_Susp_ind_data'' NS)). } apply iff_functor_forall; intros [N S]; cbn. etransitivity. { apply iffL_isesssurj; exact _. } reflexivity. Defined. (** We have to close the section now because we have to generalize [extension_iff_functor_susp] over [P]. *) End UnivPropNat. (** Now we can iterate, deducing [n]-extendability. *) Definition extendable_iff_functor_susp {X Y : Type} (f : X -> Y) (P : Susp Y -> Type) (n : nat) : (ExtendableAlong n (functor_susp f) P) <-> (forall NS, ExtendableAlong n f (fun x => DPath P (merid x) (fst NS) (snd NS))). Proof. revert P. induction n as [|n IHn]; intros P; [ split; intros; exact tt | ]. (** It would be nice to be able to do this proof by chaining logical equivalences too, especially since the two parts seem very similar. But I haven't managed to make that work. *) split. - intros [e1 en] [N S]; split. + apply extension_iff_functor_susp. exact e1. + cbn; intros h k. pose (h' := Susp_ind P N S h). pose (k' := Susp_ind P N S k). specialize (en h' k'). assert (IH := fst (IHn _) en (1,1)); clear IHn en. cbn in IH. refine (extendable_postcompose' n _ _ f _ IH); clear IH. intros y. etransitivity. 1: nrapply ds_dp. etransitivity. 1: apply ds_transport_dpath. subst h' k'; cbn. apply equiv_concat_lr. * symmetry. exact (Susp_ind_beta_merid P N S h y). * exact (Susp_ind_beta_merid P N S k y). - intros e; split. + apply extension_iff_functor_susp. intros NS; exact (fst (e NS)). + intros h k. apply (IHn _). intros [p q]. specialize (e (h North, k South)). cbn in *; apply snd in e. refine (extendable_postcompose' n _ _ f _ (e _ _)); intros y. symmetry. etransitivity. 1: nrapply ds_dp. etransitivity. 1: apply ds_transport_dpath. etransitivity. 1: reflexivity. symmetry. apply (equiv_moveR_transport_p (fun y0 : P North => DPath P (merid y) y0 (k South))). Defined. (** As usual, deducing oo-extendability is trivial. *) Definition ooextendable_iff_functor_susp {X Y : Type} (f : X -> Y) (P : Susp Y -> Type) : (ooExtendableAlong (functor_susp f) P) <-> (forall NS, ooExtendableAlong f (fun x => DPath P (merid x) (fst NS) (snd NS))). Proof. split; intros e. - intros NS n. apply extendable_iff_functor_susp. exact (e n). - intros n. apply extendable_iff_functor_susp. intros NS; exact (e NS n). Defined. (** ** Nullhomotopies of maps out of suspensions *) Definition nullhomot_susp_from_paths {X Z : Type} (f : Susp X -> Z) (n : NullHomotopy (fun x => ap f (merid x))) : NullHomotopy f. Proof. exists (f North). refine (Susp_ind _ 1 n.1^ _); intros x. refine (transport_paths_Fl _ _ @ _). apply (concat (concat_p1 _)), ap. apply n.2. Defined. Definition nullhomot_paths_from_susp {X Z : Type} (H_N H_S : Z) (f : X -> H_N = H_S) (n : NullHomotopy (Susp_rec H_N H_S f)) : NullHomotopy f. Proof. exists (n.2 North @ (n.2 South)^). intro x. apply moveL_pV. transitivity (ap (Susp_rec H_N H_S f) (merid x) @ n.2 South). - apply whiskerR, inverse, Susp_rec_beta_merid. - refine (concat_Ap n.2 (merid x) @ _). apply (concatR (concat_p1 _)), whiskerL. apply ap_const. Defined. (** ** Contractibility of the suspension *) Global Instance contr_susp (A : Type) `{Contr A} : Contr (Susp A). Proof. unfold Susp; exact _. Defined. (** ** Connectedness of the suspension *) Global Instance isconnected_susp {n : trunc_index} {X : Type} `{H : IsConnected n X} : IsConnected n.+1 (Susp X). Proof. apply isconnected_from_elim. intros C H' f. exists (f North). assert ({ p0 : f North = f South & forall x:X, ap f (merid x) = p0 }) as [p0 allpath_p0] by (apply (isconnected_elim n); rapply H'). apply (Susp_ind (fun a => f a = f North) 1 p0^). intros x. apply (concat (transport_paths_Fl _ _)). apply (concat (concat_p1 _)). apply ap, allpath_p0. Defined. (** ** Negation map *) (** The negation map on the suspension is defined by sending [North] to [South] and vice versa, and acting by flipping on the meridians. *) Definition susp_neg (A : Type) : Susp A -> Susp A := Susp_rec South North (fun a => (merid a)^). (** The negation map is an involution. *) Definition susp_neg_inv (A : Type) : susp_neg A o susp_neg A == idmap. Proof. snrapply Susp_ind_FFlr. 1, 2: reflexivity. intro a. apply equiv_p1_1q. lhs nrapply ap. 1: snrapply Susp_rec_beta_merid. lhs nrapply (ap_V _ (merid a)). lhs nrapply ap. 1: snrapply Susp_rec_beta_merid. nrapply inv_V. Defined. Global Instance isequiv_susp_neg (A : Type) : IsEquiv (susp_neg A) := isequiv_involution (susp_neg A) (susp_neg_inv A). Definition equiv_susp_neg (A : Type) : Susp A <~> Susp A := Build_Equiv _ _ (susp_neg A) _. (** By using the suspension functor, we can also define another negation map on [Susp (Susp A))]. It turns out these are homotopic. *) Definition susp_neg_stable (A : Type) : functor_susp (susp_neg A) == susp_neg (Susp A). Proof. snrapply Susp_ind_FlFr; simpl. - exact (merid North). - exact (merid South)^. - intro x. lhs nrapply whiskerR. 1: nrapply functor_susp_beta_merid. rhs nrapply whiskerL. 2: nrapply Susp_rec_beta_merid. revert x; snrapply Susp_ind_FlFr; simpl. + exact (concat_pV _ @ (concat_pV _)^). + reflexivity. + intro a. lhs nrapply concat_p1. lhs nrapply (ap_compose _ (fun y => merid y @ _) (merid a)). lhs nrapply ap. 1: nrapply Susp_rec_beta_merid. simpl. generalize (merid a) as p. generalize (@South A) as s. intros s p; destruct p. simpl. symmetry. lhs nrapply concat_p1. apply concat_pV. Defined. (** [susp_neg] is a natural equivalence on the suspension functor. *) Definition susp_neg_natural {A B : Type} (f : A -> B) : susp_neg B o functor_susp f == functor_susp f o susp_neg A. Proof. snrapply Susp_ind_FFlFFr. 1, 2: reflexivity. intro a. apply equiv_p1_1q. lhs nrapply (ap _ (Susp_rec_beta_merid _)). rhs nrapply (ap _ (Susp_rec_beta_merid _)). rhs nrapply (ap_V _ (merid a)). rhs nrapply (ap _ (Susp_rec_beta_merid _)). nrapply Susp_rec_beta_merid. Defined. Coq-HoTT-9.0/theories/Homotopy/Syllepsis.v000066400000000000000000001163021474641544500205570ustar00rootroot00000000000000From HoTT Require Import Basics Types. (* vertical composition of squares *) Section concat_square_vert. Context {X : Type}. (* 0-paths *) Context {a0 b0 c0 : X}. Context {a1 b1 c1 : X}. (* 1-paths *) Context {a01 : a0 = a1}. Context {b01 : b0 = b1}. Context {c01 : c0 = c1}. Context {ab0 : a0 = b0}. Context {ab1 : a1 = b1}. Context {bc0 : b0 = c0}. Context {bc1 : b1 = c1}. (* 2-paths *) Context (p : ab0 @ b01 = a01 @ ab1). Context (q : bc0 @ c01 = b01 @ bc1). Local Definition concat_square_vert : (ab0 @ bc0) @ c01 = a01 @ (ab1 @ bc1). Proof. refine (concat_pp_p _ _ _ @ _). refine (whiskerL _ q @ _). refine (concat_p_pp _ _ _ @ _). refine (whiskerR p _ @ _). apply concat_pp_p. Defined. End concat_square_vert. Infix "[-]" := (concat_square_vert) (at level 60). (* horizontal composition of squares *) Section concat_square_hor. Context {X : Type}. (* 0-paths *) Context {a0 b0 c0 : X}. Context {a1 b1 c1 : X}. (* 1-paths *) Context {a01 : a0 = a1}. Context {b01 : b0 = b1}. Context {c01 : c0 = c1}. Context {ab0 : a0 = b0}. Context {ab1 : a1 = b1}. Context {bc0 : b0 = c0}. Context {bc1 : b1 = c1}. (* 2-paths *) Context (p : a01 @ ab1 = ab0 @ b01). Context (q : b01 @ bc1 = bc0 @ c01). Local Definition concat_square_hor : a01 @ (ab1 @ bc1) = (ab0 @ bc0) @ c01. Proof. refine (concat_p_pp _ _ _ @ _). refine (whiskerR p _ @ _). refine (concat_pp_p _ _ _ @ _). refine (whiskerL _ q @ _). apply concat_p_pp. Defined. End concat_square_hor. Infix "[I]" := (concat_square_hor) (at level 60). (* We will frequently use the following equivalences. *) Definition rlucancel {X} {a b : X} {p q : a = b} : (p = q) <~> (p @ 1 = 1 @ q). Proof. refine (equiv_compose' _ _). - exact (equiv_concat_r (concat_1p _)^ _). - exact (equiv_concat_l (concat_p1 _) _). Defined. Definition rlucancel_inv {X} {a b : X} {p q : a = b} := (@rlucancel X a b p q)^-1. Definition lrucancel {X} {a b : X} {p q : a = b} : (p = q) <~> (1 @ p = q @ 1). Proof. refine (equiv_compose' _ _). - exact (equiv_concat_r (concat_p1 _)^ _). - exact (equiv_concat_l (concat_1p _) _). Defined. (* This special case of [equiv_path_ind] comes up a lot. *) Definition equiv_path_ind_rlucancel {X} (a b : X) (p : a = b) (P : forall (q : a = b), p @ 1 = 1 @ q -> Type) (r : P p (rlucancel 1)) : forall (q : a = b) (s : p @ 1 = 1 @ q), P q s. Proof. snrapply (equiv_path_ind (fun _ => rlucancel)). exact r. Defined. (* This special case of [equiv_path_ind] comes up a lot. *) Definition equiv_path_ind_lrucancel {X} (a b : X) (p : a = b) (P : forall (q : a = b), 1 @ p = q @ 1 -> Type) (r : P p (lrucancel 1)) : forall (q : a = b) (s : 1 @ p = q @ 1), P q s. Proof. snrapply (equiv_path_ind (fun _ => lrucancel)). exact r. Defined. (* Interaction of the above equivalences with square composition. *) Definition rlucancel_sVs_1_pp {X} {a b c : X} {p : a = b} {q : b = c} {r} (theta : p @ q = r) : (rlucancel 1 [-] rlucancel 1) @ whiskerL _ theta = whiskerR theta _ @ (rlucancel 1). Proof. by destruct theta, p, q. Defined. Definition lrucancel_sHs_1_pp {X} {a b c : X} {p : a = b} {q : b = c} {r} (theta : p @ q = r) : (lrucancel 1 [I] lrucancel 1) @ whiskerR theta _ = whiskerL _ theta @ (lrucancel 1). Proof. by destruct theta, p, q. Defined. Definition rlucancel_sHs_1 {X} {a b : X} (p : a = b) : (rlucancel 1 [I] rlucancel 1) = rlucancel (idpath p). Proof. by destruct p. Defined. Definition lrucancel_sVs_1 {X} {a b : X} (p : a = b) : (lrucancel 1 [-] lrucancel 1) = lrucancel (idpath p). Proof. by destruct p. Defined. (* Naturality of composition with 1. *) Definition ulnat {X} {a b : X} {u v : a = b} (p : u = v) : whiskerL 1 p @ concat_1p v = concat_1p u @ p. Proof. destruct p. exact (lrucancel 1). Defined. Definition urnat {X} {a b : X} {u v : a = b} (p : u = v) : whiskerR p 1 @ concat_p1 v = concat_p1 u @ p. Proof. destruct p. exact (lrucancel 1). Defined. (* Exchange law for whiskering on the left and on the right. *) Definition wlrnat {X} {a b c : X} {u v : a = b} {x y : b = c} p q : whiskerL u p @ whiskerR q y = whiskerR q x @ whiskerL v p. Proof. by destruct p, q. Defined. (* Eckmann-Hilton. This is also proved as [eckmann_hilton] in PathGroupoids.v, but we need this particular proof in order to prove the syllepsis. *) Theorem eh {X} {a : X} (p q : idpath a = idpath a) : p @ q = q @ p. Proof. refine (_ @ rlucancel_inv (urnat q [-] ulnat p)). refine ((rlucancel_inv (ulnat p [-] urnat q))^ @ _). exact (wlrnat p q). Defined. (* Eckmann-Hilton on reflexivity. *) Local Definition eh_1p_gen {X} {a b : X} {u v : a = b} (p : u = v) {q} (theta : whiskerR p 1 @ 1 = 1 @ q) : (rlucancel_inv (1 [-] theta))^ @ wlrnat 1 p @ rlucancel_inv (theta [-] 1) @ concat_p1 q = concat_1p q. Proof. revert q theta. snrapply equiv_path_ind_rlucancel. by destruct p. Defined. Definition eh_1p {X} {a : X} (p : idpath a = idpath a) : eh 1 p @ concat_p1 p = concat_1p p. Proof. exact (eh_1p_gen p (urnat p)). Defined. Local Definition eh_p1_gen {X} {a b : X} {u v : a = b} (p : u = v) {q} (theta : whiskerL 1 p @ 1 = 1 @ q) : (rlucancel_inv (theta [-] 1))^ @ wlrnat p 1 @ rlucancel_inv (1 [-] theta) @ concat_1p q = concat_p1 q. Proof. revert q theta. snrapply equiv_path_ind_rlucancel. by destruct p. Defined. Definition eh_p1 {X} {a : X} (p : idpath a = idpath a) : eh p 1 @ concat_1p p = concat_p1 p. Proof. exact (eh_p1_gen p (ulnat p)). Defined. (* Naturality of Eckmann-Hilton. *) Definition ehlnat {X} {a : X} (u : idpath a = idpath a) {x y} (p : x = y) : whiskerL u p @ eh u y = eh u x @ whiskerR p u. Proof. destruct p. exact (lrucancel 1). Defined. Definition ehrnat {X} {a : X} {u v} (p : u = v) (x : idpath a = idpath a) : whiskerR p x @ eh v x = eh u x @ whiskerL x p. Proof. destruct p. exact (lrucancel 1). Defined. (* Naturality of Eckmann-Hilton when the fixed path is 1. *) Definition ehlnat_1p {X} {a : X} {u v : idpath a = idpath a} (p : u = v) : (ehlnat 1 p [I] urnat p) @ whiskerR (eh_1p u) _ = whiskerL _ (eh_1p v) @ ulnat p. Proof. destruct p. apply lrucancel_sHs_1_pp. Defined. Definition ehrnat_p1 {X} {a : X} {u v : idpath a = idpath a} (p : u = v) : (ehrnat p 1 [I] ulnat p) @ whiskerR (eh_p1 u) _ = whiskerL _ (eh_p1 v) @ urnat p. Proof. destruct p. apply lrucancel_sHs_1_pp. Defined. (* These lemmas should probably be in the library in some form. *) Local Definition concat_p_pp_pp_p {A} {u v x y : A} (p : u = v) (q : v = x) (r : x = y) : concat_p_pp p q r @ concat_pp_p p q r = 1. Proof. by destruct p, q, r. Defined. Local Definition concat_pp_p_p_pp {A} {u v x y : A} (p : u = v) (q : v = x) (r : x = y) : concat_pp_p p q r @ concat_p_pp p q r = 1. Proof. by destruct p, q, r. Defined. (* These lemmas are in the library but with worse computational behavior. *) Local Definition whiskerL_pp {A} {a b c : A} (u : a = b) {v w z : b = c} (p : v = w) (q : w = z) : whiskerL u (p @ q) = whiskerL u p @ whiskerL u q. Proof. by destruct p, q. Defined. Local Definition whiskerR_pp {A} {a b c : A} {u v w : a = b} (z : b = c) (p : u = v) (q : v = w) : whiskerR (p @ q) z = whiskerR p z @ whiskerR q z. Proof. by destruct p, q. Defined. (* We now prove that "ulnat (p @ q)" suitably relates to "ulnat p" and "ulnat q". *) Definition ulnat_pp {X} {a b : X} {u v w : a = b} (p : u = v) (q : v = w) : ulnat p [-] ulnat q = whiskerR (whiskerL_pp _ p q)^ _ @ ulnat (p @ q). Proof. by destruct p, q, u. Defined. (* We now prove that "urnat (p @ q)" suitably relates to "urnat p" and "urnat q". *) Definition urnat_pp {X} {a b : X} {u v w : a = b} (p : u = v) (q : v = w) : urnat p [-] urnat q = whiskerR (whiskerR_pp _ p q)^ _ @ urnat (p @ q). Proof. by destruct p, q, u. Defined. (* We now prove that "ehlnat u (p @ q)" suitably relates to "ehlnat u p" and "ehlnat u q". *) Definition ehlnat_pp {X} {a : X} (u : idpath a = idpath a) {v w : idpath a = idpath a} (p : v = 1) (q : 1 = w) : (ehlnat u p [-] ehlnat u q) @ whiskerL _ (whiskerR_pp _ p q)^ = (whiskerR (whiskerL_pp _ p q)^ _) @ ehlnat u (p @ q). Proof. revert v p. snrapply (equiv_path_ind (equiv_path_inverse _)). destruct q. apply rlucancel, lrucancel_sVs_1. Defined. (* We now prove that "ehrnat (p @ q) w" suitably relates to "ehrnat p w" and "ehrnat q w". *) Definition ehrnat_pp {X} {a : X} {u v : idpath a = idpath a} (p : u = 1) (q : 1 = v) (w : idpath a = idpath a) : (ehrnat p w [-] ehrnat q w) @ whiskerL _ (whiskerL_pp _ p q)^ = (whiskerR (whiskerR_pp _ p q)^ _) @ ehrnat (p @ q) w. Proof. revert u p. snrapply (equiv_path_ind (equiv_path_inverse _)). destruct q. cbn. apply rlucancel, lrucancel_sVs_1. Defined. (* We now prove that "wlrnat p (q @ r)" suitably relates to "wlrnat p q" and "wlrnat q p". *) Definition wlrnat_p_pp {X} {a b c : X} {u v w : a = b} {x y : b = c} (p : x = y) (q : u = v) (r : v = w) : (wlrnat p q [I] wlrnat p r) @ whiskerR (whiskerR_pp _ q r)^ _ = whiskerL _ (whiskerR_pp _ q r)^ @ wlrnat p (q @ r). Proof. by destruct p, q, r. Defined. (* We now prove that "wlrnat (p @ q) r" suitably relates to "wlrnat p r" and "wlrnat q r". *) Definition wlrnat_pp_p {X} {a b c : X} {u v : a = b} {x y z : b = c} (p : x = y) (q : y = z) (r : u = v) : (wlrnat p r [-] wlrnat q r) @ whiskerL _ (whiskerL_pp _ p q)^ = whiskerR (whiskerL_pp _ p q)^ _ @ wlrnat (p @ q) r. Proof. by destruct p, q, r. Defined. (* We now prove that "wlrnat p q" suitably relates to "wlrnat q p". *) Definition wlrnat_V {X} {a : X} {u v x y : idpath a = idpath a} p q : whiskerR (wlrnat p q) (eh v y) @ (ehrnat q x [-] ehlnat v p) = (ehlnat u p [-] ehrnat q y) @ whiskerL (eh u x) (wlrnat q p)^. Proof. destruct p, q. exact (lrucancel 1). Defined. (* Coherence #1: We now prove that "eh p (q @ r)" suitably relates to "eh p q" and "eh p r". *) Section eh_p_pp. Context {X : Type}. (* 0-paths *) Context {a b c d e f : X}. (* 1-paths *) Context {wlx0 x0 : a = b}. Context {wlx1 x1 : c = d}. Context {wlx2 x2 : e = f}. Context {wry0 y0 : b = d}. Context {wry1 y1 : a = c}. Context {wrz0 z0 : d = f}. Context {wrz1 z1 : c = e}. Context {wryz0 : b = f}. Context {wryz1 : a = e}. (* 2-paths *) Context {ulnat_x0 : wlx0 @ 1 = 1 @ x0}. Context {ulnat_x1 : wlx1 @ 1 = 1 @ x1}. Context {ulnat_x2 : wlx2 @ 1 = 1 @ x2}. Context {urnat_y0 : wry0 @ 1 = 1 @ y0}. Context {urnat_y1 : wry1 @ 1 = 1 @ y1}. Context {urnat_z0 : wrz0 @ 1 = 1 @ z0}. Context {urnat_z1 : wrz1 @ 1 = 1 @ z1}. Context {urnat_yz0 : wryz0 @ 1 = 1 @ (y0 @ z0)}. Context {urnat_yz1 : wryz1 @ 1 = 1 @ (y1 @ z1)}. Context {wlrnat_x_y : wlx0 @ wry0 = wry1 @ wlx1}. Context {wlrnat_x_z : wlx1 @ wrz0 = wrz1 @ wlx2}. Context {wlrnat_x_yz : wlx0 @ wryz0 = wryz1 @ wlx2}. Context {wrpp_yz0 : wry0 @ wrz0 = wryz0}. Context {wrpp_yz1 : wry1 @ wrz1 = wryz1}. (* 3-paths *) Hypothesis H_urnat_yz0 : (urnat_y0 [-] urnat_z0) = whiskerR wrpp_yz0 _ @ urnat_yz0. Hypothesis H_urnat_yz1 : (urnat_y1 [-] urnat_z1) = whiskerR wrpp_yz1 _ @ urnat_yz1. Hypothesis H_wlrnat_x_yz : (wlrnat_x_y [I] wlrnat_x_z) @ whiskerR wrpp_yz1 _ = whiskerL _ wrpp_yz0 @ wlrnat_x_yz. (* the coherence *) Definition eh_p_pp_gen : let EH_x_y := (rlucancel_inv (ulnat_x0 [-] urnat_y0))^ @ wlrnat_x_y @ rlucancel_inv (urnat_y1 [-] ulnat_x1) in let EH_x_z := (rlucancel_inv (ulnat_x1 [-] urnat_z0))^ @ wlrnat_x_z @ rlucancel_inv (urnat_z1 [-] ulnat_x2) in let EH_x_yz := (rlucancel_inv (ulnat_x0 [-] urnat_yz0))^ @ wlrnat_x_yz @ rlucancel_inv (urnat_yz1 [-] ulnat_x2) in EH_x_yz @ (concat_pp_p _ _ _ @ whiskerL _ EH_x_z^) = concat_p_pp _ _ _ @ whiskerR EH_x_y _ @ concat_pp_p _ _ _. Proof. apply moveR_Vp in H_urnat_yz0, H_urnat_yz1, H_wlrnat_x_yz. destruct H_urnat_yz0, H_urnat_yz1, H_wlrnat_x_yz. clear H_urnat_yz0 H_urnat_yz1 H_wlrnat_x_yz. destruct wrpp_yz0, wrpp_yz1. clear wrpp_yz0 wrpp_yz1. revert x0 ulnat_x0. snrapply equiv_path_ind_rlucancel. revert x1 ulnat_x1. snrapply equiv_path_ind_rlucancel. revert x2 ulnat_x2. snrapply equiv_path_ind_rlucancel. revert y0 urnat_y0. snrapply equiv_path_ind_rlucancel. revert y1 urnat_y1. snrapply equiv_path_ind_rlucancel. revert z0 urnat_z0. snrapply equiv_path_ind_rlucancel. revert z1 urnat_z1. snrapply equiv_path_ind_rlucancel. destruct wry0, wry1, wrz0, wrz1. clear wry0 wry1 wrz0 wrz1. revert wlx2 wlrnat_x_z. snrapply equiv_path_ind_rlucancel. revert wlx1 wlrnat_x_y. snrapply equiv_path_ind_rlucancel. destruct wlx0. clear wlx0. reflexivity. Defined. End eh_p_pp. Theorem eh_p_pp {X} {a : X} (p q r : idpath a = idpath a) : eh p (q @ r) @ (concat_pp_p _ _ _ @ whiskerL _ (eh p r)^) = concat_p_pp _ _ _ @ whiskerR (eh p q) _ @ concat_pp_p _ _ _. Proof. nrapply eh_p_pp_gen. - exact (urnat_pp q r). - exact (urnat_pp q r). - exact (wlrnat_p_pp p q r). Defined. (* Coherence #1: We now prove that "eh (p @ q) r" suitably relates to "eh p r" and "eh q r". *) Section eh_pp_p. Context {X : Type}. (* 0-paths *) Context {a b c d e f : X}. (* 1-paths *) Context {wlx0 x0 : a = b}. Context {wlx1 x1 : d = e}. Context {wly0 y0 : b = c}. Context {wly1 y1 : e = f}. Context {wrz0 z0 : c = f}. Context {wrz1 z1 : b = e}. Context {wrz2 z2 : a = d}. Context {wlxy0 : a = c}. Context {wlxy1 : d = f}. (* 2-paths *) Context {ulnat_x0 : wlx0 @ 1 = 1 @ x0}. Context {ulnat_x1 : wlx1 @ 1 = 1 @ x1}. Context {ulnat_y0 : wly0 @ 1 = 1 @ y0}. Context {ulnat_y1 : wly1 @ 1 = 1 @ y1}. Context {urnat_z0 : wrz0 @ 1 = 1 @ z0}. Context {urnat_z1 : wrz1 @ 1 = 1 @ z1}. Context {urnat_z2 : wrz2 @ 1 = 1 @ z2}. Context {ulnat_xy0 : wlxy0 @ 1 = 1 @ (x0 @ y0)}. Context {ulnat_xy1 : wlxy1 @ 1 = 1 @ (x1 @ y1)}. Context {wlrnat_x_z : wlx0 @ wrz1 = wrz2 @ wlx1}. Context {wlrnat_y_z : wly0 @ wrz0 = wrz1 @ wly1}. Context {wlrnat_xy_z : wlxy0 @ wrz0 = wrz2 @ wlxy1}. Context {wlpp_xy0 : wlx0 @ wly0 = wlxy0}. Context {wlpp_xy1 : wlx1 @ wly1 = wlxy1}. (* 3-paths *) Hypothesis H_ulnat_xy0 : (ulnat_x0 [-] ulnat_y0) = whiskerR wlpp_xy0 _ @ ulnat_xy0. Hypothesis H_ulnat_xy1 : (ulnat_x1 [-] ulnat_y1) = whiskerR wlpp_xy1 _ @ ulnat_xy1. Hypothesis H_wlrnat_xy_z : (wlrnat_x_z [-] wlrnat_y_z) @ whiskerL _ wlpp_xy1 = whiskerR wlpp_xy0 _ @ wlrnat_xy_z. (* the coherence *) Definition eh_pp_p_gen : let EH_x_z := (rlucancel_inv (ulnat_x0 [-] urnat_z1))^ @ wlrnat_x_z @ rlucancel_inv (urnat_z2 [-] ulnat_x1) in let EH_y_z := (rlucancel_inv (ulnat_y0 [-] urnat_z0))^ @ wlrnat_y_z @ rlucancel_inv (urnat_z1 [-] ulnat_y1) in let EH_xy_z := (rlucancel_inv (ulnat_xy0 [-] urnat_z0))^ @ wlrnat_xy_z @ rlucancel_inv (urnat_z2 [-] ulnat_xy1) in EH_xy_z @ (concat_p_pp _ _ _ @ whiskerR EH_x_z^ _) = concat_pp_p _ _ _ @ whiskerL _ EH_y_z @ concat_p_pp _ _ _. Proof. apply moveR_Vp in H_ulnat_xy0, H_ulnat_xy1, H_wlrnat_xy_z. destruct H_ulnat_xy0, H_ulnat_xy1, H_wlrnat_xy_z. clear H_ulnat_xy0 H_ulnat_xy1 H_wlrnat_xy_z. destruct wlpp_xy0, wlpp_xy1. clear wlpp_xy0 wlpp_xy1. revert x0 ulnat_x0. snrapply equiv_path_ind_rlucancel. revert x1 ulnat_x1. snrapply equiv_path_ind_rlucancel. revert y0 ulnat_y0. snrapply equiv_path_ind_rlucancel. revert y1 ulnat_y1. snrapply equiv_path_ind_rlucancel. revert z0 urnat_z0. snrapply equiv_path_ind_rlucancel. revert z1 urnat_z1. snrapply equiv_path_ind_rlucancel. revert z2 urnat_z2. snrapply equiv_path_ind_rlucancel. destruct wlx0, wlx1, wly0, wly1. clear wlx0 wlx1 wly0 wly1. revert wrz2 wlrnat_x_z. snrapply equiv_path_ind_lrucancel. revert wrz1 wlrnat_y_z. snrapply equiv_path_ind_lrucancel. destruct wrz0. clear wrz0. reflexivity. Defined. End eh_pp_p. Theorem eh_pp_p {X} {a : X} (p q r : idpath a = idpath a) : eh (p @ q) r @ (concat_p_pp _ _ _ @ whiskerR (eh p r)^ _) = concat_pp_p _ _ _ @ whiskerL _ (eh q r) @ concat_p_pp _ _ _. Proof. nrapply eh_pp_p_gen. - exact (ulnat_pp p q). - exact (ulnat_pp p q). - exact (wlrnat_pp_p p q r). Defined. (* Syllepsis: We now prove that "eh p q" is suitably related to "eh q p". *) Section eh_V. Context {X : Type}. (* 0-paths *) Context {a b c d : X}. (* 1-paths *) Context {wlx0 x0 wrx0 : a = b}. Context {wlx1 x1 wrx1 : c = d}. Context {wly0 y0 wry0 : b = d}. Context {wly1 y1 wry1 : a = c}. (* 2-paths *) Context {ulnat_x0 : wlx0 @ 1 = 1 @ x0}. Context {urnat_x0 : wrx0 @ 1 = 1 @ x0}. Context {ulnat_x1 : wlx1 @ 1 = 1 @ x1}. Context {urnat_x1 : wrx1 @ 1 = 1 @ x1}. Context {ulnat_y0 : wly0 @ 1 = 1 @ y0}. Context {urnat_y0 : wry0 @ 1 = 1 @ y0}. Context {ulnat_y1 : wly1 @ 1 = 1 @ y1}. Context {urnat_y1 : wry1 @ 1 = 1 @ y1}. Context {ehlnat_x0 : wlx0 @ 1 = 1 @ wrx0}. Context {ehlnat_x1 : wlx1 @ 1 = 1 @ wrx1}. Context {ehrnat_y0 : wry0 @ 1 = 1 @ wly0}. Context {ehrnat_y1 : wry1 @ 1 = 1 @ wly1}. Context {wlrnat_x_y : wlx0 @ wry0 = wry1 @ wlx1}. Context {wlrnat_y_x : wly1 @ wrx1 = wrx0 @ wly0}. (* 3-paths *) Hypothesis ehlnat_1p_x0 : (ehlnat_x0 [I] urnat_x0) @ 1 = 1 @ ulnat_x0. Hypothesis ehlnat_1p_x1 : (ehlnat_x1 [I] urnat_x1) @ 1 = 1 @ ulnat_x1. Hypothesis ehrnat_p1_y0 : (ehrnat_y0 [I] ulnat_y0) @ 1 = 1 @ urnat_y0. Hypothesis ehrnat_p1_y1 : (ehrnat_y1 [I] ulnat_y1) @ 1 = 1 @ urnat_y1. Hypothesis wlrnat_V_x_y : whiskerR wlrnat_x_y _ @ (ehrnat_y1 [-] ehlnat_x1) = (ehlnat_x0 [-] ehrnat_y0) @ whiskerL _ wlrnat_y_x^. (* the syllepsis *) Definition eh_V_gen : let EH_x_y := (rlucancel_inv (ulnat_x0 [-] urnat_y0))^ @ wlrnat_x_y @ rlucancel_inv (urnat_y1 [-] ulnat_x1) in let EH_y_x := (rlucancel_inv (ulnat_y1 [-] urnat_x1))^ @ wlrnat_y_x @ rlucancel_inv (urnat_x0 [-] ulnat_y0) in EH_x_y @ EH_y_x = 1. Proof. pose (H_whiskerR_wlrnat_x_y := moveL_Mp _ _ _ (moveL_pV _ _ _ (whiskerR_p1 wlrnat_x_y))). apply moveL_pV in wlrnat_V_x_y. apply (concat H_whiskerR_wlrnat_x_y^) in wlrnat_V_x_y. apply moveL_Vp, moveL_pV in wlrnat_V_x_y. apply symmetry in wlrnat_V_x_y. destruct wlrnat_V_x_y. clear wlrnat_V_x_y. clear H_whiskerR_wlrnat_x_y. revert ulnat_x0 ehlnat_1p_x0. snrapply equiv_path_ind_rlucancel. revert ulnat_x1 ehlnat_1p_x1. snrapply equiv_path_ind_rlucancel. revert urnat_y0 ehrnat_p1_y0. snrapply equiv_path_ind_rlucancel. revert urnat_y1 ehrnat_p1_y1. snrapply equiv_path_ind_rlucancel. revert x0 urnat_x0. snrapply equiv_path_ind_rlucancel. revert x1 urnat_x1. snrapply equiv_path_ind_rlucancel. revert y0 ulnat_y0. snrapply equiv_path_ind_rlucancel. revert y1 ulnat_y1. snrapply equiv_path_ind_rlucancel. revert wlrnat_y_x. revert wrx0 ehlnat_x0. snrapply equiv_path_ind_rlucancel. revert wrx1 ehlnat_x1. snrapply equiv_path_ind_rlucancel. revert wly0 ehrnat_y0. snrapply equiv_path_ind_rlucancel. revert wly1 ehrnat_y1. snrapply equiv_path_ind_rlucancel. destruct wry0, wry1, wlx1. clear wry0 wry1 wlx1. revert wlx0. snrapply equiv_path_ind_lrucancel. reflexivity. Defined. End eh_V. Theorem eh_V {X} {a : X} (p q : idpath (idpath a) = idpath (idpath a)) : eh p q @ eh q p = 1. Proof. nrapply eh_V_gen. - exact (ehlnat_1p p). - exact (ehlnat_1p p). - exact (ehrnat_p1 q). - exact (ehrnat_p1 q). - exact (wlrnat_V p q). Defined. (* Given "ehrnat_p1 y" and "ehrnat_p1 z", we can explicitly construct "ehrnat_p1 (y @ z)". *) Section Ehrnat_p1_pp. Context {X : Type}. (* 0-paths *) Context {a0 a1 a2 : X}. Context {b0 b1 b2 : X}. Context {c0 c1 c2 : X}. (* 1-paths *) Context {wry : a0 = b0}. Context {wrz : b0 = c0}. Context {wly : a1 = b1}. Context {wlz : b1 = c1}. Context {y : a2 = b2}. Context {z : b2 = c2}. Context {wryz : a0 = c0}. Context {wlyz : a1 = c1}. Context {a01 : a0 = a1}. Context {a12 : a1 = a2}. Context {b01 : b0 = b1}. Context {b12 : b1 = b2}. Context {c01 : c0 = c1}. Context {c12 : c1 = c2}. Context {a02 : a0 = a2}. Context {c02 : c0 = c2}. (* 2-paths *) Context {ehrnat_y : wry @ b01 = a01 @ wly}. Context {ehrnat_z : wrz @ c01 = b01 @ wlz}. Context {ehrnat_yz : wryz @ c01 = a01 @ wlyz}. Context {ulnat_y : wly @ b12 = a12 @ y}. Context {ulnat_z : wlz @ c12 = b12 @ z}. Context {ulnat_yz : wlyz @ c12 = a12 @ (y @ z)}. Context {urnat_y : wry @ (b01 @ b12) = a02 @ y}. Context {urnat_z : wrz @ c02 = (b01 @ b12) @ z}. Context {urnat_yz : wryz @ c02 = a02 @ (y @ z)}. Context {wrpp_yz : wry @ wrz = wryz}. Context {wlpp_yz : wly @ wlz = wlyz}. Context (H_a02 : a01 @ a12 = a02). Context (H_c02 : c01 @ c12 = c02). (* 3-paths *) Hypothesis H_ehrnat_yz : (ehrnat_y [-] ehrnat_z) @ whiskerL _ wlpp_yz = whiskerR wrpp_yz _ @ ehrnat_yz. Hypothesis H_ulnat_yz : (ulnat_y [-] ulnat_z) = whiskerR wlpp_yz _ @ ulnat_yz. Hypothesis H_urnat_yz : (urnat_y [-] urnat_z) = whiskerR wrpp_yz _ @ urnat_yz. Variable ehrnat_p1_y : (ehrnat_y [I] ulnat_y) @ whiskerR H_a02 _ = 1 @ urnat_y. Variable ehrnat_p1_z : (ehrnat_z [I] ulnat_z) @ 1 = whiskerL _ H_c02 @ urnat_z. (* the composite iso *) Definition Ehrnat_p1_pp : (ehrnat_yz [I] ulnat_yz) @ whiskerR H_a02 _ = whiskerL _ H_c02 @ urnat_yz. Proof. apply moveR_Vp in H_urnat_yz, H_ulnat_yz, H_ehrnat_yz. destruct H_urnat_yz, H_ulnat_yz, H_ehrnat_yz. clear H_urnat_yz H_ulnat_yz H_ehrnat_yz. apply moveR_Vp in ehrnat_p1_y, ehrnat_p1_z. destruct ehrnat_p1_y, ehrnat_p1_z. clear ehrnat_p1_y ehrnat_p1_z. destruct H_a02, H_c02. clear H_a02 H_c02. destruct wrpp_yz, wlpp_yz. clear wrpp_yz wlpp_yz. destruct a01, a12, b01, b12, c01, c12. clear a01 a12 b01 b12 c01 c12. revert y ulnat_y. snrapply equiv_path_ind_rlucancel. revert z ulnat_z. snrapply equiv_path_ind_rlucancel. revert wly ehrnat_y. snrapply equiv_path_ind_rlucancel. revert wlz ehrnat_z. snrapply equiv_path_ind_rlucancel. destruct wry, wrz. clear wry wrz. reflexivity. Defined. End Ehrnat_p1_pp. Definition ehrnat_p1_pp {X} {a : X} {u v : idpath a = idpath a} (q : u = 1) (r : 1 = v) : Ehrnat_p1_pp (eh_p1 u) (eh_p1 v) (ehrnat_pp q r 1) (ulnat_pp q r) (urnat_pp q r) (ehrnat_p1 q) (ehrnat_p1 r) = ehrnat_p1 (q @ r). Proof. revert u q. snrapply (equiv_path_ind (equiv_path_inverse _)). by destruct r. Defined. (* Given "wlrnat_V x y" and "wlrnat_V x z", we can explicitly construct "wlrnat_V x (y @ z)". *) Section wlrnat_V_p_pp. Context {X : Type}. (* 0-paths *) Context {a0 b0 c0 d0 e0 f0 : X}. Context {a1 b1 c1 d1 e1 f1 : X}. (* 1-paths *) Context {wlx0 : a0 = b0}. Context {wlx1 : c0 = d0}. Context {wlx2 : e0 = f0}. Context {wrx0 : a1 = b1}. Context {wrx1 : c1 = d1}. Context {wrx2 : e1 = f1}. Context {wry0 : b0 = d0}. Context {wly0 : b1 = d1}. Context {wry1 : a0 = c0}. Context {wly1 : a1 = c1}. Context {wrz0 : d0 = f0}. Context {wlz0 : d1 = f1}. Context {wrz1 : c0 = e0}. Context {wlz1 : c1 = e1}. Context {a01 : a0 = a1}. Context {b01 : b0 = b1}. Context {c01 : c0 = c1}. Context {d01 : d0 = d1}. Context {e01 : e0 = e1}. Context {f01 : f0 = f1}. Context {wryz0 : b0 = f0}. Context {wlyz0 : b1 = f1}. Context {wryz1 : a0 = e0}. Context {wlyz1 : a1 = e1}. (* 2-paths *) Context {ehlnat_x0 : wlx0 @ b01 = a01 @ wrx0}. Context {ehlnat_x1 : wlx1 @ d01 = c01 @ wrx1}. Context {ehlnat_x2 : wlx2 @ f01 = e01 @ wrx2}. Context {ehrnat_y0 : wry0 @ d01 = b01 @ wly0}. Context {ehrnat_y1 : wry1 @ c01 = a01 @ wly1}. Context {ehrnat_z0 : wrz0 @ f01 = d01 @ wlz0}. Context {ehrnat_z1 : wrz1 @ e01 = c01 @ wlz1}. Context {ehrnat_yz0 : wryz0 @ f01 = b01 @ wlyz0}. Context {ehrnat_yz1 : wryz1 @ e01 = a01 @ wlyz1}. Context {wlrnat_x_y : wlx0 @ wry0 = wry1 @ wlx1}. Context {wlrnat_y_x : wly1 @ wrx1 = wrx0 @ wly0}. Context {wlrnat_x_z : wlx1 @ wrz0 = wrz1 @ wlx2}. Context {wlrnat_z_x : wlz1 @ wrx2 = wrx1 @ wlz0}. Context {wlrnat_x_yz : wlx0 @ wryz0 = wryz1 @ wlx2}. Context {wlrnat_yz_x : wlyz1 @ wrx2 = wrx0 @ wlyz0}. Context {wrpp_yz0 : wry0 @ wrz0 = wryz0}. Context {wlpp_yz0 : wly0 @ wlz0 = wlyz0}. Context {wrpp_yz1 : wry1 @ wrz1 = wryz1}. Context {wlpp_yz1 : wly1 @ wlz1 = wlyz1}. (* 3-paths *) Hypothesis H_ehrnat_yz0 : (ehrnat_y0 [-] ehrnat_z0) @ whiskerL _ wlpp_yz0 = whiskerR wrpp_yz0 _ @ ehrnat_yz0. Hypothesis H_ehrnat_yz1 : (ehrnat_y1 [-] ehrnat_z1) @ whiskerL _ wlpp_yz1 = whiskerR wrpp_yz1 _ @ ehrnat_yz1. Hypothesis H_wlrnat_x_yz : (wlrnat_x_y [I] wlrnat_x_z) @ whiskerR wrpp_yz1 _ = whiskerL _ wrpp_yz0 @ wlrnat_x_yz. Hypothesis H_wlrnat_yz_x : (wlrnat_y_x [-] wlrnat_z_x) @ whiskerL _ wlpp_yz0 = whiskerR wlpp_yz1 _ @ wlrnat_yz_x. Variable wlrnat_V_x_y : whiskerR wlrnat_x_y _ @ (ehrnat_y1 [-] ehlnat_x1) = (ehlnat_x0 [-] ehrnat_y0) @ whiskerL _ wlrnat_y_x^. Variable wlrnat_V_x_z : whiskerR wlrnat_x_z _ @ (ehrnat_z1 [-] ehlnat_x2) = (ehlnat_x1 [-] ehrnat_z0) @ whiskerL _ wlrnat_z_x^. (* the composite square *) Definition Wlrnat_V_p_pp : whiskerR wlrnat_x_yz _ @ (ehrnat_yz1 [-] ehlnat_x2) = (ehlnat_x0 [-] ehrnat_yz0) @ whiskerL _ wlrnat_yz_x^. Proof. apply moveR_Vp in H_ehrnat_yz0, H_ehrnat_yz1. destruct H_ehrnat_yz0, H_ehrnat_yz1. clear H_ehrnat_yz0 H_ehrnat_yz1. apply moveR_Vp in H_wlrnat_x_yz, H_wlrnat_yz_x. destruct H_wlrnat_x_yz, H_wlrnat_yz_x. clear H_wlrnat_x_yz H_wlrnat_yz_x. destruct a01, b01, c01, d01, e01, f01. clear a01 b01 c01 d01 e01 f01. pose (H_whiskerR_wlrnat_x_y := moveL_Mp _ _ _ (moveL_pV _ _ _ (whiskerR_p1 wlrnat_x_y))). pose (H_whiskerR_wlrnat_x_z := moveL_Mp _ _ _ (moveL_pV _ _ _ (whiskerR_p1 wlrnat_x_z))). apply moveL_pV in wlrnat_V_x_y. apply (concat H_whiskerR_wlrnat_x_y^) in wlrnat_V_x_y. apply moveL_Vp, moveL_pV in wlrnat_V_x_y. apply symmetry in wlrnat_V_x_y. destruct wlrnat_V_x_y. clear wlrnat_V_x_y. apply moveL_pV in wlrnat_V_x_z. apply (concat H_whiskerR_wlrnat_x_z^) in wlrnat_V_x_z. apply moveL_Vp, moveL_pV in wlrnat_V_x_z. apply symmetry in wlrnat_V_x_z. destruct wlrnat_V_x_z. clear wlrnat_V_x_z. clear H_whiskerR_wlrnat_x_y H_whiskerR_wlrnat_x_z. destruct wrpp_yz0, wlpp_yz0, wrpp_yz1, wlpp_yz1. clear wrpp_yz0 wlpp_yz0 wrpp_yz1 wlpp_yz1. revert wlrnat_y_x wlrnat_z_x. revert wrx0 ehlnat_x0. snrapply equiv_path_ind_rlucancel. revert wrx1 ehlnat_x1. snrapply equiv_path_ind_rlucancel. revert wrx2 ehlnat_x2. snrapply equiv_path_ind_rlucancel. revert wly0 ehrnat_y0. snrapply equiv_path_ind_rlucancel. revert wly1 ehrnat_y1. snrapply equiv_path_ind_rlucancel. revert wlz0 ehrnat_z0. snrapply equiv_path_ind_rlucancel. revert wlz1 ehrnat_z1. snrapply equiv_path_ind_rlucancel. destruct wry0, wry1, wrz0, wrz1. clear wry0 wry1 wrz0 wrz1. revert wlx0. snrapply equiv_path_ind_lrucancel. revert wlx1. snrapply equiv_path_ind_lrucancel. destruct wlx2. clear wlx2. reflexivity. Defined. End wlrnat_V_p_pp. Definition wlrnat_V_p_pp {X} {a : X} {u v w : idpath a = idpath a} (p : 1 = w) (q : u = 1) (r : 1 = v) : Wlrnat_V_p_pp (ehrnat_pp q r _) (ehrnat_pp q r _) (wlrnat_p_pp p q r) (wlrnat_pp_p q r p) (wlrnat_V p q) (wlrnat_V p r) = wlrnat_V p (q @ r). Proof. revert u q. snrapply (equiv_path_ind (equiv_path_inverse _)). by destruct p, r. Defined. (* Next we prove a coherence law relating [eh_V p (q @ r)] to [eh_V p q] and [eh_V p q]. *) (* The following tactics will be used to make the proof faster, but with only minor modifications, the proof goes through without these tactics. The final tactic [generalize_goal] takes a goal of the form [forall a b c ..., expression] and asserts a new goal [forall P, _ -> forall a b c ..., P a b c ...] which can be used to prove the original goal. Because [expression] has been replaced with a generic function, the proof of the new goal can be more efficient than the proof of the special case, especially when there are around 84 variables. *) Ltac apply_P ty P := lazymatch ty with | forall a : ?A, ?ty => let ty' := fresh in let P' := fresh in constr:(forall a : A, (* Bind [ty] in [match] so that we avoid issues such as https://github.com/coq/coq/issues/7299 and similar ones. Without [return _], [match] tries two ways to elaborate the branches, which results in exponential blowup on failure. *) match ty, P a return _ with | ty', P' => ltac:(let ty := (eval cbv delta [ty'] in ty') in let P := (eval cbv delta [P'] in P') in clear ty' P'; let res := apply_P ty P in exact res) end) | _ => P end. Ltac make_P_and_evar ty := let P := fresh "P" in open_constr:(forall P : _, _ -> ltac:(let res := apply_P ty P in exact res)). Ltac generalize_goal X := match goal with |- ?G => let T := make_P_and_evar G in assert (X : T) end. (* We need this equivalence twice below. *) Local Lemma equiv_helper {X} {a b : X} {p q r : a = b} (t : q @ 1 = r) (u : p @ 1 = r) (s : p = q) : ((concat_p1 p)^ @ (u @ t^)) @ (concat_p1 q) = s <~> whiskerR s 1 @ t = u. Proof. snrapply (_ oE equiv_path_inverse _ _). snrapply (_ oE equiv_moveR_pV _ _ _). snrapply (_ oE equiv_moveR_Mp _ _ _). snrapply (_ oE equiv_concat_l _ _). 3: exact (moveL_Mp _ _ _ (moveL_pV _ _ _ (whiskerR_p1 s))). snrapply (equiv_moveR_pM _ _ _). Defined. (* This special case of [equiv_path_ind] comes up a lot. *) Definition equiv_path_ind_moveL_Mp {X} (a b c : X) (p : a = c) (r : a = b) (P : forall (q : b = c), p = r @ q -> Type) (i : P (r^ @ p) (equiv_moveL_Mp _ _ _ 1)) : forall (q : b = c) (s : p = r @ q), P q s. Proof. exact (equiv_path_ind (fun q => (equiv_moveL_Mp q _ _)) P i). Defined. (* A form of the coherence we can prove by path induction. *) Definition eh_V_p_pp_gen {X : Type} (* 0-paths *) {a b c d e f : X} (* 1-paths *) {wlx0 x0 wrx0 : a = b} {wlx1 x1 wrx1 : c = d} {wlx2 x2 wrx2 : e = f} {wly0 y0 wry0 : b = d} {wly1 y1 wry1 : a = c} {wlz0 z0 wrz0 : d = f} {wlz1 z1 wrz1 : c = e} {wlyz0 wryz0 : b = f} {wlyz1 wryz1 : a = e} (* 2-paths *) {ulnat_x0 : wlx0 @ 1 = 1 @ x0} {urnat_x0 : wrx0 @ 1 = 1 @ x0} {ulnat_x1 : wlx1 @ 1 = 1 @ x1} {urnat_x1 : wrx1 @ 1 = 1 @ x1} {ulnat_x2 : wlx2 @ 1 = 1 @ x2} {urnat_x2 : wrx2 @ 1 = 1 @ x2} {ulnat_y0 : wly0 @ 1 = 1 @ y0} {urnat_y0 : wry0 @ 1 = 1 @ y0} {ulnat_y1 : wly1 @ 1 = 1 @ y1} {urnat_y1 : wry1 @ 1 = 1 @ y1} {ulnat_z0 : wlz0 @ 1 = 1 @ z0} {urnat_z0 : wrz0 @ 1 = 1 @ z0} {ulnat_z1 : wlz1 @ 1 = 1 @ z1} {urnat_z1 : wrz1 @ 1 = 1 @ z1} {ulnat_yz0 : wlyz0 @ 1 = 1 @ (y0 @ z0)} {urnat_yz0 : wryz0 @ 1 = 1 @ (y0 @ z0)} {ulnat_yz1 : wlyz1 @ 1 = 1 @ (y1 @ z1)} {urnat_yz1 : wryz1 @ 1 = 1 @ (y1 @ z1)} {ehlnat_x0 : wlx0 @ 1 = 1 @ wrx0} {ehlnat_x1 : wlx1 @ 1 = 1 @ wrx1} {ehlnat_x2 : wlx2 @ 1 = 1 @ wrx2} {ehrnat_y0 : wry0 @ 1 = 1 @ wly0} {ehrnat_y1 : wry1 @ 1 = 1 @ wly1} {ehrnat_z0 : wrz0 @ 1 = 1 @ wlz0} {ehrnat_z1 : wrz1 @ 1 = 1 @ wlz1} {ehrnat_yz0 : wryz0 @ 1 = 1 @ wlyz0} {ehrnat_yz1 : wryz1 @ 1 = 1 @ wlyz1} {wlrnat_x_y : wlx0 @ wry0 = wry1 @ wlx1} {wlrnat_y_x : wly1 @ wrx1 = wrx0 @ wly0} {wlrnat_x_z : wlx1 @ wrz0 = wrz1 @ wlx2} {wlrnat_z_x : wlz1 @ wrx2 = wrx1 @ wlz0} {wlrnat_x_yz : wlx0 @ wryz0 = wryz1 @ wlx2} {wlrnat_yz_x : wlyz1 @ wrx2 = wrx0 @ wlyz0} {wrpp_yz0 : wry0 @ wrz0 = wryz0} {wlpp_yz0 : wly0 @ wlz0 = wlyz0} {wrpp_yz1 : wry1 @ wrz1 = wryz1} {wlpp_yz1 : wly1 @ wlz1 = wlyz1} (* 3-paths *) {H_ulnat_yz0 : (ulnat_y0 [-] ulnat_z0) = whiskerR wlpp_yz0 _ @ ulnat_yz0} {H_urnat_yz0 : (urnat_y0 [-] urnat_z0) = whiskerR wrpp_yz0 _ @ urnat_yz0} {H_ulnat_yz1 : (ulnat_y1 [-] ulnat_z1) = whiskerR wlpp_yz1 _ @ ulnat_yz1} {H_urnat_yz1 : (urnat_y1 [-] urnat_z1) = whiskerR wrpp_yz1 _ @ urnat_yz1} {H_ehrnat_yz0 : (ehrnat_y0 [-] ehrnat_z0) @ whiskerL _ wlpp_yz0 = whiskerR wrpp_yz0 _ @ ehrnat_yz0} {H_ehrnat_yz1 : (ehrnat_y1 [-] ehrnat_z1) @ whiskerL _ wlpp_yz1 = whiskerR wrpp_yz1 _ @ ehrnat_yz1} {H_wlrnat_x_yz : (wlrnat_x_y [I] wlrnat_x_z) @ whiskerR wrpp_yz1 _ = whiskerL _ wrpp_yz0 @ wlrnat_x_yz} {H_wlrnat_yz_x : (wlrnat_y_x [-] wlrnat_z_x) @ whiskerL _ wlpp_yz0 = whiskerR wlpp_yz1 _ @ wlrnat_yz_x} (ehlnat_1p_x0 : (ehlnat_x0 [I] urnat_x0) @ 1 = 1 @ ulnat_x0) (ehlnat_1p_x1 : (ehlnat_x1 [I] urnat_x1) @ 1 = 1 @ ulnat_x1) (ehlnat_1p_x2 : (ehlnat_x2 [I] urnat_x2) @ 1 = 1 @ ulnat_x2) {ehrnat_p1_y0 : (ehrnat_y0 [I] ulnat_y0) @ 1 = 1 @ urnat_y0} {ehrnat_p1_y1 : (ehrnat_y1 [I] ulnat_y1) @ 1 = 1 @ urnat_y1} {ehrnat_p1_z0 : (ehrnat_z0 [I] ulnat_z0) @ 1 = 1 @ urnat_z0} {ehrnat_p1_z1 : (ehrnat_z1 [I] ulnat_z1) @ 1 = 1 @ urnat_z1} {ehrnat_p1_yz0 : (ehrnat_yz0 [I] ulnat_yz0) @ 1 = 1 @ urnat_yz0} {ehrnat_p1_yz1 : (ehrnat_yz1 [I] ulnat_yz1) @ 1 = 1 @ urnat_yz1} {wlrnat_V_x_y : whiskerR wlrnat_x_y _ @ (ehrnat_y1 [-] ehlnat_x1) = (ehlnat_x0 [-] ehrnat_y0) @ whiskerL _ wlrnat_y_x^} {wlrnat_V_x_z : whiskerR wlrnat_x_z _ @ (ehrnat_z1 [-] ehlnat_x2) = (ehlnat_x1 [-] ehrnat_z0) @ whiskerL _ wlrnat_z_x^} {wlrnat_V_x_yz : whiskerR wlrnat_x_yz _ @ (ehrnat_yz1 [-] ehlnat_x2) = (ehlnat_x0 [-] ehrnat_yz0) @ whiskerL _ wlrnat_yz_x^} (* 4-paths *) (H_ehrnat_p1_yz0 : Ehrnat_p1_pp 1 1 H_ehrnat_yz0 H_ulnat_yz0 H_urnat_yz0 ehrnat_p1_y0 ehrnat_p1_z0 = ehrnat_p1_yz0) (H_ehrnat_p1_yz1 : Ehrnat_p1_pp 1 1 H_ehrnat_yz1 H_ulnat_yz1 H_urnat_yz1 ehrnat_p1_y1 ehrnat_p1_z1 = ehrnat_p1_yz1) (H_wlrnat_V_x_yz : Wlrnat_V_p_pp H_ehrnat_yz0 H_ehrnat_yz1 H_wlrnat_x_yz H_wlrnat_yz_x wlrnat_V_x_y wlrnat_V_x_z = wlrnat_V_x_yz) : let eh_x_y := concat_p_pp x0 y0 z0 @ whiskerR (((rlucancel_inv (ulnat_x0 [-] urnat_y0))^ @ wlrnat_x_y) @ rlucancel_inv (urnat_y1 [-] ulnat_x1)) z0 in whiskerR (concat_p1 _ @@ concat_p1 _) eh_x_y @ whiskerR (eh_V_gen (ehlnat_1p_x0) (ehlnat_1p_x2) (ehrnat_p1_yz0) (ehrnat_p1_yz1) wlrnat_V_x_yz) eh_x_y @ lrucancel 1 @ whiskerL eh_x_y (Syllepsis.concat_pp_p_p_pp _ _ _)^ @ whiskerL eh_x_y (concat_p1 _ @@ concat_p1 _)^ = (eh_p_pp_gen H_urnat_yz0 H_urnat_yz1 H_wlrnat_x_yz [-] lrucancel (whiskerL _ (ap (fun p => whiskerL y1 p) (moveL_V1 _ _ (eh_V_gen ehlnat_1p_x1 ehlnat_1p_x2 ehrnat_p1_z0 ehrnat_p1_z1 wlrnat_V_x_z))))) [-] (eh_pp_p_gen H_ulnat_yz1 H_ulnat_yz0 H_wlrnat_yz_x [-] lrucancel (whiskerL _ (ap (fun p => whiskerR p z0) (moveL_1V _ _ (eh_V_gen ehlnat_1p_x0 ehlnat_1p_x1 ehrnat_p1_y0 ehrnat_p1_y1 wlrnat_V_x_y))))). Proof. (* For some reason, it's most efficient to destruct a few things here but the rest within the subgoal. *) destruct H_ehrnat_p1_yz0, H_ehrnat_p1_yz1, H_wlrnat_V_x_yz. (* For efficiency purposes, we generalize the goal to an arbitrary function [P] of the context (except for [X] and [a]), and do all of the induction steps in this generality. This reduces the size of the term that Coq needs to manipulate, speeding up the proof. The same proof works with the next three lines removed and with the second and third last lines removed. *) revert_until a. generalize_goal lem. { intros P H; intros. destruct wry0, wry1, wrz0, wrz1. destruct wrpp_yz0, wlpp_yz0, wrpp_yz1, wlpp_yz1. revert wlrnat_x_yz H_wlrnat_x_yz. snrapply equiv_path_ind_moveL_Mp. revert wlrnat_x_y wlrnat_V_x_y. snrapply (equiv_path_ind (equiv_helper _ _)). revert wlrnat_x_z wlrnat_V_x_z. snrapply (equiv_path_ind (equiv_helper _ _)). revert ulnat_x0 ehlnat_1p_x0. snrapply equiv_path_ind_rlucancel. revert ulnat_x1 ehlnat_1p_x1. snrapply equiv_path_ind_rlucancel. revert ulnat_x2 ehlnat_1p_x2. snrapply equiv_path_ind_rlucancel. revert urnat_yz0 H_urnat_yz0. snrapply equiv_path_ind_moveL_Mp. revert urnat_yz1 H_urnat_yz1. snrapply equiv_path_ind_moveL_Mp. revert wlrnat_yz_x H_wlrnat_yz_x. snrapply equiv_path_ind_moveL_Mp. revert ehrnat_yz0 H_ehrnat_yz0. snrapply equiv_path_ind_moveL_Mp. revert ehrnat_yz1 H_ehrnat_yz1. snrapply equiv_path_ind_moveL_Mp. revert ulnat_yz1 H_ulnat_yz1. snrapply equiv_path_ind_moveL_Mp. revert ulnat_yz0 H_ulnat_yz0. snrapply equiv_path_ind_moveL_Mp. revert urnat_y0 ehrnat_p1_y0. snrapply equiv_path_ind_rlucancel. revert urnat_y1 ehrnat_p1_y1. snrapply equiv_path_ind_rlucancel. revert urnat_z0 ehrnat_p1_z0. snrapply equiv_path_ind_rlucancel. revert urnat_z1 ehrnat_p1_z1. snrapply equiv_path_ind_rlucancel. revert x0 urnat_x0. snrapply equiv_path_ind_rlucancel. revert x1 urnat_x1. snrapply equiv_path_ind_rlucancel. revert x2 urnat_x2. snrapply equiv_path_ind_rlucancel. revert y0 ulnat_y0. snrapply equiv_path_ind_rlucancel. revert y1 ulnat_y1. snrapply equiv_path_ind_rlucancel. revert z0 ulnat_z0. snrapply equiv_path_ind_rlucancel. revert z1 ulnat_z1. snrapply equiv_path_ind_rlucancel. revert wlrnat_y_x. (* Paired with wlx0 below. *) revert wrx0 ehlnat_x0. snrapply equiv_path_ind_rlucancel. revert wlrnat_z_x. (* Paired with wlx1 below. *) revert wrx1 ehlnat_x1. snrapply equiv_path_ind_rlucancel. revert wrx2 ehlnat_x2. snrapply equiv_path_ind_rlucancel. revert wly0 ehrnat_y0. snrapply equiv_path_ind_rlucancel. revert wly1 ehrnat_y1. snrapply equiv_path_ind_rlucancel. revert wlz0 ehrnat_z0. snrapply equiv_path_ind_rlucancel. revert wlz1 ehrnat_z1. snrapply equiv_path_ind_rlucancel. revert wlx1. snrapply equiv_path_ind_lrucancel. revert wlx0. snrapply equiv_path_ind_lrucancel. destruct wlx2. (* Remove the next two lines if not using the [generalize_goal] tactic. *) exact H. } apply lem. reflexivity. Qed. Definition eh_V_p_pp {X} {a : X} (p q r : idpath (idpath a) = idpath (idpath a)) : whiskerR (concat_p1 _ @@ concat_p1 _) _ @ whiskerR (eh_V p (q @ r)) _ @ lrucancel 1 @ whiskerL _ (Syllepsis.concat_pp_p_p_pp _ _ _)^ @ whiskerL _ (concat_p1 _ @@ concat_p1 _)^ = (eh_p_pp_gen (urnat_pp q r) (urnat_pp q r) (wlrnat_p_pp p q r) [-] lrucancel (whiskerL _ (ap (fun p => whiskerL q p) (moveL_V1 _ _ (eh_V p r))))) [-] (eh_pp_p_gen (ulnat_pp q r) (ulnat_pp q r) (wlrnat_pp_p q r p) [-] lrucancel (whiskerL _ (ap (fun p => whiskerR p r) (moveL_1V _ _ (eh_V p q))))). Proof. exact (eh_V_p_pp_gen _ _ _ (ehrnat_p1_pp q r) (ehrnat_p1_pp q r) (wlrnat_V_p_pp p q r)). Defined. Coq-HoTT-9.0/theories/Homotopy/Wedge.v000066400000000000000000000251271474641544500176270ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed.Core Pointed.pSusp. Require Import Colimits.Pushout. Require Import WildCat. Require Import Homotopy.Suspension. Local Set Universe Minimization ToSet. (** * Wedge sums *) Local Open Scope pointed_scope. Definition Wedge (X Y : pType) : pType := [Pushout (fun _ : Unit => point X) (fun _ => point Y), pushl (point X)]. Notation "X \/ Y" := (Wedge X Y) : pointed_scope. Definition wedge_inl {X Y} : X $-> X \/ Y. Proof. snrapply Build_pMap. - exact (fun x => pushl x). - reflexivity. Defined. Definition wedge_inr {X Y} : Y $-> X \/ Y. Proof. snrapply Build_pMap. - exact (fun x => pushr x). - symmetry. by rapply pglue. Defined. Definition wglue {X Y : pType} : pushl (point X) = (pushr (point Y)) :> (X \/ Y) := pglue tt. (** Wedge recursion into an unpointed type. *) Definition wedge_rec' {X Y : pType} {Z : Type} (f : X -> Z) (g : Y -> Z) (w : f pt = g pt) : Wedge X Y -> Z. Proof. snrapply Pushout_rec. - exact f. - exact g. - intro. exact w. Defined. Definition wedge_rec {X Y : pType} {Z : pType} (f : X $-> Z) (g : Y $-> Z) : X \/ Y $-> Z. Proof. snrapply Build_pMap. - snrapply (wedge_rec' f g). exact (point_eq f @ (point_eq g)^). - exact (point_eq f). Defined. Definition wedge_rec_beta_wglue {X Y Z : pType} (f : X $-> Z) (g : Y $-> Z) : ap (wedge_rec f g) wglue = point_eq f @ (point_eq g)^ := Pushout_rec_beta_pglue _ f g _ tt. Definition wedge_pr1 {X Y : pType} : X \/ Y $-> X := wedge_rec pmap_idmap pconst. Definition wedge_pr2 {X Y : pType} : X \/ Y $-> Y := wedge_rec pconst pmap_idmap. Definition wedge_incl (X Y : pType) : X \/ Y $-> X * Y := pprod_corec _ wedge_pr1 wedge_pr2. Definition wedge_incl_beta_wglue {X Y : pType} : ap (@wedge_incl X Y) wglue = 1. Proof. lhs_V nrapply eta_path_prod. lhs nrapply ap011. - lhs_V nrapply ap_compose. nrapply wedge_rec_beta_wglue. - lhs_V nrapply ap_compose. nrapply wedge_rec_beta_wglue. - reflexivity. Defined. (** 1-universal property of wedge. *) Lemma wedge_up X Y Z (f g : X \/ Y $-> Z) : f $o wedge_inl $== g $o wedge_inl -> f $o wedge_inr $== g $o wedge_inr -> f $== g. Proof. intros p q. snrapply Build_pHomotopy. - snrapply (Pushout_ind _ p q). intros []. nrapply transport_paths_FlFr'. lhs nrapply (whiskerL _ (dpoint_eq q)). rhs nrapply (whiskerR (dpoint_eq p)). clear p q. lhs nrapply concat_p_pp. simpl. apply moveR_pV. lhs nrapply whiskerL. { nrapply whiskerR. apply ap_V. } lhs nrapply concat_p_pp. lhs nrapply whiskerR. 1: apply concat_pV. rhs nrapply concat_p_pp. apply moveL_pM. lhs_V nrapply concat_p1. lhs nrapply concat_pp_p. lhs_V nrapply whiskerL. 1: apply (inv_pp 1). rhs nrapply whiskerL. 2: apply ap_V. apply moveL_pV. reflexivity. - simpl; pelim p q. f_ap. 1: apply concat_1p. lhs nrapply inv_pp. apply concat_p1. Defined. Global Instance hasbinarycoproducts : HasBinaryCoproducts pType. Proof. intros X Y. snrapply Build_BinaryCoproduct. - exact (X \/ Y). - exact wedge_inl. - exact wedge_inr. - intros Z f g. by apply wedge_rec. - intros Z f g. snrapply Build_pHomotopy. 1: reflexivity. by simpl; pelim f. - intros Z f g. snrapply Build_pHomotopy. 1: reflexivity. simpl. apply moveL_pV. apply moveL_pM. refine (_ @ (ap_V _ (pglue tt))^). apply moveR_Mp. apply moveL_pV. apply moveR_Vp. refine (Pushout_rec_beta_pglue _ f g _ _ @ _). simpl. by pelim f g. - intros Z f g p q. by apply wedge_up. Defined. (** *** Lemmas about wedge functions *) Lemma wedge_pr1_inl {X Y} : wedge_pr1 $o (@wedge_inl X Y) $== pmap_idmap. Proof. reflexivity. Defined. Lemma wedge_pr1_inr {X Y} : wedge_pr1 $o (@wedge_inr X Y) $== pconst. Proof. snrapply Build_pHomotopy. 1: reflexivity. rhs nrapply concat_p1. rhs nrapply concat_p1. rhs nrapply (ap_V _ wglue). exact (inverse2 (wedge_rec_beta_wglue pmap_idmap pconst)^). Defined. Lemma wedge_pr2_inl {X Y} : wedge_pr2 $o (@wedge_inl X Y) $== pconst. Proof. reflexivity. Defined. Lemma wedge_pr2_inr {X Y} : wedge_pr2 $o (@wedge_inr X Y) $== pmap_idmap. Proof. snrapply Build_pHomotopy. 1: reflexivity. rhs nrapply concat_p1. rhs nrapply concat_p1. rhs nrapply (ap_V _ wglue). exact (inverse2 (wedge_rec_beta_wglue pconst pmap_idmap)^). Defined. (** Wedge of an indexed family of pointed types *) (** Note that the index type is not necessarily pointed. An empty wedge is the unit type which is the zero object in the category of pointed types. *) Definition FamilyWedge (I : Type) (X : I -> pType) : pType. Proof. snrapply Build_pType. - srefine (Pushout (A := I) (B := sig X) (C := pUnit) _ _). + exact (fun i => (i; pt)). + exact (fun _ => pt). - apply pushr. exact pt. Defined. Definition fwedge_in' (I : Type) (X : I -> pType) : forall i, X i $-> FamilyWedge I X := fun i => Build_pMap _ _ (fun x => pushl (i; x)) (pglue i). (** We have an inclusion map [pushl : sig X -> FamilyWedge X]. When [I] is pointed, so is [sig X], and then this inclusion map is pointed. *) Definition fwedge_in (I : pType) (X : I -> pType) : psigma (pointed_fam X) $-> FamilyWedge I X := Build_pMap _ _ pushl (pglue pt). (** Recursion principle for the wedge of an indexed family of pointed types. *) Definition fwedge_rec (I : Type) (X : I -> pType) (Z : pType) (f : forall i, X i $-> Z) : FamilyWedge I X $-> Z. Proof. snrapply Build_pMap. - snrapply Pushout_rec. + apply (sig_rec f). + exact pconst. + intros i. exact (point_eq (f i)). - exact idpath. Defined. (** We specify a universe variable here to prevent minimization to [Set]. *) Global Instance hasallcoproducts_ptype : HasAllCoproducts pType@{u}. Proof. intros I X. snrapply Build_Coproduct. - exact (FamilyWedge I X). - exact (fwedge_in' I X). - exact (fwedge_rec I X). - intros Z f i. snrapply Build_pHomotopy. 1: reflexivity. simpl. apply moveL_pV. apply equiv_1p_q1. symmetry. exact (Pushout_rec_beta_pglue Z _ (unit_name pt) (fun i => point_eq (f i)) _). - intros Z f g h. snrapply Build_pHomotopy. + snrapply Pushout_ind. * intros [i x]. nrapply h. * intros []. exact (point_eq _ @ (point_eq _)^). * intros i; cbn. nrapply transport_paths_FlFr'. lhs nrapply concat_p_pp. apply moveR_pV. rhs nrapply concat_pp_p. apply moveL_pM. symmetry. exact (dpoint_eq (h i)). + reflexivity. Defined. (** Wedge inclusions into the product can be defined if the indexing type has decidable paths. This is because we need to choose which factor a given wedge summand should land in. *) Definition fwedge_incl `{Funext} (I : Type) `(DecidablePaths I) (X : I -> pType) : FamilyWedge I X $-> pproduct X := cat_coprod_prod X. (** ** The pinch map on the suspension *) (** Given a suspension, there is a natural map from the suspension to the wedge of the suspension with itself. This is known as the pinch map. This is the image to keep in mind: << * /|\ / | \ Susp X / | \ / | \ * * merid(x)* /|\ \ | / / | \ \ | / / | \ \ | / / | \ Pinch \|/ * merid(x)* ----------> * \ | / /|\ \ | / / | \ \ | / / | \ \|/ / | \ * * merid(x)* \ | / \ | / \ | / \|/ * >> Note that this is only a conceptual picture as we aren't working with "reduced suspensions". This means we have to track back along [merid pt] making this map a little trickier to imagine. *) (** The pinch map for a suspension. *) Definition psusp_pinch (X : pType) : psusp X $-> psusp X \/ psusp X. Proof. refine (Build_pMap _ _ (Susp_rec pt pt _) idpath). intros x. refine (ap wedge_inl _ @ wglue @ ap wedge_inr _ @ wglue^). 1,2: exact (loop_susp_unit X x). Defined. (** It should compute when [ap]ed on a merid. *) Definition psusp_pinch_beta_merid {X : pType} (x : X) : ap (psusp_pinch X) (merid x) = ap wedge_inl (loop_susp_unit X x) @ wglue @ ap wedge_inr (loop_susp_unit X x) @ wglue^. Proof. rapply Susp_rec_beta_merid. Defined. (** Doing wedge projections on the pinch map gives the identity. *) Definition wedge_pr1_psusp_pinch {X} : wedge_pr1 $o psusp_pinch X $== Id (psusp X). Proof. snrapply Build_pHomotopy. - snrapply Susp_ind_FlFr. + reflexivity. + exact (merid pt). + intros x. rhs nrapply concat_1p. rhs nrapply ap_idmap. apply moveR_pM. change (?t = _) with (t = loop_susp_unit X x). lhs nrapply (ap_compose (psusp_pinch X)). lhs nrapply (ap _ (psusp_pinch_beta_merid x)). lhs nrapply ap_pp. lhs nrapply (ap (fun x => _ @ x) (ap_V _ _)). apply moveR_pV. rhs nrapply (whiskerL _ (wedge_rec_beta_wglue _ _)). lhs nrapply ap_pp. lhs nrapply (ap (fun x => _ @ x)). { lhs_V nrapply ap_compose. apply ap_const. } lhs nrapply concat_p1. lhs nrapply ap_pp. lhs nrapply (ap (fun x => _ @ x) (wedge_rec_beta_wglue _ _)). f_ap. lhs_V nrapply (ap_compose wedge_inl). apply ap_idmap. - reflexivity. Defined. Definition wedge_pr2_psusp_pinch {X} : wedge_pr2 $o psusp_pinch X $== Id (psusp X). Proof. snrapply Build_pHomotopy. - snrapply Susp_ind_FlFr. + reflexivity. + exact (merid pt). + intros x. rhs nrapply concat_1p. rhs nrapply ap_idmap. apply moveR_pM. change (?t = _) with (t = loop_susp_unit X x). lhs nrapply (ap_compose (psusp_pinch X)). lhs nrapply (ap _ (psusp_pinch_beta_merid x)). lhs nrapply ap_pp. lhs nrapply (ap (fun x => _ @ x) (ap_V _ _)). apply moveR_pV. rhs nrapply (whiskerL _ (wedge_rec_beta_wglue _ _)). lhs nrapply ap_pp. lhs nrapply (ap (fun x => _ @ x) _). { lhs_V nrapply ap_compose. apply ap_idmap. } rhs nrapply concat_p1. apply moveR_pM. lhs nrapply ap_pp. rhs nrapply concat_pV. lhs nrapply (ap _ (wedge_rec_beta_wglue _ _)). apply moveR_pM. lhs_V nrapply (ap_compose wedge_inl). rapply ap_const. - reflexivity. Defined. Coq-HoTT-9.0/theories/Homotopy/WhiteheadsPrinciple.v000066400000000000000000000076471474641544500225360ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed. Require Import WildCat.Core HFiber. Require Import Truncations. Require Import Algebra.Groups.Group. Require Import Homotopy.HomotopyGroup. Local Open Scope pointed_scope. Local Open Scope nat_scope. (** 8.8.1 *) Definition isequiv_issurj_tr0_isequiv_ap `{Univalence} {A B : Type} (f : A -> B) {i : IsSurjection (Trunc_functor 0 f)} {ii : forall x y, IsEquiv (@ap _ _ f x y)} : IsEquiv f. Proof. apply (equiv_isequiv_ap_isembedding f)^-1 in ii. srapply isequiv_surj_emb. srapply BuildIsSurjection. cbn; intro b. pose proof (@center _ (i (tr b))) as p. revert p. apply Trunc_functor. apply sig_ind. srapply Trunc_ind. intros a p. apply (equiv_path_Tr _ _)^-1 in p. strip_truncations. exists a. exact p. Defined. (** 8.8.2 *) Definition isequiv_isbij_tr0_isequiv_loops `{Univalence} {A B : Type} (f : A -> B) {i : IsEquiv (Trunc_functor 0 f)} {ii : forall x, IsEquiv (fmap loops (pmap_from_point f x)) } : IsEquiv f. Proof. srapply (isequiv_issurj_tr0_isequiv_ap f). intros x y. apply isequiv_inhab_codomain. intro p. apply (ap (@tr 0 _)) in p. apply (@equiv_inj _ _ _ i (tr x) (tr y)) in p. apply (equiv_path_Tr _ _)^-1 in p. strip_truncations. destruct p. cbn in ii. snrapply (isequiv_homotopic _ (H:=ii x)). exact (fun _ => concat_1p _ @ concat_p1 _). Defined. (** When the types are 0-connected and the map is pointed, just one [loops_functor] needs to be checked. *) Definition isequiv_is0connected_isequiv_loops `{Univalence} {A B : pType} `{IsConnected 0 A} `{IsConnected 0 B} (f : A ->* B) (e : IsEquiv (fmap loops f)) : IsEquiv f. Proof. apply isequiv_isbij_tr0_isequiv_loops. (** The pi_0 condition is trivial because [A] and [B] are 0-connected. *) 1: apply isequiv_contr_contr. (** Since [A] is 0-connected, it's enough to check the [loops_functor] condition for the basepoint. *) rapply conn_point_elim. (** The [loops_functor] condition for [pmap_from_point f _] is equivalent to the [loops_functor] condition for [f] with its given pointing. *) srapply isequiv_homotopic'. - exact (equiv_concat_lr (point_eq f) (point_eq f)^ oE (Build_Equiv _ _ _ e)). - intro r. simpl. hott_simpl. Defined. (** Truncated Whitehead's principle (8.8.3) *) Definition whiteheads_principle {ua : Univalence} {A B : Type} {f : A -> B} (n : trunc_index) {H0 : IsTrunc n A} {H1 : IsTrunc n B} {i : IsEquiv (Trunc_functor 0 f)} {ii : forall (x : A) (k : nat), IsEquiv (fmap (Pi k.+1) (pmap_from_point f x)) } : IsEquiv f. Proof. revert A B H0 H1 f i ii. induction n as [|n IHn]. 1: intros; apply isequiv_contr_contr. intros A B H0 H1 f i ii. nrefine (@isequiv_isbij_tr0_isequiv_loops ua _ _ f i _). intro x. nrefine (isequiv_homotopic (@ap _ _ f x x) _). 2:{intros p; cbn. symmetry; exact (concat_1p _ @ concat_p1 _). } pose proof (@istrunc_paths _ _ H0 x x) as h0. pose proof (@istrunc_paths _ _ H1 (f x) (f x)) as h1. nrefine (IHn (x=x) (f x=f x) h0 h1 (@ap _ _ f x x) _ _). - pose proof (ii x 0) as h2. unfold is0functor_pi in h2; cbn in h2. refine (@isequiv_homotopic _ _ _ _ h2 _). apply (O_functor_homotopy (Tr 0)); intros p. exact (concat_1p _ @ concat_p1 _). - intros p k; revert p. assert (h3 : forall (y:A) (q:x=y), IsEquiv (fmap (Pi k.+1) (pmap_from_point (@ap _ _ f x y) q))). 2:exact (h3 x). intros y q. destruct q. snrefine (isequiv_homotopic _ _). 1: exact (fmap (Pi k.+1) (fmap loops (pmap_from_point f x))). 2:{ rapply (fmap2 (Pi k.+1)); srefine (Build_pHomotopy _ _). - intros p; cbn. refine (concat_1p _ @ concat_p1 _). - reflexivity. } nrefine (isequiv_commsq _ _ _ _ (fmap_pi_loops k.+1 (pmap_from_point f x))). 2-3:refine (equiv_isequiv (pi_loops _ _)). exact (ii x k.+1). Defined. Coq-HoTT-9.0/theories/Idempotents.v000066400000000000000000001045571474641544500172560ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HFiber Constant. Require Import Truncations.Core Modalities.Modality. Require Import Homotopy.IdentitySystems. Local Open Scope nat_scope. Local Open Scope path_scope. Local Set Universe Minimization ToSet. (** * Idempotents and their splittings *) (** ** Basic definitions *) (** *** Retracts *) (** A *retract* of a type [X] is a type [A] equipped with a pair of morphisms [r : X -> A] and [s : A -> X] such that the composite [r o s] is the identity of [A]. *) Record RetractOf {X : Type} := { retract_type : Type ; retract_retr : X -> retract_type ; retract_sect : retract_type -> X ; retract_issect : retract_retr o retract_sect == idmap }. Arguments RetractOf X : clear implicits. Arguments retract_type / . Arguments retract_retr / . Arguments retract_sect / . Arguments retract_issect / . (** For example, here is the identity retraction. *) Definition idmap_retractof (X : Type) : RetractOf X := Build_RetractOf X X idmap idmap (fun _ => 1). (** Retractions can be composed with equivalences on either side. *) Definition retractof_equiv {X Y : Type} (f : X -> Y) `{feq : IsEquiv _ _ f} : RetractOf X -> RetractOf Y. Proof. intros [A r s H]; refine (Build_RetractOf Y A (r o f^-1) (f o s) _); intros x. exact (ap r (eissect f (s x)) @ H x). Defined. Definition retractof_equiv' {X Y : Type} (f : X <~> Y) : RetractOf X -> RetractOf Y := retractof_equiv f. Definition equiv_retractof {X : Type} (R : RetractOf X) {B : Type} (f : retract_type R -> B) `{feq : IsEquiv _ _ f} : RetractOf X. Proof. destruct R as [A r s H]; refine (Build_RetractOf X B (f o r) (s o f^-1) _); intros x. exact (ap f (H (f^-1 x)) @ eisretr f x). Defined. Definition equiv_retractof' {X : Type} (R : RetractOf X) {B : Type} (f : retract_type R <~> B) : RetractOf X := equiv_retractof R f. (** A commuting retract of the domain of map induces a retract of its fibers. *) Definition retractof_hfiber {X Y : Type} (R : RetractOf X) (f : X -> Y) (g : retract_type R -> Y) (p : g o retract_retr R == f) (y : Y) : RetractOf (hfiber f y). Proof. destruct R as [A r s H]; simpl in *. simple refine (Build_RetractOf (hfiber f y) (hfiber g y) _ _ _). - intros [x q]. exists (r x). exact (p x @ q). - intros [a q]. exists (s a). exact ((p (s a))^ @ ap g (H a) @ q). - intros [a q]. simple refine (path_sigma' _ _ _). + exact (H a). + abstract ( rewrite transport_paths_Fl, !concat_p_pp, concat_pp_V, concat_Vp, concat_1p; reflexivity). Defined. (** Retraction preserves contractibility **) Definition contr_retracttype {X : Type} (R : RetractOf X ) (contra : Contr X) : Contr (retract_type R ) := contr_retract (retract_retr R) (retract_sect R) (retract_issect R). (** Like any record type, [RetractOf X] is equivalent to a nested sigma-type. We use a product at one place in the middle, rather than a sigma, to simplify the next proof. *) Definition issig_retractof (X : Type) : { A : Type & {r : X -> A & {s : A -> X & r o s == idmap }}} <~> RetractOf X. Proof. issig. Defined. (* Path spaces of types of retractions *) Definition PathRetractOf (X : Type) (R' R : RetractOf X) := { Ap : retract_type R' <~> retract_type R & { rp : Ap o retract_retr R' == retract_retr R & { sp : retract_sect R' o Ap^-1 == retract_sect R & forall a, ap Ap (retract_issect R' (Ap^-1 a)) @ eisretr Ap a = rp (retract_sect R' (Ap^-1 a)) @ ap (retract_retr R) (sp a) @ retract_issect R a } } }. Definition equiv_path_retractof `{ua : Univalence} {X : Type} (R' R : RetractOf X) : PathRetractOf X R' R <~> R' = R. Proof. revert R' R; apply (equiv_path_issig_contr (issig_retractof X)). { intros [A [r [s H]]]; cbn. exists equiv_idmap. exists (fun x => 1%path). exists (fun x => 1%path). cbn. exact (fun a => equiv_p1_1q (ap_idmap (H a))). } intros [A [r [s H]]]; cbn. unfold PathRetractOf. contr_sigsig A (equiv_idmap A); cbn. contr_sigsig r (fun x:X => idpath (r x)); cbn. contr_sigsig s (fun x:A => idpath (s x)); cbn. refine (contr_equiv' {K : r o s == idmap & H == K} _). apply equiv_functor_sigma_id; intros K. apply equiv_functor_forall_id; intros a; cbn. apply equiv_concat_lr. - refine (concat_p1 _ @ ap_idmap (H a)). - symmetry; apply concat_1p. Defined. Definition path_retractof `{ua : Univalence} {X : Type} {R' R : RetractOf X} Ap rp sp Hp : R' = R := equiv_path_retractof R' R (Ap;rp;sp;Hp). (** *** Splittings *) (** If an endomap [f : X -> X] arises from a retract as [s o r], we say that that retract is a *splitting* of [f]. *) Definition retract_idem {X : Type} (R : RetractOf X) : (X -> X) := retract_sect R o retract_retr R. Arguments retract_idem {_} _ / x . Definition Splitting {X : Type} (f : X -> X) := { R : RetractOf X & retract_idem R == f}. (** For example, here is the canonical splitting of the identity. *) Definition splitting_idmap (X : Type) : @Splitting X idmap := (idmap_retractof X ; fun _ => 1). (** *** Pre-idempotents *) (** An "idempotent" is a map that at least "ought" to be splittable. The naive definition of idempotent, which is correct in set-level mathematics, is a morphism [f : X -> X] such that [forall x, f (f x) = f x]. We will call this a "pre-idempotent". *) Class IsPreIdempotent {X : Type} (f : X -> X) := isidem : forall x, f (f x) = f x. Arguments isidem {X} f {_} x. Definition ispreidem_homotopic {X : Type} (f : X -> X) `{IsPreIdempotent _ f} {g : X -> X} (p : f == g) : IsPreIdempotent g. Proof. intros x; refine (_ @ isidem f x @ p x). refine (_ @ (p (f x))^). apply ap; symmetry; apply p. Defined. Arguments ispreidem_homotopic / . Definition PreIdempotent (X : Type) := { f : X -> X & IsPreIdempotent f }. Definition preidempotent_pr1 {X : Type} : PreIdempotent X -> X -> X := pr1. Coercion preidempotent_pr1 : PreIdempotent >-> Funclass. Global Instance ispreidem_preidem {X : Type} (f : PreIdempotent X) : IsPreIdempotent f := f.2. (** The identity function has a canonical structure of a pre-idempotent. *) Global Instance ispreidem_idmap (X : Type) : @IsPreIdempotent X idmap := fun _ => 1. Definition preidem_idmap (X : Type) : PreIdempotent X. Proof. exists idmap; exact _. Defined. (** Any pre-idempotent on a set splits. *) Definition split_preidem_set (X : Type) `{IsHSet X} (f : PreIdempotent X) : Splitting f. Proof. simple refine (Build_RetractOf X { x : X & f x = x } (fun x => (f x ; isidem f x)) pr1 _ ; _). - intros [x p]; simpl. apply path_sigma with p; simpl. apply path_ishprop. - simpl. intros x; reflexivity. Defined. (** Any weakly constant pre-idempotent splits (Escardo) *) Definition split_preidem_wconst (X : Type) (f : PreIdempotent X) `{WeaklyConstant _ _ f} : Splitting f. Proof. simple refine (Build_RetractOf X (FixedBy f) (fun x => (f x ; isidem f x)) pr1 _ ; _). - intros x; apply path_ishprop. - simpl. intros x; reflexivity. Defined. (** If [f] is pre-idempotent and [f x = x] is collapsible for all [x], then [f] splits (Escardo). *) Definition split_preidem_splitsupp (X : Type) (f : PreIdempotent X) (ss : forall x, Collapsible (f x = x)) : Splitting f. Proof. simple refine (Build_RetractOf X { x : X & FixedBy (@collapse (f x = x) _) } _ pr1 _ ; _). - intros x; exists (f x); unfold FixedBy. exists (collapse (isidem f x)). apply wconst. - intros [x [p q]]; simpl. apply path_sigma with p. apply path_ishprop. - simpl. intros x; reflexivity. Defined. (** Moreover, in this case the section is an embedding. *) Definition isemb_split_preidem_splitsupp (X : Type) (f : PreIdempotent X) (ss : forall x, Collapsible (f x = x)) : IsEmbedding (retract_sect (split_preidem_splitsupp X f ss).1). Proof. apply istruncmap_mapinO_tr; exact _. Defined. (** Conversely, if [f] splits with a section that is an embedding, then (it is pre-idempotent and) [f x = x] is collapsible for all [x] (Escardo). *) Definition splitsupp_split_isemb (X : Type) (f : X -> X) (S : Splitting f) `{IsEmbedding (retract_sect S.1)} : forall x, Collapsible (f x = x). Proof. intros x. destruct S as [[A r s H] K]; simpl in *. assert (c1 : f x = x -> { a : A & s a = x }). { intros p; exists (r x). exact (K x @ p). } assert (c2 : { a : A & s a = x } -> f x = x). { intros [a q]. exact ((K x)^ @ ap (s o r) q^ @ ap s (H a) @ q). } exists (c2 o c1). apply wconst_through_hprop. Defined. (** *** Quasi-idempotents *) (** However, homotopically we may naturally expect to need some coherence on the witness [isidem] of idempotency. And indeed, in homotopy theory there are pre-idempotents which do not split; we will see an example later on. We expect a "coherent idempotent" to involve infinitely many data. However, Lemma 7.3.5.14 of *Higher Algebra* suggests that for an idempotent to admit *some* coherentification, hence also a splitting, it suffices to have *one* additional datum. By modifying the construction given there, we can show similarly in type theory that any idempotent satisfying an additional coherence datum splits. We will call a pre-idempotent with this one additional datum a "quasi-idempotent", since it is related to a fully coherent idempotent similarly to the way having a "quasi-inverse" is related to being a coherent equivalence. *) Class IsQuasiIdempotent {X : Type} (f : X -> X) `{IsPreIdempotent _ f} := isidem2 : forall x, ap f (isidem f x) = isidem f (f x). Arguments isidem2 {X} f {_ _} x. Definition isqidem_homotopic {X : Type} (f : X -> X) `{IsQuasiIdempotent _ f} {g : X -> X} (p : f == g) : @IsQuasiIdempotent X g (ispreidem_homotopic f p). Proof. intros x; unfold isidem; simpl. Open Scope long_path_scope. rewrite (concat_Ap (fun x => (p x)^) (p x)^). rewrite !ap_pp, !concat_pp_p; apply whiskerL. rewrite !concat_p_pp; apply moveL_pM. rewrite (concat_pA_p (fun x => (p x)^) (p x)). rewrite (concat_pA_p (fun x => (p x)^) (isidem _ x)). rewrite (concat_Ap (fun x => (p x)^) (ap f (p x)^)). rewrite !concat_pp_p; apply whiskerL. rewrite !ap_V; apply moveR_Vp. rewrite <- ap_compose. rewrite isidem2; try exact _. symmetry; refine (concat_Ap (isidem f) (p x)). Close Scope long_path_scope. Qed. Definition QuasiIdempotent (X : Type) := { f : PreIdempotent X & IsQuasiIdempotent f }. Definition quasiidempotent_pr1 {X : Type} : QuasiIdempotent X -> X -> X := pr1. Coercion quasiidempotent_pr1 : QuasiIdempotent >-> Funclass. Global Instance isqidem_qidem {X : Type} (f : QuasiIdempotent X) : IsQuasiIdempotent f := f.2. (** The identity function has a canonical structure of a quasi-idempotent. *) Global Instance isqidem_idmap (X : Type) : @IsQuasiIdempotent X idmap _ := fun _ => 1. Definition qidem_idmap (X : Type) : QuasiIdempotent X. Proof. exists (preidem_idmap X); exact _. Defined. (** We have made [IsPreIdempotent] and [IsQuasiIdempotent] typeclasses as an experiment. It could be that they should revert back to [Definitions]. *) (** ** Split morphisms are quasi-idempotent *) (** First we show that given a retract, the composite [s o r] is quasi-idempotent. *) Global Instance ispreidem_retract {X : Type} (R : RetractOf X) : IsPreIdempotent (retract_idem R). Proof. exact (fun x => ap (retract_sect R) (retract_issect R (retract_retr R x))). Defined. Definition preidem_retract {X : Type} (R : RetractOf X) : PreIdempotent X := (retract_idem R ; ispreidem_retract R). Arguments ispreidem_retract / . Arguments preidem_retract / . Global Instance isqidem_retract {X : Type} (R : RetractOf X) : IsQuasiIdempotent (retract_idem R). Proof. destruct R as [A r s H]; intros x; unfold isidem; simpl. refine ((ap_compose _ _ _) @ _). apply ap. refine ((ap_compose _ _ _)^ @ _). refine (cancelR _ _ (H (r x)) _). refine (concat_A1p H (H (r x))). Defined. Definition qidem_retract {X : Type} (R : RetractOf X) : QuasiIdempotent X := (preidem_retract R ; isqidem_retract R). (** In particular, it follows that any split function is quasi-idempotent. *) Global Instance ispreidem_split {X : Type} (f : X -> X) (S : Splitting f) : IsPreIdempotent f. Proof. destruct S as [R p]. refine (ispreidem_homotopic _ p); exact _. Defined. Arguments ispreidem_split / . Global Instance isqidem_split {X : Type} (f : X -> X) (S : Splitting f) : @IsQuasiIdempotent X f (ispreidem_split f S). Proof. destruct S as [R p]. refine (isqidem_homotopic _ p); exact _. Defined. Arguments isqidem_split / . (** ** Quasi-idempotents split *) (** We now show the converse, that every quasi-idempotent splits. *) Section Splitting. (** We need funext because our construction will involve a sequential limit. We could probably also use a HIT sequential colimit, which is more like what Lurie does. (Note that, like an interval type, HIT sequential colimits probably imply funext, so our construction uses strictly weaker hypotheses.) *) Context `{Funext}. Context {X : Type} (f : X -> X). Context `{IsQuasiIdempotent _ f}. Let I := isidem f. Let J : forall x, ap f (I x) = I (f x) := isidem2 f. (** The splitting will be the sequential limit of the sequence [... -> X -> X -> X]. *) Definition split_idem : Type := { a : nat -> X & forall n, f (a n.+1) = a n }. Definition split_idem_pr1 : split_idem -> (nat -> X) := pr1. Coercion split_idem_pr1 : split_idem >-> Funclass. Arguments split_idem_pr1 / . (** The section, retraction, and the fact that the composite in one direction is [f] are easy. *) Definition split_idem_sect : split_idem -> X := fun a => a 0. Arguments split_idem_sect / . Definition split_idem_retr : X -> split_idem. Proof. intros x. exists (fun n => f x). exact (fun n => I x). Defined. Arguments split_idem_retr / . Definition split_idem_splits (x : X) : split_idem_sect (split_idem_retr x) = f x := 1. (** What remains is to show that the composite in the other direction is the identity. We begin by showing how to construct paths in [split_idem]. *) Definition path_split_idem {a a' : split_idem} (p : a.1 == a'.1) (q : forall n, a.2 n @ p n = ap f (p n.+1) @ a'.2 n) : a = a'. Proof. simple refine (path_sigma' _ _ _). - apply path_arrow; intros n. exact (p n). - apply path_forall; intros n. abstract ( rewrite transport_forall_constant; rewrite transport_paths_FlFr; rewrite ap_apply_l, ap10_path_arrow; rewrite (ap_compose (fun b => b n.+1) (fun x => f x) _); rewrite ap_apply_l, ap10_path_arrow; rewrite concat_pp_p; apply moveR_Vp; by symmetry ). Defined. (** And we verify how those paths compute under [split_idem_sect]. *) Definition sect_path_split_idem {a a' : split_idem} (p : a.1 == a'.1) (q : forall n, a.2 n @ p n = ap f (p n.+1) @ a'.2 n) : ap split_idem_sect (path_split_idem p q) = p 0. Proof. change (ap ((fun b => b 0) o pr1) (path_split_idem p q) = p 0). refine (ap_compose pr1 (fun b => b 0) _ @ _). refine (ap (ap (fun b => b 0)) (pr1_path_sigma _ _) @ _). refine (ap_apply_l _ 0 @ _). apply ap10_path_arrow. Defined. (** Next we show that every element of [split_idem] can be nudged to an equivalent one in which all the elements of [X] occurring are double applications of [f]. *) Local Definition nudge (a : split_idem) : split_idem. Proof. exists (fun n => f (f (a (n.+1)))). exact (fun n => ap f (ap f (a.2 n.+1))). Defined. Local Definition nudge_eq a : nudge a = a. Proof. transparent assert (a' : split_idem). { exists (fun n => f (a (n.+1))). exact (fun n => ap f (a.2 n.+1)). } transitivity a'; simple refine (path_split_idem _ _); intros n; simpl. - exact (I (a n.+1)). - exact ((ap_compose f f _ @@ 1)^ @ concat_Ap I (a.2 n.+1) @ (J _ @@ 1)^). - exact (a.2 n). - reflexivity. Defined. (** Now we're ready to prove the final condition. We prove the two arguments of [path_split_idem] separately, in order to make the first one transparent and the second opaque. *) Local Definition split_idem_issect_part1 (a : split_idem) (n : nat) : f (f (a n.+1)) = f (a 0). Proof. induction n as [|n IH]. - exact (ap f (a.2 0)). - exact (ap f (a.2 n.+1) @ (I (a n.+1))^ @ IH). Defined. Local Definition split_idem_issect_part2 (a : split_idem) (n : nat) : ap f (ap f (a.2 n.+1)) @ split_idem_issect_part1 a n = ap f ((ap f (a.2 n.+1) @ (I (a.1 n.+1))^) @ split_idem_issect_part1 a n) @ I (a.1 0). Proof. induction n as [|n IH]; simpl. Open Scope long_path_scope. - rewrite !ap_pp, ap_V, !concat_pp_p. apply whiskerL, moveL_Vp. rewrite J. rewrite <- ap_compose; symmetry; apply (concat_Ap I). - rewrite ap_pp. refine (_ @ (1 @@ IH) @ concat_p_pp _ _ _). rewrite !ap_pp, !concat_p_pp, ap_V. rewrite J. rewrite <- !ap_compose. refine ((concat_pA_p (fun x => (I x)^) _ _) @@ 1). Close Scope long_path_scope. Qed. Definition split_idem_issect (a : split_idem) : split_idem_retr (split_idem_sect a) = a. Proof. refine (_ @ nudge_eq a); symmetry. simple refine (path_split_idem _ _). - exact (split_idem_issect_part1 a). - exact (split_idem_issect_part2 a). Defined. Definition split_idem_retract : RetractOf X := Build_RetractOf X split_idem split_idem_retr split_idem_sect split_idem_issect. Definition split_idem_split : Splitting f := (split_idem_retract ; split_idem_splits). (** We end this section by showing that we can recover the witness [I] of pre-idempotence from the splitting. *) Definition split_idem_preidem (x : X) : ap split_idem_sect (split_idem_issect (split_idem_retr x)) = I x. Proof. unfold split_idem_issect, nudge_eq. repeat (rewrite !ap_pp, ?ap_V, !sect_path_split_idem; simpl). apply moveR_Vp, whiskerR; symmetry; apply J. Qed. (** However, the particular witness [J] of quasi-idempotence can *not* in general be recovered from the splitting; we will mention a counterexample below. This is analogous to how [eissect] and [eisretr] cannot both be recovered after [isequiv_adjointify]; one of them has to be modified. *) End Splitting. Definition split_idem_retract' `{fs : Funext} {X : Type} : QuasiIdempotent X -> RetractOf X := fun f => split_idem_retract f. Definition split_idem_split' `{fs : Funext} {X : Type} (f : QuasiIdempotent X) : Splitting f := split_idem_split f. (** ** Splitting already-split idempotents *) (** In the other direction, suppose we are given a retract, we deduce from this a quasi-idempotent, and then split it by the above construction. We will show that the resulting retract is equivalent to the original one, so that [RetractOf X] is itelf a retract of [QuasiIdempotent X]. *) Section AlreadySplit. Context `{fs : Funext}. Context {X : Type} (R : RetractOf X). Let A := retract_type R. Let r := retract_retr R. Let s := retract_sect R. Let H := retract_issect R. (** We begin by constructing an equivalence between [split_idem (s o r)] and [A]. We want to make this equivalence transparent so that we can reason about it later. In fact, we want to reason not only about the equivalence function and its inverse, but the section and retraction homotopies! Therefore, instead of using [equiv_adjointify] we will give the coherence proof explicitly, so that we can control these homotopies. However, we can (and should) make the coherence proof itself opaque. Thus, we prove it first, and end it with [Qed]. *) Lemma equiv_split_idem_retract_isadj (a : split_idem (s o r)) : H (r (s (r (split_idem_sect (s o r) a)))) @ H (r (split_idem_sect (s o r) a)) = ap (r o split_idem_sect (s o r)) (ap (split_idem_retr (s o r)) (1 @ ap (split_idem_sect (s o r)) (split_idem_issect (s o r) a)) @ split_idem_issect (s o r) a). Proof. rewrite ap_pp. rewrite <- ap_compose; simpl. rewrite concat_1p. rewrite <- (ap_compose (split_idem_sect (s o r)) (r o s o r) (split_idem_issect (s o r) a)). rewrite (ap_compose _ (r o s o r) (split_idem_issect (s o r) a)). rewrite (ap_compose _ r (split_idem_issect (s o r) a)). unfold split_idem_issect, nudge_eq; repeat (rewrite !ap_pp, ?ap_V, !sect_path_split_idem; simpl). unfold isidem; fold r s H. rewrite !concat_pp_p. rewrite <- !ap_compose. rewrite <- (ap_compose (s o r) r). rewrite <- (ap_compose (s o r) (r o s o r)). rewrite (concat_p_Vp (ap (r o s o r) (a.2 0))). rewrite_moveL_Vp_p. rewrite (ap_compose (r o s o r) (r o s) (a.2 0)). rewrite (concat_A1p H (ap (r o s o r) (a.2 0))). rewrite (ap_compose r (r o s) (a.2 0)). rewrite (concat_pA1_p H (ap r (a.2 0))). apply whiskerR. refine (cancelR _ _ (H (r (a.1 1%nat))) _). rewrite (concat_pA1_p H (H (r (a 1%nat)))). rewrite !concat_pp_p; symmetry; refine (_ @ concat_pp_p _ _ _). exact (concat_A1p (fun x => H (r (s x)) @ H x) (H (r (a 1%nat)))). Qed. (** Now we can construct the desired equivalence. *) Definition equiv_split_idem_retract : split_idem (s o r) <~> A. Proof. simple refine (Build_Equiv _ _ (r o split_idem_sect (s o r)) (Build_IsEquiv _ _ _ (split_idem_retr (s o r) o s) _ _ _)). - intros a; simpl. refine (H _ @ H _). - intros a; simpl. refine (_ @ split_idem_issect (s o r) a). apply ap. refine ((split_idem_splits (s o r) _)^ @ _). apply ap, split_idem_issect; exact _. - intros a; simpl; apply equiv_split_idem_retract_isadj. Defined. (** It is easy to show that this equivalence respects the section and the retraction. *) Definition equiv_split_idem_retract_retr (x : X) : equiv_split_idem_retract (split_idem_retr (s o r) x) = r x := H (r x). Definition equiv_split_idem_retract_sect (a : A) : split_idem_sect (s o r) (equiv_split_idem_retract^-1 a) = s a := ap s (H a). (** Less trivial is to show that it respects the retract homotopy. *) Definition equiv_split_idem_retract_issect (a : A) : ap equiv_split_idem_retract (split_idem_issect (s o r) (equiv_split_idem_retract^-1 a)) @ eisretr equiv_split_idem_retract a = equiv_split_idem_retract_retr (split_idem_sect (s o r) (equiv_split_idem_retract^-1 a)) @ ap r (equiv_split_idem_retract_sect a) @ H a. Proof. simpl. unfold equiv_split_idem_retract_retr, equiv_split_idem_retract_sect. rewrite ap_compose. unfold split_idem_issect, nudge_eq. repeat (rewrite !ap_pp, ?ap_V, !sect_path_split_idem; simpl). unfold isidem; fold A r s H. Open Scope long_path_scope. rewrite !concat_pp_p; apply moveR_Vp; rewrite !concat_p_pp. do 4 rewrite <- ap_compose. (** For some reason this last one needs help. *) rewrite <- (ap_compose (s o r o s) r (H (r (s a)))). rewrite <- (ap_pp (r o s) _ _). rewrite <- (concat_A1p H (H (r (s a)))). rewrite ap_pp. rewrite <- (ap_compose (r o s) (r o s) _). rewrite !concat_pp_p; apply whiskerL; rewrite !concat_p_pp. rewrite (concat_A1p H (H (r (s a)))). rewrite !concat_pp_p; apply whiskerL. symmetry; refine (concat_A1p H (H a)). Close Scope long_path_scope. Qed. (** We will also show that it respects the homotopy to the split map. It's unclear whether this has any use. *) Definition equiv_split_idem_retract_splits (x : X) : split_idem_splits (s o r) x = ap (split_idem_sect (s o r)) (eissect equiv_split_idem_retract (split_idem_retr (s o r) x))^ @ equiv_split_idem_retract_sect (equiv_split_idem_retract (split_idem_retr (s o r) x)) @ ap s (equiv_split_idem_retract_retr x). Proof. simpl. unfold equiv_split_idem_retract_retr, equiv_split_idem_retract_sect, split_idem_splits. rewrite concat_1p, concat_pp_p, ap_V; apply moveL_Vp; rewrite concat_p1. (** Brace yourself. *) unfold split_idem_issect, nudge_eq. repeat (rewrite !ap_pp, ?ap_V, !sect_path_split_idem; simpl). (** Whew, that's not so bad. *) unfold isidem; fold A r s H. Open Scope long_path_scope. rewrite !concat_p_pp. rewrite <- !ap_compose; simpl. apply whiskerR. refine (_ @ (concat_1p _)); apply whiskerR. apply moveR_pV; rewrite concat_1p, concat_pp_p; apply moveR_Vp. rewrite <- (ap_compose (s o r o s) (s o r)). rewrite (ap_compose (r o s) s _). rewrite (ap_compose (r o s) s _). rewrite (ap_compose (r o s o r o s) s _). rewrite <- !ap_pp; apply ap. refine (cancelR _ _ (H (r x)) _). rewrite (concat_pA1_p H (H (r x)) _). rewrite (concat_pA1_p H (H (r x)) _). refine ((concat_A1p H (H (r (s (r x)))) @@ 1) @ _). rewrite (ap_compose (r o s) (r o s) _). rewrite (concat_A1p H (ap (r o s) (H (r x)))). rewrite !concat_pp_p; apply whiskerL. symmetry; refine (concat_A1p H (H (r x))). Close Scope long_path_scope. Qed. End AlreadySplit. (** Using these facts, we can show that [RetractOf X] is a retract of [QuasiIdempotent X]. *) Section RetractOfRetracts. Context `{ua : Univalence} {X : Type}. Definition retract_retractof_qidem : RetractOf (QuasiIdempotent X). Proof. refine (Build_RetractOf (QuasiIdempotent X) (RetractOf X) split_idem_retract' qidem_retract _). intros R. exact (@path_retractof _ _ (split_idem_retract' (qidem_retract R)) R (equiv_split_idem_retract R) (equiv_split_idem_retract_retr R) (equiv_split_idem_retract_sect R) (equiv_split_idem_retract_issect R)). Defined. (** We have a similar result for splittings of a fixed map [f]. *) Definition splitting_retractof_isqidem (f : X -> X) : RetractOf { I : IsPreIdempotent f & IsQuasiIdempotent f }. Proof. simple refine (@equiv_retractof' _ (@retractof_equiv' (hfiber quasiidempotent_pr1 f) _ _ (retractof_hfiber retract_retractof_qidem quasiidempotent_pr1 retract_idem (fun _ => 1) f)) (Splitting f) _). - refine ((hfiber_fibration f (fun g => { I : IsPreIdempotent g & @IsQuasiIdempotent _ g I }))^-1 oE _). unfold hfiber. refine (equiv_functor_sigma' (equiv_sigma_assoc _ _)^-1 (fun a => _)); simpl. destruct a as [[g I] J]; unfold quasiidempotent_pr1; simpl. apply equiv_idmap. - simpl. unfold hfiber, Splitting. refine (equiv_functor_sigma_id _); intros R; simpl. apply equiv_ap10. Defined. (** And also for splittings of a fixed map that also induce a given witness of pre-idempotency. *) Definition Splitting_PreIdempotent (f : PreIdempotent X) := { S : Splitting f & forall x, ap f (S.2 x)^ @ (S.2 (retract_idem S.1 x))^ @ ap (retract_sect S.1) (retract_issect S.1 (retract_retr S.1 x)) @ S.2 x = (isidem f x) }. Definition splitting_preidem_retractof_qidem (f : PreIdempotent X) : RetractOf (IsQuasiIdempotent f). Proof. simple refine (@equiv_retractof' _ (@retractof_equiv' (hfiber (@pr1 _ (fun fi => @IsQuasiIdempotent _ fi.1 fi.2)) f) _ _ (retractof_hfiber retract_retractof_qidem pr1 preidem_retract _ f)) (Splitting_PreIdempotent f) _). - symmetry; refine (hfiber_fibration f _). - intros [[g I] J]; simpl. refine (path_sigma' _ 1 _); simpl. apply path_forall; intros x; apply split_idem_preidem. - simpl; unfold hfiber, Splitting. refine (equiv_sigma_assoc _ _ oE _). apply equiv_functor_sigma_id; intros R; simpl. refine (_ oE (equiv_path_sigma _ _ _)^-1); simpl. refine (equiv_functor_sigma' (equiv_ap10 _ _) _); intros H; simpl. destruct f as [f I]; simpl in *. destruct H; simpl. refine (_ oE (equiv_path_forall _ _)^-1); unfold pointwise_paths. apply equiv_functor_forall_id; intros x; simpl. unfold isidem. apply equiv_concat_l. refine (concat_p1 _ @ concat_1p _). Defined. End RetractOfRetracts. (** ** Fully coherent idempotents *) (** This gives us a way to define fully coherent idempotents. By Corollary 4.4.5.14 of *Higher Topos Theory*, if we assume univalence then [RetractOf X] has the correct homotopy type of the type of fully coherent idempotents on [X]. However, its defect is that it raises the universe level. But now that we've shown that [RetractOf X] is a retract of the type [QuasiIdempotent X], which is of the same size as [X], we can obtain an equivalent type by splitting the resulting idempotent on [QuasiIdempotent X]. For convenience, we instead split the idempotent on splittings of a fixed map [f], and then sum them up to obtain the type of idempotents. *) Section CoherentIdempotents. Context {ua : Univalence}. Class IsIdempotent {X : Type} (f : X -> X) := is_coherent_idem : split_idem (retract_idem (splitting_retractof_isqidem f)). Definition Build_IsIdempotent {X : Type} (f : X -> X) : Splitting f -> IsIdempotent f := (equiv_split_idem_retract (splitting_retractof_isqidem f))^-1. Definition isidem_isqidem {X : Type} (f : X -> X) `{IsQuasiIdempotent _ f} : IsIdempotent f := Build_IsIdempotent f (split_idem_split f). Global Instance ispreidem_isidem {X : Type} (f : X -> X) `{IsIdempotent _ f} : IsPreIdempotent f. Proof. refine (split_idem_sect (retract_idem (splitting_retractof_isqidem f)) _).1. assumption. Defined. Global Instance isqidem_isidem {X : Type} (f : X -> X) `{IsIdempotent _ f} : @IsQuasiIdempotent X f (ispreidem_isidem f). Proof. refine (split_idem_sect (retract_idem (splitting_retractof_isqidem f)) _).2. Defined. Definition Idempotent (X : Type) := { f : X -> X & IsIdempotent f }. Definition idempotent_pr1 {X : Type} : Idempotent X -> (X -> X) := pr1. Coercion idempotent_pr1 : Idempotent >-> Funclass. Global Instance isidem_idem (X : Type) (f : Idempotent X) : IsIdempotent f := f.2. (** The above definitions depend on [Univalence]. Technically this is the case by their construction, since they are a splitting of a map that we only know to be idempotent in the presence of univalence. This map could be defined, and hence "split", without univalence; but also only with univalence do we know that they have the right homotopy type. Thus univalence is used in two places: concluding (meta-theoretically) from HTT 4.4.5.14 that [RetractOf X] has the right homotopy type, and showing (in the next lemma) that it is equivalent to [Idempotent X]. In the absence of univalence, we don't currently have *any* provably-correct definition of the type of coherent idempotents; it ought to involve an infinite tower of coherences as defined in HTT section 4.4.5. However, there may be some Yoneda-like meta-theoretic argument which would imply that the above-defined types do have the correct homotopy type without univalence (though almost certainly not without funext). *) Definition equiv_idempotent_retractof (X : Type) : Idempotent X <~> RetractOf X. Proof. transitivity ({ f : X -> X & Splitting f }). - unfold Idempotent. refine (equiv_functor_sigma' (equiv_idmap _) _); intros f; simpl. refine (equiv_split_idem_retract (splitting_retractof_isqidem f)). - unfold Splitting. refine (_ oE equiv_sigma_symm _). apply equiv_sigma_contr; intros R. apply contr_basedhomotopy. Defined. (** For instance, here is the standard coherent idempotent structure on the identity map. *) Global Instance isidem_idmap (X : Type@{i}) : @IsIdempotent@{i i j} X idmap := Build_IsIdempotent idmap (splitting_idmap X). Definition idem_idmap (X : Type@{i}) : Idempotent@{i i j} X := (idmap ; isidem_idmap X). End CoherentIdempotents. (** ** Quasi-idempotents need not be fully coherent *) (** We have shown that every quasi-idempotent can be "coherentified" into a fully coherent idempotent, analogously to how every quasi-inverse can be coherentified into an equivalence. However, just as for quasi-inverses, not every witness to quasi-idempotency *is itself* coherent. This is in contrast to a witness of pre-idempotency, which (if it extends to a quasi-idempotent) can itself be extended to a coherent idempotent; this is roughly the content of [split_idem_preidem] and [splitting_preidem_retractof_qidem]. The key step in showing this is to observe that when [f] is the identity, the retract type [Splitting_PreIdempotent f] of [splitting_preidem_retractof_qidem] is equivalent to the type of types-equivalent-to-[X], and hence contractible. *) Definition contr_splitting_preidem_idmap {ua : Univalence} (X : Type) : Contr (Splitting_PreIdempotent (preidem_idmap X)). Proof. refine (contr_equiv' {Y : Type & X <~> Y} _). transitivity { S : Splitting (preidem_idmap X) & forall x : X, (retract_issect S.1) (retract_retr S.1 x) = ap (retract_retr S.1) (S.2 x) }. 1:make_equiv. apply equiv_functor_sigma_id; intros [[Y r s eta] ep]; cbn in *. apply equiv_functor_forall_id; intros x. unfold ispreidem_idmap; simpl. rewrite ap_idmap, !concat_pp_p. refine (equiv_moveR_Vp _ _ _ oE _). rewrite concat_p1, concat_p_pp. refine (equiv_concat_r (concat_1p _) _ oE _). refine (equiv_whiskerR _ _ _ oE _). refine (equiv_moveR_Vp _ _ _ oE _). rewrite concat_p1. pose (isequiv_adjointify s r ep eta). refine (_ oE equiv_ap (ap s) _ _). apply equiv_concat_r. refine (cancelR _ _ (ep x) _). rewrite <- ap_compose. refine (concat_A1p ep (ep x)). Qed. (** Therefore, there is a unique coherentification of the canonical witness [preidem_idmap] of pre-idempotency for the identity. Hence, to show that not every quasi-idempotent is coherent, it suffices to give a witness of quasi-idempotency extending [preidem_idmap] which is nontrivial (i.e. not equal to [qidem_idmap]). Such a witness is exactly an element of the 2-center, and we know that some types such as [BAut (BAut Bool)] have nontrivial 2-centers. In [Spaces.BAut.Bool.IncoherentIdempotent] we use this to construct an explicit counterexample. *) (** ** A pre-idempotent that is not quasi-idempotent *) (** We can also give a specific example of a pre-idempotent that does not split, hence is not coherentifiable and not even quasi-idempotent. The construction is inspired by Warning 1.2.4.8 in *Higher Algebra*, and can be found in [Spaces.BAut.Cantor]. *) Coq-HoTT-9.0/theories/Limits/000077500000000000000000000000001474641544500160215ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Limits/Equalizer.v000066400000000000000000000015461474641544500201570ustar00rootroot00000000000000Require Import Basics Types.Sigma Types.Paths. (** Equalizers *) Definition Equalizer {A B} (f g : A -> B) := {x : A & f x = g x}. Definition functor_equalizer {A B A' B'} (f g : A -> B) (f' g' : A' -> B') (h : B -> B') (k : A -> A') (p : h o f == f' o k) (q : h o g == g' o k) : Equalizer f g -> Equalizer f' g'. Proof. intros [x r]. exists (k x). exact ((p x)^ @ (ap h r) @ (q x)). Defined. Definition equiv_functor_equalizer {A B A' B'} (f g : A -> B) (f' g' : A' -> B') (h : B <~> B') (k : A <~> A') (p : h o f == f' o k) (q : h o g == g' o k) : Equalizer f g <~> Equalizer f' g'. Proof. unfold Equalizer. srapply (equiv_functor_sigma' k). - intro a; cbn. refine (_ oE _). 2: rapply (equiv_ap h). exact (equiv_concat_r (q a) _ oE equiv_concat_l (p a)^ _). Defined. Coq-HoTT-9.0/theories/Limits/Limit.v000066400000000000000000000127451474641544500172770ustar00rootroot00000000000000Require Import Basics. Require Import Diagrams.Diagram. Require Import Diagrams.Graph. Require Import Diagrams.Cone. Require Import Diagrams.ConstantDiagram. Local Open Scope path_scope. Generalizable All Variables. (** This file contains the definition of limits, and functoriality results on limits. *) (** * Limits *) (** A Limit is the extremity of a cone. *) Class IsLimit `(D : Diagram G) (Q : Type) := { islimit_cone : Cone Q D; islimit_unicone : UniversalCone islimit_cone; }. (* Use :> and remove the two following lines, once Coq 8.16 is the minimum required version. *) #[export] Existing Instance islimit_cone. Coercion islimit_cone : IsLimit >-> Cone. Arguments Build_IsLimit {G D Q} C H : rename. Arguments islimit_cone {G D Q} C : rename. Arguments islimit_unicone {G D Q} H : rename. (** [cone_precompose_inv] is defined for convenience: it is only the inverse of [cone_precompose]. It allows to recover the map [h] from a cone [C']. *) Definition cone_precompose_inv `{D: Diagram G} {Q X} (H : IsLimit D Q) (C' : Cone X D) : X -> Q := @equiv_inv _ _ _ (islimit_unicone H X) C'. (** * Existence of limits *) Record Limit `(D : Diagram G) := { lim : forall i, D i; limp : forall i j (g : G i j), D _f g (lim i) = lim j; }. Arguments lim {_ _}. Arguments limp {_ _}. Definition cone_limit `(D : Diagram G) : Cone (Limit D) D. Proof. srapply Build_Cone. + intros i x. apply (lim x i). + intros i j g x. apply limp. Defined. Global Instance unicone_limit `(D : Diagram G) : UniversalCone (cone_limit D). Proof. srapply Build_UniversalCone; intro Y. srapply isequiv_adjointify. { intros c y. srapply Build_Limit. { intro i. apply (legs c i y). } intros i j g. apply legs_comm. } all: intro; reflexivity. Defined. Global Instance islimit_limit `(D : Diagram G) : IsLimit D (Limit D) := Build_IsLimit (cone_limit _) _. (** * Functoriality of limits *) Section FunctorialityLimit. Context `{Funext} {G : Graph}. (** Limits are preserved by composition with a (diagram) equivalence. *) Definition islimit_precompose_equiv {D : Diagram G} `(f : Q <~> Q') : IsLimit D Q' -> IsLimit D Q. Proof. intros HQ. srapply (Build_IsLimit (cone_precompose HQ f) _). apply cone_precompose_equiv_universality, HQ. Defined. Definition islimit_postcompose_equiv {D1 D2 : Diagram G} (m : D1 ~d~ D2) {Q : Type} : IsLimit D1 Q -> IsLimit D2 Q. Proof. intros HQ. srapply (Build_IsLimit (cone_postcompose m HQ) _). apply cone_postcompose_equiv_universality, HQ. Defined. (** A diagram map [m] : [D1] => [D2] induces a map between any two limits of [D1] and [D2]. *) Definition functor_limit {D1 D2 : Diagram G} (m : DiagramMap D1 D2) {Q1 Q2} (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2) : Q1 -> Q2 := cone_precompose_inv HQ2 (cone_postcompose m HQ1). (** And this map commutes with diagram map. *) Definition functor_limit_commute {D1 D2 : Diagram G} (m : DiagramMap D1 D2) {Q1 Q2} (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2) : cone_postcompose m HQ1 = cone_precompose HQ2 (functor_limit m HQ1 HQ2) := (eisretr (cone_precompose HQ2) _)^. (** ** Limits of equivalent diagrams *) (** Now we have than two equivalent diagrams have equivalent limits. *) Context {D1 D2 : Diagram G} (m : D1 ~d~ D2) {Q1 Q2} (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2). Definition functor_limit_eissect : functor_limit m HQ1 HQ2 o functor_limit (diagram_equiv_inv m) HQ2 HQ1 == idmap. Proof. apply ap10. srapply (equiv_inj (cone_precompose HQ2) _). 1: apply HQ2. etransitivity. 2:symmetry; apply cone_precompose_identity. etransitivity. 1: apply cone_precompose_comp. rewrite eisretr, cone_postcompose_precompose, eisretr. rewrite cone_postcompose_comp, diagram_inv_is_section. apply cone_postcompose_identity. Defined. Definition functor_limit_eisretr : functor_limit (diagram_equiv_inv m) HQ2 HQ1 o functor_limit m HQ1 HQ2 == idmap. Proof. apply ap10. srapply (equiv_inj (cone_precompose HQ1) _). 1: apply HQ1. etransitivity. 2:symmetry; apply cone_precompose_identity. etransitivity. 1: apply cone_precompose_comp. rewrite eisretr, cone_postcompose_precompose, eisretr. rewrite cone_postcompose_comp, diagram_inv_is_retraction. apply cone_postcompose_identity. Defined. Global Instance isequiv_functor_limit : IsEquiv (functor_limit m HQ1 HQ2) := isequiv_adjointify _ _ functor_limit_eissect functor_limit_eisretr. Definition equiv_functor_limit : Q1 <~> Q2 := Build_Equiv _ _ _ isequiv_functor_limit. End FunctorialityLimit. (** * Unicity of limits *) (** A particuliar case of the functoriality result is that all limits of a diagram are equivalent (and hence equal in presence of univalence). *) Theorem limit_unicity `{Funext} {G : Graph} {D : Diagram G} {Q1 Q2 : Type} (HQ1 : IsLimit D Q1) (HQ2 : IsLimit D Q2) : Q1 <~> Q2. Proof. srapply equiv_functor_limit. srapply (Build_diagram_equiv (diagram_idmap D)). Defined. (** * Limits are right adjoint to constant diagram *) Theorem limit_adjoint {G : Graph} {D : Diagram G} {C : Type} : (C -> Limit D) <~> DiagramMap (diagram_const C) D. Proof. srapply equiv_adjointify. { intro f. srapply Build_DiagramMap. { intros i c. apply lim, f, c. } intros i j g x. apply limp. } { intros [f p] c. srapply Build_Limit. { intro i. apply f, c. } intros i j g. apply p. } 1,2: intro; reflexivity. Defined. Coq-HoTT-9.0/theories/Limits/Pullback.v000066400000000000000000000403741474641544500177550ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HFiber Homotopy.IdentitySystems Cubical.PathSquare. Require Import Diagrams.CommutativeSquares. Local Open Scope path_scope. (** * Pullbacks *) (** The pullback as an object *) Definition Pullback {A B C} (f : B -> A) (g : C -> A) := { b : B & { c : C & f b = g c }}. Global Arguments Pullback {A B C}%_type_scope (f g)%_function_scope. (** The universal commutative square *) Definition pullback_pr1 {A B C} {f : B -> A} {g : C -> A} : Pullback f g -> B := (fun z => z.1). Definition pullback_pr2 {A B C} {f : B -> A} {g : C -> A} : Pullback f g -> C := (fun z => z.2.1). Definition pullback_commsq {A B C} (f : B -> A) (g : C -> A) : f o pullback_pr1 == g o pullback_pr2 := (fun z => z.2.2). (** The universally induced map into it by any commutative square *) Definition pullback_corec {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) : A -> Pullback k g := fun a => (f a ; h a ; p a). Definition pullback_corec_uncurried {A B C D} (k : B -> D) (g : C -> D) : { f : A -> B & { h : A -> C & k o f == g o h }} -> (A -> Pullback k g). Proof. intros [f [h p]]. exact (pullback_corec p). Defined. Global Instance isequiv_pullback_corec {A B C D} (k : B -> D) (g : C -> D) : IsEquiv (@pullback_corec_uncurried A B C D k g). Proof. snrapply isequiv_adjointify. - intro m. exact (pullback_pr1 o m ; pullback_pr2 o m ; (pullback_commsq k g) o m). - reflexivity. - reflexivity. Defined. Definition equiv_pullback_corec {A B C D} (k : B -> D) (g : C -> D) : { f : A -> B & { h : A -> C & k o f == g o h }} <~> (A -> Pullback k g) := Build_Equiv _ _ _ (isequiv_pullback_corec k g). (** A homotopy commutative square is equivalent to a pullback of arrow types *) Definition equiv_ispullback_commsq `{Funext} {A B C D} (k : B -> D) (g : C -> D) : { f : A -> B & { h : A -> C & k o f == g o h }} <~> @Pullback (A -> D) (A -> B) (A -> C) (fun f => k o f) (fun h => g o h). Proof. apply equiv_functor_sigma_id; intro f. apply equiv_functor_sigma_id; intro h. apply equiv_path_forall. Defined. (** The diagonal of a map *) Definition diagonal {X Y : Type} (f : X -> Y) : X -> Pullback f f := fun x => (x;x;idpath). (** The fiber of the diagonal is a path-space in the fiber. *) Definition hfiber_diagonal {X Y : Type} (f : X -> Y) (p : Pullback f f) : hfiber (diagonal f) p <~> ((p.1 ; p.2.2) = (p.2.1 ; idpath) :> hfiber f (f p.2.1)). Proof. destruct p as [x1 [x2 p]]; cbn. refine (_ oE equiv_functor_sigma_id (fun x => (equiv_path_sigma _ _ _)^-1)); cbn. refine (_ oE equiv_sigma_assoc' _ _). refine (_ oE equiv_contr_sigma _); cbn. refine (equiv_path_sigma _ _ _ oE _ oE (equiv_path_sigma _ _ _)^-1); cbn. apply equiv_functor_sigma_id; intros q. destruct q; cbn. apply equiv_path_inverse. Defined. (** Symmetry of the pullback *) Definition equiv_pullback_symm {A B C} (f : B -> A) (g : C -> A) : Pullback f g <~> Pullback g f. Proof. refine (_ oE equiv_sigma_symm (fun b c => f b = g c)). apply equiv_functor_sigma_id; intros c. apply equiv_functor_sigma_id; intros b. apply equiv_path_inverse. Defined. (** Pullback over [Unit] is equivalent to a product. *) Definition equiv_pullback_unit_prod (A B : Type) : Pullback (const_tt A) (const_tt B) <~> A * B. Proof. simple refine (equiv_adjointify _ _ _ _). - intros [a [b _]]; exact (a , b). - intros [a b]; exact (a ; b ; 1). - intros [a b]; exact 1. - intros [a [b p]]; simpl. apply (path_sigma' _ 1); simpl. apply (path_sigma' _ 1); simpl. apply path_contr. Defined. (** The property of a given commutative square being a pullback *) Definition IsPullback {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) := IsEquiv (pullback_corec p). Definition equiv_ispullback {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) (ip : IsPullback p) : A <~> Pullback k g := Build_Equiv _ _ (pullback_corec p) ip. (** This is equivalent to the transposed square being a pullback. *) Definition ispullback_symm {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : g o h == k o f) (pb : IsPullback (fun a => (p a)^)) : IsPullback p. Proof. rapply (cancelL_isequiv (equiv_pullback_symm g k)). apply pb. Defined. (** The pullback of the projections [{d:D & P d} -> D <- {d:D & Q d}] is equivalent to [{d:D & P d * Q d}]. *) Definition ispullback_sigprod {D : Type} (P Q : D -> Type) : IsPullback (fun z:{d:D & P d * Q d} => 1%path : (z.1;fst z.2).1 = (z.1;snd z.2).1). Proof. srapply isequiv_adjointify. - intros [[d1 p] [[d2 q] e]]; cbn in e. exists d1. exact (p, e^ # q). - intros [[d1 p] [[d2 q] e]]; unfold pullback_corec; cbn in *. destruct e; reflexivity. - intros [d [p q]]; reflexivity. Defined. Definition equiv_sigprod_pullback {D : Type} (P Q : D -> Type) : {d:D & P d * Q d} <~> Pullback (@pr1 D P) (@pr1 D Q) := Build_Equiv _ _ _ (ispullback_sigprod P Q). (** For any commutative square, the fiber of the fibers is equivalent to the fiber of the "gap map" [pullback_corec]. *) Definition hfiber_pullback_corec {A B C D} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) (b : B) (c : C) (q : k b = g c) : hfiber (pullback_corec p) (b; c; q) <~> hfiber (functor_hfiber p b) (c; q^). Proof. unfold hfiber, functor_hfiber, functor_sigma. refine (equiv_sigma_assoc _ _ oE _). apply equiv_functor_sigma_id; intros a; cbn. refine (_ oE (equiv_path_sigma _ _ _)^-1); cbn. apply equiv_functor_sigma_id; intro p0; cbn. rewrite transport_sigma'; cbn. refine ((equiv_path_sigma _ _ _) oE _ oE (equiv_path_sigma _ _ _)^-1); cbn. apply equiv_functor_sigma_id; intro p1; cbn. rewrite !transport_paths_Fr, !transport_paths_Fl. refine (_ oE (equiv_ap (equiv_path_inverse _ _) _ _)); cbn. apply equiv_concat_l. refine (_ @ (inv_pp _ _)^). apply whiskerL. refine (_ @ (inv_pp _ _)^). apply whiskerL. symmetry; apply inv_V. Defined. (** If the induced maps on fibers are equivalences, then a square is a pullback. *) Definition ispullback_isequiv_functor_hfiber {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) (e : forall b:B, IsEquiv (functor_hfiber p b)) : IsPullback p. Proof. unfold IsPullback. apply isequiv_contr_map; intro x. rapply contr_equiv'. - symmetry; apply hfiber_pullback_corec. - exact _. Defined. (** Conversely, if the square is a pullback then the induced maps on fibers are equivalences. *) Definition isequiv_functor_hfiber_ispullback {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) (e : IsPullback p) : forall b:B, IsEquiv (functor_hfiber p b). Proof. apply isequiv_from_functor_sigma. unfold IsPullback in e. snrapply isequiv_commsq'. 4: exact (equiv_fibration_replacement f)^-1%equiv. 1: exact (Pullback k g). 1: exact (pullback_corec p). { apply (functor_sigma idmap); intro b. apply (functor_sigma idmap); intro c. apply inverse. } { intros [x [y q]]. destruct q. apply (path_sigma' _ idpath). apply (path_sigma' _ idpath). simpl. refine (_^ @ (inv_Vp _ _)^). apply concat_1p. } all: exact _. Defined. (** The pullback of a map along another one *) Definition pullback_along {A B C} (f : B -> A) (g : C -> A) : Pullback f g -> B := pr1. Notation "f ^*" := (pullback_along f) : function_scope. Definition hfiber_pullback_along {A B C} (f : B -> A) (g : C -> A) (b:B) : hfiber (f ^* g) b <~> hfiber g (f b). Proof. refine (equiv_functor_sigma_id (fun c => equiv_path_inverse _ _) oE _). make_equiv_contr_basedpaths. Defined. (** And the dual sort of pullback *) Definition pullback_along' {A B C} (g : C -> A) (f : B -> A) : Pullback f g -> C := fun z => z.2.1. Arguments pullback_along' / . Notation "g ^*'" := (pullback_along' g) : function_scope. Definition hfiber_pullback_along' {A B C} (g : C -> A) (f : B -> A) (c:C) : hfiber (g ^*' f) c <~> hfiber f (g c). Proof. make_equiv_contr_basedpaths. Defined. (** A version where [g] is pointed, but we unbundle the pointed condition to avoid importing pointed types. *) Definition hfiber_pullback_along_pointed {A B C} {c : C} {a : A} (g : C -> A) (f : B -> A) (p : g c = a) : hfiber (g ^*' f) c <~> hfiber f a. Proof. refine (_ oE hfiber_pullback_along' _ _ _); cbn. srapply (equiv_functor_hfiber2 (h:=equiv_idmap) (k:=equiv_idmap)). - reflexivity. - assumption. Defined. Section Functor_Pullback. Context {A1 B1 C1 A2 B2 C2} (f1 : B1 -> A1) (g1 : C1 -> A1) (f2 : B2 -> A2) (g2 : C2 -> A2) (h : A1 -> A2) (k : B1 -> B2) (l : C1 -> C2) (p : f2 o k == h o f1) (q : g2 o l == h o g1). Definition functor_pullback : Pullback f1 g1 -> Pullback f2 g2 := functor_sigma k (fun b1 => (functor_sigma l (fun c1 e1 => p b1 @ ap h e1 @ (q c1)^))). Definition hfiber_functor_pullback (z : Pullback f2 g2) : hfiber functor_pullback z <~> Pullback (transport (hfiber h) z.2.2 o functor_hfiber (k := f2) p z.1) (functor_hfiber q z.2.1). Proof. destruct z as [b2 [c2 e2]]. refine (_ oE hfiber_functor_sigma _ _ _ _ _ _). apply equiv_functor_sigma_id. intros [b1 e1]; simpl. refine (_ oE (equiv_transport _ (transport_sigma' e1^ (c2; e2)))). refine (_ oE hfiber_functor_sigma _ _ _ _ _ _); simpl. apply equiv_functor_sigma_id. intros [c1 e3]; simpl. refine (_ oE (equiv_transport _ (ap (fun e => e3^ # e) (transport_paths_Fl e1^ e2)))). refine (_ oE (equiv_transport _ (transport_paths_Fr e3^ _))). unfold functor_hfiber; simpl. refine (equiv_concat_l (transport_sigma' e2 _) _ oE _); simpl. refine (equiv_path_sigma _ _ _ oE _); simpl. apply equiv_functor_sigma_id; intros e0; simpl. refine (equiv_concat_l (transport_paths_Fl e0 _) _ oE _). refine (equiv_concat_l (whiskerL (ap h e0)^ (transport_paths_r e2 _)) _ oE _). refine (equiv_moveR_Vp _ _ _ oE _). refine (equiv_concat_l (concat_pp_p _ _ _) _ oE _). refine (equiv_moveR_Vp _ _ _ oE _). do 2 refine (equiv_concat_r (concat_pp_p _ _ _) _ oE _). refine (equiv_moveL_pM _ _ _ oE _). abstract (rewrite !ap_V, inv_V; refine (equiv_path_inverse _ _)). Defined. End Functor_Pullback. Section EquivPullback. Context {A B C f g A' B' C' f' g'} (eA : A <~> A') (eB : B <~> B') (eC : C <~> C') (p : f' o eB == eA o f) (q : g' o eC == eA o g). Lemma equiv_pullback : Pullback f g <~> Pullback f' g'. Proof. unfold Pullback. apply (equiv_functor_sigma' eB); intro b. apply (equiv_functor_sigma' eC); intro c. refine (equiv_concat_l (p _) _ oE _). refine (equiv_concat_r (q _)^ _ oE _). refine (equiv_ap' eA _ _). Defined. End EquivPullback. (** Pullbacks commute with sigmas *) Section PullbackSigma. Context {X Y Z : Type} {A : X -> Type} {B : Y -> Type} {C : Z -> Type} (f : Y -> X) (g : Z -> X) (r : forall x, B x -> A (f x)) (s : forall x, C x -> A (g x)). Definition equiv_sigma_pullback : {p : Pullback f g & Pullback (transport A p.2.2 o r p.1) (s p.2.1)} <~> Pullback (functor_sigma f r) (functor_sigma g s). Proof. refine (equiv_functor_sigma_id (fun _ => equiv_functor_sigma_id _) oE _). - intros; rapply equiv_path_sigma. - make_equiv. Defined. End PullbackSigma. (** ** Paths in pullbacks *) Definition equiv_path_pullback {A B C} (f : B -> A) (g : C -> A) (x y : Pullback f g) : { p : x.1 = y.1 & { q : x.2.1 = y.2.1 & PathSquare (ap f p) (ap g q) x.2.2 y.2.2 } } <~> (x = y). Proof. revert y; rapply equiv_path_from_contr. { exists idpath. exists idpath. cbn. apply sq_refl_v. } destruct x as [b [c p]]; unfold Pullback; cbn. contr_sigsig b (idpath b). contr_sigsig c (idpath c). cbn. rapply (contr_equiv' {p' : f b = g c & p = p'}). apply equiv_functor_sigma_id; intros p'. apply sq_1G. Defined. (** Maps into pullbacks are determined by their composites with the projections, and a coherence. This can also be proved directly. With [Funext], we could also prove an equivalence analogous to [equiv_path_pullback_rec_hset] below. Not sure of the best name for this version. *) Definition pullback_homotopic {A B C D} {g : C -> D} {k : B -> D} (f h : A -> Pullback k g) (p1 : pullback_pr1 o f == pullback_pr1 o h) (p2 : pullback_pr2 o f == pullback_pr2 o h) (q : forall a, (ap k) (p1 a) @ (h a).2.2 = (f a).2.2 @ (ap g) (p2 a)) : f == h. Proof. intro a. apply equiv_path_pullback. exists (p1 a). exists (p2 a). apply sq_path, q. Defined. (** When [A] is a set, the [PathSquare] becomes trivial. *) Definition equiv_path_pullback_hset {A B C} `{IsHSet A} (f : B -> A) (g : C -> A) (x y : Pullback f g) : (x.1 = y.1) * (x.2.1 = y.2.1) <~> (x = y). Proof. refine (equiv_path_pullback f g x y oE _^-1%equiv). refine (_ oE equiv_sigma_prod (fun pq => PathSquare (ap f (fst pq)) (ap g (snd pq)) (x.2).2 (y.2).2)). rapply equiv_sigma_contr. (* Uses [istrunc_sq]. *) Defined. Lemma equiv_path_pullback_rec_hset `{Funext} {A X Y Z : Type} `{IsHSet Z} (f : X -> Z) (g : Y -> Z) (phi psi : A -> Pullback f g) : ((pullback_pr1 o phi == pullback_pr1 o psi) * (pullback_pr2 o phi == pullback_pr2 o psi)) <~> (phi == psi). Proof. refine (_ oE equiv_prod_coind _ _). srapply equiv_functor_forall_id; intro a; cbn. apply equiv_path_pullback_hset. Defined. (** The 3x3 Lemma *) Section Pullback3x3. Context (A00 A02 A04 A20 A22 A24 A40 A42 A44 : Type) (f01 : A00 -> A02) (f03 : A04 -> A02) (f10 : A00 -> A20) (f12 : A02 -> A22) (f14 : A04 -> A24) (f21 : A20 -> A22) (f23 : A24 -> A22) (f30 : A40 -> A20) (f32 : A42 -> A22) (f34 : A44 -> A24) (f41 : A40 -> A42) (f43 : A44 -> A42) (H11 : f12 o f01 == f21 o f10) (H13 : f12 o f03 == f23 o f14) (H31 : f32 o f41 == f21 o f30) (H33 : f32 o f43 == f23 o f34). Let fX1 := functor_pullback f10 f30 f12 f32 f21 f01 f41 H11 H31. Let fX3 := functor_pullback f14 f34 f12 f32 f23 f03 f43 H13 H33. Let f1X := functor_pullback f01 f03 f21 f23 f12 f10 f14 (symmetry _ _ H11) (symmetry _ _ H13). Let f3X := functor_pullback f41 f43 f21 f23 f32 f30 f34 (symmetry _ _ H31) (symmetry _ _ H33). Theorem pullback3x3 : Pullback fX1 fX3 <~> Pullback f1X f3X. Proof. refine (_ oE _ oE _). 1,3:do 2 (rapply equiv_functor_sigma_id; intro). 1:apply equiv_path_pullback. 1:symmetry; apply equiv_path_pullback. refine (_ oE _). { do 4 (rapply equiv_functor_sigma_id; intro). refine (sq_tr oE _). refine (sq_move_14^-1 oE _). refine (sq_move_31 oE _). refine (sq_move_24^-1 oE _). refine (sq_move_23^-1 oE _). rewrite 2 inv_V. reflexivity. } make_equiv. Defined. End Pullback3x3. (** Pasting for pullbacks (or 2-pullbacks lemma) *) Section Pasting. (** Given the following diagram where the right square is a pullback square, then the outer square is a pullback square if and only if the left square is a pullback. *) (* A --k--> B --l--> C | // | // | f comm g comm h | // | // | V // V // V X --i--> Y --j--> Z *) Context {A B C X Y Z : Type} {k : A -> B} {l : B -> C} {f : A -> X} {g : B -> Y} {h : C -> Z} {i : X -> Y} {j : Y -> Z} (H : i o f == g o k) (K : j o g == h o l) {e1 : IsPullback K}. Definition ispullback_pasting_left : IsPullback (comm_square_comp' H K) -> IsPullback H. Proof. intro e2. apply ispullback_isequiv_functor_hfiber. intro b. pose (e1' := isequiv_functor_hfiber_ispullback _ e1 (i b)). pose (e2' := isequiv_functor_hfiber_ispullback _ e2 b). snrapply isequiv_commsq'. 7: apply isequiv_idmap. 4: apply (functor_hfiber_compose H K b). 1,2: exact _. Defined. Definition ispullback_pasting_outer : IsPullback H -> IsPullback (comm_square_comp' H K). Proof. intro e2. apply ispullback_isequiv_functor_hfiber. intro b. pose (e1' := isequiv_functor_hfiber_ispullback _ e1 (i b)). pose (e2' := isequiv_functor_hfiber_ispullback _ e2 b). snrapply isequiv_commsq'. 9: apply isequiv_idmap. 4: symmetry; apply (functor_hfiber_compose H K b). 1,2: exact _. Defined. End Pasting. Coq-HoTT-9.0/theories/Metatheory/000077500000000000000000000000001474641544500167015ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Metatheory/Core.v000066400000000000000000000016651474641544500177700ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. (** * Metatheory *) (** This directory contains files that prove important metatheoretic results about HoTT, but that are not important for internal development of mathematics in HoTT. Thus, no files in this directory should ever need to be imported by files outside of this directory. *) (** Many of these results are about ways to prove univalence and function extensionality (which in the main library we simply assert as axioms, though we track their usage with dummy typeclasses). For convenience, here we define the types of these two statements. *) Definition Funext_type@{i j max} := forall (A : Type@{i}) (P : A -> Type@{j}) f g, IsEquiv (@apD10@{i j max} A P f g). (** Univalence is a property of a single universe; its statement lives in a higher universe *) Definition Univalence_type@{i iplusone} : Type@{iplusone} := forall (A B : Type@{i}), IsEquiv (equiv_path@{i iplusone} A B). Coq-HoTT-9.0/theories/Metatheory/FunextVarieties.v000066400000000000000000000164471474641544500222310ustar00rootroot00000000000000(** * Varieties of function extensionality *) Require Import HoTT.Basics HoTT.Types. Require Import Metatheory.Core. Local Open Scope path_scope. (** In the Overture, we defined function extensionality to be the assertion that the map [apD10] is an equivalence. We now prove that this follows from a couple of weaker-looking forms of function extensionality. We do require eta conversion, which Coq 8.4+ has judgmentally. This proof is originally due to Voevodsky; it has since been simplified by Peter Lumsdaine and Michael Shulman. *) (** Naive funext is the simple assertion that pointwise equal functions are equal. The domain and codomain could live in different universes; the third universe argument is essentially the max of [i] and [j] (and similarly for all subsequent axioms). *) Definition NaiveFunext := forall (A : Type@{i}) (P : A -> Type@{j}) (f g : forall x, P x), (forall x, f x = g x) -> (f = g). (** Naive non-dependent funext is the same, but only for non-dependent functions. *) Definition NaiveNondepFunext := forall (A B : Type) (f g : A -> B), (forall x, f x = g x) -> (f = g). (** Weak funext says that a product of contractible types is contractible. *) Definition WeakFunext := forall (A : Type) (P : A -> Type), (forall x, Contr (P x)) -> Contr (forall x, P x). (** The obvious implications are Funext -> NaiveFunext -> WeakFunext and NaiveFunext -> NaiveNondepFunext. None of these do anything fiddly with the universes either. *) Definition Funext_implies_NaiveFunext@{i j max} : Funext_type@{i j max} -> NaiveFunext@{i j max}. Proof. intros fe A P f g h. unfold Funext_type in *. exact ((@apD10 A P f g)^-1 h). Defined. Definition NaiveFunext_implies_WeakFunext@{i j max} : NaiveFunext@{i j max} -> WeakFunext@{i j max}. Proof. intros nf A P Pc. apply (Build_Contr _ (fun x => center (P x))). intros f; apply nf; intros x. apply contr. Defined. Definition NaiveFunext_implies_NaiveNondepFunext@{i j max} : NaiveFunext@{i j max} -> NaiveNondepFunext@{i j max} := fun nf A B f g => nf A (fun _ => B) f g. (** The non-obvious directions are that WeakFunext implies Funext and that NaiveNondepFunext implies WeakFunext (and hence all four are logically equivalent). *) (** ** Weak funext implies Funext *) (** To show that WeakFunext implies Funext, the point is that under weak funext, the space of "pointwise homotopies" has the same universal property as the space of paths. *) Section Homotopies. Context (wf : WeakFunext). Context {A:Type} {B : A -> Type}. Context (f : forall x, B x). (* Recall that [f == g] is the type of pointwise paths (or "homotopies") from [f] to [g]. *) Let idhtpy : f == f := fun x => idpath (f x). (** Weak funext implies that the "based homotopy space" of the Pi-type is contractible, just like the based path space. *) (** Use priority 1, so we don't override [Contr Unit]. *) Global Instance contr_basedhtpy : Contr {g : forall x, B x & f == g } | 1. Proof. unfold WeakFunext in wf. (* Allow typeclass inference to find it *) apply (Build_Contr _ (f;idhtpy)). intros [g h]. (* The trick is to show that the type [{g : forall x, B x & f == g }] is a retract of [forall x, {y : B x & f x = y}], which is contractible due to J and weak funext. Here are the retraction and its section. *) pose (r := fun k => exist (fun g => f == g) (fun x => (k x).1) (fun x => (k x).2)). pose (s := fun (g : forall x, B x) (h : f == g) x => (g x ; h x)). (* Because of judgemental eta-conversion, the retraction is actually definitional, so we can just replace the goal. *) change (r (fun x => (f x ; idpath (f x))) = r (s g h)). apply ap; srapply path_contr. Defined. (** This enables us to prove that pointwise homotopies have the same elimination rule as the identity type. *) Context (Q : forall g (h : f == g), Type). Context (d : Q f idhtpy). Definition htpy_ind g h : Q g h := @transport _ (fun gh => Q gh.1 gh.2) (f;idhtpy) (g;h) (@path_contr _ _ _ _) d. (** The computation rule, of course, is only propositional. *) Definition htpy_ind_beta : htpy_ind f idhtpy = d := transport (fun p : (f;idhtpy) = (f;idhtpy) => transport (fun gh => Q gh.1 gh.2) p d = d) (@path2_contr _ _ _ _ (path_contr (f;idhtpy) (f;idhtpy)) (idpath _))^ (idpath _). End Homotopies. (** Now the proof is fairly easy; we can just use the same induction principle on both sides. This proof also preserves all the universes. *) Theorem WeakFunext_implies_Funext@{i j max} : WeakFunext@{i j max} -> Funext_type@{i j max}. Proof. intros wf; hnf; intros A B f g. refine (isequiv_adjointify (@apD10 A B f g) (htpy_ind wf f (fun g' _ => f = g') idpath g) _ _). - revert g; refine (htpy_ind wf _ _ _). refine (ap _ (htpy_ind_beta wf _ _ _)). - intros h; destruct h. refine (htpy_ind_beta wf _ _ _). Defined. Definition NaiveFunext_implies_Funext : NaiveFunext -> Funext_type := WeakFunext_implies_Funext o NaiveFunext_implies_WeakFunext. (** ** Naive non-dependent funext implies weak funext *) (** First we show that naive non-dependent funext suffices to show that postcomposition with an equivalence is an equivalence. *) Definition equiv_postcompose_from_NaiveNondepFunext (nf : NaiveNondepFunext) {A B C : Type} (f : B <~> C) : (A -> B) <~> (A -> C) := Build_Equiv _ _ (fun (g:A->B) => f o g) (isequiv_adjointify (fun (g:A->B) => f o g) (fun h => f^-1 o h) (fun h => nf _ _ _ _ (fun x => eisretr f (h x))) (fun g => nf _ _ _ _ (fun y => eissect f (g y)))). (** Now, if each [P x] is contractible, the projection [pr1 : {x:X & P x} -> X] is an equivalence (this requires no funext). Thus, postcomposition with it is also an equivalence, and hence the fiber of postcomposition over [idmap X] is contractible. But this fiber is "the type of sections of [pr1]" and hence equivalent to [forall x:X, P x]. The latter equivalence requires full funext to prove, but without any funext we can show that [forall x:X, P x] is a *retract* of the type of sections, hence also contractible. *) Theorem NaiveNondepFunext_implies_WeakFunext : NaiveNondepFunext -> WeakFunext. Proof. intros nf X P H. pose (T := (hfiber (equiv_postcompose_from_NaiveNondepFunext nf (equiv_pr1 P)) idmap)). exact (@contr_retract T _ _ (fun fp x => transport P (ap10 fp.2 x) (fp.1 x).2) (fun f => ((fun x => (x ; f x)) ; 1)) (fun f => 1)). Defined. (** Therefore, naive nondependent funext also implies full funext. Interestingly, this requires the universe of the assumption codomain to be not just that of the conclusion codomain, but the max of that universe with the domain universe (which is unchanged). *) Definition NaiveNondepFunext_implies_Funext@{i j max} : NaiveNondepFunext@{i max max} -> Funext_type@{i j max} := WeakFunext_implies_Funext o NaiveNondepFunext_implies_WeakFunext. (** ** Functional extensionality is downward closed *) (** If universe [U_i] is functionally extensional, then so are universes [U_i'] for [i' ≤ i]. *) Lemma Funext_downward_closed@{i j max i' j' max' | i <= max, j <= max, i' <= max', j' <= max', i' <= i, j' <= j} `{H : Funext_type@{i j max}} : Funext_type@{i' j' max'}. Proof. hnf in *. (* Here we make use of cumulativity. *) exact (fun A P => H A P). Defined. Coq-HoTT-9.0/theories/Metatheory/ImpredicativeTruncation.v000066400000000000000000000132351474641544500237300ustar00rootroot00000000000000(** * Impredicative truncations *) (** In this file, under the assumptions of propositional resizing [PropResizing] and function extensionality [Funext], we define the proposition truncation in any universe. In the main library, these are constructed using HITs. The definitions here are meant to be for illustration. *) Require Import HoTT.Basics. Require Import Universes.Smallness. Local Open Scope path_scope. (** Using only function extensionality, we can define a "propositional truncation" [Trm A] of a type [A] in universe [i] which eliminates into propositions in universe [j]. It lands in [max(i,j+1)]. So if we want it to land in universe [i], then we can only eliminate into propositions in a strictly smaller universe [j]. Or, if we want it to eliminate into propositions in universe [i], then it must land in a strictly larger universe. *) Definition Trm@{i j | } (A : Type@{i}) := forall P:Type@{j}, IsHProp P -> (A -> P) -> P. Definition trm@{i j | } {A : Type@{i}} : A -> Trm@{i j} A := fun a P HP f => f a. (** Here [k] plays the role of [max(i,j+1)]. *) Global Instance ishprop_Trm@{i j k | i <= k, j < k} `{Funext} (A : Type@{i}) : IsHProp (Trm@{i j} A). Proof. nrapply istrunc_forall@{k k k}; intro B. nrapply istrunc_forall@{j k k}; intro ishp. apply istrunc_forall@{k j k}. Defined. (** As mentioned above, it eliminates into propositions in universe [j]. *) Definition Trm_rec@{i j | } {A : Type@{i}} {P : Type@{j}} {p : IsHProp@{j} P} (f : A -> P) : Trm@{i j} A -> P := fun ma => ma P p f. (** This computes definitionally. *) Definition Trm_rec_beta@{i j | } {A : Type@{i}} {P : Type@{j}} `{IsHProp P} (f : A -> P) : Trm_rec@{i j} f o trm == f := fun _ => idpath. (** Because of the universe constraints, we can't make this into a functor on [Type@{i}]. We have a universe constraint [i' <= j] and [Trm@{i j} A] lands in [max(i,j+1)], which is strictly larger. *) Definition functor_Trm@{i j i' j' | i' <= j, j' < j} `{Funext} {A : Type@{i}} {A' : Type@{i'}} (f : A -> A') : Trm@{i j} A -> Trm@{i' j'} A' := Trm_rec (trm o f). (** We also record the dependent induction principle. But it only computes propositionally. *) Definition Trm_ind@{i j k | i <= k, j < k} {A : Type@{i}} `{Funext} {P : Trm@{i j} A -> Type@{j}} {p : forall x, IsHProp@{j} (P x)} (f : forall a, P (trm a)) : forall x, P x. Proof. unfold Trm. intro x. rapply x. intro a. refine (transport P _ (f a)). rapply path_ishprop@{k}. Defined. (** The universe constraints go away if we assume propositional resizing. *) Section AssumePropResizing. Context `{PropResizing}. (** If we assume propositions resizing, then we may as well quantify over propositions in the lowest universe [Set] when defining the truncation. This reduces the number of universe variables. We also assume that [Set < i], so that the construction lands in universe [i]. *) Definition imp_Trm@{i | Set < i} (A : Type@{i}) : Type@{i} := Trm@{i Set} A. (** Here we use propositional resizing to resize a arbitrary proposition [P] from an arbitrary universe [j] to universe [Set], so there is no constraint on the universe [j]. In particular, we can take [j = i], which shows that [imp_Trm] is a reflective subuniverse of [Type@{i}], since any two maps into a proposition agree. *) Definition imp_Trm_rec@{i j | Set < i} {A : Type@{i}} {P : Type@{j}} `{IsHProp P} (f : A -> P) : imp_Trm@{i} A -> P := fun ma => (equiv_smalltype@{Set j} P) (ma (smalltype@{Set j} P) _ ((equiv_smalltype@{Set j} P)^-1 o f)). (** Similarly, there are no constraints between [i] and [i'] in the next definition, so they could be taken to be equal. *) Definition functor_imp_Trm@{i i' | Set < i, Set < i'} `{Funext} {A : Type@{i}} {A' : Type@{i'}} (f : A -> A') : imp_Trm@{i} A -> imp_Trm@{i'} A' := imp_Trm_rec (trm o f). (** Note that [imp_Trm_rec] only computes propositionally. *) Definition imp_Trm_rec_beta@{i j | Set < i} {A : Type@{i}} {P : Type@{j}} `{IsHProp P} (f : A -> P) : imp_Trm_rec@{i j} f o trm == f. Proof. intro a. unfold imp_Trm_rec, trm; cbn beta. apply eisretr@{Set j}. Defined. End AssumePropResizing. (** Above, we needed the constraint [Set < i]. But one can use propositional resizing again to make [imp_Trm] land in the lowest universe, if that is needed. (We'll in fact let it land in any universe [u].) To do this, we need to assume [Funext] in the definition of the truncation itself. *) Section TruncationWithFunext. Context `{PropResizing} `{Funext}. (** [Funext] implies that [Trm A] is a proposition, so [PropResizing] can be used to put it in any universe. The construction passes through universe [k], which represents [max(i,Set+1)]. *) Definition resized_Trm@{i k u | i <= k, Set < k} (A : Type@{i}) : Type@{u} := smalltype@{u k} (Trm@{i Set} A). Definition resized_trm@{i k u | i <= k, Set < k} {A : Type@{i}} : A -> resized_Trm@{i k u} A := (equiv_smalltype _)^-1 o trm. Definition resized_Trm_rec@{i j k u | i <= k, Set < k} {A : Type@{i}} {P : Type@{j}} `{IsHProp P} (f : A -> P) : resized_Trm@{i k u} A -> P. Proof. refine (_ o (equiv_smalltype@{u k} _)). exact (fun ma => (equiv_smalltype@{Set j} P) (ma (smalltype@{Set j} P) _ ((equiv_smalltype@{Set j} P)^-1 o f))). Defined. (** The beta rule is again propositional. *) Definition resized_Trm_rec_beta@{i j k u | i <= k, Set < k} {A : Type@{i}} {P : Type@{j}} `{IsHProp P} (f : A -> P) : resized_Trm_rec@{i j k u} f o resized_trm == f. Proof. intro a. unfold resized_Trm_rec, resized_trm, Trm, trm; cbn beta. rewrite eisretr@{u k}. apply eisretr@{Set j}. Defined. End TruncationWithFunext. Coq-HoTT-9.0/theories/Metatheory/IntervalImpliesFunext.v000066400000000000000000000013351474641544500233730ustar00rootroot00000000000000(** * An interval type implies function extensionality *) Require Import HoTT.Basics. Require Import HIT.Interval. Require Import Metatheory.Core Metatheory.FunextVarieties. (** From an interval type with definitional computation rules on the end points, we can prove function extensionality. *) Definition funext_type_from_interval : Funext_type := WeakFunext_implies_Funext (NaiveFunext_implies_WeakFunext (fun A P f g p => let h := fun (x:interval) (a:A) => interval_rec _ (f a) (g a) (p a) x in ap h seg)). (** Note that the converse is also true: function extensionality implies that an interval type exists, with definitional computation rules. This is illustrated in TruncImpliesFunext.v. *) Coq-HoTT-9.0/theories/Metatheory/Nat.v000066400000000000000000001131661474641544500176220ustar00rootroot00000000000000(** * Defining the natural numbers from univalence and propresizing. *) Require Import Basics. Require Import Types. Require Import HProp. Require Import Universes.Smallness. Local Open Scope path_scope. (* Be careful about [Import]ing this file! Usually you want to use the standard [Nat] instead. *) (** Using propositional resizing and univalence, we can construct the natural numbers rather than defining them as an inductive type. In concrete practice there is no reason we would want to do this, but semantically it means that an elementary (oo,1)-topos (unlike an elementary 1-topos) automatically has a natural numbers object. *) Section AssumeStuff. Context {UA:Univalence} {PR:PropResizing}. (** The basic idea is that since the universe is closed under coproducts, it is already "infinite", so we can find the "smallest infininte set" N inside it. To get rid of the automorphisms in the universe coming from univalence and make N a set, instead of the universe of types we consider graphs (we could use posets or many other things too; in fact the graphs we are interested in will be posets). *) (** Here is the readable definition of [Graph]: > Definition Graph := { V : Type & { E : V -> V -> Type & forall x y, IsHProp@{hp} (E x y) }}. However, to enable performance speedups by controlling universes, we write out its universe parameters explicitly, making it less readable. Moreover, since here we will eventually only be interested in those graphs that represent natural numbers, it does no harm to fix these universes at the outset throughout the entire development. *) (** [s] : universe of the vertex and edge types [u] : universe of the graph type, morally [s+1] *) Universes s u. Definition Graph@{} := @sig@{u u} Type@{s} (fun V => @sig@{u u} (V -> V -> Type@{s}) (fun E => forall x y, IsHProp (E x y))). (** We also write out its constructors and fields explicitly to control their universes. *) Definition Build_Graph@{} (vert : Type@{s}) (edge : vert -> vert -> Type@{s}) (ishprop_edge : forall x y, IsHProp (edge x y)) : Graph := @exist@{u u} Type@{s} (fun V => @sig@{u u} (V -> V -> Type@{s}) (fun E => forall x y, IsHProp (E x y))) vert (@exist@{u u} (vert -> vert -> Type@{s}) (fun E => forall x y, IsHProp (E x y)) edge ishprop_edge). Definition vert@{} : Graph -> Type@{s} := pr1. Definition edge@{} (A : Graph) : vert A -> vert A -> Type@{s} := pr1 (pr2 A). Instance ishprop_edge@{} (A : Graph) (x y : vert A) : IsHProp (edge A x y) := pr2 (pr2 A) x y. (** We will need universe annotations in a few more places, but not many. *) Definition equiv_path_graph@{} (A B : Graph) : { f : vert A <~> vert B & forall x y, edge A x y <-> edge B (f x) (f y) } <~> (A = B). Proof. srefine (equiv_path_sigma _ A B oE _). srefine (equiv_functor_sigma' (equiv_path_universe (vert A) (vert B)) _). intros f; cbn. rewrite transport_sigma. srefine (equiv_path_sigma_hprop _ _ oE _). cbn. srefine (equiv_path_forall _ _ oE _). srefine (equiv_functor_forall' (f^-1) _). intros x. srefine (equiv_path_forall _ _ oE _). srefine (equiv_functor_forall' (f^-1) _). intros y. cbn. rewrite transport_arrow. rewrite transport_arrow_toconst. rewrite !transport_path_universe_V. rewrite !eisretr. srefine (equiv_path_universe _ _ oE _). srefine (equiv_equiv_iff_hprop _ _). Qed. (** N will be the set of graphs generated by the empty graph as "zero", and "adding a new top element" as "successor". *) Definition graph_zero@{} : Graph := Build_Graph Empty (fun x y => @Empty_rec@{u} Type@{s} x) (fun x y => Empty_rec x). Definition graph_succ@{} (A : Graph) : Graph. Proof. srefine (Build_Graph (sum@{s s} (vert A) Unit) _ _). - intros [x|x] [y|y]. + exact (edge A x y). + exact Unit. + exact Empty. + exact Unit. - cbn; intros [x|x] [y|y]; exact _. Defined. (** The following lemmas about graphs will be used later on to prove the Peano axioms about N. *) Definition graph_succ_top@{} {A : Graph} (x : vert (graph_succ A)) : edge (graph_succ A) x (inr tt). Proof. destruct x as [x|x]; exact tt. Qed. Definition graph_succ_top_unique@{} {A : Graph} (y : vert (graph_succ A)) (yt : forall x, edge (graph_succ A) x y) : y = inr tt. Proof. destruct y as [y|[]]. - destruct (yt (inr tt)). - reflexivity. Qed. Definition graph_succ_not_top@{} {A : Graph} (x : vert A) : ~(edge (graph_succ A) (inr tt) (inl x)) := idmap. Definition graph_succ_not_top_unique@{} {A : Graph} (x : vert (graph_succ A)) (xt : ~(edge (graph_succ A) (inr tt) x)) : is_inl x. Proof. destruct x as [x|x]. - exact tt. - destruct (xt tt). Qed. Section Graph_Succ_Equiv. Context {A B : Graph} (f : vert (graph_succ A) <~> vert (graph_succ B)) (e : forall x y, edge (graph_succ A) x y <-> edge (graph_succ B) (f x) (f y)). Definition graph_succ_equiv_inr@{} : f (inr tt) = inr tt. Proof. apply (graph_succ_top_unique (f (inr tt))). intros x. rewrite <- (eisretr f x). apply (fst (e (f^-1 x) (inr tt))). apply graph_succ_top. Qed. Local Definition Ha@{} : forall x, is_inl (f (inl x)). Proof. intros x. apply graph_succ_not_top_unique. rewrite <- (eisretr f (inr tt)). intros ed. apply (snd (e (f^-1 (inr tt)) (inl x))) in ed. pose (finr := graph_succ_equiv_inr). apply moveL_equiv_V in finr. rewrite <- finr in ed. exact (graph_succ_not_top x ed). Qed. (* Coq bug: without the [:Unit] annotation some floating universe appears. *) Local Definition Hb@{} : forall x:Unit, is_inr (f (inr x)). Proof. destruct x. srefine (transport@{s Set} is_inr graph_succ_equiv_inr^ tt). Qed. Definition graph_unsucc_equiv_vert@{} : vert A <~> vert B := equiv_unfunctor_sum_l@{s s s s s s} f Ha Hb. Definition graph_unsucc_equiv_edge@{} (x y : vert A) : iff@{s s s} (edge A x y) (edge B (graph_unsucc_equiv_vert x) (graph_unsucc_equiv_vert y)). Proof. pose (h := e (inl x) (inl y)). rewrite <- (unfunctor_sum_l_beta f Ha x) in h. rewrite <- (unfunctor_sum_l_beta f Ha y) in h. exact h. Qed. End Graph_Succ_Equiv. Definition graph_succ_path_equiv@{} (A B : Graph) : (A = B) <~> (graph_succ A = graph_succ B). Proof. refine ((equiv_path_graph _ _) oE _). refine (_ oE (equiv_path_graph _ _)^-1). srefine (equiv_adjointify _ _ _ _). - intros [f e]. exists (f +E 1). intros x y. destruct x as [x|x]; destruct y as [y|y]; cbn. + apply e. + split; apply idmap. + split; apply idmap. + split; apply idmap. - intros [f e]. exists (graph_unsucc_equiv_vert f e). exact (graph_unsucc_equiv_edge f e). - intros [f e]. apply path_sigma_hprop; cbn. apply path_equiv, path_arrow; intros [x|[]]; cbn. + apply unfunctor_sum_l_beta. + symmetry; apply graph_succ_equiv_inr, e. - intros [f e]. apply path_sigma_hprop; cbn. apply path_equiv, path_arrow; intros x; reflexivity. Defined. Definition graph_unsucc_path@{} (A B : Graph) : (graph_succ A = graph_succ B) -> A = B := (graph_succ_path_equiv A B)^-1. (** Here is the impredicative definition of N, as the smallest subtype of [Graph] containing [graph_zero] and closed under [graph_succ]. *) Definition in_N@{p} (n : Graph) := forall (P : Graph -> Type@{p}), (forall A, IsHProp (P A)) -> P graph_zero -> (forall A, P A -> P (graph_succ A)) -> P n. Instance ishprop_in_N@{p sp} (n : Graph) : IsHProp@{sp} (in_N@{p} n). Proof. apply istrunc_forall. Qed. (** [p] : universe of [N], morally [u+1] i.e. [s+2]. *) Universe p. Definition N@{} : Type@{p} := @sig@{u p} Graph in_N@{u}. Definition path_N@{} (n m : N) : n.1 = m.1 -> n = m := path_sigma_hprop@{u p p} n m. Definition zero@{} : N. Proof. exists graph_zero. intros P PH P0 Ps; exact P0. Defined. Definition succ@{} : N -> N. Proof. intros [n nrec]. exists (graph_succ n). intros P PH P0 Ps. apply Ps. exact (nrec P PH P0 Ps). Defined. (** First Peano axiom: successor is injective *) Definition succ_inj@{} (n m : N) (p : succ n = succ m) : n = m. Proof. apply path_N. apply ((graph_succ_path_equiv n.1 m.1)^-1). exact (p..1). Qed. (** A slightly more general version of the theorem that N is a set, which will be useful later. *) Lemma ishprop_path_graph_in_N@{} (A B : Graph) (Arec : in_N@{u} A) : IsHProp (A = B). Proof. apply hprop_inhabited_contr; intros []. apply Arec; try exact _. - apply contr_inhabited_hprop; try exact 1. apply hprop_allpath. equiv_intro (equiv_path_graph graph_zero graph_zero) fe. destruct fe as [f e]. equiv_intro (equiv_path_graph graph_zero graph_zero) fe'. destruct fe' as [f' e']. apply equiv_ap; try exact _. apply path_sigma_hprop, path_equiv@{s s s}, path_arrow. intros []. - try clear B;intros B BC. refine (contr_equiv (B = B) (graph_succ_path_equiv B B)). Qed. Instance ishprop_path_N@{} (n : N) (A : Graph) : IsHProp (n.1 = A). Proof. apply ishprop_path_graph_in_N, pr2. Qed. Instance ishset_N@{} : IsHSet N. Proof. apply istrunc_S. intros n m. change (IsHProp (n = m)). refine (istrunc_equiv_istrunc (n.1 = m.1) (equiv_path_sigma_hprop n m)). Qed. Definition graph_zero_neq_succ@{} {A : Graph} : graph_zero <> graph_succ A. Proof. intros p. destruct ((equiv_path_graph graph_zero (graph_succ A))^-1 p) as [f e]. exact (f^-1 (inr tt)). Qed. (** Second Peano axiom: zero is not a successor *) Definition zero_neq_succ@{} (n : N) : zero <> succ n. Proof. intros p; apply pr1_path in p; refine (graph_zero_neq_succ p). Qed. (** This tweak is sometimes necessary to avoid universe inconsistency. It's how the impredicativity of propositional resizing enters. *) Definition resize_nrec@{p0 p1} (n : Graph) (nrec : in_N@{p0} n) : in_N@{p1} n. Proof. intros P' PH' P0' Ps'. srefine ((equiv_smalltype (P' n)) (nrec (fun A => smalltype (P' A)) _ _ _)); try exact _; cbn. - exact ((equiv_smalltype (P' graph_zero))^-1 P0'). - intros A P'A. exact ((equiv_smalltype (P' (graph_succ A)))^-1 (Ps' A ((equiv_smalltype (P' A)) P'A))). Qed. Local Instance ishprop_graph_zero_or_succ@{} : forall n : Graph, IsHProp ((n = graph_zero) + { m : N & n = graph_succ m.1 }). Proof. intros n. apply ishprop_sum@{u p p}. - apply (@istrunc_equiv_istrunc _ _ (equiv_path_inverse _ _)),ishprop_path_graph_in_N. exact zero.2. - apply @ishprop_sigma_disjoint. + intros m;apply (@istrunc_equiv_istrunc _ _ (equiv_path_inverse _ _)). apply ishprop_path_graph_in_N. exact ((succ m).2). + intros x y ex ey. apply succ_inj, path_N. path_via n. - intros e0 [m es]. apply zero_neq_succ with m, path_N. path_via n. Qed. Local Instance ishprop_N_zero_or_succ@{} : forall n : N, IsHProp ((n = zero) + { m : N & n = succ m }). Proof. intros n. apply ishprop_sum. - exact _. - apply ishprop_sigma_disjoint. intros x y ex ey. apply succ_inj;path_via n. - intros e0 [m es]. apply zero_neq_succ with m. path_via n. Qed. Definition N_zero_or_succ@{} (n : N) : (n = zero) + { m : N & n = succ m }. Proof. apply (functor_sum (path_N _ _) (functor_sigma (Q := fun m:N => n = succ m) idmap (fun m => path_N _ (succ m)))). destruct n as [n nrec]; cbn. srefine (resize_nrec n nrec (fun n => (n = graph_zero) + {m : N & n = graph_succ m.1}) _ _ _); cbn. - apply inl; reflexivity. - intros A [A0|[m As]]; apply inr. + exists zero. rewrite A0. reflexivity. + exists (succ m). rewrite As. reflexivity. Qed. Definition pred_in_N@{} (n : Graph) (snrec : in_N@{u} (graph_succ n)) : in_N@{u} n. Proof. destruct (N_zero_or_succ (graph_succ n ; snrec)) as [H0|[m Hs]]. - apply pr1_path in H0; cbn in H0. destruct (graph_zero_neq_succ H0^). - apply pr1_path in Hs. apply graph_unsucc_path in Hs. apply (transport@{u p} in_N Hs^). exact m.2. Qed. (** Final Peano axiom: induction. Importantly, the universe of the motive [P] is not constrained but can be arbitrary. *) Definition N_propind@{P} (P : N -> Type@{P}) `{forall n, IsHProp (P n)} (P0 : P zero) (Ps : forall n, P n -> P (succ n)) : forall n, P n. Proof. intros [n nrec]. pose (Q := fun m:Graph => forall (mrec : in_N m), P (m;mrec)). refine (resize_nrec n nrec Q _ _ _ nrec); clear n nrec. - intros zrec. refine (transport P _ P0). apply ap. apply path_ishprop. - intros A QA Asrec. pose (m := (A ; pred_in_N A Asrec) : N). refine (transport P _ (Ps m (QA (pred_in_N A Asrec)))). apply path_N; reflexivity. Qed. (** A first application *) Definition N_neq_succ@{} (n : N) : n <> succ n. Proof. revert n; apply N_propind@{p}. - intros n;exact istrunc_arrow@{p p p}. - apply zero_neq_succ. - intros n H e. apply H. exact (succ_inj n (succ n) e). Qed. (** Now we want to use induction to define recursion. The basic idea is the same as always: define partial attempts and show by induction that they are uniquely defined. But we have to be careful to phrase it in a way that works without assuming any truncation restritions on the codomain. First we need inequality on N, which we define in terms of addition. Normally addition is defined *using* recursion, but here we can "cheat" because we know how to add graphs, and then prove that it satisfies the recursive equations for addition. *) Definition graph_add@{} (A B : Graph) : Graph. Proof. exists (vert A + vert B). exists (fun ab ab' => match ab, ab' return Type@{s} with | inl a, inl a' => edge A a a' | inl a, inr b => Unit | inr b, inl a => Empty | inr b, inr b' => edge B b b' end). intros [a|b] [a'|b']; exact _. Defined. Definition graph_add_zero_r@{} (A : Graph) : graph_add A graph_zero = A. Proof. apply equiv_path_graph. exists (sum_empty_r (vert A)). intros [x|[]] [y|[]]. apply iff_reflexive@{u s}. Qed. Definition graph_add_zero_l@{} (A : Graph) : graph_add graph_zero A = A. Proof. apply equiv_path_graph. exists (sum_empty_l (vert A)). intros [[]|x] [[]|y]. apply iff_reflexive@{u s}. Qed. Definition graph_add_succ@{} (A B : Graph) : graph_add A (graph_succ B) = graph_succ (graph_add A B). Proof. apply equiv_path_graph. exists (equiv_inverse (equiv_sum_assoc (vert A) (vert B) Unit)). intros [x|[x|[]]] [y|[y|[]]];apply iff_reflexive@{u s}. Qed. Definition graph_add_assoc@{} (A B C : Graph) : graph_add (graph_add A B) C = graph_add A (graph_add B C). Proof. apply equiv_path_graph. exists (equiv_sum_assoc _ _ _). intros [[x|x]|x] [[y|y]|y]; apply iff_reflexive@{u s}. Qed. Definition graph_one@{} : Graph := Build_Graph Unit (fun _ _ : Unit => Unit) _. Definition graph_add_one_succ@{} (A : Graph) : graph_add A graph_one = graph_succ A. Proof. apply equiv_path_graph. exists equiv_idmap. intros [x|[]] [y|[]]; apply iff_reflexive@{u s}. Qed. Definition graph_succ_zero@{} : graph_succ graph_zero = graph_one. Proof. rewrite <- graph_add_one_succ. apply graph_add_zero_l. Qed. Definition one@{} : N. Proof. exists graph_one. intros P PH P0 Ps. rewrite <- graph_succ_zero. apply Ps, P0. Defined. Definition N_add@{} (n m : N) : N. Proof. exists (graph_add n.1 m.1). intros P PH P0 Ps. apply m.2. - intros; apply PH. - apply (transport P (graph_add_zero_r n.1)^). exact (n.2 P PH P0 Ps). - intros A PA. apply (transport P (graph_add_succ n.1 A)^). apply Ps, PA. Defined. Notation "n + m" := (N_add n m). Definition N_add_zero_l@{} (n : N) : zero + n = n. Proof. apply path_N, graph_add_zero_l. Qed. Definition N_add_zero_r@{} (n : N) : n + zero = n. Proof. apply path_N, graph_add_zero_r. Qed. Definition N_add_succ@{} (n m : N) : n + succ m = succ (n + m). Proof. apply path_N, graph_add_succ. Qed. Definition N_add_assoc@{} (n m k : N) : (n + m) + k = n + (m + k). Proof. apply path_N, graph_add_assoc. Qed. Definition N_add_cancel_r@{} (n m k : N) (H : n + k = m + k) : n = m. Proof. revert k H. refine (N_propind _ _ _). - intros H; rewrite !N_add_zero_r in H; exact H. - intros k H1 H2. rewrite !N_add_succ in H2. apply H1. exact (succ_inj _ _ H2). Qed. Definition N_add_cancel_zero_r@{} (n k : N) (H : k + n = n) : k = zero. Proof. refine (N_add_cancel_r k zero n _). rewrite H; symmetry. apply path_N, graph_add_zero_l. Qed. Definition N_add_one_r@{} (n : N) : n + one = succ n. Proof. apply path_N; cbn. apply graph_add_one_succ. Qed. Definition N_add_one_l@{} (n : N) : one + n = succ n. Proof. revert n; refine (N_propind (fun m => one + m = succ m) _ _). - rewrite N_add_zero_r. apply path_N. symmetry; apply graph_succ_zero. - intros n H. rewrite N_add_succ. apply ap, H. Qed. Definition N_add_succ_l@{} (n m : N) : succ n + m = succ (n + m). Proof. rewrite <- (N_add_one_r n). rewrite N_add_assoc. rewrite N_add_one_l. apply N_add_succ. Qed. (** Now we define inequality in terms of addition. *) Definition N_le@{} (n m : N) : Type@{p} := { k : N & k + n = m }. Notation "n <= m" := (N_le n m). Local Instance ishprop_N_le@{} n m : IsHProp (n <= m). Proof. apply ishprop_sigma_disjoint. intros x y e1 e2. apply N_add_cancel_r with n. path_via m. Qed. Definition N_zero_le@{} (n : N) : zero <= n. Proof. exists n. apply N_add_zero_r. Qed. Definition N_le_zero@{} (n : N) (H : n <= zero) : n = zero. Proof. destruct H as [k H]. apply pr1_path in H. apply ((equiv_path_graph _ _)^-1), pr1 in H. pose proof ((fun x => H (inr x)) : (vert n.1) -> Empty) as f. apply path_N, equiv_path_graph. srefine ((Build_Equiv _ _ f _);_); cbn. intros x y; destruct (f x). Qed. Instance contr_le_zero@{} : Contr {n:N & n <= zero}. Proof. apply (Build_Contr _ (exist (fun n => n <= zero) zero (N_zero_le zero))). intros [n H]. apply path_sigma_hprop. exact (N_le_zero n H)^. Qed. Instance reflexive_N_le@{} : Reflexive N_le. Proof. intros n. exists zero. apply N_add_zero_l. Qed. Definition N_lt@{} (n m : N) : Type@{p} := { k : N & (succ k) + n = m }. Notation "n < m" := (N_lt n m). Lemma ishprop_N_lt@{} n m : IsHProp (n < m). Proof. apply ishprop_sigma_disjoint. intros x y e1 e2. apply N_add_cancel_r with (succ n). rewrite !N_add_succ, <-!N_add_succ_l. path_via m. Qed. Local Existing Instance ishprop_N_lt. Definition N_lt_zero@{} (n : N) : ~(n < zero). Proof. unfold N_lt; intros [k H]. apply pr1_path, (equiv_path_graph _ _)^-1, pr1 in H. exact (H (inl (inr tt))). Qed. Definition N_lt_irref@{} (n : N) : ~(n < n). Proof. revert n; apply N_propind@{p}. - intros n;exact istrunc_arrow@{p p p}. - apply N_lt_zero. - intros n H [k K]. apply H; exists k. rewrite N_add_succ in K. apply succ_inj; assumption. Qed. Definition N_le_eq_or_lt@{} (n m : N) (H : n <= m) : (n = m) + (n < m). Proof. assert (HP : IsHProp ((n = m) + (n < m))). { apply ishprop_sum; try exact _. intros [] [l K]. apply N_add_cancel_zero_r in K. symmetry in K; apply zero_neq_succ in K; assumption. } destruct H as [k K]. destruct (N_zero_or_succ k) as [k0|[l L]]. - rewrite k0 in K. rewrite (N_add_zero_l n) in K. exact (inl K). - rewrite L in K. exact (inr (l;K)). Qed. Definition N_succ_nlt@{} (n : N) : ~(succ n < n). Proof. revert n; apply N_propind@{p}. - intros n;exact istrunc_arrow@{p p p}. - apply N_lt_zero. - intros n H L. apply H; clear H. destruct L as [k H]. exists k. rewrite N_add_succ in H. exact (succ_inj _ _ H). Qed. Definition N_lt_succ@{} (n : N) : n < succ n. Proof. exists zero. rewrite N_add_succ_l. apply ap, N_add_zero_l. Qed. Definition N_succ_lt@{} (n m : N) (H : n < m) : succ n < succ m. Proof. destruct H as [k H]. exists k. rewrite N_add_succ. apply ap; assumption. Qed. Definition N_lt_le@{} (n m : N) (H : n < m) : n <= m. Proof. destruct H as [k K]. exact (succ k; K). Qed. Definition N_lt_iff_succ_le@{} (n m : N) : (n < m) <-> (succ n <= m). Proof. split; intros [k H]; exists k. - rewrite N_add_succ, <- N_add_succ_l. assumption. - rewrite N_add_succ_l, <- N_add_succ. assumption. Qed. Definition N_lt_succ_iff_le@{} (n m : N) : (n < succ m) <-> (n <= m). Proof. split; intros [k H]; exists k. - rewrite N_add_succ_l in H. exact (succ_inj _ _ H). - rewrite N_add_succ_l; apply ap, H. Qed. Definition equiv_N_segment@{} (n : N) : { m : N & m <= n } <~> (sum@{p p} {m : N & m < n} Unit). Proof. srefine (equiv_adjointify _ _ _ _). - intros mH. destruct (N_le_eq_or_lt mH.1 n mH.2) as [H0|Hs]. + exact (inr tt). + exact (inl (mH.1;Hs)). - intros [mH|?]. + exact (mH.1; N_lt_le mH.1 n mH.2). + exists n; reflexivity. - abstract (intros [[m H]|[]]; cbn; [ generalize (N_le_eq_or_lt m n (N_lt_le m n H)); intros [H0|Hs]; cbn; [ apply Empty_rec; rewrite H0 in H; exact (N_lt_irref n H) | apply ap, ap, path_ishprop ] | generalize (N_le_eq_or_lt n n (reflexive_N_le n)); intros [H0|Hs]; [ reflexivity | apply Empty_rec; exact (N_lt_irref n Hs) ]]). - abstract (intros [m H]; cbn; generalize (N_le_eq_or_lt m n H); intros [H0|Hs]; cbn; [ apply path_sigma_hprop; symmetry; assumption | apply ap, path_ishprop ]). Defined. Definition equiv_N_segment_succ@{} (n : N) : { m : N & m <= succ n } <~> @sum@{p p} {m : N & m <= n} Unit. Proof. refine (_ oE equiv_N_segment (succ n)). apply equiv_functor_sum_r. apply equiv_functor_sigma_id. intros m; apply equiv_iff_hprop_uncurried, N_lt_succ_iff_le. Defined. (** A fancy name for [1] so that we can [rewrite] with it later. *) Definition equiv_N_segment_succ_inv_inl@{} (n : N) (mh : {m:N & m <= n}) : ((equiv_N_segment_succ n)^-1 (inl mh)).1 = mh.1. Proof. reflexivity. Qed. Definition equiv_N_segment_lt_succ@{} (n : N) : { m : N & m < succ n } <~> {m : N & m <= n}. Proof. apply equiv_functor_sigma_id. intros; apply equiv_iff_hprop; apply N_lt_succ_iff_le. Defined. Definition zero_seg@{} (n : N) : { m : N & m <= n } := (zero ; N_zero_le n). Definition succ_seg@{} (n : N) : { m : N & m < n } -> { m : N & m <= n } := fun mh => let (m,H) := mh in (succ m; fst (N_lt_iff_succ_le m n) H). Definition refl_seg@{} (n : N) : {m : N & m <= n}. Proof. exists n. reflexivity. Defined. (** Now we're finally ready to prove recursion. *) Section NRec. (** Here is the type we will recurse into. Importantly, it doesn't have to be a set! *) (** [nr] is the universe of [partial_Nrec], morally [max(p,x)]. Note that it shouldn't be [large], see constraints on [contr_partial_Nrec_zero]. *) Universes x nr. Context (X : Type@{x}) (x0 : X) (xs : X -> X). (** The type of partially defined recursive functions "up to [n]". *) Local Definition partial_Nrec@{} (n : N) : Type@{nr} := sig@{nr nr} (fun f : ({ m : N & m <= n} -> X) => prod@{x nr} (f (zero_seg n) = x0) (forall (mh : {m:N & m < n}), f (succ_seg n mh) = xs (f ((equiv_N_segment n)^-1 (inl mh))))). (** The crucial point that makes it work for arbitrary [X] is to prove in one big induction that these types are always contractible. Here is the base case. *) Lemma contr_partial_Nrec_zero@{} : Contr (partial_Nrec zero). Proof. unfold partial_Nrec. srefine (istrunc_equiv_istrunc {f0 : {f : {m : N & m <= zero} -> X & (f (zero_seg zero) = x0)} & (forall mh : {m : N & m < zero}, f0.1 (succ_seg zero mh) = xs (f0.1 ((equiv_N_segment zero)^-1 (inl mh))))} _). - exact _. - refine (_ oE equiv_inverse (equiv_sigma_assoc _ _)). apply equiv_functor_sigma_id; intros f. cbn; apply equiv_sigma_prod0. - refine (@istrunc_sigma@{nr nr nr} _ _ _ _ _). + srefine (Build_Contr _ _ _). * exists (fun _ => x0); reflexivity. * intros [g H]. srefine (path_sigma _ _ _ _ _); cbn. { apply path_forall; intros m. exact (H^ @ ap g (path_ishprop _ _)). } { rewrite transport_paths_Fl. rewrite ap_apply_l. rewrite ap10_path_forall. rewrite inv_pp, inv_V, concat_p1. transitivity ((ap g 1)^ @ H). - apply whiskerR, ap, ap. apply path_ishprop. - apply concat_1p. } + intros [f H]. apply (Build_Contr _ (fun mh => Empty_rec (N_lt_zero mh.1 mh.2))). intros g. apply path_forall; intros m. destruct (N_lt_zero m.1 m.2). Qed. Local Existing Instance contr_partial_Nrec_zero. Local Definition equiv_N_segment_succ_maps@{} (n : N) : Equiv@{nr nr} (prod@{nr x} ({ m : N & m <= n} -> X) X) ({ m : N & m <= succ n} -> X). Proof. refine (_ oE @equiv_sum_ind@{x nr nr nr nr p p p} _ {m:N&m<=n} Unit (fun _ => X) oE _). - apply equiv_precompose'. apply equiv_N_segment_succ. - apply equiv_functor_prod_l. apply equiv_unit_rec@{x nr}. Defined. Local Definition equiv_seg_succ@{} (n m : N) (H : m < succ n) (f : { m : N & m <= n} -> X) (xsn : X) : equiv_N_segment_succ_maps n (f,xsn) (m ; N_lt_le m _ H) = f (exist (fun m=>m<=n) m (fst (N_lt_succ_iff_le m _) H)). Proof. cbn. generalize (N_le_eq_or_lt m (succ n) (N_lt_le m (succ n) H)). intros [E|L]. - apply Empty_rec. rewrite E in H. exact (N_lt_irref _ H). - cbn. apply ap, path_sigma_hprop; reflexivity. Qed. (** And here, essentially, is the inductive step. *) Local Definition partial_Nrec_succ0 (n : N) : partial_Nrec n <~> partial_Nrec (succ n). Proof. unfold partial_Nrec. srefine (equiv_functor_sigma' (equiv_N_segment_succ_maps n) _ oE _). { intros [f xsn]. srefine ((f (zero_seg n) = x0) * ((forall (mh : {m:N & m < n}), f (succ_seg n mh) = xs (f ((equiv_N_segment n)^-1 (inl mh)))) * (xsn = xs (f (refl_seg n))))). } { intros [f xsn]. apply equiv_functor_prod'. { apply equiv_concat_l. cbn. generalize (N_le_eq_or_lt zero (succ n) (N_zero_le (succ n))). intros [H0|Hs]. + destruct (zero_neq_succ n (H0)). + cbn. apply ap. apply path_sigma_hprop; reflexivity. } { srefine ((equiv_functor_forall_pb (equiv_N_segment_lt_succ n)^-1)^-1 oE _). srefine ((equiv_functor_forall_pb (equiv_N_segment n)^-1)^-1 oE _). srefine (equiv_sum_ind _ oE _). apply equiv_functor_prod'. - apply equiv_functor_forall_id; intros [m H]. apply equiv_concat_lr. + transitivity ((equiv_N_segment_succ_maps n) (f,xsn) (succ m; N_lt_le _ _ (N_succ_lt m n H))). * apply ap. apply path_sigma_hprop. reflexivity. * rewrite equiv_seg_succ. apply ap, path_sigma_hprop; reflexivity. + apply ap. cbv [equiv_fun equiv_inv equiv_isequiv equiv_inverse equiv_adjointify isequiv_adjointify equiv_compose' equiv_compose equiv_precompose' equiv_functor_sigma_id equiv_N_segment_succ equiv_sum_ind equiv_functor_prod_l equiv_functor_sum_r equiv_functor_sigma' equiv_functor_sum equiv_functor_sum' equiv_functor_sigma equiv_functor_prod equiv_functor_prod' equiv_idmap isequiv_idmap equiv_unit_rec isequiv_functor_sigma equiv_iff_hprop equiv_iff_hprop_uncurried eisretr inverse transport succ_seg equiv_N_segment_succ_maps equiv_N_segment_lt_succ equiv_N_segment]; cbn. match goal with | [ |- context[match ?L with | inl _ => inr tt | inr Hs => inl (?k; Hs) end] ] => generalize L end. intros [L|L]. * apply Empty_rec; rewrite L in H. exact (N_succ_nlt n H). * cbn. apply ap, path_sigma_hprop; reflexivity. - refine ((equiv_contr_forall _)^-1 oE _). apply equiv_concat_lr. + cbn. match goal with | [ |- context[match ?L with | inl _ => inr tt | inr Hs => inl (?k; Hs) end] ] => generalize L end. intros [L|L]. * reflexivity. * case (N_lt_irref _ L). + apply ap. cbv [eisretr equiv_adjointify equiv_compose equiv_compose' equiv_fun equiv_functor_prod equiv_functor_prod' equiv_functor_prod_l equiv_functor_sigma equiv_functor_sigma' equiv_functor_sigma_id equiv_functor_sum equiv_functor_sum' equiv_functor_sum_r equiv_idmap equiv_iff_hprop equiv_iff_hprop_uncurried equiv_inv equiv_inverse equiv_isequiv equiv_N_segment equiv_N_segment_lt_succ equiv_N_segment_succ equiv_N_segment_succ_maps equiv_precompose' equiv_sum_ind equiv_unit_rec inverse isequiv_adjointify isequiv_functor_sigma isequiv_idmap transport]; cbn [fst snd pr1 pr2 functor_sigma]. match goal with | [ |- context[match ?L with | inl _ => inr tt | inr Hs => inl (?k; Hs) end] ] => generalize L end. intros [L|L]. * case (N_neq_succ n L). * cbn. apply ap, path_sigma_hprop. reflexivity. } } { refine (equiv_sigma_prod _ oE _). apply equiv_functor_sigma_id. intros f. refine (equiv_functor_sigma_id (fun b:X => equiv_sigma_prod0 _ _) oE _). refine (equiv_sigma_symm _ oE _). refine (_ oE (equiv_sigma_prod0 _ _)^-1). apply equiv_functor_sigma_id; intros f0. refine (equiv_functor_sigma_id (fun b:X => equiv_sigma_prod0 _ _) oE _). refine (equiv_sigma_symm _ oE _). exact ((equiv_sigma_contr _)^-1%equiv). } Defined. Local Definition partial_Nrec_succ@{} := Eval unfold partial_Nrec_succ0 in partial_Nrec_succ0@{nr nr}. Local Instance contr_partial_Nrec@{} (n : N) : Contr (partial_Nrec n). Proof. revert n; apply N_propind; try exact _. intros n H. refine (istrunc_equiv_istrunc _ (partial_Nrec_succ n)). Qed. (** This will be useful later. *) Local Definition partial_Nrec_restr@{} (n : N) : partial_Nrec (succ n) -> partial_Nrec n. Proof. intros f. destruct f as [f [f0 fs]]. exists (fun mh => f ((equiv_N_segment_succ n)^-1 (inl mh))). split. - refine (_ @ f0). apply ap, path_sigma_hprop. reflexivity. - intros mh. refine (_ @ fs (((equiv_N_segment_lt_succ n)^-1) ((equiv_N_segment n)^-1 (inl mh))) @ _). + apply ap. apply path_sigma_hprop; reflexivity. + apply ap, ap. apply path_sigma_hprop; reflexivity. Defined. (** Finally, we want to put all this together to show that the type of fully defined recursive functions is contractible, so that N has the universal property of a natural numbers object. If we attack it directly, this can lead to quite annoying path algebra. Instead, we will show that it is a retract of the product of all the types of partial attempts, which is contractible since each of them is. *) Local Definition partials@{} := forall n, partial_Nrec n. Local Instance contr_partials@{} : Contr partials := istrunc_forall@{p nr nr}. (** From a family of partial attempts, we get a totally defined recursive function. *) Section Partials. Context (pf : partials). Local Definition N_rec'@{} : N -> X := fun n => (pf n).1 (refl_seg n). Definition N_rec_beta_zero'@{} : N_rec' zero = x0. Proof. refine (_ @ fst (pf zero).2). unfold N_rec'. apply ap, path_sigma_hprop; reflexivity. Defined. Definition N_rec_beta_succ'@{} (n : N) : N_rec' (succ n) = xs (N_rec' n). Proof. unfold N_rec'. refine (_ @ snd (pf (succ n)).2 (n ; N_lt_succ n) @ _). - apply ap, path_sigma_hprop; reflexivity. - apply ap. transitivity ((partial_Nrec_restr n (pf (succ n))).1 (refl_seg n)). + refine (ap (pf (succ n)).1 _). apply path_sigma_hprop; reflexivity. + apply ap10@{p x nr}. apply ap, path_contr. Defined. End Partials. (** Applying this to the "canonical" partial attempts, we get "the recursor". *) Definition N_rec@{} : N -> X := N_rec' (center partials). Definition N_rec_beta_zero@{} : N_rec zero = x0 := N_rec_beta_zero' (center partials). Definition N_rec_beta_succ@{} (n : N) : N_rec (succ n) = xs (N_rec n) := N_rec_beta_succ' (center partials) n. (** Here is the type of totally defined recursive functions that we want to prove to be contractible. *) Definition NRec : Type@{nr} := sig@{nr nr} (fun f : N -> X => prod@{x nr} (f zero = x0) (forall m:N, f (succ m) = xs (f m))). Local Definition nrec_partials@{} : NRec -> partials. Proof. intros f n. exists (fun mh => f.1 mh.1). split. - exact (fst f.2). - intros mh. exact (snd f.2 mh.1). Defined. (** This is a weird lemma. We could prove it by [path_contr], but we give an explicit proof instead using [path_sigma], so that later on we know what happens when [pr1_path] is applied to it. *) Local Definition nrec_partials_succ@{} (n : N) (f : NRec) : partial_Nrec_restr n (nrec_partials f (succ n)) = nrec_partials f n. Proof. change (?x = ?y) with ((x.1; x.2) = (y.1; y.2)). srefine (path_sigma'@{nr nr nr} _ 1 _). abstract (rewrite transport_1; apply path_prod; [ cbn [partial_Nrec_restr nrec_partials fst pr2 pr1]; rewrite ap_compose; rewrite ap_pr1_path_sigma_hprop; apply concat_1p | cbn [partial_Nrec_restr nrec_partials pr1 pr2 snd]; apply path_forall; intros mh; rewrite ap_compose; rewrite ap_pr1_path_sigma_hprop; rewrite ap_1, concat_1p; refine (_ @ concat_p1 _); apply whiskerL; refine (_ @ ap_1 _ xs); apply ap; rewrite ap_compose; rewrite ap_pr1_path_sigma_hprop; reflexivity ]). Defined. Local Definition partials_nrec@{} : partials -> NRec. Proof. intros pf. exists (N_rec' pf). exact (N_rec_beta_zero' pf, N_rec_beta_succ' pf). Defined. Local Definition nrec_partials_sect@{} (f : NRec) : partials_nrec (nrec_partials f) = f. Proof. destruct f as [f [f0 fs]]. unfold partials_nrec, nrec_partials. cbn. unfold N_rec', N_rec_beta_zero'; cbn. apply ap@{nr nr}, path_prod. - cbn. rewrite ap_compose. rewrite ap_pr1_path_sigma_hprop. apply concat_1p. - apply path_forall; intros n. unfold N_rec_beta_succ'. cbn [fst snd pr1 pr2]; cbv [equiv_fun equiv_inverse equiv_inv equiv_isequiv equiv_compose' equiv_compose isequiv_compose equiv_functor_sum_r equiv_functor_sigma_id equiv_functor_sigma' equiv_functor_sigma equiv_functor_sum' equiv_functor_sum equiv_adjointify isequiv_adjointify isequiv_functor_sum isequiv_idmap equiv_idmap isequiv_functor_sigma equiv_iff_hprop_uncurried functor_sum functor_sigma equiv_N_segment equiv_N_segment_succ inverse transport eisretr]; cbn [fst snd pr1 pr2 refl_seg]. rewrite ap_compose. rewrite ap_pr1_path_sigma_hprop. rewrite ap_1, concat_1p. rewrite (ap_compose pr1 f). rewrite ap_pr1_path_sigma_hprop. rewrite ap_1, concat_1p. refine (_ @ (concat_p1 _)); apply whiskerL. set (refl_seg_n := refl_seg n). (** Here is where we use [nrec_partials_succ]: the [path_contr] equal to it, which allows us to identify [ap pr1] of the latter. (Note that [ap pr1] of a [path_contr] can be nontrivial even when the endpoints happen to coincide judgmentally, for instance (x;p) and (x;1) in {y:X & y = x}, so there really is something to prove here.) *) transitivity (ap xs (ap10 (ap pr1 (nrec_partials_succ n (f;(f0,fs)))) refl_seg_n)). + apply ap. assert (p : path_contr _ _ = nrec_partials_succ n (f; (f0, fs))). { apply path_contr. } exact (ap (fun h => ap10 (ap pr1 h) refl_seg_n) p). + unfold nrec_partials_succ. unfold path_sigma'. rewrite ap_pr1_path_sigma. reflexivity. Qed. (** And we're done! *) Global Instance contr_NRec@{} : Contr NRec. Proof. refine (istrunc_isequiv_istrunc partials partials_nrec). refine (isequiv_adjointify _ nrec_partials nrec_partials_sect _). intros x; apply path_contr. Defined. End NRec. End AssumeStuff. Coq-HoTT-9.0/theories/Metatheory/PropTrunc.v000066400000000000000000000032711474641544500210270ustar00rootroot00000000000000Require Import Basics Types. Require Import Diagrams.Sequence. Require Import Homotopy.Join.Core. Require Import Colimits.Colimit Colimits.Sequential. Local Open Scope nat_scope. (** * Propositonal truncation as a colimit. *) (** In this file we give an alternative construction of the propositional truncation using colimits. This can serve as a metatheoretic justification that propositional truncations exist. *) (** The sequence of increasing joins. *) Definition Join_seq (A : Type) : Sequence. Proof. srapply Build_Sequence. 1: exact (iterated_join A). intros n. exact joinr. Defined. (** Propositional truncation can be defined as the colimit of this sequence. *) Definition PropTrunc A : Type := Colimit (Join_seq A). (** The constructor is given by the colimit constructor. *) Definition ptr_in {A} : A -> PropTrunc A := colim (D:=Join_seq A) 0. (** The sequential colimit of this sequence is the propositional truncation. *) (** Universal property of propositional truncation. *) Lemma equiv_PropTrunc_rec `{Funext} (A P : Type) `{IsHProp P} : (PropTrunc A -> P) <~> (A -> P). Proof. refine (_ oE equiv_colim_seq_rec _ P). srapply equiv_iff_hprop. { intros h. exact (h 0). } intros f. induction n. - exact f. - cbn. srapply Join_rec. 1,2: assumption. intros a b. rapply path_ishprop. Defined. (** The propositional truncation is a hprop. *) Global Instance ishprop_proptrunc `{Funext} (A : Type) : IsHProp (PropTrunc A). Proof. rapply hprop_inhabited_contr. rapply (equiv_PropTrunc_rec _ _)^-1. intros x. srapply contr_colim_seq_into_prop. - intros n. destruct n. 1: exact x. exact (joinl x). - intros n. rapply jglue. Defined. Coq-HoTT-9.0/theories/Metatheory/TruncImpliesFunext.v000066400000000000000000000053721474641544500227070ustar00rootroot00000000000000(** * Propositional truncation implies function extensionality *) Require Import HoTT.Basics HoTT.Truncations HoTT.Types.Bool. Require Import Metatheory.Core Metatheory.FunextVarieties Metatheory.ImpredicativeTruncation. (** Assuming that we have a propositional truncation operation with a definitional computation rule, we can prove function extensionality. Since we can't assume we have a definitional computation rule, we work with the propositional truncation defined as a HIT, which does have a definitional computation rule. *) (** We can construct an interval type as [Trunc -1 Bool]. *) Local Definition interval := Trunc (-1) Bool. Local Definition interval_rec (P : Type) (a b : P) (p : a = b) : interval -> P. Proof. (* We define this map by factoring it through the type [{ x : P & x = b}], which is a proposition since it is contractible. *) refine ((pr1 : { x : P & x = b } -> P) o _). apply Trunc_rec. intros []. - exact (a; p). - exact (b; idpath). Defined. Local Definition seg : tr true = tr false :> interval := path_ishprop _ _. (** From an interval type, and thus from truncations, we can prove function extensionality. See IntervalImpliesFunext.v for an approach that works with an interval defined as a HIT. *) Definition funext_type_from_trunc : Funext_type := WeakFunext_implies_Funext (NaiveFunext_implies_WeakFunext (fun A P f g p => let h := fun (x:interval) (a:A) => interval_rec _ (f a) (g a) (p a) x in ap h seg)). (** ** Function extensionality implies an interval type *) (** Assuming [Funext] (and not propositional resizing), the construction [Trm] in ImpredicativeTruncation.v applied to [Bool] gives an interval type with definitional computation on the end points. So we see that function extensionality is equivalent to the existence of an interval type. *) Section AssumeFunext. Context `{Funext}. Definition finterval := Trm Bool. Definition finterval_rec (P : Type) (a b : P) (p : a = b) : finterval -> P. Proof. refine ((pr1 : { x : P & x = b } -> P) o _). apply Trm_rec. intros []. - exact (a; p). - exact (b; idpath). Defined. (** As an example, we check that it computes on [true]. *) Definition finterval_rec_beta (P : Type) (a b : P) (p : a = b) : finterval_rec P a b p (trm true) = a := idpath. Definition fseg : trm true = trm false :> finterval := path_ishprop _ _. (** To verify that our interval type is good enough, we use it to prove function extensionality. *) Definition funext_type_from_finterval : Funext_type := WeakFunext_implies_Funext (NaiveFunext_implies_WeakFunext (fun A P f g p => let h := fun (x:finterval) (a:A) => finterval_rec _ (f a) (g a) (p a) x in ap h fseg)). End AssumeFunext. Coq-HoTT-9.0/theories/Metatheory/UnivalenceImpliesFunext.v000066400000000000000000000072171474641544500237050ustar00rootroot00000000000000Require Import HoTT.Basics. Require Import Types.Universe. Require Import Metatheory.Core Metatheory.FunextVarieties. Generalizable All Variables. (** * Univalence Implies Functional Extensionality *) Section UnivalenceImpliesFunext. Context `{ua : Univalence_type}. (** Exponentiation preserves equivalences, i.e., if [e] is an equivalence then so is post-composition by [e]. *) (* Should this go somewhere else? *) Theorem univalence_isequiv_postcompose `{H0 : IsEquiv A B w} C : IsEquiv (fun (g:C->A) => w o g). Proof. unfold Univalence_type in *. refine (isequiv_adjointify (fun (g:C->A) => w o g) (fun (g:C->B) => w^-1 o g) _ _); intro; pose (Build_Equiv _ _ w _) as w'; change H0 with (@equiv_isequiv _ _ w'); change w with (@equiv_fun _ _ w'); clearbody w'; clear H0 w; rewrite <- (@eisretr _ _ (@equiv_path A B) (ua A B) w'); generalize ((@equiv_inv _ _ (equiv_path A B) (ua A B)) w'); intro p; clear w'; destruct p; reflexivity. Defined. (** We are ready to prove functional extensionality, starting with the naive non-dependent version. *) Local Instance isequiv_src_compose A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) (fun g => (fst o pr1) o g). Proof. rapply @univalence_isequiv_postcompose. refine (isequiv_adjointify (fst o pr1) (fun x => ((x, x); idpath)) (fun _ => idpath) _); let p := fresh in intros [[? ?] p]; simpl in p; destruct p; reflexivity. Defined. Local Instance isequiv_tgt_compose A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) (fun g => (snd o pr1) o g). Proof. rapply @univalence_isequiv_postcompose. refine (isequiv_adjointify (snd o pr1) (fun x => ((x, x); idpath)) (fun _ => idpath) _); let p := fresh in intros [[? ?] p]; simpl in p; destruct p; reflexivity. Defined. Theorem Univalence_implies_FunextNondep : NaiveNondepFunext. Proof. intros A B f g p. (** Consider the following maps. *) pose (d := fun x : A => exist (fun xy => fst xy = snd xy) (f x, f x) (idpath (f x))). pose (e := fun x : A => exist (fun xy => fst xy = snd xy) (f x, g x) (p x)). (** If we compose [d] and [e] with [free_path_target], we get [f] and [g], respectively. So, if we had a path from [d] to [e], we would get one from [f] to [g]. *) change f with ((snd o pr1) o d). change g with ((snd o pr1) o e). rapply (ap (fun g => snd o pr1 o g)). (** Since composition with [src] is an equivalence, we can freely compose with [src]. *) pose (fun A B x y=> @equiv_inv _ _ _ (@isequiv_ap _ _ _ (@isequiv_src_compose A B) x y)) as H'. apply H'. reflexivity. Defined. End UnivalenceImpliesFunext. (** Now we use this to prove strong dependent funext. Again only the codomain universe must be univalent, but the domain universe must be no larger than it is. Thus practically speaking this means that a univalent universe satisfies funext only for functions between two types in that same universe. *) Definition Univalence_implies_WeakFunext : Univalence_type -> WeakFunext := NaiveNondepFunext_implies_WeakFunext o @Univalence_implies_FunextNondep. Definition Univalence_type_implies_Funext_type `{ua : Univalence_type@{j jplusone} } : Funext_type@{i j j} := NaiveNondepFunext_implies_Funext (@Univalence_implies_FunextNondep ua). (** The above proof justifies assuming [Univalence -> Funext], which we did axiomatically in [Types/Universe.v]. *) Coq-HoTT-9.0/theories/Metatheory/UnivalenceVarieties.v000066400000000000000000000064441474641544500230450ustar00rootroot00000000000000(** * Varieties of univalence *) Require Import HoTT.Basics HoTT.Types. Require Import Idempotents. Require Import Metatheory.Core. Local Open Scope path_scope. (** A weaker form that only asserts that we can make equivalences into paths with a computation rule (no uniqueness rule). *) Definition WeakUnivalence := { etop : forall A B, (A <~> B) -> (A = B) & forall A B (f : A <~> B), equiv_path A B (etop A B f) = f }. (** The same thing, stated with an incoherent notion of equivalence but a pointwise equality for the computation rule. *) Definition IncoherentWeakUnivalence := { etop : forall A B (f : A -> B) (g : B -> A), (f o g == idmap) -> (g o f == idmap) -> (A = B) & forall A B f g H K, equiv_path A B (etop A B f g H K) == f }. (** Finally, it even suffices to consider only just a few special cases. This is due to Ian Orton and Andrew Pitts. *) Record VeryWeakUnivalence := { unit : forall A, A = { a : A & Unit }; flip : forall A B (C : A -> B -> Type), { a : A & { b : B & C a b }} = { b : B & { a : A & C a b }}; contract : forall A, Contr A -> A = Unit; unit_comp : forall A a, transport idmap (unit A) a = (a;tt); flip_comp : forall A B C (a:A) (b:B) (c : C a b), transport idmap (flip A B C) (a ; (b ; c)) = (b ; (a ; c)) }. Theorem WeakUnivalence_implies_Univalence : WeakUnivalence -> Univalence_type. Proof. intros [etop H] A. apply isequiv_from_functor_sigma. srapply isequiv_contr_contr. srapply (contr_retracttype (Build_RetractOf _ _ (fun Be => (Be.1 ; equiv_path A Be.1 Be.2)) (fun Bf => (Bf.1 ; etop A Bf.1 Bf.2)) _)). intros [B f]. refine (path_sigma' (fun B => A <~> B) 1 (H A B f)). Defined. (** For this one and the next one, we need to assume funext to start with (so that these forms of univalence, unlike the usual one, probably don't suffice to prove funext from). *) Theorem IncoherentWeakUnivalence_implies_Univalence `{Funext} : IncoherentWeakUnivalence -> Univalence_type. Proof. intros [etop K]. apply WeakUnivalence_implies_Univalence. transparent assert (etop' : (forall A B, (A <~> B) -> (A = B))). { intros A B f. refine (etop A B f f^-1 _ _). - intros x; apply eisretr. - intros x; apply eissect. } exists etop'. intros A B f. apply path_equiv, path_arrow, K. Defined. Theorem VeryWeakUnivalence_implies_Univalence `{Funext} : VeryWeakUnivalence -> Univalence_type. Proof. intros vwu. apply WeakUnivalence_implies_Univalence. simple refine (_;_). { intros A B f. refine (unit vwu A @ _ @ (unit vwu B)^). refine (_ @ flip vwu A B (fun a b => f a = b) @ _). - apply ap, path_arrow; intros a. symmetry; rapply (contract vwu). - apply ap, path_arrow; intros b. apply (contract vwu); exact _. } { intros A B f. apply path_equiv, path_arrow; intros a; cbn. rewrite !transport_pp. refine (moveR_transport_V idmap (unit vwu B) _ (f a) _). rewrite !(unit_comp vwu). rewrite <- !(transport_compose idmap sig). rewrite (transport_sigma' (C := fun P (a0:A) => P a0)); cbn. refine (ap _ _ @ _). 1:{ apply ap, ap. exact (path_contr _ (f a ; 1)). } rewrite (flip_comp vwu). rewrite transport_sigma'; cbn. apply ap, path_contr. } Defined. Coq-HoTT-9.0/theories/Modalities/000077500000000000000000000000001474641544500166525ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Modalities/Accessible.v000066400000000000000000000241531474641544500211030ustar00rootroot00000000000000(** * Accessible subuniverses and modalities *) Require Import HoTT.Basics HoTT.Types. Require Import Extensions NullHomotopy. Require Import Modality. Local Open Scope nat_scope. Local Open Scope path_scope. (** ** Accessible reflective subuniverses *) (** An accessible reflective subuniverse is one that is the localization at a small family of maps. Accessibility is necessary for some constructions, and in practice it's a reasonable hypothesis that includes most examples (though a few examples, such as double negation, may only be accessible if we assume propositional resizing). We now give the basic definitions related to accessibility, using [ooExtendableAlong] as our notion of equivalence as we did with reflective subuniverses. The actual construction of a reflective subuniverse by localization will be in [Localization]. *) Record LocalGenerators@{a} := { lgen_indices : Type@{a} ; lgen_domain : lgen_indices -> Type@{a} ; lgen_codomain : lgen_indices -> Type@{a} ; lgenerator : forall i, lgen_domain i -> lgen_codomain i }. Coercion lgenerator : LocalGenerators >-> Funclass. (** We put this definition in a module so that no one outside of this file will use it accidentally. It will be redefined in [Localization] to refer to the localization reflective subuniverse, which is judgmentally the same but will also pick up typeclass inference for [In]. *) Module Import IsLocal_Internal. Definition IsLocal f X := (forall (i : lgen_indices f), ooExtendableAlong (f i) (fun _ => X)). End IsLocal_Internal. Class IsAccRSU@{a i} (O : Subuniverse@{i}) := { acc_lgen : LocalGenerators@{a} ; inO_iff_islocal : forall (X : Type@{i}), (** We call [iff] explicitly to control the number of universe parameters. *) iff@{i i i} (In O X) (IsLocal acc_lgen X) ; }. Arguments acc_lgen O {_}. Arguments inO_iff_islocal O {_} X. Global Instance O_inverts_generators {O : ReflectiveSubuniverse} `{IsAccRSU O} (i : lgen_indices (acc_lgen O)) : O_inverts O (acc_lgen O i). Proof. pose (ext_dom := fst (inO_iff_islocal O (O (lgen_domain (acc_lgen O) i))) _). pose (ext_cod := fst (inO_iff_islocal O (O (lgen_codomain (acc_lgen O) i))) _). simple refine (isequiv_adjointify _ _ _ _). - apply O_rec. exact ((fst (ext_dom i 1%nat) (to O _)).1). - apply O_indpaths; intros x; simpl. rewrite O_rec_beta. refine ((fst (snd (ext_cod i 2) (fun x => O_functor O (acc_lgen O i) ((fst (ext_dom i 1%nat) (to O _)).1 x)) _) _).1 x); intros a. rewrite ((fst (ext_dom i 1%nat) (to O _)).2 a). apply to_O_natural. - apply O_indpaths; intros x; simpl. rewrite (to_O_natural O (acc_lgen O i) x). rewrite O_rec_beta. apply ((fst (ext_dom i 1%nat) (to O _)).2 x). Qed. (** The construction of the localization reflective subuniverse for any family of maps will be in [Localization]. *) (** ** Accessible modalities *) (** A modality is accessible just when its underlying reflective subuniverse is accessible. However, for modalities we have a simpler characterization in terms of families of generating connected objects rather than families of generating inverted maps. We call an object [S]-null if it is local with respect to the maps [S i -> Unit]. *) Record NullGenerators := { ngen_indices : Type@{a} ; ngen_type : ngen_indices -> Type@{a} }. Coercion ngen_type : NullGenerators >-> Funclass. Definition null_to_local_generators : NullGenerators@{a1} -> LocalGenerators@{a2} := fun S => Build_LocalGenerators (ngen_indices S) (ngen_type S) (fun _ => Unit) (fun _ _ => tt). (** As with [IsLocal], the real version of this notation will be defined in [Nullification]. *) Module Import IsNull_Internal. Definition IsNull (S : NullGenerators@{a}) (X : Type@{i}) := IsLocal@{i i a} (null_to_local_generators@{a a} S) X. End IsNull_Internal. (** A central fact: if a type [X] is null for all the fibers of a map [f], then it is [f]-local. (NB: the converse is *not* generally true.) TODO: Should this go in [Extensions]? *) Definition extendable_isnull_fibers (n : nat) {A B} (f : A -> B) (C : B -> Type) : (forall b, ooExtendableAlong (const_tt (hfiber f b)) (fun _ => C b)) -> ExtendableAlong n f C. Proof. revert C. simple_induction n n IHn; intros C null; [exact tt | split]. - intros g. exists (fun b => (fst (null b 1%nat) (fun x => x.2 # g x.1)).1 tt). intros a. rewrite (path_unit tt (const_tt _ a)). exact ((fst (null (f a) 1%nat) _).2 (a ; 1)). - intros h k. apply IHn; intros b. apply ooextendable_homotopy, null. Defined. Definition ooextendable_isnull_fibers {A B} (f : A -> B) (C : B -> Type) : (forall b, ooExtendableAlong (const_tt (hfiber f b)) (fun _ => C b)) -> ooExtendableAlong f C := fun null n => extendable_isnull_fibers n f C null. (** We define a modality to be accessible if it consists of the null types for some family of generators as above. *) Class IsAccModality@{a i} (O : Subuniverse@{i}) := { acc_ngen : NullGenerators@{a} ; inO_iff_isnull : forall (X : Type@{i}), iff@{i i i} (In O X) (IsNull acc_ngen X) ; }. Arguments acc_ngen O {_}. Arguments inO_iff_isnull O {_} X. Section AccessibleModalities. Context (O : Modality) {acco : IsAccModality O}. (** Unsurprisingly, the generators are connected. *) Global Instance isconnected_acc_ngen i : IsConnected O (acc_ngen O i). Proof. apply isconnected_from_elim_to_O. pose (H := fst (fst (inO_iff_isnull O (O (acc_ngen O i))) _ i 1%nat) (to O ((acc_ngen O) i))). exists (H.1 tt). exact (fun x => (H.2 x)^). Defined. (** If all the generators are inhabited, some things become a bit simpler. *) Section InhabitedGenerators. Context (inhab : forall i, acc_ngen O i). (** For testing modal-ness of types, it suffices for all maps out of a generator to be constant. Probably one could do without [Funext]. *) Definition inO_const_fromgen `{Funext} A (c : forall i (f : acc_ngen O i -> A), NullHomotopy f) : In O A. Proof. apply (snd (inO_iff_isnull O A)); intros i. apply ((equiv_ooextendable_isequiv _ _)^-1%equiv). snrapply isequiv_adjointify. - intros f []; exact (c i f).1. - intros f; apply path_arrow; intros x. simpl; unfold composeD. symmetry; exact ((c i f).2 x). - intros g; apply path_arrow; intros []. pose ((c i (g oD (null_to_local_generators (acc_ngen O)) i)).2). simpl in p; unfold composeD in p. symmetry; apply p, inhab. Defined. (** In particular, all hprops are modal. *) Definition inO_hprop_inhab_gen `{Funext} (A : Type) `{IsHProp A} : In O A. Proof. apply inO_const_fromgen; intros i f. exists (f (inhab i)). intros; apply path_ishprop. Defined. End InhabitedGenerators. End AccessibleModalities. (** We will now show that a modality is accessible in this sense if and only if its underlying reflective subuniverse is accessible in the sense previously defined. We (almost?) never need to actually use this, though; in practice accessible modalities usually seem to be given to us with the appropriate sort of generators. *) (** One direction of this implication is trivial. *) Global Instance acc_rsu_modality (O : Modality) `{IsAccModality O} : IsAccRSU O := Build_IsAccRSU O (null_to_local_generators (acc_ngen O)) (fun X => inO_iff_isnull O X). (** For the less trivial converse, the idea is as follows. By [ooextendable_isnull_fibers], we can detect locality with respect to a map by nullity with respect to its fibers. Therefore, our first thought might be to just consider all the fibers of all the maps that we are localizing at. However, this doesn't quite work because [ooextendable_isnull_fibers] is not an if-and-only-if, so not every modal type would necessarily be null for that type family. We do know, however, that if [f] is an [O]-connected map, then any [O]-modal type is null for its fibers (since they are [O]-connected types). There is no *a priori* why all the maps we localize at should end up being connected for the modality; they will always be inverted, but not every inverted map is connected (unless the modality is lex). But if [f : A -> B] is [O]-inverted, then the [O]-connected map [to O A] is (up to equivalence) the composite of [f] with the [O]-connected map [to O B]. Thus, if [X] is null for the fibers of [to O A] and [to O B], it will be [f]-local and hence [O]-modal, while all [O]-modal types will be null for these fibers since they are connected. *) (** We don't make this an [Instance] since it is rarely used, and would cause loops when combined with the previous one. *) Definition acc_modality_rsu (O : Modality) `{IsAccRSU O} : IsAccModality O. Proof. unshelve econstructor. { refine (Build_NullGenerators ( { i : lgen_indices@{a} (acc_lgen O) & O (lgen_domain@{a} (acc_lgen O) i) } + { i : lgen_indices@{a} (acc_lgen O) & O (lgen_codomain@{a} (acc_lgen O) i) }) _). intros [ [i x] | [i x] ]; exact (hfiber (to O _) x). } { assert (cm := @conn_map_to_O O). split. - intros X_inO [ [i x] | [i x] ]; exact (ooextendable_const_isconnected_inO O _ _). - intros Xnull. apply (snd (inO_iff_islocal O X)); intros i. refine (cancelL_ooextendable (fun _ => X) (acc_lgen O i) (to O (lgen_codomain (acc_lgen O) i)) _ _). + apply ooextendable_isnull_fibers; intros x. exact (Xnull (inr (i;x))). + refine (ooextendable_homotopic _ (O_functor O (acc_lgen O i) o to O (lgen_domain (acc_lgen O) i)) _ _). 1:apply to_O_natural. apply ooextendable_compose. * apply ooextendable_equiv, O_inverts_generators. * apply ooextendable_isnull_fibers; intros x. exact (Xnull (inl (i;x))). } Defined. (** The construction of the nullification modality for any family of types will be in [Nullification]. *) Coq-HoTT-9.0/theories/Modalities/Closed.v000066400000000000000000000060531474641544500202560ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Extensions. Require Import Modality Accessible Nullification Lex Topological. Require Import Colimits.Pushout Homotopy.Join.Core. Local Open Scope nat_scope. Local Open Scope path_scope. (** * Closed modalities *) (** We begin by characterizing the modal types. *) Section ClosedModalTypes. Context (U : HProp). Definition equiv_inO_closed (A : Type) : (U -> Contr A) <-> IsEquiv (fun a:A => push (inr a) : Join U A). Proof. split. - intros uac. simple refine (isequiv_adjointify _ _ _ _). * simple refine (Pushout_rec A _ _ _). + intros u; pose (uac u); exact (center A). + intros a; assumption. + intros [u a]. simpl. pose (uac u). apply contr. * intros z. pattern z. simple refine (Pushout_ind _ _ _ _ z). + intros u. pose (contr_inhabited_hprop U u). apply path_contr. + intros a; reflexivity. + intros [u a]; pose (contr_inhabited_hprop U u). apply path_contr. * intros a. reflexivity. - intros ? u. refine (contr_equiv (Join U A) (fun a:A => push (inr a))^-1). pose (contr_inhabited_hprop U u). exact _. Defined. End ClosedModalTypes. (** Exercise 7.13(ii): Closed modalities *) Definition Cl (U : HProp) : Modality. Proof. snrapply Build_Modality. - intros X; exact (U -> Contr X). - exact _. - intros T B T_inO f feq. cbn; intros u; pose (T_inO u). refine (contr_equiv _ f); exact _. - intros ; exact (Join U X). - intros T u. pose (contr_inhabited_hprop _ u). exact _. - intros T x. exact (push (inr x)). - intros A B B_inO f z. srefine (Pushout_ind B _ _ _ z). + intros u; apply center, B_inO, u. + intros a; apply f. + intros [u a]. pose (B_inO (push (inr a)) u). apply path_contr. - intros; reflexivity. - intros A A_inO z z' u. pose (A_inO u). apply contr_paths_contr. Defined. (** The closed modality is accessible. *) Global Instance accmodality_closed (U : HProp) : IsAccModality (Cl U). Proof. unshelve econstructor. - econstructor. exact (fun _:U => Empty). - intros X; split. + intros X_inO u. pose (X_inO u). apply ooextendable_contr; exact _. + intros ext u. apply (Build_Contr _ ((fst (ext u 1%nat) Empty_rec).1 tt)); intros x. unfold const in ext. exact ((fst (snd (ext u 2) (fst (ext u 1%nat) Empty_rec).1 (fun _ => x)) (Empty_ind _)).1 tt). Defined. (** In fact, it is topological, and therefore (assuming univalence) lex. As for topological modalities generally, we don't need to declare these as global instances, but we prove them here as local instances for exposition. *) Local Instance topological_closed (U : HProp) : Topological (Cl U) := _. Global Instance lex_closed `{Univalence} (U : HProp) : Lex (Cl U). Proof. rapply lex_topological. Defined. (** Thus, it also has the following alternative version. *) Definition Cl' (U : HProp) : Modality := Nul (Build_NullGenerators U (fun _ => Empty)). Coq-HoTT-9.0/theories/Modalities/CoreflectiveSubuniverse.v000066400000000000000000000145211474641544500237110ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Modalities.Modality Modalities.Open. Local Open Scope path_scope. (** * Coreflective subuniverses. *) (** In this file we study "coreflective subuniverses" that are defined dually to reflective subuniverses. However, it turns out that there are many fewer examples of these. The "internal" nature of such definitions, which in the reflective case makes the subuniverse automatically an exponential ideal, in the coreflective case has much stronger consequences: it forces the entire coreflection to be determined by the image of [Unit], which can be an arbitrary hprop. Thus, this file is essentially just a no-go theorem: there are no coreflective subuniverses other than a certain class of fairly simple ones (which we call "co-open" since they are dual to open modalities). In particular, since we do not foresee many applications of this file, we don't bother introducing modules to make the definitions more universe polymorphic the way we did for reflective subuniverses. *) Record CoreflectiveSubuniverse := { inF : Type -> HProp ; F_coreflector : Type -> Type ; F_inF : forall X, inF (F_coreflector X) ; fromF : forall X, F_coreflector X -> X ; (** We also don't bother defining [ooLiftableAlong] so as to state the universal property without [Funext]. *) isequiv_fromF_postcompose : forall {Y X} {Y_inF : inF Y}, IsEquiv (fun (g : Y -> F_coreflector X) => fromF X o g) (** Similarly, we don't bother asserting repleteness; we'll just use univalence. *) }. Coercion F_coreflector : CoreflectiveSubuniverse >-> Funclass. Section CoreflectiveSubuniverse. Context `{Univalence}. Context {F : CoreflectiveSubuniverse}. (** We begin by extracting the corecursor, its computation rule, and its eta principle. *) Definition F_corec {Y X} `(inF F Y) (f : Y -> X) : Y -> F X. Proof. refine ((fun (g : Y -> F X) => fromF F X o g)^-1 f). by apply isequiv_fromF_postcompose. Defined. Definition F_corec_beta {Y X} (YF : inF F Y) (f : Y -> X) : fromF F X o F_corec YF f == f. Proof. apply ap10, (eisretr (fun g => fromF F X o g)). Defined. Definition F_coindpaths {Y X} `(inF F Y) (g h : Y -> F X) (p : fromF F X o g == fromF F X o h) : g == h. Proof. apply ap10. refine (equiv_inj (fun k => fromF F X o k) _). - by apply isequiv_fromF_postcompose. - by apply path_arrow. Defined. (** The functorial action of the coreflector. *) Definition F_functor {X Y} (f : X -> Y) : F X -> F Y := F_corec (F_inF F X) (f o fromF F X). (** The coreflector preserves hprops (since it is a right adjoint and thus preserves limits). *) Local Instance ishprop_coreflection A `{IsHProp A} : IsHProp (F A). Proof. apply hprop_allpath; intros x y. exact (F_coindpaths (F_inF F A) (const x) (const y) (fun _ => path_ishprop _ _) x). Defined. (** A type lies in [F] as soon as [fromF] admits a section. *) Definition inF_fromF_sect X (s : X -> F X) (p : fromF F X o s == idmap) : inF F X. Proof. refine (transport (inF F) (path_universe (fromF F X)) (F_inF F X)). refine (isequiv_adjointify _ s p _). change (s o fromF F X == idmap). apply F_coindpaths; try apply F_inF. intros x; apply p. Defined. (** So far, nothing unexpected has happened. Now, however, we claim that [F] is completely determined by the image of [Unit], which by [ishprop_coreflection] is an hprop. Specifically, we claim that [X] lies in [F] exactly when [X -> F Unit]. *) Definition inF_equiv_implies_funit X : inF F X <~> (X -> F Unit). Proof. apply equiv_iff_hprop. - intros ?. apply F_corec; try assumption. exact (fun _ => tt). - intros f. simple refine (inF_fromF_sect X _ _). + intros x. exact (F_functor (unit_name x) (f x)). + intros x; unfold F_functor. exact (F_corec_beta (F_inF F Unit) (const x) (f x)). Defined. End CoreflectiveSubuniverse. (** Conversely, we will now show that for any hprop [U], the types [X] such that [X -> U] are a coreflective subuniverse, which we call "co-open" since it is dual to the open modality. *) Section CoOpen. Context `{Funext} (U : HProp). Definition coOp : CoreflectiveSubuniverse. Proof. simple refine (Build_CoreflectiveSubuniverse (fun X => Build_HProp (X -> U)) (fun X => X * U) (fun X => @snd X U) (fun X => @fst X U) _); try exact _. intros Y X YU; simpl in *. refine (isequiv_adjointify _ (fun h y => (h y , YU y)) _ _). - intros g; apply path_arrow; intros y; reflexivity. - intros h; apply path_arrow; intros y. apply path_prod; [ reflexivity | by apply path_ishprop ]. Defined. (** Thus, each coreflective subuniverses are uniquely determined by an hprop. Moreover, the coreflective subuniverse corresponding to an hprop [U] is closely related to the open modality [Op U]. Specifically, they form an _adjoint modality pair_ in the sense that the subuniverses are canonically equivalent, and the coreflection and reflection respect this equivalence. In categorical language, this says that the inclusion of an open subtopos is the center of a local geometric morphism in the other direction. We express this concisely as follows. *) Definition coopen_isequiv_open X : IsEquiv (O_functor (Op U) (fromF coOp X)). Proof. refine (isequiv_adjointify _ (fun ux => fun u => (ux u , u)) _ _). - intros ux; simpl in *. apply path_arrow; intros u. transitivity (O_functor (Op U) fst (to (Op U) (X * U) (ux u , u)) u). + apply ap10, ap, path_arrow; intros u'; simpl in *. apply path_prod; simpl; [ apply ap | ]; apply path_ishprop. + exact (ap10 (to_O_natural (Op U) (@fst X U) (ux u , u)) u). - intros uux; simpl in *. apply path_arrow; intros u. apply path_prod; [ simpl | apply path_ishprop ]. transitivity (O_functor (Op U) fst (to (Op U) _ (fst (uux u) , u)) u). + apply ap10, ap, path_arrow; intros u'. apply path_prod; simpl. * exact (ap fst (ap uux (path_ishprop u' u))). * apply path_ishprop. + exact (ap10 (to_O_natural (Op U) (@fst X U) (fst (uux u) , u)) u). Defined. Definition coopen_equiv_open X : Op U (coOp X) <~> Op U X := Build_Equiv _ _ (O_functor (Op U) (fromF coOp X)) (coopen_isequiv_open X). End CoOpen. Coq-HoTT-9.0/theories/Modalities/Descent.v000066400000000000000000000446211474641544500204350ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HFiber Extensions Limits.Pullback. Require Import Modality Accessible Modalities.Localization. Local Open Scope path_scope. Local Open Scope subuniverse_scope. (** * Descent between subuniverses *) (** We study here a strengthening of the relation [O << O'] saying that [O]-modal type families descend along [O']-equivalences. Pairs of reflective subuniverses with this relation share nearly all the properties of a reflective subuniverse [O] paired with its subuniverse [Sep O] of separated types (see [Separated.v]) and also many of those of a single left exact modality (see [Lex.v]). Thus, many of the results herein generalize those of RSS for lex modalities and those of CORS for separated subuniverses. Note that this kind of descent is not the same as the "modal descent" of Cherubini and Rijke. When we get around to formalizing that, we may need to worry about disambiguating the names. *) (** ** Definitions *) (** This definition is an analogue of the statement of Lemma 2.19 of CORS, and of Theorem 3.1(xiii) of RSS. Note that CORS Lemma 2.19 includes uniqueness of the extension, which we don't assert explicitly. However, uniqueness follows from the [ReflectsD] parameter -- see [ooextendable_TypeO_lex_leq] below. *) Class Descends@{i} (O' O : Subuniverse@{i}) (T : Type@{i}) `{ReflectsD@{i} O' O T} := { OO_descend : forall (P : T -> Type@{i}) {P_inO : forall x, In O (P x)}, O_reflector O' T -> Type@{i} ; OO_descend_inO : forall (P : T -> Type@{i}) {P_inO : forall x, In O (P x)} (x : O_reflector O' T), In O (OO_descend P x) ; OO_descend_beta : forall (P : T -> Type@{i}) {P_inO : forall x, In O (P x)} (x : T), OO_descend P (to O' T x) <~> P x ; }. Global Existing Instance OO_descend_inO. Arguments OO_descend O' O {T _ _ _} P {P_inO} x. Arguments OO_descend_inO O' O {T _ _ _} P {P_inO} x. Arguments OO_descend_beta O' O {T _ _ _} P {P_inO} x. Class O_lex_leq (O1 O2 : ReflectiveSubuniverse) `{O1 << O2} := O_lex_leq_descends : forall A, Descends O2 O1 A. Infix "<<<" := O_lex_leq : subuniverse_scope. Global Existing Instance O_lex_leq_descends. (** Unfortunately, it seems that generalizing binders don't work on notations: writing [`{O <<< O'}] doesn't automatically add the precondition [O << O'], although writing [`{O_lex_leq O O'}] does. *) Definition O_lex_leq_eq {O1 O2 O3 : ReflectiveSubuniverse} `{O1 <=> O2} `{O2 << O3, O2 <<< O3} (Hstrong := O_strong_leq_trans_l O1 O2 O3) : O1 <<< O3. Proof. intros A; unshelve econstructor; intros P P_inO1. all:pose (P_inO2 := fun x => inO_leq O1 O2 _ (P_inO1 x)). - apply (OO_descend O3 O2 P). - intros x; apply (inO_leq O2 O1), (OO_descend_inO O3 O2 P). - apply (OO_descend_beta O3 O2 P). Defined. (** ** Left exactness properties *) (** We prove analogues of the properties in section 2.4 of CORS and Theorem 3.1 of RSS, but in a different order, with different proofs, to increase the generality. The proofs in CORS use Proposition 2.26 for everything else, but it seems that most of the other results are true in the generality of two reflective subuniverses with [O <<< O'], so we give different proofs for some of them. (To show that this generality is non-spurious, note that a lex modality [O] satisfies [O <<< O], but does not generally coincide with [Sep O].) In the case of a single modality, most of these statements are equivalent to lex-ness (as stated in Theorem 3.1 of RSS). We do not know if anything similar is true more generally. *) Section LeftExactness. Universe i. Context (O' O : ReflectiveSubuniverse@{i}) `{O << O', O <<< O'}. (** Proposition 2.30 of CORS and Theorem 3.1(xii) of RSS: any [O']-equivalence is [O]-connected. The special case when [f = to O' A] requires only [O << O'], but the general case seems to require [O <<< O']. It is convenient to have this as an instance in this file, but we don't make it global, as it requires that Coq guess [O']. *) Local Instance conn_map_OO_inverts {A B : Type} (f : A -> B) `{O_inverts O' f} : IsConnMap O f. Proof. apply conn_map_from_extension_elim. intros P P_inO. assert (E : ExtendableAlong 1%nat f P); [ | exact (fst E) ]. assert (Qp := OO_descend_beta O' O P). assert (Q_inO := OO_descend_inO O' O P). set (Q := OO_descend O' O P) in *. refine (extendable_postcompose' _ (Q o to O' B) P f Qp _). refine (cancelL_extendable _ Q f (to O' B) _ _). 1:srapply (extendable_conn_map_inO O). refine (extendable_homotopic _ _ (O_functor O' f o to O' A) (to_O_natural O' f) _). srapply extendable_compose. 1:srapply extendable_equiv. srapply (extendable_conn_map_inO O). Defined. (** A generalization of Lemma 2.27 of CORS: [functor_sigma] of a family of [O]-equivalences over an [O']-equivalence is an [O]-equivalence. CORS Lemma 2.27 is the case when [f = to O' A] and [g] is a family of identities. *) Definition OO_inverts_functor_sigma {A B : Type} {P : A -> Type} {Q : B -> Type} (f : A -> B) (g : forall a, P a -> Q (f a)) `{O_inverts O' f} `{forall a, O_inverts O (g a)} : O_inverts O (functor_sigma f g). Proof. srapply isequiv_homotopic'. - refine (equiv_O_sigma_O O _ oE _ oE (equiv_O_sigma_O O _)^-1). refine (Build_Equiv _ _ (O_functor O (functor_sigma f (fun x => O_functor O (g x)))) _). - apply O_indpaths. intros [x u]; cbn. rewrite !to_O_natural, O_rec_beta; cbn. rewrite !to_O_natural, O_rec_beta. reflexivity. Defined. (** Families of [O]-modal types descend along all [O']-equivalences (not just the [O']-units, as asserted in the definition of [<<<]. *) Definition OO_descend_O_inverts {A B : Type} (f : A -> B) `{O_inverts O' f} (P : A -> Type) {P_inO : forall x, In O (P x)} : B -> Type. Proof. intros b. pose (Q := OO_descend O' O P). exact (Q ((O_functor O' f)^-1 (to O' B b))). Defined. Global Instance OO_descend_O_inverts_inO {A B : Type} (f : A -> B) `{O_inverts O' f} (P : A -> Type) {P_inO : forall x, In O (P x)} (b : B) : In O (OO_descend_O_inverts f P b) := _. Definition OO_descend_O_inverts_beta {A B : Type} (f : A -> B) `{O_inverts O' f} (P : A -> Type) {P_inO : forall x, In O (P x)} (a : A) : (OO_descend_O_inverts f P (f a)) <~> P a. Proof. unfold OO_descend_O_inverts. refine (OO_descend_beta O' O P a oE _). assert (p := (to_O_natural O' f a)^). apply moveR_equiv_V in p. exact (equiv_transport _ p). Defined. (** Morally, an equivalent way of saying [O <<< O'] is that the universe of [O]-modal types is [O']-modal. We can't say this directly since this type lives in a higher universe, but here is a rephrasing of it. *) Definition ooextendable_TypeO_lex_leq `{Univalence} {A B : Type} (f : A -> B) `{O_inverts O' f} : ooExtendableAlong f (fun _ => Type_ O). Proof. rapply ooextendable_TypeO_from_extension; intros P. exists (fun x => (OO_descend_O_inverts f P x ; OO_descend_O_inverts_inO f P x)). intros x; apply path_TypeO, path_universe_uncurried; cbn. exact (OO_descend_O_inverts_beta f P x). Defined. (** We can also state it in terms of belonging to a subuniverse if we lift [O'] accessibly (an analogue of Theorem 3.11(iii) of RSS). *) Global Instance inO_TypeO_lex_leq `{Univalence} `{IsAccRSU O'} : In (lift_accrsu O') (Type_ O) := fun i => ooextendable_TypeO_lex_leq (acc_lgen O' i). (** If [f] is an [O']-equivalence, then [ap f] is an [O]-equivalence. *) Global Instance OO_inverts_ap@{} {A B : Type@{i}} (f : A -> B) `{O_inverts O' f} (x y : A) : O_inverts O (@ap _ _ f x y). Proof. assert (Pb := OO_descend_O_inverts_beta f (fun y:A => O (x = y))). assert (P_inO := OO_descend_O_inverts_inO f (fun y:A => O (x = y))). set (P := OO_descend_O_inverts f (fun y:A => O (x = y))) in *. clearbody P; cbn in *. srapply isequiv_adjointify. - intros q. pose (t := fun p => @transport B P (f x) (f y) p ((Pb x)^-1 (to O (x = x) 1))). exact (Pb y (O_rec t q)). - apply O_indpaths; intros p; cbn. rewrite O_rec_beta. assert (g := extension_conn_map_elim O (functor_sigma f (fun (a:A) (p:P (f a)) => p)) (fun bp => O (f x = bp.1)) (fun u => O_functor O (ap f) (Pb u.1 u.2))). pose (g1 b p := g.1 (b;p)). cbn in g1. assert (e : (fun u => g1 u.1 u.2) == g.1). 1:intros [a b]; reflexivity. assert (g2 := fun a p => e _ @ g.2 (a;p)); cbn in g2. refine ((g2 y _)^ @ _). rewrite (ap_transport p g1). rewrite (g2 x ((Pb x)^-1 (to O (x = x) 1))). rewrite eisretr, to_O_natural; cbn. rewrite <- (ap_transport p (fun b => to O (f x = b))). apply ap. rewrite transport_paths_r. apply concat_1p. - apply O_indpaths; intros p; cbn. rewrite to_O_natural, O_rec_beta. destruct p; cbn. srapply eisretr. Defined. Definition equiv_O_functor_ap_OO_inverts {A B : Type} (f : A -> B) `{O_inverts O' f} (x y : A) : O (x = y) <~> O (f x = f y) := Build_Equiv _ _ (O_functor O (ap f)) _. (** Theorem 3.1(i) of RSS: path-spaces of [O']-connected types are [O]-connected. *) Definition OO_isconnected_paths {A : Type} `{IsConnected O' A} (x y : A) : IsConnected O (x = y). Proof. rapply (contr_equiv' _ (equiv_O_functor_ap_OO_inverts (const_tt _) x y)^-1). Defined. (** Proposition 2.26 of CORS and Theorem 3.1(ix) of RSS; also generalizes Theorem 7.3.12 of the book. Here we need to add the extra assumption that [O' <= Sep O], which is satisfied when [O' = Sep O] but also when [O] is lex and [O' = O]. That some such extra hypothesis is necessary can be seen from the fact that [Tr (-2) <<< O'] for any [O'], whereas this statement is certainly not true in that generality. *) Definition path_OO `{O' <= Sep O} {X : Type@{i}} (x y : X) : O (x = y) -> (to O' X x = to O' X y). Proof. nrefine (O_rec (O := O) (@ap X (O' X) (to O' X) x y)). - rapply (@inO_leq O' (Sep O)). - exact _. Defined. Global Instance isequiv_path_OO `{O' <= Sep O} {X : Type@{i}} (x y : X) : IsEquiv (path_OO x y). Proof. nrefine (isequiv_O_rec_O_inverts O _). (** Typeclass search can find this, but it's quicker (and may help the reader) to give it explicitly. *) apply (OO_inverts_ap (to O' X)). Defined. Definition equiv_path_OO `{O' <= Sep O} {X : Type@{i}} (x y : X) : O (x = y) <~> (to O' X x = to O' X y) := Build_Equiv _ _ (path_OO x y) _. (** [functor_hfiber] on a pair of [O']-equivalences is an [O]-equivalence. *) Global Instance OO_inverts_functor_hfiber {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) (b : B) `{O_inverts O' h, O_inverts O' k} : O_inverts O (functor_hfiber p b). Proof. unfold functor_hfiber. snrefine (OO_inverts_functor_sigma _ _). 1:exact _. intros a; cbn. refine (isequiv_homotopic (O_functor O (concat (p a)^) o O_functor O (@ap _ _ k (f a) b)) _). symmetry; apply O_functor_compose. Defined. (** Corollary 2.29 of CORS: [O'] preserves fibers up to [O]-equivalence. *) Global Instance OO_inverts_functor_hfiber_to_O {Y X : Type} (f : Y -> X) (x : X) : O_inverts O (functor_hfiber (fun a => (to_O_natural O' f a)^) x). Proof. (** Typeclass search can find this, but it's faster to give it explicitly. *) exact (OO_inverts_functor_hfiber _ _). Defined. Definition equiv_OO_functor_hfiber_to_O {Y X : Type@{i} } (f : Y -> X) (x : X) : O (hfiber f x) <~> O (hfiber (O_functor O' f) (to O' X x)) := Build_Equiv _ _ _ (OO_inverts_functor_hfiber_to_O f x). (** Theorem 3.1(iii) of RSS: any map between [O']-connected types is [O]-connected. (Part (ii) is just the version for dependent projections.) *) Definition OO_conn_map_isconnected {Y X : Type} `{IsConnected O' Y, IsConnected O' X} (f : Y -> X) : IsConnMap O f. Proof. intros x; rapply (contr_equiv' _ (equiv_OO_functor_hfiber_to_O f x)^-1). Defined. Definition OO_isconnected_hfiber {Y X : Type} `{IsConnected O' Y, IsConnected O' X} (f : Y -> X) (x : X) : IsConnected O (hfiber f x) := OO_conn_map_isconnected f x. (** Theorem 3.1(iv) of RSS: an [O]-modal map between [O']-connected types is an equivalence. *) Definition OO_isequiv_mapino_isconnected {Y X : Type} `{IsConnected O' Y, IsConnected O' X} (f : Y -> X) `{MapIn O _ _ f} : IsEquiv f. Proof. apply (isequiv_conn_ino_map O). - apply OO_conn_map_isconnected. - assumption. Defined. (** Theorem 3.1(vi) of RSS (and part (v) is just the analogue for dependent projections). *) Definition OO_conn_map_functor_hfiber {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} `{IsConnMap O' _ _ h, IsConnMap O' _ _ k} (p : k o f == g o h) (b : B) : IsConnMap O (functor_hfiber p b). Proof. intros [c q]. nrefine (isconnected_equiv' O _ (hfiber_functor_hfiber p b c q)^-1 _). apply OO_isconnected_hfiber. Defined. (** An enhancement of Corollary 2.29 of CORS, corresponding to Theorem 3.1(viii) of RSS: when [O'] is a modality, the map between fibers is not just an O-equivalence but is O-connected. *) Global Instance OO_conn_map_functor_hfiber_to_O `{IsModality O'} {Y X : Type} (f : Y -> X) (x : X) : IsConnMap O (functor_hfiber (fun y => (to_O_natural O' f y)^) x). Proof. apply OO_conn_map_functor_hfiber. Defined. (** Theorem 3.1(vii) of RSS *) Definition OO_ispullback_connmap_mapino {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) `{O_inverts O' h, O_inverts O' k, MapIn O _ _ f, MapIn O _ _ g} : IsPullback p. Proof. apply ispullback_isequiv_functor_hfiber; intros b. apply (isequiv_O_inverts O). apply OO_inverts_functor_hfiber; exact _. Defined. (** [functor_pullback] on a triple of [O']-equivalences is an [O]-equivalence. *) Global Instance OO_inverts_functor_pullback {A1 B1 C1 A2 B2 C2 : Type} (f1 : B1 -> A1) (g1 : C1 -> A1) (f2 : B2 -> A2) (g2 : C2 -> A2) (h : A1 -> A2) (k : B1 -> B2) (l : C1 -> C2) (p : f2 o k == h o f1) (q : g2 o l == h o g1) `{O_inverts O' h, O_inverts O' k, O_inverts O' l} : O_inverts O (functor_pullback f1 g1 f2 g2 h k l p q). Proof. unfold functor_pullback. snrefine (OO_inverts_functor_sigma _ _). 1:exact _. intros b1; cbn. snrefine (OO_inverts_functor_sigma _ _). 1:exact _. intros c1; cbn. pose @isequiv_compose. (* Speed up typeclass search. *) refine (isequiv_homotopic (O_functor O (fun r => r @ (q c1)^) o O_functor O (concat (p b1)) o O_functor O (@ap _ _ h (f1 b1) (g1 c1))) _). intros r; symmetry. refine (_ @ _). 2:apply O_functor_compose. cbn; srapply O_functor_compose. Defined. (** Proposition 2.28 of CORS, and Theorem 3.1(x) of RSS: the functor [O'] preserves pullbacks up to [O]-equivalence. *) Global Instance OO_inverts_functor_pullback_to_O {A B C : Type} (f : B -> A) (g : C -> A) : O_inverts O (functor_pullback f g (O_functor O' f) (O_functor O' g) (to O' A) (to O' B) (to O' C) (to_O_natural O' f) (to_O_natural O' g)). Proof. apply OO_inverts_functor_pullback; exact _. Defined. Definition equiv_OO_pullback {A B C : Type} (f : B -> A) (g : C -> A) : O (Pullback f g) <~> O (Pullback (O_functor O' f) (O_functor O' g)) := Build_Equiv _ _ _ (OO_inverts_functor_pullback_to_O f g). (** The "if" direction of CORS Proposition 2.31, and the nontrivial part of Theorem 3.1(xi) of RSS. Note that we could also deduce Theorem 3.1(iii) of RSS from this. *) Definition OO_cancelL_conn_map {Y X Z : Type} (f : Y -> X) (g : X -> Z) `{IsConnMap O' _ _ (g o f)} `{IsConnMap O' _ _ g} : IsConnMap O f. Proof. apply conn_map_OO_inverts. nrapply (cancelL_isequiv (O_functor O' g)). 1:exact _. rapply (isequiv_homotopic _ (O_functor_compose O' f g)). Defined. End LeftExactness. (** Here's the "only if" direction of CORS Proposition 2.31. Note that the hypotheses are different from those of the "if" direction, and the proof is shorter than the one given in CORS. *) Definition OO_cancelR_conn_map (O' O : ReflectiveSubuniverse@{u}) `{O_leq@{u u u} O O', O' <= Sep O} {Y X Z : Type} (f : Y -> X) (g : X -> Z) `{IsConnMap O' _ _ (g o f)} `{IsConnMap O _ _ f} : IsConnMap O' g. Proof. apply conn_map_from_extension_elim. intros P P_inO h. exists (conn_map_elim O' (g o f) P (h o f)). nrefine (conn_map_elim O f _ _); [ exact _ | .. ]. - intros x. pose proof (fun z => inO_leq O' (Sep O) (P z) (P_inO z)). exact _. - intros y. apply (conn_map_comp O' (g o f)). Defined. Definition OO_isconnected_from_conn_map (O' O : ReflectiveSubuniverse) `{O <= O', O' <= Sep O} {Y X : Type} (f : Y -> X) `{IsConnected O' Y} `{IsConnMap O _ _ f} : IsConnected O' X. Proof. apply isconnected_conn_map_to_unit. apply (OO_cancelR_conn_map O' O f (const_tt _)). Defined. (** An interesting scholium to Proposition 2.31. *) Definition OO_inverts_conn_map_factor_conn_map (O' O : ReflectiveSubuniverse) `{O << O', O <<< O', O' <= Sep O} {Y X Z : Type} (f : Y -> X) (g : X -> Z) `{IsConnMap O' _ _ (g o f)} `{IsConnMap O _ _ f} : O_inverts O' f. Proof. nrapply (cancelL_isequiv (O_functor O' g)). - apply O_inverts_conn_map. apply (OO_cancelR_conn_map O' O f g). - rapply (isequiv_homotopic _ (O_functor_compose O' f g)). Defined. Definition OO_inverts_conn_map_isconnected_domain (O' O : ReflectiveSubuniverse) `{O << O', O <<< O', O' <= Sep O} {Y X : Type} (f : Y -> X) `{IsConnected O' Y} `{IsConnMap O _ _ f} : O_inverts O' f. Proof. apply (OO_inverts_conn_map_factor_conn_map O' O f (const_tt _)). Defined. (** Here is the converse of [ooextendable_TypeO_lex_leq]. *) Definition O_lex_leq_extendable_TypeO (O' O : ReflectiveSubuniverse) `{O << O'} (e : forall (A:Type) (g:A->Type_ O), ExtensionAlong (to O' A) (fun _ => Type_ O) g) : O <<< O'. Proof. intros A; unshelve econstructor; intros P' P_inO; pose (P := fun x => (P' x ; P_inO x) : Type_ O). - exact (fun x => ((e A P).1 x).1). - exact (fun x => ((e A P).1 x).2). - intros x. apply equiv_path. exact (((e A P).2 x)..1). Defined. (** And a version for the accessible case. *) Definition O_lex_leq_inO_TypeO (O' O : ReflectiveSubuniverse) `{O << O'} `{IsAccRSU O'} `{In (lift_accrsu O') (Type_ O)} : O <<< O'. Proof. apply O_lex_leq_extendable_TypeO. intros A g. assert (O_inverts (lift_accrsu O') (to O' A)). - rapply (O_inverts_O_leq' (lift_accrsu O') O'). - exact (fst (ooextendable_O_inverts (lift_accrsu O') (to O' A) (Type_ O) 1%nat) g). Defined. Coq-HoTT-9.0/theories/Modalities/Fracture.v000066400000000000000000000227511474641544500206230ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Extensions Limits.Pullback. Require Import Modality Lex Open Closed Nullification. Local Open Scope path_scope. (** * The lex-modal fracture theorem *) (** The fracture theorem for two modalities [O1] and [O2] and a type [A], when it holds, states that the naturality square << A --> O1 A | | | | V V O2 A --> O2 (O1 A) >> is a pullback. This says in a certain precise sense that [A] can be recovered from its [O1]- and [O2]-reflections together with some information about how they fit together. If we think of [O1] and [O2] as subuniverses or subtoposes, then the fracture theorem says that their "union", or more precisely their *gluing*, is the whole universe. We will prove the fracture theorem holds under the assumptions that [O2] is lex, and that [O1]-connected types are [O2]-modal. Note that like lex-ness, the latter is also a "large" hypothesis. But also as with lex-ness, rather than hypothesize it polymorphically with a module type, we just hypothesize it in the obvious way and allow the polymophism of the resulting theorem to be computed automatically. This actually gives more precise information: the fracture theorem for a particular type [A] only depends on this hypothesis for types [B] lying in the same universe as [A]. (In fact, as we will see, it only needs the special cases of the fibers of [to O1 A], but in examples it seems no harder to verify the general case.) It may sometimes happen that in addition, the "intersection" of [O1] and [O2] is trivial. This is naturally expressed in the context of the fracture theorem by saying that [O2]-modal types are [O1]-connected, i.e. the converse of the second hypothesis of our fracture theorem. When this also holds, we can show that the universe [Type] can actually be reconstructed, up to equivalence, from the universes of [O1]- and [O2]-modal types and the [O2]-reflection from the first to the second, using the "Artin gluing construction" from topos theory. *) (** ** The fracture theorem *) Section FractureTheorem. Context (O1 O2 : Modality). Definition fracture_square (A : Type) : O_functor O2 (to O1 A) o to O2 A == to O2 (O1 A) o to O1 A := to_O_natural O2 (to O1 A). (** Here are the hypotheses of the fracture theorem *) Context `{Lex O2}. Definition Gluable : Type := forall (A : Type), IsConnected O1 A -> In O2 A. Context (ino2_isconnectedo1 : Gluable). (** The fracture theorem. *) Definition ispullback_fracture_square A : IsPullback (fracture_square A). Proof. apply ispullback_symm. nrefine (ispullback_connmap_mapino_commsq O2 _). 1-3:exact _. 2:rapply mapinO_between_inO. intros x; refine (ino2_isconnectedo1 _ _). Defined. (** ** The fracture gluing theorem *) (** We now also assume the converse of the second hyopthesis *) Definition Disjoint : Type := forall (A : Type), In O2 A -> IsConnected O1 A. Context (isconnectedo1_ino2 : Disjoint). (** This implies that the universe decomposes into an [O1]-part, an [O2]-part, and a gluing map. We define these pieces separately in order to make the maps transparent but the homotopies opaque. *) Definition fracture_glue_uncurried : { B : Type_ O1 & { C : Type_ O2 & C -> O2 B }} -> Type := fun BCf => Pullback BCf.2.2 (to O2 BCf.1). Definition fracture_glue (B C : Type) `{HB: In O1 B} `{HC: In O2 C} (f : C -> O2 B) : Type := fracture_glue_uncurried ((B;HB);((C;HC);f)). Definition fracture_unglue : Type -> { B : Type_ O1 & { C : Type_ O2 & C -> O2 B }} := fun A => ((O1 A ; O_inO A) ; ((O2 A ; O_inO A) ; O_functor O2 (to O1 A))). Definition fracture_unglue_isretr `{Univalence} (BCf : { B : Type_ O1 & { C : Type_ O2 & C -> O2 B }}) : fracture_unglue (fracture_glue_uncurried BCf) = BCf. Proof. destruct BCf as [B [C f]]. (** The first two components of our path will be applications of univalence. We begin by observing that maps we will use are equivalences. *) assert (IsEquiv (O_rec ((to O2 B)^*' f))). { apply isequiv_O_rec_O_inverts. apply O_inverts_conn_map, conn_map_pullback'. intros ob; apply isconnectedo1_ino2. rapply mapinO_between_inO. } assert (IsEquiv (O_rec (f^* (to O2 B)))). { apply isequiv_O_rec_O_inverts. apply O_inverts_conn_map, conn_map_pullback; exact _. } (** Now we start building the path. *) simple refine (path_sigma' _ _ _). { apply path_TypeO; unfold ".1", ".2". refine (path_universe (O_rec ((to O2 B)^*' f))). } refine (transport_sigma' _ _ @ _); unfold ".1", ".2". simple refine (path_sigma' _ _ _). { apply path_TypeO; unfold ".1", ".2". refine (path_universe (O_rec (f^* (to O2 B)))). } (** It remains to identify the induced function with the given [f]. We begin with some boilerplate. *) apply path_arrow; intros c. refine (transport_arrow_toconst _ _ _ @ _). refine (transport_arrow_fromconst (C := fun X:Type_ O1 => O2 X) _ _ _ @ _). refine (transport_compose O2 (TypeO_pr1 O1) _ _ @ _). refine (transport_compose idmap O2 _ _ @ _). (** Now we have to compute through the action of [ap] and [transport] on paths in sigmas and the universe. In applying these it helps to specify a couple of intermediate steps explicitly. *) transitivity (transport idmap (ap O2 (path_universe (O_rec ((to O2 B)^*' f)))) (O_functor O2 (to O1 (Pullback f (to O2 B))) ((O_rec (f^* (to O2 B)))^-1 c))); [ apply ap11; repeat apply ap | transitivity (O_functor O2 (O_rec ((to O2 B)^*' f)) (O_functor O2 (to O1 (Pullback f (to O2 B))) ((O_rec (f^* (to O2 B)))^-1 c))) ]. + refine (pr1_path_sigma_uncurried _ @ eisretr pr1 _). + refine (transport_compose idmap (TypeO_pr1 O2) (path_TypeO O2 (O2 (Pullback f (to O2 B)); _) C _)^ c @ _). refine (ap (fun p => transport idmap p c) (ap_V _ _) @ _). refine (ap (fun p => transport idmap p^ c) (pr1_path_sigma_uncurried _ @ eisretr pr1 _) @ _). refine (transport_path_universe_V _ _). + refine (ap (fun p => transport idmap p _) (ap_O_path_universe O2 _) @ _). refine (transport_path_universe _ _). (** Now we're down to the real point. *) + refine ((O_functor_compose O2 _ _ _)^ @ _). refine (O_functor_homotopy O2 _ _ (O_rec_beta _) _ @ _). revert c; equiv_intro (O_rec (f^* (to O2 B))) x. refine (ap _ (eissect _ _) @ _). revert x; apply O_indpaths; intros x. refine (to_O_natural O2 _ x @ _). refine (_ @ ap f (O_rec_beta _ _)^). destruct x as [a [b q]]; exact (q^). Qed. Definition fracture_unglue_issect `{Univalence} (A : Type) : fracture_glue_uncurried (fracture_unglue A) = A. Proof. apply path_universe_uncurried, equiv_inverse. exact (Build_Equiv _ _ (pullback_corec (fracture_square A)) (ispullback_fracture_square A)). Qed. Definition isequiv_fracture_unglue `{Univalence} : IsEquiv fracture_unglue := isequiv_adjointify fracture_unglue fracture_glue_uncurried fracture_unglue_isretr fracture_unglue_issect. Definition equiv_fracture_unglue `{Univalence} : Type <~> { B : Type_ O1 & { C : Type_ O2 & C -> O2 B }} := Build_Equiv _ _ fracture_unglue isequiv_fracture_unglue. End FractureTheorem. (** ** The propositional fracture theorem *) (** An easy example of the lex-modal fracture theorem is supplied by the open and closed modalities for an hprop [U]. *) Definition gluable_open_closed `{Funext} (U : HProp) : Gluable (Op U) (Cl U). Proof. intros A. change (Contr (U -> A) -> (U -> Contr A)); intros ? u. apply (Build_Contr _ (center (U -> A) u)); intros a. exact (ap10 (path_contr _ (fun _ => a)) u). Defined. Definition disjoint_open_closed `{Funext} (U : HProp) : Disjoint (Op U) (Cl U). Proof. intros A. change ((U -> Contr A) -> Contr (U -> A)); intros uc. apply (Build_Contr _ (fun u => let i := uc u in center A)). intros f; apply path_arrow; intros u. pose (uc u); apply path_contr. Defined. (** We can also prove the same thing without funext if we use the nullification versions of these modalities. *) Definition gluable_open_closed' (U : HProp) : Gluable (Op' U) (Cl' U). Proof. intros A ? u; simpl in *. pose proof (contr_inhabited_hprop U u). assert (Contr A). { simple refine (contr_equiv (Op' U A) _). - refine (O_rec idmap). intros []; simpl. apply ooextendable_equiv. refine (equiv_isequiv (@equiv_contr_contr U Unit _ _)). - refine (isequiv_adjointify _ (to (Op' U) A) _ _). + intros a; apply O_rec_beta. + apply O_indpaths; cbn. reflexivity. } apply ooextendable_contr; exact _. Defined. Definition disjoint_open_closed' (U : HProp) : Disjoint (Op' U) (Cl' U). Proof. intros A An. apply isconnected_from_elim; intros C Cn f. simple refine (@local_rec _ C Cn tt _ tt ; _); simpl. - intros u. exact (f (@local_rec _ A An u Empty_rec tt)). - intros a; simpl. refine (@local_indpaths _ C Cn tt (fun _ => f a) _ _ tt); intros u; simpl in *. refine (_ @ (@local_rec_beta _ C Cn tt _ u)^). apply ap. exact (@local_indpaths _ A An u (fun _ => a) _ (Empty_ind _) tt). Defined. Coq-HoTT-9.0/theories/Modalities/Identity.v000066400000000000000000000011431474641544500206310ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Modality Accessible. Local Open Scope path_scope. (** * The identity modality *) (** Everything to say here is fairly trivial. *) Definition purely : Modality. Proof. srapply (Build_Modality (fun _ => Unit) _ _ idmap). 1-2,6:intros; exact tt. - intros; assumption. - intros ? ? ? f z; exact (f z). - intros; reflexivity. Defined. Global Instance accmodality_purely : IsAccModality purely. Proof. unshelve econstructor. - econstructor. exact (@Empty_rec Type). - intros X; split. + intros _ []. + intros; exact tt. Defined. Coq-HoTT-9.0/theories/Modalities/Lex.v000066400000000000000000000430201474641544500175700ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HFiber Limits.Pullback Factorization Truncations.Core. Require Import Modality Accessible Modalities.Localization Descent Separated. Local Open Scope path_scope. Local Open Scope subuniverse_scope. (** * Lex modalities *) (** A lex modality is one that preserves finite limits, or equivalently pullbacks. Many equivalent characterizations of this can be found in Theorem 3.1 of RSS. We choose as our definition that a lex modality to be a reflective subuniverse such that [O <<< O], which is close to (but not quite the same as) RSS Theorem 3.1 (xiii). Note that since this includes [O << O] as a precondition, such an [O] must indeed be a modality (and since modalities coerce to reflective subuniverses, in the following notation [O] could be either an element of [ReflectiveSubuniverse] or of [Modality]). *) Notation Lex O := (O <<< O). (** ** Properties of lex modalities *) (** We now show that lex modalities have all the other properties from RSS Theorem 3.1 (which are equivalent to lex-ness). All of them are simple specializations of properties from [Descent.v] to the case [O' = O] (although in the general case they are not known to be equivalent). *) Section LexModality. Context (O : Modality) `{Lex O}. (** RSS Theorem 3.1 (i) *) Definition isconnected_paths {A : Type} `{IsConnected O A} (x y : A) : IsConnected O (x = y) := OO_isconnected_paths O O x y. (** RSS Theorem 3.1 (iii) *) Definition conn_map_lex {Y X : Type} `{IsConnected O Y, IsConnected O X} (f : Y -> X) : IsConnMap O f := OO_conn_map_isconnected O O f. (** RSS Theorem 3.1 (iv) *) Definition isequiv_mapino_isconnected {Y X : Type} `{IsConnected O Y, IsConnected O X} (f : Y -> X) `{MapIn O _ _ f} : IsEquiv f := OO_isequiv_mapino_isconnected O O f. (** RSS Theorem 3.1 (vi) *) Definition conn_map_functor_hfiber {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} `{IsConnMap O _ _ h, IsConnMap O _ _ k} (p : k o f == g o h) (b : B) : IsConnMap O (functor_hfiber p b) := OO_conn_map_functor_hfiber O O p b. (** RSS Theorem 3.1 (vii) *) Definition ispullback_connmap_mapino_commsq {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D} (p : k o f == g o h) `{O_inverts O h, O_inverts O k, MapIn O _ _ f, MapIn O _ _ g} : IsPullback p := OO_ispullback_connmap_mapino O O p. (** RSS Theorem 3.1 (viii) *) Global Instance conn_map_functor_hfiber_to_O {Y X : Type} (f : Y -> X) (x : X) : IsConnMap O (functor_hfiber (fun y => (to_O_natural O f y)^) x) := OO_conn_map_functor_hfiber_to_O O O f x. Global Instance isequiv_O_functor_hfiber {A B} (f : A -> B) (b : B) : IsEquiv (O_functor_hfiber O f b). Proof. apply (isequiv_O_rec_O_inverts O). apply O_inverts_conn_map. refine (conn_map_homotopic O (functor_hfiber (fun x => (to_O_natural O f x)^) b) _ _ _). intros [a p]. unfold functor_hfiber, functor_sigma. apply ap. apply whiskerR, inv_V. Defined. Definition equiv_O_functor_hfiber {A B} (f : A -> B) (b : B) : O (hfiber f b) <~> hfiber (O_functor O f) (to O B b) := Build_Equiv _ _ (O_functor_hfiber O f b) _. (** RSS Theorem 3.1 (ix) *) Global Instance isequiv_path_O {X : Type@{i}} (x y : X) : IsEquiv (path_OO O O x y) := isequiv_path_OO O O x y. Definition equiv_path_O {X : Type@{i}} (x y : X) : O (x = y) <~> (to O X x = to O X y) := equiv_path_OO O O x y. Definition equiv_path_O_to_O {X : Type} (x y : X) : (equiv_path_O x y) o (to O (x = y)) == @ap _ _ (to O X) x y. Proof. intros p; unfold equiv_path_O, equiv_path_OO, path_OO; cbn. apply O_rec_beta. Defined. (** RSS Theorem 3.1 (x). This justifies the term "left exact". *) Global Instance O_inverts_functor_pullback_to_O {A B C : Type} (f : B -> A) (g : C -> A) : O_inverts O (functor_pullback f g (O_functor O f) (O_functor O g) (to O A) (to O B) (to O C) (to_O_natural O f) (to_O_natural O g)) := OO_inverts_functor_pullback_to_O O O f g. Definition equiv_O_pullback {A B C : Type} (f : B -> A) (g : C -> A) : O (Pullback f g) <~> Pullback (O_functor O f) (O_functor O g) := equiv_O_rec_O_inverts O (functor_pullback f g (O_functor O f) (O_functor O g) (to O A) (to O B) (to O C) (to_O_natural O f) (to_O_natural O g)). Definition O_functor_pullback {A B C : Type} (f : B -> A) (g : C -> A) : IsPullback (O_functor_square O _ _ _ _ (pullback_commsq f g)). Proof. unfold IsPullback. nrapply (isequiv_homotopic (O_rec (functor_pullback _ _ _ _ _ _ _ (to_O_natural O f) (to_O_natural O g)))). 1: apply isequiv_O_rec_O_inverts; exact _. apply O_indpaths. etransitivity. 1: intro x; apply O_rec_beta. symmetry. snrapply pullback_homotopic; intros [b [c e]]; cbn. all: change (to (modality_subuniv O)) with (to O). - nrapply (to_O_natural O). - nrapply (to_O_natural O). - Open Scope long_path_scope. lhs nrapply concat_p_pp. lhs nrapply (concat_p_pp _ _ _ @@ 1). rewrite to_O_natural_compose. unfold O_functor_square. rewrite O_functor_homotopy_beta. rewrite 6 concat_pp_p. do 3 apply whiskerL. rhs_V nrapply concat_pp_p. apply moveL_pM. lhs_V nrapply inv_pp. rhs_V nrapply inv_Vp. apply (ap inverse). nrapply to_O_natural_compose. Close Scope long_path_scope. Defined. Definition diagonal_O_functor {A B : Type} (f : A -> B) : diagonal (O_functor O f) == equiv_O_pullback f f o O_functor O (diagonal f). Proof. apply O_indpaths; intros x. refine (_ @ (ap _ (to_O_natural _ _ _))^). cbn. refine (_ @ (O_rec_beta _ _)^). unfold diagonal, functor_pullback, functor_sigma; cbn. apply ap, ap. apply moveL_pV; exact (concat_1p_p1 _). Defined. (** RSS Theorem 3.1 (xi) *) Definition cancelL_conn_map {Y X Z : Type} (f : Y -> X) (g : X -> Z) `{IsConnMap O _ _ (g o f)} `{IsConnMap O _ _ g} : IsConnMap O f := OO_cancelL_conn_map O O f g. (** RSS Theorem 3.1 (xii) *) Global Instance conn_map_O_inverts {A B : Type} (f : A -> B) `{O_inverts O f} : IsConnMap O f := conn_map_OO_inverts O O f. (** RSS Theorem 3.1 (xiii) *) Definition modal_over_connected_isconst_lex (A : Type) `{IsConnected O A} (P : A -> Type) `{forall x, In O (P x)} : {Q : Type & In O Q * forall x, Q <~> P x}. Proof. pose proof (O_inverts_isconnected O (fun _:A => tt)). exists (OO_descend_O_inverts O O (fun _:A => tt) P tt); split. - apply OO_descend_O_inverts_inO. - intros; nrapply OO_descend_O_inverts_beta. Defined. (** RSS Theorem 3.11 (iii): in the accessible case, the universe is modal. *) Global Instance inO_typeO_lex `{Univalence} `{IsAccRSU O} : In (lift_accrsu O) (Type_ O) := _. (** Part of RSS Corollary 3.9: lex modalities preserve [n]-types for all [n]. This is definitely not equivalent to lex-ness, since it is true for the truncation modalities that are not lex. But it is also not true of all modalities; e.g. the shape modality in a cohesive topos can take 0-types to [oo]-types. With a little more work, this can probably be proven without [Funext]. *) Global Instance istrunc_O_lex `{Funext} {n : trunc_index} {A : Type} `{IsTrunc n A} : IsTrunc n (O A). Proof. generalize dependent A; simple_induction n n IHn; intros A ?. - exact _. (** Already proven for all modalities. *) - apply istrunc_S. refine (O_ind (fun x => forall y, IsTrunc n (x = y)) _); intros x. refine (O_ind (fun y => IsTrunc n (to O A x = y)) _); intros y. refine (istrunc_equiv_istrunc _ (equiv_path_O x y)). Defined. End LexModality. (** ** Equivalent characterizations of lex-ness *) (** We will not prove that *all* of the above properties from RSS Theorem 3.1 are equivalent to lex-ness, but we will do it for some of them. *) Section ImpliesLex. Context {O : Modality}. (** RSS 3.1 (xiii) implies lexness *) Definition lex_from_modal_over_connected_isconst (H : forall (A : Type) (A_isC : IsConnected O A) (P : A -> Type) (P_inO : forall x, In O (P x)), {Q : Type & In O Q * forall x, Q <~> P x}) : Lex O. Proof. intros A; unshelve econstructor; intros P P_inO. all:pose (Q := fun z:O A => H (hfiber (to O A) z) _ (P o pr1) _). - exact (fun z => (Q z).1). - exact (fun z => fst (Q z).2). - intros x; cbn. exact (snd (Q (to O A x)).2 (x;1)). Defined. (** RSS 3.11 (iii), the universe is modal, implies lex-ness *) Definition lex_from_inO_typeO `{IsAccRSU O} `{In (lift_accrsu O) (Type_ O)} : Lex O. Proof. apply (O_lex_leq_inO_TypeO O O). Defined. (** RSS Theorem 3.1 (xi) implies lex-ness *) Definition lex_from_cancelL_conn_map (cancel : forall {Y X Z : Type} (f : Y -> X) (g : X -> Z), (IsConnMap O (g o f)) -> (IsConnMap O g) -> IsConnMap O f) : Lex O. Proof. apply lex_from_modal_over_connected_isconst; intros. exists (O {x:A & P x}); split; [ exact _ | intros x; symmetry ]. refine (Build_Equiv _ _ (fun p => to O _ (x ; p)) _). nrefine (isequiv_conn_map_ino O _). 1-2:exact _. revert x; apply conn_map_fiber. nrefine (cancel _ _ _ _ (fun z:{x:A & O {x : A & P x}} => z.2) _ _). 1: clear cancel; exact _. intros z. refine (isconnected_equiv' O A _ _). unfold hfiber. refine (equiv_adjointify (fun x => ((x ; z) ; 1)) (fun y => y.1.1) _ _). - intros [[x y] []]; reflexivity. - intros x; reflexivity. Defined. (** RSS Theorem 3.1 (iii) implies lex-ness *) Definition lex_from_conn_map_lex (H : forall A B (f : A -> B), (IsConnected O A) -> (IsConnected O B) -> IsConnMap O f) : Lex O. Proof. apply lex_from_cancelL_conn_map. intros Y X Z f g gfc gc x. pose (h := @functor_hfiber Y Z X Z (g o f) g f idmap (fun a => 1%path)). assert (cc := H _ _ (h (g x)) (gfc (g x)) (gc (g x))). refine (isconnected_equiv' O _ _ (cc (x;1))). unfold hfiber. subst h; unfold functor_hfiber, functor_sigma; cbn. refine (_ oE (equiv_sigma_assoc _ _)^-1). apply equiv_functor_sigma_id; intros y; cbn. refine (_ oE (equiv_functor_sigma_id _)). 2:intros; symmetry; apply equiv_path_sigma. cbn. refine (_ oE equiv_sigma_symm _). apply equiv_sigma_contr; intros p. destruct p; cbn. refine (contr_equiv' { p : g (f y) = g (f y) & p = 1%path } _). apply equiv_functor_sigma_id; intros p; cbn. apply equiv_concat_l. exact (concat_1p _ @ ap_idmap _). Defined. (** RSS Theorem 3.1 (i) implies lex-ness *) Definition lex_from_isconnected_paths (H : forall (A : Type) (Ac : IsConnected O A) (x y : A), IsConnected O (x = y)) : Lex O. Proof. apply lex_from_conn_map_lex. intros A B f Ac Bc c. rapply isconnected_sigma. Defined. (** RSS Theorem 3.1 (iv) implies lex-ness *) Definition lex_from_isequiv_ismodal_isconnected_types (H : forall A B (f : A -> B), (IsConnected O A) -> (IsConnected O B) -> (MapIn O f) -> IsEquiv f) : Lex O. Proof. apply lex_from_conn_map_lex. intros A B f AC BC. apply (conn_map_homotopic O _ _ (fact_factors (image O f))). apply conn_map_compose; [ exact _ | ]. apply conn_map_isequiv. apply H; [ | exact _ | exact _ ]. apply isconnected_conn_map_to_unit. apply (cancelR_conn_map O (factor1 (image O f)) (const_tt _)). Defined. (** RSS Theorem 3.1 (vii) implies lex-ness *) Definition lex_from_ispullback_connmap_mapino_commsq (H : forall {A B C D} (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D), (IsConnMap O f) -> (IsConnMap O g) -> (MapIn O h) -> (MapIn O k) -> forall (p : k o f == g o h), IsPullback p) : Lex O. Proof. apply lex_from_isequiv_ismodal_isconnected_types. intros A B f AC BC fM. specialize (H A Unit B Unit (const_tt _) (const_tt _) f idmap _ _ _ _ (fun _ => 1)). unfold IsPullback, pullback_corec in H. refine (@isequiv_compose _ _ _ H _ (fun x => x.2.1) _). unfold Pullback. refine (@isequiv_compose _ {b:Unit & B} (functor_sigma idmap (fun a => pr1)) _ _ pr2 _). refine (@isequiv_compose _ _ (equiv_sigma_prod0 Unit B) _ _ snd _). apply (equiv_isequiv (prod_unit_l B)). Defined. End ImpliesLex. (** ** Lex reflective subuniverses *) (** A reflective subuniverse that preserves fibers is in fact a modality (and hence lex). *) Definition ismodality_isequiv_O_functor_hfiber (O : ReflectiveSubuniverse) (H : forall {A B : Type} (f : A -> B) (b : B), IsEquiv (O_functor_hfiber O f b)) : IsModality O. Proof. intros A'; rapply reflectsD_from_inO_sigma. intros B B_inO. pose (A := O A'). pose (g := O_rec pr1 : O {x : A & B x} -> A). transparent assert (p : (forall x, g (to O _ x) = x.1)). { intros x; subst g; apply O_rec_beta. } apply inO_isequiv_to_O. apply isequiv_contr_map; intros x. snrefine (contr_equiv' _ (hfiber_hfiber_compose_map _ g x)). apply contr_map_isequiv. unfold hfiber_compose_map. transparent assert (h : (hfiber (@pr1 A B) (g x) <~> hfiber g (g x))). { refine (_ oE equiv_to_O O _). refine (_ oE Build_Equiv _ _ (O_functor_hfiber O (@pr1 A B) (g x)) _). unfold hfiber. apply equiv_functor_sigma_id. intros y; cbn. refine (_ oE (equiv_moveR_equiv_V _ _)). apply equiv_concat_l. apply moveL_equiv_V. unfold g, O_functor. revert y; apply O_indpaths; intros [a q]; cbn. refine (_ @ (O_rec_beta _ _)^). apply ap, O_rec_beta. } refine (isequiv_homotopic (h oE equiv_hfiber_homotopic _ _ p (g x)) _). intros [[a b] q]; cbn. clear h. unfold O_functor_hfiber. rewrite O_rec_beta. unfold functor_sigma; cbn. refine (path_sigma' _ 1 _). rewrite O_indpaths_beta; cbn. unfold moveL_equiv_V, moveR_equiv_V. Open Scope long_path_scope. Local Opaque eissect. (* work around bug 4533 *) (* Even though https://github.com/coq/coq/issues/4533 is closed, this is still needed. *) rewrite !ap_pp, !concat_p_pp, !ap_V. unfold to_O_natural. rewrite concat_pV_p. subst p. rewrite concat_pp_V. rewrite concat_pp_p; apply moveR_Vp. rewrite <- !(ap_compose (to O A) (to O A)^-1). rapply @concat_A1p. Local Transparent eissect. (* work around bug 4533 *) Close Scope long_path_scope. Qed. (** ** Lexness via generators *) (** Here the characterization of when an accessible presentation yields a lex modality from Anel-Biederman-Finster-Joyal ("Higher Sheaves and Left-Exact Localizations of ∞-Topoi", arXiv:2101.02791): it's enough for path spaces of the generators to be connected. *) Definition lex_gen `{Univalence} (O : Modality) `{IsAccModality O} (lexgen : forall (i : ngen_indices (acc_ngen O)) (x y : ngen_type (acc_ngen O) i), IsConnected O (x = y)) : Lex O. Proof. srapply lex_from_inO_typeO; [ exact _ | intros i ]. rapply ooextendable_TypeO_from_extension; intros P; srefine (_;_). 1:intros; exists (forall x, P x); exact _. assert (wc : forall y z, P y <~> P z). { intros y z. (** Here we use the hypothesis [lexgen] (typeclass inference finds it automatically). *) refine (pr1 (isconnected_elim O _ (@equiv_transport _ P y z))). } intros x; apply path_TypeO, path_universe_uncurried. refine (equiv_adjointify (fun f => f x) (fun u y => wc x y ((wc x x)^-1 u)) _ _). - intros u; apply eisretr. - intros f; apply path_forall; intros y; apply moveR_equiv_M. destruct (isconnected_elim O _ (fun y => (wc x y)^-1 (f y))) as [z p]. exact (p x @ (p y)^). Defined. (** ** n-fold separation *) (** A type is [n]-[O]-separated, for n >= -2, if all its (n+2)-fold iterated identity types are [O]-modal. Inductively, this means that it is (-2)-O-separated if it is O-modal, and (n+1)-O-separated if its identity types are n-O-separated. *) Fixpoint nSep (n : trunc_index) (O : Subuniverse) : Subuniverse := match n with | -2 => O | n.+1 => Sep (nSep n O) end. (** The reason for indexing this notion by a [trunc_index] rather than a [nat] is that when O is lex, a type is n-O-separated if and only if its O-unit is an n-truncated map. *) Definition nsep_iff_trunc_to_O (n : trunc_index) (O : Modality) `{Lex O} (A : Type) : In (nSep n O) A <-> IsTruncMap n (to O A). Proof. revert A; induction n as [|n IHn]; intros A; split; intros ?. - apply contr_map_isequiv; rapply isequiv_to_O_inO. - apply (inO_equiv_inO (O A) (to O A)^-1). - apply istruncmap_from_ap; intros x y. pose (i := fst (IHn (x = y)) _). apply istruncmap_mapinO_tr, (mapinO_homotopic _ _ (equiv_path_O_to_O O x y)). - intros x y. apply (snd (IHn (x = y))). pose (i := istruncmap_ap n (to O A) x y). apply mapinO_tr_istruncmap in i. apply istruncmap_mapinO_tr, (mapinO_homotopic _ ((equiv_path_O O x y)^-1 o (@ap _ _ (to O A) x y))). { intros p; apply moveR_equiv_V; symmetry; apply equiv_path_O_to_O. } pose mapinO_isequiv. (* This speeds up the next line. *) rapply mapinO_compose. Defined. Coq-HoTT-9.0/theories/Modalities/Localization.v000066400000000000000000000563751474641544500215110ustar00rootroot00000000000000(** * Localization *) Require Import HoTT.Basics HoTT.Types. Require Import Extensions. Require Import ReflectiveSubuniverse Accessible. Local Open Scope nat_scope. Local Open Scope path_scope. (** Suppose given a family of maps [f : forall (i:I), S i -> T i]. A type [X] is said to be [f]-local if for all [i:I], the map [(T i -> X) -> (S i -> X)] given by precomposition with [f i] is an equivalence. Our goal is to show that the [f]-local types form a reflective subuniverse, with a reflector constructed by localization. That is, morally we want to say << Inductive Localize f (X : Type) : Type := | loc : X -> Localize X | islocal_localize : forall i, IsEquiv (fun (g : T i -> X) => g o f i). >> This is not a valid HIT by the usual rules, but if we expand out the definition of [IsEquiv] and apply [path_sigma] and [path_forall], then it becomes one. We get a simpler definition (no 2-path constructors) if we do this with [BiInv] rather than [IsEquiv]: << Inductive Localize f (X : Type) : Type := | loc : X -> Localize X | lsect : forall i (g : S i -> X), T i -> X | lissect : forall i (g : S i -> X) (s : S i), lsect i g (f i s) = g s | lretr : forall i (g : S i -> X), T i -> X | lisretr : forall i (h : T i -> X) (t : T i), lretr i (h o f i) t = h t. >> This definition works, and from it one can prove that the [f]-local types form a reflective subuniverse. However, the proof inextricably involves [Funext]. We can avoid [Funext] in the same way that we did in the definition of a [ReflectiveSubuniverse], by using pointwise path-split precomposition equivalences. Observe that the assertion [ExtendableAlong n f C] consists entirely of points, paths, and higher paths in [C]. Therefore, for any [n] we might choose, we can define [Localize f X] as a HIT to universally force [ExtendableAlong n (f i) (fun _ => Localize f X)] to hold for all [i]. For instance, when [n] is 2 (the smallest value which will ensure that [Localize f X] is actually [f]-local), we get << Inductive Localize f (X : Type) : Type := | loc : X -> Localize X | lrec : forall i (g : S i -> X), T i -> X | lrec_beta : forall i (g : S i -> X) (s : T i), lrec i g (f i s) = g s | lindpaths : forall i (h k : T i -> X) (p : h o f i == k o f i) (t : T i), h t = k t | lindpaths_beta : forall i (h k : T i -> X) (p : h o f i == k o f i) (s : S i), lindpaths i h k p (f i s) = p s. >> However, just as for [ReflectiveSubuniverse], in order to completely avoid [Funext] we need the [oo]-version of path-splitness. Written out as above, this would involve infinitely many constructors (but it would not otherwise be problematic, so for instance it can be constructed semantically in model categories). We can't actually write out infinitely many constructors in Coq, of course, but since we have a finite definition of [ooExtendableAlong], we can just assert directly that [ooExtendableAlong (f i) (fun _ => Localize f X)] holds for all [i]. Then, however, we have to express the hypotheses of the induction principle. We know what these should be for each path-constructor and higher path-constructor, so all we need is a way to package up those infinitely many hypotheses into a single one, analogously to [ooExtendableAlong]. Thus, we begin this file by defining a "dependent" version of [ooExtendableAlong], and of course we start this with a version for finite [n]. *) (** ** Dependent extendability *) Fixpoint ExtendableAlong_Over@{a b c d m | a <= m, b <= m, c <= m, d <= m} (n : nat) {A : Type@{a}} {B : Type@{b}} (f : A -> B) (C : B -> Type@{c}) (D : forall b, C b -> Type@{d}) (ext : ExtendableAlong@{a b c m} n f C) : Type@{m} := match n return ExtendableAlong@{a b c m} n f C -> Type@{m} with | 0 => fun _ => Unit | S n => fun ext' => (forall (g : forall a, C (f a)) (g' : forall a, D (f a) (g a)), sig@{m m} (** Control universe parameters *) (fun (rec : forall b, D b ((fst ext' g).1 b)) => forall a, (fst ext' g).2 a # rec (f a) = g' a )) * forall (h k : forall b, C b) (h' : forall b, D b (h b)) (k' : forall b, D b (k b)), ExtendableAlong_Over n f (fun b => h b = k b) (fun b c => c # h' b = k' b) (snd ext' h k) end ext. (** Like [ExtendableAlong], these can be postcomposed with known equivalences. *) Definition extendable_over_postcompose' (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) (ext : ExtendableAlong n f C) (D E : forall b, C b -> Type) (g : forall b c, D b c <~> E b c) : ExtendableAlong_Over n f C D ext -> ExtendableAlong_Over n f C E ext. Proof. revert C ext D E g; simple_induction n n IHn; intros C ext D E g; simpl. 1:by apply idmap. intros ext'. split. - intros h k. exists (fun b => g b ((fst ext h).1 b) ((fst ext' h (fun a => (g _ _)^-1 (k a))).1 b)). intros a. refine ((ap_transport ((fst ext h).2 a) (g (f a)) _)^ @ _). apply moveR_equiv_M. exact ((fst ext' h (fun a => (g _ _)^-1 (k a))).2 a). - intros p q p' q'. refine (IHn (fun b => p b = q b) _ (fun b => fun c => transport (D b) c ((g b (p b))^-1 (p' b)) = ((g b (q b))^-1 (q' b))) _ _ (snd ext' p q (fun b => (g b (p b))^-1 (p' b)) (fun b => (g b (q b))^-1 (q' b)))). intros b c. refine (_ oE equiv_moveR_equiv_M _ _). apply equiv_concat_l. refine (_ @ (ap_transport c (g b) _)^). apply ap, symmetry, eisretr. Defined. Definition extendable_over_postcompose (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) (ext : ExtendableAlong n f C) (D E : forall b, C b -> Type) (g : forall b c, D b c -> E b c) `{forall b c, IsEquiv (g b c)} : ExtendableAlong_Over n f C D ext -> ExtendableAlong_Over n f C E ext := extendable_over_postcompose' n C f ext D E (fun b c => Build_Equiv _ _ (g b c) _). (** And if the dependency is trivial, we obtain them from an ordinary [ExtendableAlong]. *) Definition extendable_over_const (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) (ext : ExtendableAlong n f C) (D : B -> Type) : ExtendableAlong n f D -> ExtendableAlong_Over n f C (fun b _ => D b) ext. Proof. revert C ext D. simple_induction n n IHn; intros C ext D ext'. 1:exact tt. split. - intros g g'. exists ((fst ext' g').1). exact (fun a => transport_const ((fst ext g).2 a) _ @ (fst ext' g').2 a). - intros h k h' k'. refine (extendable_over_postcompose' _ _ _ _ _ _ _ (IHn (fun b => h b = k b) (snd ext h k) (fun b => h' b = k' b) (snd ext' h' k'))). exact (fun b c => equiv_concat_l (transport_const c (h' b)) (k' b)). Defined. (** This lemma will be used in stating the computation rule for localization. *) Fixpoint apD_extendable_eq (n : nat) {A B : Type} (C : B -> Type) (f : A -> B) (ext : ExtendableAlong n f C) (D : forall b, C b -> Type) (g : forall b c, D b c) (ext' : ExtendableAlong_Over n f C D ext) {struct n} : Type. Proof. destruct n. - exact Unit. - apply prod. + exact (forall (h : forall a, C (f a)) (b : B), g b ((fst ext h).1 b) = (fst ext' h (fun a => g (f a) (h a))).1 b). + exact (forall h k, apD_extendable_eq n A B (fun b => h b = k b) f (snd ext h k) (fun b c => c # g b (h b) = g b (k b)) (fun b c => apD (g b) c) (snd ext' h k _ _)). Defined. (** Here's the [oo]-version. *) Definition ooExtendableAlong_Over@{a b c d m | a <= m, b <= m, c <= m, d <= m} {A : Type@{a}} {B : Type@{b}} (f : A -> B) (C : B -> Type@{c}) (D : forall b, C b -> Type@{d}) (ext : ooExtendableAlong f C) := forall n, ExtendableAlong_Over@{a b c d m} n f C D (ext n). (** The [oo]-version for trivial dependency. *) Definition ooextendable_over_const {A B : Type} (C : B -> Type) (f : A -> B) (ext : ooExtendableAlong f C) (D : B -> Type) : ooExtendableAlong f D -> ooExtendableAlong_Over f C (fun b _ => D b) ext := fun ext' n => extendable_over_const n C f (ext n) D (ext' n). (** A crucial fact: the [oo]-version is inherited by types of homotopies. *) Definition ooextendable_over_homotopy {A B : Type} (C : B -> Type) (f : A -> B) (ext : ooExtendableAlong f C) (D : forall b, C b -> Type) (r s : forall b c, D b c) : ooExtendableAlong_Over f C D ext -> ooExtendableAlong_Over f C (fun b c => r b c = s b c) ext. Proof. intros ext' n. revert C ext D r s ext'. simple_induction n n IHn; intros C ext D r s ext'. 1:exact tt. split. - intros g g'. simple refine (_;_); simpl. + intros b. refine (_ @ (fst (snd (ext' 2) _ _ (fun b' => r b' ((fst (ext n.+1) g).1 b')) (fun b' => s b' ((fst (ext n.+1) g).1 b'))) (fun _ => 1) _).1 b). * refine (transport2 (D b) (p := 1) _ _). refine ((fst (snd (snd (ext 3) _ _) (fun b' => 1) ((fst (snd (ext 2) _ _) (fun a : A => 1)).1) ) _).1 b); intros a. symmetry; refine ((fst (snd (ext 2) _ _) (fun a' => 1)).2 a). * intros a; simpl. refine (_ @ ap (transport (D (f a)) ((fst (ext n.+1) g).2 a)^) (g' a) @ _); [ symmetry; by apply apD | by apply apD ]. + intros a; simpl. set (h := (fst (ext n.+1) g).1). match goal with |- context[ (fst (snd (ext' 2) _ _ ?k1 ?k2) (fun _ => 1) ?l).1 ] => pose (p := (fst (snd (ext' 2) _ _ k1 k2) (fun _ => 1) l).2 a); simpl in p end. rewrite transport_paths_Fl in p. apply moveL_Mp in p. refine (ap (transport _ _) (1 @@ p) @ _); clear p. unfold transport2; rewrite concat_p_pp. match goal with |- transport ?P ?p ((ap ?f ?q @ ap ?f ?r) @ ?s) = ?t => refine (ap (transport P p) ((ap_pp f q r)^ @@ (idpath s)) @ _) end. pose (p := (fst (snd (snd (ext 3) h h) (fun b' : B => 1) ((fst (snd (ext 2) h h) (fun a0 : A => 1)).1)) (fun a' : A => ((fst (snd (ext 2) h h) (fun a' : A => 1)).2 a')^)).2 a); simpl in p. refine (ap (transport _ _) (ap (ap _) (p @@ 1) @@ 1) @ _); clear p. rewrite concat_Vp; simpl; rewrite concat_1p. refine (transport_paths_FlFr_D _ _ @ _). Open Scope long_path_scope. rewrite !ap_pp, !concat_p_pp, ap_transport_pV. (* Even though https://github.com/coq/coq/issues/4533 is closed, this workaround is still needed. Without the Opaque setting, the [rewrite] unfolds the first [transport_pV] in the goal, and the first [moveR_Vp] below fails. *) Local Opaque transport_pV. (* work around bug 4533 *) rewrite !concat_p_pp. Local Transparent transport_pV. (* work around bug 4533 *) refine ((((_ @@ 1) @ concat_1p _) @@ 1 @@ 1 @@ 1) @ _). * rewrite ap_V, concat_pp_p. do 2 apply moveR_Vp. rewrite concat_p1. symmetry; apply transport_pV_ap. * rewrite !concat_pp_p. refine ((1 @@ _) @ (concat_p1 _)). apply moveR_Vp; rewrite concat_p1. apply transport_pV_ap. Close Scope long_path_scope. - intros h k h' k'. refine (extendable_over_postcompose' _ _ _ _ _ _ (fun b c => equiv_cancelL (apD (r b) c) _ _) _). refine (IHn _ _ _ _ _ (fun n => snd (ext' n.+1) h k (fun b => r b (h b)) (fun b => s b (k b)))). Qed. (** ** Local types *) Import IsLocal_Internal. Definition islocal_equiv_islocal (f : LocalGenerators@{a}) (X : Type@{i}) {Y : Type@{j}} (Xloc : IsLocal@{i i' a} f X) (g : X -> Y) `{IsEquiv@{i j} _ _ g} : IsLocal@{j j' a} f Y. Proof. intros i. (** We have to fiddle with the max universes to get this to work, since [ooextendable_postcompose] requires the max universe in both cases to be the same, whereas we don't want to assume that the hypothesis and conclusion are related in any way. *) apply lift_ooextendablealong@{a a a a a a j j j k j'}. refine (ooextendable_postcompose@{a a i j k k k k k k} _ _ (f i) (fun _ => g) _). apply lift_ooextendablealong@{a a a a a a i i i i' k}. apply Xloc. Defined. (** ** Localization as a HIT *) Module Export LocalizationHIT. Cumulative Private Inductive Localize (f : LocalGenerators@{a}) (X : Type@{i}) : Type@{max(a,i)} := | loc : X -> Localize f X. Arguments loc {f X} x. (** Note that the following axiom actually contains a point-constructor. We could separate out that point-constructor and make it an actual argument of the private inductive type, thereby getting a judgmental computation rule for it. However, since locality is an hprop, there seems little point to this. *) Axiom islocal_localize : forall (f : LocalGenerators@{a}) (X : Type@{i}), IsLocal@{i k a} f (Localize f X). Definition Localize_ind (f : LocalGenerators@{a}) (X : Type@{i}) (P : Localize f X -> Type@{j}) (loc' : forall x, P (loc x)) (islocal' : forall i, ooExtendableAlong_Over@{a a i j k} (f i) (fun _ => Localize@{a i} f X) (fun _ => P) (islocal_localize@{a i k} f X i)) (z : Localize f X) : P z := match z with | loc x => fun _ => loc' x end islocal'. (** We now state the computation rule for [islocal_localize]. Since locality is an hprop, we never actually have any use for it, but the fact that we can state it is a reassuring check that we have defined a meaningful HIT. *) Axiom Localize_ind_islocal_localize_beta : forall (f : LocalGenerators) (X : Type) (P : Localize f X -> Type) (loc' : forall x, P (loc x)) (islocal' : forall i, ooExtendableAlong_Over (f i) (fun _ => Localize f X) (fun _ => P) (islocal_localize f X i)) i n, apD_extendable_eq n (fun _ => Localize f X) (f i) (islocal_localize f X i n) (fun _ => P) (fun _ => Localize_ind f X P loc' islocal') (islocal' i n). End LocalizationHIT. (** Now we prove that localization is a reflective subuniverse. *) Section Localization. Context (f : LocalGenerators). (** The induction principle is an equivalence. *) Definition ext_localize_ind (X : Type) (P : Localize f X -> Type) (Ploc : forall i, ooExtendableAlong_Over (f i) (fun _ => Localize f X) (fun _ => P) (islocal_localize f X i)) : ooExtendableAlong loc P. Proof. intros n; generalize dependent P. simple_induction n n IHn; intros P Ploc. 1:exact tt. split. - intros g. exists (Localize_ind f X P g Ploc). intros x; reflexivity. - intros h k; apply IHn; intros i m. apply ooextendable_over_homotopy. exact (Ploc i). Defined. End Localization. Definition Loc@{a i} (f : LocalGenerators@{a}) : ReflectiveSubuniverse@{i}. Proof. snrefine (Build_ReflectiveSubuniverse (Build_Subuniverse (IsLocal f) _ _) (fun A => Build_PreReflects _ A (Localize f A) _ (@loc f A)) (fun A => Build_Reflects _ _ _ _)). - (** Typeclass inference can find this, but we give it explicitly to prevent extra universes from cropping up. *) intros ? T; unfold IsLocal. nrefine (istrunc_forall@{a i i}); try assumption. intros i. apply ishprop_ooextendable@{a a i i i i i i i i i i i i i i}. - apply islocal_equiv_islocal. - apply islocal_localize. - cbn. intros Q Q_inO. apply ext_localize_ind; intros ?. apply ooextendable_over_const. apply Q_inO. Defined. (** Here is the "real" definition of the notation [IsLocal]. Defining it this way allows it to inherit typeclass inference from [In], unlike (for instance) the slightly annoying case of [IsTrunc n] versus [In (Tr n)]. *) Notation IsLocal f := (In (Loc f)). Section LocalTypes. Context (f : LocalGenerators). (** A remark on universes: recall that [ooExtendableAlong] takes four universe parameters, three for the sizes of the types involved and one for the max of all of them. In the definition of [IsLocal f X] we set that max universe to be the same as the size of [X], so that [In (Loc f) X] would lie in the same universes as [X], which is necessary for our definition of a reflective subuniverse. However, in practice we may need this extendability property with the max universe being larger, to avoid coalescing universes undesiredly. Thus, in making it available by the following name, we also insert a [lift] to generalize the max universe. *) Definition ooextendable_islocal {X : Type@{i}} {Xloc : IsLocal f X} i : ooExtendableAlong@{a a i k} (f i) (fun _ => X) := (lift_ooextendablealong _ _ (Xloc i)). Global Instance islocal_loc (X : Type) : IsLocal f (Localize f X) := islocal_localize f X. Global Instance isequiv_precomp_islocal `{Funext} {X : Type} `{IsLocal f X} i : IsEquiv (fun g => g o f i) := isequiv_ooextendable (fun _ => X) (f i) (ooextendable_islocal i). (** The non-dependent eliminator *) Definition Localize_rec {X Z : Type} `{IsLocal f Z} (g : X -> Z) : Localize f X -> Z. Proof. refine (Localize_ind f X (fun _ => Z) g _); intros i. apply ooextendable_over_const. apply ooextendable_islocal. Defined. Definition local_rec {X} `{IsLocal f X} {i} (g : lgen_domain f i -> X) : lgen_codomain f i -> X := (fst (ooextendable_islocal i 1%nat) g).1. Definition local_rec_beta {X} `{IsLocal f X} {i} (g : lgen_domain f i -> X) s : local_rec g (f i s) = g s := (fst (ooextendable_islocal i 1%nat) g).2 s. Definition local_indpaths {X} `{IsLocal f X} {i} {h k : lgen_codomain f i -> X} (p : h o f i == k o f i) : h == k := (fst (snd (ooextendable_islocal i 2) h k) p).1. Definition local_indpaths_beta {X} `{IsLocal f X} {i} (h k : lgen_codomain f i -> X) (p : h o f i == k o f i) s : local_indpaths p (f i s) = p s := (fst (snd (ooextendable_islocal i 2) h k) p).2 s. End LocalTypes. Arguments local_rec : simpl never. Arguments local_rec_beta : simpl never. Arguments local_indpaths : simpl never. Arguments local_indpaths_beta : simpl never. (** ** Localization and accessibility *) (** Localization subuniverses are accessible, essentially by definition. Without the universe annotations, [a] and [i] get collapsed. *) Global Instance accrsu_loc@{a i} (f : LocalGenerators@{a}) : IsAccRSU@{a i} (Loc@{a i} f). Proof. unshelve econstructor. - exact f. - intros; split; apply idmap. Defined. (** Conversely, if a subuniverse is accessible, then the corresponding localization subuniverse is equivalent to it, and moreover exists at every universe level and satisfies its computation rules judgmentally. This is called [lift_accrsu] but in fact it works equally well to *lower* the universe level, as long as both levels are no smaller than the size [a] of the generators. *) Definition lift_accrsu@{a i j} (O : Subuniverse@{i}) `{IsAccRSU@{a i} O} : ReflectiveSubuniverse@{j} := Loc@{a j} (acc_lgen O). (** The lifted universe agrees with the original one, on any universe contained in both [i] and [j] *) Global Instance O_eq_lift_accrsu@{a i j k} (O : Subuniverse@{i}) `{IsAccRSU@{a i} O} : O_eq@{i j k} O (lift_accrsu@{a i j} O). Proof. (** Anyone stepping through this proof should do [Set Printing Universes]. *) split; intros A A_inO. - intros i. assert (e := fst (inO_iff_islocal O A) A_inO i). apply (lift_ooextendablealong@{a a a a a a i j k i j} (acc_lgen O i) (fun _ => A)). exact e. - apply (inO_iff_islocal O). intros i. pose (e := A_inO i). apply (lift_ooextendablealong@{a a a a a a j i k j i} (acc_lgen O i) (fun _ => A)). exact e. Defined. Definition O_leq_lift_accrsu@{a i1 i2} (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{IsAccRSU@{a i1} O1} `{O_leq@{i1 i2 i2} O1 O2} : O_leq@{i2 i2 i2} (lift_accrsu@{a i1 i2} O1) O2. Proof. intros B B_inO1. apply (inO_leq@{i1 i2 i2} O1 O2). apply (snd (inO_iff_islocal O1 B)). intros i. specialize (B_inO1 i). apply (lift_ooextendablealong@{a a a a a a i2 i1 i2 i2 i1} (acc_lgen O1 i) (fun _ => B)). exact B_inO1. Defined. (** Similarly, because localization is a HIT that has an elimination rule into types in *all* universes, for accessible reflective subuniverses we can show that containment implies connectedness properties with the universe containments in the other order. *) Definition isconnected_O_leq'@{a i1 i2} (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{IsAccRSU@{a i1} O1} (** Compared to [O_leq@{i1 i2 i1}] and [A : Type@{i1}] in [isconnected_O_leq], these two lines are what make [i2 <= i1] instead of vice versa. *) `{O_leq@{i1 i2 i2} O1 O2} (A : Type@{i2}) `{IsConnected O2 A} : IsConnected O1 A. Proof. (** Anyone stepping through this proof should do [Set Printing Universes]. *) srefine (isconnected_O_leq O1 (lift_accrsu@{a i1 i1} O1) A). 1-2:exact _. change (Contr@{i1} (Localize@{a i2} (acc_lgen@{a i1} O1) A)). (** At this point you should also do [Unset Printing Notations] to see the universe annotation on [IsTrunc] change. *) refine (contr_equiv'@{i2 i1} _ 1%equiv). change (IsConnected@{i2} (lift_accrsu@{a i1 i2} O1) A). srapply (isconnected_O_leq _ O2). rapply O_leq_lift_accrsu. Defined. (** And similarly for connected maps. *) Definition conn_map_O_leq'@{a i1 i2} (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{IsAccRSU@{a i1} O1} `{O_leq@{i1 i2 i2} O1 O2} {A B : Type@{i2}} (f : A -> B) `{IsConnMap O2 A B f} : IsConnMap O1 f. Proof. (** Anyone stepping through this proof should do [Set Printing Universes]. *) intros b. apply (isconnected_equiv' O1 (hfiber@{i2 i2} f b)). - srapply equiv_adjointify. 1-2:intros [u p]; exact (u;p). all:intros [u p]; reflexivity. - apply (isconnected_O_leq' O1 O2). apply isconnected_hfiber_conn_map. Defined. (** The same is true for inverted maps, too. *) Definition O_inverts_O_leq'@{a i1 i2} (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{IsAccRSU@{a i1} O1} `{O_leq@{i1 i2 i2} O1 O2} {A B : Type@{i2}} (f : A -> B) `{O_inverts O2 f} : O_inverts O1 f. Proof. assert (oleq := O_leq_lift_accrsu O1 O2). assert (e := O_inverts_O_leq (lift_accrsu@{a i1 i2} O1) O2 f); clear oleq. nrapply (O_inverts_O_leq O1 (lift_accrsu@{a i1 i1} O1) f). 1:exact _. (** It looks like we can say [exact e], but that would collapse the universes [i1] and [i2]. You can check with [Set Printing Universes. Unset Printing Notations.] that [e] and the goal have different universes. So instead we do this: *) refine (@isequiv_homotopic _ _ _ _ e _). apply O_indpaths; intros x; reflexivity. Defined. Coq-HoTT-9.0/theories/Modalities/Meet.v000066400000000000000000000344461474641544500177460ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Extensions HFiber Truncations NullHomotopy Limits.Pullback. Require Import Descent Lex Separated. (** We construct "canonical" binary meets of reflective subuniverses (that is, whose underlying subuniverse is an intersection), without assuming accessibility. In particular, we will show: 1. Given two reflective subuniverses L and O, if [L O X] is [O]-modal, then it is a reflection into the canonical meet. In particular, this is always the case if [L] preserves [O]-modal types; this is Theorem 3.30 of RSS. 1. If L and O are lex modalities satisfying an additional "composability" condition, then the composite functor [L o O] converges to a reflection into the canonical meet after n+2 applications when applied to an n-type for some finite n. The latter gives in particular a synthetic approach to higher sheafification (stack completion). As described at https://ncatlab.org/nlab/show/plus+construction+on+presheaves, for any site C the topos of presheaves on its Grothendieck topology is cohesive and even totally connected, so that its shape and sharp modalities are both lex. Their canonical meet is the topos of sheaves for the given topology, and the composite functor [shape o sharp] is the usual "plus construction" on (higher) presheaves. Thus, we recover synthetically the result that an n-truncated type can be stackified by (n+2) applications of the plus construction. We also refer to [L o O] as a "plus construction" in the general case of reflective subuniverses. *) Section RSUMeet. Context (L O : ReflectiveSubuniverse). (** The canonical meet of two subuniverses is their intersection. *) Definition Meet : Subuniverse. Proof. unshelve econstructor. - intros X; exact (In L X * In O X). - intros ? X; exact _. - intros T U [? ?] f feq; split; apply (inO_equiv_inO _ f). Defined. Global Instance inO_inmeet_l (X : Type) `{im : In Meet X} : In L X := fst im. Global Instance inO_inmeet_r (X : Type) `{im : In Meet X} : In O X := snd im. (** The basic tool in studying its reflectivity is the "plus construction" that applies the two reflectors in sequence. *) Definition Plus (X : Type) := L (O X). Global Instance inO_plus_l (X : Type) : In L (Plus X) := _. (** This is not necessarily a reflector, but it is a well-pointed endofunctor. *) Definition to_plus (X : Type) : X -> Plus X := to L (O X) o to O X. Definition plus_functor {X Y : Type} (f : X -> Y) : Plus X -> Plus Y := O_functor L (O_functor O f). Definition to_plus_natural {X Y : Type} (f : X -> Y) : plus_functor f o to_plus X == to_plus Y o f. Proof. intros x. unfold plus_functor, to_plus. refine (to_O_natural L (O_functor O f) (to O X x) @ _). apply ap. apply to_O_natural. Defined. Definition wellpointed_plus (X : Type) : to_plus (Plus X) == plus_functor (to_plus X). Proof. rapply (@O_indpaths L). intros ox. unfold to_plus, plus_functor; cbn. refine (_ @ (to_O_natural L _ ox)^). apply ap. revert ox; apply O_indpaths; intros x. exact ((to_O_natural O _ x)^). Defined. (** Moreover, it has the desired factorization property of a reflector (though it may not belong to the meet subuniverse itself). *) Definition ooextendable_plus {X Y : Type} `{In Meet Y} : ooExtendableAlong (to_plus X) (fun _ => Y). Proof. apply (ooextendable_compose _ (to O X) (to L (O X))); rapply extendable_to_O. Defined. Definition plus_rec {P Q : Type} `{In Meet Q} (f : P -> Q) : Plus P -> Q := (fst (ooextendable_plus 1%nat) f).1. Definition plus_rec_beta {P Q : Type} `{In Meet Q} (f : P -> Q) (x : P) : plus_rec f (to_plus P x) = f x := (fst (ooextendable_plus 1%nat) f).2 x. Definition plus_indpaths {P Q : Type} `{In Meet Q} (g h : Plus P -> Q) (p : g o to_plus P == h o to_plus P) : g == h := (fst (snd (ooextendable_plus 2%nat) g h) p).1. Definition plus_indpaths_beta {P Q : Type} `{In Meet Q} (g h : Plus P -> Q) (p : g o (to_plus P) == h o (to_plus P)) (x : P) : plus_indpaths g h p (to_plus P x) = p x := (fst (snd (ooextendable_plus 2%nat) g h) p).2 x. (** Moreover, its fixed points, as a pointed endofunctor, are the types in the meet. *) Definition isequiv_plus_inmeet (X : Type) `{In Meet X} : IsEquiv (to_plus X). Proof. apply (@isequiv_compose _ _ (to O X) _ _ (to L (O X))). apply isequiv_to_O_inO. apply (inO_equiv_inO X (to O X)). Defined. Definition inmeet_isequiv_plus (X : Type) `{IsEquiv _ _ (to_plus X)} : In Meet X. Proof. split. - apply (inO_equiv_inO (Plus X) (to_plus X)^-1). - srapply inO_to_O_retract. + exact ((to_plus X)^-1 o (to L (O X))). + intros x; apply (eissect (to_plus X)). Defined. (** It follows that if [Plus X] ever *does* lie in the meet, then it is a reflection. *) Global Instance prereflects_plus_inO (X : Type) `{In O (Plus X)} : PreReflects Meet X. Proof. unshelve econstructor. - exact (Plus X). - split; exact _. - apply to_plus. Defined. Global Instance reflects_plus_inO (X : Type) `{In O (Plus X)} : Reflects Meet X. Proof. constructor; intros; apply ooextendable_plus. Defined. (** Recalling that a type is connected for a reflective subuniverse if and only if its reflector is nullhomotopic, we define a type to be "plus-connected" if its map to plus is nullhomotopic. If the meet is reflective, this coincides with connectedness for that reflective subuniverse. *) Definition PlusConnected (X : Type) := NullHomotopy (to_plus X). Definition plusconnected_equiv {X Y : Type} (f : X <~> Y) : PlusConnected X -> PlusConnected Y. Proof. intros [px e]. exists (plus_functor f px); intros y. refine (_ @ ap (plus_functor f) (e (f^-1 y))). rewrite to_plus_natural. symmetry; apply ap, eisretr. Defined. (** Similarly, we say a map is plus-connected if all of its fibers are. *) Definition PlusConnMap {X Y : Type} (f : X -> Y) := forall y, PlusConnected (hfiber f y). End RSUMeet. (** Let's now assume we are trying to intersect two lex modalities. *) Section LexMeet. Context (L O : Modality) `{Lex L} `{Lex O}. (** The plus construction, being a composite of two lex functors, is also lex. Thus, it preserves path-types. *) Definition plus_path {X : Type} (x y : X) : Plus L O (x = y) <~> (to_plus L O X x = to_plus L O X y). Proof. refine (equiv_path_O L (to O X x) (to O X y) oE _). apply equiv_O_functor. rapply equiv_path_O. Defined. Definition plus_path_to_plus {X : Type} (x y : X) : plus_path x y o to_plus L O (x = y) == @ap _ _ (to_plus L O X) x y. Proof. intros p; unfold plus_path, to_plus, equiv_path_O, equiv_path_OO, path_OO. cbn. rewrite to_O_natural. rewrite O_rec_beta. rewrite (ap_compose (to O X) (to L (O X))). apply ap. apply O_rec_beta. Defined. (** This implies that plus-connected types are closed under path-spaces. *) Definition plusconnected_path {X : Type} (x y : X) (pc : PlusConnected L O X) : PlusConnected L O (x = y). Proof. unfold PlusConnected in *. apply (cancelL_nullhomotopy_equiv _ (plus_path x y)). apply (nullhomotopy_homotopic (fun u => (plus_path_to_plus x y u)^)). apply nullhomotopy_ap; assumption. Defined. (** And hence plus-connected maps are closed under diagonals. *) Definition plusconnmap_diagonal {X Y : Type} (f : X -> Y) : PlusConnMap L O f -> PlusConnMap L O (diagonal f). Proof. intros pc p. refine (plusconnected_equiv L O (hfiber_diagonal f p)^-1 _). apply plusconnected_path, pc. Defined. (** The plus-construction also preserves fibers. *) Definition plus_hfiber {X Y : Type} (f : X -> Y) (y : Y) : Plus L O (hfiber f y) <~> hfiber (plus_functor L O f) (to_plus L O Y y). Proof. refine (equiv_O_functor_hfiber L (O_functor O f) (to O Y y) oE _). apply equiv_O_functor. rapply equiv_O_functor_hfiber. Defined. Definition plus_hfiber_to_plus {X Y : Type} (f : X -> Y) (y : Y) : plus_hfiber f y o to_plus L O (hfiber f y) == functor_hfiber (fun u => (to_plus_natural L O f u)^) y. Proof. intros [x q]; unfold plus_hfiber, to_plus. cbn. rewrite to_O_natural. rewrite O_functor_hfiber_natural. unfold O_functor_hfiber, functor_hfiber, functor_sigma; cbn. rewrite O_rec_beta; cbn. apply ap. unfold to_plus_natural. rewrite !inv_V, ap_pp, concat_p_pp. apply whiskerL. rewrite <- ap_compose. reflexivity. Defined. (** And pullbacks. *) Definition equiv_plus_pullback {A B C : Type} (f : B -> A) (g : C -> A) : Plus L O (Pullback f g) <~> Pullback (plus_functor L O f) (plus_functor L O g). Proof. refine (equiv_O_pullback L (O_functor O f) (O_functor O g) oE _). apply equiv_O_functor. rapply equiv_O_pullback. Defined. (** And diagonals. *) Definition diagonal_plus_functor {A B : Type} (f : A -> B) : diagonal (plus_functor L O f) == equiv_plus_pullback f f o plus_functor L O (diagonal f). Proof. intros x. refine (diagonal_O_functor L (O_functor O f) x @ _). apply (ap (equiv_O_pullback L (O_functor O f) (O_functor O f))). refine (O_functor_homotopy L _ _ (diagonal_O_functor O f) x @ _). unfold plus_functor. exact (O_functor_compose L _ _ x). Defined. (** Recall that a modality is characterized by connectedness of the units. Analogously, we can now prove that the plus-units are all plus-connected. This is equivalently a sort of coherence axiom for the homotopy [wellpointed_plus], that when precomposed with [to_plus] it becomes [to_plus_natural]. *) Definition plusconnmap_to_plus (X : Type) : PlusConnMap L O (to_plus L O X). Proof. intros y; unfold PlusConnected. apply (cancelL_nullhomotopy_equiv _ (plus_hfiber (to_plus L O X) y)). apply (nullhomotopy_homotopic (fun u => (plus_hfiber_to_plus (to_plus L O X) y u)^)). unfold NullHomotopy, hfiber. unshelve refine ((y ; _) ; _). { symmetry; apply wellpointed_plus. } intros [x p]; destruct p. unfold functor_hfiber, functor_sigma; cbn. apply ap. rewrite inv_V, concat_p1. unfold wellpointed_plus. rewrite !O_indpaths_beta. rewrite inv_pp, ap_V, !inv_V. reflexivity. Defined. (** Recall also (from [nsep_iff_trunc_to_O]) that a type is n-separated for a lex modality [O] if and only if its [O]-unit is an n-truncated map. We can now prove the analogous fact for the plus-construction. We state this using [MapIn (Tr n)] instead of [IsTrunc n] because we have more useful lemmas for [MapIn]. *) Definition nsep_iff_trunc_plus (n : trunc_index) (X : Type) : In (nSep n (Meet L O)) X <-> MapIn (Tr n) (to_plus L O X). Proof. revert X; induction n as [|n IHn]; intros X; split; intros H. - apply contr_map_isequiv. rapply isequiv_plus_inmeet. - apply inmeet_isequiv_plus. rapply isequiv_contr_map. - apply istruncmap_from_ap; intros x y. apply istruncmap_mapinO_tr. pose (i := fst (IHn _) (H x y)). apply (mapinO_homotopic _ _ (plus_path_to_plus x y)). - intros x y. apply (snd (IHn (x = y))). pose (i := istruncmap_ap n (to_plus L O X) x y). apply mapinO_tr_istruncmap in i. apply (mapinO_homotopic _ ((plus_path x y)^-1 o (@ap _ _ (to_plus L O X) x y))). { intros p; apply moveR_equiv_V; symmetry; apply plus_path_to_plus. } rapply mapinO_compose. Defined. (** We now make one more assumption, that the plus-construction inverts plus-connected embeddings. In the case of the plus-construction for stacks, this corresponds roughly to the "local character" condition on a Grothendieck topology. *) Context (composing : forall (X Y : Type) (f : X -> Y) (fe : IsEmbedding f) (fc : PlusConnMap L O f), IsEquiv (plus_functor L O f)). (** This implies, by induction, that the plus-construction decreases the truncation-level of any finitely truncated plus-connected map. *) Definition istruncmap_plus_functor {n : trunc_index} {X Y : Type} (f : X -> Y) `{MapIn (Tr n.+1) _ _ f} (pc : PlusConnMap L O f) : MapIn (Tr n) (plus_functor L O f). Proof. generalize dependent f; revert X Y; induction n as [|n IHn]; intros X Y f ? pc. { apply mapinO_tr_istruncmap, contr_map_isequiv, composing; assumption. } pose (O_eq_Tr n). apply (mapinO_O_leq (Sep (Tr n)) _), mapinO_from_diagonal. nrapply (mapinO_homotopic (Tr n) _ (fun u => (diagonal_plus_functor f u)^)). apply mapinO_compose. 2:rapply mapinO_isequiv. apply IHn. - rapply mapinO_diagonal. pose (O_eq_Tr n.+1). rapply (mapinO_O_leq _ (Sep (Tr n.+1))). - apply plusconnmap_diagonal; assumption. Defined. (** It follows, by applying this to the plus-unit and using well-pointedness, that the plus-construction on *types* decreases their plus-separatedness. *) Definition nsep_plus (n : trunc_index) (X : Type) `{In (nSep n.+1 (Meet L O)) X} : In (nSep n (Meet L O)) (Plus L O X). Proof. apply nsep_iff_trunc_plus. nrefine (mapinO_homotopic _ _ (fun u => (wellpointed_plus L O X u)^)). apply mapinO_tr_istruncmap, istruncmap_plus_functor. - apply istruncmap_mapinO_tr, nsep_iff_trunc_plus; assumption. - apply plusconnmap_to_plus. Defined. (** Therefore, if a type starts out as n-plus-separated, then n+2 applications of the plus-construction suffice to make it (-2)-plus-separated, i.e. in the meet subuniverse. Hence it has a reflection. *) Global Instance prereflects_plus_nsep (n : trunc_index) (X : Type) `{In (nSep n (Meet L O)) X} : PreReflects (Meet L O) X. Proof. generalize dependent X; induction n as [|n IHn]; intros X ?. { rapply prereflects_in. } specialize (IHn (Plus L O X) (nsep_plus n X)). unshelve econstructor. - exact (O_reflector (Meet L O) (Plus L O X)). - exact _. - exact (to (Meet L O) (Plus L O X) o to_plus L O X). Defined. Global Instance reflects_plus_nsep (n : trunc_index) (X : Type) `{In (nSep n (Meet L O)) X} : Reflects (Meet L O) X. Proof. generalize dependent X; induction n as [|n IHn]; intros X ?. { rapply reflects_in. } specialize (IHn (Plus L O X) (nsep_plus n X)). constructor; intros. apply (ooextendable_compose _ (to_plus L O X) (to (Meet L O) (Plus L O X))). - apply (@extendable_to_O (Meet L O) (Plus L O X)); assumption. - rapply ooextendable_plus. Defined. End LexMeet. Coq-HoTT-9.0/theories/Modalities/Modality.v000066400000000000000000000655261474641544500206410ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HFiber Extensions Factorization Limits.Pullback. Require Export ReflectiveSubuniverse. (* [Export] because many of the lemmas and facts about reflective subuniverses are equally important for modalities. *) Local Open Scope path_scope. (** * Modalities *) (** ** Dependent eliminators *) (** A dependent version of the reflection universal property. For later use we generalize it to refer to different subuniverses in the reflection and the elimination target. *) Class ReflectsD@{i} (O' O : Subuniverse@{i}) (T : Type@{i}) `{PreReflects@{i} O' T} := { extendable_to_OO : forall (Q : O_reflector O' T -> Type@{i}) {Q_inO : forall x, In O (Q x)}, ooExtendableAlong (to O' T) Q }. (** In particular, from this we get a dependent eliminator. *) Definition OO_ind {O' : Subuniverse} (O : Subuniverse) {A : Type} `{ReflectsD O' O A} (B : O_reflector O' A -> Type) {B_inO : forall oa, In O (B oa)} (f : forall a, B (to O' A a)) (oa : O_reflector O' A) : B oa := (fst (extendable_to_OO B 1%nat) f).1 oa. Definition OO_ind_beta {O' O : Subuniverse} {A : Type} `{ReflectsD O' O A} (B : O_reflector O' A -> Type) {B_inO : forall oa, In O (B oa)} (f : forall a, B (to O' A a)) (a : A) : OO_ind O B f (to O' A a) = f a := (fst (extendable_to_OO B 1%nat) f).2 a. (** Conversely, if [O] is closed under path-types, a dependent eliminator suffices to prove the whole dependent universal property. *) Definition reflectsD_from_OO_ind@{i} {O' O : Subuniverse@{i}} {A : Type@{i}} `{PreReflects O' A} (OO_ind' : forall (B : O_reflector O' A -> Type@{i}) (B_inO : forall oa, In O (B oa)) (f : forall a, B (to O' A a)) oa, B oa) (OO_ind_beta' : forall (B : O_reflector O' A -> Type@{i}) (B_inO : forall oa, In O (B oa)) (f : forall a, B (to O' A a)) a, OO_ind' B B_inO f (to O' A a) = f a) (inO_paths' : forall (B : Type@{i}) (B_inO : In O B) (z z' : B), In O (z = z')) : ReflectsD O' O A. Proof. constructor. intros Q Q_inO n. revert Q Q_inO. simple_induction n n IHn; intros Q Q_inO. 1:exact tt. split. - intros g. exists (OO_ind' Q _ g). rapply OO_ind_beta'. - intros h k. rapply IHn. Defined. (** In particular, this is the case if [O] is a reflective subuniverse. *) Definition reflectsD_from_RSU {O' : Subuniverse} {O : ReflectiveSubuniverse} {A : Type} `{PreReflects O' A} (OO_ind' : forall (B : O_reflector O' A -> Type) (B_inO : forall oa, In O (B oa)) (f : forall a, B (to O' A a)) oa, B oa) (OO_ind_beta' : forall (B : O_reflector O' A -> Type) (B_inO : forall oa, In O (B oa)) (f : forall a, B (to O' A a)) a, OO_ind' B B_inO f (to O' A a) = f a) : ReflectsD O' O A := reflectsD_from_OO_ind OO_ind' OO_ind_beta' _. (** Of course, with funext this becomes an actual equivalence. *) Definition isequiv_oD_to_O {fs : Funext} (O' O : Subuniverse) {A : Type} `{ReflectsD O' O A} (B : O_reflector O' A -> Type) `{forall a, In O (B a)} : IsEquiv (fun (h : forall oa, B oa) => h oD to O' A). Proof. apply isequiv_ooextendable, extendable_to_OO; assumption. Defined. (** ** The strong order *) (** Note the reversal of the order: [O1 << O2] means that [O2] has dependent eliminators into [O1]. *) Class O_strong_leq (O1 O2 : ReflectiveSubuniverse) := reflectsD_strong_leq : forall A, ReflectsD O2 O1 A. Global Existing Instance reflectsD_strong_leq. Infix "<<" := O_strong_leq : subuniverse_scope. Open Scope subuniverse_scope. (** The strong order implies the weak order. *) Global Instance O_leq_strong_leq {O1 O2 : ReflectiveSubuniverse} `{O1 << O2} : O1 <= O2. Proof. intros A A_inO1. srapply inO_to_O_retract. - exact (OO_ind O1 (fun _:O2 A => A) idmap). - intros a. srapply OO_ind_beta. Defined. (** The strong order is not obviously transitive, but it composes with the weak order on one side at least. *) Definition O_strong_leq_trans_l (O1 O2 O3 : ReflectiveSubuniverse) `{O1 <= O2} `{O2 << O3} : O1 << O3. Proof. intros A; constructor; intros B B_inO. apply (extendable_to_OO (O := O2)). intros x. srapply inO_leq; apply B_inO. Defined. (** ** Modalities *) (** A modality is a reflective subuniverse with a dependent universal property with respect to itself. *) Notation IsModality O := (O << O). (** However, it's not clear what the best bundled definition of modality is. The obvious one [{ O : ReflectiveSubuniverse & IsModality O}] has the advantage that bundling a reflective subuniverse into a modality and then unbundling it is definitionally the identity; but it is redundant, since the dependent universal property implies the non-dependent one, and in practice most modalities are constructed directly with a dependent eliminator. Thus, for now at least, we take the following definition, which in RSS is called a "uniquely eliminating modality". *) Record Modality@{i} := Build_Modality' { modality_subuniv : Subuniverse@{i} ; modality_prereflects : forall (T : Type@{i}), PreReflects modality_subuniv T ; modality_reflectsD : forall (T : Type@{i}), ReflectsD modality_subuniv modality_subuniv T ; }. Global Existing Instance modality_reflectsD. (** We don't declare [modality_subuniv] as a coercion or [modality_prereflects] as a global instance, because we want them only to be found by way of the following "unbundling" coercion to reflective subuniverses. *) Definition modality_to_reflective_subuniverse (O : Modality@{i}) : ReflectiveSubuniverse@{i}. Proof. refine (Build_ReflectiveSubuniverse (modality_subuniv O) (modality_prereflects O) _). intros T; constructor. intros Q Q_inO. srapply extendable_to_OO. Defined. Coercion modality_to_reflective_subuniverse : Modality >-> ReflectiveSubuniverse. (** Unfortunately, sometimes [modality_subuniv] pops up anyway. The following hint helps typeclass inference look through it. *) #[export] Hint Extern 0 (In (modality_subuniv _) _) => progress change modality_subuniv with (rsu_subuniv o modality_to_reflective_subuniverse) in * : typeclass_instances. (** Modalities are precisely the reflective subuniverses that are [<<] themselves. *) Global Instance ismodality_modality (O : Modality) : IsModality O. Proof. intros A; exact _. Defined. Definition modality_ismodality (O : ReflectiveSubuniverse) `{IsModality O} : Modality. Proof. rapply Build_Modality'. Defined. (** When combined with [isequiv_oD_to_O], this yields Theorem 7.7.7 in the book. *) Definition isequiv_oD_to_O_modality `{Funext} (O : Modality) {A : Type} (B : O A -> Type) `{forall a, In O (B a)} : IsEquiv (fun (h : forall oa, B oa) => h oD to O A). Proof. srapply (isequiv_oD_to_O O O). Defined. (** Of course, modalities have dependent eliminators. *) Definition O_ind {O : Subuniverse} {A : Type} `{ReflectsD O O A} := @OO_ind O O A _ _. Arguments O_ind {O A _ _} B {B_inO} f oa. Definition O_ind_beta {O : Subuniverse} {A : Type} `{ReflectsD O O A} := @OO_ind_beta O O A _ _. Arguments O_ind_beta {O A _ _} B {B_inO} f a. (** Conversely, as remarked above, we can build a modality from a dependent eliminator as long as we assume the modal types are closed under paths. This is probably the most common way to define a modality, and one might argue that this would be a better definition of the bundled type [Modality]. For now we simply respect that by dignifying it with the unprimed constructor name [Build_Modality]. *) Definition Build_Modality (In' : Type -> Type) (hprop_inO' : Funext -> forall T : Type, IsHProp (In' T)) (inO_equiv_inO' : forall T U : Type, In' T -> forall f : T -> U, IsEquiv f -> In' U) (O_reflector' : Type -> Type) (O_inO' : forall T, In' (O_reflector' T)) (to' : forall T, T -> O_reflector' T) (O_ind' : forall (A : Type) (B : O_reflector' A -> Type) (B_inO : forall oa, In' (B oa)) (f : forall a, B (to' A a)) (z : O_reflector' A), B z) (O_ind_beta' : forall (A : Type) (B : O_reflector' A -> Type) (B_inO : forall oa, In' (B oa)) (f : forall a, B (to' A a)) (a : A), O_ind' A B B_inO f (to' A a) = f a) (inO_paths' : forall (A : Type) (A_inO : In' A) (z z' : A), In' (z = z')) : Modality. Proof. pose (O := Build_Subuniverse In' hprop_inO' inO_equiv_inO'). simple refine (Build_Modality' O _ _); intros T. - exact (Build_PreReflects O T (O_reflector' T) (O_inO' T) (to' T)). - srapply reflectsD_from_OO_ind. + rapply O_ind'. + rapply O_ind_beta'. + rapply inO_paths'. Defined. (** A tactic that extends [strip_reflections] to modalities. It handles non-dependent elimination for reflective subuniverses and dependent elimination for modalities. [strip_truncations] does the same for truncations, but introduces fewer universe variables, so tends to work better when removing truncations. *) Ltac strip_modalities := (** Search for hypotheses of type [O X] for some [O] such that the goal is [O]-local. *) progress repeat match goal with | [ T : _ |- _ ] => revert_opaque T; (** Handle the non-dependent and dependent cases. The last case requires that [O] be a modality. *) refine (@O_rec _ _ _ _ _ _ _) || refine (@O_indpaths _ _ _ _ _ _ _ _ _) || refine (@O_ind _ _ _ _ _ _ _); (** Ensure that we didn't generate more than one subgoal, i.e. that the goal was appropriately local. *) []; intro T end. (** ** Dependent sums *) (** A dependent elimination of a reflective subuniverse [O'] into [O] implies that the sum of a family of [O]-modal types over an [O']-modal type is [O']-modal. More specifically, for a particular such sum it suffices for the [O']-reflection of that sum to dependently eliminate into [O]. *) Global Instance inO_sigma_reflectsD {O' : ReflectiveSubuniverse} {O : Subuniverse} {A : Type} (B : A -> Type) `{!ReflectsD O' O (sig B)} `{In O' A} `{forall a, In O (B a)} : In O' {x:A & B x}. Proof. pose (h := fun x => @O_rec O' ({x:A & B x}) A _ _ _ pr1 x). assert (p := (fun z => O_rec_beta pr1 z) : h o (to O' _) == pr1). pose (g := fun z => (transport B ((p z)^) z.2)). simpl in *. pose (f := OO_ind O (fun x:O' (sig B) => B (h x)) g). pose (q := OO_ind_beta (fun x:O' (sig B) => B (h x)) g). apply inO_to_O_retract with (mu := fun w => (h w; f w)). intros [x1 x2]. simple refine (path_sigma B _ _ _ _); simpl. - apply p. - refine (ap _ (q (x1;x2)) @ _). unfold g; simpl. exact (transport_pV B _ _). Defined. (** Specialized to a modality, this yields the implication (ii) => (i) from Theorem 7.7.4 of the book, and also Corollary 7.7.8, part 2. *) Global Instance inO_sigma (O : Modality) {A:Type} (B : A -> Type) `{In O A} `{forall a, In O (B a)} : In O {x:A & B x} := _. (** This implies that the composite of modal maps is modal. *) Global Instance mapinO_compose {O : Modality} {A B C : Type} (f : A -> B) (g : B -> C) `{MapIn O _ _ f} `{MapIn O _ _ g} : MapIn O (g o f). Proof. intros c. refine (inO_equiv_inO' _ (hfiber_compose f g c)^-1). Defined. (** It also implies Corollary 7.3.10 from the book, generalized to modalities. (Theorem 7.3.9 is true for any reflective subuniverse; we called it [equiv_O_sigma_O].) *) Corollary equiv_sigma_inO_O {O : Modality} {A : Type} `{In O A} (P : A -> Type) : {x:A & O (P x)} <~> O {x:A & P x}. Proof. transitivity (O {x:A & O (P x)}). - rapply equiv_to_O. - apply equiv_O_sigma_O. Defined. (** Conversely, if the sum of a particular family of [O]-modal types over an [O']-reflection is in [O'], then that family admits a dependent eliminator. *) Definition extension_from_inO_sigma {O' : Subuniverse} (O : Subuniverse) {A:Type} `{Reflects O' A} (B: O_reflector O' A -> Type) {inO_sigma : In O' {z:O_reflector O' A & B z}} (g : forall x, B (to O' A x)) : ExtensionAlong (to O' A) B g. Proof. set (Z := sig B) in *. pose (g' := (fun a:A => (to O' A a ; g a)) : A -> Z). pose (f' := O_rec (O := O') g'). pose (eqf := (O_rec_beta g') : f' o to O' A == g'). pose (eqid := O_indpaths (pr1 o f') idmap (fun x => ap@{k i} pr1 (eqf x))). exists (fun z => transport B (eqid z) ((f' z).2)). intros a. unfold eqid. refine (_ @ pr2_path (O_rec_beta g' a)). refine (ap (fun p => transport B p (O_rec g' (to O' A a)).2) _). srapply O_indpaths_beta. Defined. (** And even a full equivalence of spaces of sections. This is stated in CORS Proposition 2.8 (but our version avoids funext by using [ooExtendableAlong], as usual). *) Definition ooextendable_from_inO_sigma {O' : ReflectiveSubuniverse} (O : Subuniverse) {A : Type} (B: O_reflector O' A -> Type) {inO_sigma : In O' {z:O_reflector O' A & B z}} : ooExtendableAlong (to O' A) B. Proof. intros n; generalize dependent A. induction n as [|n IHn]; intros; [ exact tt | cbn ]. refine (extension_from_inO_sigma O B , _). intros h k; nrapply IHn. set (Z := sig B) in *. pose (W := sig (fun a => B a * B a)). nrefine (inO_equiv_inO' (Pullback (A := W) (fun a:O_reflector O' A => (a;(h a,k a))) (fun z:Z => (z.1;(z.2,z.2)))) _). { refine (inO_pullback O' _ _). exact (inO_equiv_inO' _ (equiv_sigprod_pullback B B)^-1). } unfold Pullback. (** The rest is just extracting paths from sigma- and product types and contracting a couple of based path spaces. *) apply equiv_functor_sigma_id; intros z; cbn. refine (_ oE equiv_functor_sigma_id _). 2:intros; symmetry; apply equiv_path_sigma. refine (_ oE equiv_functor_sigma_id (fun z => equiv_functor_sigma_id (fun p => _))). 2:symmetry; apply equiv_path_prod. cbn. make_equiv_contr_basedpaths. Defined. (** Thus, if this holds for all sigma-types, we get the dependent universal property. Making this an [Instance] causes typeclass search to spin. Note the slightly different hypotheses, which mean that we can't just use the previous result: here we need only assume that the [O']-reflection of [A] exists rather than that [O'] is fully reflective, at the cost of assuming that [O] is fully reflective (although actually, closed under path-spaces would suffice). *) Definition reflectsD_from_inO_sigma {O' : Subuniverse} (O : ReflectiveSubuniverse) {A : Type} `{Reflects O' A} (inO_sigma : forall (B: O_reflector O' A -> Type), (forall oa, In O (B oa)) -> In O' {z:O_reflector O' A & B z}) : ReflectsD O' O A. Proof. constructor; intros B B_inO. intros n; generalize dependent A. induction n as [|n IHn]; intros; [ exact tt | cbn ]. refine (extension_from_inO_sigma O B , _). intros h k; rapply IHn. Defined. (** In particular, we get the converse implication (i) => (ii) from Theorem 7.7.4 of the book: a reflective subuniverse closed under sigmas is a modality. *) Definition modality_from_inO_sigma (O : ReflectiveSubuniverse) (H : forall (A:Type) (B:A -> Type) {A_inO : In O A} `{forall a, In O (B a)}, (In O {x:A & B x})) : Modality. Proof. refine (Build_Modality' O _ _). intros; srapply reflectsD_from_inO_sigma. Defined. (** ** Connectedness of the units *) (** Dependent reflection can also be characterized by connectedness of the unit maps. *) Global Instance conn_map_to_O_reflectsD {O' : Subuniverse} (O : ReflectiveSubuniverse) {A : Type} `{ReflectsD O' O A} : IsConnMap O (to O' A). Proof. apply conn_map_from_extension_elim. intros P P_inO f. exact (fst (extendable_to_OO (O := O) P 1%nat) f). Defined. Definition reflectsD_from_conn_map_to_O {O' : Subuniverse} (O : ReflectiveSubuniverse) {A : Type} `{PreReflects O' A} `{IsConnMap O _ _ (to O' A)} : ReflectsD O' O A. Proof. constructor; rapply ooextendable_conn_map_inO. Defined. (** In particular, if [O1 << O2] then every [O2]-unit is [O1]-connected. *) Global Instance conn_map_to_O_strong_leq {O1 O2 : ReflectiveSubuniverse} `{O1 << O2} (A : Type) : IsConnMap O1 (to O2 A) := _. (** Thus, if [O] is a modality, then every [O]-unit is [O]-connected. This is Corollary 7.5.8 in the book. *) Global Instance conn_map_to_O {O : Modality} (A : Type) : IsConnMap O (to O A) := _. (** When [O1 << O2], [O_functor O2] preserves [O1]-connected maps. *) Proposition conn_map_O_functor_strong_leq {O1 O2 : ReflectiveSubuniverse} (leq : O1 << O2) {X Y : Type} (f : X -> Y) `{IsConnMap O1 _ _ f} : IsConnMap O1 (O_functor O2 f). Proof. rapply (cancelR_conn_map _ (to O2 _)). nrapply conn_map_homotopic. 1: symmetry; apply to_O_natural. rapply conn_map_compose. Defined. (** ** Easy modalities *) (** The book uses yet a different definition of modality, which requires an induction principle only into families of the form [fun oa => O (B oa)], and similarly only that path-spaces of types [O A] are "modal" in the sense that the unit is an equivalence. As shown in section 1 of RSS, this is equivalent, roughly since every modal type [A] (in this sense) is equivalent to [O A]. Our definitions are more convenient in formalized applications because in some examples (such as [Trunc] and closed modalities), there is a naturally occurring [O_ind] into all modal types that is not judgmentally equal to the one that can be constructed by passing through [O] and back again. Thus, when we apply general theorems about modalities to a particular modality such as [Trunc], the proofs will reduce definitionally to "the way we would have proved them directly" if we didn't know about general modalities. On the other hand, in other examples (such as [~~] and open modalities) it is easier to construct the latter weaker induction principle. Thus, we now show how to get from that to our definition of modality. *) Section EasyModalities. Universe i. Context (O_reflector : Type@{i} -> Type@{i}) (to : forall (T : Type@{i}), T -> O_reflector T) (O_indO : forall (A : Type@{i}) (B : O_reflector A -> Type@{i}) (f : forall a, O_reflector (B (to A a))) (z : O_reflector A), O_reflector (B z)) (O_indO_beta : forall (A : Type@{i}) (B : O_reflector A -> Type@{i}) (f : forall a, O_reflector (B (to A a))) (a : A), O_indO A B f (to A a) = f a) (inO_pathsO : forall (A : Type@{i}) (z z' : O_reflector A), IsEquiv (to (z = z'))). Local Definition In_easy : Type@{i} -> Type@{i} := fun A => IsEquiv (to A). Local Definition O_ind_easy (A : Type) (B : O_reflector A -> Type) (B_inO : forall oa, In_easy (B oa)) : (forall a, B (to A a)) -> forall oa, B oa. Proof. simpl; intros f oa. pose (H := B_inO oa); unfold In_easy in H. apply ((to (B oa))^-1). apply O_indO. intros a; apply to, f. Defined. Local Definition O_ind_easy_beta (A : Type) (B : O_reflector A -> Type) (B_inO : forall oa, In_easy (B oa)) (f : forall a : A, B (to A a)) (a:A) : O_ind_easy A B B_inO f (to A a) = f a. Proof. unfold O_ind_easy. apply moveR_equiv_V. apply @O_indO_beta with (f := fun x => to _ (f x)). Qed. Local Definition O_inO_easy (A : Type) : In_easy (O_reflector A). Proof. refine (isequiv_adjointify (to (O_reflector A)) (O_indO (O_reflector A) (fun _ => A) idmap) _ _). - intros x; pattern x; apply O_ind_easy. + intros oa; apply inO_pathsO. + intros a; apply ap. exact (O_indO_beta (O_reflector A) (fun _ => A) idmap a). - intros a. exact (O_indO_beta (O_reflector A) (fun _ => A) idmap a). Defined. (** It seems to be surprisingly hard to show repleteness (without univalence). We basically have to manually develop enough functoriality of [O] and naturality of [to O]. *) Local Definition inO_equiv_inO_easy (A B : Type) (A_inO : In_easy A) (f : A -> B) (feq : IsEquiv f) : In_easy B. Proof. simple refine (isequiv_commsq (to A) (to B) f (O_ind_easy A (fun _ => O_reflector B) _ (fun a => to B (f a))) _). - intros; apply O_inO_easy. - intros a; refine (O_ind_easy_beta A (fun _ => O_reflector B) _ _ a). - apply A_inO. - simple refine (isequiv_adjointify _ (O_ind_easy B (fun _ => O_reflector A) _ (fun b => to A (f^-1 b))) _ _); intros x. + apply O_inO_easy. + pattern x; refine (O_ind_easy B _ _ _ x); intros. * apply inO_pathsO. * simpl; abstract (repeat rewrite O_ind_easy_beta; apply ap, eisretr). + pattern x; refine (O_ind_easy A _ _ _ x); intros. * apply inO_pathsO. * simpl; abstract (repeat rewrite O_ind_easy_beta; apply ap, eissect). Defined. Local Definition inO_paths_easy (A : Type) (A_inO : In_easy A) (a a' : A) : In_easy (a = a'). Proof. simple refine (inO_equiv_inO_easy (to A a = to A a') _ _ (@ap _ _ (to A) a a')^-1 _). - apply inO_pathsO. - refine (@isequiv_ap _ _ _ A_inO _ _). - apply isequiv_inverse. Defined. Definition easy_modality : Modality := Build_Modality In_easy _ inO_equiv_inO_easy O_reflector O_inO_easy to O_ind_easy O_ind_easy_beta inO_paths_easy. End EasyModalities. (** ** The modal factorization system *) Section ModalFact. Context `{fs : Funext} (O : Modality). (** Lemma 7.6.4 *) Definition image {A B : Type} (f : A -> B) : Factorization (@IsConnMap O) (@MapIn O) f. Proof. pose mapinO_pr1. (** Slightly speeds up next line. *) refine (Build_Factorization {b : B & O (hfiber f b)} (fun a => (f a ; to O _ (a;1))) pr1 (fun a => 1) _ _). pose conn_map_functor_sigma. (** Slightly speeds up next line. *) exact (conn_map_compose O (equiv_fibration_replacement f) (functor_sigma idmap (fun b => to O (hfiber f b)))). Defined. Global Instance conn_map_factor1_image {A B : Type} (f : A -> B) : IsConnMap O (factor1 (image f)) := inclass1 (image f). Global Instance inO_map_factor1_image {A B : Type} (f : A -> B) : MapIn O (factor2 (image f)) := inclass2 (image f). (** This is the composite of the three displayed equivalences at the beginning of the proof of Lemma 7.6.5. Note that it involves only a single factorization of [f]. *) Lemma O_hfiber_O_fact {A B : Type} {f : A -> B} (fact : Factorization (@IsConnMap O) (@MapIn O) f) (b : B) : O (hfiber (factor2 fact o factor1 fact) b) <~> hfiber (factor2 fact) b. Proof. refine (_ oE (equiv_O_functor O (hfiber_compose (factor1 fact) (factor2 fact) b))). nrefine (equiv_sigma_contr (fun w => O (hfiber (factor1 fact) w.1)) oE _). - intros w; exact (inclass1 fact w.1). - nrefine ((equiv_sigma_inO_O (fun w => hfiber (factor1 fact) w.1))^-1)%equiv. exact (inclass2 fact b). Defined. (** This is the corresponding first three of the displayed "mapsto"s in proof of Lemma 7.6.5, and also the last three in reverse order, generalized to an arbitrary path [p]. Note that it is much harder to prove than in the book, because we are working in the extra generality of a modality where [O_ind_beta] is only propositional. *) Lemma O_hfiber_O_fact_inverse_beta {A B : Type} {f : A -> B} (fact : Factorization (@IsConnMap O) (@MapIn O) f) (a : A) (b : B) (p : factor2 fact (factor1 fact a) = b) : (O_hfiber_O_fact fact b)^-1 (factor1 fact a ; p) = to O _ (a ; p). Proof. set (g := factor1 fact); set (h := factor2 fact). apply moveR_equiv_V. unfold O_hfiber_O_fact. ev_equiv. apply moveL_equiv_M. transitivity (exist (fun (w : hfiber h b) => O (hfiber g w.1)) (g a; p) (to O (hfiber g (g a)) (a ; 1))). - apply moveR_equiv_V; reflexivity. - apply moveL_equiv_V. transitivity (to O _ (exist (fun (w : hfiber h b) => (hfiber g w.1)) (g a; p) (a ; 1))). + cbn; repeat rewrite O_rec_beta; reflexivity. + destruct p; symmetry; apply to_O_natural. Qed. Section TwoFactorizations. Context {A B : Type} (f : A -> B) (fact fact' : Factorization (@IsConnMap O) (@MapIn O) f). Let H := fun x => fact_factors fact x @ (fact_factors fact' x)^. (** Lemma 7.6.5, part 1. *) Definition equiv_O_factor_hfibers (b:B) : hfiber (factor2 fact) b <~> hfiber (factor2 fact') b. Proof. refine (O_hfiber_O_fact fact' b oE _). refine (_ oE (O_hfiber_O_fact fact b)^-1). apply equiv_O_functor. apply equiv_hfiber_homotopic. exact H. Defined. (** Lemma 7.6.5, part 2. *) Definition equiv_O_factor_hfibers_beta (a : A) : equiv_O_factor_hfibers (factor2 fact (factor1 fact a)) (factor1 fact a ; 1) = (factor1 fact' a ; (H a)^). Proof. unfold equiv_O_factor_hfibers. ev_equiv. apply moveR_equiv_M. do 2 rewrite O_hfiber_O_fact_inverse_beta. unfold equiv_fun, equiv_O_functor. transitivity (to O _ (equiv_hfiber_homotopic (factor2 fact o factor1 fact) (factor2 fact' o factor1 fact') H (factor2 fact (factor1 fact a)) (a;1))). - refine (to_O_natural O _ _). - apply ap. simpl. apply ap; auto with path_hints. Qed. End TwoFactorizations. (** Theorem 7.6.6. Recall that a lot of hard work was done in [Factorization.path_factorization]. *) Definition O_factsys : FactorizationSystem. Proof. refine (Build_FactorizationSystem (@IsConnMap O) _ _ _ (@MapIn O) _ _ _ (@image) _). intros A B f fact fact'. simple refine (Build_PathFactorization fact fact' _ _ _ _). - refine (_ oE equiv_fibration_replacement (factor2 fact)). refine ((equiv_fibration_replacement (factor2 fact'))^-1 oE _). apply equiv_functor_sigma_id; intros b; simpl. apply equiv_O_factor_hfibers. - intros a; exact (pr1_path (equiv_O_factor_hfibers_beta f fact fact' a)). - intros x. exact ((equiv_O_factor_hfibers f fact fact' (factor2 fact x) (x ; 1)).2 ^). - intros a. apply moveR_pM. refine ((inv_V _)^ @ _ @ inv_V _); apply inverse2. refine (_ @ pr2_path (equiv_O_factor_hfibers_beta f fact fact' a)). refine (_ @ (transport_paths_Fl _ _)^). exact (inv_pp _ _ @ (1 @@ inv_V _)). Defined. End ModalFact. Coq-HoTT-9.0/theories/Modalities/Notnot.v000066400000000000000000000021761474641544500203300ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types Universes.HProp. Require Import Modality. Local Open Scope path_scope. (** * The double negation modality *) (** The operation sending [X] to [~~X] is a modality. This is Exercise 7.12 in the book. Note that it is (apparently) *not* accessible unless we assume propositional resizing. *) Definition NotNot `{Funext} : Modality. Proof. snrapply easy_modality. - intros X; exact (~~X). - exact @not_not_unit. - cbn beta; intros A B f z nBz. apply z; intros a. exact (f a (transport (fun x => ~ (B x)) (path_ishprop _ _) nBz)). - cbn beta; intros A B f a. apply path_ishprop. - cbn beta; intros A z z'. refine (isequiv_iff_hprop _ _). intros; apply path_ishprop. Defined. (** By definition, the local types for this modality are the types such that [not_not_unit : P -> ~~P] is an equivalence. These are exactly the stable propositions, i.e. those propositions [P] such that [~~P -> P]. *) Definition inO_notnot `{Funext} (P : Type) : In NotNot P <~> (Stable P * IsHProp P) := equiv_isequiv_not_not_unit_stable_hprop P. Coq-HoTT-9.0/theories/Modalities/Nullification.v000066400000000000000000000066271474641544500216540ustar00rootroot00000000000000(** * Nullification *) Require Import HoTT.Basics HoTT.Types. Require Import Extensions. Require Import Modality Accessible. Require Export Modalities.Localization. (** Nullification is a special case of localization *) Local Open Scope path_scope. (** Nullification is the special case of localization where the codomains of the generating maps are all [Unit]. In this case, we get a modality and not just a reflective subuniverse. *) (** The hypotheses of this lemma may look slightly odd (why are we bothering to talk about type families dependent over [Unit]?), but they seem to be the most convenient to make the induction go through. *) Definition extendable_over_unit (n : nat) (A : Type@{a}) (C : Unit -> Type@{i}) (D : forall u, C u -> Type@{j}) (ext : ExtendableAlong@{a a i k} n (const_tt A) C) (ext' : forall (c : forall u, C u), ExtendableAlong@{a a j k} n (const_tt A) (fun u => (D u (c u)))) : ExtendableAlong_Over@{a a i j k} n (const_tt A) C D ext. Proof. generalize dependent C; simple_induction n n IH; intros C D ext ext'; [exact tt | split]. - intros g g'. exists ((fst (ext' (fst ext g).1) (fun a => ((fst ext g).2 a)^ # (g' a))).1); intros a; simpl. apply moveR_transport_p. exact ((fst (ext' (fst ext g).1) (fun a => ((fst ext g).2 a)^ # (g' a))).2 a). - intros h k h' k'. apply IH; intros g. exact (snd (ext' k) (fun u => g u # h' u) k'). Defined. Definition ooextendable_over_unit@{i j k l m} (A : Type@{i}) (C : Unit -> Type@{j}) (D : forall u, C u -> Type@{k}) (ext : ooExtendableAlong@{l l j m} (const_tt A) C) (ext' : forall (c : forall u, C u), ooExtendableAlong (const_tt A) (fun u => (D u (c u)))) : ooExtendableAlong_Over (const_tt A) C D ext := fun n => extendable_over_unit n A C D (ext n) (fun c => ext' c n). #[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances. Definition Nul@{a i} (S : NullGenerators@{a}) : Modality@{i}. Proof. (** We use the localization reflective subuniverses for most of the necessary data. *) simple refine (Build_Modality' (Loc (null_to_local_generators S)) _ _). - exact _. - intros A. (** We take care with universes. *) snrefine (reflectsD_from_OO_ind@{i} _ _ _). + intros B B_inO g. refine (Localize_ind@{a i i i} (null_to_local_generators S) A B g _); intros i. apply ooextendable_over_unit; intros c. refine (ooextendable_postcompose@{a a i i i i i i i i} (fun (_:Unit) => B (c tt)) _ _ (fun u => transport B (ap@{Set _} c (path_unit tt u))) _). refine (ooextendable_islocal _ i). + reflexivity. + apply inO_paths@{i i}. Defined. (** And here is the "real" definition of the notation [IsNull]. *) Notation IsNull f := (In (Nul f)). (** ** Nullification and Accessibility *) (** Nullification modalities are accessible, essentially by definition. *) Global Instance accmodality_nul (S : NullGenerators) : IsAccModality (Nul S). Proof. unshelve econstructor. - exact S. - intros; reflexivity. Defined. (** And accessible modalities can be lifted to other universes. *) Definition lift_accmodality@{a i j} (O : Subuniverse@{i}) `{IsAccModality@{a i} O} : Modality@{j} := Nul@{a j} (acc_ngen O). Global Instance O_eq_lift_accmodality (O : Subuniverse@{i}) `{IsAccModality@{a i} O} : O <=> lift_accmodality O. Proof. split; intros A; apply inO_iff_isnull. Defined. Coq-HoTT-9.0/theories/Modalities/Open.v000066400000000000000000000053171474641544500177500ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Extensions. Require Import Modality Accessible Nullification Lex. Local Open Scope path_scope. (** * Open modalities *) (** ** Definition *) Definition Op `{Funext} (U : HProp) : Modality. Proof. snrapply easy_modality. - intros X; exact (U -> X). - intros T x; cbn. exact (fun _ => x). - cbn; intros A B f z u. refine (transport B _ (f (z u) u)). apply path_arrow; intros u'. apply ap; apply path_ishprop. - cbn; intros A B f a. apply path_arrow; intros u. transitivity (transport B 1 (f a u)); auto with path_hints. apply (ap (fun p => transport B p (f a u))). transitivity (path_arrow (fun _ => a) (fun _ => a) (@ap10 U _ _ _ 1)); auto with path_hints. * apply ap. apply path_forall; intros u'. apply ap_const. * apply eta_path_arrow. - intros A z z'. srefine (isequiv_adjointify _ _ _ _). * intros f; apply path_arrow; intros u. exact (ap10 (f u) u). * intros f; apply path_arrow; intros u. transitivity (path_arrow z z' (ap10 (f u))). + unfold to; apply ap. apply path_forall; intros u'. apply (ap (fun u0 => ap10 (f u0) u')). apply path_ishprop. + apply eta_path_arrow. * intros p. refine (eta_path_arrow _ _ _). Defined. (** ** The open modality is lex *) (** Note that unlike most other cases, we can prove this without univalence (though we do of course need funext). *) Global Instance lex_open `{Funext} (U : HProp) : Lex (Op U). Proof. apply lex_from_isconnected_paths. intros A Ac x y. nrapply contr_forall. intro u. pose (contr_inhabited_hprop U u). rapply contr_paths_contr. refine (contr_equiv (U -> A) (equiv_contr_forall _)). exact Ac. Defined. (** ** The open modality is accessible. *) Global Instance acc_open `{Funext} (U : HProp) : IsAccModality (Op U). Proof. unshelve econstructor. - econstructor. exact (unit_name U). - intros X; split. + intros X_inO u. apply (equiv_inverse (equiv_ooextendable_isequiv _ _)). refine (cancelR_isequiv (fun x (u:Unit) => x)). apply X_inO. + intros ext; specialize (ext tt). refine (isequiv_compose (f := (fun x => unit_name x)) (g := (fun h => h o const_tt U))). refine (isequiv_ooextendable (fun _ => X) (const_tt U) ext). Defined. (** Thus, arguably a better definition of [Op] would be as a nullification modality, as it would not require [Funext] and would have a judgmental computation rule. However, the above definition is also nice to know, as it doesn't use HITs. We name the other version [Op']. *) Definition Op' (U : HProp) : Modality := Nul (Build_NullGenerators Unit (fun _ => U)). Coq-HoTT-9.0/theories/Modalities/ReflectiveSubuniverse.v000066400000000000000000002457661474641544500234100ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Equiv.BiInv Extensions HProp HFiber NullHomotopy Limits.Pullback. Require Import Homotopy.IdentitySystems. Require Import Colimits.Pushout. Local Open Scope nat_scope. Local Open Scope path_scope. (** * Reflective Subuniverses *) (** ** References *) (** Reflective subuniverses (and modalities) are studied in the following papers, which we will refer to below by their abbreviations: - The Book: The Homotopy Type Theory Book, chapter 7. Bare references to "Theorem 7.x.x" are always to the Book. - RSS: Rijke, Spitters, and Shulman, "Modalities in homotopy type theory", https://arxiv.org/abs/1706.07526. - CORS: Christensen, Opie, Rijke, and Scoccola, "Localization in Homotopy Type Theory", https://arxiv.org/abs/1807.04155. *) (** ** Definitions *) (** *** Subuniverses *) Record Subuniverse@{i} := { In_internal : Type@{i} -> Type@{i} ; hprop_inO_internal : Funext -> forall (T : Type@{i}), IsHProp (In_internal T) ; inO_equiv_inO_internal : forall (T U : Type@{i}) (T_inO : In_internal T) (f : T -> U) {feq : IsEquiv f}, In_internal U ; }. (** Work around Coq bug that fields of records can't be typeclasses. *) Class In (O : Subuniverse) (T : Type) := in_internal : In_internal O T. (** Being in the subuniverse is a mere predicate (by hypothesis). We include funext in the hypotheses of hprop_inO so that it doesn't have to be assumed in all definitions of (reflective) subuniverses, since in most examples it is required for this and this only. Here we redefine it using the replaced [In]. *) Global Instance hprop_inO `{Funext} (O : Subuniverse) (T : Type) : IsHProp (In O T) := @hprop_inO_internal _ _ T. (** We assumed repleteness of the subuniverse in the definition. Of course, with univalence this would be automatic, but we include it as a hypothesis since most of the theory of reflective subuniverses and modalities doesn't need univalence, and most or all examples can be shown to be replete without using univalence. Here we redefine it using the replaced [In]. *) Definition inO_equiv_inO {O : Subuniverse} (T : Type) {U : Type} `{T_inO : In O T} (f : T -> U) `{IsEquiv T U f} : In O U := @inO_equiv_inO_internal O T U T_inO f _. Definition inO_equiv_inO' {O : Subuniverse} (T : Type) {U : Type} `{In O T} (f : T <~> U) : In O U := inO_equiv_inO T f. Definition iff_inO_equiv (O : Subuniverse) {T : Type} {U : Type} (f : T <~> U) : In O T <-> In O U := (fun H => inO_equiv_inO' _ f, fun H => inO_equiv_inO' _ f^-1). Definition equiv_inO_equiv `{Funext} (O : Subuniverse) {T : Type} {U : Type} (f : T <~> U) : In O T <~> In O U := equiv_iff_hprop_uncurried (iff_inO_equiv _ f). (** The universe of types in the subuniverse *) Definition Type_@{i j} (O : Subuniverse@{i}) : Type@{j} := @sig@{j i} Type@{i} (fun (T : Type@{i}) => In O T). Coercion TypeO_pr1 O (T : Type_ O) := @pr1 Type (In O) T. (** The second component of [TypeO] is unique. *) Definition path_TypeO@{i j} {fs : Funext} O (T T' : Type_@{i j} O) (p : T.1 = T'.1) : T = T' := path_sigma_hprop@{j i j} T T' p. Definition equiv_path_TypeO@{i j} {fs : Funext} O (T T' : Type_@{i j} O) : (paths@{j} T.1 T'.1) <~> (T = T') := equiv_path_sigma_hprop@{j i j} T T'. (** Types in [TypeO] are always in [O]. *) Global Instance inO_TypeO {O : Subuniverse} (A : Type_ O) : In O A := A.2. (** ** Properties of Subuniverses *) (** A map is O-local if all its fibers are. *) Class MapIn (O : Subuniverse) {A B : Type} (f : A -> B) := inO_hfiber_ino_map : forall (b:B), In O (hfiber f b). Global Existing Instance inO_hfiber_ino_map. Section Subuniverse. Context (O : Subuniverse). (** Being a local map is an hprop *) Global Instance ishprop_mapinO `{Funext} {A B : Type} (f : A -> B) : IsHProp (MapIn O f). Proof. apply istrunc_forall. Defined. (** Anything homotopic to a local map is local. *) Definition mapinO_homotopic {A B : Type} (f : A -> B) {g : A -> B} (p : f == g) `{MapIn O _ _ f} : MapIn O g. Proof. intros b. exact (inO_equiv_inO (hfiber f b) (equiv_hfiber_homotopic f g p b)). Defined. (** The projection from a family of local types is local. *) Global Instance mapinO_pr1 {A : Type} {B : A -> Type} `{forall a, In O (B a)} : MapIn O (@pr1 A B). Proof. intros a. exact (inO_equiv_inO (B a) (hfiber_fibration a B)). Defined. (** A family of types is local if and only if the associated projection map is local. *) Lemma iff_forall_inO_mapinO_pr1 {A : Type} (B : A -> Type) : (forall a, In O (B a)) <-> MapIn O (@pr1 A B). Proof. split. - exact _. (* Uses the instance mapinO_pr1 above. *) - rapply functor_forall; intros a x. exact (inO_equiv_inO (hfiber pr1 a) (hfiber_fibration a B)^-1%equiv). Defined. Lemma equiv_forall_inO_mapinO_pr1 `{Funext} {A : Type} (B : A -> Type) : (forall a, In O (B a)) <~> MapIn O (@pr1 A B). Proof. exact (equiv_iff_hprop_uncurried (iff_forall_inO_mapinO_pr1 B)). Defined. End Subuniverse. (** *** Reflections *) (** A pre-reflection is a map to a type in the subuniverse. *) Class PreReflects@{i} (O : Subuniverse@{i}) (T : Type@{i}) := { O_reflector : Type@{i} ; O_inO : In O O_reflector ; to : T -> O_reflector ; }. Arguments O_reflector O T {_}. Arguments to O T {_}. Arguments O_inO {O} T {_}. Global Existing Instance O_inO. (** It is a reflection if it has the requisite universal property. *) Class Reflects@{i} (O : Subuniverse@{i}) (T : Type@{i}) `{PreReflects@{i} O T} := { extendable_to_O : forall {Q : Type@{i}} {Q_inO : In O Q}, ooExtendableAlong (to O T) (fun _ => Q) }. Arguments extendable_to_O O {T _ _ Q Q_inO}. (** Here's a modified version that applies to types in possibly-smaller universes without collapsing those universes to [i]. *) Definition extendable_to_O'@{i j k | j <= i, k <= i} (O : Subuniverse@{i}) (T : Type@{j}) `{Reflects O T} {Q : Type@{k}} {Q_inO : In O Q} : ooExtendableAlong (to O T) (fun _ => Q). Proof. apply lift_ooextendablealong. rapply extendable_to_O. Defined. (** In particular, every type in the subuniverse automatically reflects into it. *) Definition prereflects_in (O : Subuniverse) (T : Type) `{In O T} : PreReflects O T. Proof. unshelve econstructor. - exact T. - assumption. - exact idmap. Defined. Definition reflects_in (O : Subuniverse) (T : Type) `{In O T} : @Reflects O T (prereflects_in O T). Proof. constructor; intros; rapply ooextendable_equiv. Defined. (** A reflective subuniverse is one for which every type reflects into it. *) Record ReflectiveSubuniverse@{i} := { rsu_subuniv : Subuniverse@{i} ; rsu_prereflects : forall (T : Type@{i}), PreReflects rsu_subuniv T ; rsu_reflects : forall (T : Type@{i}), Reflects rsu_subuniv T ; }. Coercion rsu_subuniv : ReflectiveSubuniverse >-> Subuniverse. Global Existing Instance rsu_prereflects. Global Existing Instance rsu_reflects. (** We allow the name of a subuniverse or modality to be used as the name of its reflector. This means that when defining a particular example, you should generally put the parametrizing family in a wrapper, so that you can notate the subuniverse as parametrized by, rather than identical to, its parameter. See Modality.v, Truncations.v, and Localization.v for examples. *) Definition rsu_reflector (O : ReflectiveSubuniverse) (T : Type) : Type := O_reflector O T. Coercion rsu_reflector : ReflectiveSubuniverse >-> Funclass. (** *** Recursion principles *) (** We now extract the recursion principle and the restricted induction principles for paths. *) Section ORecursion. Context {O : Subuniverse} {P Q : Type} {Q_inO : In O Q} `{Reflects O P}. Definition O_rec (f : P -> Q) : O_reflector O P -> Q := (fst (extendable_to_O O 1%nat) f).1. Definition O_rec_beta (f : P -> Q) (x : P) : O_rec f (to O P x) = f x := (fst (extendable_to_O O 1%nat) f).2 x. Definition O_indpaths (g h : O_reflector O P -> Q) (p : g o to O P == h o to O P) : g == h := (fst (snd (extendable_to_O O 2) g h) p).1. Definition O_indpaths_beta (g h : O_reflector O P -> Q) (p : g o (to O P) == h o (to O P)) (x : P) : O_indpaths g h p (to O P x) = p x := (fst (snd (extendable_to_O O 2) g h) p).2 x. Definition O_ind2paths {g h : O_reflector O P -> Q} (p q : g == h) (r : p oD (to O P) == q oD (to O P)) : p == q := (fst (snd (snd (extendable_to_O O 3) g h) p q) r).1. Definition O_ind2paths_beta {g h : O_reflector O P -> Q} (p q : g == h) (r : p oD (to O P) == q oD (to O P)) (x : P) : O_ind2paths p q r (to O P x) = r x := (fst (snd (snd (extendable_to_O O 3) g h) p q) r).2 x. (** Clearly we can continue indefinitely as needed. *) End ORecursion. (* We never want to see [extendable_to_O]. The [!x] allows [cbn] to unfold these when passed a constructor, such as [tr x]. This, for example, means that [O_rec (O:=Tr n) f (tr x)] will compute to [f x] and [Trunc_functor n f (tr x)] will compute to [tr (f x)]. *) Arguments O_rec {O} {P Q}%_type_scope {Q_inO H H0} f%_function_scope !x. Arguments O_rec_beta {O} {P Q}%_type_scope {Q_inO H H0} f%_function_scope !x. Arguments O_indpaths {O} {P Q}%_type_scope {Q_inO H H0} (g h)%_function_scope p !x. Arguments O_indpaths_beta {O} {P Q}%_type_scope {Q_inO H H0} (g h)%_function_scope p !x. Arguments O_ind2paths {O} {P Q}%_type_scope {Q_inO H H0} {g h}%_function_scope p q r !x. Arguments O_ind2paths_beta {O} {P Q}%_type_scope {Q_inO H H0} {g h}%_function_scope p q r !x. (** A tactic that generalizes [strip_truncations] to reflective subuniverses. [strip_truncations] introduces fewer universe variables, so tends to work better when removing truncations. [strip_modalities] in Modality.v also applies dependent elimination when [O] is a modality. *) Ltac strip_reflections := (** Search for hypotheses of type [O X] for some [O] such that the goal is [O]-local. *) progress repeat match goal with | [ T : _ |- _ ] => revert_opaque T; refine (@O_rec _ _ _ _ _ _ _) || refine (@O_indpaths _ _ _ _ _ _ _ _ _); (** Ensure that we didn't generate more than one subgoal, i.e. that the goal was appropriately local. *) []; intro T end. (** Given [Funext], we prove the definition of reflective subuniverse in the book. *) Global Instance isequiv_o_to_O `{Funext} (O : ReflectiveSubuniverse) (P Q : Type) `{In O Q} : IsEquiv (fun g : O P -> Q => g o to O P) := isequiv_ooextendable _ _ (extendable_to_O O). Definition equiv_o_to_O `{Funext} (O : ReflectiveSubuniverse) (P Q : Type) `{In O Q} : (O P -> Q) <~> (P -> Q) := Build_Equiv _ _ (fun g : O P -> Q => g o to O P) _. (** [isequiv_ooextendable] is defined in a way that makes [O_rec] definitionally equal to the inverse of [equiv_o_to_O]. *) Global Instance isequiv_O_rec_to_O `{Funext} (O : ReflectiveSubuniverse) (P Q : Type) `{In O Q} : IsEquiv (fun g : P -> Q => O_rec g) := (equiv_isequiv (equiv_o_to_O O P Q)^-1). (** ** Properties of Reflective Subuniverses *) (** We now prove a bunch of things about an arbitrary reflective subuniverse. *) Section Reflective_Subuniverse. Context (O : ReflectiveSubuniverse). (** Functoriality of [O_rec] homotopies *) Definition O_rec_homotopy {P Q : Type} `{In O Q} (f g : P -> Q) (pi : f == g) : O_rec (O := O) f == O_rec g. Proof. apply O_indpaths; intro x. etransitivity. { apply O_rec_beta. } { etransitivity. { exact (pi _). } { symmetry; apply O_rec_beta. } } Defined. (** If [T] is in the subuniverse, then [to O T] is an equivalence. *) Global Instance isequiv_to_O_inO (T : Type) `{In O T} : IsEquiv (to O T). Proof. pose (g := O_rec idmap : O T -> T). refine (isequiv_adjointify (to O T) g _ _). - refine (O_indpaths (to O T o g) idmap _). intros x. apply ap. apply O_rec_beta. - intros x. apply O_rec_beta. Defined. Definition equiv_to_O (T : Type) `{In O T} : T <~> O T := Build_Equiv T (O T) (to O T) _. Section Functor. (** In this section, we see that [O] is a functor. *) Definition O_functor {A B : Type} (f : A -> B) : O A -> O B := O_rec (to O B o f). (** Naturality of [to O] *) Definition to_O_natural {A B : Type} (f : A -> B) : (O_functor f) o (to O A) == (to O B) o f := (O_rec_beta _). (** Functoriality on composition *) Definition O_functor_compose {A B C : Type} (f : A -> B) (g : B -> C) : (O_functor (g o f)) == (O_functor g) o (O_functor f). Proof. srapply O_indpaths; intros x. refine (to_O_natural (g o f) x @ _). transitivity (O_functor g (to O B (f x))). - symmetry. exact (to_O_natural g (f x)). - apply ap; symmetry. exact (to_O_natural f x). Defined. (** Functoriality on homotopies (2-functoriality) *) Definition O_functor_homotopy {A B : Type} (f g : A -> B) (pi : f == g) : O_functor f == O_functor g. Proof. refine (O_indpaths _ _ _); intros x. refine (to_O_natural f x @ _). refine (_ @ (to_O_natural g x)^). apply ap, pi. Defined. (** Functoriality for inverses of homotopies *) Definition O_functor_homotopy_V {A B : Type} (f g : A -> B) (pi : f == g) : O_functor_homotopy g f (fun x => (pi x)^) == fun x => (O_functor_homotopy f g pi x)^. Proof. refine (O_ind2paths _ _ _); intros x. unfold composeD, O_functor_homotopy. rewrite !O_indpaths_beta, !ap_V, !inv_pp, inv_V, !concat_p_pp. reflexivity. Qed. (** Hence functoriality on commutative squares *) Definition O_functor_square {A B C X : Type} (pi1 : X -> A) (pi2 : X -> B) (f : A -> C) (g : B -> C) (comm : (f o pi1) == (g o pi2)) : ( (O_functor f) o (O_functor pi1) ) == ( (O_functor g) o (O_functor pi2) ). Proof. intros x. transitivity (O_functor (f o pi1) x). - symmetry; rapply O_functor_compose. - transitivity (O_functor (g o pi2) x). * apply O_functor_homotopy, comm. * rapply O_functor_compose. Defined. (** Functoriality on identities *) Definition O_functor_idmap (A : Type) : @O_functor A A idmap == idmap. Proof. refine (O_indpaths _ _ _); intros x. apply O_rec_beta. Defined. (** 3-functoriality, as an example use of [O_ind2paths] *) Definition O_functor_2homotopy {A B : Type} {f g : A -> B} (p q : f == g) (r : p == q) : O_functor_homotopy f g p == O_functor_homotopy f g q. Proof. refine (O_ind2paths _ _ _); intros x. unfold O_functor_homotopy, composeD. do 2 rewrite O_indpaths_beta. apply whiskerL, whiskerR, ap, r. (** Of course, if we wanted to prove 4-functoriality, we'd need to make this transparent. *) Qed. (** 2-naturality: Functoriality on homotopies is also natural *) Definition O_functor_homotopy_beta {A B : Type} (f g : A -> B) (pi : f == g) (x : A) : O_functor_homotopy f g pi (to O A x) = to_O_natural f x @ ap (to O B) (pi x) @ (to_O_natural g x)^. Proof. unfold O_functor_homotopy, to_O_natural. refine (O_indpaths_beta _ _ _ x @ _). refine (concat_p_pp _ _ _). Defined. (** The pointed endofunctor ([O],[to O]) is well-pointed *) Definition O_functor_wellpointed (A : Type) : O_functor (to O A) == to O (O A). Proof. refine (O_indpaths _ _ _); intros x. apply to_O_natural. Defined. (** "Functoriality of naturality": the pseudonaturality axiom for composition *) Definition to_O_natural_compose {A B C : Type} (f : A -> B) (g : B -> C) (a : A) : ap (O_functor g) (to_O_natural f a) @ to_O_natural g (f a) = (O_functor_compose f g (to O A a))^ @ to_O_natural (g o f) a. Proof. unfold O_functor_compose, to_O_natural. rewrite O_indpaths_beta. rewrite !inv_pp, ap_V, !inv_V, !concat_pp_p. rewrite concat_Vp, concat_p1; reflexivity. Qed. (** The pseudofunctoriality axiom *) Definition O_functor_compose_compose {A B C D : Type} (f : A -> B) (g : B -> C) (h : C -> D) (a : O A) : O_functor_compose f (h o g) a @ O_functor_compose g h (O_functor f a) = O_functor_compose (g o f) h a @ ap (O_functor h) (O_functor_compose f g a). Proof. revert a; refine (O_ind2paths _ _ _). intros a; unfold composeD, O_functor_compose; cbn. Open Scope long_path_scope. rewrite !O_indpaths_beta, !ap_pp, !ap_V, !concat_p_pp. refine (whiskerL _ (apD _ (to_O_natural f a)^)^ @ _). rewrite O_indpaths_beta. rewrite transport_paths_FlFr, !concat_p_pp. rewrite !ap_V, inv_V. rewrite !concat_pV_p. apply whiskerL. apply inverse2. apply ap_compose. Close Scope long_path_scope. Qed. (** Preservation of equivalences *) Global Instance isequiv_O_functor {A B : Type} (f : A -> B) `{IsEquiv _ _ f} : IsEquiv (O_functor f). Proof. refine (isequiv_adjointify (O_functor f) (O_functor f^-1) _ _). - intros x. refine ((O_functor_compose _ _ x)^ @ _). refine (O_functor_homotopy _ idmap _ x @ _). + intros y; apply eisretr. + apply O_functor_idmap. - intros x. refine ((O_functor_compose _ _ x)^ @ _). refine (O_functor_homotopy _ idmap _ x @ _). + intros y; apply eissect. + apply O_functor_idmap. Defined. Definition equiv_O_functor {A B : Type} (f : A <~> B) : O A <~> O B := Build_Equiv _ _ (O_functor f) _. (** This is sometimes useful to have a separate name for, to facilitate rewriting along it. *) Definition to_O_equiv_natural {A B} (f : A <~> B) : (equiv_O_functor f) o (to O A) == (to O B) o f := to_O_natural f. (** This corresponds to [ap O] on the universe. *) Definition ap_O_path_universe' `{Univalence} {A B : Type} (f : A <~> B) : ap O (path_universe_uncurried f) = path_universe_uncurried (equiv_O_functor f). Proof. revert f. equiv_intro (equiv_path A B) p. refine (ap (ap O) (eta_path_universe p) @ _). destruct p; simpl. apply moveL_equiv_V. apply path_equiv, path_arrow, O_indpaths; intros x. symmetry; apply to_O_natural. Defined. Definition ap_O_path_universe `{Univalence} {A B : Type} (f : A -> B) `{IsEquiv _ _ f} : ap O (path_universe f) = path_universe (O_functor f) := ap_O_path_universe' (Build_Equiv _ _ f _). (** Postcomposition respects [O_rec] *) Definition O_rec_postcompose {A B C : Type@{i}} `{In O B} {C_inO : In O C} (f : A -> B) (g : B -> C) : g o O_rec (O := O) f == O_rec (O := O) (g o f). Proof. refine (O_indpaths _ _ _); intros x. transitivity (g (f x)). - apply ap. apply O_rec_beta. - symmetry. exact (O_rec_beta (g o f) x). Defined. (** In particular, we have: *) Definition O_rec_postcompose_to_O {A B : Type} (f : A -> B) `{In O B} : to O B o O_rec f == O_functor f := O_rec_postcompose f (to O B). End Functor. Section Replete. (** An equivalent formulation of repleteness is that a type lies in the subuniverse as soon as its unit map is an equivalence. *) Definition inO_isequiv_to_O (T:Type) : IsEquiv (to O T) -> In O T := fun _ => inO_equiv_inO (O T) (to O T)^-1. (** We don't make this an ordinary instance, but we allow it to solve [In O] constraints if we already have [IsEquiv] as a hypothesis. *) #[local] Hint Immediate inO_isequiv_to_O : typeclass_instances. Definition inO_iff_isequiv_to_O (T:Type) : In O T <-> IsEquiv (to O T). Proof. split; exact _. Defined. (** Thus, [T] is in a subuniverse as soon as [to O T] admits a retraction. *) Definition inO_to_O_retract (T:Type) (mu : O T -> T) : mu o (to O T) == idmap -> In O T. Proof. intros H. apply inO_isequiv_to_O. apply isequiv_adjointify with (g:=mu). - refine (O_indpaths (to O T o mu) idmap _). intros x; exact (ap (to O T) (H x)). - exact H. Defined. (** It follows that reflective subuniverses are closed under retracts. *) Definition inO_retract_inO (A B : Type) `{In O B} (s : A -> B) (r : B -> A) (K : r o s == idmap) : In O A. Proof. nrapply (inO_to_O_retract A (r o (to O B)^-1 o (O_functor s))). intro a. lhs exact (ap (r o (to O B)^-1) (to_O_natural s a)). lhs nrefine (ap r (eissect _ (s a))). apply K. Defined. End Replete. (** The maps that are inverted by the reflector. Note that this notation is not (yet) global (because notations in a section cannot be made global); it only exists in this section. After the section is over, we will redefine it globally. *) Local Notation O_inverts f := (IsEquiv (O_functor f)). Section OInverts. Global Instance O_inverts_O_unit (A : Type) : O_inverts (to O A). Proof. refine (isequiv_homotopic (to O (O A)) _). intros x; symmetry; apply O_functor_wellpointed. Defined. (** A map between modal types that is inverted by [O] is already an equivalence. This can't be an [Instance], probably because it causes an infinite regress applying more and more [O_functor]. *) Definition isequiv_O_inverts {A B : Type} `{In O A} `{In O B} (f : A -> B) `{O_inverts f} : IsEquiv f. Proof. refine (isequiv_commsq' f (O_functor f) (to O A) (to O B) _). apply to_O_natural. Defined. (** Strangely, even this seems to cause infinite loops *) (** [Hint Immediate isequiv_O_inverts : typeclass_instances.] *) Definition equiv_O_inverts {A B : Type} `{In O A} `{In O B} (f : A -> B) `{O_inverts f} : A <~> B := Build_Equiv _ _ f (isequiv_O_inverts f). Definition isequiv_O_rec_O_inverts {A B : Type} `{In O B} (f : A -> B) `{O_inverts f} : IsEquiv (O_rec (O := O) f). Proof. (* Not sure why we need [C:=O B] on the next line to get Coq to use two typeclass instances. *) rapply (cancelL_isequiv (C:=O B) (to O B)). rapply (isequiv_homotopic (O_functor f) (fun x => (O_rec_postcompose_to_O f x)^)). Defined. Definition equiv_O_rec_O_inverts {A B : Type} `{In O B} (f : A -> B) `{O_inverts f} : O A <~> B := Build_Equiv _ _ _ (isequiv_O_rec_O_inverts f). Definition isequiv_to_O_O_inverts {A B : Type} `{In O A} (f : A -> B) `{O_inverts f} : IsEquiv (to O B o f) := isequiv_homotopic (O_functor f o to O A) (to_O_natural f). Definition equiv_to_O_O_inverts {A B : Type} `{In O A} (f : A -> B) `{O_inverts f} : A <~> O B := Build_Equiv _ _ _ (isequiv_to_O_O_inverts f). (** If [f] is inverted by [O], then mapping out of it into any modal type is an equivalence. First we prove a version not requiring funext. For use in [O_inverts_O_leq] below, we allow the types [A], [B], and [Z] to perhaps live in smaller universes than the one [i] on which our subuniverse lives. This the first half of Lemma 1.23 of RSS. *) Definition ooextendable_O_inverts@{a b z i} {A : Type@{a}} {B : Type@{b}} (f : A -> B) `{O_inverts f} (Z : Type@{z}) `{In@{i} O Z} : ooExtendableAlong@{a b z i} f (fun _ => Z). Proof. refine (cancelL_ooextendable@{a b i z i i i i i} _ _ (to O B) _ _). 1:exact (extendable_to_O'@{i b z} O B). refine (ooextendable_homotopic _ (O_functor f o to O A) _ _). 1:apply to_O_natural. refine (ooextendable_compose _ (to O A) (O_functor f) _ _). - srapply ooextendable_equiv. - exact (extendable_to_O'@{i a z} O A). Defined. (** And now the funext version *) Definition isequiv_precompose_O_inverts `{Funext} {A B : Type} (f : A -> B) `{O_inverts f} (Z : Type) `{In O Z} : IsEquiv (fun g:B->Z => g o f). Proof. srapply (equiv_extendable_isequiv 0). exact (ooextendable_O_inverts f Z 2). Defined. (** Conversely, if a map is inverted by the representable functor [? -> Z] for all [O]-modal types [Z], then it is inverted by [O]. As before, first we prove a version that doesn't require funext. *) Definition O_inverts_from_extendable {A : Type@{i}} {B : Type@{j}} (f : A -> B) (** Without the universe annotations, the result ends up insufficiently polymorphic. *) (e : forall (Z:Type@{k}), In O Z -> ExtendableAlong@{i j k l} 2 f (fun _ => Z)) : O_inverts f. Proof. srapply isequiv_adjointify. - exact (O_rec (fst (e (O A) _) (to O A)).1). - srapply O_indpaths. intros b. rewrite O_rec_beta. assert (e1 := fun h k => fst (snd (e (O B) _) h k)). cbn in e1. refine ((e1 (fun y => O_functor f ((fst (e (O A) _) (to O A)).1 y)) (to O B) _).1 b). intros a. rewrite ((fst (e (O A) (O_inO A)) (to O A)).2 a). apply to_O_natural. - srapply O_indpaths. intros a. rewrite to_O_natural, O_rec_beta. exact ((fst (e (O A) (O_inO A)) (to O A)).2 a). Defined. #[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances. (** And the version with funext. Use it with universe parameters [i j k l lplus l l l l]. *) Definition O_inverts_from_isequiv_precompose `{Funext} {A B : Type} (f : A -> B) (e : forall (Z:Type), In O Z -> IsEquiv (fun g:B->Z => g o f)) : O_inverts f. Proof. apply O_inverts_from_extendable. intros Z ?. rapply ((equiv_extendable_isequiv 0 _ _)^-1%equiv). Defined. (** This property also characterizes the types in the subuniverse, which is the other half of Lemma 1.23. *) Definition inO_ooextendable_O_inverts (Z:Type@{k}) (E : forall (A : Type@{i}) (B : Type@{j}) (f : A -> B) (Oif : O_inverts f), ooExtendableAlong f (fun _ => Z)) : In O Z. Proof. pose (EZ := fst (E Z (O Z) (to O Z) _ 1%nat) idmap). exact (inO_to_O_retract _ EZ.1 EZ.2). Defined. (** A version with the equivalence form of the extension condition. *) Definition inO_isequiv_precompose_O_inverts (Z:Type) (Yo : forall (A : Type) (B : Type) (f : A -> B) (Oif : O_inverts f), IsEquiv (fun g:B->Z => g o f)) : In O Z. Proof. pose (EZ := extension_isequiv_precompose (to O Z) _ (Yo Z (O Z) (to O Z) _) idmap). exact (inO_to_O_retract _ EZ.1 EZ.2). Defined. Definition to_O_inv_natural {A B : Type} `{In O A} `{In O B} (f : A -> B) : (to O B)^-1 o (O_functor f) == f o (to O A)^-1. Proof. refine (O_indpaths _ _ _); intros x. apply moveR_equiv_V. refine (to_O_natural f x @ _). do 2 apply ap. symmetry; apply eissect. Defined. (** Two maps between modal types that become equal after applying [O_functor] are already equal. *) Definition O_functor_faithful_inO {A B : Type} `{In O A} `{In O B} (f g : A -> B) (e : O_functor f == O_functor g) : f == g. Proof. intros x. refine (ap f (eissect (to O A) x)^ @ _). refine (_ @ ap g (eissect (to O A) x)). transitivity ((to O B)^-1 (O_functor f (to O A x))). + symmetry; apply to_O_inv_natural. + transitivity ((to O B)^-1 (O_functor g (to O A x))). * apply ap, e. * apply to_O_inv_natural. Defined. (** Any map to a type in the subuniverse that is inverted by [O] must be equivalent to [to O]. More precisely, the type of such maps is contractible. *) Definition typeof_to_O (A : Type) := { OA : Type & { Ou : A -> OA & ((In O OA) * (O_inverts Ou)) }}. Global Instance contr_typeof_O_unit `{Univalence} (A : Type) : Contr (typeof_to_O A). Proof. apply (Build_Contr _ (O A ; (to O A ; (_ , _)))). intros [OA [Ou [? ?]]]. pose (f := O_rec Ou : O A -> OA). pose (g := (O_functor Ou)^-1 o to O OA : (OA -> O A)). assert (IsEquiv f). { refine (isequiv_adjointify f g _ _). - apply O_functor_faithful_inO; intros x. rewrite O_functor_idmap. rewrite O_functor_compose. unfold g. rewrite (O_functor_compose (to O OA) (O_functor Ou)^-1). rewrite O_functor_wellpointed. rewrite (to_O_natural (O_functor Ou)^-1 x). refine (to_O_natural f _ @ _). set (y := (O_functor Ou)^-1 x). transitivity (O_functor Ou y); [ | apply eisretr]. unfold f, O_functor. apply O_rec_postcompose. - refine (O_indpaths _ _ _); intros x. unfold f. rewrite O_rec_beta. unfold g. apply moveR_equiv_V. symmetry; apply to_O_natural. } simple refine (path_sigma _ _ _ _ _); cbn. - exact (path_universe f). - rewrite transport_sigma. simple refine (path_sigma _ _ _ _ _); cbn; [ | apply path_ishprop]. apply path_arrow; intros x. rewrite transport_arrow_fromconst. rewrite transport_path_universe. unfold f; apply O_rec_beta. Qed. End OInverts. Section Types. (** ** The [Unit] type *) Global Instance inO_unit : In O Unit. Proof. apply inO_to_O_retract@{Set} with (mu := fun x => tt). exact (@contr@{Set} Unit _). Defined. (** It follows that any contractible type is in [O]. *) Global Instance inO_contr {A : Type} `{Contr A} : In O A. Proof. exact (inO_equiv_inO@{Set _ _} Unit equiv_contr_unit^-1). Defined. (** And that the reflection of a contractible type is still contractible. *) Global Instance contr_O_contr {A : Type} `{Contr A} : Contr (O A). Proof. exact (contr_equiv A (to O A)). Defined. (** ** Dependent product and arrows *) (** Theorem 7.7.2 *) Global Instance inO_forall {fs : Funext} (A:Type) (B:A -> Type) : (forall x, (In O (B x))) -> (In O (forall x:A, (B x))). Proof. intro H. pose (ev := fun x => (fun (f:(forall x, (B x))) => f x)). pose (zz := fun x:A => O_rec (O := O) (ev x)). apply inO_to_O_retract with (mu := fun z => fun x => zz x z). intro phi. unfold zz, ev; clear zz; clear ev. apply path_forall; intro x. exact (O_rec_beta (fun f : forall x0, (B x0) => f x) phi). Defined. Global Instance inO_arrow {fs : Funext} (A B : Type) `{In O B} : In O (A -> B). Proof. apply inO_forall. intro a. exact _. Defined. (** ** Product *) Global Instance inO_prod (A B : Type) `{In O A} `{In O B} : In O (A*B). Proof. apply inO_to_O_retract with (mu := fun X => (@O_rec _ (A * B) A _ _ _ fst X , O_rec snd X)). intros [a b]; apply path_prod; simpl. - exact (O_rec_beta fst (a,b)). - exact (O_rec_beta snd (a,b)). Defined. (** Two ways to define a map [O(A * B) -> X * Y] agree. *) Definition O_rec_functor_prod {A B X Y : Type} `{In O X} `{In O Y} (f : A -> X) (g : B -> Y) : O_rec (functor_prod f g) == prod_coind (O_rec (f o fst : A * B -> X)) (O_rec (g o snd : A * B -> Y)). Proof. apply O_indpaths; intro ab. unfold functor_prod, prod_coind, prod_coind_uncurried; simpl. lhs (nrapply O_rec_beta). apply path_prod; cbn; symmetry; nrapply O_rec_beta. Defined. (** We show that [OA*OB] has the same universal property as [O(A*B)] *) (** Here is the map witnessing the universal property. *) Definition O_prod_unit (A B : Type) : A * B -> O A * O B := functor_prod (to O A) (to O B). (** We express the universal property without funext, using extensions. *) Definition ooextendable_O_prod_unit (A B C : Type) `{In O C} : ooExtendableAlong (O_prod_unit A B) (fun _ => C). Proof. apply ooextendable_functor_prod. all:intros; rapply extendable_to_O. Defined. (** Here's the version with funext. *) Definition isequiv_O_prod_unit_precompose {fs : Funext} (A B C : Type) `{In O C} : IsEquiv (fun (f : (O A) * (O B) -> C) => f o O_prod_unit A B). Proof. rapply isequiv_ooextendable. rapply ooextendable_O_prod_unit. Defined. Definition equiv_O_prod_unit_precompose {fs : Funext} (A B C : Type) `{In O C} : ((O A) * (O B) -> C) <~> (A * B -> C) := Build_Equiv _ _ _ (isequiv_O_prod_unit_precompose A B C). (** The (funext-free) universal property implies that [O_prod_unit] is an [O]-equivalence, hence induces an equivalence between [O (A*B)] and [O A * O B]. *) Global Instance O_inverts_O_prod_unit (A B : Type) : O_inverts (O_prod_unit A B). Proof. rapply O_inverts_from_extendable. intros; rapply ooextendable_O_prod_unit. Defined. Definition O_prod_cmp (A B : Type) : O (A * B) -> O A * O B := O_rec (O_prod_unit A B). Global Instance isequiv_O_prod_cmp (A B : Type) : IsEquiv (O_prod_cmp A B). Proof. rapply isequiv_O_rec_O_inverts. Defined. Definition equiv_O_prod_cmp (A B : Type) : O (A * B) <~> (O A * O B) := Build_Equiv _ _ (O_prod_cmp A B) _. Definition equiv_path_O_prod {X Y : Type} {x0 x1 : X} {y0 y1 : Y} : (to O _ (x0, y0) = to O _ (x1, y1)) <~> (to O _ x0 = to O _ x1) * (to O _ y0 = to O _ y1). Proof. refine (_ oE equiv_ap' (equiv_O_prod_cmp _ _) _ _). refine (_ oE equiv_concat_lr _ _); only 2: symmetry. 2,3: apply O_rec_beta. exact (equiv_path_prod _ _)^-1%equiv. Defined. Definition O_prod_cmp_coind (A B : Type) : O_prod_cmp A B == prod_coind (O_rec (to O _ o fst : A * B -> O A)) (O_rec (to O _ o snd : A * B -> O B)) := O_rec_functor_prod _ _. (** ** Pullbacks *) Global Instance inO_pullback {A B C} (f : B -> A) (g : C -> A) `{In O A} `{In O B} `{In O C} : In O (Pullback f g). Proof. srapply inO_to_O_retract. - intros op. exists (O_rec pr1 op). exists (O_rec (fun p => p.2.1) op). revert op; apply O_indpaths; intros [b [c a]]. refine (ap f (O_rec_beta _ _) @ _); cbn. refine (a @ ap g (O_rec_beta _ _)^). - intros [b [c a]]; cbn. srapply path_sigma'. { apply O_rec_beta. } refine (transport_sigma' _ _ @ _); cbn. srapply path_sigma'. { apply O_rec_beta. } abstract ( rewrite transport_paths_Fr; rewrite transport_paths_Fl; rewrite O_indpaths_beta; rewrite concat_V_pp; rewrite ap_V; apply concat_pV_p ). Defined. (** ** Fibers *) Global Instance inO_hfiber {A B : Type} `{In O A} `{In O B} (f : A -> B) (b : B) : In O (hfiber f b). Proof. simple refine (inO_to_O_retract _ _ _). - intros x; simple refine (_;_). + exact (O_rec pr1 x). + revert x; apply O_indpaths; intros x; simpl. refine (ap f (O_rec_beta pr1 x) @ _). exact (x.2). - intros [a p]; simple refine (path_sigma' _ _ _). + exact (O_rec_beta pr1 (a;p)). + refine (ap (transport _ _) (O_indpaths_beta _ _ _ _) @ _); simpl. refine (transport_paths_Fl _ _ @ _). apply concat_V_pp. Defined. Definition inO_unsigma {A : Type} (B : A -> Type) `{In O A} {B_inO : In O {x:A & B x}} (x : A) : In O (B x) := inO_equiv_inO _ (hfiber_fibration x B)^-1. #[local] Hint Immediate inO_unsigma : typeclass_instances. (** The reflector preserving hfibers is a characterization of lex modalities. Here is the comparison map. *) Definition O_functor_hfiber {A B} (f : A -> B) (b : B) : O (hfiber f b) -> hfiber (O_functor f) (to O B b). Proof. apply O_rec. intros [a p]. exists (to O A a). refine (to_O_natural f a @ _). apply ap, p. Defined. Definition O_functor_hfiber_natural {A B} (f : A -> B) (b : B) : (O_functor_hfiber f b) o to O (hfiber f b) == functor_hfiber (fun u => (to_O_natural f u)^) b. Proof. intros [a p]; unfold O_functor_hfiber, functor_hfiber, functor_sigma; cbn. refine (O_rec_beta _ _ @ _). exact (ap _ (inv_V _ @@ 1))^. Defined. (** [functor_sigma] over [idmap] preserves [O]-equivalences. *) Definition O_inverts_functor_sigma_id {A} {P Q : A -> Type} (g : forall a, P a -> Q a) `{forall a, O_inverts (g a)} : O_inverts (functor_sigma idmap g). Proof. apply O_inverts_from_extendable; intros Z Z_inO. apply ooextendable_functor_sigma_id; intros a. nrapply ooextendable_O_inverts; exact _. Defined. (** Theorem 7.3.9: The reflector [O] can be discarded inside a reflected sum. This can be obtained from [O_inverts_functor_sigma_id] applied to the family of units [to O (P x)], but unfortunately the definitional behavior of the inverse obtained thereby (which here we take as the "forwards" direction) is poor. So instead we give an explicit proof, but note that the "backwards" direction here is precisely [functor_sigma]. *) Definition equiv_O_sigma_O {A} (P : A -> Type) : O {x:A & O (P x)} <~> O {x:A & P x}. (** := (Build_Equiv _ _ _ (O_inverts_functor_sigma_id (fun x => to O (P x))))^-1. *) Proof. srapply equiv_adjointify. - apply O_rec; intros [a op]; revert op. apply O_rec; intros p. exact (to O _ (a;p)). - apply O_functor. exact (functor_sigma idmap (fun x => to O (P x))). - unfold O_functor; rapply O_indpaths. intros [a p]; simpl. abstract (repeat (rewrite O_rec_beta); reflexivity). - unfold O_functor; rapply O_indpaths. intros [a op]; revert op; rapply O_indpaths; intros p; simpl. abstract (repeat (rewrite O_rec_beta); reflexivity). Defined. (** ** Equivalences *) (** Naively it might seem that we need closure under Sigmas (hence a modality) to deduce closure under [Equiv], but in fact the above closure under fibers is sufficient. This appears as part of the proof of Proposition 2.18 of CORS. For later use, we try to reduce the number of universe parameters (but we don't completely control them all). *) Global Instance inO_equiv `{Funext} (A : Type@{i}) (B : Type@{j}) `{In O A} `{In O B} : In O (A <~> B). Proof. refine (inO_equiv_inO _ (issig_equiv@{i j k} A B)). refine (inO_equiv_inO _ (equiv_functor_sigma equiv_idmap@{k} (fun f => equiv_biinv_isequiv@{i j k} f))). transparent assert (c : (prod@{k k} (A->B) (prod@{k k} (B->A) (B->A)) -> prod@{k k} (A -> A) (B -> B))). { intros [f [g h]]; exact (h o f, f o g). } pose (U := hfiber@{k k} c (idmap, idmap)). refine (inO_equiv_inO'@{k k k} U _). (** Introduces some extra copies of [k] by typeclass inference. *) unfold hfiber, BiInv; cbn in *. srefine (equiv_adjointify _ _ _ _). - intros [[f [g h]] p]. apply (equiv_inverse (equiv_path_prod _ _)) in p. destruct p as [p q]; cbn in *. exists f; split; [ exists h | exists g ]. all:apply ap10; assumption. - intros [f [[g p] [h q]]]. exists (f,(h,g)); cbn. apply path_prod; apply path_arrow; assumption. - intros [f [[g p] [h q]]]; cbn. apply (path_sigma' _ 1); apply path_prod; apply (path_sigma' _ 1); cbn; rewrite transport_1. 1:rewrite ap_fst_path_prod. 2:rewrite ap_snd_path_prod. all:apply path_forall; intros x; rewrite ap10_path_arrow; reflexivity. - intros fghp. cbn. apply (path_sigma' _ 1); cbn. refine (_ @ eta_path_prod (pr2 fghp)); apply ap011; apply eta_path_arrow. Defined. (** ** Paths *) Definition inO_paths@{i} (S : Type@{i}) {S_inO : In O S} (x y : S) : In O (x=y). Proof. simple refine (inO_to_O_retract@{i} _ _ _); intro u. - assert (p : (fun _ : O (x=y) => x) == (fun _=> y)). { refine (O_indpaths _ _ _); simpl. intro v; exact v. } exact (p u). - simpl. rewrite O_indpaths_beta; reflexivity. Qed. Global Existing Instance inO_paths. Lemma O_concat {A : Type} {a0 a1 a2 : A} : O (a0 = a1) -> O (a1 = a2) -> O (a0 = a2). Proof. intros p q. strip_reflections. exact (to O _ (p @ q)). Defined. (** ** Truncations *) (** The reflector preserves hprops (and, as we have already seen, contractible types), although it doesn't generally preserve [n]-types for other [n]. *) Global Instance ishprop_O_ishprop {A} `{IsHProp A} : IsHProp (O A). Proof. refine ishprop_isequiv_diag. refine (isequiv_homotopic (O_prod_cmp A A o O_functor (fun (a:A) => (a,a))) _). apply O_indpaths; intros x; simpl. refine (ap (O_prod_cmp A A) (to_O_natural (fun (a:A) => (a,a)) x) @ _). unfold O_prod_cmp; apply O_rec_beta. Defined. (** If [A] is [In O], then so is [IsTrunc n A]. *) Global Instance inO_istrunc `{Funext} {n} {A} `{In O A} : In O (IsTrunc n A). Proof. generalize dependent A; simple_induction n n IH; intros A ?. - (** We have to be slightly clever here: the actual definition of [Contr] involves a sigma, which [O] is not generally closed under, but fortunately we have [equiv_contr_inhabited_allpath]. *) refine (inO_equiv_inO _ equiv_contr_inhabited_allpath^-1). - refine (inO_equiv_inO _ (equiv_istrunc_unfold n.+1 A)^-1). Defined. (** ** Coproducts *) Definition O_inverts_functor_sum {A B A' B'} (f : A -> A') (g : B -> B') `{O_inverts f} `{O_inverts g} : O_inverts (functor_sum f g). Proof. apply O_inverts_from_extendable; intros. apply extendable_functor_sum; apply ooextendable_O_inverts; assumption. Defined. Definition equiv_O_functor_sum {A B A' B'} (f : A -> A') (g : B -> B') `{O_inverts f} `{O_inverts g} : O (A + B) <~> O (A' + B') := Build_Equiv _ _ _ (O_inverts_functor_sum f g). Definition equiv_O_sum {A B} : O (A + B) <~> O (O A + O B) := equiv_O_functor_sum (to O A) (to O B). (** ** Coequalizers *) Section OCoeq. Context {B A : Type} (f g : B -> A). Definition O_inverts_functor_coeq {B' A' : Type} {f' g' : B' -> A'} (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) `{O_inverts k} `{O_inverts h} : O_inverts (functor_coeq h k p q). Proof. apply O_inverts_from_extendable. intros Z Z_inO. apply extendable_functor_coeq'. all:nrapply ooextendable_O_inverts; assumption. Defined. Definition equiv_O_functor_coeq {B' A' : Type} (f' g' : B' -> A') (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) `{O_inverts k} `{O_inverts h} : O (Coeq f g) <~> O (Coeq f' g') := Build_Equiv _ _ _ (O_inverts_functor_coeq h k p q). Definition coeq_cmp : Coeq f g -> Coeq (O_functor f) (O_functor g) := functor_coeq (to O B) (to O A) (fun y => (to_O_natural f y)^) (fun y => (to_O_natural g y)^). Global Instance isequiv_O_coeq_cmp : O_inverts coeq_cmp. Proof. rapply O_inverts_functor_coeq. Defined. Definition equiv_O_coeq : O (Coeq f g) <~> O (Coeq (O_functor f) (O_functor g)) := Build_Equiv _ _ (O_functor coeq_cmp) _. Definition equiv_O_coeq_to_O (a : A) : equiv_O_coeq (to O (Coeq f g) (coeq a)) = to O (Coeq (O_functor f) (O_functor g)) (coeq (to O A a)). Proof. refine (to_O_natural _ _). Defined. Definition inverse_equiv_O_coeq_to_O (a : A) : equiv_O_coeq^-1 (to O (Coeq (O_functor f) (O_functor g)) (coeq (to O A a))) = to O (Coeq f g) (coeq a). Proof. apply moveR_equiv_V; symmetry; apply equiv_O_coeq_to_O. Defined. End OCoeq. (** ** Pushouts *) Section OPushout. Context {A B C : Type} (f : A -> B) (g : A -> C). Definition O_inverts_functor_pushout {A' B' C'} {f' : A' -> B'} {g' : A' -> C'} (h : A -> A') (k : B -> B') (l : C -> C') (p : k o f == f' o h) (q : l o g == g' o h) `{O_inverts h} `{O_inverts k} `{O_inverts l} : O_inverts (functor_pushout h k l p q). Proof. rapply O_inverts_functor_coeq; rapply O_inverts_functor_sum. Defined. Definition equiv_O_pushout : O (Pushout f g) <~> O (Pushout (O_functor f) (O_functor g)) := Build_Equiv _ _ _ (O_inverts_functor_pushout (to O A) (to O B) (to O C) (fun x => (to_O_natural f x)^) (fun x => (to_O_natural g x)^)). Definition equiv_O_pushout_to_O_pushl (b : B) : equiv_O_pushout (to O (Pushout f g) (pushl b)) = to O (Pushout (O_functor f) (O_functor g)) (pushl (to O B b)). Proof. cbn. rapply to_O_natural. Defined. Definition equiv_O_pushout_to_O_pushr (c : C) : equiv_O_pushout (to O (Pushout f g) (pushr c)) = to O (Pushout (O_functor f) (O_functor g)) (pushr (to O C c)). Proof. cbn. rapply to_O_natural. Defined. Definition inverse_equiv_O_pushout_to_O_pushl (b : B) : equiv_O_pushout^-1 (to O (Pushout (O_functor f) (O_functor g)) (pushl (to O B b))) = to O (Pushout f g) (pushl b). Proof. apply moveR_equiv_V; symmetry; apply equiv_O_pushout_to_O_pushl. Qed. Definition inverse_equiv_O_pushout_to_O_pushr (c : C) : equiv_O_pushout^-1 (to O (Pushout (O_functor f) (O_functor g)) (pushr (to O C c))) = to O (Pushout f g) (pushr c). Proof. apply moveR_equiv_V; symmetry; apply equiv_O_pushout_to_O_pushr. Qed. End OPushout. End Types. Section Decidable. (** If [Empty] belongs to [O], then [O] preserves decidability. *) Global Instance decidable_O `{In O Empty} (A : Type) `{Decidable A} : Decidable (O A). Proof. destruct (dec A) as [y|n]. - exact (inl (to O A y)). - exact (inr (O_rec n)). Defined. (** Dually, if [O A] is decidable, then [O (Decidable A)]. *) Definition O_decidable (A : Type) `{Decidable (O A)} : O (Decidable A). Proof. destruct (dec (O A)) as [y|n]. - exact (O_functor inl y). - refine (O_functor inr _). apply to; intros a. exact (n (to O A a)). Defined. End Decidable. Section Monad. Definition O_monad_mult (A : Type) : O (O A) -> O A := O_rec idmap. Definition O_monad_mult_natural {A B} (f : A -> B) : O_functor f o O_monad_mult A == O_monad_mult B o O_functor (O_functor f). Proof. apply O_indpaths; intros x; unfold O_monad_mult. rewrite (to_O_natural (O_functor f) x). rewrite (O_rec_beta idmap x). rewrite (O_rec_beta idmap (O_functor f x)). reflexivity. Qed. Definition O_monad_unitlaw1 (A : Type) : O_monad_mult A o (to O (O A)) == idmap. Proof. apply O_indpaths; intros x; unfold O_monad_mult. exact (O_rec_beta idmap (to O A x)). Defined. Definition O_monad_unitlaw2 (A : Type) : O_monad_mult A o (O_functor (to O A)) == idmap. Proof. apply O_indpaths; intros x; unfold O_monad_mult, O_functor. repeat rewrite O_rec_beta. reflexivity. Qed. Definition O_monad_mult_assoc (A : Type) : O_monad_mult A o O_monad_mult (O A) == O_monad_mult A o O_functor (O_monad_mult A). Proof. apply O_indpaths; intros x; unfold O_monad_mult, O_functor. repeat rewrite O_rec_beta. reflexivity. Qed. End Monad. Section StrongMonad. Context {fs : Funext}. Definition O_monad_strength (A B : Type) : A * O B -> O (A * B) := fun aob => O_rec (fun b a => to O (A*B) (a,b)) (snd aob) (fst aob). Definition O_monad_strength_natural (A A' B B' : Type) (f : A -> A') (g : B -> B') : O_functor (functor_prod f g) o O_monad_strength A B == O_monad_strength A' B' o functor_prod f (O_functor g). Proof. intros [a b]. revert a. apply ap10. strip_reflections. apply path_arrow; intros a. unfold O_monad_strength, O_functor; simpl. repeat rewrite O_rec_beta. reflexivity. Qed. (** The diagrams for strength, see http://en.wikipedia.org/wiki/Strong_monad *) Definition O_monad_strength_unitlaw1 (A : Type) : O_functor (@snd Unit A) o O_monad_strength Unit A == @snd Unit (O A). Proof. intros [[] a]. strip_reflections. unfold O_monad_strength, O_functor. simpl. rewrite O_rec_beta. nrapply O_rec_beta. Qed. Definition O_monad_strength_unitlaw2 (A B : Type) : O_monad_strength A B o functor_prod idmap (to O B) == to O (A*B). Proof. intros [a b]. unfold O_monad_strength, functor_prod. simpl. revert a; apply ap10. nrapply O_rec_beta. Qed. Definition O_monad_strength_assoc1 (A B C : Type) : O_functor (equiv_prod_assoc A B C)^-1 o O_monad_strength (A*B) C == O_monad_strength A (B*C) o functor_prod idmap (O_monad_strength B C) o (equiv_prod_assoc A B (O C))^-1. Proof. intros [[a b] c]. revert a; apply ap10. revert b; apply ap10. strip_reflections. apply path_arrow; intros b. apply path_arrow; intros a. unfold O_monad_strength, O_functor, functor_prod. simpl. repeat rewrite O_rec_beta. reflexivity. Qed. Definition O_monad_strength_assoc2 (A B : Type) : O_monad_mult (A*B) o O_functor (O_monad_strength A B) o O_monad_strength A (O B) == O_monad_strength A B o functor_prod idmap (O_monad_mult B). Proof. intros [a b]. revert a; apply ap10. strip_reflections. apply path_arrow; intros a. unfold O_monad_strength, O_functor, O_monad_mult, functor_prod. simpl. repeat (rewrite O_rec_beta; simpl). reflexivity. Qed. End StrongMonad. End Reflective_Subuniverse. (** Now we make the [O_inverts] notation global. *) Notation O_inverts O f := (IsEquiv (O_functor O f)). (** ** Modally connected types *) (** Connectedness of a type, relative to a modality or reflective subuniverse, can be defined in two equivalent ways: quantifying over all maps into modal types, or by considering just the universal case, the modal reflection of the type itself. The former requires only core Coq, but blows up the size (universe level) of [IsConnected], since it quantifies over types; moreover, it is not even quite correct since (at least with a polymorphic modality) it should really be quantified over all universes. Thus, we use the latter, although in most examples it requires HITs to define the modal reflection. Question: is there a definition of connectedness (say, for n-types) that neither blows up the universe level, nor requires HIT's? *) (** We give annotations to reduce the number of universe parameters. *) Class IsConnected (O : ReflectiveSubuniverse@{i}) (A : Type@{i}) := isconnected_contr_O : Contr@{i} (O A). Global Existing Instance isconnected_contr_O. Section ConnectedTypes. Context (O : ReflectiveSubuniverse). (** Being connected is an hprop *) Global Instance ishprop_isconnected `{Funext} A : IsHProp (IsConnected O A). Proof. unfold IsConnected; exact _. Defined. (** Anything equivalent to a connected type is connected. *) Definition isconnected_equiv (A : Type) {B : Type} (f : A -> B) `{IsEquiv _ _ f} : IsConnected O A -> IsConnected O B. Proof. intros ?; refine (contr_equiv (O A) (O_functor O f)). Defined. Definition isconnected_equiv' (A : Type) {B : Type} (f : A <~> B) : IsConnected O A -> IsConnected O B := isconnected_equiv A f. (** The O-connected types form a subuniverse. *) Definition Conn : Subuniverse. Proof. rapply (Build_Subuniverse (IsConnected O)). simpl; intros T U isconnT f isequivf. exact (isconnected_equiv T f isconnT). Defined. (** Connectedness of a type [A] can equivalently be characterized by the fact that any map to an [O]-type [C] is nullhomotopic. Here is one direction of that equivalence. *) Definition isconnected_elim {A : Type} `{IsConnected O A} (C : Type) `{In O C} (f : A -> C) : NullHomotopy f. Proof. set (ff := @O_rec O _ _ _ _ _ f). exists (ff (center _)). intros a. symmetry. refine (ap ff (contr (to O _ a)) @ _). apply O_rec_beta. Defined. (** For the other direction of the equivalence, it's sufficient to consider the case when [C] is [O A]. *) Definition isconnected_from_elim_to_O {A : Type} : NullHomotopy (to O A) -> IsConnected O A. Proof. intros nh. apply (Build_Contr _ (nh .1)). rapply O_indpaths. intros x; symmetry; apply (nh .2). Defined. (** Now the general case follows. *) Definition isconnected_from_elim {A : Type} : (forall (C : Type) `{In O C} (f : A -> C), NullHomotopy f) -> IsConnected O A. Proof. intros H. exact (isconnected_from_elim_to_O (H (O A) (O_inO A) (to O A))). Defined. (** Connected types are closed under sigmas. *) Global Instance isconnected_sigma {A : Type} {B : A -> Type} `{IsConnected O A} `{forall a, IsConnected O (B a)} : IsConnected O {a:A & B a}. Proof. apply isconnected_from_elim; intros C ? f. pose (nB := fun a => @isconnected_elim (B a) _ C _ (fun b => f (a;b))). pose (nA := isconnected_elim C (fun a => (nB a).1)). exists (nA.1); intros [a b]. exact ((nB a).2 b @ nA.2 a). Defined. (** Contractible types are connected. *) Global Instance isconnected_contr {A : Type} `{Contr A} : IsConnected O A. Proof. rapply contr_O_contr. Defined. (** A type which is both connected and modal is contractible. *) Definition contr_trunc_conn {A : Type} `{In O A} `{IsConnected O A} : Contr A. Proof. apply (contr_equiv _ (to O A)^-1). Defined. (** Any map between connected types is inverted by O. *) Global Instance O_inverts_isconnected {A B : Type} (f : A -> B) `{IsConnected O A} `{IsConnected O B} : O_inverts O f. Proof. exact _. Defined. (** Here's another way of stating the universal property for mapping out of connected types into modal ones. *) Definition extendable_const_isconnected_inO (n : nat) (A : Type) `{IsConnected O A} (C : Type) `{In O C} : ExtendableAlong n (const_tt A) (fun _ => C). Proof. generalize dependent C; simple_induction n n IHn; intros C ?; [ exact tt | split ]. - intros f. exists (fun _ : Unit => (isconnected_elim C f).1); intros a. symmetry; apply ((isconnected_elim C f).2). - intros h k. refine (extendable_postcompose' n _ _ _ _ (IHn (h tt = k tt) (inO_paths _ _ _ _))). intros []; apply equiv_idmap. Defined. Definition ooextendable_const_isconnected_inO (A : Type@{i}) `{IsConnected@{i} O A} (C : Type@{j}) `{In O C} : ooExtendableAlong (const_tt A) (fun _ => C) := fun n => extendable_const_isconnected_inO n A C. Definition isequiv_const_isconnected_inO `{Funext} {A : Type} `{IsConnected O A} (C : Type) `{In O C} : IsEquiv (@const A C). Proof. refine (@isequiv_compose _ _ (fun c u => c) _ _ _ (isequiv_ooextendable (fun _ => C) (const_tt A) (ooextendable_const_isconnected_inO A C))). Defined. Definition equiv_const_isconnected_inO `{Funext} {A : Type} `{IsConnected O A} (C : Type) `{In O C} : C <~> (A -> C) := Build_Equiv _ _ const (isequiv_const_isconnected_inO C). End ConnectedTypes. (** ** Modally truncated maps *) Section ModalMaps. Context (O : ReflectiveSubuniverse). (** Any equivalence is modal *) Global Instance mapinO_isequiv {A B : Type} (f : A -> B) `{IsEquiv _ _ f} : MapIn O f. Proof. intros b; exact _. Defined. (** A slightly specialized result: if [Empty] is modal, then a map with decidable hprop fibers (such as [inl] or [inr]) is modal. *) Global Instance mapinO_hfiber_decidable_hprop {A B : Type} (f : A -> B) `{In O Empty} `{forall b, IsHProp (hfiber f b)} `{forall b, Decidable (hfiber f b)} : MapIn O f. Proof. intros b. destruct (equiv_decidable_hprop (hfiber f b)) as [e|e]. - exact (inO_equiv_inO Unit e^-1). - exact (inO_equiv_inO Empty e^-1). Defined. (** Any map between modal types is modal. *) Global Instance mapinO_between_inO {A B : Type} (f : A -> B) `{In O A} `{In O B} : MapIn O f. Proof. intros b; exact _. Defined. (** Modal maps cancel on the left. *) Definition cancelL_mapinO {A B C : Type} (f : A -> B) (g : B -> C) : MapIn O g -> MapIn O (g o f) -> MapIn O f. Proof. intros ? ? b. refine (inO_equiv_inO _ (hfiber_hfiber_compose_map f g b)). Defined. (** Modal maps also cancel with equivalences on the other side. *) Definition cancelR_isequiv_mapinO {A B C : Type} (f : A -> B) (g : B -> C) `{IsEquiv _ _ f} `{MapIn O _ _ (g o f)} : MapIn O g. Proof. intros b. srefine (inO_equiv_inO' (hfiber (g o f) b) _). exact (equiv_functor_sigma f (fun a => 1%equiv)). Defined. Definition cancelR_equiv_mapinO {A B C : Type} (f : A <~> B) (g : B -> C) `{MapIn O _ _ (g o f)} : MapIn O g := cancelR_isequiv_mapinO f g. (** The pullback of a modal map is modal. *) Global Instance mapinO_pullback {A B C} (f : B -> A) (g : C -> A) `{MapIn O _ _ g} : MapIn O (f^* g). Proof. intros b. refine (inO_equiv_inO _ (hfiber_pullback_along f g b)^-1). Defined. Global Instance mapinO_pullback' {A B C} (g : C -> A) (f : B -> A) `{MapIn O _ _ f} : MapIn O (g^*' f). Proof. intros c. refine (inO_equiv_inO _ (hfiber_pullback_along' g f c)^-1). Defined. (** [functor_sum] preserves modal maps. *) Global Instance mapinO_functor_sum {A A' B B'} (f : A -> A') (g : B -> B') `{MapIn O _ _ f} `{MapIn O _ _ g} : MapIn O (functor_sum f g). Proof. intros [a|b]. - refine (inO_equiv_inO _ (hfiber_functor_sum_l f g a)^-1). - refine (inO_equiv_inO _ (hfiber_functor_sum_r f g b)^-1). Defined. (** So does [unfunctor_sum], if both summands are preserved. These can't be [Instance]s since they require [Ha] and [Hb] to be supplied. *) Definition mapinO_unfunctor_sum_l {A A' B B'} (h : A + B -> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) `{MapIn O _ _ h} : MapIn O (unfunctor_sum_l h Ha). Proof. intros a. refine (inO_equiv_inO _ (hfiber_unfunctor_sum_l h Ha Hb a)^-1). Defined. Definition mapinO_unfunctor_sum_r {A A' B B'} (h : A + B -> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) `{MapIn O _ _ h} : MapIn O (unfunctor_sum_r h Hb). Proof. intros b. refine (inO_equiv_inO _ (hfiber_unfunctor_sum_r h Ha Hb b)^-1). Defined. (** Given a family of maps [f : forall a, P a -> Q a] which are in [O], the induced map on Pi types is also in [O]. *) Definition mapinO_functor_forall_id `{Funext} {A : Type} {P Q : A -> Type} (f : forall a, P a -> Q a) `{forall a, MapIn O (f a)} : MapIn O (functor_forall_id f). Proof. intro g. rapply (inO_equiv_inO _ (hfiber_functor_forall_id f g)^-1%equiv). Defined. End ModalMaps. (** ** Modally connected maps *) (** Connectedness of a map can again be defined in two equivalent ways: by connectedness of its fibers (as types), or by the lifting property/elimination principle against modal types. We use the former; the equivalence with the latter is given below in [conn_map_elim], [conn_map_comp], and [conn_map_from_extension_elim]. *) Class IsConnMap (O : ReflectiveSubuniverse@{i}) {A : Type@{i}} {B : Type@{i}} (f : A -> B) := isconnected_hfiber_conn_map (** The extra universe [k] is >= max(i,j). *) : forall b:B, IsConnected@{i} O (hfiber@{i i} f b). Global Existing Instance isconnected_hfiber_conn_map. Section ConnectedMaps. Universe i. Context (O : ReflectiveSubuniverse@{i}). (** Any equivalence is connected *) Global Instance conn_map_isequiv {A B : Type} (f : A -> B) `{IsEquiv _ _ f} : IsConnMap O f. Proof. intros b; exact _. Defined. (** Anything homotopic to a connected map is connected. *) Definition conn_map_homotopic {A B : Type} (f g : A -> B) (h : f == g) : IsConnMap O f -> IsConnMap O g. Proof. intros ? b. exact (isconnected_equiv O (hfiber@{i i} f b) (equiv_hfiber_homotopic@{i i i} f g h b) _). Defined. (** The pullback of a connected map is connected *) Global Instance conn_map_pullback {A B C} (f : B -> A) (g : C -> A) `{IsConnMap O _ _ g} : IsConnMap O (f^* g). Proof. intros b. refine (isconnected_equiv _ _ (hfiber_pullback_along f g b)^-1 _). Defined. Global Instance conn_map_pullback' {A B C} (g : C -> A) (f : B -> A) `{IsConnMap O _ _ f} : IsConnMap O (g^*' f). Proof. intros c. refine (isconnected_equiv _ _ (hfiber_pullback_along' g f c)^-1 _). Defined. (** The projection from a family of connected types is connected. *) Global Instance conn_map_pr1 {A : Type} {B : A -> Type} `{forall a, IsConnected O (B a)} : IsConnMap O (@pr1 A B). Proof. intros a. refine (isconnected_equiv O (B a) (hfiber_fibration a B) _). Defined. (** Being connected is an hprop *) Global Instance ishprop_isconnmap `{Funext} {A B : Type} (f : A -> B) : IsHProp (IsConnMap O f). Proof. apply istrunc_forall. Defined. (** Connected maps are orthogonal to modal maps (i.e. familes of modal types). *) Definition conn_map_elim {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (P : B -> Type) `{forall b:B, In O (P b)} (d : forall a:A, P (f a)) : forall b:B, P b. Proof. intros b. refine (pr1 (isconnected_elim O (A:=hfiber f b) _ _)). intros [a p]. exact (transport P p (d a)). Defined. Definition conn_map_comp {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (P : B -> Type) `{forall b:B, In O (P b)} (d : forall a:A, P (f a)) : forall a:A, conn_map_elim f P d (f a) = d a. Proof. intros a. unfold conn_map_elim. set (fibermap := (fun a0p : hfiber f (f a) => let (a0, p) := a0p in transport P p (d a0))). destruct (isconnected_elim O (P (f a)) fibermap) as [x e]. change (d a) with (fibermap (a;1)). apply inverse, e. Defined. (** A map which is both connected and modal is an equivalence. *) Definition isequiv_conn_ino_map {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} `{MapIn O _ _ f} : IsEquiv f. Proof. apply isequiv_contr_map. intros b. apply (contr_trunc_conn O). Defined. (** We can re-express this in terms of extensions. *) Lemma extension_conn_map_elim {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (P : B -> Type) `{forall b:B, In O (P b)} (d : forall a:A, P (f a)) : ExtensionAlong f P d. Proof. exists (conn_map_elim f P d). apply conn_map_comp. Defined. Definition extendable_conn_map_inO (n : nat) {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (P : B -> Type) `{forall b:B, In O (P b)} : ExtendableAlong n f P. Proof. generalize dependent P. simple_induction n n IHn; intros P ?; [ exact tt | split ]. - intros d; apply extension_conn_map_elim; exact _. - intros h k; apply IHn; exact _. Defined. Definition ooextendable_conn_map_inO {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (P : B -> Type) `{forall b:B, In O (P b)} : ooExtendableAlong f P := fun n => extendable_conn_map_inO n f P. Lemma allpath_extension_conn_map `{Funext} {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (P : B -> Type) `{forall b:B, In O (P b)} (d : forall a:A, P (f a)) (e e' : ExtensionAlong f P d) : e = e'. Proof. apply path_extension. refine (extension_conn_map_elim _ _ _). Defined. (** It follows that [conn_map_elim] is actually an equivalence. *) Theorem isequiv_o_conn_map `{Funext} {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (P : B -> Type) `{forall b:B, In O (P b)} : IsEquiv (fun (g : forall b:B, P b) => g oD f). Proof. apply isequiv_contr_map; intros d. apply contr_inhabited_hprop. - nrefine (@istrunc_equiv_istrunc {g : forall b, P b & g oD f == d} _ _ _ _). { refine (equiv_functor_sigma_id _); intros g. apply equiv_path_forall. } apply hprop_allpath. intros g h. exact (allpath_extension_conn_map f P d g h). - exists (conn_map_elim f P d). apply path_forall; intros x; apply conn_map_comp. Defined. Definition equiv_o_conn_map `{Funext} {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (P : B -> Type) `{forall b:B, In O (P b)} : (forall b, P b) <~> (forall a, P (f a)) := Build_Equiv _ _ _ (isequiv_o_conn_map f P). (** When considering lexness properties, we often want to consider the property of the universe of modal types being modal. We can't say this directly (except in the accessible, hence liftable, case) because it lives in a higher universe, but we can make a direct extendability statement. Here we prove a lemma that oo-extendability into the universe follows from plain extendability, essentially because the type of equivalences between two [O]-modal types is [O]-modal. *) Definition ooextendable_TypeO_from_extension `{Univalence} {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} (extP : forall P : A -> Type_ O, ExtensionAlong f (fun _ : B => Type_ O) P) : ooExtendableAlong f (fun _ => Type_ O). Proof. (** By definition, in addition to our assumption [extP] that maps into [Type_ O] extend along [f], we must show that sections of families of equivalences are [ooExtendableAlong] it. *) intros [|[|n]]. - exact tt. (* n = 0 *) (** Note that due to the implementation of [ooExtendableAlong], we actually have to use [extP] twice (there should probably be a general cofixpoint lemma for this). *) - split; [ apply extP | intros; exact tt ]. (* n = 1 *) - split; [ apply extP | ]. (* n > 1 *) (** What remains is to extend families of paths. *) intros P Q; rapply (ooextendable_postcompose' (fun b => P b <~> Q b)). + intros x; refine (equiv_path_TypeO _ _ _ oE equiv_path_universe _ _). + rapply ooextendable_conn_map_inO. Defined. (** Conversely, if a map satisfies this elimination principle (expressed via extensions), then it is connected. This completes the proof of Lemma 7.5.7 from the book. *) Lemma conn_map_from_extension_elim {A B : Type} (f : A -> B) : (forall (P : B -> Type) {P_inO : forall b:B, In O (P b)} (d : forall a:A, P (f a)), ExtensionAlong f P d) -> IsConnMap O f. Proof. intros Hf b. apply isconnected_from_elim_to_O. assert (e := Hf (fun b => O (hfiber f b)) _ (fun a => to O _ (a;1))). exists (e.1 b). intros [a p]. destruct p. symmetry; apply (e.2). Defined. (** Lemma 7.5.6: Connected maps compose and cancel on the right. *) Global Instance conn_map_compose {A B C : Type} (f : A -> B) (g : B -> C) `{IsConnMap O _ _ f} `{IsConnMap O _ _ g} : IsConnMap O (g o f). Proof. apply conn_map_from_extension_elim; intros P ? d. exists (conn_map_elim g P (conn_map_elim f (fun b => P (g b)) d)); intros a. exact (conn_map_comp g P _ _ @ conn_map_comp f (fun b => P (g b)) d a). Defined. Definition cancelR_conn_map {A B C : Type} (f : A -> B) (g : B -> C) `{IsConnMap O _ _ f} `{IsConnMap O _ _ (g o f)} : IsConnMap O g. Proof. apply conn_map_from_extension_elim; intros P ? d. exists (conn_map_elim (g o f) P (d oD f)); intros b. pattern b; refine (conn_map_elim f _ _ b); intros a. exact (conn_map_comp (g o f) P (d oD f) a). Defined. (** Connected maps also cancel with equivalences on the other side. *) Definition cancelL_isequiv_conn_map {A B C : Type} (f : A -> B) (g : B -> C) `{IsEquiv _ _ g} `{IsConnMap O _ _ (g o f)} : IsConnMap O f. Proof. intros b. srefine (isconnected_equiv' O (hfiber (g o f) (g b)) _ _). exact (equiv_inverse (equiv_functor_sigma_id (fun a => equiv_ap g (f a) b))). Defined. Definition cancelL_equiv_conn_map {A B C : Type} (f : A -> B) (g : B <~> C) `{IsConnMap O _ _ (g o f)} : IsConnMap O f := cancelL_isequiv_conn_map f g. (** The constant map to [Unit] is connected just when its domain is. *) Definition isconnected_conn_map_to_unit {A : Type} `{IsConnMap O _ _ (const_tt A)} : IsConnected O A. Proof. refine (isconnected_equiv O (hfiber (const_tt A) tt) (equiv_sigma_contr _) _). Defined. #[local] Hint Immediate isconnected_conn_map_to_unit : typeclass_instances. Global Instance conn_map_to_unit_isconnected {A : Type} `{IsConnected O A} : IsConnMap O (const_tt A). Proof. intros u. refine (isconnected_equiv O A (equiv_sigma_contr _)^-1 _). Defined. (* Lemma 7.5.10: A map to a type in [O] exhibits its codomain as the [O]-reflection of its domain if it is [O]-connected. (The converse is true if and only if [O] is a modality.) *) Definition isequiv_O_rec_conn_map {A B : Type} `{In O B} (f : A -> B) `{IsConnMap O _ _ f} : IsEquiv (O_rec (O := O) f). Proof. refine (isequiv_adjointify _ (conn_map_elim f (fun _ => O A) (to O A)) _ _). - intros x. pattern x. refine (conn_map_elim f _ _ x); intros a. exact (ap (O_rec f) (conn_map_comp f (fun _ => O A) (to O A) a) @ O_rec_beta f a). - apply O_indpaths; intros a; simpl. refine (ap _ (O_rec_beta f a) @ _). refine (conn_map_comp f (fun _ => O A) (to O A) a). Defined. (** Lemma 7.5.12 *) Section ConnMapFunctorSigma. Context {A B : Type} {P : A -> Type} {Q : B -> Type} (f : A -> B) (g : forall a, P a -> Q (f a)) `{forall a, IsConnMap O (g a)}. Definition equiv_O_hfiber_functor_sigma (b:B) (v:Q b) : O (hfiber (functor_sigma f g) (b;v)) <~> O (hfiber f b). Proof. equiv_via (O {w : hfiber f b & hfiber (g w.1) ((w.2)^ # v)}). { apply equiv_O_functor, hfiber_functor_sigma. } equiv_via (O {w : hfiber f b & O (hfiber (g w.1) ((w.2)^ # v))}). { symmetry; apply equiv_O_sigma_O. } apply equiv_O_functor. apply equiv_sigma_contr; intros [a p]; simpl; exact _. Defined. Global Instance conn_map_functor_sigma `{IsConnMap O _ _ f} : IsConnMap O (functor_sigma f g). Proof. intros [b v]. refine (contr_equiv' _ (equiv_inverse (equiv_O_hfiber_functor_sigma b v))). Defined. Definition conn_map_base_inhabited (inh : forall b, Q b) `{IsConnMap O _ _ (functor_sigma f g)} : IsConnMap O f. Proof. intros b. refine (contr_equiv _ (equiv_O_hfiber_functor_sigma b (inh b))). Defined. End ConnMapFunctorSigma. (** Lemma 7.5.13. The "if" direction is a special case of [conn_map_functor_sigma], so we prove only the "only if" direction. *) Definition conn_map_fiber {A : Type} {P Q : A -> Type} (f : forall a, P a -> Q a) `{IsConnMap O _ _ (functor_sigma idmap f)} : forall a, IsConnMap O (f a). Proof. intros a q. refine (isconnected_equiv' O (hfiber (functor_sigma idmap f) (a;q)) _ _). exact (hfiber_functor_sigma_idmap P Q f a q). Defined. (** Lemma 7.5.14: Connected maps are inverted by [O]. *) Global Instance O_inverts_conn_map {A B : Type} (f : A -> B) `{IsConnMap O _ _ f} : O_inverts O f. Proof. rapply O_inverts_from_extendable. intros; rapply extendable_conn_map_inO. Defined. (** As a consequence, connected maps between modal types are equivalences. *) Definition isequiv_conn_map_ino {A B : Type} (f : A -> B) `{In O A} `{In O B} `{IsConnMap O _ _ f} : IsEquiv f := isequiv_commsq' f (O_functor O f) (to O A) (to O B) (to_O_natural O f). (** Connectedness is preserved by [O_functor]. *) Global Instance conn_map_O_functor {A B} (f : A -> B) `{IsConnMap O _ _ f} : IsConnMap O (O_functor O f). Proof. unfold O_functor. rapply conn_map_compose. Defined. (** Connected maps are preserved by coproducts *) Definition conn_map_sum {A B A' B'} (f : A -> A') (g : B -> B') `{IsConnMap O _ _ f} `{IsConnMap O _ _ g} : IsConnMap O (functor_sum f g). Proof. apply conn_map_from_extension_elim; intros. apply extension_functor_sum; rapply ooextendable_conn_map_inO. Defined. (** Connected maps are preserved by coequalizers *) Definition conn_map_functor_coeq {B A B' A'} {f g : B -> A} {f' g' : B' -> A'} (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) `{IsConnMap O _ _ k} `{IsConnMap O _ _ h} : IsConnMap O (functor_coeq h k p q). Proof. apply conn_map_from_extension_elim; intros. apply extension_functor_coeq. - rapply ooextendable_conn_map_inO. - intros; rapply ooextendable_conn_map_inO. Defined. (** And by pushouts *) Definition conn_map_functor_pushout {A B C A' B' C'} (f : A -> B) (g : A -> C) {f' : A' -> B'} {g' : A' -> C'} (h : A -> A') (k : B -> B') (l : C -> C') (p : k o f == f' o h) (q : l o g == g' o h) `{IsConnMap O _ _ h} `{IsConnMap O _ _ k} `{IsConnMap O _ _ l} : IsConnMap O (functor_pushout h k l p q). Proof. apply conn_map_from_extension_elim; intros. apply extension_functor_coeq. - apply extendable_functor_sum; rapply ooextendable_conn_map_inO. - intros; rapply ooextendable_conn_map_inO. Defined. End ConnectedMaps. (** ** Containment of (reflective) subuniverses *) (** One subuniverse is contained in another if every [O1]-modal type is [O2]-modal. We define this parametrized by three universes: [O1] and [O2] are reflective subuniverses of [Type@{i1}] and [Type@{i2}] respectively, and the relation says that all types in [Type@{j}] that [O1]-modal are also [O2]-modal. This implies [j <= i1] and [j <= i2], of course. The most common application is when [i1 = i2 = j], but it's sometimes useful to talk about a subuniverse of a larger universe agreeing with a subuniverse of a smaller universe on the smaller universe. *) Class O_leq@{i1 i2 j} (O1 : Subuniverse@{i1}) (O2 : Subuniverse@{i2}) := inO_leq : forall (A : Type@{j}), In O1 A -> In O2 A. Arguments inO_leq O1 O2 {_} A _. Declare Scope subuniverse_scope. Notation "O1 <= O2" := (O_leq O1 O2) : subuniverse_scope. Open Scope subuniverse_scope. Global Instance reflexive_O_leq : Reflexive O_leq | 10. Proof. intros O A ?; assumption. Defined. Global Instance transitive_O_leq : Transitive O_leq | 10. Proof. intros O1 O2 O3 O12 O23 A ?. rapply (@inO_leq O2 O3). rapply (@inO_leq O1 O2). Defined. Definition mapinO_O_leq (O1 O2 : Subuniverse) `{O1 <= O2} {A B : Type} (f : A -> B) `{MapIn O1 A B f} : MapIn O2 f. Proof. intros b; rapply (inO_leq O1 O2). Defined. (** This implies that every [O2]-connected type is [O1]-connected, and similarly for maps and equivalences. We give universe annotations so that [O1] and [O2] don't have to be on the same universe, but we do have to have [i1 <= i2] for this statement. When [i2 <= i1] it seems that the statement might not be true unless the RSU on the larger universe is accessibly extended from the smaller one; see [Localization.v]. *) Definition isconnected_O_leq@{i1 i2} (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{O_leq@{i1 i2 i1} O1 O2} (A : Type@{i1}) `{IsConnected O2 A} : IsConnected O1 A. Proof. apply isconnected_from_elim. intros C C1 f. apply (isconnected_elim O2); srapply inO_leq; exact _. Defined. (** This one has the same universe constraint [i1 <= i2]. *) Definition conn_map_O_leq@{i1 i2} (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{O_leq@{i1 i2 i1} O1 O2} {A B : Type@{i1}} (f : A -> B) `{IsConnMap O2 A B f} : IsConnMap O1 f. Proof. (** We could prove this by applying [isconnected_O_leq] fiberwise, but unless we were very careful that would collapse the two universes [i1] and [i2]. So instead we just give an analogous direct proof. *) apply conn_map_from_extension_elim. intros P P_inO g. rapply (extension_conn_map_elim O2). intros b; rapply (inO_leq O1). Defined. (** This is Lemma 2.12(i) in CORS, again with the same universe constraint [i1 <= i2]. *) Definition O_inverts_O_leq@{i1 i2} (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{O_leq@{i1 i2 i1} O1 O2} {A B : Type@{i1}} (f : A -> B) `{O_inverts O2 f} : O_inverts O1 f. Proof. apply O_inverts_from_extendable@{i1 i1 i1 i1 i1}; intros Z Z_inO. pose (inO_leq O1 O2 Z _). apply (lift_extendablealong@{i1 i1 i1 i1 i1 i1 i2 i1 i1 i2 i1}). apply (ooextendable_O_inverts O2); exact _. Defined. (** ** Equality of (reflective) subuniverses *) (** Two subuniverses are the same if they have the same modal types. The universe parameters are the same as for [O_leq]: [O1] and [O2] are reflective subuniverses of [Type@{i1}] and [Type@{i2}], and the relation says that they agree when restricted to [Type@{j}], where [j <= i1] and [j <= i2]. *) Class O_eq@{i1 i2 j} (O1 : Subuniverse@{i1}) (O2 : Subuniverse@{i2}) := { O_eq_l : O_leq@{i1 i2 j} O1 O2 ; O_eq_r : O_leq@{i2 i1 j} O2 O1 ; }. Global Existing Instances O_eq_l O_eq_r. Infix "<=>" := O_eq : subuniverse_scope. Definition issig_O_eq O1 O2 : _ <~> O_eq O1 O2 := ltac:(issig). Global Instance reflexive_O_eq : Reflexive O_eq | 10. Proof. intros; split; reflexivity. Defined. Global Instance transitive_O_eq : Transitive O_eq | 10. Proof. intros O1 O2 O3; split; refine (transitivity (y := O2) _ _). Defined. Global Instance symmetric_O_eq : Symmetric O_eq | 10. Proof. intros O1 O2 [? ?]; split; assumption. Defined. Definition issig_subuniverse : _ <~> Subuniverse := ltac:(issig). Definition equiv_path_subuniverse `{Univalence} (O1 O2 : Subuniverse) : (O1 <=> O2) <~> (O1 = O2). Proof. refine (_ oE (issig_O_eq O1 O2)^-1). revert O1 O2; refine (equiv_path_along_equiv issig_subuniverse _). cbn; intros O1 O2. refine (equiv_path_sigma_hprop O1 O2 oE _). destruct O1 as [O1 [O1h ?]]; destruct O2 as [O2 [O2h ?]]; cbn. refine (equiv_path_arrow _ _ oE _). srapply (equiv_iff_hprop). - srapply istrunc_sigma; unfold O_leq; exact _. - intros [h k] A; specialize (h A); specialize (k A); cbn in *. apply path_universe_uncurried, equiv_iff_hprop; assumption. - intros h; split; intros A e; specialize (h A); cbn in *. 1:rewrite <- h. 2:rewrite h. all:exact e. Defined. (** It should also be true that if [O1] and [O2] are reflective subuniverses, then [O1 <=> O2] is equivalent to [O1 = O2 :> ReflectiveSubuniverse]. Probably [contr_typeof_O_unit] should be useful in proving that. *) (** Reflections into one subuniverse are also reflections into an equal one. Unfortunately these almost certainly can't be [Instance]s for fear of infinite loops, since [<=>] is reflexive. *) Definition prereflects_O_leq (O1 O2 : Subuniverse) `{O1 <= O2} (A : Type) `{PreReflects O1 A} : PreReflects O2 A. Proof. unshelve econstructor. - exact (O_reflector O1 A). - rapply (inO_leq O1 O2). - exact (to O1 A). Defined. Definition reflects_O_eq (O1 O2 : Subuniverse) `{O1 <=> O2} (A : Type) `{Reflects O1 A} : @Reflects O2 A (prereflects_O_leq O1 O2 A). Proof. constructor; intros B B_inO2. pose proof (inO_leq O2 O1 _ B_inO2). apply (extendable_to_O O1). Defined. (** ** Separated subuniverses *) (** For any subuniverse [O], a type is [O]-separated iff all its identity types are [O]-modal. We will study these further in [Separated.v], but we put the definition here because it's needed in [Descent.v]. *) Definition Sep (O : Subuniverse) : Subuniverse. Proof. unshelve econstructor. - intros A; exact (forall (x y:A), In O (x = y)). - exact _. - intros T U ? f ? x y; cbn in *. refine (inO_equiv_inO' _ (equiv_ap f^-1 x y)^-1). Defined. Global Instance inO_paths_SepO (O : Subuniverse) {A : Type} {A_inO : In (Sep O) A} (x y : A) : In O (x = y) := A_inO x y. (** TODO: Where to put this? Morally it goes with the study of [<<] in [Modality.v] and [<<<] in [Descent.v] and [Sep] in [Separated.v], but it doesn't actually need any of those relations, only [O' <= Sep O], and it would also be nice to have it next to [O_inverts_functor_coeq]. It's a variation on the latter: if [O' <= Sep O], then for [O'] to invert [functor_coeq h k] it suffices that it invert [k] and that [h] be [O]-connected (by [conn_map_OO_inverts], which has different hypotheses but applies in many of the same examples, that is a weaker assumption). *) Definition OO_inverts_functor_coeq (O O' : ReflectiveSubuniverse) `{O' <= Sep O} {B A : Type} (f g : B -> A) {B' A' : Type} (f' g' : B' -> A') (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) `{O_inverts O' k} `{IsConnMap O _ _ h} : O_inverts O' (functor_coeq h k p q). Proof. apply O_inverts_from_extendable. intros Z Z_inO. apply extendable_functor_coeq. - nrapply (ooextendable_O_inverts O'); assumption. - pose (inO_leq O' (Sep O)). intros u v; rapply (extendable_conn_map_inO O). Defined. (** And a similar property for pushouts *) Definition OO_inverts_functor_pushout (O O' : ReflectiveSubuniverse) `{O' <= Sep O} {A B C A' B' C'} (f : A -> B) (g : A -> C) {f' : A' -> B'} {g' : A' -> C'} (h : A -> A') (k : B -> B') (l : C -> C') (p : k o f == f' o h) (q : l o g == g' o h) `{IsConnMap O _ _ h} `{O_inverts O' k} `{O_inverts O' l} : O_inverts O' (functor_pushout h k l p q). Proof. nrapply (OO_inverts_functor_coeq O O'). 1,3:exact _. rapply O_inverts_functor_sum. Defined. (** And similar properties for connected maps *) Definition OO_conn_map_functor_coeq (O O' : ReflectiveSubuniverse) `{O' <= Sep O} {B A B' A'} {f g : B -> A} {f' g' : B' -> A'} (h : B -> B') (k : A -> A') (p : k o f == f' o h) (q : k o g == g' o h) `{IsConnMap O' _ _ k} `{IsConnMap O _ _ h} : IsConnMap O' (functor_coeq h k p q). Proof. apply conn_map_from_extension_elim; intros. apply extension_functor_coeq. - rapply ooextendable_conn_map_inO. - pose (inO_leq O' (Sep O)); intros; rapply (ooextendable_conn_map_inO O). Defined. Definition OO_conn_map_functor_pushout (O O' : ReflectiveSubuniverse) `{O' <= Sep O} {A B C A' B' C'} (f : A -> B) (g : A -> C) {f' : A' -> B'} {g' : A' -> C'} (h : A -> A') (k : B -> B') (l : C -> C') (p : k o f == f' o h) (q : l o g == g' o h) `{IsConnMap O _ _ h} `{IsConnMap O' _ _ k} `{IsConnMap O' _ _ l} : IsConnMap O' (functor_pushout h k l p q). Proof. apply conn_map_from_extension_elim; intros. apply extension_functor_coeq. - apply extendable_functor_sum; rapply ooextendable_conn_map_inO. - pose (inO_leq O' (Sep O)); intros; rapply ooextendable_conn_map_inO. Defined. #[export] Hint Immediate inO_isequiv_to_O : typeclass_instances. #[export] Hint Immediate inO_unsigma : typeclass_instances. #[export] Hint Immediate isconnected_conn_map_to_unit : typeclass_instances. Coq-HoTT-9.0/theories/Modalities/Separated.v000066400000000000000000000227431474641544500207610ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types HoTT.Cubical.DPath. Require Import HFiber Extensions Factorization Limits.Pullback. Require Import Modality Accessible Descent. Require Import Truncations.Core. Require Import Homotopy.Suspension. Local Open Scope path_scope. Local Open Scope subuniverse_scope. (** * Subuniverses of separated types *) (** The basic reference for subuniverses of separated types is - Christensen, Opie, Rijke, and Scoccola, "Localization in Homotopy Type Theory", https://arxiv.org/abs/1807.04155. hereinafter referred to as "CORS". *) (** ** Definition *) (** The definition is in [ReflectiveSubuniverse.v]. *) (** ** Basic properties *) (** A function is (fiberwise) in [Sep O] exactly when its diagonal is in [O]. *) Section Diagonal. Context (O : Subuniverse) {X Y : Type} (f : X -> Y). Definition mapinO_diagonal `{MapIn (Sep O) _ _ f} : MapIn O (diagonal f). Proof. intros p. refine (inO_equiv_inO' _ (hfiber_diagonal f p)^-1). Defined. Definition mapinO_from_diagonal `{MapIn O _ _ (diagonal f)} : MapIn (Sep O) f. Proof. intros x1 u v. destruct v as [x2 p]. destruct p. refine (inO_equiv_inO' _ (hfiber_diagonal f (u.1; x2; u.2))). Defined. End Diagonal. (** Lemma 2.15 of CORS: If [O] is accessible, so is [Sep O]. Its generators are the suspension of those of [O], in the following sense: *) Definition susp_localgen (f : LocalGenerators@{a}) : LocalGenerators@{a}. Proof. econstructor; intros i. exact (functor_susp (f i)). Defined. Global Instance isaccrsu_sep (O : Subuniverse) `{IsAccRSU O} : IsAccRSU (Sep O). Proof. exists (susp_localgen (acc_lgen O)). intros A; split; intros A_inO. { intros i. apply (ooextendable_iff_functor_susp (acc_lgen O i)). intros [x y]. cbn in *. refine (ooextendable_postcompose' _ _ _ _ _). 2:apply inO_iff_islocal; exact (A_inO x y). intros b. apply dp_const. } { intros x y. apply (inO_iff_islocal O); intros i. specialize (A_inO i). refine (ooextendable_postcompose' _ _ _ _ _). 2:exact (fst (ooextendable_iff_functor_susp (acc_lgen O i) _) A_inO (x,y)). intros b. symmetry; apply dp_const. } Defined. Definition susp_nullgen (S : NullGenerators@{a}) : NullGenerators@{a}. Proof. econstructor; intros i. exact (Susp (S i)). Defined. Global Instance isaccmodality_sep (O : Subuniverse) `{IsAccModality O} : IsAccModality (Sep O). Proof. exists (susp_nullgen (acc_ngen O)). intros A; split; intros A_inO. { intros i. apply (ooextendable_compose _ (functor_susp (fun _:acc_ngen O i => tt)) (fun _:Susp Unit => tt)). 1:apply ooextendable_equiv, isequiv_contr_contr. apply (ooextendable_iff_functor_susp (fun _:acc_ngen O i => tt)). intros [x y]. refine (ooextendable_postcompose' _ _ _ _ _). 2:apply inO_iff_isnull; exact (A_inO x y). intros b. apply dp_const. } { intros x y. apply (inO_iff_isnull O); intros i. specialize (A_inO i). assert (ee : ooExtendableAlong (functor_susp (fun _:acc_ngen O i => tt)) (fun _ => A)). { refine (cancelL_ooextendable _ _ (fun _ => tt) _ A_inO). apply ooextendable_equiv. apply isequiv_contr_contr. } assert (e := fst (ooextendable_iff_functor_susp (fun _:acc_ngen O i => tt) _) ee (x,y)). cbn in e. refine (ooextendable_postcompose' _ _ _ _ e). intros b. symmetry; apply dp_const. } Defined. (** Remark 2.16(1) of CORS *) Global Instance O_leq_SepO (O : ReflectiveSubuniverse) : O <= Sep O. Proof. intros A ? x y; exact _. Defined. (** Part of Remark 2.16(2) of CORS *) Definition in_SepO_embedding (O : Subuniverse) {A B : Type} (i : A -> B) `{IsEmbedding i} `{In (Sep O) B} : In (Sep O) A. Proof. intros x y. refine (inO_equiv_inO' _ (equiv_ap_isembedding i x y)^-1). Defined. (* As a special case, if X embeds into an n-type for n >= -1 then X is an n-type. Note that this doesn't hold for n = -2. *) Corollary istrunc_embedding_trunc {X Y : Type} {n : trunc_index} `{istr : IsTrunc n.+1 Y} (i : X -> Y) `{isem : IsEmbedding i} : IsTrunc n.+1 X. Proof. apply istrunc_S. exact (@in_SepO_embedding (Tr n) _ _ i isem istr). Defined. Global Instance in_SepO_hprop (O : ReflectiveSubuniverse) {A : Type} `{IsHProp A} : In (Sep O) A. Proof. srapply (in_SepO_embedding O (const_tt _)). intros x y; exact _. Defined. (** Remark 2.16(4) of CORS *) Definition sigma_closed_SepO (O : Modality) {A : Type} (B : A -> Type) `{A_inO : In (Sep O) A} `{B_inO : forall a, In (Sep O) (B a)} : In (Sep O) (sig B). Proof. intros [x u] [y v]. specialize (A_inO x y). pose proof (fun p:x=y => B_inO y (p # u) v). pose @inO_sigma. (* Speed up typeclass search. *) refine (inO_equiv_inO' _ (equiv_path_sigma B _ _)). Defined. (** Lemma 2.17 of CORS *) Global Instance issurjective_to_SepO (O : ReflectiveSubuniverse) (X : Type) `{Reflects (Sep O) X} : IsSurjection (to (Sep O) X). Proof. pose (im := himage (to (Sep O) X)). pose proof (in_SepO_embedding O (factor2 im)). pose (s := O_rec (factor1 im)). assert (h : factor2 im o s == idmap). - apply O_indpaths; intros x; subst s. rewrite O_rec_beta. apply fact_factors. - apply BuildIsSurjection. intros z. specialize (h z); cbn in h. set (w := s z) in *. destruct w as [w1 w2]. destruct h. exact w2. Defined. (** Proposition 2.18 of CORS. *) Definition almost_inSepO_typeO@{i j} `{Univalence} (O : ReflectiveSubuniverse) (A B : Type_@{i j} O) : { Z : Type@{i} & In O Z * (Z <~> (A = B)) }. Proof. exists (A <~> B); split. - exact _. - refine (equiv_path_TypeO O A B oE _). apply equiv_path_universe. Defined. (** Lemma 2.21 of CORS *) Global Instance inSepO_sigma (O : ReflectiveSubuniverse) {X : Type} {P : X -> Type} `{In (Sep O) X} `{forall x, In O (P x)} : In (Sep O) (sig P). Proof. intros u v. refine (inO_equiv_inO' _ (equiv_path_sigma P _ _)). Defined. (** Proposition 2.22 of CORS (in funext-free form). *) Global Instance reflectsD_SepO (O : ReflectiveSubuniverse) {X : Type} `{Reflects (Sep O) X} : ReflectsD (Sep O) O X. Proof. srapply reflectsD_from_inO_sigma. Defined. (** Once we know that [Sep O] is a reflective subuniverse, this will mean that [O << Sep O]. *) (** And now the version with funext. *) Definition isequiv_toSepO_inO `{Funext} (O : ReflectiveSubuniverse) {X : Type} `{Reflects (Sep O) X} (P : O_reflector (Sep O) X -> Type) `{forall x, In O (P x)} : IsEquiv (fun g : (forall y, P y) => g o to (Sep O) X) := isequiv_ooextendable _ _ (extendable_to_OO P). Definition equiv_toSepO_inO `{Funext} (O : ReflectiveSubuniverse) {X : Type} `{Reflects (Sep O) X} (P : O_reflector (Sep O) X -> Type) `{forall x, In O (P x)} : (forall y, P y) <~> (forall x, P (to (Sep O) X x)) := Build_Equiv _ _ _ (isequiv_toSepO_inO O P). (** TODO: Actually prove this, and put it somewhere more appropriate. *) Section JoinConstruction. Universes i j. Context {X : Type@{i}} {Y : Type@{j}} (f : X -> Y) (ls : forall (y1 y2 : Y), @sig@{j j} Type@{i} (fun (Z : Type@{i}) => Equiv@{i j} Z (y1 = y2))). Definition jc_image@{} : Type@{i}. Admitted. Definition jc_factor1@{} : X -> jc_image. Admitted. Definition jc_factor2@{} : jc_image -> Y. Admitted. Definition jc_factors@{} : jc_factor2 o jc_factor1 == f. Admitted. Global Instance jc_factor1_issurj@{} : IsSurjection jc_factor1. Admitted. Global Instance jc_factor2_isemb : IsEmbedding jc_factor2. Admitted. End JoinConstruction. (** We'd like to say that the universe of [O]-modal types is [O]-separated, i.e. belongs to [Sep O]. But since a given subuniverse like [Sep O] lives only on a single universe size, trying to say that in the naive way yields a universe inconsistency. *) Fail Goal forall (O : ReflectiveSubuniverse), In (Sep O) (Type_ O). (** Instead, we do as in Lemma 2.19 of CORS and prove the morally-equivalent "descent" property, using Lemma 2.18 and the join construction. *) Global Instance SepO_lex_leq `{Univalence} (O : ReflectiveSubuniverse) {X : Type} `{Reflects (Sep O) X} : Descends (Sep O) O X. Proof. assert (e : forall (P : X -> Type_ O), { Q : (O_reflector (Sep O) X -> Type_ O) & forall x, Q (to (Sep O) X x) <~> P x }). 2:{ unshelve econstructor; intros P' P_inO; pose (P := fun x => (P' x; P_inO x) : Type_ O); pose (ee := e P). - exact ee.1. - simpl; exact _. - intros x; cbn; apply ee.2. } intros P. assert (ls : forall A B : Type_ O, { Z : Type & Z <~> (A = B) }). { intros A B. pose (q := almost_inSepO_typeO O A B). exact (q.1; snd q.2). } pose (p := jc_factor2 P ls). set (J := jc_image P ls) in p. assert (In (Sep O) J). { intros x y. pose (q := almost_inSepO_typeO O (p x) (p y)). refine (inO_equiv_inO' q.1 _). refine (_ oE _). - symmetry; srapply (equiv_ap_isembedding p). - exact (snd q.2). } pose (O_rec (O := Sep O) (jc_factor1 P ls)). exists (p o j). intros x; subst p j. rewrite O_rec_beta. apply equiv_path. exact ((jc_factors P ls x)..1). Defined. (** Once we know that [Sep O] is a reflective subuniverse, this will imply [O <<< Sep O], and that if [Sep O] is accessible (such as if [O] is) then [Type_ O] belongs to its accessible lifting (see [inO_TypeO_lex_leq]. *) (** ** Reflectiveness of [Sep O] *) (** TODO *) (** ** Left-exactness properties *) (** Nearly all of these are true in the generality of a pair of reflective subuniverses with [O <<< O'] and/or [O' <= Sep O], and as such can be found in [Descent.v]. *) Coq-HoTT-9.0/theories/Modalities/Topological.v000066400000000000000000000154041474641544500213210ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Extensions HoTT.Truncations. Require Import Accessible Lex Nullification. Local Open Scope path_scope. (** * Topological localizations *) (** A topological localization -- or, as we will say, a topological nullification -- is a nullification at a family of hprops, or more generally an accessible modality whose generators of accessibility are all hprops. This is not quite the same as Lurie's definition: in Higher Topos Theory, a topological localization is an accessible *left exact* localization at a pullback-stable class generated by a set of monomorphisms. "Pullback-stable class generated by" is roughly incorporated into our internal notion of accessibility, so the main new difference here is that when the generation is internal in this way, the localization at a family of hprops is *automatically* left exact. *) Notation Topological O := (forall i, IsHProp (acc_ngen O i)). (** ** Topological modalities are lex *) (** We prove left-exactness by proving that the universe of modal types is modal, using univalence. It's unclear whether univalence is necessary or not in general; in one special case (open modalities) funext suffices. But it's plausible that it would be necessary in general, because lex-ness of nullification is a statement about the path-spaces of a HIT, and characterizing those in any way usually requires some amount of univalence. *) Global Instance lex_topological `{Univalence} (O : Modality) `{IsAccModality O} `{Topological O} : Lex O. Proof. snrapply lex_from_inO_typeO; [ exact _ | intros i ]. apply ((equiv_ooextendable_isequiv _ _)^-1%equiv). srapply isequiv_adjointify; cbn. - intros B _. refine ((forall a, B a) ; _). exact _. - intros B. apply path_arrow; intros a. apply path_TypeO, path_universe_uncurried. unfold composeD; simpl. simple refine (equiv_adjointify _ _ _ _). + intros f. exact (f a). + intros b a'. exact (transport B (path_ishprop a a') b). + intros b. refine (transport2 B (path_contr _ 1) b). + intros f. apply path_forall; intros a'. exact (apD f _). - intros B. apply path_arrow; intros []. apply path_TypeO, path_universe_uncurried. unfold composeD; simpl. pose (e := isequiv_ooextendable _ _ (fst (inO_iff_isnull O (B tt)) (inO_TypeO (B tt)) i)). unfold composeD in e; simpl in e. refine (_ oE (Build_Equiv _ _ _ e)^-1). exact (equiv_contr_forall _). Defined. Global Instance lex_nullification `{Univalence} (S : NullGenerators) `{forall i, IsHProp (S i)} : Lex (Nul S). Proof. rapply lex_topological. Defined. (** ** Lex modalities generated by n-types are topological *) (** For [n >= 0], nullification at a family of [n]-types need not be lex. For instance, the (-1)-truncation is nullification at [Bool]. However, if the nullification at a family of [n]-types *is* lex, then it is topological. *) (** This is kind of annoying to prove, not just because the proof is fiddly, but because we have to pass back and forth between different generating families for the "same" modality. It's a bit easier to prove it about nullifications than about arbitrary accessible lex modalities. *) Definition topological_lex_trunc_acc `{Funext} (B : NullGenerators) {Olex : Lex (Nul B)} (n : trunc_index) (gtr : forall a, IsTrunc n (ngen_type B a)) : { D : NullGenerators & (forall c, IsHProp (ngen_type D c)) * (Nul D <=> Nul B) }. Proof. destruct n. { exists (Build_NullGenerators Empty (fun _ => Unit)). split; [ exact _ | split; intros X _; [ | intros [] ] ]. intros i. apply ooextendable_equiv, isequiv_contr_contr. } pose (O := Nul B). pose (OeqB := reflexive_O_eq O : O <=> (Nul B)). change (Nul B) with O in Olex. clearbody O OeqB. revert B OeqB gtr. induction n; intros B OeqB gtr. { exists B; split; [ assumption | reflexivity ]. } pose (A := ngen_indices B). pose (C := A + { a:A & B(a) * B(a) }). pose (D := Build_NullGenerators C (fun c:C => match c with | inl a => merely (B a) | inr (a ; (b1, b2)) => (b1 = b2) end : Type)). assert (Dtrunc : forall c:C, IsTrunc n.+1 (D c)). { intros [a | [a [b1 b2]]]; [ cbn | exact _ ]. (* Because [trunc_hprop] can't be used as an idmap... *) destruct n; exact _. } assert (OeqD : O <=> (Nul D)). { split; intros X. - intros X_inO c. assert (Bc : forall a:A, IsConnected O (B a)). { intros a. rapply (@isconnected_O_leq O (Nul B)). exact (isconnected_acc_ngen (Nul B) a). } apply (ooextendable_const_isconnected_inO O); [ destruct c as [a | [a [b1 b2]]] | exact X_inO ]. + apply isconnected_from_elim_to_O. destruct (isconnected_elim O (O (merely (B a))) (fun b => to O _ (tr b))) as [x h]. exists x; intros y; cbn in y. strip_truncations. exact (h y). + cbn. rapply isconnected_paths. - intros Dnull; rapply (@inO_leq (Nul B) O). intros a; cbn in a; cbn. apply ((equiv_ooextendable_isequiv (unit_name X) (fun _:B a => tt))^-1). apply isequiv_contr_map; intros f; cbn in f. refine (contr_equiv' { x:X & forall u:B a, x = f u } _). { refine (equiv_functor_sigma' (equiv_unit_rec X) _). intros x; unfold composeD; cbn. apply equiv_path_arrow. } refine ((isconnected_elim (Nul D) (A := D (inl a)) _ _).1). { rapply isconnected_acc_ngen. } intros b; cbn in b. strip_truncations. assert (bc : IsConnMap (Nul D) (unit_name b)). { intros x; unfold hfiber. apply (isconnected_equiv (Nul D) (b = x) (equiv_contr_sigma _)^-1). rapply (isconnected_acc_ngen (Nul D) (inr (a;(b,x)))). } pose (p := conn_map_elim (Nul D) (unit_name b) (fun u => f b = f u) (fun _ => 1)). apply (Build_Contr _ (f b ; p)); intros [x q]. refine (path_sigma' _ (q b)^ _); apply path_forall. refine (conn_map_elim (Nul D) (unit_name b) _ _); intros []. rewrite transport_forall_constant, transport_paths_l, inv_V. rewrite (conn_map_comp (Nul D) (unit_name b) (fun u:B a => f b = f u) (fun _ => 1) tt : p b = 1). apply concat_p1. } destruct (IHn D OeqD _) as [E [HE EeqD]]. exists E; split; [ exact HE | ]. refine (transitivity EeqD _). refine (transitivity _ OeqB). symmetry; assumption. Defined. Coq-HoTT-9.0/theories/Pointed.v000066400000000000000000000004231474641544500163500ustar00rootroot00000000000000Require Export Pointed.Core. Require Export Pointed.Loops. Require Export Pointed.pMap. Require Export Pointed.pFiber. Require Export Pointed.pEquiv. Require Export Pointed.pTrunc. Require Export Pointed.pModality. Require Export Pointed.pSusp. Require Export Pointed.pSect. Coq-HoTT-9.0/theories/Pointed/000077500000000000000000000000001474641544500161625ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Pointed/Core.v000066400000000000000000001100171474641544500172410ustar00rootroot00000000000000Require Import Basics Types. Require Import Homotopy.IdentitySystems. Require Import WildCat. Require Import Truncations.Core. Require Import ReflectiveSubuniverse. Require Import Extensions. Local Set Polymorphic Inductive Cumulativity. Declare Scope pointed_scope. Local Open Scope pointed_scope. Local Open Scope path_scope. Generalizable Variables A B f. (** ** Pointed Types *) Notation "'pt'" := (point _) : pointed_scope. Notation "[ X , x ]" := (Build_pType X x) : pointed_scope. (** The unit type is pointed *) Global Instance ispointed_unit : IsPointed Unit := tt. (** The Unit pType *) Definition pUnit : pType := [Unit, tt]. (** A sigma type of pointed components is pointed. *) Global Instance ispointed_sigma `{IsPointed A} `{IsPointed (B (point A))} : IsPointed (sig B) := (point A; point (B (point A))). (** A product of pointed types is pointed. *) Global Instance ispointed_prod `{IsPointed A, IsPointed B} : IsPointed (A * B) := (point A, point B). (** We override the notation for products in pointed_scope *) Notation "X * Y" := ([X * Y, ispointed_prod]) : pointed_scope. (** A pointed type family consists of a type family over a pointed type and a section of that family at the basepoint. By making this a Record, it has one fewer universe variable, and is cumulative. We declare [pfam_pr1] to be a coercion [pFam >-> Funclass]. *) Record pFam (A : pType) := { pfam_pr1 :> A -> Type; dpoint : pfam_pr1 (point A)}. Arguments Build_pFam {A} _ _. Arguments pfam_pr1 {A} P : rename. Arguments dpoint {A} P : rename. (** The constant pointed family *) Definition pfam_const {A : pType} (B : pType) : pFam A := Build_pFam (fun _ => pointed_type B) (point B). (** [IsTrunc] for a pointed type family *) Class IsTrunc_pFam n {A} (P : pFam A) := trunc_pfam_is_trunc : forall x, IsTrunc n (P x). (** Pointed dependent functions *) Record pForall (A : pType) (P : pFam A) := { pointed_fun : forall x, P x ; dpoint_eq : pointed_fun (point A) = dpoint P ; }. Arguments dpoint_eq {A P} f : rename. Arguments pointed_fun {A P} f : rename. Coercion pointed_fun : pForall >-> Funclass. (** ** Pointed functions *) (** A pointed map is a map with a proof that it preserves the point. We define it as as a notation for a non-dependent version of [pForall]. *) Notation "A ->* B" := (pForall A (pfam_const B)) : pointed_scope. Definition Build_pMap (A B : pType) (f : A -> B) (p : f (point A) = point B) : A ->* B := Build_pForall A (pfam_const B) f p. (** The [&] tells Coq to use the context to infer the later arguments (in this case, all of them). *) Arguments Build_pMap & _ _ _ _. (** Pointed maps perserve the base point *) Definition point_eq {A B : pType} (f : A ->* B) : f (point A) = point B := dpoint_eq f. (** The identity pointed map *) Definition pmap_idmap {A : pType} : A ->* A := Build_pMap A A idmap 1. (** Composition of pointed maps *) Definition pmap_compose {A B C : pType} (g : B ->* C) (f : A ->* B) : A ->* C := Build_pMap A C (g o f) (ap g (point_eq f) @ point_eq g). Infix "o*" := pmap_compose : pointed_scope. (** ** Pointed homotopies *) (** A pointed homotopy is a homotopy with a proof that the presevation paths agree. We define it instead as a special case of a [pForall]. This means that we can define pointed homotopies between pointed homotopies. *) Definition pfam_phomotopy {A : pType} {P : pFam A} (f g : pForall A P) : pFam A := Build_pFam (fun x => f x = g x) (dpoint_eq f @ (dpoint_eq g)^). Definition pHomotopy {A : pType} {P : pFam A} (f g : pForall A P) := pForall A (pfam_phomotopy f g). Infix "==*" := pHomotopy : pointed_scope. Definition Build_pHomotopy {A : pType} {P : pFam A} {f g : pForall A P} (p : f == g) (q : p (point A) = dpoint_eq f @ (dpoint_eq g)^) : f ==* g := Build_pForall A (pfam_phomotopy f g) p q. (** The underlying homotopy of a pointed homotopy *) Coercion pointed_htpy {A : pType} {P : pFam A} {f g : pForall A P} (h : f ==* g) : f == g := h. (** This is the form that the underlying proof of a pointed homotopy used to take before we changed it to be defined in terms of pForall. *) Definition point_htpy {A : pType} {P : pFam A} {f g : pForall A P} (h : f ==* g) : h (point A) @ dpoint_eq g = dpoint_eq f. Proof. apply moveR_pM. exact (dpoint_eq h). Defined. (** ** Pointed equivalences *) (** A pointed equivalence is a pointed map and a proof that it is an equivalence *) Record pEquiv (A B : pType) := { pointed_equiv_fun : pForall A (pfam_const B) ; pointed_isequiv : IsEquiv pointed_equiv_fun ; }. (** TODO: It might be better behaved to define pEquiv as an equivalence and a proof that this equivalence is pointed. In pEquiv.v we have another constructor Build_pEquiv' which coq can infer faster than Build_pEquiv. *) Infix "<~>*" := pEquiv : pointed_scope. (** Note: because we define pMap as a special case of pForall, we must declare all coercions into pForall, *not* into pMap. *) Coercion pointed_equiv_fun : pEquiv >-> pForall. Global Existing Instance pointed_isequiv. Coercion pointed_equiv_equiv {A B} (f : A <~>* B) : A <~> B := Build_Equiv A B f _. (** The pointed identity is a pointed equivalence *) Definition pequiv_pmap_idmap {A} : A <~>* A := Build_pEquiv _ _ pmap_idmap _. (** Pointed sigma types *) Definition psigma {A : pType} (P : pFam A) : pType := [sig P, (point A; dpoint P)]. (** *** Pointed products *) (** Pointed pi types; note that the domain is not pointed *) Definition pproduct {A : Type} (F : A -> pType) : pType := [forall (a : A), pointed_type (F a), ispointed_type o F]. Definition pproduct_corec `{Funext} {A : Type} (F : A -> pType) (X : pType) (f : forall a, X ->* F a) : X ->* pproduct F. Proof. snrapply Build_pMap. - intros x a. exact (f a x). - cbn. funext a. apply point_eq. Defined. Definition pproduct_proj {A : Type} {F : A -> pType} (a : A) : pproduct F ->* F a. Proof. snrapply Build_pMap. - intros x. exact (x a). - reflexivity. Defined. (** The projections from a pointed product are pointed maps. *) Definition pfst {A B : pType} : A * B ->* A := Build_pMap (A * B) A fst idpath. Definition psnd {A B : pType} : A * B ->* B := Build_pMap (A * B) B snd idpath. Definition pprod_corec {X Y} (Z : pType) (f : Z ->* X) (g : Z ->* Y) : Z ->* (X * Y) := Build_pMap Z (X * Y) (fun z => (f z, g z)) (path_prod' (point_eq _) (point_eq _)). Definition pprod_corec_beta_fst {X Y} (Z : pType) (f : Z ->* X) (g : Z ->* Y) : pfst o* pprod_corec Z f g ==* f. Proof. snrapply Build_pHomotopy. 1: reflexivity. apply moveL_pV. refine (concat_1p _ @ _^ @ (concat_p1 _)^). apply ap_fst_path_prod'. Defined. Definition pprod_corec_beta_snd {X Y} (Z : pType) (f : Z ->* X) (g : Z ->* Y) : psnd o* pprod_corec Z f g ==* g. Proof. snrapply Build_pHomotopy. 1: reflexivity. apply moveL_pV. refine (concat_1p _ @ _^ @ (concat_p1 _)^). apply ap_snd_path_prod'. Defined. (** The following tactics often allow us to "pretend" that pointed maps and homotopies preserve basepoints strictly. *) (** First a version with no rewrites, which leaves some cleanup to be done but which can be used in transparent proofs. *) Ltac pointed_reduce := (*TODO: are these correct? *) unfold pointed_fun, pointed_htpy; cbn in *; repeat match goal with | [ X : pType |- _ ] => destruct X as [X ?point] | [ P : pFam ?X |- _ ] => destruct P as [P ?] | [ phi : pForall ?X ?Y |- _ ] => destruct phi as [phi ?] | [ alpha : pHomotopy ?f ?g |- _ ] => let H := fresh in destruct alpha as [alpha H]; try (apply moveR_pM in H) | [ equiv : pEquiv ?X ?Y |- _ ] => destruct equiv as [equiv ?iseq] end; cbn in *; unfold point in *; path_induction; cbn. (** Next a version that uses [rewrite], and should only be used in opaque proofs. *) Ltac pointed_reduce_rewrite := pointed_reduce; rewrite ?concat_p1, ?concat_1p. (** Finally, a version that just strictifies a single map or equivalence. This has the advantage that it leaves the context more readable. *) Ltac pointed_reduce_pmap f := try match type of f with | pEquiv ?X ?Y => destruct f as [f ?iseq] end; match type of f with | _ ->* ?Y => let p := fresh in destruct Y as [Y ?], f as [f p]; cbn in *; destruct p; cbn end. (** A general tactic to replace pointedness paths in a pForall with reflexivity. Because it generalizes [f pt], it can usually only be applied once the function itself is not longer needed. Compared to [pointed_reduce], an advantage is that the pointed types do not need to be destructed. *) Ltac pelim f := try match type of f with | pEquiv ?X ?Y => destruct f as [f ?iseq]; unfold pointed_fun in * end; destruct f as [f ?ptd]; cbn in f, ptd |- *; match type of ptd with ?fpt = _ => generalize dependent fpt end; nrapply paths_ind_r; try clear f. Tactic Notation "pelim" constr(x0) := pelim x0. Tactic Notation "pelim" constr(x0) constr(x1) := pelim x0; pelim x1. Tactic Notation "pelim" constr(x0) constr(x1) constr(x2) := pelim x0; pelim x1 x2. Tactic Notation "pelim" constr(x0) constr(x1) constr(x2) constr(x3) := pelim x0; pelim x1 x2 x3. Tactic Notation "pelim" constr(x0) constr(x1) constr(x2) constr(x3) constr(x4) := pelim x0; pelim x1 x2 x3 x4. Tactic Notation "pelim" constr(x0) constr(x1) constr(x2) constr(x3) constr(x4) constr(x5) := pelim x0; pelim x1 x2 x3 x4 x5. Tactic Notation "pelim" constr(x0) constr(x1) constr(x2) constr(x3) constr(x4) constr(x5) constr(x6) := pelim x0; pelim x1 x2 x3 x4 x5 x6. (** ** Equivalences to sigma-types. *) (** pType *) Definition issig_ptype : { X : Type & X } <~> pType := ltac:(issig). (** pForall *) Definition issig_pforall (A : pType) (P : pFam A) : {f : forall x, P x & f (point A) = dpoint P} <~> (pForall A P) := ltac:(issig). (** pMap *) Definition issig_pmap (A B : pType) : {f : A -> B & f (point A) = point B} <~> (A ->* B) := ltac:(issig). (** pHomotopy *) Definition issig_phomotopy {A : pType} {P : pFam A} (f g : pForall A P) : {p : f == g & p (point A) = dpoint_eq f @ (dpoint_eq g)^} <~> (f ==* g) := ltac:(issig). (** pEquiv *) Definition issig_pequiv (A B : pType) : {f : A ->* B & IsEquiv f} <~> (A <~>* B) := ltac:(issig). (** The record for pointed equivalences is equivalently a different sigma type *) Definition issig_pequiv' (A B : pType) : {f : A <~> B & f (point A) = point B} <~> (A <~>* B) := ltac:(make_equiv). (** pForall can also be described as a type of extensions. *) Definition equiv_extension_along_pforall `{Funext} {A : pType} (P : pFam A) : ExtensionAlong@{Set _ _ _} (unit_name (point A)) P (unit_name (dpoint P)) <~> pForall A P. Proof. unfold ExtensionAlong. refine (issig_pforall A P oE _). apply equiv_functor_sigma_id; intro s. symmetry; apply equiv_unit_rec. Defined. (** This is [equiv_prod_coind] for pointed families. *) Definition equiv_pprod_coind {A : pType} (P Q : pFam A) : (pForall A P * pForall A Q) <~> (pForall A (Build_pFam (fun a => prod (P a) (Q a)) (dpoint P, dpoint Q))). Proof. transitivity {p : prod (forall a:A, P a) (forall a:A, Q a) & prod (fst p _ = dpoint P) (snd p _ = dpoint Q)}. 1: make_equiv. refine (issig_pforall _ _ oE _). srapply equiv_functor_sigma'. 1: apply equiv_prod_coind. intro f; cbn. unfold prod_coind_uncurried. exact (equiv_path_prod (fst f _, snd f _) (dpoint P, dpoint Q)). Defined. Definition functor_pprod {A A' B B' : pType} (f : A ->* A') (g : B ->* B') : A * B ->* A' * B'. Proof. snrapply Build_pMap. - exact (functor_prod f g). - apply path_prod; apply point_eq. Defined. (** [isequiv_functor_prod] applies, and is a Global Instance. *) Definition equiv_functor_pprod {A A' B B' : pType} (f : A <~>* A') (g : B <~>* B') : A * B <~>* A' * B' := Build_pEquiv _ _ (functor_pprod f g) _. (** ** Various operations with pointed homotopies *) (** For the following three instances, the typeclass (e.g. [Reflexive]) requires a third universe variable, the maximum of the universe of [A] and the universe of the values of [P]. Because of this, in each case we first prove a version not mentioning the typeclass, which avoids a stray universe variable. *) (** [pHomotopy] is a reflexive relation *) Definition phomotopy_reflexive {A : pType} {P : pFam A} (f : pForall A P) : f ==* f := Build_pHomotopy (fun x => 1) (concat_pV _)^. Global Instance phomotopy_reflexive' {A : pType} {P : pFam A} : Reflexive (@pHomotopy A P) := @phomotopy_reflexive A P. (** [pHomotopy] is a symmetric relation *) Definition phomotopy_symmetric {A P} {f g : pForall A P} (p : f ==* g) : g ==* f. Proof. snrefine (Build_pHomotopy _ _); cbn. 1: intros x; exact ((p x)^). by pelim p f g. Defined. Global Instance phomotopy_symmetric' {A P} : Symmetric (@pHomotopy A P) := @phomotopy_symmetric A P. Notation "p ^*" := (phomotopy_symmetric p) : pointed_scope. (** [pHomotopy] is a transitive relation *) Definition phomotopy_transitive {A P} {f g h : pForall A P} (p : f ==* g) (q : g ==* h) : f ==* h. Proof. snrefine (Build_pHomotopy (fun x => p x @ q x) _). nrefine (dpoint_eq p @@ dpoint_eq q @ concat_pp_p _ _ _ @ _). nrapply whiskerL; nrapply concat_V_pp. Defined. Global Instance phomotopy_transitive' {A P} : Transitive (@pHomotopy A P) := @phomotopy_transitive A P. Notation "p @* q" := (phomotopy_transitive p q) : pointed_scope. (** ** Whiskering of pointed homotopies by pointed functions *) Definition pmap_postwhisker {A B C : pType} {f g : A ->* B} (h : B ->* C) (p : f ==* g) : h o* f ==* h o* g. Proof. snrefine (Build_pHomotopy _ _); cbn. 1: exact (fun x => ap h (p x)). by pelim p f g h. Defined. Definition pmap_prewhisker {A B C : pType} (f : A ->* B) {g h : B ->* C} (p : g ==* h) : g o* f ==* h o* f. Proof. snrefine (Build_pHomotopy _ _); cbn. 1: exact (fun x => p (f x)). by pelim f p g h. Defined. (** ** 1-categorical properties of [pType]. *) (** Composition of pointed maps is associative up to pointed homotopy *) Definition pmap_compose_assoc {A B C D : pType} (h : C ->* D) (g : B ->* C) (f : A ->* B) : (h o* g) o* f ==* h o* (g o* f). Proof. snrapply Build_pHomotopy. 1: reflexivity. by pelim f g h. Defined. (** precomposition of identity pointed map *) Definition pmap_precompose_idmap {A B : pType} (f : A ->* B) : f o* pmap_idmap ==* f. Proof. snrapply Build_pHomotopy. 1: reflexivity. by pelim f. Defined. (** postcomposition of identity pointed map *) Definition pmap_postcompose_idmap {A B : pType} (f : A ->* B) : pmap_idmap o* f ==* f. Proof. snrapply Build_pHomotopy. 1: reflexivity. by pelim f. Defined. (** ** 1-categorical properties of [pForall]. *) Definition phomotopy_postwhisker {A : pType} {P : pFam A} {f g h : pForall A P} {p p' : f ==* g} (r : p ==* p') (q : g ==* h) : p @* q ==* p' @* q. Proof. snrapply Build_pHomotopy. 1: exact (fun x => whiskerR (r x) (q x)). by pelim q r p p' f g h. Defined. Definition phomotopy_prewhisker {A : pType} {P : pFam A} {f g h : pForall A P} (p : f ==* g) {q q' : g ==* h} (s : q ==* q') : p @* q ==* p @* q'. Proof. snrapply Build_pHomotopy. 1: exact (fun x => whiskerL (p x) (s x)). by pelim s q q' p f g h. Defined. Definition phomotopy_compose_assoc {A : pType} {P : pFam A} {f g h k : pForall A P} (p : f ==* g) (q : g ==* h) (r : h ==* k) : p @* (q @* r) ==* (p @* q) @* r. Proof. snrapply Build_pHomotopy. 1: exact (fun x => concat_p_pp (p x) (q x) (r x)). by pelim r q p f g h k. Defined. Definition phomotopy_compose_p1 {A : pType} {P : pFam A} {f g : pForall A P} (p : f ==* g) : p @* reflexivity g ==* p. Proof. srapply Build_pHomotopy. 1: intro; apply concat_p1. by pelim p f g. Defined. Definition phomotopy_compose_1p {A : pType} {P : pFam A} {f g : pForall A P} (p : f ==* g) : reflexivity f @* p ==* p. Proof. srapply Build_pHomotopy. 1: intro x; apply concat_1p. by pelim p f g. Defined. Definition phomotopy_compose_pV {A : pType} {P : pFam A} {f g : pForall A P} (p : f ==* g) : p @* p ^* ==* phomotopy_reflexive f. Proof. srapply Build_pHomotopy. 1: intro x; apply concat_pV. by pelim p f g. Defined. Definition phomotopy_compose_Vp {A : pType} {P : pFam A} {f g : pForall A P} (p : f ==* g) : p ^* @* p ==* phomotopy_reflexive g. Proof. srapply Build_pHomotopy. 1: intro x; apply concat_Vp. by pelim p f g. Defined. (** ** The pointed category structure of [pType] *) (** Pointed types of pointed maps *) (** A family of pointed types gives rise to a [pFam]. *) Definition pointed_fam {A : pType} (B : A -> pType) : pFam A := Build_pFam (pointed_type o B) (point (B (point A))). (** The section of a family of pointed types *) Definition point_pforall {A : pType} (B : A -> pType) : pForall A (pointed_fam B) := Build_pForall A (pointed_fam B) (fun x => point (B x)) 1. (** The pointed type of dependent pointed maps. Note that we need a family of pointed types, not just a family of types with a point over the basepoint of [A]. *) Definition ppForall (A : pType) (B : A -> pType) : pType := [pForall A (pointed_fam B), point_pforall B]. Notation "'ppforall' x .. y , P" := (ppForall _ (fun x => .. (ppForall _ (fun y => P)) ..)) : pointed_scope. (** The constant (zero) map *) Definition pconst {A B : pType} : A ->* B := point_pforall (fun _ => B). (** The pointed type of pointed maps. This is a special case of [ppForall]. *) Definition ppMap (A B : pType) : pType := [A ->* B, pconst]. Infix "->**" := ppMap : pointed_scope. Lemma pmap_punit_pconst {A : pType} (f : A ->* pUnit) : pconst ==* f. Proof. srapply Build_pHomotopy. 1: intro; apply path_unit. apply path_contr. Defined. Lemma punit_pmap_pconst {A : pType} (f : pUnit ->* A) : pconst ==* f. Proof. srapply Build_pHomotopy. 1: intros []; exact (point_eq f)^. exact (concat_1p _)^. Defined. Global Instance contr_pmap_from_contr `{Funext} {A B : pType} `{C : Contr A} : Contr (A ->* B). Proof. rapply (contr_equiv' { b : B & b = pt }). refine (issig_pmap A B oE _). exact (equiv_functor_sigma_pb (equiv_arrow_from_contr A B)^-1%equiv). Defined. (** * pType and pForall as wild categories *) (** Note that the definitions for [pForall] are also used for the higher structure in [pType]. *) (** pType is a graph *) Global Instance isgraph_ptype : IsGraph pType := Build_IsGraph pType (fun X Y => X ->* Y). (** pForall is a graph *) Global Instance isgraph_pforall (A : pType) (P : pFam A) : IsGraph (pForall A P) := Build_IsGraph _ pHomotopy. (** pType is a 0-coherent 1-category *) Global Instance is01cat_ptype : Is01Cat pType := Build_Is01Cat pType _ (@pmap_idmap) (@pmap_compose). (** pForall is a 0-coherent 1-category *) Global Instance is01cat_pforall (A : pType) (P : pFam A) : Is01Cat (pForall A P). Proof. econstructor. - exact phomotopy_reflexive. - intros a b c f g. exact (g @* f). Defined. Global Instance is2graph_ptype : Is2Graph pType := fun f g => _. Global Instance is2graph_pforall (A : pType) (P : pFam A) : Is2Graph (pForall A P) := fun f g => _. (** pForall is a 0-coherent 1-groupoid *) Global Instance is0gpd_pforall (A : pType) (P : pFam A) : Is0Gpd (pForall A P). Proof. srapply Build_Is0Gpd. intros ? ? h. exact h^*. Defined. (** pType is a 1-coherent 1-category *) Global Instance is1cat_ptype : Is1Cat pType. Proof. snrapply Build_Is1Cat'. 1, 2: exact _. - intros A B C h; rapply Build_Is0Functor. intros f g p; cbn. apply pmap_postwhisker; assumption. - intros A B C h; rapply Build_Is0Functor. intros f g p; cbn. apply pmap_prewhisker; assumption. - intros ? ? ? ? f g h; exact (pmap_compose_assoc h g f). - intros ? ? f; exact (pmap_postcompose_idmap f). - intros ? ? f; exact (pmap_precompose_idmap f). Defined. (** pType is a pointed category *) Global Instance ispointedcat_ptype : IsPointedCat pType. Proof. snrapply Build_IsPointedCat. + exact pUnit. + intro A. exists pconst. exact punit_pmap_pconst. + intro B. exists pconst. exact pmap_punit_pconst. Defined. (** The constant map is definitionally equal to the zero_morphism of a pointed category *) Definition path_zero_morphism_pconst (A B : pType) : (@pconst A B) = zero_morphism := idpath. (** pForall is a 1-category *) Global Instance is1cat_pforall (A : pType) (P : pFam A) : Is1Cat (pForall A P) | 10. Proof. snrapply Build_Is1Cat'. 1, 2: exact _. - intros f g h p; rapply Build_Is0Functor. intros q r s. exact (phomotopy_postwhisker s p). - intros f g h p; rapply Build_Is0Functor. intros q r s. exact (phomotopy_prewhisker p s). - intros ? ? ? ? p q r. simpl. exact (phomotopy_compose_assoc p q r). - intros ? ? p; exact (phomotopy_compose_p1 p). - intros ? ? p; exact (phomotopy_compose_1p p). Defined. (** pForall is a 1-groupoid *) Global Instance is1gpd_pforall (A : pType) (P : pFam A) : Is1Gpd (pForall A P) | 10. Proof. econstructor. + intros ? ? p. exact (phomotopy_compose_pV p). + intros ? ? p. exact (phomotopy_compose_Vp p). Defined. Global Instance is3graph_ptype : Is3Graph pType := fun f g => is2graph_pforall _ _. Global Instance is21cat_ptype : Is21Cat pType. Proof. unshelve econstructor. - exact _. - intros A B C f; nrapply Build_Is1Functor. + intros g h p q r. srapply Build_pHomotopy. 1: exact (fun _ => ap _ (r _)). by pelim r p q g h f. + intros g. srapply Build_pHomotopy. 1: reflexivity. by pelim g f. + intros g h i p q. srapply Build_pHomotopy. 1: cbn; exact (fun _ => ap_pp _ _ _). by pelim p q g h i f. - intros A B C f; nrapply Build_Is1Functor. + intros g h p q r. srapply Build_pHomotopy. 1: intro; exact (r _). by pelim f r p q g h. + intros g. srapply Build_pHomotopy. 1: reflexivity. by pelim f g. + intros g h i p q. srapply Build_pHomotopy. 1: reflexivity. by pelim f p q i g h. - intros A B C f g h k p q. snrapply Build_pHomotopy. + intros x. exact (concat_Ap q _)^. + by pelim p f g q h k. - intros A B C D f g. snrapply Build_Is1Natural. intros r1 r2 s1. srapply Build_pHomotopy. 1: exact (fun _ => concat_p1 _ @ (concat_1p _)^). by pelim f g s1 r1 r2. - intros A B C D f g. snrapply Build_Is1Natural. intros r1 r2 s1. srapply Build_pHomotopy. 1: exact (fun _ => concat_p1 _ @ (concat_1p _)^). by pelim f s1 r1 r2 g. - intros A B C D f g. snrapply Build_Is1Natural. intros r1 r2 s1. srapply Build_pHomotopy. 1: cbn; exact (fun _ => concat_p1 _ @ ap_compose _ _ _ @ (concat_1p _)^). by pelim s1 r1 r2 f g. - intros A B. snrapply Build_Is1Natural. intros r1 r2 s1. srapply Build_pHomotopy. 1: exact (fun _ => concat_p1 _ @ ap_idmap _ @ (concat_1p _)^). by pelim s1 r1 r2. - intros A B. snrapply Build_Is1Natural. intros r1 r2 s1. srapply Build_pHomotopy. 1: exact (fun _ => concat_p1 _ @ (concat_1p _)^). simpl; by pelim s1 r1 r2. - intros A B C D E f g h j. srapply Build_pHomotopy. 1: reflexivity. by pelim f g h j. - intros A B C f g. srapply Build_pHomotopy. 1: reflexivity. by pelim f g. Defined. (** The forgetful map from pType to Type is a 0-functor *) Global Instance is0functor_pointed_type : Is0Functor pointed_type. Proof. apply Build_Is0Functor. intros. exact f. Defined. (** The forgetful map from pType to Type is a 1-functor *) Global Instance is1functor_pointed_type : Is1Functor pointed_type. Proof. apply Build_Is1Functor. + intros ? ? ? ? h. exact h. + intros. reflexivity. + intros. reflexivity. Defined. (** pType has binary products *) Global Instance hasbinaryproducts_ptype : HasBinaryProducts pType. Proof. intros X Y. snrapply Build_BinaryProduct. - exact (X * Y). - exact pfst. - exact psnd. - exact pprod_corec. - exact pprod_corec_beta_fst. - exact pprod_corec_beta_snd. - intros Z f g p q. simpl. snrapply Build_pHomotopy. { intros a. apply path_prod'; cbn. - exact (p a). - exact (q a). } simpl. by pelim p q f g. Defined. (** pType has I-indexed product. *) Global Instance hasallproducts_ptype `{Funext} : HasAllProducts pType. Proof. intros I x. snrapply Build_Product. - exact (pproduct x). - exact pproduct_proj. - exact (pproduct_corec x). - intros Z f i. snrapply Build_pHomotopy. 1: reflexivity. apply moveL_pV. apply equiv_1p_q1. exact (apD10_path_forall _ _ (fun a => point_eq (f a)) i)^. - intros Z f g p. snrapply Build_pHomotopy. 1: intros z; funext i; apply p. cbn; apply moveR_equiv_V. funext i. rhs nrapply ap_pp. lhs nrapply (dpoint_eq (p i)). cbn; f_ap. + apply concat_p1. + rhs nrapply (ap_V _ (dpoint_eq g)). apply inverse2. apply concat_p1. Defined. (** Some higher homotopies *) (** Horizontal composition of homotopies. *) Notation "p @@* q" := (p $@@ q). (** ** Funext for pointed types and direct consequences. *) (** By funext pointed homotopies are equivalent to paths *) Definition equiv_path_pforall `{Funext} {A : pType} {P : pFam A} (f g : pForall A P) : (f ==* g) <~> (f = g). Proof. refine (_ oE (issig_phomotopy f g)^-1). revert f g; apply (equiv_path_issig_contr (issig_pforall A P)). { intros [f feq]; cbn. exists (fun a => 1%path). exact (concat_pV _)^. } intros [f feq]; cbn. contr_sigsig f (fun a:A => idpath (f a)); cbn. refine (contr_equiv' {feq' : f (point A) = dpoint P & feq = feq'} _). refine (equiv_functor_sigma' (equiv_idmap _) _); intros p. refine (_^-1 oE equiv_path_inverse _ _). apply equiv_moveR_1M. Defined. Definition path_pforall `{Funext} {A : pType} {P : pFam A} {f g : pForall A P} : (f ==* g) -> (f = g) := equiv_path_pforall f g. (** We note that the inverse of [path_pforall] computes definitionally on reflexivity, and hence [path_pforall] itself computes typally so. *) Definition equiv_inverse_path_pforall_1 `{Funext} {A : pType} {P : pFam A} (f : pForall A P) : (equiv_path_pforall f f)^-1%equiv 1%path = reflexivity f := 1. Definition path_pforall_1 `{Funext} {A : pType} {P : pFam A} {f : pForall A P} : equiv_path_pforall _ _ (reflexivity f) = 1%path := moveR_equiv_M _ _ (equiv_inverse_path_pforall_1 f)^. (** Here is the inverse map without assuming funext *) Definition phomotopy_path {A : pType} {P : pFam A} {f g : pForall A P} : (f = g) -> (f ==* g) := ltac:(by intros []). (** And we prove that it agrees with the inverse of [equiv_path_pforall] *) Definition path_equiv_path_pforall_phomotopy_path `{Funext} {A : pType} {P : pFam A} {f g : pForall A P} : phomotopy_path (f:=f) (g:=g) = (equiv_path_pforall f g)^-1%equiv := ltac:(by funext []). (** TODO: The next few results could be proven for [GpdHom_path] in any WildCat. *) (** [phomotopy_path] sends concatenation to composition of pointed homotopies.*) Definition phomotopy_path_pp {A : pType} {P : pFam A} {f g h : pForall A P} (p : f = g) (q : g = h) : phomotopy_path (p @ q) ==* phomotopy_path p @* phomotopy_path q. Proof. induction p. induction q. symmetry. apply phomotopy_compose_p1. Defined. (** ** [phomotopy_path] respects 2-cells. *) Definition phomotopy_path2 {A : pType} {P : pFam A} {f g : pForall A P} {p p' : f = g} (q : p = p') : phomotopy_path p ==* phomotopy_path p'. Proof. induction q. reflexivity. Defined. (** [phomotopy_path] sends inverses to inverses.*) Definition phomotopy_path_V {A : pType} {P : pFam A} {f g : pForall A P} (p : f = g) : phomotopy_path (p^) ==* (phomotopy_path p)^*. Proof. induction p. simpl. symmetry. exact gpd_rev_1. Defined. (** Since pointed homotopies are equivalent to equalities, we can act as if they are paths and define a path induction for them. *) Definition phomotopy_ind `{H0 : Funext} {A : pType} {P : pFam A} {k : pForall A P} (Q : forall (k' : pForall A P), (k ==* k') -> Type) (q : Q k (reflexivity k)) (k' : pForall A P) : forall (H : k ==* k'), Q k' H. Proof. equiv_intro (equiv_path_pforall k k')^-1%equiv p. induction p. exact q. Defined. (** Sometimes you have a goal with both a pointed homotopy [H] and [path_pforall H]. This is an induction principle that allows us to replace both of them by reflexivity at the same time. *) Definition phomotopy_ind' `{H0 : Funext} {A : pType} {P : pFam A} {k : pForall A P} (Q : forall (k' : pForall A P), (k ==* k') -> (k = k') -> Type) (q : Q k (reflexivity k) 1 % path) (k' : pForall A P) (H : k ==* k') (p : k = k') (r : path_pforall H = p) : Q k' H p. Proof. induction r. revert k' H. rapply phomotopy_ind. exact (transport (Q _ (reflexivity _)) path_pforall_1^ q). Defined. Definition phomotopy_ind_1 `{H0 : Funext} {A : pType} {P : pFam A} {k : pForall A P} (Q : forall (k' : pForall A P), (k ==* k') -> Type) (q : Q k (reflexivity k)) : phomotopy_ind Q q k (reflexivity k) = q. Proof. change (reflexivity k) with ((equiv_path_pforall k k)^-1%equiv (idpath k)). apply equiv_ind_comp. Defined. Definition phomotopy_ind_1' `{H0 : Funext} {A : pType} {P : pFam A} {k : pForall A P} (Q : forall (k' : pForall A P), (k ==* k') -> (k = k') -> Type) (q : Q k (reflexivity k) 1 % path) : phomotopy_ind' Q q k (reflexivity k) (path_pforall (reflexivity k)) (1 % path) = transport (Q k (reflexivity k)) path_pforall_1^ q. Proof. srapply phomotopy_ind_1. Defined. (** Every homotopy between pointed maps of sets is a pointed homotopy. *) Definition phomotopy_homotopy_hset {X Y : pType} `{IsHSet Y} {f g : X ->* Y} (h : f == g) : f ==* g. Proof. apply (Build_pHomotopy h). apply path_ishprop. Defined. (** Pointed homotopies in a set form an HProp. *) Global Instance ishprop_phomotopy_hset `{Funext} {X Y : pType} `{IsHSet Y} (f g : X ->* Y) : IsHProp (f ==* g) := inO_equiv_inO' (O:=Tr (-1)) _ (issig_phomotopy f g). (** ** Operations on equivalences needed to make pType a wild category with equivalences *) (** The inverse equivalence of a pointed equivalence is again a pointed equivalence *) Definition pequiv_inverse {A B} (f : A <~>* B) : B <~>* A. Proof. snrapply Build_pEquiv. 1: apply (Build_pMap _ _ f^-1). 1: apply moveR_equiv_V; symmetry; apply point_eq. exact _. Defined. (* A pointed equivalence is a section of its inverse *) Definition peissect {A B : pType} (f : A <~>* B) : (pequiv_inverse f) o* f ==* pmap_idmap. Proof. srefine (Build_pHomotopy _ _). 1: apply (eissect f). simpl. unfold moveR_equiv_V. pointed_reduce. symmetry. refine (concat_p1 _ @ concat_1p _ @ concat_1p _). Defined. (* A pointed equivalence is a retraction of its inverse *) Definition peisretr {A B : pType} (f : A <~>* B) : f o* (pequiv_inverse f) ==* pmap_idmap. Proof. srefine (Build_pHomotopy _ _). 1: apply (eisretr f). pointed_reduce. unfold moveR_equiv_V. refine (eisadj f _ @ _). symmetry. exact (concat_p1 _ @ concat_p1 _ @ ap _ (concat_1p _)). Defined. (** Univalence for pointed types *) Definition equiv_path_ptype `{Univalence} (A B : pType@{u}) : A <~>* B <~> A = B. Proof. refine (equiv_path_from_contr A (fun C => A <~>* C) pequiv_pmap_idmap _ B). nrapply (contr_equiv' { X : Type@{u} & { f : A <~> X & {x : X & f pt = x} }}). 1: make_equiv. rapply (contr_equiv' { X : Type@{u} & A <~> X }). nrapply equiv_functor_sigma_id; intro X; symmetry. rapply equiv_sigma_contr. (** If you replace the type in the second line with { Xf : {X : Type & A <~> X} & {x : Xf.1 & Xf.2 pt = x} }, then the third line completes the proof, but that results in an extra universe variable. *) Defined. Definition path_ptype `{Univalence} {A B : pType} : (A <~>* B) -> A = B := equiv_path_ptype A B. (** The inverse map can be defined without Univalence. *) Definition pequiv_path {A B : pType} (p : A = B) : (A <~>* B) := match p with idpath => pequiv_pmap_idmap end. (** This just confirms that it is definitionally the inverse map. *) Definition pequiv_path_equiv_path_ptype_inverse `{Univalence} {A B : pType} : @pequiv_path A B = (equiv_path_ptype A B)^-1 := idpath. Global Instance isequiv_pequiv_path `{Univalence} {A B : pType} : IsEquiv (@pequiv_path A B) := isequiv_inverse (equiv_path_ptype A B). (** Two pointed equivalences are equal if their underlying pointed functions are equal. This requires [Funext] for knowing that [IsEquiv] is an [HProp]. *) Definition equiv_path_pequiv' `{Funext} {A B : pType} (f g : A <~>* B) : (f = g :> (A ->* B)) <~> (f = g :> (A <~>* B)). Proof. refine ((equiv_ap' (issig_pequiv A B)^-1%equiv f g)^-1%equiv oE _); cbn. match goal with |- _ <~> ?F = ?G => exact (equiv_path_sigma_hprop F G) end. Defined. (** Two pointed equivalences are equal if their underlying pointed functions are pointed homotopic. *) Definition equiv_path_pequiv `{Funext} {A B : pType} (f g : A <~>* B) : (f ==* g) <~> (f = g) := equiv_path_pequiv' f g oE equiv_path_pforall f g. Definition path_pequiv `{Funext} {A B : pType} (f g : A <~>* B) : (f ==* g) -> (f = g) := equiv_path_pequiv f g. Definition equiv_phomotopy_concat_l `{Funext} {A B : pType} (f g h : A ->* B) (K : g ==* f) : f ==* h <~> g ==* h. Proof. refine ((equiv_path_pforall _ _)^-1%equiv oE _ oE equiv_path_pforall _ _). rapply equiv_concat_l. apply equiv_path_pforall. exact K. Defined. (** Under funext, pType has morphism extensionality *) Global Instance hasmorext_ptype `{Funext} : HasMorExt pType. Proof. srapply Build_HasMorExt; intros A B f g. refine (isequiv_homotopic (equiv_path_pforall f g)^-1%equiv _). intros []; reflexivity. Defined. (** pType has equivalences *) Global Instance hasequivs_ptype : HasEquivs pType. Proof. srapply ( Build_HasEquivs _ _ _ _ _ pEquiv (fun A B f => IsEquiv f)); intros A B f; cbn; intros. - exact f. - exact _. - exact (Build_pEquiv _ _ f _). - reflexivity. - exact (pequiv_inverse f). - apply peissect. - cbn. refine (peisretr f). - rapply (isequiv_adjointify f g). + intros x; exact (r x). + intros x; exact (s x). Defined. Global Instance hasmorext_core_ptype `{Funext} : HasMorExt (core pType). Proof. rapply hasmorext_core. intros A B f g. snrapply isequiv_homotopic'. 1: exact (equiv_path_pequiv' f g)^-1%equiv. by intros []. Defined. (** pType is a univalent 1-coherent 1-category *) Global Instance isunivalent_ptype `{Univalence} : IsUnivalent1Cat pType. Proof. srapply Build_IsUnivalent1Cat; intros A B. (* [cate_equiv_path] is almost definitionally equal to [pequiv_path]. Both are defined by path induction, sending [idpath A] to [id_cate A] and [pequiv_pmap_idmap A], respectively. [id_cate A] is almost definitionally equal to [pequiv_pmap_idmap A], except that the former uses [catie_adjointify], so the adjoint law is different. However, the underlying pointed maps are definitionally equal. *) refine (isequiv_homotopic pequiv_path _). intros []. apply equiv_path_pequiv'. (* Change to equality as pointed functions. *) reflexivity. Defined. (** The free base point added to a type. This is in fact a functor and left adjoint to the forgetful functor pType to Type. *) Definition pointify (S : Type) : pType := [S + Unit, inr tt]. Global Instance is0functor_pointify : Is0Functor pointify. Proof. apply Build_Is0Functor. intros A B f. srapply Build_pMap. 1: exact (functor_sum f idmap). reflexivity. Defined. (** pointify is left adjoint to forgetting the basepoint in the following sense *) Theorem equiv_pointify_map `{Funext} (A : Type) (X : pType) : (pointify A ->* X) <~> (A -> X). Proof. snrapply equiv_adjointify. 1: exact (fun f => f o inl). { intros f. snrapply Build_pMap. { intros [a|]. 1: exact (f a). exact pt. } reflexivity. } 1: intro x; reflexivity. intros f. cbv. pointed_reduce. rapply equiv_path_pforall. snrapply Build_pHomotopy. 1: by intros [a|[]]. reflexivity. Defined. Lemma natequiv_pointify_r `{Funext} (A : Type) : NatEquiv (opyon (pointify A)) (opyon A o pointed_type). Proof. snrapply Build_NatEquiv. 1: rapply equiv_pointify_map. snrapply Build_Is1Natural. cbv; reflexivity. Defined. (** * Pointed categories give rise to pointed structures *) (** Pointed categories have pointed hom sets *) Definition pHom {A : Type} `{IsPointedCat A} (a1 a2 : A) := [Hom a1 a2, zero_morphism]. (** Pointed functors give pointed maps on morphisms *) Definition pfmap {A B : Type} (F : A -> B) `{IsPointedCat A, IsPointedCat B, !HasEquivs B, !HasMorExt B} `{!Is0Functor F, !Is1Functor F, !IsPointedFunctor F} {a1 a2 : A} : pHom a1 a2 ->* pHom (F a1) (F a2). Proof. snrapply Build_pMap. - exact (fmap F). - apply path_hom. snrapply fmap_zero_morphism; assumption. Defined. Coq-HoTT-9.0/theories/Pointed/Loops.v000066400000000000000000000352731474641544500174570ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HFiber Factorization Truncations.Core Truncations.Connectedness HProp. Require Import Pointed.Core Pointed.pEquiv. Require Import WildCat. Require Import Spaces.Nat.Core. Local Open Scope pointed_scope. Local Open Scope path_scope. (** ** Loop spaces *) (** The type [x = x] is pointed. *) Global Instance ispointed_loops A (a : A) : IsPointed (a = a) := 1. Definition loops (A : pType) : pType := [point A = point A, 1]. Definition iterated_loops (n : nat) (A : pType) : pType := nat_iter n loops A. (* Inner unfolding for iterated loops *) Definition unfold_iterated_loops (n : nat) (X : pType) : iterated_loops n.+1 X = iterated_loops n (loops X) := nat_iter_succ_r _ _ _. (** The loop space decreases the truncation level by one. We don't bother making this an instance because it is automatically found by typeclass search, but we record it here in case anyone is looking for it. *) Definition istrunc_loops {n} (A : pType) `{IsTrunc n.+1 A} : IsTrunc n (loops A) := _. (** Similarly for connectedness. *) Definition isconnected_loops `{Univalence} {n} (A : pType) `{IsConnected n.+1 A} : IsConnected n (loops A) := _. Lemma pequiv_loops_punit : loops pUnit <~>* pUnit. Proof. snrapply Build_pEquiv'. { srapply (equiv_adjointify (fun _ => tt) (fun _ => idpath)). 1: by intros []. rapply path_contr. } reflexivity. Defined. (** ** Functoriality of loop spaces *) (** Action on 1-cells *) Global Instance is0functor_loops : Is0Functor loops. Proof. apply Build_Is0Functor. intros A B f. refine (Build_pMap (loops A) (loops B) (fun p => (point_eq f)^ @ (ap f p @ point_eq f)) _). refine (_ @ concat_Vp (point_eq f)). apply whiskerL. apply concat_1p. Defined. Global Instance is1functor_loops : Is1Functor loops. Proof. apply Build_Is1Functor. (** Action on 2-cells *) - intros A B f g p. pointed_reduce. srapply Build_pHomotopy; cbn. { intro q. refine (_ @ (concat_p1 _)^ @ (concat_1p _)^). apply moveR_Vp. apply (concat_Ap (fun x => p x @ 1)). } simpl. generalize (p point0). generalize (g point0). intros _ []. reflexivity. (** Preservation of identity. *) - intros A. srapply Build_pHomotopy. { intro p. refine (concat_1p _ @ concat_p1 _ @ ap_idmap _). } reflexivity. (** Preservation of compositon. *) - intros A B c g f. srapply Build_pHomotopy. { intros p. cbn. refine ((inv_pp _ _ @@ 1) @ concat_pp_p _ _ _ @ _). apply whiskerL. refine (((ap_V _ _)^ @@ 1) @ _ @ concat_p_pp _ _ _ @ ((ap_pp _ _ _)^ @@ 1)). apply whiskerL. refine (_ @ concat_p_pp _ _ _ @ ((ap_pp _ _ _)^ @@ 1)). apply whiskerR. apply ap_compose. } by pointed_reduce. Defined. (** *** Properties of loops functor *) (** Loops functor distributes over concatenation *) Lemma fmap_loops_pp {X Y : pType} (f : X ->* Y) (x y : loops X) : fmap loops f (x @ y) = fmap loops f x @ fmap loops f y. Proof. pointed_reduce_rewrite. apply ap_pp. Defined. (** Loops is a pointed functor *) Global Instance ispointedfunctor_loops : IsPointedFunctor loops. Proof. snrapply Build_IsPointedFunctor'. 1-4: exact _. exact pequiv_loops_punit. Defined. Lemma fmap_loops_pconst {A B : pType} : fmap loops (@pconst A B) ==* pconst. Proof. rapply fmap_zero_morphism. Defined. (** *** Iterated loops functor *) (** Action on 1-cells *) Global Instance is0functor_iterated_loops n : Is0Functor (iterated_loops n). Proof. induction n. 1: exact _. nrapply is0functor_compose; exact _. Defined. Global Instance is1functor_iterated_loops n : Is1Functor (iterated_loops n). Proof. induction n. 1: exact _. nrapply is1functor_compose; exact _. Defined. Lemma fmap_iterated_loops_pp {X Y : pType} (f : X ->* Y) n (x y : iterated_loops n.+1 X) : fmap (iterated_loops n.+1) f (x @ y) = fmap (iterated_loops n.+1) f x @ fmap (iterated_loops n.+1) f y. Proof. apply fmap_loops_pp. Defined. (** The fiber of [fmap loops f] is equivalent to a fiber of [ap f]. *) Definition hfiber_fmap_loops {A B : pType} (f : A ->* B) (p : loops B) : {q : loops A & ap f q = (point_eq f @ p) @ (point_eq f)^} <~> hfiber (fmap loops f) p. Proof. apply equiv_functor_sigma_id; intros q. refine (equiv_moveR_Vp _ _ _ oE _). apply equiv_moveR_pM. Defined. (** The loop space functor decreases the truncation level by one. *) Global Instance istrunc_fmap_loops {n} (A B : pType) (f : A ->* B) `{IsTruncMap n.+1 _ _ f} : IsTruncMap n (fmap loops f). Proof. intro p. apply (istrunc_equiv_istrunc _ (hfiber_fmap_loops f p)). Defined. (** And likewise the connectedness. *) Global Instance isconnected_fmap_loops `{Univalence} {n : trunc_index} (A B : pType) (f : A ->* B) `{IsConnMap n.+1 _ _ f} : IsConnMap n (fmap loops f). Proof. intros p; eapply isconnected_equiv'. - refine (hfiber_fmap_loops f p oE _). symmetry; apply hfiber_ap. - exact _. Defined. Definition isconnected_iterated_fmap_loops `{Univalence} (n : trunc_index) (k : nat) (A B : pType) (f : A ->* B) (C : IsConnMap (trunc_index_inc' n k) f) : IsConnMap n (fmap (iterated_loops k) f). Proof. induction k in n, C |- *. - exact C. - apply isconnected_fmap_loops. apply IHk. exact C. Defined. (** It follows that loop spaces "commute with images". *) Definition equiv_loops_image `{Univalence} n {A B : pType} (f : A ->* B) : loops ([image n.+1 f, factor1 (image n.+1 f) (point A)]) <~> image n (fmap loops f). Proof. set (C := [image n.+1 f, factor1 (image n.+1 f) (point A)]). pose (g := Build_pMap A C (factor1 (image n.+1 f)) 1). pose (h := Build_pMap C B (factor2 (image n.+1 f)) (point_eq f)). transparent assert (I : (Factorization (@IsConnMap n) (@MapIn n) (fmap loops f))). { refine (@Build_Factorization (@IsConnMap n) (@MapIn n) (loops A) (loops B) (fmap loops f) (loops C) (fmap loops g) (fmap loops h) _ _ _). intros x; symmetry. refine (_ @ fmap_comp loops g h x). simpl. abstract (rewrite !concat_1p; reflexivity). } exact (path_intermediate (path_factor (O_factsys n) (fmap loops f) I (image n (fmap loops f)))). Defined. (** Loop inversion is a pointed equivalence *) Definition loops_inv (A : pType) : loops A <~>* loops A. Proof. srapply Build_pEquiv. 1: exact (Build_pMap (loops A) (loops A) inverse 1). apply isequiv_path_inverse. Defined. (** Loops functor preserves equivalences *) Definition pequiv_fmap_loops {A B : pType} : A $<~> B -> loops A $<~> loops B := emap loops. (** A version of [unfold_iterated_loops] that's an equivalence rather than an equality. We could get this from the equality, but it's more useful to construct it explicitly since then we can reason about it. *) Definition unfold_iterated_loops' (n : nat) (X : pType) : iterated_loops n.+1 X <~>* iterated_loops n (loops X). Proof. induction n. 1: reflexivity. change (iterated_loops n.+2 X) with (loops (iterated_loops n.+1 X)). apply pequiv_fmap_loops, IHn. Defined. (** For instance, we can prove that it's natural. *) Definition unfold_iterated_fmap_loops {A B : pType} (n : nat) (f : A ->* B) : (unfold_iterated_loops' n B) o* (fmap (iterated_loops n.+1) f) ==* (fmap (iterated_loops n) (fmap loops f)) o* (unfold_iterated_loops' n A). Proof. induction n. - srefine (Build_pHomotopy _ _). + reflexivity. + cbn. apply moveL_pV. refine (concat_1p _ @ _). refine (concat_1p _ @ _). refine (_ @ (concat_p1 _)^). exact ((ap_idmap _)^). - refine ((fmap_comp loops _ _)^* @* _). refine (_ @* (fmap_comp loops _ _)). rapply (fmap2 loops). apply IHn. Defined. (** Iterated loops preserves equivalences *) Definition pequiv_fmap_iterated_loops {A B} n : A <~>* B -> iterated_loops n A <~>* iterated_loops n B := emap (iterated_loops n). (** Loops preserves products. *) Lemma loops_prod (X Y : pType) : loops (X * Y) <~>* loops X * loops Y. Proof. snrapply Build_pEquiv'. 1: exact (equiv_path_prod (point (X * Y)) (point (X * Y)))^-1%equiv. reflexivity. Defined. (** There is a natural map from [loops (X * Y)] to [loops X * loops Y], and ideally it would definitionally underly the equivalence [loops_prod]. That's not the case, but we show that [loops_prod] is homotopic to the expected maps after projecting to each factor. *) Definition pfst_loops_prod (X Y : pType) : pfst o* loops_prod X Y ==* fmap loops pfst. Proof. snrapply Build_pHomotopy. - intro p; simpl. rhs nrapply concat_1p. symmetry; apply concat_p1. - reflexivity. Defined. Definition psnd_loops_prod (X Y : pType) : psnd o* loops_prod X Y ==* fmap loops psnd. Proof. snrapply Build_pHomotopy. - intro p; simpl. rhs nrapply concat_1p. symmetry; apply concat_p1. - reflexivity. Defined. (** Iterated loops of products are products of iterated loops. *) Lemma iterated_loops_prod (X Y : pType) {n} : iterated_loops n (X * Y) <~>* (iterated_loops n X) * (iterated_loops n Y). Proof. induction n as [|n IHn]. 1: reflexivity. exact (loops_prod _ _ o*E emap loops IHn). Defined. (** Similarly, we compute the projections here. *) Definition pfst_iterated_loops_prod (X Y : pType) {n} : pfst o* iterated_loops_prod X Y ==* fmap (iterated_loops n) pfst. Proof. induction n as [|n IHn]. - reflexivity. - change (_ ==* ?R) with (pfst o* (loops_prod _ _ o* fmap loops (iterated_loops_prod _ _)) ==* R). refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker _ (pfst_loops_prod _ _) @* _). refine ((fmap_comp loops _ _)^* @* _). change (?L ==* _) with (L ==* fmap loops (fmap (iterated_loops n) pfst)). rapply (fmap2 loops); simpl. exact IHn. Defined. Definition psnd_iterated_loops_prod (X Y : pType) {n} : psnd o* iterated_loops_prod X Y ==* fmap (iterated_loops n) psnd. Proof. induction n as [|n IHn]. - reflexivity. - change (_ ==* ?R) with (psnd o* (loops_prod _ _ o* fmap loops (iterated_loops_prod _ _)) ==* R). refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker _ (psnd_loops_prod _ _) @* _). refine ((fmap_comp loops _ _)^* @* _). change (?L ==* _) with (L ==* fmap loops (fmap (iterated_loops n) psnd)). rapply (fmap2 loops); simpl. exact IHn. Defined. (* A dependent form of loops *) Definition loopsD {A} : pFam A -> pFam (loops A) := fun Pp => Build_pFam (fun q : loops A => transport Pp q (dpoint Pp) = (dpoint Pp)) 1. Global Instance istrunc_pfam_loopsD {n} {A} (P : pFam A) {H :IsTrunc_pFam n.+1 P} : IsTrunc_pFam n (loopsD P). Proof. intros a. pose (H (point A)). exact _. Defined. (* psigma and loops 'commute' *) Lemma loops_psigma_commute (A : pType) (P : pFam A) : loops (psigma P) <~>* psigma (loopsD P). Proof. snrapply Build_pEquiv'. 1: exact (equiv_path_sigma _ _ _)^-1%equiv. reflexivity. Defined. (* product and loops 'commute' *) Lemma loops_pproduct_commute `{Funext} (A : Type) (F : A -> pType) : loops (pproduct F) <~>* pproduct (loops o F). Proof. snrapply Build_pEquiv'. 1: apply equiv_apD10. reflexivity. Defined. (* product and iterated loops commute *) Lemma iterated_loops_pproduct_commute `{Funext} (A : Type) (F : A -> pType) (n : nat) : iterated_loops n (pproduct F) <~>* pproduct (iterated_loops n o F). Proof. induction n. 1: reflexivity. refine (loops_pproduct_commute _ _ o*E _). rapply (emap loops). exact IHn. Defined. (* Loops neutralise sigmas when truncated *) Lemma loops_psigma_trunc (n : nat) (Aa : pType) (Pp : pFam Aa) (istrunc_Pp : IsTrunc_pFam (trunc_index_inc minus_two n) Pp) : iterated_loops n (psigma Pp) <~>* iterated_loops n Aa. Proof. induction n in Aa, Pp, istrunc_Pp |- *. { snrapply Build_pEquiv'. 1: refine (@equiv_sigma_contr _ _ istrunc_Pp). reflexivity. } refine (pequiv_inverse (unfold_iterated_loops' _ _) o*E _ o*E unfold_iterated_loops' _ _). refine (IHn _ _ _ o*E _). rapply (emap (iterated_loops _)). apply loops_psigma_commute. Defined. (* We can convert between loops in a type and loops in [Type] at that type. *) Definition loops_type `{Univalence} (A : Type@{i}) : loops [Type@{i}, A] <~>* [A <~> A, equiv_idmap]. Proof. apply issig_pequiv'. exists (equiv_equiv_path A A). reflexivity. Defined. (* An iterated version. Note that the statement with "-1" substituted for [n] is [loops [Type, A] <~>* [A -> A, idmap]], which is not true in general. Compare the previous result. *) Lemma local_global_looping `{Univalence} (A : Type@{i}) (n : nat) : iterated_loops@{j} n.+2 [Type@{i}, A] <~>* pproduct (fun a => iterated_loops@{j} n.+1 [A, a]). Proof. induction n. { refine (_ o*E emap loops (loops_type A)). apply issig_pequiv'. exists (equiv_inverse (equiv_path_arrow 1%equiv 1%equiv) oE equiv_inverse (equiv_path_equiv 1%equiv 1%equiv)). reflexivity. } exact (loops_pproduct_commute _ _ o*E emap loops IHn). Defined. (* 7.2.7 *) Theorem equiv_istrunc_istrunc_loops `{Funext} n X : IsTrunc n.+2 X <~> forall (x : X), IsTrunc n.+1 (loops [X, x]). Proof. srapply equiv_iff_hprop. intro tr_loops. apply istrunc_S; intros x y. apply istrunc_S; intros p. destruct p. nrapply tr_loops. Defined. (* 7.2.9, with [n] here meaning the same as [n-1] there. Note that [n.-1] in the statement is short for [trunc_index_pred (nat_to_trunc_index n)] which is definitionally equal to [(trunc_index_inc minus_two n).+1]. *) Theorem equiv_istrunc_contr_iterated_loops `{Funext} (n : nat) (A : Type) : IsTrunc n.-1 A <~> forall a : A, Contr (iterated_loops n [A, a]). Proof. induction n in A |- *. { cbn. exact equiv_hprop_inhabited_contr. } refine (_ oE equiv_istrunc_istrunc_loops n.-2 _). srapply equiv_functor_forall_id. intro a. cbn beta. refine (_ oE IHn (loops [A, a])). refine (equiv_inO_equiv (-2) (unfold_iterated_loops' n [A,a])^-1 oE _). rapply equiv_iff_hprop. intros X p. refine (@contr_equiv' _ _ _ X). rapply (emap (iterated_loops _)). srapply Build_pEquiv'. 1: exact (equiv_concat_lr p 1). cbn; unfold ispointed_loops. exact (concat_p1 _ @ concat_p1 _). Defined. (** [loops_inv] is a natural transformation. *) Global Instance is1natural_loops_inv : Is1Natural loops loops loops_inv. Proof. snrapply Build_Is1Natural. intros A B f. srapply Build_pHomotopy. + intros p. refine (inv_Vp _ _ @ whiskerR _ (point_eq f) @ concat_pp_p _ _ _). refine (inv_pp _ _ @ whiskerL (point_eq f)^ (ap_V f p)^). + pointed_reduce. reflexivity. Defined. (** Loops on the pointed type of dependent pointed maps correspond to pointed dependent maps into a family of loops. We define this in this direction, because the forward map is pointed by reflexivity. *) Definition equiv_loops_ppforall `{Funext} {A : pType} (B : A -> pType) : loops (ppforall x : A, B x) <~>* (ppforall x : A, loops (B x)). Proof. srapply Build_pEquiv'. 1: symmetry; exact (equiv_path_pforall (point_pforall B) (point_pforall B)). reflexivity. Defined. Coq-HoTT-9.0/theories/Pointed/pEquiv.v000066400000000000000000000105721474641544500176270ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import WildCat. Require Import Pointed.Core. Local Open Scope pointed_scope. (* Pointed equivalence is a reflexive relation. *) Global Instance pequiv_reflexive : Reflexive pEquiv. Proof. intro; apply pequiv_pmap_idmap. Defined. (* We can probably get rid of the following notation, and use ^-1$ instead. *) Notation "f ^-1*" := (@cate_inv pType _ _ _ _ hasequivs_ptype _ _ f) : pointed_scope. (* Pointed equivalence is a symmetric relation. *) Global Instance pequiv_symmetric : Symmetric pEquiv. Proof. intros ? ?; apply pequiv_inverse. Defined. (* Pointed equivalences compose. *) Definition pequiv_compose {A B C : pType} (f : A <~>* B) (g : B <~>* C) : A <~>* C := g $oE f. (* Pointed equivalence is a transitive relation. *) Global Instance pequiv_transitive : Transitive pEquiv. Proof. intros ? ? ?; apply pequiv_compose. Defined. Notation "g o*E f" := (pequiv_compose f g) : pointed_scope. (* Sometimes we wish to construct a pEquiv from an equiv and a proof that it is pointed. *) Definition Build_pEquiv' {A B : pType} (f : A <~> B) (p : f (point A) = point B) : A <~>* B := Build_pEquiv _ _ (Build_pMap _ _ f p) _. Arguments Build_pEquiv' & _ _ _ _. (* A version of equiv_adjointify for pointed equivalences where all data is pointed. There is a lot of unnecessary data here but sometimes it is easier to prove equivalences using this. *) Definition pequiv_adjointify {A B : pType} (f : A ->* B) (f' : B ->* A) (r : f o* f' ==* pmap_idmap) (s : f' o* f == pmap_idmap) : A <~>* B := (Build_pEquiv _ _ f (isequiv_adjointify f f' r s)). (* In some situations you want the back and forth maps to be pointed but not the sections. *) Definition pequiv_adjointify' {A B : pType} (f : A ->* B) (f' : B ->* A) (r : f o f' == idmap) (s : f' o f == idmap) : A <~>* B := (Build_pEquiv _ _ f (isequiv_adjointify f f' r s)). (** Pointed versions of [moveR_equiv_M] and friends. *) Definition moveR_pequiv_Mf {A B C} (f : B <~>* C) (g : A ->* B) (h : A ->* C) (p : g ==* f^-1* o* h) : (f o* g ==* h). Proof. refine (pmap_postwhisker f p @* _). refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker h (peisretr f) @* _). apply pmap_postcompose_idmap. Defined. Definition moveL_pequiv_Mf {A B C} (f : B <~>* C) (g : A ->* B) (h : A ->* C) (p : f^-1* o* h ==* g) : (h ==* f o* g). Proof. refine (_ @* pmap_postwhisker f p). refine (_ @* (pmap_compose_assoc _ _ _)). refine ((pmap_postcompose_idmap _)^* @* _). apply pmap_prewhisker. symmetry; apply peisretr. Defined. Definition moveL_pequiv_Vf {A B C} (f : B <~>* C) (g : A ->* B) (h : A ->* C) (p : f o* g ==* h) : g ==* f^-1* o* h. Proof. refine (_ @* pmap_postwhisker f^-1* p). refine (_ @* (pmap_compose_assoc _ _ _)). refine ((pmap_postcompose_idmap _)^* @* _). apply pmap_prewhisker. symmetry; apply peissect. Defined. Definition moveR_pequiv_Vf {A B C} (f : B <~>* C) (g : A ->* B) (h : A ->* C) (p : h ==* f o* g) : f^-1* o* h ==* g. Proof. refine (pmap_postwhisker f^-1* p @* _). refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker g (peissect f) @* _). apply pmap_postcompose_idmap. Defined. Definition moveR_pequiv_fV {A B C} (f : B ->* C) (g : A <~>* B) (h : A ->* C) (p : f o* g ==* h) : (f ==* h o* g^-1*). Proof. refine (_ @* pmap_prewhisker g^-1* p). refine (_ @* (pmap_compose_assoc _ _ _)^*). refine ((pmap_precompose_idmap _)^* @* _). apply pmap_postwhisker. symmetry; apply peisretr. Defined. Definition pequiv_pequiv_precompose `{Funext} {A B C : pType} (f : A <~>* B) : (B ->** C) <~>* (A ->** C). Proof. srapply Build_pEquiv'. - exact (equiv_precompose_cat_equiv f). - (* By using [pelim f], we can avoid [Funext] in this part of the proof. *) cbn; unfold "o*", point_pforall; cbn. by pelim f. Defined. Definition pequiv_pequiv_postcompose `{Funext} {A B C : pType} (f : B <~>* C) : (A ->** B) <~>* (A ->** C). Proof. srapply Build_pEquiv'. - exact (equiv_postcompose_cat_equiv f). - cbn; unfold "o*", point_pforall; cbn. by pelim f. Defined. Proposition equiv_pequiv_inverse `{Funext} {A B : pType} : (A <~>* B) <~> (B <~>* A). Proof. refine (issig_pequiv' _ _ oE _ oE (issig_pequiv' A B)^-1). srapply (equiv_functor_sigma' (equiv_equiv_inverse _ _)); intro e; cbn. exact (equiv_moveR_equiv_V _ _ oE equiv_path_inverse _ _). Defined. Coq-HoTT-9.0/theories/Pointed/pFiber.v000066400000000000000000000076241474641544500175710ustar00rootroot00000000000000Require Import Basics Types WildCat. Require Import HFiber. Require Import Pointed.Core. Require Import Pointed.pEquiv. Require Import Pointed.Loops. Local Open Scope pointed_scope. (** ** Pointed fibers *) Global Instance ispointed_fiber {A B : pType} (f : A ->* B) : IsPointed (hfiber f (point B)) := (point A; point_eq f). Definition pfiber {A B : pType} (f : A ->* B) : pType := [hfiber f (point B), _]. Definition pfib {A B : pType} (f : A ->* B) : pfiber f ->* A := Build_pMap (pfiber f) A pr1 1. (** The double fiber object is equivalent to loops on the base. *) Definition pfiber2_loops {A B : pType} (f : A ->* B) : pfiber (pfib f) <~>* loops B. Proof. pointed_reduce_pmap f. snrapply Build_pEquiv'. 1: make_equiv_contr_basedpaths. reflexivity. Defined. Definition pfiber_fmap_loops {A B : pType} (f : A ->* B) : pfiber (fmap loops f) <~>* loops (pfiber f). Proof. srapply Build_pEquiv'. { etransitivity. 2: srapply equiv_path_sigma. simpl; unfold hfiber. srapply equiv_functor_sigma_id. intro p; cbn. refine (_ oE equiv_moveL_Mp _ _ _). refine (_ oE equiv_concat_r (concat_p1 _) _). refine (_ oE equiv_moveL_Vp _ _ _). refine (_ oE equiv_path_inverse _ _). apply equiv_concat_l. apply transport_paths_Fl. } by pointed_reduce. Defined. Definition pr1_pfiber_fmap_loops {A B} (f : A ->* B) : fmap loops (pfib f) o* pfiber_fmap_loops f ==* pfib (fmap loops f). Proof. srapply Build_pHomotopy. - intros [u v]. refine (concat_1p _ @ concat_p1 _ @ _). exact (@ap_pr1_path_sigma _ _ (point A; point_eq f) (point A;point_eq f) _ _). - abstract (pointed_reduce_rewrite; reflexivity). Defined. Definition pfiber_fmap_iterated_loops {A B : pType} (n : nat) (f : A ->* B) : pfiber (fmap (iterated_loops n) f) <~>* iterated_loops n (pfiber f). Proof. induction n. 1: reflexivity. refine (_ o*E pfiber_fmap_loops _ ). rapply (emap loops). exact IHn. Defined. Definition functor_pfiber {A B C D} {f : A ->* B} {g : C ->* D} {h : A ->* C} {k : B ->* D} (p : k o* f ==* g o* h) : pfiber f ->* pfiber g. Proof. srapply Build_pMap. + cbn. refine (functor_hfiber2 p (point_eq k)). + srapply path_hfiber. - apply point_eq. - refine (concat_pp_p _ _ _ @ _). apply moveR_Vp. apply (point_htpy p)^. Defined. Definition pequiv_pfiber {A B C D} {f : A ->* B} {g : C ->* D} (h : A <~>* C) (k : B <~>* D) (p : k o* f ==* g o* h) : pfiber f $<~> pfiber g := Build_pEquiv _ _ (functor_pfiber p) _. Definition square_functor_pfiber {A B C D} {f : A ->* B} {g : C ->* D} {h : A ->* C} {k : B ->* D} (p : k o* f ==* g o* h) : h o* pfib f ==* pfib g o* functor_pfiber p. Proof. srapply Build_pHomotopy. - intros x; reflexivity. - apply moveL_pV. cbn; unfold functor_sigma; cbn. abstract (rewrite ap_pr1_path_sigma, concat_p1; reflexivity). Defined. Definition square_pequiv_pfiber {A B C D} {f : A ->* B} {g : C ->* D} (h : A <~>* C) (k : B <~>* D) (p : k o* f ==* g o* h) : h o* pfib f ==* pfib g o* pequiv_pfiber h k p := square_functor_pfiber p. (** The triple-fiber functor is equal to the negative of the loopspace functor. *) Definition pfiber2_fmap_loops {A B : pType} (f : A ->* B) : pfiber2_loops f o* pfib (pfib (pfib f)) ==* fmap loops f o* (loops_inv _ o* pfiber2_loops (pfib f)). Proof. pointed_reduce. simple refine (Build_pHomotopy _ _). - intros [[[x p] q] r]. simpl in *. (** Apparently [destruct q] isn't smart enough to generalize over [p]. *) move q before x; revert dependent x; refine (paths_ind_r _ _ _); intros p r; cbn. rewrite !concat_1p, concat_p1. rewrite paths_ind_r_transport. rewrite transport_arrow_toconst, transport_paths_Fl. rewrite concat_p1, inv_V, ap_V. refine (((r^)..2)^ @ _). rewrite transport_paths_Fl; cbn. rewrite pr1_path_V, !ap_V, !inv_V. apply concat_p1. - reflexivity. Qed. Coq-HoTT-9.0/theories/Pointed/pMap.v000066400000000000000000000203771474641544500172570ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed.Core. Local Open Scope pointed_scope. (** ** Trivially pointed maps *) (** Not infrequently we have a map between two unpointed types and want to consider it as a pointed map that trivially respects some given point in the domain. *) Definition pmap_from_point {A B : Type} (f : A -> B) (a : A) : [A, a] ->* [B, f a] := Build_pMap [A, a] [B, f a] f 1%path. (** A variant of [pmap_from_point] where the domain is pointed, but the codomain is not. *) Definition pmap_from_pointed {A : pType} {B : Type} (f : A -> B) : A ->* [B, f (point A)] := Build_pMap A [B, f (point A)] f 1%path. (** The same, for a dependent pointed map. *) Definition pforall_from_pointed {A : pType} {B : A -> Type} (f : forall x, B x) : pForall A (Build_pFam B (f (point A))) := Build_pForall A (Build_pFam B (f (point A))) f 1%path. (* precomposing the zero map is the zero map *) Lemma precompose_pconst {A B C : pType} (f : B ->* C) : f o* @pconst A B ==* pconst. Proof. srapply Build_pHomotopy. 1: intro; apply point_eq. exact (concat_p1 _ @ concat_1p _)^. Defined. (* postcomposing the zero map is the zero map *) Lemma postcompose_pconst {A B C : pType} (f : A ->* B) : pconst o* f ==* @pconst A C. Proof. srapply Build_pHomotopy. 1: reflexivity. exact (concat_p1 _ @ concat_p1 _ @ ap_const _ _)^. Defined. Lemma pconst_factor {A B : pType} {f : pUnit ->* B} {g : A ->* pUnit} : f o* g ==* pconst. Proof. refine (_ @* precompose_pconst f). apply pmap_postwhisker. symmetry. apply pmap_punit_pconst. Defined. (* We note that the inverse of [path_pmap] computes definitionally on reflexivity, and hence [path_pmap] itself computes typally so. *) Definition equiv_inverse_path_pmap_1 `{Funext} {A B} {f : A ->* B} : (equiv_path_pforall f f)^-1%equiv 1%path = reflexivity f := 1. (** If we have a fiberwise pointed map, with a variable as codomain, this is an induction principle that allows us to assume it respects all basepoints by reflexivity*) Definition fiberwise_pointed_map_rec `{H0 : Funext} {A : Type} {B : A -> pType} (P : forall (C : A -> pType) (g : forall a, B a ->* C a), Type) (H : forall (C : A -> Type) (g : forall a, B a -> C a), P _ (fun a => pmap_from_pointed (g a))) : forall (C : A -> pType) (g : forall a, B a ->* C a), P C g. Proof. equiv_intros (equiv_functor_arrow' (equiv_idmap A) issig_ptype oE equiv_sig_coind _ _) C. destruct C as [C c0]. equiv_intros (@equiv_functor_forall_id _ A _ _ (fun a => issig_pmap (B a) [C a, c0 a]) oE equiv_sig_coind _ _) g. simpl in *. destruct g as [g g0]. unfold point in g0. unfold functor_forall, sig_coind_uncurried. simpl. (* now we need to apply path induction on the homotopy g0 *) pose (path_forall _ c0 g0). assert (p = path_forall (fun x : A => g x (ispointed_type (B x))) c0 g0). 1: reflexivity. induction p. apply moveR_equiv_V in X. induction X. apply H. Defined. (** A alternative constructor to build a pHomotopy between maps into pForall *) Definition Build_pHomotopy_pForall `{Funext} {A B : pType} {C : B -> pType} {f g : A ->* ppforall b, C b} (p : forall a, f a ==* g a) (q : p (point A) ==* phomotopy_path (point_eq f) @* (phomotopy_path (point_eq g))^*) : f ==* g. Proof. snrapply Build_pHomotopy. 1: intro a; exact (path_pforall (p a)). hnf; rapply moveR_equiv_M'. refine (_^ @ ap10 _ _). 2: exact path_equiv_path_pforall_phomotopy_path. apply path_pforall. refine (phomotopy_path_pp _ _ @* _ @* q^*). apply phomotopy_prewhisker. apply phomotopy_path_V. Defined. (** Operations on dependent pointed maps *) (* functorial action of [pForall A B] in [B] *) Definition functor_pforall_right {A : pType} {B B' : pFam A} (f : forall a, B a -> B' a) (p : f (point A) (dpoint B) = dpoint B') (g : pForall A B) : pForall A B' := Build_pForall A B' (fun a => f a (g a)) (ap (f (point A)) (dpoint_eq g) @ p). Definition equiv_functor_pforall_id `{Funext} {A : pType} {B B' : pFam A} (f : forall a, B a <~> B' a) (p : f (point A) (dpoint B) = dpoint B') : pForall A B <~> pForall A B'. Proof. refine (issig_pforall _ _ oE _ oE (issig_pforall _ _)^-1). srapply equiv_functor_sigma'. 1: exact (equiv_functor_forall_id f). intro s; cbn. refine (equiv_concat_r p _ oE _). apply (equiv_ap' (f (point A))). Defined. Definition functor2_pforall_right {A : pType} {B C : pFam A} {g g' : forall (a : A), B a -> C a} {g₀ : g (point A) (dpoint B) = dpoint C} {g₀' : g' (point A) (dpoint B) = dpoint C} {f f' : pForall A B} (p : forall a, g a == g' a) (q : f ==* f') (r : p (point A) (dpoint B) @ g₀' = g₀) : functor_pforall_right g g₀ f ==* functor_pforall_right g' g₀' f'. Proof. srapply Build_pHomotopy. 1: { intro a. refine (p a (f a) @ ap (g' a) (q a)). } pointed_reduce_rewrite. symmetry. apply concat_Ap. Defined. Definition functor2_pforall_right_refl {A : pType} {B C : pFam A} (g : forall a, B a -> C a) (g₀ : g (point A) (dpoint B) = dpoint C) (f : pForall A B) : functor2_pforall_right (fun a => reflexivity (g a)) (phomotopy_reflexive f) (concat_1p _) ==* phomotopy_reflexive (functor_pforall_right g g₀ f). Proof. pointed_reduce. reflexivity. Defined. (* functorial action of [pForall A (pointed_fam B)] in [B]. *) Definition pmap_compose_ppforall {A : pType} {B B' : A -> pType} (g : forall a, B a ->* B' a) (f : ppforall a, B a) : ppforall a, B' a. Proof. simple refine (functor_pforall_right _ _ f). + exact g. + exact (point_eq (g (point A))). Defined. Definition pmap_compose_ppforall_point {A : pType} {B B' : A -> pType} (g : forall a, B a ->* B' a) : pmap_compose_ppforall g (point_pforall B) ==* point_pforall B'. Proof. srapply Build_pHomotopy. + intro x. exact (point_eq (g x)). + exact (concat_p1 _ @ concat_1p _)^. Defined. Definition pmap_compose_ppforall_compose {A : pType} {P Q R : A -> pType} (h : forall (a : A), Q a ->* R a) (g : forall (a : A), P a ->* Q a) (f : ppforall a, P a) : pmap_compose_ppforall (fun a => h a o* g a) f ==* pmap_compose_ppforall h (pmap_compose_ppforall g f). Proof. srapply Build_pHomotopy. + reflexivity. + simpl. refine ((whiskerL _ (inverse2 _)) @ concat_pV _)^. refine (whiskerR _ _ @ concat_pp_p _ _ _). refine (ap_pp _ _ _ @ whiskerR (ap_compose _ _ _)^ _). Defined. Definition pmap_compose_ppforall2 {A : pType} {P Q : A -> pType} {g g' : forall (a : A), P a ->* Q a} {f f' : ppforall (a : A), P a} (p : forall a, g a ==* g' a) (q : f ==* f') : pmap_compose_ppforall g f ==* pmap_compose_ppforall g' f'. Proof. srapply functor2_pforall_right. + exact p. + exact q. + exact (point_htpy (p (point A))). Defined. Definition pmap_compose_ppforall2_left {A : pType} {P Q : A -> pType} {g g' : forall (a : A), P a ->* Q a} (f : ppforall (a : A), P a) (p : forall a, g a ==* g' a) : pmap_compose_ppforall g f ==* pmap_compose_ppforall g' f := pmap_compose_ppforall2 p (phomotopy_reflexive f). Definition pmap_compose_ppforall2_right {A : pType} {P Q : A -> pType} (g : forall (a : A), P a ->* Q a) {f f' : ppforall (a : A), P a} (q : f ==* f') : pmap_compose_ppforall g f ==* pmap_compose_ppforall g f' := pmap_compose_ppforall2 (fun a => phomotopy_reflexive (g a)) q. Definition pmap_compose_ppforall2_refl `{Funext} {A : pType} {P Q : A -> pType} (g : forall (a : A), P a ->* Q a) (f : ppforall (a : A), P a) : pmap_compose_ppforall2 (fun a => phomotopy_reflexive (g a)) (phomotopy_reflexive f) ==* phomotopy_reflexive _. Proof. unfold pmap_compose_ppforall2. revert Q g. refine (fiberwise_pointed_map_rec _ _). intros Q g. srapply functor2_pforall_right_refl. Defined. Definition pmap_compose_ppforall_pid_left {A : pType} {P : A -> pType} (f : ppforall (a : A), P a) : pmap_compose_ppforall (fun a => pmap_idmap) f ==* f. Proof. srapply Build_pHomotopy. + reflexivity. + symmetry. refine (whiskerR (concat_p1 _ @ ap_idmap _) _ @ concat_pV _). Defined. Definition pmap_compose_ppforall_path_pforall `{Funext} {A : pType} {P Q : A -> pType} (g : forall a, P a ->* Q a) {f f' : ppforall a, P a} (p : f ==* f') : ap (pmap_compose_ppforall g) (path_pforall p) = path_pforall (pmap_compose_ppforall2_right g p). Proof. revert f' p. refine (phomotopy_ind _ _). refine (ap _ path_pforall_1 @ path_pforall_1^ @ ap _ _^). exact (path_pforall (pmap_compose_ppforall2_refl _ _)). Defined. Coq-HoTT-9.0/theories/Pointed/pModality.v000066400000000000000000000057211474641544500203200ustar00rootroot00000000000000Require Import Basics Types ReflectiveSubuniverse Pointed.Core. Local Open Scope pointed_scope. (** * Modalities, reflective subuniverses and pointed types *) (** So far, everything is about general reflective subuniverses, but in the future results about modalities can be placed here as well. *) Global Instance ispointed_O `{O : ReflectiveSubuniverse} (X : Type) `{IsPointed X} : IsPointed (O X) := to O _ (point X). Definition pto (O : ReflectiveSubuniverse@{u}) (X : pType@{u}) : X ->* [O X, _] := Build_pMap X [O X, _] (to O X) idpath. (** If [A] is already [O]-local, then Coq knows that [pto] is an equivalence, so we can simply define: *) Definition pequiv_pto `{O : ReflectiveSubuniverse} {X : pType} `{In O X} : X <~>* [O X, _] := Build_pEquiv _ _ (pto O X) _. (** Applying [O_rec] to a pointed map yields a pointed map. *) Definition pO_rec `{O : ReflectiveSubuniverse} {X Y : pType} `{In O Y} (f : X ->* Y) : [O X, _] ->* Y := Build_pMap [O X, _] _ (O_rec f) (O_rec_beta _ _ @ point_eq f). Definition pO_rec_beta `{O : ReflectiveSubuniverse} {X Y : pType} `{In O Y} (f : X ->* Y) : pO_rec f o* pto O X ==* f. Proof. srapply Build_pHomotopy. 1: nrapply O_rec_beta. cbn. apply moveL_pV. exact (concat_1p _)^. Defined. (** A pointed version of the universal property. *) Definition pequiv_o_pto_O `{Funext} (O : ReflectiveSubuniverse) (P Q : pType) `{In O Q} : ([O P, _] ->** Q) <~>* (P ->** Q). Proof. snrapply Build_pEquiv. (* We could just use the map [e] defined in the next bullet, but we want Coq to immediately unfold the underlying map to this. *) - exact (Build_pMap _ _ (fun f => f o* pto O P) 1). (* We'll give an equivalence that definitionally has the same underlying map. *) - transparent assert (e : (([O P, _] ->* Q) <~> (P ->* Q))). + refine (issig_pmap P Q oE _ oE (issig_pmap [O P, _] Q)^-1%equiv). snrapply equiv_functor_sigma'. * rapply equiv_o_to_O. * intro f; cbn. (* [reflexivity] works here, but then the underlying map won't agree definitionally with precomposition by [pto P], since pointed composition inserts a reflexivity path here. *) apply (equiv_concat_l 1). + apply (equiv_isequiv e). Defined. (** ** Pointed functoriality *) Definition O_pfunctor `(O : ReflectiveSubuniverse) {X Y : pType} (f : X ->* Y) : [O X, _] ->* [O Y, _] := pO_rec (pto O Y o* f). (** Coq knows that [O_pfunctor O f] is an equivalence whenever [f] is. *) Definition equiv_O_pfunctor `(O : ReflectiveSubuniverse) {X Y : pType} (f : X ->* Y) `{IsEquiv _ _ f} : [O X, _] <~>* [O Y, _] := Build_pEquiv _ _ (O_pfunctor O f) _. (** Pointed naturality of [O_pfunctor]. *) Definition pto_O_natural `(O : ReflectiveSubuniverse) {X Y : pType} (f : X ->* Y) : O_pfunctor O f o* pto O X ==* pto O Y o* f. Proof. nrapply pO_rec_beta. Defined. Definition pequiv_O_inverts `(O : ReflectiveSubuniverse) {X Y : pType} (f : X ->* Y) `{O_inverts O f} : [O X, _] <~>* [O Y, _] := Build_pEquiv _ _ (O_pfunctor O f) _. Coq-HoTT-9.0/theories/Pointed/pSect.v000066400000000000000000000040051474641544500174260ustar00rootroot00000000000000Require Import Basics Types Pointed.Core Pointed.pEquiv. (** * Pointed sections of pointed maps *) Local Open Scope pointed_scope. (* The type of pointed sections of a pointed map. *) Definition pSect {A B : pType} (f : A ->* B) := { s : B ->* A & f o* s ==* pmap_idmap }. Definition issig_psect { A B : pType } (f : A ->* B) : { s : B -> A & { p : s pt = pt & { H : f o s == idmap & H pt = ap f p @ (point_eq f) } } } <~> pSect f. Proof. transitivity {s : B -> A & {p : s pt = pt & {H : f o s == idmap & H pt = ap f p @ (point_eq f) @ 1 }}}. 2: make_equiv. do 3 (nrapply equiv_functor_sigma_id; intro). rapply equiv_concat_r. exact (concat_p1 _)^. Defined. (** Any pointed equivalence over [A] induces an equivalence between pointed sections. *) Definition equiv_pequiv_pslice_psect `{Funext} {A B C : pType} (f : B ->* A) (g : C ->* A) (t : B <~>* C) (h : f ==* g o* t) : pSect f <~> pSect g. Proof. srapply equiv_functor_sigma'. 1: exact (pequiv_pequiv_postcompose t). intro s; cbn. apply equiv_phomotopy_concat_l. refine ((pmap_compose_assoc _ _ _)^* @* _). apply pmap_prewhisker. exact h^*. Defined. (** Pointed sections of [psnd : A * B ->* B] correspond to pointed maps [B ->* A]. *) Definition equiv_psect_psnd `{Funext} {A B : pType} : pSect (@psnd A B) <~> (B ->* A). Proof. unfold pSect. transitivity {s : (B ->* A) * (B ->* B) & snd s ==* pmap_idmap}. { snrefine (equiv_functor_sigma' (equiv_pprod_coind (pfam_const A) (pfam_const B))^-1%equiv _). cbn. intro s. apply equiv_phomotopy_concat_l. srapply Build_pHomotopy. 1: reflexivity. cbn. apply moveL_pV. exact (concat_1p _ @ concat_p1 _). } snrefine (_ oE equiv_functor_sigma_id (fun s => equiv_path_pforall _ _)). snrefine (_ oE (equiv_functor_sigma_pb (equiv_sigma_prod0 _ _))^-1%equiv); cbn. refine (_ oE (equiv_sigma_assoc _ _)^-1%equiv). rapply equiv_sigma_contr. Defined. Coq-HoTT-9.0/theories/Pointed/pSusp.v000066400000000000000000000251141474641544500174660ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import Pointed.Core. Require Import Pointed.Loops. Require Import Pointed.pTrunc. Require Import Pointed.pEquiv. Require Import Homotopy.Suspension. Require Import Homotopy.Freudenthal. Require Import Truncations. Require Import WildCat. Generalizable Variables X A B f g n. Local Open Scope path_scope. Local Open Scope pointed_scope. (** ** Pointedness of [Susp] and path spaces thereof *) (** We arbitrarily choose [North] to be the point. *) Global Instance ispointed_susp {X : Type} : IsPointed (Susp X) | 0 := North. Global Instance ispointed_path_susp `{IsPointed X} : IsPointed (North = South :> Susp X) | 0 := merid (point X). Global Instance ispointed_path_susp' `{IsPointed X} : IsPointed (South = North :> Susp X) | 0 := (merid (point X))^. Definition psusp (X : Type) : pType := [Susp X, _]. (** ** Suspension Functor *) (** [psusp] has a functorial action. *) (** TODO: make this a displayed functor *) Global Instance is0functor_psusp : Is0Functor psusp := Build_Is0Functor _ _ _ _ psusp (fun X Y f => Build_pMap (psusp X) (psusp Y) (functor_susp f) 1). (** [psusp] is a 1-functor. *) Global Instance is1functor_psusp : Is1Functor psusp. Proof. snrapply Build_Is1Functor. (** Action on 2-cells *) - intros X Y f g p. pointed_reduce. srapply Build_pHomotopy. { simpl. srapply Susp_ind. 1,2: reflexivity. intro x; cbn. rewrite transport_paths_FlFr. rewrite concat_p1. rewrite 2 Susp_rec_beta_merid. destruct (p x). apply concat_Vp. } reflexivity. (** Preservation of identity. *) - intros X. srapply Build_pHomotopy. { srapply Susp_ind; try reflexivity. intro x. refine (transport_paths_FFlr _ _ @ _). by rewrite ap_idmap, Susp_rec_beta_merid, concat_p1, concat_Vp. } reflexivity. (** Preservation of composition. *) - pointed_reduce_rewrite; srefine (Build_pHomotopy _ _); cbn. { srapply Susp_ind; try reflexivity; cbn. intros x. refine (transport_paths_FlFr _ _ @ _). rewrite concat_p1; apply moveR_Vp. by rewrite concat_p1, ap_compose, !Susp_rec_beta_merid. } reflexivity. Defined. (** ** Loop-Suspension Adjunction *) Module Book_Loop_Susp_Adjunction. (** Here is the proof of the adjunction isomorphism given in the book (6.5.4); we put it in a non-exported module for reasons discussed below. *) Definition loop_susp_adjoint `{Funext} (A B : pType) : (psusp A ->* B) <~> (A ->* loops B). Proof. refine (_ oE (issig_pmap (psusp A) B)^-1). refine (_ oE (equiv_functor_sigma_pb (Q := fun NSm => fst NSm.1 = point B) (equiv_Susp_rec A B))). transitivity {bp : {b:B & b = point B} & {b:B & A -> bp.1 = b} }. 1:make_equiv. refine (_ oE equiv_contr_sigma _); simpl. refine (_ oE (equiv_sigma_contr (A := {p : B & A -> point B = p}) (fun pm => { q : point B = pm.1 & pm.2 (point A) = q }))^-1). make_equiv_contr_basedpaths. Defined. (** Unfortunately, with this definition it seems to be quite hard to prove that the isomorphism is natural on pointed maps. The following proof gets partway there, but ends with a pretty intractable goal. It's also quite slow, so we don't want to compile it all the time. *) (** << Definition loop_susp_adjoint_nat_r `{Funext} (A B B' : pType) (f : psusp A ->* B) (g : B ->* B') : loop_susp_adjoint A B' (g o* f) ==* fmap loops g o* loop_susp_adjoint A B f. Proof. pointed_reduce. (* Very slow for some reason. *) srefine (Build_pHomotopy _ _). - intros a. simpl. refine (_ @ (concat_1p _)^). refine (_ @ (concat_p1 _)^). rewrite !transport_sigma. simpl. rewrite !(transport_arrow_fromconst (B := A)). rewrite !transport_paths_Fr. rewrite !ap_V, !ap_pr1_path_basedpaths. Fail rewrite ap_pp, !(ap_compose f g), ap_V. (* This line fails with current versions of the library. *) Fail reflexivity. admit. - cbn. Fail reflexivity. Abort. >> *) End Book_Loop_Susp_Adjunction. (** Thus, instead we will construct the adjunction in terms of a unit and counit natural transformation. *) Definition loop_susp_unit (X : pType) : X ->* loops (psusp X) := Build_pMap X (loops (psusp X)) (fun x => merid x @ (merid (point X))^) (concat_pV _). (** By Freudenthal, we have that this map is (2n+2)-connected when [X] is (n+1)-connected. *) Global Instance conn_map_loop_susp_unit `{Univalence} (n : trunc_index) (X : pType) `{IsConnected n.+1 X} : IsConnMap (n +2+ n) (loop_susp_unit X). Proof. refine (conn_map_compose _ merid (equiv_concat_r (merid pt)^ _)). Defined. (** We also have this corollary: *) Definition pequiv_ptr_loop_psusp `{Univalence} (X : pType) n `{IsConnected n.+1 X} : pTr (n +2+ n) X <~>* pTr (n +2+ n) (loops (psusp X)). Proof. snrapply Build_pEquiv. 1:rapply (fmap (pTr _) (loop_susp_unit _)). rapply O_inverts_conn_map. Defined. Definition loop_susp_unit_natural {X Y : pType} (f : X ->* Y) : loop_susp_unit Y o* f ==* fmap loops (fmap psusp f) o* loop_susp_unit X. Proof. pointed_reduce. simple refine (Build_pHomotopy _ _); cbn. - intros x; symmetry. refine (concat_1p _@ (concat_p1 _ @ _)). refine (ap_pp (Susp_rec North South (merid o f)) (merid x) (merid (point X))^ @ _). refine ((1 @@ ap_V _ _) @ _). refine (Susp_rec_beta_merid _ @@ inverse2 (Susp_rec_beta_merid _)). - cbn. apply moveL_pV. rewrite !inv_pp, !concat_pp_p, concat_1p; symmetry. apply moveL_Vp. refine (concat_pV_inverse2 _ _ (Susp_rec_beta_merid (point X)) @ _). apply moveL_Vp, moveL_Vp. refine (ap_pp_concat_pV _ _ @ _). apply moveL_Vp, moveL_Vp. rewrite concat_p1_1, concat_1p_1. cbn; symmetry. refine (concat_p1 _ @ _). refine (ap_compose (fun p' => (ap (Susp_rec North South (merid o f))) p' @ 1) (fun p' => 1 @ p') (concat_pV (merid (point X))) @ _). apply ap. refine (ap_compose (ap (Susp_rec North South (merid o f))) (fun p' => p' @ 1) _). Qed. Definition loop_susp_counit (X : pType) : psusp (loops X) ->* X := Build_pMap (psusp (loops X)) X (Susp_rec (point X) (point X) idmap) 1. Definition loop_susp_counit_natural {X Y : pType} (f : X ->* Y) : f o* loop_susp_counit X ==* loop_susp_counit Y o* fmap psusp (fmap loops f). Proof. pointed_reduce. simple refine (Build_pHomotopy _ _); simpl. - simple refine (Susp_ind _ _ _ _); cbn; try reflexivity; intros p. rewrite transport_paths_FlFr, ap_compose, concat_p1. apply moveR_Vp. refine (ap_compose (Susp_rec North South (fun x0 => merid (1 @ (ap f x0 @ 1)))) (Susp_rec (point Y) (point Y) idmap) (merid p) @ _). do 2 rewrite Susp_rec_beta_merid. refine (concat_1p _ @ _). f_ap. f_ap. symmetry. refine (Susp_rec_beta_merid _). - reflexivity. Qed. (** Now the triangle identities *) Definition loop_susp_triangle1 (X : pType) : fmap loops (loop_susp_counit X) o* loop_susp_unit (loops X) ==* pmap_idmap. Proof. simple refine (Build_pHomotopy _ _). - intros p; cbn. refine (concat_1p _ @ (concat_p1 _ @ _)). refine (ap_pp (Susp_rec (point X) (point X) idmap) (merid p) (merid (point (point X = point X)))^ @ _). refine ((1 @@ ap_V _ _) @ _). refine ((Susp_rec_beta_merid p @@ inverse2 (Susp_rec_beta_merid (point (loops X)))) @ _). exact (concat_p1 _). - apply moveL_pV. destruct X as [X x]; cbn; unfold point. apply whiskerR. rewrite (concat_pV_inverse2 (ap (Susp_rec x x idmap) (merid 1)) 1 (Susp_rec_beta_merid 1)). rewrite (ap_pp_concat_pV (Susp_rec x x idmap) (merid 1)). rewrite ap_compose, (ap_compose _ (fun p => p @ 1)). rewrite concat_1p_1; apply ap. apply concat_p1_1. Qed. Definition loop_susp_triangle2 (X : pType) : loop_susp_counit (psusp X) o* fmap psusp (loop_susp_unit X) ==* pmap_idmap. Proof. simple refine (Build_pHomotopy _ _); [ simple refine (Susp_ind _ _ _ _) | ]; try reflexivity; cbn. - exact (merid (point X)). - intros x. rewrite transport_paths_FlFr, ap_idmap, ap_compose. rewrite Susp_rec_beta_merid. apply moveR_pM; rewrite concat_p1. refine (inverse2 (Susp_rec_beta_merid _) @ _). rewrite inv_pp, inv_V; reflexivity. Qed. (** Now we can finally construct the adjunction equivalence. *) Definition loop_susp_adjoint `{Funext} (A B : pType) : (psusp A ->** B) <~>* (A ->** loops B). Proof. snrapply Build_pEquiv'. - refine (equiv_adjointify (fun f => fmap loops f o* loop_susp_unit A) (fun g => loop_susp_counit B o* fmap psusp g) _ _). + intros g. apply path_pforall. refine (pmap_prewhisker _ (fmap_comp loops _ _) @* _). refine (pmap_compose_assoc _ _ _ @* _). refine (pmap_postwhisker _ (loop_susp_unit_natural g)^* @* _). refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker g (loop_susp_triangle1 B) @* _). apply pmap_postcompose_idmap. + intros f. apply path_pforall. refine (pmap_postwhisker _ (fmap_comp psusp _ _) @* _). refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker _ (loop_susp_counit_natural f)^* @* _). refine (pmap_compose_assoc _ _ _ @* _). refine (pmap_postwhisker f (loop_susp_triangle2 A) @* _). apply pmap_precompose_idmap. - apply path_pforall. unfold equiv_adjointify, equiv_fun. nrapply (pmap_prewhisker _ fmap_loops_pconst @* _). rapply cat_zero_l. Defined. (** And its naturality is easy. *) Definition loop_susp_adjoint_nat_r `{Funext} (A B B' : pType) (f : psusp A ->* B) (g : B ->* B') : loop_susp_adjoint A B' (g o* f) ==* fmap loops g o* loop_susp_adjoint A B f. Proof. cbn. refine (_ @* pmap_compose_assoc _ _ _). apply pmap_prewhisker. refine (fmap_comp loops f g). Defined. Definition loop_susp_adjoint_nat_l `{Funext} (A A' B : pType) (f : A ->* loops B) (g : A' ->* A) : (loop_susp_adjoint A' B)^-1 (f o* g) ==* (loop_susp_adjoint A B)^-1 f o* fmap psusp g. Proof. cbn. refine (_ @* (pmap_compose_assoc _ _ _)^*). apply pmap_postwhisker. exact (fmap_comp psusp g f). Defined. Global Instance is1natural_loop_susp_adjoint_r `{Funext} (A : pType) : Is1Natural (opyon (psusp A)) (opyon A o loops) (loop_susp_adjoint A). Proof. snrapply Build_Is1Natural. intros B B' g f. refine ( _ @ cat_assoc_strong _ _ _). refine (ap (fun x => x o* loop_susp_unit A) _). apply path_pforall. rapply (fmap_comp loops). Defined. Lemma natequiv_loop_susp_adjoint_r `{Funext} (A : pType) : NatEquiv (opyon (psusp A)) (opyon A o loops). Proof. rapply Build_NatEquiv. Defined. Coq-HoTT-9.0/theories/Pointed/pTrunc.v000066400000000000000000000162431474641544500176320ustar00rootroot00000000000000Require Import Basics Types WildCat Truncations Pointed.Core Pointed.pEquiv Pointed.Loops Pointed.pModality. Local Open Scope pointed_scope. (** * Truncations of pointed types *) (** TODO: Many things here can be generalized to any modality or any reflective subuniverse, and could be moved to pModality.v *) Definition pTr (n : trunc_index) (A : pType) : pType := [Tr n A, _]. (** We specialize [pto] and [pequiv_pto] from pModalities.v to truncations. *) Definition ptr {n : trunc_index} {A : pType} : A ->* pTr n A := pto (Tr n) _. Definition pequiv_ptr {n : trunc_index} {A : pType} `{IsTrunc n A} : A <~>* pTr n A := @pequiv_pto (Tr n) A _. (** We could specialize [pO_rec] to give the following result, but since maps induced by truncation-recursion compute on elements of the form [tr _], we can give a better proof of pointedness than the one coming from [pO_rec]. *) Definition pTr_rec n {X Y : pType} `{IsTrunc n Y} (f : X ->* Y) : pTr n X ->* Y := Build_pMap (pTr n X) Y (Trunc_rec f) (point_eq f). (** Note that we get an equality of pointed functions here, without Funext, while [pO_rec_beta] only gives a pointed homotopy. This is because [pTr_rec] computes on elements of the form [tr _]. *) Definition pTr_rec_beta_path n {X Y : pType} `{IsTrunc n Y} (f : X ->* Y) : pTr_rec n f o* ptr = f. Proof. unfold pTr_rec, "o*"; cbn. (* Since [f] is definitionally equal to [Build_pMap _ _ f (point_eq f)], this works: *) apply (ap (Build_pMap _ _ f)). apply concat_1p. Defined. (** The version with a pointed homotopy. *) Definition pTr_rec_beta n {X Y : pType} `{IsTrunc n Y} (f : X ->* Y) : pTr_rec n f o* ptr ==* f := phomotopy_path (pTr_rec_beta_path n f). (** A pointed version of the induction principle. *) Definition pTr_ind n {X : pType} {Y : pFam (pTr n X)} `{forall x, IsTrunc n (Y x)} (f : pForall X (Build_pFam (Y o tr) (dpoint Y))) : pForall (pTr n X) Y := Build_pForall (pTr n X) Y (Trunc_ind Y f) (dpoint_eq f). Definition pequiv_ptr_rec `{Funext} {n} {X Y : pType} `{IsTrunc n Y} : (pTr n X ->** Y) <~>* (X ->** Y) := pequiv_o_pto_O _ X Y. (** ** Functoriality of [pTr] *) Global Instance is0functor_ptr n : Is0Functor (pTr n). Proof. apply Build_Is0Functor. intros X Y f. exact (pTr_rec _ (ptr o* f)). Defined. Global Instance is1functor_ptr n : Is1Functor (pTr n). Proof. apply Build_Is1Functor. - intros X Y f g p. srapply pTr_ind; cbn. snrapply Build_pForall. + cbn. exact (fun x => ap tr (p x)). + pointed_reduce. exact (concat_p1 _ @ concat_p1 _ @ ap _ (concat_p1 _))^. - intros X. srapply Build_pHomotopy. 1: apply Trunc_rec_tr. cbn. reflexivity. - intros X Y Z f g. srapply Build_pHomotopy. 1: by rapply Trunc_ind. by pointed_reduce. Defined. (** Naturality of [ptr]. Note that we get a equality of pointed functions, not just a pointed homotopy. *) Definition ptr_natural_path (n : trunc_index) {X Y : pType} (f : X ->* Y) : fmap (pTr n) f o* ptr = ptr o* f := pTr_rec_beta_path n (ptr o* f). (** The version with a pointed homotopy. *) Definition ptr_natural (n : trunc_index) {X Y : pType} (f : X ->* Y) : fmap (pTr n) f o* ptr ==* ptr o* f := phomotopy_path (ptr_natural_path n f). Definition ptr_functor_pconst {X Y : pType} n : fmap (pTr n) (@pconst X Y) ==* pconst. Proof. srapply Build_pHomotopy. 1: by rapply Trunc_ind. reflexivity. Defined. Definition pequiv_ptr_functor {X Y : pType} (n : trunc_index) (f : X <~>* Y) : pTr n X <~>* pTr n Y := emap (pTr n) f. Definition ptr_loops `{Univalence} (n : trunc_index) (A : pType) : pTr n (loops A) <~>* loops (pTr n.+1 A). Proof. srapply Build_pEquiv'. 1: apply equiv_path_Tr. reflexivity. Defined. Definition ptr_iterated_loops `{Univalence} (n : trunc_index) (k : nat) (A : pType) : pTr n (iterated_loops k A) <~>* iterated_loops k (pTr (trunc_index_inc' n k) A). Proof. revert A n. induction k. { intros A n; cbn. reflexivity. } intros A n. cbn; etransitivity. 1: apply ptr_loops. rapply (emap loops). apply IHk. Defined. Definition ptr_loops_eq `{Univalence} (n : trunc_index) (A : pType) : pTr n (loops A) = loops (pTr n.+1 A) :> pType := path_ptype (ptr_loops n A). (* This lemma generalizes a goal that appears in [ptr_loops_commutes], allowing us to prove it by path induction. *) Definition path_Tr_commutes (n : trunc_index) (A : Type) (a0 a1 : A) (p : a0 = a1) : path_Tr (n:=n) (tr p) = ap tr p. Proof. by destruct p. Defined. (* [ptr_loops] commutes with the two [ptr] maps. *) Definition ptr_loops_commutes `{Univalence} (n : trunc_index) (A : pType) : (ptr_loops n A) o* ptr ==* fmap loops ptr. Proof. srapply Build_pHomotopy. - intro p. simpl. refine (_ @ _). + apply path_Tr_commutes. + symmetry; refine (_ @ _). * apply concat_1p. * apply concat_p1. - simpl. reflexivity. Defined. (** Pointed truncation preserves binary products. *) Definition pequiv_ptr_prod (n : trunc_index) (A B : pType) : pTr n (A * B) <~>* pTr n A * pTr n B. Proof. snrapply Build_pEquiv'. 1: nrapply equiv_Trunc_prod_cmp. reflexivity. Defined. (** ** Truncatedness of [pForall] and [pMap] *) (** Buchholtz-van Doorn-Rijke, Theorem 4.2: Let [j >= -1] and [n >= -2]. When [X] is [j]-connected and [Y] is a pointed family of [j+k+1]-truncated types, the type of pointed sections is [n]-truncated. We formalize it with [j] replaced with a trunc index [m], and so there is a shift compared to the informal statement. This version also allows [n] to be one smaller than BvDR allow. *) Definition istrunc_pforall `{Univalence} {m n : trunc_index} (X : pType@{u}) {iscX : IsConnected m.+1 X} (Y : pFam@{u v} X) {istY : forall x, IsTrunc (n +2+ m) (Y x)} : IsTrunc@{w} n (pForall X Y). Proof. nrapply (istrunc_equiv_istrunc _ (equiv_extension_along_pforall@{v w u} Y)). rapply (istrunc_extension_along_conn (n:=m) _ Y (HP:=istY)). Defined. (** From this we deduce the non-dependent version, which is Corollary 4.3 of BvDR. We include [n = -2] here as well, but in this case it is not interesting. Since [X ->* Y] is inhabited, the [n = -1] case also gives contractibility, with weaker hypotheses. *) Definition istrunc_pmap `{Univalence} {m n : trunc_index} (X Y : pType) `{!IsConnected m.+1 X} `{!IsTrunc (n +2+ m) Y} : IsTrunc n (X ->* Y) := istrunc_pforall X (pfam_const Y). (** We can give a different proof of the [n = -1] case (with the conclusion upgraded to contractibility). This proof works for any reflective subuniverse and avoids univalence. Is it possible to generalize this to dependent functions while still avoiding univalence and/or keeping [O] a general RSU or modality? Can [istrunc_pmap] be proven without univalence? What about [istrunc_pforall]? If the [n = -2] or [n = -1] cases can be proven without univalence, the rest can be done inductively without univalence. *) Definition contr_pmap_isconnected_inO `{Funext} (O : ReflectiveSubuniverse) (X : pType) `{IsConnected O X} (Y : pType) `{In O Y} : Contr (X ->* Y). Proof. srapply (contr_equiv' ([O X, _] ->* Y)). rapply pequiv_o_pto_O. Defined. (** Every pointed type is (-1)-connected. *) Global Instance is_minus_one_connected_pointed (X : pType) : IsConnected (Tr (-1)) X := contr_inhabited_hprop _ (tr pt). Coq-HoTT-9.0/theories/Projective.v000066400000000000000000000135041474641544500170640ustar00rootroot00000000000000Require Import Basics Types. Require Import Truncations.Core Truncations.SeparatedTrunc. Require Import Modalities.Modality Modalities.Identity. Require Import Limits.Pullback. (** * Projective types *) (** To quantify over all truncation levels including infinity, we parametrize [IsOProjective] by a [Modality]. When specializing to [IsOProjective purely] we get an (oo,-1)-projectivity predicate, [IsProjective]. When specializing to [IsOProjective (Tr n)] we get an (n,-1)-projectivity predicate, [IsTrProjective]. *) Definition IsOProjective (O : Modality) (X : Type) : Type := forall A, In O A -> forall B, In O B -> forall f : X -> B, forall p : A -> B, IsSurjection p -> merely (exists s : X -> A, p o s == f). (** (oo,-1)-projectivity. *) Notation IsProjective := (IsOProjective purely). (** (n,-1)-projectivity. *) Notation IsTrProjective n := (IsOProjective (Tr n)). (** A type X is projective if and only if surjections into X merely split. *) Proposition iff_isoprojective_surjections_split (O : Modality) (X : Type) `{In O X} : IsOProjective O X <-> (forall (Y : Type), In O Y -> forall (p : Y -> X), IsSurjection p -> merely (exists s : X -> Y, p o s == idmap)). Proof. split. - intros isprojX Y oY p S; unfold IsOProjective in isprojX. exact (isprojX Y _ X _ idmap p S). - intro splits. unfold IsOProjective. intros A oA B oB f p S. pose proof (splits (Pullback p f) _ pullback_pr2 _) as s'. strip_truncations. destruct s' as [s E]. refine (tr (pullback_pr1 o s; _)). intro x. refine (pullback_commsq p f (s x) @ _). apply (ap f). apply E. Defined. Corollary equiv_isoprojective_surjections_split `{Funext} (O : Modality) (X : Type) `{In O X} : IsOProjective O X <~> (forall (Y : Type), In O Y -> forall (p : Y -> X), IsSurjection p -> merely (exists s : X -> Y, p o s == idmap)). Proof. exact (equiv_iff_hprop_uncurried (iff_isoprojective_surjections_split O X)). Defined. (** ** Projectivity and the axiom of choice *) (** In topos theory, an object X is said to be projective if the axiom of choice holds when making choices indexed by X. We will refer to this as [HasOChoice], to avoid confusion with [IsOProjective] above. In similarity with [IsOProjective], we parametrize it by a [Modality]. *) Class HasOChoice (O : Modality) (A : Type) := hasochoice : forall (B : A -> Type), (forall x, In O (B x)) -> (forall x, merely (B x)) -> merely (forall x, B x). (** (oo,-1)-choice. *) Notation HasChoice := (HasOChoice purely). (** (n,-1)-choice. *) Notation HasTrChoice n := (HasOChoice (Tr n)). Global Instance hasochoice_sigma `{Funext} {A : Type} {B : A -> Type} (O : Modality) (chA : HasOChoice O A) (chB : forall a : A, HasOChoice O (B a)) : HasOChoice O {a : A | B a}. Proof. intros C sC f. set (f' := fun a => chB a (fun b => C (a; b)) _ (fun b => f (a; b))). specialize (chA (fun a => forall b, C (a; b)) _ f'). strip_truncations. apply tr. intro. apply chA. Defined. Proposition isoprojective_ochoice (O : Modality) (X : Type) : HasOChoice O X -> IsOProjective O X. Proof. intros chX A ? B ? f p S. assert (g : merely (forall x:X, hfiber p (f x))). - rapply chX. intro x. exact (center _). - strip_truncations; apply tr. exists (fun x:X => pr1 (g x)). intro x. exact (g x).2. Defined. Proposition hasochoice_oprojective (O : Modality) (X : Type) `{In O X} : IsOProjective O X -> HasOChoice O X. Proof. refine (_ o fst (iff_isoprojective_surjections_split O X)). intros splits P oP S. specialize splits with {x : X & P x} pr1. pose proof (splits _ (fst (iff_merely_issurjection P) S)) as M. clear S splits. strip_truncations; apply tr. destruct M as [s p]. intro x. exact (transport _ (p x) (s x).2). Defined. Proposition iff_isoprojective_hasochoice (O : Modality) (X : Type) `{In O X} : IsOProjective O X <-> HasOChoice O X. Proof. split. - apply hasochoice_oprojective. exact _. - apply isoprojective_ochoice. Defined. Proposition equiv_isoprojective_hasochoice `{Funext} (O : Modality) (X : Type) `{In O X} : IsOProjective O X <~> HasOChoice O X. Proof. refine (equiv_iff_hprop_uncurried (iff_isoprojective_hasochoice O X)). apply istrunc_forall. Defined. Proposition isprojective_unit : IsProjective Unit. Proof. apply (isoprojective_ochoice purely Unit). intros P trP S. specialize S with tt. strip_truncations; apply tr. apply Unit_ind. exact S. Defined. Section AC_oo_neg1. (** ** Projectivity and AC_(oo,-1) (defined in HoTT book, Exercise 7.8) *) (* TODO: Generalize to n, m. *) Context {AC : forall X : HSet, HasChoice X}. (** (Exercise 7.9) Assuming AC_(oo,-1) every type merely has a projective cover. *) Proposition projective_cover_AC `{Univalence} (A : Type) : merely (exists X:HSet, exists p : X -> A, IsSurjection p). Proof. pose (X := Build_HSet (Tr 0 A)). pose proof ((equiv_isoprojective_hasochoice _ X)^-1 (AC X)) as P. pose proof (P A _ X _ idmap tr _) as F; clear P. strip_truncations. destruct F as [f p]. refine (tr (X; (f; BuildIsSurjection f _))). intro a; unfold hfiber. apply equiv_O_sigma_O. refine (tr (tr a; _)). rapply (equiv_path_Tr _ _)^-1%equiv. (* Uses Univalence. *) apply p. Defined. (** Assuming AC_(oo,-1), projective types are exactly sets. *) Theorem equiv_isprojective_ishset_AC `{Univalence} (X : Type) : IsProjective X <~> IsHSet X. Proof. apply equiv_iff_hprop. - intro isprojX. unfold IsOProjective in isprojX. pose proof (projective_cover_AC X) as P; strip_truncations. destruct P as [P [p issurj_p]]. pose proof (isprojX P _ X _ idmap p issurj_p) as S; strip_truncations. exact (inO_retract_inO (Tr 0) X P S.1 p S.2). - intro ishsetX. apply (equiv_isoprojective_hasochoice purely X)^-1. rapply AC. Defined. End AC_oo_neg1. Coq-HoTT-9.0/theories/Sets/000077500000000000000000000000001474641544500154765ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Sets/AC.v000066400000000000000000000042351474641544500161540ustar00rootroot00000000000000From HoTT Require Import ExcludedMiddle canonical_names. From HoTT Require Import HIT.unique_choice. From HoTT Require Import Spaces.Card. From HoTT.Sets Require Import Ordinals. Local Open Scope hprop_scope. (** * Set-theoretic formulation of the axiom of choice (AC) *) Monomorphic Axiom Choice : Type0. Existing Class Choice. Definition Choice_type := forall (X Y : HSet) (R : X -> Y -> HProp), (forall x, hexists (R x)) -> hexists (fun f => forall x, R x (f x)). Axiom AC : forall `{Choice}, Choice_type. Global Instance is_global_axiom_propresizing : IsGlobalAxiom Choice := {}. (** * The well-ordering theorem implies AC *) Lemma WO_AC {LEM : ExcludedMiddle} : (forall (X : HSet), hexists (fun (A : Ordinal) => InjectsInto X A)) -> Choice_type. Proof. intros H X Y R HR. specialize (H Y). eapply merely_destruct; try apply H. intros [A HA]. eapply merely_destruct; try apply HA. intros [f Hf]. apply tr. unshelve eexists. - intros x. assert (HR' : hexists (fun y => merely (R x y * forall y', R x y' -> f y < f y' \/ f y = f y'))). + pose proof (HAR := ordinal_has_minimal_hsolutions A (fun a => Build_HProp (merely (exists y, f y = a /\ R x y)))). eapply merely_destruct; try apply HAR. * eapply merely_destruct; try apply (HR x). intros [y Hy]. apply tr. exists (f y). apply tr. exists y. by split. * intros [a [H1 H2]]. eapply merely_destruct; try apply H1. intros [y [<- Hy]]. apply tr. exists y. apply tr. split; trivial. intros y' Hy'. apply H2. apply tr. exists y'. split; trivial. + edestruct (@iota Y) as [y Hy]; try exact y. 2: split; try apply HR'. 1: exact _. intros y y' Hy Hy'. eapply merely_destruct; try apply Hy. intros [H1 H2]. eapply merely_destruct; try apply Hy'. intros [H3 H4]. apply Hf. eapply merely_destruct; try apply (H2 y'); trivial. intros [H5|H5]; trivial. eapply merely_destruct; try apply (H4 y); trivial. intros [H6| -> ]; trivial. apply Empty_rec. apply (irreflexive_ordinal_relation _ _ _ (f y)). apply (ordinal_transitivity _ (f y')); trivial. - intros x. cbn. destruct iota as [y Hy]. eapply merely_destruct; try apply Hy. by intros []. Qed. Coq-HoTT-9.0/theories/Sets/GCH.v000066400000000000000000000112721474641544500162710ustar00rootroot00000000000000From HoTT Require Import TruncType abstract_algebra. From HoTT Require Import Universes.Smallness. From HoTT Require Import Spaces.Nat.Core Spaces.Card. Local Open Scope type. Local Open Scope hprop_scope. (** * Formulation of GCH *) (* GCH states that for any infinite set X with Y between X and P(X) either Y embeds into X or P(X) embeds into Y. *) Definition GCH := forall X Y : HSet, infinite X -> InjectsInto X Y -> InjectsInto Y (X -> HProp) -> InjectsInto Y X + InjectsInto (X -> HProp) Y. (** * GCH is a proposition *) Lemma Cantor_inj {PR : PropResizing} {FE : Funext} X : ~ Injection (X -> HProp) X. Proof. intros [i HI]. pose (p n := Build_HProp (smalltype (forall q, i q = n -> ~ q n))). enough (Hp : p (i p) <-> ~ p (i p)). { apply Hp; apply Hp; intros H; by apply Hp. } unfold p at 1. split. - intros H. apply equiv_smalltype in H. apply H. reflexivity. - intros H. apply equiv_smalltype. intros q -> % HI. apply H. Qed. (* The concluding disjunction of GCH is excluse since otherwise we'd obtain an injection of P(X) into X. *) Lemma hprop_GCH {PR : PropResizing} {FE : Funext} : IsHProp GCH. Proof. repeat (nrapply istrunc_forall; intros). apply hprop_allpath. intros [H|H] [H'|H']. - enough (H = H') as ->; trivial. apply path_ishprop. - apply Empty_rec. eapply merely_destruct; try eapply (Cantor_inj a); trivial. by apply InjectsInto_trans with a0. - apply Empty_rec. eapply merely_destruct; try eapply (Cantor_inj a); trivial. by apply InjectsInto_trans with a0. - enough (H = H') as ->; trivial. apply path_ishprop. Qed. (** * GCH implies LEM *) Section LEM. Variable X : HSet. Variable P : HProp. Context {PR : PropResizing}. Context {FE : Funext}. Definition hpaths (x y : X) := Build_HProp (paths x y). Definition sing (p : X -> HProp) := exists x, p = hpaths x. Let sings := { p : X -> HProp | sing p \/ (P + ~ P) }. (* The main idea is that for a given set X and proposition P, the set sings fits between X and P(X). Then CH for X implies that either sings embeds into X (which can be refuted constructively), or that P(X) embeds into sings, from which we can extract a proof of P + ~P. *) Lemma Cantor_sing (i : (X -> HProp) -> (X -> HProp)) : IsInjective i -> exists p, ~ sing (i p). Proof. intros HI. pose (p n := Build_HProp (smalltype (forall q, i q = hpaths n -> ~ q n))). exists p. intros [n HN]. enough (Hp : p n <-> ~ p n). { apply Hp; apply Hp; intros H; by apply Hp. } unfold p at 1. split. - intros H. apply equiv_smalltype in H. apply H, HN. - intros H. apply equiv_smalltype. intros q HQ. rewrite <- HN in HQ. by apply HI in HQ as ->. Qed. Lemma injective_proj1 {Z} (r : Z -> HProp) : IsInjective (@proj1 Z r). Proof. intros [p Hp] [q Hq]; cbn. intros ->. unshelve eapply path_sigma; cbn. - reflexivity. - cbn. apply path_ishprop. Qed. Lemma inject_sings : (P + ~ P) -> Injection (X -> HProp) sings. Proof. intros HP. unshelve eexists. - intros p. exists p. apply tr. by right. - intros p q. intros H. change p with ((exist (fun r => sing r \/ (P + ~ P)) p (tr (inr HP))).1). rewrite H. cbn. reflexivity. Qed. Theorem CH_LEM : (Injection X sings -> Injection sings (X -> HProp) -> ~ (Injection sings X) -> InjectsInto (X -> HProp) sings) -> P \/ ~ P. Proof. intros ch. eapply merely_destruct; try apply ch. - unshelve eexists. + intros x. exists (hpaths x). apply tr. left. exists x. reflexivity. + intros x y. intros H % pr1_path. cbn in H. change (hpaths x y). by rewrite H. - exists (@proj1 _ _). by apply injective_proj1. - intros H. assert (HP' : ~ ~ (P + ~ P)). { intros HP. apply HP. right. intros p. apply HP. by left. } apply HP'. intros HP % inject_sings. clear HP'. apply Cantor_inj with X. by eapply (Injection_trans _ _ _ HP). - intros [i Hi]. destruct (Cantor_sing (fun p => @proj1 _ _ (i p))) as [p HP]. + intros x y H % injective_proj1. by apply Hi. + destruct (i p) as [q Hq]; cbn in *. eapply merely_destruct; try apply Hq. intros [H|H]; [destruct (HP H)|by apply tr]. Qed. End LEM. (* We can instantiate the previous lemma with nat to obtain GCH -> LEM. *) Theorem GCH_LEM {PR : PropResizing} {UA : Univalence} : GCH -> (forall P : HProp, P \/ ~ P). Proof. intros gch P. eapply (CH_LEM (Build_HSet nat)); try exact _. intros H1 H2 H3. pose (sings := { p : nat -> HProp | sing (Build_HSet nat) p \/ (P + ~ P) }). destruct (gch (Build_HSet nat) (Build_HSet sings)) as [H|H]. - cbn. exists idmap. apply isinj_idmap. - apply tr. apply H1. - apply tr. apply H2. - apply Empty_rec. eapply merely_destruct; try apply H. apply H3. - apply H. Qed. Coq-HoTT-9.0/theories/Sets/GCHtoAC.v000066400000000000000000000311441474641544500170400ustar00rootroot00000000000000From HoTT Require Import TruncType ExcludedMiddle abstract_algebra. From HoTT Require Import Universes.Smallness. From HoTT Require Import Spaces.Nat.Core Spaces.Card. From HoTT Require Import Equiv.BiInv. From HoTT Require Import HIT.unique_choice. From HoTT.Sets Require Import Ordinals Hartogs Powers GCH AC. Open Scope type. Close Scope trunc_scope. (* The proof of Sierpinski's results that GCH implies AC given in this file consists of two ingredients: 1. Adding powers of infinite sets does not increase the cardinality (path_infinite_power). 2. A variant of Cantor's theorem saying that P(X) <= (X + Y) implies P(X) <= Y for large X (Cantor_injects_injects). Those are used to obtain that cardinality-controlled functions are well-behaved in the presence of GCH (Sierpinski), from which we obtain by instantiation with the Hartogs number that every set embeds into an ordinal, which is enough to conclude GCH -> AC (GCH_AC) since the well-ordering theorem implies AC (WO_AC). *) (** * Constructive equivalences *) (* For the first ingredient, we establish a bunch of paths and conclude the desired result by equational reasoning. *) Section Preparation. Context {UA : Univalence}. Lemma path_sum_prod X Y Z : (X -> Z) * (Y -> Z) = ((X + Y) -> Z). Proof. apply path_universe_uncurried. apply equiv_sum_distributive. Qed. Lemma path_sum_assoc X Y Z : X + (Y + Z) = X + Y + Z. Proof. symmetry. apply path_universe_uncurried. apply equiv_sum_assoc. Qed. Lemma path_sum_bool X : X + X = Bool * X. Proof. apply path_universe_uncurried. srapply equiv_adjointify. - exact (fun x => match x with inl x => (true, x) | inr x => (false, x) end). - exact (fun x => match x with (true, x) => inl x | (false, x) => inr x end). - intros [[]]; reflexivity. - intros []; reflexivity. Qed. Lemma path_unit_nat : Unit + nat = nat. Proof. apply path_universe_uncurried. srapply equiv_adjointify. - exact (fun x => match x with inl _ => O | inr n => S n end). - exact (fun n => match n with O => inl tt | S n => inr n end). - by intros []. - by intros [[]|n]. Qed. Lemma path_unit_fun X : X = (Unit -> X). Proof. apply path_universe_uncurried. apply equiv_unit_rec. Qed. (** * Equivalences relying on LEM **) Context {EM : ExcludedMiddle}. Lemma path_bool_prop : HProp = Bool. Proof. apply path_universe_uncurried. srapply equiv_adjointify. - exact (fun P => if LEM P _ then true else false). - exact (fun b : Bool => if b then merely Unit else merely Empty). - intros []; destruct LEM as [H|H]; auto. + destruct (H (tr tt)). + apply (@merely_destruct Empty); try done. exact _. - intros P. destruct LEM as [H|H]; apply equiv_path_iff_hprop. + split; auto. intros _. apply tr. exact tt. + split; try done. intros HE. apply (@merely_destruct Empty); try done. exact _. Qed. Lemma path_bool_subsingleton : (Unit -> HProp) = Bool. Proof. rewrite <- path_unit_fun. apply path_bool_prop. Qed. Lemma path_pred_sum X (p : X -> HProp) : X = sig p + sig (fun x => ~ p x). Proof. apply path_universe_uncurried. srapply equiv_adjointify. - intros x. destruct (LEM (p x) _) as [H|H]; [left | right]; by exists x. - intros [[x _]|[x _]]; exact x. - cbn. intros [[x Hx]|[x Hx]]; destruct LEM as [H|H]; try contradiction. + enough (H = Hx) as -> by reflexivity. apply path_ishprop. + enough (H = Hx) as -> by reflexivity. apply path_forall. by intros HP. - cbn. intros x. by destruct LEM. Qed. Definition ran {X Y : Type} (f : X -> Y) := fun y => hexists (fun x => f x = y). Lemma path_ran {X} {Y : HSet} (f : X -> Y) : IsInjective f -> sig (ran f) = X. Proof. intros Hf. apply path_universe_uncurried. srapply equiv_adjointify. - intros [y H]. destruct (iota (fun x => f x = y) _) as [x Hx]; try exact x. split; try apply H. intros x x'. cbn. intros Hy Hy'. rewrite <- Hy' in Hy. by apply Hf. - intros x. exists (f x). apply tr. exists x. reflexivity. - cbn. intros x. destruct iota as [x' H]. by apply Hf. - cbn. intros [y x]. apply path_sigma_hprop. cbn. destruct iota as [x' Hx]. apply Hx. Qed. (** * Equivalences on infinite sets *) Lemma path_infinite_unit (X : HSet) : infinite X -> Unit + X = X. Proof. intros [f Hf]. rewrite (@path_pred_sum X (ran f)). rewrite (path_ran _ Hf). rewrite path_sum_assoc. rewrite path_unit_nat. reflexivity. Qed. Fact path_infinite_power (X : HSet) : infinite X -> (X -> HProp) + (X -> HProp) = (X -> HProp). Proof. intros H. rewrite path_sum_bool. rewrite <- path_bool_subsingleton. rewrite path_sum_prod. by rewrite path_infinite_unit. Qed. (** * Variants of Cantors's theorem *) (* For the second ingredient, we give a preliminary version (Cantor_path_inject) to see the idea, as well as a stronger refinement (Cantor_injects_injects) which is then a mere reformulation. *) Context {PR : PropResizing}. Lemma Cantor X (f : X -> X -> Type) : { p | forall x, f x <> p }. Proof. exists (fun x => ~ f x x). intros x H. enough (Hx : f x x <-> ~ f x x). - apply Hx; apply Hx; intros H'; by apply Hx. - pattern (f x) at 1. rewrite H. reflexivity. Qed. Lemma hCantor {X} (f : X -> X -> HProp) : { p | forall x, f x <> p }. Proof. exists (fun x => Build_HProp (f x x -> Empty)). intros x H. enough (Hx : f x x <-> ~ f x x). - apply Hx; apply Hx; intros H'; by apply Hx. - pattern (f x) at 1. rewrite H. reflexivity. Qed. Definition clean_sum {X Y Z} (f : X -> Y + Z) : (forall x y, f x <> inl y) -> forall x, { z | inr z = f x }. Proof. intros Hf. enough (H : forall x a, a = f x -> {z : Z & inr z = f x}). - intros x. by apply (H x (f x)). - intros x a Hxa. specialize (Hf x). destruct (f x) as [y|z]. + apply Empty_rect. by apply (Hf y). + by exists z. Qed. Fact Cantor_path_injection {X Y} : (X -> HProp) = (X + Y) -> (X + X) = X -> Injection (X -> HProp) Y. Proof. intros H1 H2. assert (H : X + Y = (X -> HProp) * (X -> HProp)). - by rewrite <- H1, path_sum_prod, H2. - apply equiv_path in H as [f [g Hfg Hgf _]]. pose (f' x := fst (f (inl x))). destruct (hCantor f') as [p Hp]. pose (g' q := g (p, q)). assert (H' : forall q x, g' q <> inl x). + intros q x H. apply (Hp x). unfold f'. rewrite <- H. unfold g'. by rewrite Hfg. + exists (fun x => proj1 (clean_sum _ H' x)). intros q q' H. assert (Hqq' : g' q = g' q'). * destruct clean_sum as [z <-]. destruct clean_sum as [z' <-]. cbn in H. by rewrite H. * unfold g' in Hqq'. change (snd (p, q) = snd (p, q')). rewrite <- (Hfg (p, q)), <- (Hfg (p, q')). by rewrite Hqq'. Qed. (* Version just requiring propositional injections *) Lemma Cantor_rel X (R : X -> (X -> HProp) -> HProp) : (forall x p p', R x p -> R x p' -> merely (p = p')) -> { p | forall x, ~ R x p }. Proof. intros HR. pose (pc x := Build_HProp (smalltype (forall p : X -> HProp, R x p -> ~ p x))). exists pc. intros x H. enough (Hpc : pc x <-> ~ pc x). 2: split. { apply Hpc; apply Hpc; intros H'; by apply Hpc. } - intros Hx. apply equiv_smalltype in Hx. by apply Hx. - intros Hx. apply equiv_smalltype. intros p Hp. eapply merely_destruct; try apply (HR _ _ _ Hp H). by intros ->. Qed. Lemma InjectsInto_power_morph X Y : InjectsInto X Y -> InjectsInto (X -> HProp) (Y -> HProp). Proof. intros HF. eapply merely_destruct; try apply HF. intros [f Hf]. apply tr. exists (fun p => fun y => hexists (fun x => p x /\ y = f x)). intros p q H. apply path_forall. intros x. apply equiv_path_iff_hprop. split; intros Hx. - assert (Hp : (fun y : Y => hexists (fun x : X => p x * (y = f x))) (f x)). { apply tr. exists x. split; trivial. } pattern (f x) in Hp. rewrite H in Hp. eapply merely_destruct; try apply Hp. by intros [x'[Hq <- % Hf]]. - assert (Hq : (fun y : Y => hexists (fun x : X => q x * (y = f x))) (f x)). { apply tr. exists x. split; trivial. } pattern (f x) in Hq. rewrite <- H in Hq. eapply merely_destruct; try apply Hq. by intros [x'[Hp <- % Hf]]. Qed. Fact Cantor_injects_injects {X Y : HSet} : InjectsInto (X -> HProp) (X + Y) -> InjectsInto (X + X) X -> InjectsInto (X -> HProp) Y. Proof. intros H1 H2. assert (HF : InjectsInto ((X -> HProp) * (X -> HProp)) (X + Y)). - eapply InjectsInto_trans; try apply H1. eapply InjectsInto_trans; try apply InjectsInto_power_morph, H2. rewrite path_sum_prod. apply tr. reflexivity. - eapply merely_destruct; try apply HF. intros [f Hf]. pose (R x p := hexists (fun q => f (p, q) = inl x)). destruct (@Cantor_rel _ R) as [p Hp]. { intros x p p' H3 H4. eapply merely_destruct; try apply H3. intros [q Hq]. eapply merely_destruct; try apply H4. intros [q' Hq']. apply tr. change p with (fst (p, q)). rewrite (Hf (p, q) (p', q')); trivial. by rewrite Hq, Hq'. } pose (f' q := f (p, q)). assert (H' : forall q x, f' q <> inl x). + intros q x H. apply (Hp x). apply tr. exists q. apply H. + apply tr. exists (fun x => proj1 (clean_sum _ H' x)). intros q q' H. assert (Hqq' : f' q = f' q'). * destruct clean_sum as [z <-]. destruct clean_sum as [z' <-]. cbn in H. by rewrite H. * apply Hf in Hqq'. change q with (snd (p, q)). by rewrite Hqq'. Qed. End Preparation. (** * Sierpinski's Theorem *) Section Sierpinski. Context {UA : Univalence}. Context {EM : ExcludedMiddle}. Context {PR : PropResizing}. Definition powfix X := forall n, (power_iterated X n + power_iterated X n) = (power_iterated X n). Variable HN : HSet -> HSet. Hypothesis HN_ninject : forall X, ~ InjectsInto (HN X) X. Variable HN_bound : nat. Hypothesis HN_inject : forall X, InjectsInto (HN X) (power_iterated X HN_bound). (* This section then concludes the intermediate result that abstractly, any function HN behaving like the Hartogs number is tamed in the presence of GCH. Morally we show that X <= HN(X) for all X, we just ensure that X is large enough by considering P(N + X). *) Lemma InjectsInto_sum X Y X' Y' : InjectsInto X X' -> InjectsInto Y Y' -> InjectsInto (X + Y) (X' + Y'). Proof. intros H1 H2. eapply merely_destruct; try apply H1. intros [f Hf]. eapply merely_destruct; try apply H2. intros [g Hg]. apply tr. exists (fun z => match z with inl x => inl (f x) | inr y => inr (g y) end). intros [x|y] [x'|y'] H. - apply ap. apply Hf. apply path_sum_inl with Y'. apply H. - by apply inl_ne_inr in H. - by apply inr_ne_inl in H. - apply ap. apply Hg. apply path_sum_inr with X'. apply H. Qed. (* The main proof is by induction on the cardinality bound for HN. As the Hartogs number is bounded by P^3(X), we'd actually just need finitely many instances of GCH. *) Lemma Sierpinski_step (X : HSet) n : GCH -> infinite X -> powfix X -> InjectsInto (HN X) (power_iterated X n) -> InjectsInto X (HN X). Proof. intros gch H1 H2 Hi. induction n. - by apply HN_ninject in Hi. - destruct (gch (Build_HSet (power_iterated X n)) (Build_HSet (power_iterated X n + HN X))) as [H|H]. + by apply infinite_power_iterated. + apply tr. exists inl. intros x x'. apply path_sum_inl. + eapply InjectsInto_trans. * apply InjectsInto_sum; try apply Hi. apply tr, Injection_power. exact _. * cbn. specialize (H2 (S n)). cbn in H2. rewrite H2. apply tr, Injection_refl. + apply IHn. eapply InjectsInto_trans; try apply H. apply tr. exists inr. intros x y. apply path_sum_inr. + apply InjectsInto_trans with (power_iterated X (S n)); try apply tr, Injection_power_iterated. cbn. apply (Cantor_injects_injects H). rewrite (H2 n). apply tr, Injection_refl. Qed. Theorem GCH_injects' (X : HSet) : GCH -> infinite X -> InjectsInto X (HN (Build_HSet (X -> HProp))). Proof. intros gch HX. eapply InjectsInto_trans; try apply tr, Injection_power; try apply X. apply (@Sierpinski_step (Build_HSet (X -> HProp)) HN_bound gch). - apply infinite_inject with X; trivial. apply Injection_power. apply X. - intros n. cbn. rewrite !power_iterated_shift. eapply path_infinite_power. cbn. by apply infinite_power_iterated. - apply HN_inject. Qed. Theorem GCH_injects (X : HSet) : GCH -> InjectsInto X (HN (Build_HSet (Build_HSet (nat + X) -> HProp))). Proof. intros gch. eapply InjectsInto_trans with (nat + X). - apply tr. exists inr. intros x y. apply path_sum_inr. - apply GCH_injects'; trivial. exists inl. intros x y. apply path_sum_inl. Qed. End Sierpinski. (* Main result: GCH implies AC *) Theorem GCH_AC {UA : Univalence} {PR : PropResizing} {LEM : ExcludedMiddle} : GCH -> Choice_type. Proof. intros gch. apply WO_AC. intros X. apply tr. exists (hartogs_number (Build_HSet (Build_HSet (nat + X) -> HProp))). unshelve eapply (@GCH_injects UA LEM PR hartogs_number _ 3 _ X gch). - intros Y. intros H. eapply merely_destruct; try apply H. apply hartogs_number_no_injection. - intros Y. apply tr. apply hartogs_number_injection. Qed. (* Note that the assumption of LEM is actually not necessary due to GCH_LEM. *) Coq-HoTT-9.0/theories/Sets/Hartogs.v000066400000000000000000000271541474641544500173050ustar00rootroot00000000000000From HoTT Require Import TruncType ExcludedMiddle Modalities.ReflectiveSubuniverse abstract_algebra HSet. From HoTT Require Import Universes.Smallness. From HoTT Require Import Spaces.Card. From HoTT.Sets Require Import Ordinals Powers. Close Scope trunc_scope. (** This file contains a construction of the Hartogs number. *) (** We begin with some results about changing the universe of a power set using propositional resizing. *) Definition power_inj `{PropResizing} {C : Type@{i}} (p : C -> HProp@{j}) : C -> HProp@{k}. Proof. exact (fun a => Build_HProp (smalltype@{k j} (p a))). Defined. Lemma injective_power_inj `{PropResizing} {ua : Univalence} (C : Type@{i}) : IsInjective (@power_inj _ C). Proof. intros p p'. unfold power_inj. intros q. apply path_forall. intros a. apply path_iff_hprop; intros Ha. - eapply equiv_smalltype. change ((fun a => Build_HProp (smalltype (p' a))) a). rewrite <- q. apply equiv_smalltype. apply Ha. - eapply equiv_smalltype. change ((fun a => Build_HProp (smalltype (p a))) a). rewrite q. apply equiv_smalltype. apply Ha. Qed. (* TODO: Could factor this as something keeping the [HProp] universe the same, followed by [power_inj]. *) Definition power_morph `{PropResizing} {ua : Univalence} {C B : Type@{i}} (f : C -> B) : (C -> HProp) -> (B -> HProp). Proof. intros p b. exact (Build_HProp (smalltype (forall a, f a = b -> p a))). Defined. Definition injective_power_morph `{PropResizing} {ua : Univalence} {C B : Type@{i}} (f : C -> B) : IsInjective f -> IsInjective (@power_morph _ _ C B f). Proof. intros Hf p p' q. apply path_forall. intros a. apply path_iff_hprop; intros Ha. - enough (Hp : power_morph f p (f a)). + rewrite q in Hp. apply equiv_smalltype in Hp. apply Hp. reflexivity. + apply equiv_smalltype. intros a' -> % Hf. apply Ha. - enough (Hp : power_morph f p' (f a)). + rewrite <- q in Hp. apply equiv_smalltype in Hp. apply Hp. reflexivity. + apply equiv_smalltype. intros a' -> % Hf. apply Ha. Qed. (** We'll also need this result. *) Lemma le_Cardinal_lt_Ordinal `{PropResizing} `{Univalence} (B C : Ordinal) : B < C -> card B ≤ card C. Proof. intros B_C. apply tr. cbn. rewrite (bound_property B_C). exists out. apply isinjective_simulation. apply is_simulation_out. Qed. (** * Hartogs number *) Section Hartogs_Number. Declare Scope Hartogs. Open Scope Hartogs. Notation "'𝒫'" := power_type (at level 30) : Hartogs. Local Coercion subtype_as_type' {X} (Y : 𝒫 X) := { x : X & Y x }. Universe A. Context {univalence : Univalence} {prop_resizing : PropResizing} {lem: ExcludedMiddle} (A : HSet@{A}). (* The Hartogs number of [A] consists of all ordinals that embed into [A]. Note that this construction necessarily increases the universe level. *) Fail Check { B : Ordinal@{A _} | card B <= card A } : Type@{A}. Definition hartogs_number' : Ordinal. Proof. set (carrier := {B : Ordinal@{A _} & card B <= card A}). set (relation := fun (B C : carrier) => B.1 < C.1). exists carrier relation. snrapply (isordinal_simulation pr1). 1-4: exact _. - apply isinj_embedding, (mapinO_pr1 (Tr (-1))). (* Faster than [exact _.] *) - constructor. + intros a a' a_a'. exact a_a'. + intros [B small_B] C C_B; cbn in *. apply tr. unshelve eexists (C; _); cbn; auto. revert small_B. srapply Trunc_rec. intros [f isinjective_f]. apply tr. destruct C_B as [b ->]. exists (fun '(x; x_b) => f x); cbn. intros [x x_b] [y y_b] fx_fy. apply path_sigma_hprop; cbn. apply (isinjective_f x y). exact fx_fy. Defined. Definition proper_subtype_inclusion (U V : 𝒫 A) := (forall a, U a -> V a) /\ merely (exists a : A, V a /\ ~(U a)). Infix "⊊" := proper_subtype_inclusion (at level 50) : Hartogs. Notation "(⊊)" := proper_subtype_inclusion : Hartogs. (* The hartogs number of [A] embeds into the threefold power set of [A]. This preliminary injection also increases the universe level though. *) Lemma hartogs_number'_injection : exists f : hartogs_number' -> (𝒫 (𝒫 (𝒫 A))), IsInjective f. Proof. transparent assert (ϕ : (forall X : 𝒫 (𝒫 A), Lt X)). { intros X. intros x1 x2. exact (x1.1 ⊊ x2.1). } unshelve eexists. - intros [B _]. intros X. exact (merely (Isomorphism (X : Type; ϕ X) B)). - intros [B B_A] [C C_A] H0. apply path_sigma_hprop; cbn. revert B_A. rapply Trunc_rec. intros [f injective_f]. apply equiv_path_Ordinal. assert {X : 𝒫 (𝒫 A) & Isomorphism (X : Type; ϕ X) B} as [X iso]. { assert (H2 : forall X : 𝒫 A, IsHProp { b : B & forall a, X a <-> exists b', b' < b /\ a = f b' }). { intros X. apply hprop_allpath; intros [b1 Hb1] [b2 Hb2]. snrapply path_sigma_hprop; cbn. - intros b. snrapply istrunc_forall. intros a. snrapply istrunc_prod. 2: exact _. snrapply istrunc_arrow. rapply ishprop_sigma_disjoint. intros b1' b2' [_ ->] [_ p]. apply (injective_f). exact p. - apply extensionality. intros b'. split. + intros b'_b1. specialize (Hb1 (f b')). apply snd in Hb1. specialize (Hb1 (b'; (b'_b1, idpath))). apply Hb2 in Hb1. destruct Hb1 as (? & H2 & H3). apply injective in H3. 2: assumption. destruct H3. exact H2. + intros b'_b2. specialize (Hb2 (f b')). apply snd in Hb2. specialize (Hb2 (b'; (b'_b2, idpath))). apply Hb1 in Hb2. destruct Hb2 as (? & H2 & H3). apply injective in H3. 2: assumption. destruct H3. exact H2. } exists (fun X : 𝒫 A => Build_HProp { b : B & forall a, X a <-> exists b', b' < b /\ a = f b' }). { unfold subtype_as_type'. unshelve eexists. - srapply equiv_adjointify. + intros [X [b _]]. exact b. + intros b. unshelve eexists (fun a => Build_HProp (exists b', b' < b /\ a = f b')). 1: exact _. { apply hprop_allpath. intros [b1 [b1_b p]] [b2 [b2_b q]]. apply path_sigma_hprop; cbn. apply (injective f). destruct p, q. reflexivity. } exists b. intros b'. cbn. reflexivity. + cbn. reflexivity. + cbn. intros [X [b Hb]]. apply path_sigma_hprop. cbn. apply path_forall; intros a. apply path_iff_hprop; apply Hb. - cbn. intros [X1 [b1 H'1]] [X2 [b2 H'2]]. unfold ϕ, proper_subtype_inclusion. cbn. split. + intros H3. refine (Trunc_rec _ (trichotomy_ordinal b1 b2)). intros [b1_b2 | H4]. * exact b1_b2. * revert H4. rapply Trunc_rec. intros [b1_b2 | b2_b1]. -- apply Empty_rec. destruct H3 as [_ H3]. revert H3. rapply Trunc_rec. intros [a [X2a not_X1a]]. apply not_X1a. apply H'1. rewrite b1_b2. apply H'2. exact X2a. -- apply Empty_rec. destruct H3 as [_ H3]. revert H3. rapply Trunc_rec. intros [a [X2a not_X1a]]. apply not_X1a. apply H'1. apply H'2 in X2a. destruct X2a as [b' [b'_b2 a_fb']]. exists b'. split. ++ transitivity b2; assumption. ++ assumption. + intros b1_b2. split. * intros a X1a. apply H'2. apply H'1 in X1a. destruct X1a as [b' [b'_b1 a_fb']]. exists b'. split. -- transitivity b1; assumption. -- assumption. * apply tr. exists (f b1). split. -- apply H'2. exists b1; auto. -- intros X1_fb1. apply H'1 in X1_fb1. destruct X1_fb1 as [b' [b'_b1 fb1_fb']]. apply (injective f) in fb1_fb'. destruct fb1_fb'. apply irreflexivity in b'_b1. 2: exact _. assumption. } } assert (IsOrdinal X (ϕ X)) by exact (isordinal_simulation iso.1). apply apD10 in H0. specialize (H0 X). cbn in H0. refine (transitive_Isomorphism _ (X : Type; ϕ X) _ _ _). { apply isomorphism_inverse. assumption. } enough (merely (Isomorphism (X : Type; ϕ X) C)). { revert X1. nrapply Trunc_rec. { exact (ishprop_Isomorphism (Build_Ordinal X (ϕ X) _) C). } auto. } rewrite <- H0. apply tr. exact iso. Qed. (** Using hprop resizing, the threefold power set can be pushed to the same universe level as [A]. *) Definition uni_fix (X : 𝒫 (𝒫 (𝒫 A))) : ((𝒫 (𝒫 (𝒫 A))) : Type@{A}). Proof. revert X. nrapply power_morph. nrapply power_morph. nrapply power_inj. Defined. Lemma injective_uni_fix : IsInjective uni_fix. Proof. intros X Y. unfold uni_fix. intros H % injective_power_morph; trivial. intros P Q. intros H' % injective_power_morph; trivial. intros p q. apply injective_power_inj. Qed. (* We can therefore resize the Hartogs number of A to the same universe level as A. *) Definition hartogs_number_carrier : Type@{A} := {X : 𝒫 (𝒫 (𝒫 A)) | smalltype (merely (exists a, uni_fix (hartogs_number'_injection.1 a) = X))}. Lemma hartogs_equiv : hartogs_number_carrier <~> hartogs_number'. Proof. apply equiv_inverse. unshelve eexists. - intros a. exists (uni_fix (hartogs_number'_injection.1 a)). apply equiv_smalltype, tr. exists a. reflexivity. - snrapply isequiv_surj_emb. + apply BuildIsSurjection. intros [X HX]. eapply merely_destruct. * eapply equiv_smalltype, HX. * intros [a <-]. cbn. apply tr. exists a. cbn. apply ap. apply path_ishprop. + apply isembedding_isinj_hset. intros a b. intros H % pr1_path. cbn in H. specialize (injective_uni_fix (hartogs_number'_injection.1 a) (hartogs_number'_injection.1 b)). intros H'. apply H' in H. by apply hartogs_number'_injection.2. Qed. Definition hartogs_number : Ordinal@{A _} := resize_ordinal hartogs_number' hartogs_number_carrier hartogs_equiv. (* This final definition by satisfies the expected cardinality properties. *) Lemma hartogs_number_injection : exists f : hartogs_number -> 𝒫 (𝒫 (𝒫 A)), IsInjective f. Proof. cbn. exists proj1. intros [X HX] [Y HY]. cbn. intros ->. apply ap. apply path_ishprop. Qed. Lemma hartogs_number_no_injection : ~ (exists f : hartogs_number -> A, IsInjective f). Proof. cbn. intros [f Hf]. cbn in f. assert (HN : card hartogs_number <= card A). { apply tr. by exists f. } transparent assert (HNO : hartogs_number'). { exists hartogs_number. apply HN. } apply (ordinal_initial hartogs_number' HNO). eapply (transitive_Isomorphism hartogs_number' hartogs_number). - apply isomorphism_inverse. unfold hartogs_number. exact (resize_ordinal_iso hartogs_number' hartogs_number_carrier hartogs_equiv). - assert (Isomorphism hartogs_number ↓hartogs_number) by apply isomorphism_to_initial_segment. eapply transitive_Isomorphism. 1: exact X. unshelve eexists. + srapply equiv_adjointify. * intros [a Ha % equiv_smalltype]. unshelve eexists. -- exists a. transitivity (card hartogs_number). ++ nrapply le_Cardinal_lt_Ordinal; apply Ha. ++ apply HN. -- apply equiv_smalltype. cbn. exact Ha. * intros [[a Ha] H % equiv_smalltype]. exists a. apply equiv_smalltype. apply H. * intro a. apply path_sigma_hprop. apply path_sigma_hprop. reflexivity. * intro a. apply path_sigma_hprop. reflexivity. + reflexivity. Defined. End Hartogs_Number. Coq-HoTT-9.0/theories/Sets/Ordinals.v000066400000000000000000000657061474641544500174560ustar00rootroot00000000000000From HoTT Require Import TruncType ExcludedMiddle Modalities.ReflectiveSubuniverse abstract_algebra. From HoTT Require Import Universes.Smallness. From HoTT Require Import Colimits.Quotient. From HoTT Require Import HSet. Local Close Scope trunc_scope. Local Open Scope hprop_scope. (** This file contains a definition of ordinals and some fundamental results, roughly following the presentation in the HoTT book. *) (** * Well-foundedness *) Inductive Accessible {A} (R : Lt A) (a : A) := acc : (forall b, b < a -> Accessible R b) -> Accessible R a. Global Instance ishprop_Accessible `{Funext} {A} (R : Lt A) (a : A) : IsHProp (Accessible R a). Proof. apply hprop_allpath. intros acc1. induction acc1 as [a acc1' IH]. intros [acc2']. apply ap. apply path_forall; intros b. apply path_forall; intros Hb. apply IH. Qed. Class WellFounded {A} (R : Relation A) := well_foundedness : forall a : A, Accessible R a. Global Instance ishprop_WellFounded `{Funext} {A} (R : Relation A) : IsHProp (WellFounded R). Proof. apply hprop_allpath; intros H1 H2. apply path_forall; intros a. apply path_ishprop. Qed. (** * Extensionality *) Class Extensional {A} (R : Lt A) := extensionality : forall a b : A, (forall c : A, c < a <-> c < b) -> a = b. Global Instance ishprop_Extensional `{Funext} {A} `{IsHSet A} (R : Relation A) : IsHProp (Extensional R). Proof. unfold Extensional. exact _. Qed. (** * Ordinals *) Class IsOrdinal@{carrier relation} (A : Type@{carrier}) (R : Relation@{carrier relation} A) := { ordinal_is_hset : IsHSet A ; ordinal_relation_is_mere : is_mere_relation A R ; ordinal_extensionality : Extensional R ; ordinal_well_foundedness : WellFounded R ; ordinal_transitivity : Transitive R ; }. #[export] Existing Instances ordinal_is_hset ordinal_relation_is_mere ordinal_extensionality ordinal_well_foundedness ordinal_transitivity. Global Instance ishprop_IsOrdinal `{Funext} A R : IsHProp (IsOrdinal A R). Proof. eapply istrunc_equiv_istrunc. { issig. } unfold Transitive. exact _. Qed. Record Ordinal@{carrier relation +} := { ordinal_carrier : Type@{carrier} ; ordinal_relation : Lt@{carrier relation} ordinal_carrier ; ordinal_property : IsOrdinal@{carrier relation} ordinal_carrier (<) }. Global Existing Instances ordinal_relation ordinal_property. Coercion ordinal_as_hset (A : Ordinal) : HSet := Build_HSet (ordinal_carrier A). Global Instance irreflexive_ordinal_relation A R : IsOrdinal A R -> Irreflexive R. Proof. intros is_ordinal a H. induction (well_foundedness a) as [a _ IH]. apply (IH a); assumption. Qed. Definition TypeWithRelation := { A : Type & Relation A }. Coercion ordinal_as_type_with_relation (A : Ordinal) : TypeWithRelation := (A : Type; (<)). (** * Paths in Ordinal *) Definition equiv_Ordinal_to_sig : Ordinal <~> { R : { A : Type & Relation A } & IsOrdinal _ R.2 }. Proof. transitivity { A : Type & { R : Relation A & IsOrdinal A R } }. { symmetry. issig. } apply equiv_sigma_assoc'. Defined. Definition Isomorphism : TypeWithRelation -> TypeWithRelation -> Type := fun '(A; R__A) '(B; R__B) => { f : A <~> B & forall a a', R__A a a' <-> R__B (f a) (f a') }. Global Instance isomorphism_id : Reflexive Isomorphism. Proof. intros A. exists equiv_idmap. cbn. intros a a'. reflexivity. Qed. Lemma isomorphism_inverse : forall A B, Isomorphism A B -> Isomorphism B A. Proof. intros [A R__A] [B R__B] [f H]. exists (equiv_inverse f). intros b b'. cbn. rewrite <- (eisretr f b). set (a := f^-1 b). rewrite eissect. rewrite <- (eisretr f b'). set (a' := f^-1 b'). rewrite eissect. (* We don't apply the symmetry tactic because that would introduce bad universe constraints *) split; apply H. Defined. (** We state this first without using [Transitive] to allow more general universe variables. *) Lemma transitive_Isomorphism : forall A B C, Isomorphism A B -> Isomorphism B C -> Isomorphism A C. Proof. intros [A R__A] [B R__B] [C R__C]. intros [f Hf] [g Hg]. exists (equiv_compose' g f). intros a a'. split. - intros a_a'. apply Hg. apply Hf. exact a_a'. - intros gfa_gfa'. apply Hf. apply Hg. exact gfa_gfa'. Defined. Global Instance isomorphism_compose_backwards : Transitive Isomorphism := transitive_Isomorphism. Definition equiv_path_Ordinal `{Univalence} (A B : Ordinal) : Isomorphism A B <~> A = B. Proof. unfold Isomorphism. rapply symmetric_equiv. transitivity (equiv_Ordinal_to_sig A = equiv_Ordinal_to_sig B). { apply equiv_ap'. } transitivity ((equiv_Ordinal_to_sig A).1 = (equiv_Ordinal_to_sig B).1). { exists pr1_path. exact (isequiv_pr1_path_hprop _ _). } transitivity (exist Relation A (<) = exist Relation B (<)). { reflexivity. } transitivity { p : A = B :> Type & p # (<) = (<) }. { symmetry. exact (equiv_path_sigma Relation (exist Relation A (<)) (exist Relation B (<))). } srapply equiv_functor_sigma'. - exact (equiv_equiv_path A B). - cbn. intros p. nrapply equiv_iff_hprop. + apply (istrunc_equiv_istrunc (forall b b' : B, (p # (<)) b b' = (b < b'))). { transitivity (forall b : B, (p # lt) b = lt b). { apply equiv_functor_forall_id; intros b. apply equiv_path_arrow. } apply equiv_path_arrow. } exact _. + exact _. + intros <- a a'. rewrite transport_arrow. rewrite transport_arrow_toconst. repeat rewrite transport_Vp. reflexivity. + intros H0. by_extensionality b. by_extensionality b'. rewrite transport_arrow. rewrite transport_arrow_toconst. apply path_iff_ishprop_uncurried. specialize (H0 (transport idmap p^ b) (transport idmap p^ b')). repeat rewrite transport_pV in H0. exact H0. Qed. Lemma path_Ordinal `{Univalence} (A B : Ordinal) : forall f : A <~> B, (forall a a' : A, a < a' <-> f a < f a') -> A = B. Proof. intros f H0. apply equiv_path_Ordinal. exists f. exact H0. Qed. Lemma trichotomy_ordinal `{ExcludedMiddle} {A : Ordinal} (a b : A) : a < b \/ a = b \/ b < a. Proof. revert b. induction (well_foundedness a) as [a _ IHa]. intros b. induction (well_foundedness b) as [b _ IHb]. destruct (LEM (merely (exists b', b' < b /\ (a = b' \/ a < b')))) as [H1 | H1]; try exact _. - revert H1. rapply Trunc_rec. intros [b' [b'_b Hb']]. revert Hb'. rapply Trunc_rec. intros [a_b' | b'_a]. + apply tr. left. rewrite a_b'. exact b'_b. + apply tr. left. transitivity b'; assumption. - destruct (LEM (merely (exists a', a' < a /\ (a' = b \/ b < a')))) as [H2 | H2]; try exact _. + revert H2. rapply Trunc_rec. intros [a' [a'_a Ha']]. revert Ha'. rapply Trunc_rec. intros [a'_b | b_a']. * apply tr. right. apply tr. right. rewrite <- a'_b. exact a'_a. * apply tr. right. apply tr. right. transitivity a'; assumption. + apply tr. right. apply tr. left. apply extensionality. intros c. split. * intros c_a. apply LEM_to_DNE; try exact _. intros not_c_b. apply H2. apply tr. exists c. split. -- exact c_a. -- refine (Trunc_rec _ (IHa c c_a b)). intros [c_b | H3]. ++ apply Empty_rec. exact (not_c_b c_b). ++ exact H3. * intros c_b. apply LEM_to_DNE; try exact _. intros not_c_a. apply H1. apply tr. exists c. split. -- exact c_b. -- refine (Trunc_rec _ (IHb c c_b)). intros [a_c | H3]. ++ apply tr. right. exact a_c. ++ refine (Trunc_rec _ H3). intros [a_c | c_a]. ** apply tr. left. exact a_c. ** apply tr. right. apply Empty_rec. exact (not_c_a c_a). Qed. Lemma ordinal_has_minimal_hsolutions {lem : ExcludedMiddle} (A : Ordinal) (P : A -> HProp) : merely (exists a, P a) -> merely (exists a, P a /\ forall b, P b -> a < b \/ a = b). Proof. intros H'. eapply merely_destruct; try apply H'. intros [a Ha]. induction (well_foundedness a) as [a _ IH]. destruct (LEM (merely (exists b, P b /\ b < a)) _) as [H|H]. - eapply merely_destruct; try apply H. intros [b Hb]. apply (IH b); apply Hb. - apply tr. exists a. split; try apply Ha. intros b Hb. specialize (trichotomy_ordinal a b). intros H1. eapply merely_destruct; try apply H1. intros [H2|H2]. { apply tr. by left. } eapply merely_destruct; try apply H2. intros [H3|H3]. { apply tr. by right. } apply Empty_rec, H, tr. exists b. by split. Qed. (** * Simulations *) (* We define the notion of simulations between arbitrary relations. For simplicity, most lemmas about simulations are formulated for ordinals only, even if they do not need all properties of ordinals. The only exception is isordinal_simulation which can be used to prove that a relation is an ordinal. *) Class IsSimulation {A B : Type} {R__A : Lt A} {R__B : Lt B} (f : A -> B) := { simulation_is_hom {a a'} : a < a' -> f a < f a' ; simulation_is_merely_minimal {a b} : b < f a -> hexists (fun a' => a' < a /\ f a' = b) }. Arguments simulation_is_hom {_ _ _ _} _ {_ _ _}. Global Instance ishprop_IsSimulation `{Funext} {A B : Ordinal} (f : A -> B) : IsHProp (IsSimulation f). Proof. eapply istrunc_equiv_istrunc. - issig. - exact _. Qed. Global Instance isinjective_simulation {A : Type} {R : Lt A} `{IsOrdinal A R} {B : Type} {Q : Lt B} `{IsOrdinal B Q} (f : A -> B) {is_simulation : IsSimulation f} : IsInjective f. Proof. intros a. induction (well_foundedness a) as [a _ IHa]. intros b. revert a IHa. induction (well_foundedness b) as [b _ IHb]. intros a IHa. intros fa_fb. apply extensionality; intros c. split. - intros c_a. assert (fc_fa : f c < f a) by exact (simulation_is_hom f c_a). assert (fc_fb : f c < f b) by (rewrite <- fa_fb; exact fc_fa). assert (H1 : hexists (fun c' => c' < b /\ f c' = f c)) by exact (simulation_is_merely_minimal fc_fb). refine (Trunc_rec _ H1). intros (c' & c'_b & fc'_fc). assert (c = c') as ->. { apply IHa. + exact c_a. + symmetry. exact fc'_fc. } exact c'_b. - intros c_b. assert (fc_fb : f c < f b) by exact (simulation_is_hom f c_b). assert (fc_fa : f c < f a) by (rewrite fa_fb; exact fc_fb). assert (H1 : hexists (fun c' => c' < a /\ f c' = f c)) by exact (simulation_is_merely_minimal fc_fa). refine (Trunc_rec _ H1). intros (c' & c'_a & fc'_fc). assert (c' = c) as <-. + apply IHb. * exact c_b. * intros a' a'_c'. apply IHa. exact (transitivity a'_c' c'_a). * exact fc'_fc. + exact c'_a. Qed. Lemma simulation_is_minimal {A : Type} {R : Lt A} `{IsOrdinal A R} {B : Type} {Q : Lt B} `{IsOrdinal B Q} (f : A -> B) {is_simulation : IsSimulation f} : forall {a b}, b < f a -> exists a', a' < a /\ f a' = b. Proof. intros a b H1. refine (Trunc_rec _ (simulation_is_merely_minimal H1)). { apply hprop_allpath. intros (a1 & ? & p) (a2 & ? & <-). apply path_sigma_hprop; cbn. apply (injective f). exact p. } exact idmap. Qed. Lemma path_simulation `{Funext} {A B : Ordinal} (f : A -> B) {is_simulation_f : IsSimulation f} (g : A -> B) {is_simulation_g : IsSimulation g} : f = g. Proof. apply path_forall; intros a. induction (well_foundedness a) as [a _ IH]. apply (extensionality (f a) (g a)). intros b. split. - intros b_fa. destruct (simulation_is_minimal f b_fa) as (a' & a'_a & <-). rewrite (IH _ a'_a). apply (simulation_is_hom g). exact a'_a. - intros b_ga. destruct (simulation_is_minimal g b_ga) as (a' & a'_a & <-). rewrite <- (IH _ a'_a). apply (simulation_is_hom f). exact a'_a. Qed. Global Instance is_simulation_isomorphism {A : Type} {R__A : Lt A} {B : Type} {R__B : Lt B} (f : Isomorphism (A; R__A) (B; R__B)) : IsSimulation f.1. Proof. constructor. - intros a a' a_a'. apply f.2. exact a_a'. - intros a b b_fa. apply tr. exists (f.1^-1 b). split. + apply f.2. rewrite eisretr. exact b_fa. + apply eisretr. Qed. Global Instance ishprop_Isomorphism `{Funext} (A B : Ordinal) : IsHProp (Isomorphism A B). Proof. apply hprop_allpath; intros f g. apply path_sigma_hprop; cbn. apply path_equiv. apply path_simulation; exact _. Qed. Global Instance ishset_Ordinal `{Univalence} : IsHSet Ordinal. Proof. apply istrunc_S. intros A B. apply (istrunc_equiv_istrunc (Isomorphism A B)). { apply equiv_path_Ordinal. } exact _. Qed. Lemma isordinal_simulation {A : Type} `{IsHSet A} {R : Lt A} {mere : is_mere_relation _ R} {B : Type} {Q : Lt B} `{IsOrdinal B Q} (f : A -> B) `{IsInjective _ _ f} {is_simulation : IsSimulation f} : IsOrdinal A R. Proof. constructor. - exact _. - exact _. - intros a a' H1. apply (injective f). apply extensionality. intros b. split. + intros b_fa. refine (Trunc_rec _ (simulation_is_merely_minimal b_fa)). intros [a0 [a0_a <-]]. apply (simulation_is_hom f). apply H1. exact a0_a. + intros b_fa'. refine (Trunc_rec _ (simulation_is_merely_minimal b_fa')). intros [a0 [a0_a' <-]]. apply (simulation_is_hom f). apply H1. exact a0_a'. - intros a. remember (f a) as b eqn: fa_b. revert a fa_b. induction (well_foundedness b) as [b _ IH]. intros a <-. constructor; intros a' a'_a. apply (IH (f a')). + apply (simulation_is_hom f). exact a'_a. + reflexivity. - intros a b c a_b b_c. assert (fa_fc : f a < f c). { transitivity (f b). { apply (simulation_is_hom f). exact a_b. } apply (simulation_is_hom f). exact b_c. } refine (Trunc_rec _ (simulation_is_merely_minimal fa_fc)). intros [a' [a'_c fa'_fa]]. apply (injective f) in fa'_fa. subst a'. exact a'_c. Qed. (** * Initial segments *) Definition initial_segment `{PropResizing} {A : Type} {R : Lt A} `{IsOrdinal A R} (a : A) : Ordinal. Proof. srefine {| ordinal_carrier := {b : A & smalltype (b < a)} ; ordinal_relation := fun x y => x.1 < y.1 |}; try exact _. srapply (isordinal_simulation pr1). - unfold lt. exact _. - exact _. - exact _. - constructor. + intros x y x_y. exact x_y. + intros b a' a'_b; cbn in *. apply tr. assert (b_a : b.1 < a). { exact ((equiv_smalltype _) b.2). } srapply exist. { exists a'. apply equiv_smalltype. exact (transitivity a'_b b_a). } cbn. split. * exact a'_b. * reflexivity. Defined. Declare Scope Ordinals. Open Scope Ordinals. Notation "↓ a" := (initial_segment a) (at level 4, format "↓ a") : Ordinals. (* 3 is the level of most unary postfix operators in the standard lib, e.g. f^-1 *) Definition in_ `{PropResizing} {A : Ordinal} {a : A} (x : A) (H : x < a) : ↓a := (x; (equiv_smalltype _)^-1 H). Definition out `{PropResizing} {A : Ordinal} {a : A} : ↓a -> A := pr1. Definition initial_segment_property `{PropResizing} {A : Ordinal} {a : A} : forall x : ↓a, out x < a. Proof. intros x. exact (equiv_smalltype _ (proj2 x)). Defined. Global Instance is_simulation_out `{PropResizing} {A : Ordinal} (a : A) : IsSimulation (out : ↓a -> A). Proof. unfold out. constructor. - auto. - intros x a' a'_x. apply tr. assert (a'_a : a' < a). { transitivity (out x). { assumption. } apply initial_segment_property. (* TODO: Rename? *) } exists (in_ a' a'_a); cbn. auto. Qed. Global Instance isinjective_initial_segment `{Funext} `{PropResizing} (A : Ordinal) : IsInjective (initial_segment : A -> Ordinal). Proof. enough (H1 : forall a1 a2 : A, ↓a1 = ↓a2 -> forall b : ↓a1, out b < a2). { intros a1 a2 p. apply extensionality; intros b. split. - intros b_a1. exact (H1 a1 a2 p (in_ b b_a1)). - intros b_a2. exact (H1 a2 a1 p^ (in_ b b_a2)). } intros a1 a2 p b. assert (out = transport (fun B : Ordinal => B -> A) p^ out) as ->. { apply path_simulation. - exact _. - apply transportD. exact _. } rewrite transport_arrow_toconst. rewrite inv_V. apply initial_segment_property. Qed. Lemma equiv_initial_segment_simulation `{PropResizing} {A : Type@{A}} {R : Lt@{_ R} A} `{IsOrdinal A R} {B : Type@{B}} {Q : Lt@{_ Q} B} `{IsOrdinal B Q} (f : A -> B) {is_simulation : IsSimulation f} (a : A) : Isomorphism ↓(f a) ↓a. Proof. apply isomorphism_inverse. srapply exist. - srapply equiv_adjointify. + intros x. exists (f x.1). apply (equiv_smalltype _)^-1. rapply simulation_is_hom. apply (equiv_smalltype _). exact x.2. + intros x. assert (x_fa : x.1 < f a). { exact ((equiv_smalltype _) x.2). } destruct (simulation_is_minimal f x_fa) as (a' & a'_a & _). exact (a'; (equiv_smalltype _)^-1 a'_a). + cbn. intros x. apply path_sigma_hprop; cbn. transparent assert (x_fa : (x.1 < f a)). { exact (equiv_smalltype _ x.2). } exact (snd (simulation_is_minimal f x_fa).2). + cbn. intros x. apply path_sigma_hprop; cbn. transparent assert (x_a : (x.1 < a)). { exact (equiv_smalltype _ x.2). } apply (injective f). cbn. unfold initial_segment_property. cbn. rewrite eisretr. exact (snd (simulation_is_minimal f (simulation_is_hom f x_a)).2). - cbn. intros [x x_a] [y y_a]; cbn. split. + apply (simulation_is_hom f). + intros fx_fy. destruct (simulation_is_minimal f fx_fy) as (a' & a'_y & p). apply injective in p; try exact _. subst a'. exact a'_y. Qed. Lemma path_initial_segment_simulation `{Univalence} `{PropResizing} {A : Type} {R : Lt A} `{IsOrdinal A R} {B : Type} {Q : Lt B} `{IsOrdinal B Q} (f : A -> B) {is_simulation : IsSimulation f} (a : A) : ↓(f a) = ↓a. Proof. apply equiv_path_Ordinal. apply (equiv_initial_segment_simulation f). Qed. (** * `Ordinal` is an ordinal *) Global Instance lt_Ordinal@{carrier relation +} `{PropResizing} : Lt Ordinal@{carrier relation} := fun A B => exists b : B, A = ↓b. Global Instance is_mere_relation_lt_on_Ordinal `{Univalence} `{PropResizing} : is_mere_relation Ordinal lt_Ordinal. Proof. intros A B. apply ishprop_sigma_disjoint. intros b b' -> p. apply (injective initial_segment). exact p. Qed. Definition bound `{PropResizing} {A B : Ordinal} (H : A < B) : B := H.1. (* We use this notation to hide the proof of A < B that `bound` takes as an argument *) Notation "A ◁ B" := (@bound A B _) (at level 70) : Ordinals. Definition bound_property `{PropResizing} {A B : Ordinal} (H : A < B) : A = ↓(bound H) := H.2. Lemma isembedding_initial_segment `{PropResizing} `{Univalence} {A : Ordinal} (a b : A) : a < b <-> ↓a < ↓b. Proof. split. - intros a_b. exists (in_ a a_b). exact (path_initial_segment_simulation out (in_ a a_b)). - intros a_b. assert (a = out (bound a_b)) as ->. { apply (injective initial_segment). rewrite (path_initial_segment_simulation out). apply bound_property. } apply initial_segment_property. Qed. Global Instance Ordinal_is_ordinal `{PropResizing} `{Univalence} : IsOrdinal Ordinal (<). Proof. constructor. - exact _. - exact is_mere_relation_lt_on_Ordinal. - intros A B H1. srapply path_Ordinal. + srapply equiv_adjointify. * assert (lt_B : forall a : A, ↓a < B). { intros a. apply H1. exists a. reflexivity. } exact (fun a => bound (lt_B a)). * assert (lt_A : forall b : B, ↓b < A). { intros b. apply H1. exists b. reflexivity. } exact (fun b => bound (lt_A b)). * cbn. intros b. apply (injective initial_segment). repeat rewrite <- bound_property. reflexivity. * cbn. intros a. apply (injective initial_segment). repeat rewrite <- bound_property. reflexivity. + cbn. intros a a'. split. * intros a_a'. apply isembedding_initial_segment. repeat rewrite <- bound_property. apply isembedding_initial_segment. assumption. * intros a_a'. apply isembedding_initial_segment in a_a'. repeat rewrite <- bound_property in a_a'. apply isembedding_initial_segment in a_a'. assumption. - intros A. constructor. intros ? [a ->]. induction (well_foundedness a) as [a _ IH]. constructor. intros ? [x ->]. rewrite <- (path_initial_segment_simulation out). apply IH. apply initial_segment_property. - intros ? ? A [x ->] [a ->]. exists (out x). rewrite (path_initial_segment_simulation out). reflexivity. Qed. (* This is analogous to the set-theoretic statement that an ordinal is the set of all smaller ordinals. *) Lemma isomorphism_to_initial_segment `{PropResizing} `{Univalence} (B : Ordinal@{A _}) : Isomorphism B ↓B. Proof. srapply exist. - srapply equiv_adjointify. + intros b. exists ↓b. apply equiv_smalltype. exists b. reflexivity. + intros [C HC]. eapply equiv_smalltype in HC. exact (bound HC). + cbn. intros [C HC]. apply path_sigma_hprop; cbn. symmetry. apply bound_property. + cbn. intros x. rewrite eisretr. reflexivity. - cbn. intros b b'. apply isembedding_initial_segment. Qed. (** But an ordinal isn't isomorphic to any initial segment of itself. *) Lemma ordinal_initial `{PropResizing} `{Univalence} (O : Ordinal) (a : O) : Isomorphism O ↓a -> Empty. Proof. intros p % equiv_path_Ordinal. enough (HO : O < O) by apply (irreflexive_ordinal_relation _ _ _ _ HO). exists a. apply p. Qed. (** * Ordinal successor *) Definition successor (A : Ordinal) : Ordinal. Proof. set (carrier := (A + Unit)%type). set (relation (x y : carrier) := match x, y with | inl x, inl y => x < y | inl x, inr _ => Unit | inr _, inl y => Empty | inr _, inr _ => Empty end). exists carrier relation. constructor. - exact _. - intros [x | ?] [y | ?]; cbn; exact _. - intros [x | []] [y | []] H. + f_ap. apply extensionality. intros z. exact (H (inl z)). + enough (H0 : relation (inl x) (inl x)). { cbn in H0. destruct (irreflexivity _ _ H0). } apply H. cbn. exact tt. + enough (H0 : relation (inl y) (inl y)). { cbn in H0. destruct (irreflexivity _ _ H0). } apply H. cbn. exact tt. + reflexivity. - assert (H : forall a, Accessible relation (inl a)). { intros a. induction (well_foundedness a) as [a _ IH]. constructor; intros [b | []]; cbn; intros H. + apply IH. exact H. + destruct H. } intros [x | []]. + apply H. + constructor; intros [b | []]; cbn; intros H0. * apply H. * destruct H0. - intros [x | []] [y | []] [z | []]; cbn; auto. intros _ []. Defined. Lemma lt_successor `{PropResizing} `{Univalence} (A : Ordinal) : A < successor A. Proof. exists (inr tt). srapply path_Ordinal. - srapply equiv_adjointify. + intros a. srapply in_. * exact (inl a). * exact tt. + intros [[a | []] Ha]; cbn in *. * exact a. * apply equiv_smalltype in Ha. destruct Ha. + intros [[a | []] Ha]. * unfold in_. cbn. f_ap. assert (IsHProp (smalltype Unit)) by exact _. apply path_ishprop. * destruct (equiv_smalltype _ Ha). + intros a. reflexivity. - cbn. intros a a'. reflexivity. Qed. (** * Ordinal limit *) Section Image. Universes i j. (** In the following, there are no constraints between [i] and [j]. *) Context `{PropResizing} `{Funext} {A : Type@{i}} {B : HSet@{j}} (f : A -> B). Local Definition qkfs := quotient_kernel_factor_small f. Local Definition image : Type@{i} := qkfs.1. Local Definition factor1 : A -> image := qkfs.2.1. Local Definition factor2 : image -> B := qkfs.2.2.1. Local Definition isinjective_factor2 : IsInjective factor2 := isinj_embedding _ (snd (fst qkfs.2.2.2)). Local Definition image_ind_prop (P : image -> Type@{k}) `{forall x, IsHProp (P x)} (step : forall a : A, P (factor1 a)) : forall x : image, P x := Quotient_ind_hprop _ P step. (** [factor2 o factor1 == f] is definitional, so we don't state that. *) End Image. Definition limit `{Univalence} `{PropResizing} {X : Type} (F : X -> Ordinal) : Ordinal. Proof. set (f := fun x : {i : X & F i} => ↓x.2). set (carrier := image f : Type@{i}). set (relation := fun A B : carrier => smalltype (factor2 f A < factor2 f B) : Type@{i}). exists carrier relation. snrapply (isordinal_simulation (factor2 f)). 1-4: exact _. - apply isinjective_factor2. - constructor. + intros x x' x_x'. unfold lt, relation. apply equiv_smalltype in x_x'. exact x_x'. + nrefine (image_ind_prop f _ _). 1: exact _. intros a. change (factor2 f (class_of _ a)) with (f a). intros B B_fa. apply tr. exists (factor1 f (a.1; out (bound B_fa))). unfold lt, relation. change (factor2 f (factor1 f ?A)) with (f A). unfold f. assert (↓(out (bound B_fa)) = B) as ->. { rewrite (path_initial_segment_simulation out). symmetry. apply bound_property. } split. * apply equiv_smalltype. exact B_fa. * reflexivity. Defined. Global Instance le_on_Ordinal : Le Ordinal := fun A B => exists f : A -> B, IsSimulation f. Definition limit_is_upper_bound `{Univalence} `{PropResizing} {X : Type} (F : X -> Ordinal) : forall x, F x <= limit F. Proof. set (f := fun x : {i : X & F i} => ↓x.2). intros x. unfold le, le_on_Ordinal. exists (fun u => factor1 f (x; u)). split. - intros u v u_v. change (smalltype (f (x; u) < f (x; v))). apply equiv_smalltype. apply isembedding_initial_segment. exact u_v. - intros u. nrefine (image_ind_prop f _ _). 1: exact _. intros a a_u. change (smalltype (f a < f (x; u))) in a_u. apply equiv_smalltype in a_u. apply tr. exists (out (bound a_u)). split. + apply initial_segment_property. + apply (isinjective_factor2 f); simpl. change (factor2 f (factor1 f ?A)) with (f A). unfold f. rewrite (path_initial_segment_simulation out). symmetry. apply bound_property. Qed. (** Any type equivalent to an ordinal is an ordinal, and we can change the universe that the relation takes values in. *) (* TODO: Should factor this into two results: (1) Anything equivalent to an ordinal is an ordinal (with the relation landing in the same universe for both). (2) Under PropResizing, the universe that the relation takes values in can be changed. *) Definition resize_ordinal@{i j +} `{PropResizing} (B : Ordinal@{i _}) (C : Type@{j}) (g : C <~> B) : Ordinal@{j _}. Proof. exists C (fun c1 c2 : C => smalltype (g c1 < g c2)). snrapply (isordinal_simulation g). 2, 3, 4, 5: exact _. - apply (istrunc_equiv_istrunc B (equiv_inverse g)). - constructor. + intros a a' a_a'. apply (equiv_smalltype _). exact a_a'. + intros a b b_fa. apply tr. exists (g^-1 b). split. * apply equiv_smalltype. rewrite eisretr. exact b_fa. * apply eisretr. Defined. Lemma resize_ordinal_iso@{i j +} `{PropResizing} (B : Ordinal@{i _}) (C : Type@{j}) (g : C <~> B) : Isomorphism (resize_ordinal B C g) B. Proof. exists g. intros a a'. cbn. split; apply equiv_smalltype. Qed. Coq-HoTT-9.0/theories/Sets/Powers.v000066400000000000000000000040171474641544500171460ustar00rootroot00000000000000From HoTT Require Import Basics Types TruncType. From HoTT Require Import Universes.Smallness. From HoTT Require Import Spaces.Card Spaces.Nat.Core. (** * Definition of Power types *) (* The definition is only used in Hartogs.v to allow defining a coercion, and one place below. Everywhere else we prefer to write out the definition for clarity. *) Definition power_type (A : Type) : Type := A -> HProp. (** * Iterated powers *) Lemma Injection_power {PR : PropResizing} X : IsHSet X -> Injection X (X -> HProp). Proof. intros HX. set (f (x : X) := fun y => Build_HProp (smalltype (x = y))). exists f. intros x x' H. eapply equiv_smalltype. change (f x x'). rewrite H. cbn. apply equiv_smalltype. reflexivity. Qed. Definition power_iterated X n := nat_iter n power_type X. Definition power_iterated_shift X n : power_iterated (X -> HProp) n = (power_iterated X n -> HProp) := (nat_iter_succ_r _ _ _)^. Global Instance hset_power {UA : Univalence} (X : HSet) : IsHSet (X -> HProp). Proof. apply istrunc_S. intros p q. apply hprop_allpath. intros H H'. destruct (equiv_path_arrow p q) as [f [g Hfg Hgf _]]. rewrite <- (Hfg H), <- (Hfg H'). apply ap. apply path_forall. intros x. apply path_ishprop. Qed. Global Instance hset_power_iterated {UA : Univalence} (X : HSet) n : IsHSet (power_iterated X n). Proof. nrapply (nat_iter_invariant n power_type (fun A => IsHSet A)). - intros Y HS. rapply hset_power. - exact _. Defined. Lemma Injection_power_iterated {UA : Univalence} {PR : PropResizing} (X : HSet) n : Injection X (power_iterated X n). Proof. induction n as [|n IHn]. - reflexivity. - eapply Injection_trans; try apply IHn. apply Injection_power. exact _. Qed. Lemma infinite_inject X Y : infinite X -> Injection X Y -> infinite Y. Proof. apply Injection_trans. Qed. Lemma infinite_power_iterated {UA : Univalence} {PR : PropResizing} (X : HSet) n : infinite X -> infinite (power_iterated X n). Proof. intros H. eapply infinite_inject; try apply H. apply Injection_power_iterated. Qed. Coq-HoTT-9.0/theories/Spaces/000077500000000000000000000000001474641544500157765ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/BAut/000077500000000000000000000000001474641544500166315ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/BAut/Bool.v000066400000000000000000000372401474641544500177210ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Constant. Require Import HoTT.Truncations.Core HoTT.Truncations.Connectedness. Require Import Universes.BAut. Require Import Pointed.Core. Local Open Scope trunc_scope. Local Open Scope path_scope. Local Open Scope pointed_scope. (** * BAut(Bool) *) Section AssumeUnivalence. Context `{Univalence}. (** ** Nontrivial central homotopy *) (** The equivalence [Bool <~> (Bool <~> Bool)], and particularly its consequence [abelian_aut_bool], implies that [BAut Bool] has a nontrivial center. *) Definition negb_center_baut_bool : forall (Z:BAut Bool), Z = Z. Proof. apply center_baut; try exact _. exists equiv_negb. intros g; apply abelian_aut_bool. Defined. Definition nontrivial_negb_center_baut_bool : negb_center_baut_bool <> (fun Z => idpath Z). Proof. intros oops. pose (p := ap10_equiv ((ap (center_baut Bool))^-1 (oops @ (id_center_baut Bool)^))..1 true). exact (false_ne_true p). Defined. (** In particular, every element of [BAut Bool] has a canonical flip automorphism. *) Definition negb_baut_bool (Z : BAut Bool) : Z <~> Z := equiv_path Z Z (negb_center_baut_bool Z)..1. Definition negb_baut_bool_ne_idmap (Z : BAut Bool) : negb_baut_bool Z <> equiv_idmap Z. Proof. intros oops. apply nontrivial_negb_center_baut_bool. apply path_forall; intros Z'. pose (p := merely_path_component Z Z'). clearbody p. strip_truncations. destruct p. unfold negb_baut_bool in oops. apply moveL_equiv_V in oops. refine (_ @ ap (equiv_path_sigma_hprop _ _) (oops @ path_universe_1) @ _). - symmetry. refine (eisretr (equiv_path_sigma_hprop Z Z) _). - apply moveR_equiv_M; reflexivity. Defined. (** If [Z] is [Bool], then the flip is the usual one. *) Definition negb_baut_bool_bool_negb : negb_baut_bool pt = equiv_negb. Proof. pose (c := aut_bool_idmap_or_negb (negb_baut_bool pt)). destruct c. - pose (negb_baut_bool_ne_idmap pt p). contradiction. - assumption. Defined. Definition ap_pr1_negb_baut_bool_bool : (negb_center_baut_bool pt)..1 = path_universe negb. Proof. apply moveL_equiv_V. apply negb_baut_bool_bool_negb. Defined. (** Moreover, we can show that every automorphism of a [Z : BAut Bool] must be either the flip or the identity. *) Definition aut_baut_bool_idmap_or_negb (Z : BAut Bool) (e : Z <~> Z) : (e = equiv_idmap Z) + (e = negb_baut_bool Z). Proof. assert (IsHProp ((e = equiv_idmap Z) + (e = negb_baut_bool Z))). { apply ishprop_sum; try exact _. intros p q; exact (negb_baut_bool_ne_idmap Z (q^ @ p)). } baut_reduce. case (aut_bool_idmap_or_negb e). - intros p; exact (inl p). - intros q; apply inr. exact (q @ negb_baut_bool_bool_negb^). Defined. (** ** Connectedness *) Global Instance isminusoneconnected_baut_bool `{Funext} (Z : BAut Bool) : IsConnected (-1) Z. Proof. baut_reduce. rapply contr_inhabited_hprop. exact (tr true). Defined. Definition merely_inhab_baut_bool `{Funext} (Z : BAut Bool) : merely Z := center (merely Z). (** ** Equivalence types *) (** As soon as an element of [BAut Bool] is inhabited, it is (purely) equivalent to [Bool]. (Of course, every element of [BAut Bool] is *merely* inhabited, since [Bool] is.) In fact, it is equivalent in two canonical ways. First we define the function that will be the equivalence. *) Definition inhab_baut_bool_from_bool (t : Bool) (Z : BAut Bool) (z : Z) : Bool -> Z := fun b => if t then if b then z else negb_baut_bool Z z else if b then negb_baut_bool Z z else z. (** We compute this in the case when [Z] is [Bool]. *) Definition inhab_baut_bool_from_bool_bool (t : Bool) : inhab_baut_bool_from_bool t pt = fun (z : point (BAut Bool)) (b : Bool) => if t then if b then z else negb z else if b then negb z else z. Proof. apply path_forall; intros z'; simpl in z'. apply path_forall; intros b. destruct z', b, t; simpl; try reflexivity; try apply (ap10_equiv negb_baut_bool_bool_negb). Defined. (** Now we show that it is an equivalence. *) Global Instance isequiv_inhab_baut_bool_from_bool (t : Bool) (Z : BAut Bool) (z : Z) : IsEquiv (inhab_baut_bool_from_bool t Z z). Proof. baut_reduce. refine (transport IsEquiv (ap10 (inhab_baut_bool_from_bool_bool t)^ z) _). simpl in z; destruct z, t; simpl. - refine (isequiv_homotopic idmap _); intros []; reflexivity. - apply isequiv_negb. - apply isequiv_negb. - refine (isequiv_homotopic idmap _); intros []; reflexivity. Defined. Definition equiv_inhab_baut_bool_bool (t : Bool) (Z : BAut Bool) (z : Z) : Bool <~> Z := Build_Equiv _ _ (inhab_baut_bool_from_bool t Z z) _. Definition path_baut_bool_inhab (Z : BAut Bool) (z : Z) : (point (BAut Bool)) = Z. Proof. apply path_baut. exact (equiv_inhab_baut_bool_bool true Z z). (** [true] is a choice! *) Defined. (** In fact, the map sending [z:Z] to this equivalence [Bool <~> Z] is also an equivalence. To assist with computing the result when [Z] is [Bool], we prove it with an extra parameter first. *) Definition isequiv_equiv_inhab_baut_bool_bool_lemma (t : Bool) (Z : BAut Bool) (m : merely (pt = Z)) : IsEquiv (equiv_inhab_baut_bool_bool t Z). Proof. strip_truncations. destruct m. refine (isequiv_adjointify _ (fun (e : Bool <~> Bool) => e t) _ _). + intros e. apply path_equiv. refine (ap10 (inhab_baut_bool_from_bool_bool t) (e t) @ _). apply path_arrow; intros []; destruct t. * reflexivity. * refine (abelian_aut_bool equiv_negb e false). * refine (abelian_aut_bool equiv_negb e true). * reflexivity. + intros z. refine (ap10 (ap10 (inhab_baut_bool_from_bool_bool t) z) t @ _). destruct t; reflexivity. Defined. Global Instance isequiv_equiv_inhab_baut_bool_bool (t : Bool) (Z : BAut Bool) : IsEquiv (equiv_inhab_baut_bool_bool t Z). Proof. exact (isequiv_equiv_inhab_baut_bool_bool_lemma t Z (merely_path_component _ _)). Defined. (** The names are getting pretty ridiculous; below we suggest a better name for this. *) Definition equiv_equiv_inhab_baut_bool_bool (t : Bool) (Z : BAut Bool) : Z <~> (Bool <~> Z) := Build_Equiv _ _ (equiv_inhab_baut_bool_bool t Z) _. (** We compute its inverse in the case of [Bool]. *) Definition equiv_equiv_inhab_baut_bool_bool_bool_inv (t : Bool) (e : Bool <~> Bool) : equiv_inverse (equiv_equiv_inhab_baut_bool_bool t pt) e = e t. Proof. pose (alt := Build_Equiv _ _ (equiv_inhab_baut_bool_bool t pt) (isequiv_equiv_inhab_baut_bool_bool_lemma t pt (tr 1))). assert (p : equiv_equiv_inhab_baut_bool_bool t pt = alt). { apply (ap (fun i => Build_Equiv _ _ _ i)). apply (ap (isequiv_equiv_inhab_baut_bool_bool_lemma t pt)). apply path_ishprop. } exact (ap10_equiv (ap equiv_inverse p) e). Defined. (** ** Group structure *) (** Homotopically, [BAut Bool] is a [K(Z/2,1)]. In particular, it has a (coherent) abelian group structure induced from that of [Z/2]. With our definition of [BAut Bool], we can construct this operation as follows. *) Definition baut_bool_pairing : BAut Bool -> BAut Bool -> BAut Bool. Proof. intros Z W. exists (Z <~> W). baut_reduce; simpl. apply tr, symmetry. exact (path_universe equiv_bool_aut_bool). Defined. Declare Scope baut_bool_scope. Notation "Z ** W" := (baut_bool_pairing Z W) : baut_bool_scope. Local Open Scope baut_bool_scope. (** Now [equiv_equiv_inhab_baut_bool_bool] is revealed as simply the left unit law of this pairing. *) Definition baut_bool_pairing_1Z Z : pt ** Z = Z. Proof. apply path_baut, equiv_inverse, equiv_equiv_inhab_baut_bool_bool. exact true. (** This is a choice! *) Defined. (** The pairing is obviously symmetric. *) Definition baut_bool_pairing_symm Z W : Z ** W = W ** Z. Proof. apply path_baut, equiv_equiv_inverse. Defined. (** Whence we get the right unit law as well. *) Definition baut_bool_pairing_Z1 Z : Z ** pt = Z := baut_bool_pairing_symm Z pt @ baut_bool_pairing_1Z Z. (** Every element is its own inverse. *) Definition baut_bool_pairing_ZZ Z : Z ** Z = pt. Proof. apply symmetry, path_baut_bool_inhab. apply equiv_idmap. (** A choice! Could be the flip. *) Defined. (** Associativity is easiest to think about in terms of "curried 2-variable equivalences". We start with some auxiliary lemmas. *) Definition baut_bool_pairing_ZZ_Z_symm_part1 {Y Z W} (e : Y ** (Z ** W)) (z : Z) : Y ** W. Proof. simple refine (equiv_adjointify _ _ _ _). + exact (fun y => e y z). + intros w. destruct (path_baut_bool_inhab W w). destruct (path_baut_bool_inhab Z z). (** It might be tempting to just say [e^-1 (equiv_idmap _)] here, but for the rest of the proof to work, we actually need to choose between [idmap] and [negb] based on whether [z] and [w] are equal or not. *) destruct (dec (z=w)). * exact (e^-1 (equiv_idmap _)). * exact (e^-1 equiv_negb). + intros w. destruct (path_baut_bool_inhab W w). destruct (path_baut_bool_inhab Z z). simpl. destruct z,w; simpl; refine (ap10_equiv (eisretr e _) _). + intros y. destruct (path_baut_bool_inhab Y y). destruct (path_baut_bool_inhab Z z). destruct (path_baut_bool_inhab W (e y z)). simpl. case (dec (z = e y z)); intros p; apply moveR_equiv_V; destruct (aut_bool_idmap_or_negb (e y)) as [q|q]. * symmetry; assumption. * case (not_fixed_negb z (p @ ap10_equiv q z)^). * case (p (ap10_equiv q z)^). * symmetry; assumption. Defined. Definition baut_bool_pairing_ZZ_Z_symm_lemma {Y Z W} (e : Y ** (Z ** W)) (f : Y ** W) : merely Y -> Z. Proof. pose (k := (fun y => (e y)^-1 (f y))). refine (merely_rec_hset k); intros y1 y2. destruct (path_baut_bool_inhab Y y1). destruct (path_baut_bool_inhab W (f y1)). destruct (path_baut_bool_inhab Z (k y1)). destruct (aut_bool_idmap_or_negb f) as [p|p]; refine (ap (e y1)^-1 (ap10_equiv p y1) @ _); refine (_ @ (ap (e y2)^-1 (ap10_equiv p y2))^); clear p f k; simpl. + destruct (dec (y1=y2)) as [p|p]. { exact (ap (fun y => (e y)^-1 y) p). } destruct (aut_bool_idmap_or_negb (e y1)) as [q1|q1]; destruct (aut_bool_idmap_or_negb (e y2)) as [q2|q2]. * case (p ((ap e)^-1 (q1 @ q2^))). * rewrite q1, q2. exact (negb_ne p). * rewrite q1, q2. symmetry. exact (negb_ne (fun r => p r^)). * case (p ((ap e)^-1 (q1 @ q2^))). + destruct (dec (y1=y2)) as [p|p]. { exact (ap (fun y => (e y)^-1 (negb y)) p). } destruct (aut_bool_idmap_or_negb (e y1)) as [q1|q1]; destruct (aut_bool_idmap_or_negb (e y2)) as [q2|q2]. * case (p ((ap e)^-1 (q1 @ q2^))). * rewrite q1, q2. exact (negb_ne (fun r => p ((ap negb)^-1 r))). * rewrite q1, q2. symmetry. exact (negb_ne (fun r => p ((ap negb)^-1 r)^)). * case (p ((ap e)^-1 (q1 @ q2^))). Defined. Definition baut_bool_pairing_ZZ_Z_symm_map Y Z W : Y ** (Z ** W) -> Z ** (Y ** W). Proof. intros e. simple refine (equiv_adjointify (baut_bool_pairing_ZZ_Z_symm_part1 e) _ _ _). - intros f. exact (baut_bool_pairing_ZZ_Z_symm_lemma e f (merely_inhab_baut_bool Y)). - intros f. apply path_equiv, path_arrow; intros y. change ((e y) (baut_bool_pairing_ZZ_Z_symm_lemma e f (merely_inhab_baut_bool Y)) = f y). refine (ap (e y o baut_bool_pairing_ZZ_Z_symm_lemma e f) (path_ishprop _ (tr y)) @ _). simpl. apply eisretr. - intros z. assert (IsHSet Z) by exact _. refine (Trunc_rec _ (merely_inhab_baut_bool Y)); intros y. refine (ap (baut_bool_pairing_ZZ_Z_symm_lemma e _) (path_ishprop _ (tr y)) @ _). simpl. refine (eissect _ _). Defined. Definition baut_bool_pairing_ZZ_Z_symm_inv Y Z W : baut_bool_pairing_ZZ_Z_symm_map Y Z W o baut_bool_pairing_ZZ_Z_symm_map Z Y W == idmap. Proof. intros e. apply path_equiv, path_arrow; intros z. apply path_equiv, path_arrow; intros y. reflexivity. Defined. Definition baut_bool_pairing_ZZ_Z_symm Y Z W : Y ** (Z ** W) <~> Z ** (Y ** W). Proof. refine (equiv_adjointify (baut_bool_pairing_ZZ_Z_symm_map Y Z W) (baut_bool_pairing_ZZ_Z_symm_map Z Y W) (baut_bool_pairing_ZZ_Z_symm_inv Y Z W) (baut_bool_pairing_ZZ_Z_symm_inv Z Y W)). Defined. (** Finally, we can prove associativity. *) Definition baut_bool_pairing_ZZ_Z Z W Y : (Z ** W) ** Y = Z ** (W ** Y). Proof. refine (baut_bool_pairing_symm (Z ** W) Y @ _). refine (_ @ ap (fun X => Z ** X) (baut_bool_pairing_symm Y W)). apply path_baut, baut_bool_pairing_ZZ_Z_symm. Defined. (** Since [BAut Bool] is not a set, we ought to have some coherence for these operations too, but we'll leave that for another time. *) (** ** Automorphisms of [BAut Bool] *) (** Interestingly, like [Bool] itself, [BAut Bool] is equivalent to its own automorphism group. *) (** An initial lemma: every automorphism of [BAut Bool] and its inverse are "adjoint" with respect to the pairing. *) Definition aut_baut_bool_moveR_pairing_V (e : BAut Bool <~> BAut Bool) (Z W : BAut Bool) : (e^-1 Z ** W) = (Z ** e W). Proof. apply path_baut; simpl. refine ((equiv_equiv_path _ _) oE _ oE (equiv_equiv_path _ _)^-1). refine (_ oE (@equiv_moveL_equiv_M _ _ e _ W Z) oE _). - apply equiv_inverse, equiv_path_sigma_hprop. - apply equiv_path_sigma_hprop. Defined. Definition equiv_baut_bool_aut_baut_bool : BAut Bool <~> (BAut Bool <~> BAut Bool). Proof. simple refine (equiv_adjointify _ _ _ _). - intros Z. refine (equiv_involution (fun W => Z ** W) _). intros W. refine ((baut_bool_pairing_ZZ_Z Z Z W)^ @ _). refine (_ @ baut_bool_pairing_1Z W). apply (ap (fun Y => Y ** W)). apply baut_bool_pairing_ZZ. - intros e. exact (e^-1 pt). - intros e. apply path_equiv, path_arrow; intros Z; simpl. refine (aut_baut_bool_moveR_pairing_V e pt Z @ _). apply baut_bool_pairing_1Z. - intros Z. apply baut_bool_pairing_Z1. Defined. (** ** [BAut (BAut Bool)] *) (** Putting all of this together, we can construct a nontrivial 2-central element of [BAut (BAut Bool)]. *) Definition center_baut_bool_central (g : BAut Bool <~> BAut Bool) (W : BAut Bool) : ap g (negb_center_baut_bool W) = negb_center_baut_bool (g W). Proof. revert g; equiv_intro equiv_baut_bool_aut_baut_bool Z. simpl. baut_reduce. refine (_ @ apD negb_center_baut_bool (baut_bool_pairing_1Z pt)^). rewrite transport_paths_lr, inv_V. apply moveL_pV. exact (concat_A1p baut_bool_pairing_1Z (negb_center_baut_bool pt)). Qed. Definition negb_center2_baut_baut_bool : forall B : BAut (BAut Bool), (idpath B) = (idpath B). Proof. refine (center2_baut (BAut Bool) _). exists negb_center_baut_bool. apply center_baut_bool_central. Defined. Definition nontrivial_negb_center_baut_baut_bool : negb_center2_baut_baut_bool <> (fun Z => idpath (idpath Z)). Proof. intros oops. exact (nontrivial_negb_center_baut_bool (((ap (center2_baut (BAut Bool)))^-1 (oops @ (id_center2_baut (BAut Bool))^))..1)). Defined. End AssumeUnivalence. Coq-HoTT-9.0/theories/Spaces/BAut/Bool/000077500000000000000000000000001474641544500175245ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/BAut/Bool/IncoherentIdempotent.v000066400000000000000000000047121474641544500240460ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Equiv.BiInv Idempotents. Require Import Universes.BAut Spaces.BAut.Bool. Local Open Scope path_scope. (** * An incoherent quasi-idempotent on [BAut (BAut Bool)]. *) Section IncoherentQuasiIdempotent. Context `{Univalence}. (** We use the identity map, and the nontrivial 2-central element of [BAut (BAut Bool)]. *) Definition nontrivial_qidem_baut_baut_bool : IsQuasiIdempotent (preidem_idmap (BAut (BAut Bool))) := negb_center2_baut_baut_bool. Let ret := splitting_preidem_retractof_qidem (preidem_idmap (BAut (BAut Bool))). Let s := retract_sect ret. Let r := retract_retr ret. Let issect := retract_issect ret : r o s == idmap. (** Since the space of splittings of the identity pre-idempotent is contractible, nontriviality of this 2-central element implies that not every quasi-idempotence witness of the identity is recoverable from its own splitting. *) Definition splitting_preidem_notequiv_qidem_baut_baut_bool : ~ (s o r == idmap). Proof. intros oops. assert (p := oops nontrivial_qidem_baut_baut_bool). assert (q := oops (isqidem_idmap (BAut (BAut Bool)))); clear oops. apply nontrivial_negb_center_baut_baut_bool. refine (p^ @ ap s _ @ q). pose (contr_splitting_preidem_idmap (BAut (BAut Bool))). apply path_contr. Defined. (** Therefore, not every quasi-idempotence witness is obtainable from *any* splitting, i.e. it may not have any coherentification. *) Definition not_all_coherent_qidem_baut_baut_bool : ~ (forall q : IsQuasiIdempotent (preidem_idmap (BAut (BAut Bool))), { S : Splitting_PreIdempotent (preidem_idmap _) & s S = q }). Proof. intros oops. assert (IsEquiv s). { apply isequiv_biinv; split. - exists r; exact issect. - exists (fun q => (oops q).1). exact (fun q => (oops q).2). } apply splitting_preidem_notequiv_qidem_baut_baut_bool; intros q. refine (ap s (ap r (eisretr s q)^) @ _). refine (ap s (issect (s^-1 q)) @ _). apply eisretr. Defined. (** These results show only that not *every* quasi-idempotence witness is coherent. "Clearly" the nontrivial quasi-idempotence witness [nontrivial_qidem_baut_baut_bool] should be the one that is not coherent. To show this, we would probably need to show that [isqidem_idmap] *is* in the image of [s], and this seems rather annoying to do based on our construction of [splitting_preidem_retractof_qidem]. *) End IncoherentQuasiIdempotent. Coq-HoTT-9.0/theories/Spaces/BAut/Cantor.v000066400000000000000000000151771474641544500202610ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Idempotents. Require Import HoTT.Truncations.Core Universes.BAut Spaces.Cantor. Local Open Scope equiv_scope. Local Open Scope path_scope. (** * BAut(Cantor) *) (** ** A pre-idempotent on [BAut Cantor] that does not split *) (** We go into a non-exported module so that we can use short names for definitions without polluting the global namespace. *) Module BAut_Cantor_Idempotent. Section Assumptions. Context `{Univalence}. Definition f : BAut Cantor -> BAut Cantor. Proof. intros Z. (** Here is the important part of this definition. *) exists (Z + Cantor). (** The rest is just a proof that [Z+Cantor] is again equivalent to [Cantor], using [cantor_fold] and the assumption that [Z] is equivalent to [Cantor]. *) pose (e := Z.2); simpl in e; clearbody e. strip_truncations. apply tr. apply path_universe_uncurried. refine (equiv_cantor_fold oE _). refine (equiv_path _ _ e +E 1). Defined. (** For the pre-idempotence of [f], the main point is again the existence of the equivalence [fold_cantor]. *) Definition preidem_f : IsPreIdempotent f. Proof. intros Z. apply path_baut. unfold f; simpl. refine (_ oE equiv_sum_assoc Z Cantor Cantor). apply (1 +E equiv_cantor_fold). Defined. (** We record how the action of [f] and [f o f] on paths corresponds to an action on equivalences. *) Definition ap_f {Z Z' : BAut Cantor} (p : Z = Z') : equiv_path _ _ (ap f p)..1 = equiv_path Z Z' p..1 +E 1. Proof. destruct p. apply path_equiv, path_arrow. intros [z|a]; reflexivity. Defined. Definition ap_ff {Z Z' : BAut Cantor} (p : Z = Z') : equiv_path _ _ (ap (f o f) p)..1 = equiv_path Z Z' p..1 +E 1 +E 1. Proof. destruct p. apply path_equiv, path_arrow. intros [[z|a]|a]; reflexivity. Defined. (** Now let's assume [f] is quasi-idempotent, but not necessarily using the same witness of pre-idempotency. *) Context (Ip : IsPreIdempotent f) (Jp : @IsQuasiIdempotent _ f Ip). Definition I (Z : BAut Cantor) : (Z + Cantor) + Cantor <~> Z + Cantor := equiv_path _ _ (Ip Z)..1. Definition I0 : Cantor + Cantor + Cantor + Cantor <~> Cantor + Cantor + Cantor := I (f (point (BAut Cantor))). (** We don't know much about [I0], but we can show that it maps the rightmost two summands to the rightmost one, using the naturality of [I]. Here is the naturality. *) Definition Inat (Z Z' : BAut Cantor) (e : Z <~> Z') : I Z' oE (e +E 1 +E 1) = (e +E 1) oE I Z. Proof. revert e; equiv_intro (equiv_path Z Z') q. revert q; equiv_intro ((equiv_path_sigma_hprop Z Z')^-1) p. simpl. rewrite <- ap_ff, <- ap_f. unfold I. refine ((equiv_path_pp _ _)^ @ _ @ (equiv_path_pp _ _)). apply ap. refine ((pr1_path_pp (ap (f o f) p) (Ip Z'))^ @ _ @ pr1_path_pp _ _). apply ap. apply (concat_Ap Ip). Qed. (** To show our claim about the action of [I0], we will apply this naturality to the flip automorphism of [Cantor + Cantor]. Here are the images of that automorphism under [f] and [f o f]. *) Definition f_flip := equiv_sum_symm Cantor Cantor +E equiv_idmap Cantor. Definition ff_flip := (equiv_sum_symm Cantor Cantor +E equiv_idmap Cantor) +E (equiv_idmap Cantor). (** The naturality of [I] implies that [I0] commutes with these images of the flip. *) Definition I0nat_flip (x : ((Cantor + Cantor) + Cantor) + Cantor) : I0 (ff_flip x) = f_flip (I0 x) := ap10_equiv (Inat (f (point (BAut Cantor))) (f (point (BAut Cantor))) (equiv_sum_symm Cantor Cantor)) x. (** The value of this is that we can detect which summand an element is in depending on whether or not it is fixed by [f_flip] or [ff_flip]. *) Definition f_flip_fixed_iff_inr (x : Cantor + Cantor + Cantor) : (f_flip x = x) <-> is_inr x. Proof. split; intros p; destruct x as [[c|c]|c]; simpl in p. - apply path_sum_inl in p. elim (inl_ne_inr _ _ p^). - apply path_sum_inl in p. elim (inl_ne_inr _ _ p). - exact tt. - elim p. - elim p. - reflexivity. Defined. Definition ff_flip_fixed_iff_inr (x : Cantor + Cantor + Cantor + Cantor) : (ff_flip x = x) <-> (is_inr x + is_inl_and is_inr x). Proof. split; intros p; destruct x as [[[c|c]|c]|c]; simpl in p. - do 2 apply path_sum_inl in p. elim (inl_ne_inr _ _ p^). - do 2 apply path_sum_inl in p. elim (inl_ne_inr _ _ p). - exact (inr tt). - exact (inl tt). - destruct p as [e|e]; elim e. - destruct p as [e|e]; elim e. - destruct p as [e|_]; [ elim e | reflexivity ]. - destruct p as [_|e]; [ reflexivity | elim e ]. Defined. (** And the naturality guarantees that [I0] preserves fixed points. *) Definition I0_fixed_iff_fixed (x : Cantor + Cantor + Cantor + Cantor) : (ff_flip x = x) <-> (f_flip (I0 x) = I0 x). Proof. split; intros p. - refine ((I0nat_flip x)^ @ ap I0 p). - apply (equiv_inj I0). refine (I0nat_flip x @ p). Defined. (** Putting it all together, here is the proof of our claim about [I0]. *) Definition I0_preserves_inr (x : Cantor + Cantor + Cantor + Cantor) : (is_inr x + is_inl_and is_inr x) <-> is_inr (I0 x). Proof. refine (iff_compose _ (f_flip_fixed_iff_inr (I0 x))). refine (iff_compose _ (I0_fixed_iff_fixed x)). apply iff_inverse, ff_flip_fixed_iff_inr. Defined. (** Now we bring quasi-idempotence into play. *) Definition J (Z : BAut Cantor) : I Z +E 1 = I (f Z). Proof. unfold I; simpl. refine ((ap_f (Ip Z))^ @ _). do 2 apply ap. apply Jp. Defined. (** We reach a contradiction by showing that the two maps which [J] claims are equal send elements of the third summand of the domain into different summands of the codomain. *) Definition impossible : Empty. Proof. pose (x := inl (inr (fun n => true)) : ((f (point (BAut Cantor))) + Cantor) + Cantor). apply (not_is_inl_and_inr' (I (f (point (BAut Cantor))) x)). - exact (transport is_inl (ap10_equiv (J (point (BAut Cantor))) x) tt). - exact (fst (I0_preserves_inr x) (inr tt)). Defined. End Assumptions. End BAut_Cantor_Idempotent. (** Let's make the important conclusions available globally. *) Definition baut_cantor_idem `{Univalence} : BAut Cantor -> BAut Cantor := BAut_Cantor_Idempotent.f. Definition preidem_baut_cantor_idem `{Univalence} : IsPreIdempotent baut_cantor_idem := BAut_Cantor_Idempotent.preidem_f. Definition not_qidem_baut_cantor_idem `{Univalence} : ~ { I : IsPreIdempotent baut_cantor_idem & IsQuasiIdempotent baut_cantor_idem } := fun IJ => BAut_Cantor_Idempotent.impossible IJ.1 IJ.2. Coq-HoTT-9.0/theories/Spaces/BinInt.v000066400000000000000000000002441474641544500173500ustar00rootroot00000000000000Require Export HoTT.Spaces.BinInt.Core. Require Export HoTT.Spaces.BinInt.Spec. Require Export HoTT.Spaces.BinInt.Equiv. Require Export HoTT.Spaces.BinInt.LoopExp. Coq-HoTT-9.0/theories/Spaces/BinInt/000077500000000000000000000000001474641544500171615ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/BinInt/Core.v000066400000000000000000000147421474641544500202500ustar00rootroot00000000000000Require Import Basics. Require Import Spaces.Pos.Core. Local Set Universe Minimization ToSet. (** * Binary Integers *) Local Close Scope trunc_scope. Local Close Scope nat_scope. Local Open Scope positive_scope. (** ** Definition of the Integers *) (** We define an integer as being a positive number labelled negative, zero or a positive number labelled positive. *) Inductive BinInt : Type0 := | neg : Pos -> BinInt | zero : BinInt | pos : Pos -> BinInt. Arguments pos p%_pos. Declare Scope binint_scope. Local Open Scope binint_scope. Delimit Scope binint_scope with binint. (** The integers are a pointed type *) Global Instance ispointed_BinInt : IsPointed BinInt := zero. (** Properties of constructors *) Definition neg_inj {z w : Pos} (p : neg z = neg w) : z = w := transport (fun s => z = (match s with neg a => a | zero => w | pos a => w end)) p (idpath z). Definition pos_inj {z w : Pos} (p : pos z = pos w) : z = w := transport (fun s => z = (match s with neg a => w | zero => w | pos a => a end)) p (idpath z). Definition neg_neq_zero {z : Pos} : ~ (neg z = zero) := fun p => transport (fun s => match s with neg a => z = a| zero => Empty | pos _ => Empty end) p (idpath z). Definition pos_neq_zero {z : Pos} : ~ (pos z = zero) := fun p => transport (fun s => match s with pos a => z = a | zero => Empty | neg _ => Empty end) p (idpath z). Definition neg_neq_pos {z w : Pos} : ~ (neg z = pos w) := fun p => transport (fun s => match s with neg a => z = a | zero => Empty | pos _ => Empty end) p (idpath z). Definition zero_neq_neg {z : Pos} := @neg_neq_zero z o symmetry _ _. Definition zero_neq_pos {z : Pos} := @pos_neq_zero z o symmetry _ _. Definition pos_neq_neg {z w : Pos} := @neg_neq_pos z w o symmetry _ _. (** ** Conversion with a decimal representation for printing/parsing *) Definition binint_to_decimal_binint (n : BinInt) : Decimal.int := match n with | neg m => Decimal.Neg (pos_to_uint m) | zero => Decimal.Pos Decimal.Nil | pos m => Decimal.Pos (pos_to_uint m) end. Definition binint_to_number_binint (n : BinInt) : Numeral.int := Numeral.IntDec (binint_to_decimal_binint n). Fixpoint binint_of_decimal_uint (d : Decimal.uint) : BinInt := match d with | Decimal.Nil => zero | Decimal.D0 l => binint_of_decimal_uint l | Decimal.D1 l => pos (pos_of_uint_acc l 1) | Decimal.D2 l => pos (pos_of_uint_acc l 1~0) | Decimal.D3 l => pos (pos_of_uint_acc l 1~1) | Decimal.D4 l => pos (pos_of_uint_acc l 1~0~0) | Decimal.D5 l => pos (pos_of_uint_acc l 1~0~1) | Decimal.D6 l => pos (pos_of_uint_acc l 1~1~0) | Decimal.D7 l => pos (pos_of_uint_acc l 1~1~1) | Decimal.D8 l => pos (pos_of_uint_acc l 1~0~0~0) | Decimal.D9 l => pos (pos_of_uint_acc l 1~0~0~1) end. Definition binint_of_decimal_binint (d : Decimal.int) : BinInt := match d with | Decimal.Pos u => binint_of_decimal_uint u | Decimal.Neg u => let t := binint_of_decimal_uint u in match t with | pos v => neg v | _ => zero end end. Definition binint_of_number_binint (d:Numeral.int) := match d with | Numeral.IntDec d => Some (binint_of_decimal_binint d) | Numeral.IntHex _ => None end. Number Notation BinInt binint_of_number_binint binint_to_number_binint : binint_scope. (* For some reason 0 can be parsed as an integer, but is printed as [zero]. This notation fixes that. *) Notation "0" := zero : binint_scope. (** ** Doubling and variants *) Definition binint_double x := match x with | 0 => 0 | pos p => pos p~0 | neg p => neg p~0 end. Definition binint_succ_double x := match x with | 0 => 1 | pos p => pos p~1 | neg p => neg (pos_pred_double p) end. Definition binint_pred_double x := match x with | 0 => neg 1%pos | neg p => neg p~1 | pos p => pos (pos_pred_double p) end. (** ** Subtraction of positive into BinInt *) Fixpoint binint_pos_sub (x y : Pos) {struct y} : BinInt := match x, y with | p~1, q~1 => binint_double (binint_pos_sub p q) | p~1, q~0 => binint_succ_double (binint_pos_sub p q) | p~1, 1 => pos p~0 | p~0, q~1 => binint_pred_double (binint_pos_sub p q) | p~0, q~0 => binint_double (binint_pos_sub p q) | p~0, 1 => pos (pos_pred_double p) | 1, q~1 => neg q~0 | 1, q~0 => neg (pos_pred_double q) | 1, 1 => zero end%pos. (** ** Negation *) Definition binint_negation x := match x with | zero => zero | pos x => neg x | neg x => pos x end. Notation "- x" := (binint_negation x) : binint_scope. Lemma ibnint_negation_negation n : --n = n. Proof. by destruct n. Qed. (** ** Addition *) Definition binint_add x y := match x, y with | 0, y => y | x, 0 => x | pos x', pos y' => pos (x' + y') | pos x', neg y' => binint_pos_sub x' y' | neg x', pos y' => binint_pos_sub y' x' | neg x', neg y' => neg (x' + y') end. Infix "+" := binint_add : binint_scope. (** ** Successor *) Definition binint_succ x := x + 1. (** ** Predecessor *) Definition binint_pred x := x + neg 1%pos. (** ** Subtraction *) Definition binint_sub m n := m + -n. Infix "-" := binint_sub : binint_scope. (** ** Multiplication *) Definition binint_mul x y := match x, y with | 0, _ => 0 | _, 0 => 0 | pos x', pos y' => pos (x' * y') | pos x', neg y' => neg (x' * y') | neg x', pos y' => neg (x' * y') | neg x', neg y' => pos (x' * y') end. Infix "*" := binint_mul : binint_scope. (** ** Power function *) Definition binint_pow x y := match y with | pos p => pos_iter (binint_mul x) p 1 | 0 => 1 | neg _ => 0 end. (** ** Square *) Definition binint_square x := match x with | 0 => 0 | pos p => pos (pos_square p) | neg p => pos (pos_square p) end. (** ** Sign function *) Definition binint_sgn z := match z with | 0 => 0 | pos p => 1 | neg p => neg 1%pos end. (* ** Decidable paths and truncation. *) Global Instance decpaths_binint : DecidablePaths BinInt. Proof. intros [n | | n] [m | | m]. + destruct (dec (n = m)) as [p | q]. - apply inl, ap, p. - by apply inr; intro; apply q, neg_inj. + exact (inr neg_neq_zero). + exact (inr neg_neq_pos). + exact (inr zero_neq_neg). + exact (inl idpath). + exact (inr zero_neq_pos). + exact (inr pos_neq_neg). + exact (inr pos_neq_zero). + destruct (dec (n = m)) as [p | q]. - apply inl, ap, p. - by apply inr; intro; apply q, pos_inj. Defined. (** Since integers have decidable paths they are a hset *) Global Instance hset_binint : IsHSet BinInt | 0 := _. Coq-HoTT-9.0/theories/Spaces/BinInt/Equiv.v000066400000000000000000000057101474641544500204440ustar00rootroot00000000000000Require Import Basics. Require Import Spaces.Pos. Require Import Spaces.BinInt.Core. Require Import Spaces.BinInt.Spec. (** ** Iteration of equivalences *) (** *** Iteration by arbitrary integers *) Definition binint_iter {A} (f : A -> A) `{!IsEquiv f} (n : BinInt) : A -> A := match n with | neg n => fun x => pos_iter f^-1 n x | zero => idmap | pos n => fun x => pos_iter f n x end. (** Iteration by arbitrary integers requires the endofunction to be an equivalence, so that we can define a negative iteration by using its inverse. *) Definition binint_iter_succ_l {A} (f : A -> A) `{IsEquiv _ _ f} (n : BinInt) (a : A) : binint_iter f (binint_succ n) a = f (binint_iter f n a). Proof. destruct n as [n| |n]; trivial. + revert n f H a. srapply pos_peano_ind. { intros f H a. symmetry. apply eisretr. } hnf; intros n p f H a. refine (ap (fun x => _ x _) _ @ _). 1: rewrite binint_neg_pos_succ. 1: exact (eisretr binint_succ (neg n)). apply moveL_equiv_M. cbn; symmetry. srapply pos_iter_succ_l. + cbn. rewrite pos_add_1_r. srapply pos_iter_succ_l. Qed. Definition binint_iter_succ_r {A} (f : A -> A) `{IsEquiv _ _ f} (n : BinInt) (a : A) : binint_iter f (binint_succ n) a = binint_iter f n (f a). Proof. destruct n as [n| |n]; trivial. + revert n f H a. srapply pos_peano_ind. { intros f H a. symmetry. apply eissect. } hnf; intros n p f H a. rewrite binint_neg_pos_succ. refine (ap (fun x => _ x _) _ @ _). 1: exact (eisretr binint_succ (neg n)). cbn; rewrite pos_add_1_r. rewrite pos_iter_succ_r. rewrite eissect. reflexivity. + cbn. rewrite pos_add_1_r. srapply pos_iter_succ_r. Qed. Definition iter_binint_pred_l {A} (f : A -> A) `{IsEquiv _ _ f} (n : BinInt) (a : A) : binint_iter f (binint_pred n) a = f^-1 (binint_iter f n a). Proof. destruct n as [n| |n]; trivial. + cbn; rewrite pos_add_1_r. by rewrite pos_iter_succ_l. + revert n. srapply pos_peano_ind. - cbn; symmetry; apply eissect. - hnf; intros p q. rewrite <- pos_add_1_r. change (binint_pred (pos (p + 1)%pos)) with (binint_pred (binint_succ (pos p))). rewrite binint_pred_succ. change (pos (p + 1)%pos) with (binint_succ (pos p)). rewrite binint_iter_succ_l. symmetry. apply eissect. Qed. Definition iter_binint_pred_r {A} (f : A -> A) `{IsEquiv _ _ f} (n : BinInt) (a : A) : binint_iter f (binint_pred n) a = binint_iter f n (f^-1 a). Proof. revert f H n a. destruct n as [n| |n]; trivial; induction n as [|n nH] using pos_peano_ind; trivial. 2: hnf; intros; apply symmetry, eisretr. all: rewrite <- pos_add_1_r. all: intro a. 1: change (neg (n + 1)%pos) with (binint_pred (neg n)). 2: change (pos (n + 1)%pos) with (binint_succ (pos n)). 1: rewrite <- 2 binint_neg_pos_succ. 1: cbn; apply pos_iter_succ_r. rewrite binint_pred_succ. rewrite binint_iter_succ_r. rewrite eisretr. reflexivity. Qed. Coq-HoTT-9.0/theories/Spaces/BinInt/LoopExp.v000066400000000000000000000147361474641544500207510ustar00rootroot00000000000000Require Import Basics. Require Import Types.Universe. Require Import Spaces.Pos. Require Import Spaces.BinInt.Core. Require Import Spaces.BinInt.Spec. Require Import Spaces.BinInt.Equiv. Local Open Scope positive_scope. Local Open Scope binint_scope. (** ** Exponentiation of loops *) Definition loopexp_pos {A : Type} {x : A} (p : x = x) (n : Pos) : (x = x). Proof. revert n. srapply pos_peano_ind. + exact p. + intros n q. exact (q @ p). Defined. Definition loopexp {A : Type} {x : A} (p : x = x) (z : BinInt) : (x = x) := match z with | neg n => loopexp_pos p^ n | zero => 1 | pos n => loopexp_pos p n end. (** TODO: One can also define [loopexp] as [int_iter (equiv_concat_r p x) z idpath]. This has slightly different computational behaviour, e.g., it sends [1 : int] to [1 @ p] rather than [p]. But with this definition, some of the results below become special cases of results in BinInt.Equiv, and others could be generalized to results belonging in BinInt.Equiv. It's probably worth investigating this. *) Lemma loopexp_pos_inv {A : Type} {x : A} (p : x = x) (n : Pos) : loopexp_pos p^ n = (loopexp_pos p n)^. Proof. revert n. srapply pos_peano_ind; cbn; trivial. unfold loopexp_pos. intros n q. rewrite 2 pos_peano_ind_beta_pos_succ, q. refine ((inv_pp _ _)^ @ _). apply ap. clear q. revert n. srapply pos_peano_ind; cbn; trivial. intros n q. by rewrite pos_peano_ind_beta_pos_succ, concat_p_pp, q. Qed. Definition ap_loopexp_pos {A B} (f : A -> B) {x : A} (p : x = x) (n : Pos) : ap f (loopexp_pos p n) = loopexp_pos (ap f p) n. Proof. revert n. srapply pos_peano_ind; cbn; trivial. unfold loopexp_pos. intros n q. rewrite 2 pos_peano_ind_beta_pos_succ. by rewrite ap_pp, q. Qed. Definition ap_loopexp {A B} (f : A -> B) {x : A} (p : x = x) (z : BinInt) : ap f (loopexp p z) = loopexp (ap f p) z. Proof. destruct z as [n| |n]; trivial. + cbn. rewrite loopexp_pos_inv, ap_V, loopexp_pos_inv. apply ap. apply ap_loopexp_pos. + apply ap_loopexp_pos. Qed. Lemma loopexp_pos_concat {A : Type} {x : A} (p : x = x) (a : Pos) : loopexp_pos p a @ p = p @ loopexp_pos p a. Proof. induction a as [|a aH] using pos_peano_ind; trivial. unfold loopexp_pos. rewrite pos_peano_ind_beta_pos_succ. change ((loopexp_pos p a @ p) @ p = p @ (loopexp_pos p a @ p)). by rewrite concat_p_pp, aH. Qed. Lemma loopexp_pos_add {A : Type} {x : A} (p : x = x) (a b : Pos) : loopexp_pos p (a + b)%pos = loopexp_pos p a @ loopexp_pos p b. Proof. revert a b. induction a as [|a aH] using pos_peano_ind; induction b as [|b bH] using pos_peano_ind; trivial. + rewrite pos_add_1_l in *. unfold loopexp_pos. rewrite pos_peano_ind_beta_pos_succ. change (loopexp_pos p (pos_succ b) @ p = p @ loopexp_pos p (pos_succ b)). rewrite bH; cbn. by rewrite concat_pp_p, loopexp_pos_concat. + rewrite pos_add_1_r in *. unfold loopexp_pos. by rewrite pos_peano_ind_beta_pos_succ. + rewrite pos_add_succ_l. unfold loopexp_pos. rewrite 2 pos_peano_ind_beta_pos_succ. change (loopexp_pos p (a + pos_succ b)%pos @ p = (loopexp_pos p a @ p) @ loopexp_pos p (pos_succ b)). by rewrite aH, 2 concat_pp_p, loopexp_pos_concat. Qed. Lemma loopexp_binint_pos_sub_l {A : Type} {x : A} (p : x = x) (a b : Pos) : loopexp p (binint_pos_sub a b) = loopexp_pos p^ b @ loopexp_pos p a. Proof. symmetry. revert a b. induction a as [|a aH] using pos_peano_ind; induction b as [|b bH] using pos_peano_ind. + apply concat_Vp. + cbn; rewrite binint_pos_sub_succ_r. unfold loopexp_pos. rewrite pos_peano_ind_beta_pos_succ. by rewrite concat_pp_p, concat_Vp, concat_p1. + rewrite binint_pos_sub_succ_l; cbn. unfold loopexp_pos. rewrite pos_peano_ind_beta_pos_succ. rewrite loopexp_pos_concat. by rewrite concat_p_pp, concat_Vp, concat_1p. + rewrite binint_pos_sub_succ_succ. unfold loopexp_pos. rewrite 2 pos_peano_ind_beta_pos_succ. change ((loopexp_pos p^ b @ p^) @ (loopexp_pos p a @ p) = loopexp p (binint_pos_sub a b)). rewrite (loopexp_pos_concat p). rewrite concat_pp_p, (concat_p_pp p^ p). rewrite concat_Vp, concat_1p. apply aH. Qed. Lemma loopexp_binint_pos_sub_r {A : Type} {x : A} (p : x = x) (a b : Pos) : loopexp p (binint_pos_sub a b) = loopexp_pos p a @ loopexp_pos p^ b. Proof. symmetry. revert a b. induction a as [|a aH] using pos_peano_ind; induction b as [|b bH] using pos_peano_ind. + apply concat_pV. + cbn; rewrite binint_pos_sub_succ_r. unfold loopexp_pos. rewrite pos_peano_ind_beta_pos_succ. change (p @ (loopexp_pos p^ b @ p^) = loopexp p (neg b)). rewrite loopexp_pos_concat. by rewrite concat_p_pp, concat_pV, concat_1p. + rewrite binint_pos_sub_succ_l; cbn. unfold loopexp_pos. rewrite pos_peano_ind_beta_pos_succ. change ((loopexp_pos p a @ p) @ p^ = loopexp_pos p a). by rewrite concat_pp_p, concat_pV, concat_p1. + rewrite binint_pos_sub_succ_succ. unfold loopexp_pos. rewrite 2 pos_peano_ind_beta_pos_succ. change ((loopexp_pos p a @ p) @ (loopexp_pos p^ b @ p^) = loopexp p (binint_pos_sub a b)). rewrite (loopexp_pos_concat p^). rewrite concat_pp_p, (concat_p_pp p p^). rewrite concat_pV, concat_1p. apply aH. Qed. Lemma loopexp_add {A : Type} {x : A} (p : x = x) a b : loopexp p (a + b) = loopexp p a @ loopexp p b. Proof. destruct a as [a| |a], b as [b| |b]; trivial; try apply loopexp_pos_add; cbn. 1,6: symmetry; apply concat_p1. 2,3: symmetry; apply concat_1p. 1: apply loopexp_binint_pos_sub_l. apply loopexp_binint_pos_sub_r. Qed. (** Under univalence, exponentiation of loops corresponds to iteration of autoequivalences. *) Definition equiv_path_loopexp {A : Type} (p : A = A) (z : BinInt) (a : A) : equiv_path A A (loopexp p z) a = binint_iter (equiv_path A A p) z a. Proof. destruct z as [n| |n]; trivial. all: induction n as [|n IH] using pos_peano_ind; try reflexivity; cbn in *. all: unfold loopexp_pos; rewrite pos_peano_ind_beta_pos_succ. all: unfold pos_iter; rewrite pos_peano_rec_beta_pos_succ. all: refine (transport_pp _ _ _ _ @ _); cbn; apply ap, IH. Defined. Definition loopexp_path_universe `{Univalence} {A : Type} (f : A <~> A) (z : BinInt) (a : A) : transport idmap (loopexp (path_universe f) z) a = binint_iter f z a. Proof. revert f. equiv_intro (equiv_path A A) p. refine (_ @ equiv_path_loopexp p z a). refine (ap (fun q => equiv_path A A (loopexp q z) a) _). apply eissect. Defined. Coq-HoTT-9.0/theories/Spaces/BinInt/Spec.v000066400000000000000000000300361474641544500202440ustar00rootroot00000000000000Require Import Basics. Require Import Spaces.Pos. Require Import Spaces.BinInt.Core. Local Set Universe Minimization ToSet. Local Open Scope binint_scope. (** ** Addition is commutative *) Lemma binint_add_comm n m : n + m = m + n. Proof. destruct n, m; trivial. all: cbn. all: apply ap, pos_add_comm. Defined. (** ** Zero is the additive identity. *) Definition binint_add_0_l n : 0 + n = n := 1. Lemma binint_add_0_r n : n + 0 = n. Proof. by destruct n. Defined. (** ** Multiplication by zero is zero *) Definition binint_mul_0_l n : 0 * n = 0 := 1. Lemma binint_mul_0_r n : n * 0 = 0. Proof. by destruct n. Defined. (** ** One is the multiplicative identity *) Lemma binint_mul_1_l n : 1 * n = n. Proof. by destruct n. Defined. Lemma binint_mul_1_r n : n * 1 = n. Proof. destruct n; trivial; cbn; apply ap, pos_mul_1_r. Defined. (** ** Inverse laws *) Lemma binint_pos_sub_diag n : binint_pos_sub n n = 0. Proof. induction n; trivial; cbn. all: exact (ap binint_double IHn). Defined. Lemma binint_add_negation_l n : (-n) + n = 0. Proof. destruct n; trivial; cbn; apply binint_pos_sub_diag. Defined. Lemma binint_add_negation_r n : n + (-n) = 0. Proof. destruct n; trivial; cbn; apply binint_pos_sub_diag. Defined. (** ** Permutation of neg and pos_succ *) Lemma binint_neg_pos_succ p : neg (pos_succ p) = binint_pred (neg p). Proof. by destruct p. Defined. (** ** Permutation of pos and pos_succ *) Lemma binint_pos_pos_succ p : pos (pos_succ p) = binint_succ (pos p). Proof. by destruct p. Defined. (** ** Negation of a doubled positive integer *) Lemma binint_negation_double a : - (binint_double a) = binint_double (- a). Proof. by destruct a. Defined. (** Negation of the predecessor of a doubled positive integer. *) Lemma binint_negation_pred_double a : - (binint_pred_double a) = binint_succ_double (- a). Proof. by destruct a. Defined. (** Negation of the doubling of the sucessor of an positive. *) Lemma binint_negation_succ_double a : - (binint_succ_double a) = binint_pred_double (- a). Proof. by destruct a. Defined. (** Negation of subtraction of positive integers *) Lemma binint_pos_sub_negation a b : - (binint_pos_sub a b) = binint_pos_sub b a. Proof. revert a b. induction a as [|a ah|a ah]; destruct b; cbn; trivial. all: rewrite ?binint_negation_double, ?binint_negation_succ_double, ?binint_negation_pred_double. all: apply ap, ah. Defined. (** ** binint_succ is a retract of binint_pred *) Definition binint_succ_pred : binint_succ o binint_pred == idmap. Proof. intros [n | | n]; [|trivial|]. all: destruct n; trivial. 1,2: cbn; apply ap. 1: apply pos_pred_double_succ. rewrite pos_add_1_r. apply pos_succ_pred_double. Defined. (** ** binint_pred is a retract of binint_succ *) Definition binint_pred_succ : binint_pred o binint_succ == idmap. Proof. intros [n | | n]; [|trivial|]. all: destruct n; trivial. 1,2: cbn; apply ap. 1: rewrite pos_add_1_r. 1: apply pos_succ_pred_double. apply pos_pred_double_succ. Defined. (* ** The successor autoequivalence. *) Global Instance isequiv_binint_succ : IsEquiv binint_succ | 0 := isequiv_adjointify binint_succ _ binint_succ_pred binint_pred_succ. Definition equiv_binint_succ : BinInt <~> BinInt := Build_Equiv _ _ _ isequiv_binint_succ. (** ** Negation distributes over addition *) Lemma binint_negation_add_distr n m : - (n + m) = - n + - m. Proof. destruct n, m; simpl; trivial using binint_pos_sub_negation. Defined. (** ** Negation is injective *) Lemma binint_negation_inj n m : -n = -m -> n = m. Proof. destruct n, m; simpl; intro H. 1: apply pos_inj in H. 2: apply pos_neq_zero in H. 3: apply pos_neq_neg in H. 4: apply zero_neq_pos in H. 6: apply zero_neq_neg in H. 7: apply neg_neq_pos in H. 8: apply neg_neq_zero in H. 9: apply neg_inj in H. all: by destruct H. Defined. (** ** Subtracting 1 from a sucessor gives the positive integer. *) Lemma binint_pos_sub_succ_l a : binint_pos_sub (pos_succ a) 1%pos = pos a. Proof. destruct a; trivial. cbn; apply ap, pos_pred_double_succ. Defined. (** ** Subtracting a sucessor from 1 gives minus the integer. *) Lemma binint_pos_sub_succ_r a : binint_pos_sub 1%pos (pos_succ a) = neg a. Proof. destruct a; trivial. cbn; apply ap, pos_pred_double_succ. Defined. (** ** Interaction of doubling functions and subtraction *) Lemma binint_succ_double_binint_pos_sub a b : binint_succ_double (binint_pos_sub a (pos_succ b)) = binint_pred_double (binint_pos_sub a b). Proof. revert a b. induction a; induction b; trivial. + cbn; apply ap. by rewrite pos_pred_double_succ. + destruct a; trivial. + cbn; destruct (binint_pos_sub a b); trivial. + cbn. rewrite <- IHa. destruct (binint_pos_sub a (pos_succ b)); trivial. + destruct a; trivial. + cbn; destruct (binint_pos_sub a b); trivial. + cbn. rewrite IHa. cbn; destruct (binint_pos_sub a b); trivial. Defined. Lemma binint_pred_double_binint_pos_sub a b : binint_pred_double (binint_pos_sub (pos_succ a) b) = binint_succ_double (binint_pos_sub a b). Proof. revert a b. induction a; induction b; trivial. + by destruct b. + by destruct b. + cbn; by destruct (binint_pos_sub a b). + cbn; by destruct (binint_pos_sub a b). + cbn; apply ap. by rewrite pos_pred_double_succ. + cbn. rewrite <- IHa. by destruct (binint_pos_sub (pos_succ a) b). + cbn. rewrite IHa. by destruct (binint_pos_sub a b). Defined. (** ** Subtractions cancel sucessors. *) Lemma binint_pos_sub_succ_succ a b : binint_pos_sub (pos_succ a) (pos_succ b) = binint_pos_sub a b. Proof. rewrite <- 2 pos_add_1_r. revert a b. induction a; induction b; trivial. 1: destruct b; trivial. { destruct b; trivial. cbn; apply ap. by rewrite pos_pred_double_succ. } 1: destruct a; trivial. 1: apply binint_succ_double_binint_pos_sub. { destruct a; trivial. cbn; apply ap, ap, pos_pred_double_succ. } 1: apply binint_pred_double_binint_pos_sub. cbn; apply ap. rewrite <- 2 pos_add_1_r. apply IHa. Defined. (** ** Predecessor of a subtraction is the subtraction of a sucessor. *) Lemma binint_pred_pos_sub_r a b : binint_pred (binint_pos_sub a b) = binint_pos_sub a (pos_succ b). Proof. revert a. induction b as [|b bH] using pos_peano_ind. 1: destruct a; trivial; destruct a; trivial. intro a. revert b bH. induction a as [|a aH] using pos_peano_ind. { intros b bH. rewrite <- bH. destruct b; trivial. cbn; apply ap. rewrite 2 pos_add_1_r. rewrite pos_succ_pred_double. rewrite pos_pred_double_succ. trivial. } intros b bH. rewrite 2 binint_pos_sub_succ_succ. apply bH. Defined. (** ** Negation of the predecessor is an involution. *) Lemma binint_negation_pred_negation_red x : - binint_pred (- binint_pred x) = x. Proof. destruct x as [x| |x]; trivial; destruct x; trivial; cbn; apply ap. 1: apply pos_pred_double_succ. rewrite pos_add_1_r. apply pos_succ_pred_double. Defined. (** ** Predecessor of a sum is the sum with a predecessor *) Lemma binint_pred_add_r a b : binint_pred (a + b) = a + binint_pred b. Proof. revert a b. intros [a| |a] [b| |b]; trivial. + cbn; apply ap. by rewrite pos_add_assoc. + revert a. induction b as [|b bH] using pos_peano_ind. - intro a; exact (binint_pred_succ (neg a)). - intro a. rewrite <- pos_add_1_r. rewrite (binint_pred_succ (pos b)). rewrite binint_add_comm. cbn. rewrite pos_add_1_r. rewrite <- binint_pos_sub_negation. rewrite <- binint_pred_pos_sub_r. apply binint_negation_inj. rewrite binint_pos_sub_negation. apply binint_negation_pred_negation_red. + cbn. rewrite pos_add_1_r. apply binint_pred_pos_sub_r. + revert a. induction b as [|b bH] using pos_peano_ind. - intro a; exact (binint_pred_succ (pos a)). - intro a. rewrite <- pos_add_1_r. rewrite (binint_pred_succ (pos b)). cbn; rewrite pos_add_assoc. change (binint_pred (binint_succ (pos (a + b)%pos)) = pos a + pos b). apply binint_pred_succ. Defined. (** ** Subtraction from a sum is the sum of a subtraction *) Lemma binint_pos_sub_add (a b c : Pos) : binint_pos_sub (a + b)%pos c = pos a + binint_pos_sub b c. Proof. revert c b a. induction c as [|c ch] using pos_peano_ind. { intros b a. change (binint_pred (pos a + pos b) = pos a + (binint_pred (pos b))). apply binint_pred_add_r. } intros b a. rewrite <- binint_pred_pos_sub_r. rewrite ch. rewrite <- binint_pred_pos_sub_r. apply binint_pred_add_r. Defined. (** An auxillary lemma used to prove associativity. *) Lemma binint_add_assoc_pos p n m : pos p + (n + m) = pos p + n + m. Proof. destruct n as [n| |n], m as [m| |m]; trivial. - cbn; apply binint_negation_inj. rewrite !binint_negation_add_distr, !binint_pos_sub_negation. rewrite binint_add_comm, pos_add_comm. apply binint_pos_sub_add. - symmetry. apply binint_add_0_r. - by rewrite <- binint_pos_sub_add, binint_add_comm, <- binint_pos_sub_add, pos_add_comm. - symmetry. apply binint_pos_sub_add. - cbn; apply ap, pos_add_assoc. Defined. (** ** Associativity of addition *) Lemma binint_add_assoc n m p : n + (m + p) = n + m + p. Proof. destruct n. - apply binint_negation_inj. rewrite !binint_negation_add_distr. apply binint_add_assoc_pos. - trivial. - apply binint_add_assoc_pos. Defined. (** ** Relationship between [int_succ], [int_pred] and addition. *) Lemma binint_add_succ_l a b : binint_succ a + b = binint_succ (a + b). Proof. rewrite <- binint_add_assoc, (binint_add_comm 1 b). apply binint_add_assoc. Defined. Lemma binint_add_succ_r a b : a + binint_succ b = binint_succ (a + b). Proof. apply binint_add_assoc. Defined. Lemma binint_add_pred_l a b : binint_pred a + b = binint_pred (a + b). Proof. rewrite <- binint_add_assoc, (binint_add_comm (-1) b). apply binint_add_assoc. Defined. Lemma binint_add_pred_r a b : a + binint_pred b = binint_pred (a + b). Proof. apply binint_add_assoc. Defined. (** ** Commutativity of multiplication *) Lemma binint_mul_comm n m : n * m = m * n. Proof. destruct n, m; cbn; try reflexivity; apply ap; apply pos_mul_comm. Defined. (** Distributivity of multiplication over addition *) Lemma binint_pos_sub_mul_pos n m p : binint_pos_sub n m * pos p = binint_pos_sub (n * p)%pos (m * p)%pos. Proof. rewrite binint_mul_comm. rewrite 2 (pos_mul_comm _ p). induction p. { rewrite 2 pos_mul_1_l. apply binint_mul_1_l. } { cbn. rewrite <- IHp. set (binint_pos_sub n m) as k. by destruct k. } cbn. rewrite binint_pos_sub_add. rewrite <- (binint_pos_sub_negation _ (x0 _)). rewrite binint_pos_sub_add. rewrite binint_negation_add_distr. rewrite binint_pos_sub_negation. rewrite binint_add_assoc. cbn. rewrite <- IHp. set (binint_pos_sub n m) as k. by destruct k. Defined. Lemma binint_pos_sub_mul_neg n m p : binint_pos_sub m n * neg p = binint_pos_sub (n * p)%pos (m * p)%pos. Proof. rewrite binint_mul_comm. rewrite 2 (pos_mul_comm _ p). induction p. { rewrite 2 pos_mul_1_l. rewrite <- binint_pos_sub_negation. by destruct (binint_pos_sub n m). } { cbn. rewrite <- IHp. rewrite <- binint_pos_sub_negation. set (binint_pos_sub n m) as k. by destruct k. } cbn. rewrite binint_pos_sub_add. rewrite <- (binint_pos_sub_negation _ (x0 _)). rewrite binint_pos_sub_add. rewrite binint_negation_add_distr. rewrite binint_pos_sub_negation. rewrite binint_add_assoc. cbn. rewrite <- IHp. rewrite <- (binint_pos_sub_negation m). set (binint_pos_sub m n) as k. by destruct k. Defined. Lemma binint_mul_add_distr_r n m p : (n + m) * p = n * p + m * p. Proof. induction p; destruct n, m; cbn; trivial; try f_ap; try apply pos_mul_add_distr_r; try apply binint_pos_sub_mul_neg; try apply binint_pos_sub_mul_pos; apply binint_mul_0_r. Defined. Lemma binint_mul_add_distr_l n m p : n * (m + p) = n * m + n * p. Proof. rewrite 3 (binint_mul_comm n); apply binint_mul_add_distr_r. Defined. Lemma binint_mul_assoc n m p : n * (m * p) = n * m * p. Proof. destruct n, m, p; cbn; trivial; f_ap; apply pos_mul_assoc. Defined. Coq-HoTT-9.0/theories/Spaces/Cantor.v000066400000000000000000000022231474641544500174120ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Local Open Scope nat_scope. Local Open Scope path_scope. (** * Cantor space 2^N *) Definition Cantor : Type := nat -> Bool. Definition cantor_fold : Cantor + Cantor -> Cantor. Proof. intros [c|c]; intros n. - destruct n as [|n]. + exact true. + exact (c n). - destruct n as [|n]. + exact false. + exact (c n). Defined. Definition cantor_unfold : Cantor -> Cantor + Cantor. Proof. intros c. case (c 0). - exact (inl (fun n => c n.+1)). - exact (inr (fun n => c n.+1)). Defined. Global Instance isequiv_cantor_fold `{Funext} : IsEquiv cantor_fold. Proof. refine (isequiv_adjointify _ cantor_unfold _ _). - intros c; apply path_arrow; intros n. induction n as [|n IH]. + unfold cantor_unfold. case (c 0); reflexivity. + unfold cantor_unfold. case (c 0); reflexivity. - intros [c|c]; apply path_sum; reflexivity. Defined. Definition equiv_cantor_fold `{Funext} : Cantor + Cantor <~> Cantor := Build_Equiv _ _ cantor_fold _. Definition equiv_cantor_unfold `{Funext} : Cantor <~> Cantor + Cantor := Build_Equiv _ _ cantor_unfold (isequiv_inverse equiv_cantor_fold). Coq-HoTT-9.0/theories/Spaces/Card.v000066400000000000000000000130751474641544500170440ustar00rootroot00000000000000(** Representation of cardinals, see Chapter 10 of the HoTT book. *) Require Import HoTT.Universes.TruncType. Require Import HoTT.Classes.interfaces.abstract_algebra. (** This speeds things up considerably *) Local Opaque equiv_isequiv istrunc_isequiv_istrunc. (** ** Definitions and operations *) Definition Card := Trunc 0 HSet. Definition card A `{IsHSet A} : Card := tr (Build_HSet A). Definition sum_card (a b : Card) : Card. Proof. strip_truncations. refine (tr (Build_HSet (a + b))). Defined. Definition prod_card (a b : Card) : Card. Proof. strip_truncations. refine (tr (Build_HSet (a * b))). Defined. Definition exp_card `{Funext} (b a : Card) : Card. Proof. strip_truncations. refine (tr (Build_HSet (b -> a))). Defined. Definition leq_card `{Univalence} : Card -> Card -> HProp. Proof. refine (Trunc_rec (fun a => _)). refine (Trunc_rec (fun b => _)). exact (hexists (fun (i : a -> b) => IsInjective i)). Defined. (** ** Properties *) Section contents. Context `{Univalence}. Global Instance plus_card : Plus Card := sum_card. Global Instance mult_card : Mult Card := prod_card. Global Instance zero_card : Zero Card := tr (Build_HSet Empty). Global Instance one_card : One Card := tr (Build_HSet Unit). Global Instance le_card : Le Card := leq_card. (* Reduce an algebraic equation to an equivalence *) Local Ltac reduce := repeat (intros ?); strip_truncations; cbn; f_ap; apply path_hset. (* Simplify an equation by unfolding all the definitions apart from the actual operations. *) (* Note that this is an expensive thing to do, and will be very slow unless we tell it not to unfold the following. *) Local Ltac simpl_ops := cbv-[plus_card mult_card zero_card one_card exp_card]. (** We only make the instances of upper classes global, since the other instances will be project anyway. *) (** *** [Card] is a semi-ring *) Instance associative_sum : Associative plus_card. Proof. reduce. symmetry. apply equiv_sum_assoc. Defined. Instance rightid_sum : RightIdentity plus_card zero_card. Proof. reduce. apply sum_empty_r. Defined. Instance commutative_sum : Commutative plus_card. Proof. reduce. apply equiv_sum_symm. Defined. Instance associative_prod : Associative mult_card. Proof. reduce. apply equiv_prod_assoc. Defined. Instance rightid_prod : RightIdentity mult_card one_card. Proof. reduce. apply prod_unit_r. Defined. Instance commutative_prod : Commutative mult_card. Proof. reduce. apply equiv_prod_symm. Defined. Instance leftdistributive_card : LeftDistribute mult_card plus_card. Proof. reduce. apply sum_distrib_l. Defined. Instance leftabsorb_card : LeftAbsorb mult_card zero_card. Proof. reduce. apply prod_empty_l. Defined. Global Instance issemiring_card : IsSemiCRing Card. Proof. repeat split; try apply _. - repeat intro. simpl_ops. rewrite (commutativity zero_card _). apply rightid_sum. - repeat intro. simpl_ops. rewrite (commutativity one_card _). apply rightid_prod. Defined. (** *** Properties of exponentiation *) Lemma exp_zero_card (a : Card) : exp_card 0 a = 1. Proof. simpl_ops. reduce. symmetry. apply equiv_empty_rec. Defined. Lemma exp_card_one (a : Card) : exp_card a 1 = 1. Proof. simpl_ops. reduce. symmetry. apply equiv_unit_coind. Defined. Lemma exp_one_card (a : Card) : exp_card 1 a = a. Proof. reduce. symmetry. apply equiv_unit_rec. Defined. Lemma exp_card_sum_mult (a b c : Card) : exp_card (b + c) a = (exp_card b a) * (exp_card c a). Proof. reduce. symmetry. apply equiv_sum_distributive. Defined. Lemma exp_mult_card_exp (a b c : Card) : exp_card (b * c) a = exp_card c (exp_card b a). Proof. rewrite (@commutativity _ _ (.*.) _ b c). reduce. symmetry. apply equiv_uncurry. Defined. Lemma exp_card_mult_mult (a b c : Card) : exp_card c (a * b) = (exp_card c a) * (exp_card c b). Proof. reduce. symmetry. apply equiv_prod_coind. Defined. (** *** Properties of ≤ *) Instance reflexive_card : Reflexive leq_card. Proof. intro x. strip_truncations. apply tr. exists idmap. refine (fun _ _ => idmap). Defined. Instance transitive_card : Transitive leq_card. Proof. intros a b c. strip_truncations. intros Hab Hbc. strip_truncations. destruct Hab as [iab Hab]. destruct Hbc as [ibc Hbc]. apply tr. exists (ibc ∘ iab). intros x y Hxy. apply Hab. apply Hbc. apply Hxy. Defined. Global Instance preorder_card : PreOrder le_card. Proof. split; apply _. Defined. End contents. (** * Cardinality comparisons *) (* We also work with cardinality comparisons directly to avoid unnecessary type truncations via cardinals. *) Definition Injection X Y := { f : X -> Y | IsInjective f }. Global Instance Injection_refl : Reflexive Injection. Proof. intros X. exists (fun x => x). intros x x'. done. Qed. Lemma Injection_trans X Y Z : Injection X Y -> Injection Y Z -> Injection X Z. Proof. intros [f Hf] [g Hg]. exists (fun x => g (f x)). intros x x' H. by apply Hf, Hg. Qed. Definition InjectsInto X Y := merely (Injection X Y). Global Instance InjectsInto_refl : Reflexive InjectsInto. Proof. intros X. apply tr. reflexivity. Qed. Lemma InjectsInto_trans X Y Z : InjectsInto X Y -> InjectsInto Y Z -> InjectsInto X Z. Proof. intros H1 H2. eapply merely_destruct; try apply H1. intros [f Hf]. eapply merely_destruct; try apply H2. intros [g Hg]. apply tr. exists (fun x => g (f x)). intros x x' H. by apply Hf, Hg. Qed. (** * Infinity *) (* We call a set infinite if nat embeds into it. *) Definition infinite X := Injection nat X. Coq-HoTT-9.0/theories/Spaces/Circle.v000066400000000000000000000216211474641544500173700ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed.Core Pointed.Loops Pointed.pEquiv. Require Import HSet. Require Import Spaces.Int. Require Import Colimits.Coeq. Require Import Truncations.Core Truncations.Connectedness. (** * Theorems about the [Circle]. *) Local Open Scope pointed_scope. Local Open Scope path_scope. Generalizable Variables X A B f g n. (* ** Definition of the [Circle]. *) (** We define the circle as the coequalizer of two copies of the identity map of [Unit]. This is easily equivalent to the naive definition << Private Inductive Circle : Type0 := | base : Circle | loop : base = base. >> but it allows us to apply the flattening lemma directly rather than having to pass across that equivalence. *) (** The circle is defined to be the coequalizer of two copies of the identity map on [Unit]. *) Definition Circle := @Coeq Unit Unit idmap idmap. (** It has a basepoint. *) Definition base : Circle := coeq tt. (** And a non-trivial path. *) Definition loop : base = base := cglue tt. (** Here is a notation for the circle that can be imported. *) Module CircleNotation. Notation S1 := Circle (only parsing). End CircleNotation. (** Circle induction *) Definition Circle_ind (P : Circle -> Type) (b : P base) (l : loop # b = b) : forall (x : Circle), P x. Proof. refine (Coeq_ind P (fun u => transport P (ap coeq (path_unit tt u)) b) _). intros []; exact l. Defined. (** Computation rule for circle induction. *) Definition Circle_ind_beta_loop (P : Circle -> Type) (b : P base) (l : loop # b = b) : apD (Circle_ind P b l) loop = l := Coeq_ind_beta_cglue P _ _ tt. (** We mark [Circle], [base] and [loop] to never be simplified by [simpl] or [cbn] in order to hide how we defined it from the user. *) Arguments Circle : simpl never. Arguments base : simpl never. Arguments loop : simpl never. Arguments Circle_ind_beta_loop : simpl never. (** The recursion princple or non-dependent eliminator. *) Definition Circle_rec (P : Type) (b : P) (l : b = b) : Circle -> P := Circle_ind (fun _ => P) b (transport_const _ _ @ l). (** Computation rule for non-dependent eliminator. *) Definition Circle_rec_beta_loop (P : Type) (b : P) (l : b = b) : ap (Circle_rec P b l) loop = l. Proof. unfold Circle_rec. refine (cancelL (transport_const loop b) _ _ _). refine ((apD_const (Circle_ind (fun _ => P) b _) loop)^ @ _). refine (Circle_ind_beta_loop (fun _ => P) _ _). Defined. (** The [Circle] is pointed by [base]. *) Global Instance ispointed_Circle : IsPointed Circle := base. Definition pCircle : pType := [Circle, base]. (** ** The loop space of the [Circle] is the Integers [Int] This is the encode-decode style proof a la Licata-Shulman. *) Section EncodeDecode. (** We assume univalence throughout this section. *) Context `{Univalence}. (** First we define the type of codes, this is a type family over the circle. This can be thought of as the covering space by the homotopical real numbers. It is defined by mapping loop to the path given by univalence applied to the automorphism of the integers. We will show that the section of this family at [base] is equivalent to the loop space of the circle. Giving us an equivalence [base = base <~> Int]. *) Definition Circle_code : Circle -> Type := Circle_rec Type Int (path_universe int_succ). (** Transporting along [loop] gives us the successor automorphism on [Int]. *) Definition transport_Circle_code_loop (z : Int) : transport Circle_code loop z = int_succ z. Proof. refine (transport_compose idmap Circle_code loop z @ _). unfold Circle_code; rewrite Circle_rec_beta_loop. apply transport_path_universe. Defined. (** Transporting along [loop^] gives us the predecessor on [Int]. *) Definition transport_Circle_code_loopV (z : Int) : transport Circle_code loop^ z = int_pred z. Proof. refine (transport_compose idmap Circle_code loop^ z @ _). rewrite ap_V. unfold Circle_code; rewrite Circle_rec_beta_loop. rewrite <- (path_universe_V int_succ). apply transport_path_universe. Defined. (** To turn a path in [Circle] based at [base] into a code we transport along it. We call this encoding. *) Definition Circle_encode (x:Circle) : (base = x) -> Circle_code x := fun p => p # zero. (** TODO: explain this proof in more detail. *) (** Turning a code into a path based at [base]. We call this decoding. *) Definition Circle_decode (x : Circle) : Circle_code x -> (base = x). Proof. revert x; refine (Circle_ind (fun x => Circle_code x -> base = x) (loopexp loop) _). apply path_forall; intros z; simpl in z. refine (transport_arrow _ _ _ @ _). refine (transport_paths_r loop _ @ _). rewrite transport_Circle_code_loopV. rewrite loopexp_pred_r. apply concat_pV_p. Defined. (** The non-trivial part of the proof that decode and encode are equivalences is showing that decoding followed by encoding is the identity on the fibers over [base]. *) Definition Circle_encode_loopexp (z : Int) : Circle_encode base (loopexp loop z) = z. Proof. induction z as [|n | n]. - reflexivity. - rewrite loopexp_succ_r. unfold Circle_encode in IHz |- *. rewrite transport_pp. rewrite IHz. apply transport_Circle_code_loop. - rewrite loopexp_pred_r. unfold Circle_encode in IHz |- *. rewrite transport_pp. rewrite IHz. apply transport_Circle_code_loopV. Defined. (** Now we put it together. *) Definition Circle_encode_isequiv (x:Circle) : IsEquiv (Circle_encode x). Proof. refine (isequiv_adjointify (Circle_encode x) (Circle_decode x) _ _). (* Here we induct on [x:Circle]. We just did the case when [x] is [base]. *) - refine (Circle_ind (fun x => (Circle_encode x) o (Circle_decode x) == idmap) Circle_encode_loopexp _ _). (* What remains is easy since [Int] is known to be a set. *) by apply path_forall; intros z; apply hset_path2. (* The other side is trivial by path induction. *) - intros []; reflexivity. Defined. (** Finally giving us an equivalence between the loop space of the [Circle] and [Int]. *) Definition equiv_loopCircle_int : (base = base) <~> Int := Build_Equiv _ _ (Circle_encode base) (Circle_encode_isequiv base). End EncodeDecode. (** ** Connectedness and truncatedness of the [Circle] *) (** The circle is 0-connected. *) Global Instance isconnected_Circle `{Univalence} : IsConnected 0 Circle. Proof. apply is0connected_merely_allpath. 1: exact (tr base). srefine (Circle_ind _ _ _). - simple refine (Circle_ind _ _ _). + exact (tr 1). + apply path_ishprop. - apply path_ishprop. Defined. (** It follows that the circle is a 1-type. *) Global Instance istrunc_Circle `{Univalence} : IsTrunc 1 Circle. Proof. apply istrunc_S. intros x y. assert (p := merely_path_is0connected Circle base x). assert (q := merely_path_is0connected Circle base y). strip_truncations. destruct p, q. refine (istrunc_equiv_istrunc (n := 0) Int equiv_loopCircle_int^-1). Defined. (** ** Iteration of equivalences *) (** If [P : Circle -> Type] is defined by a type [X] and an autoequivalence [f], then the image of [n : Int] regarded as in [base = base] is [iter_int f n]. *) Definition Circle_action_is_iter `{Univalence} X (f : X <~> X) (n : Int) (x : X) : transport (Circle_rec Type X (path_universe f)) (equiv_loopCircle_int^-1 n) x = int_iter f n x. Proof. refine (_ @ loopexp_path_universe _ _ _). refine (transport_compose idmap _ _ _ @ _). refine (ap (fun p => transport idmap p x) _). unfold equiv_loopCircle_int; cbn. unfold Circle_decode; simpl. rewrite ap_loopexp. refine (ap (fun p => loopexp p n) _). apply Circle_rec_beta_loop. Defined. (** The universal property of the circle (Lemma 6.2.9 in the Book). We could deduce this from [isequiv_Coeq_rec], but it's nice to see a direct proof too. *) Definition Circle_rec_uncurried (P : Type) : {b : P & b = b} -> (Circle -> P) := fun x => Circle_rec P (pr1 x) (pr2 x). Global Instance isequiv_Circle_rec_uncurried `{Funext} (P : Type) : IsEquiv (Circle_rec_uncurried P). Proof. srapply isequiv_adjointify. - exact (fun g => (g base ; ap g loop)). - intros g. apply path_arrow. srapply Circle_ind. + reflexivity. + unfold Circle_rec_uncurried; cbn. apply transport_paths_FlFr'. apply equiv_p1_1q. apply Circle_rec_beta_loop. - intros [b p]; apply ap. apply Circle_rec_beta_loop. Defined. Definition equiv_Circle_rec `{Funext} (P : Type) : {b : P & b = b} <~> (Circle -> P) := Build_Equiv _ _ _ (isequiv_Circle_rec_uncurried P). (** A pointed version of the universal property of the circle. *) Definition pmap_from_circle_loops `{Funext} (X : pType) : (pCircle ->** X) <~>* loops X. Proof. snrapply Build_pEquiv'. - refine (_ oE (issig_pmap _ _)^-1%equiv). equiv_via { xp : { x : X & x = x } & xp.1 = pt }. 2: make_equiv_contr_basedpaths. exact ((equiv_functor_sigma_pb (equiv_Circle_rec X)^-1%equiv)). - simpl. apply ap_const. Defined. Coq-HoTT-9.0/theories/Spaces/Finite.v000066400000000000000000000002701474641544500174020ustar00rootroot00000000000000Require Export Finite.Fin. Require Export Finite.FinNat. Require Export Finite.FinInduction. Require Export Finite.Finite. Require Export Finite.FinSeq. Require Export Finite.Tactics. Coq-HoTT-9.0/theories/Spaces/Finite/000077500000000000000000000000001474641544500172145ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/Finite/Fin.v000066400000000000000000000337531474641544500201320ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import HSet. Require Import Spaces.Nat.Core. Require Import Equiv.PathSplit. (** By setting this, using [simple_induction] instead of [induction], and specifying universe variables in a couple of places, we can avoid all universe variables in this file. Several results are confirmed to use no universe variables with an @{} annotation. *) Local Set Universe Minimization ToSet. Local Open Scope path_scope. Local Open Scope nat_scope. (** * Finite sets *) (** ** Canonical finite sets *) (** A *finite set* is a type that is merely equivalent to the canonical finite set determined by some natural number. There are many equivalent ways to define the canonical finite sets, such as [{ k : nat & k < n}]; we instead choose a recursive one. *) Fixpoint Fin (n : nat) : Type0 := match n with | 0 => Empty | S n => Fin n + Unit end. Fixpoint fin_to_nat {n} : Fin n -> nat := match n with | 0 => Empty_rec | S n' => fun k => match k with | inl k' => fin_to_nat k' | inr tt => n' end end. Global Instance decidable_fin (n : nat) : Decidable (Fin n). Proof. destruct n as [|n]; try exact _. exact (inl (inr tt)). Defined. Global Instance decidablepaths_fin@{} (n : nat) : DecidablePaths (Fin n). Proof. simple_induction n n IHn; simpl; exact _. Defined. Global Instance contr_fin1 : Contr (Fin 1). Proof. refine (contr_equiv' Unit (sum_empty_l Unit)^-1). Defined. Definition fin_empty (n : nat) (f : Fin n -> Empty) : n = 0. Proof. destruct n; [ reflexivity | ]. elim (f (inr tt)). Defined. (** The zeroth element of a non-empty finite set is the left most element. It also happens to be the biggest by termsize. *) Fixpoint fin_zero {n : nat} : Fin n.+1 := match n with | O => inr tt | S _ => inl fin_zero end. (** Where `fin_zero` computes the first element of Fin (S n), `fin_last` computes the last. *) Definition fin_last {n : nat} : Fin (S n) := inr tt. (** Injection Fin n -> Fin n.+1 mapping the kth element to the kth element. *) Definition fin_incl {n : nat} (k : Fin n) : Fin (S n) := inl k. (** There is an injection from Fin n -> Fin n.+1 that maps the kth element to the (k+1)th element. *) Fixpoint fsucc {n : nat} : Fin n -> Fin n.+1 := match n with | O => Empty_rec | S n' => fun i : Fin (S n') => match i with | inl i' => inl (fsucc i') | inr tt => inr tt end end. (** This injection is an injection/embedding *) Lemma isembedding_fsucc@{} {n : nat} : IsEmbedding (@fsucc n). Proof. apply isembedding_isinj_hset. simple_induction n n IHn. - intro i. elim i. - intros [] []; intro p. + f_ap. apply IHn. eapply path_sum_inl. exact p. + destruct u. elim (inl_ne_inr _ _ p). + destruct u. elim (inr_ne_inl _ _ p). + destruct u, u0; reflexivity. Defined. Lemma path_fin_fsucc_incl {n : nat} : forall k : Fin n, fsucc (fin_incl k) = fin_incl (fsucc k). Proof. trivial. Defined. Definition path_nat_fin_incl {n : nat} (k : Fin n) : fin_to_nat (fin_incl k) = fin_to_nat k := 1. Lemma path_nat_fsucc@{} {n : nat} : forall k : Fin n, fin_to_nat (fsucc k) = S (fin_to_nat k). Proof. simple_induction n n IHn. - intros []. - intros [k'|[]]. + rewrite path_fin_fsucc_incl, path_nat_fin_incl. apply IHn. + reflexivity. Defined. Lemma path_nat_fin_zero@{} {n} : fin_to_nat (@fin_zero n) = 0. Proof. simple_induction n n IHn. - reflexivity. - trivial. Defined. Definition path_nat_fin_last {n} : fin_to_nat (@fin_last n) = n := 1. (** ** Transposition equivalences *) (** To prove some basic facts about canonical finite sets, we need some standard automorphisms of them. Here we define some transpositions and prove that they in fact do the desired things. *) (** *** Swap the last two elements. *) Definition fin_transpose_last_two (n : nat) : Fin n.+2 <~> Fin n.+2 := ((equiv_sum_assoc _ _ _)^-1) oE (1 +E (equiv_sum_symm _ _)) oE (equiv_sum_assoc _ _ _). Arguments fin_transpose_last_two : simpl nomatch. Definition fin_transpose_last_two_last (n : nat) : fin_transpose_last_two n (inr tt) = (inl (inr tt)) := 1. Definition fin_transpose_last_two_nextlast (n : nat) : fin_transpose_last_two n (inl (inr tt)) = (inr tt) := 1. Definition fin_transpose_last_two_rest (n : nat) (k : Fin n) : fin_transpose_last_two n (inl (inl k)) = (inl (inl k)) := 1. (** *** Swap the last element with [k]. *) Fixpoint fin_transpose_last_with (n : nat) (k : Fin n.+1) : Fin n.+1 <~> Fin n.+1. Proof. destruct k as [k|]. - destruct n as [|n]. + elim k. + destruct k as [k|]. * refine ((fin_transpose_last_two n) oE _ oE (fin_transpose_last_two n)). refine ((fin_transpose_last_with n (inl k)) +E 1). * apply fin_transpose_last_two. - exact (equiv_idmap _). Defined. Arguments fin_transpose_last_with : simpl nomatch. Definition fin_transpose_last_with_last@{} (n : nat) (k : Fin n.+1) : fin_transpose_last_with n k (inr tt) = k. Proof. destruct k as [k|]. - simple_induction n n IHn; intro k; simpl. + elim k. + destruct k as [k|]. * simpl. rewrite IHn; reflexivity. * simpl. apply ap, ap, path_contr. - (** We have to destruct [n] since fixpoints don't reduce unless their argument is a constructor. *) destruct n; simpl. all:apply ap, path_contr. Qed. Definition fin_transpose_last_with_with@{} (n : nat) (k : Fin n.+1) : fin_transpose_last_with n k k = inr tt. Proof. destruct k as [k|]. - simple_induction n n IHn; intro k; simpl. + elim k. + destruct k as [|k]; simpl. * rewrite IHn; reflexivity. * apply ap, path_contr. - destruct n; simpl. all:apply ap, path_contr. Qed. Definition fin_transpose_last_with_rest@{} (n : nat) (k : Fin n.+1) (l : Fin n) (notk : k <> inl l) : fin_transpose_last_with n k (inl l) = (inl l). Proof. destruct k as [k|]. - simple_induction n n IHn; intros k l notk; simpl. 1: elim k. destruct k as [k|]; simpl. { destruct l as [l|]; simpl. - rewrite IHn. + reflexivity. + exact (fun p => notk (ap inl p)). - reflexivity. } { destruct l as [l|]; simpl. - reflexivity. - elim (notk (ap inl (ap inr (path_unit _ _)))). } - destruct n; reflexivity. Defined. Definition fin_transpose_last_with_last_other (n : nat) (k : Fin n.+1) : fin_transpose_last_with n (inr tt) k = k. Proof. destruct n; reflexivity. Defined. Definition fin_transpose_last_with_invol (n : nat) (k : Fin n.+1) : fin_transpose_last_with n k o fin_transpose_last_with n k == idmap. Proof. intros l. destruct l as [l|[]]. - destruct k as [k|[]]. { destruct (dec_paths k l) as [p|p]. - rewrite p. rewrite fin_transpose_last_with_with. apply fin_transpose_last_with_last. - rewrite fin_transpose_last_with_rest; try apply fin_transpose_last_with_rest; exact (fun q => p (path_sum_inl _ q)). } + rewrite fin_transpose_last_with_last_other. apply fin_transpose_last_with_last_other. - rewrite fin_transpose_last_with_last. apply fin_transpose_last_with_with. Defined. (** ** Equivalences between canonical finite sets *) (** To give an equivalence [Fin n.+1 <~> Fin m.+1] is equivalent to giving an element of [Fin m.+1] (the image of the last element) together with an equivalence [Fin n <~> Fin m]. More specifically, any such equivalence can be decomposed uniquely as a last-element transposition followed by an equivalence fixing the last element. *) (** Here is the uncurried map that constructs an equivalence [Fin n.+1 <~> Fin m.+1]. *) Definition fin_equiv (n m : nat) (k : Fin m.+1) (e : Fin n <~> Fin m) : Fin n.+1 <~> Fin m.+1 := (fin_transpose_last_with m k) oE (e +E 1). (** Here is the curried version that we will prove to be an equivalence. *) Definition fin_equiv' (n m : nat) : ((Fin m.+1) * (Fin n <~> Fin m)) -> (Fin n.+1 <~> Fin m.+1) := fun ke => fin_equiv n m (fst ke) (snd ke). (** We construct its inverse and the two homotopies first as versions using homotopies without funext (similar to [ExtendableAlong]), then apply funext at the end. *) Definition fin_equiv_hfiber@{} (n m : nat) (e : Fin n.+1 <~> Fin m.+1) : { kf : (Fin m.+1) * (Fin n <~> Fin m) & fin_equiv' n m kf == e }. Proof. simpl in e. refine (equiv_sigma_prod _ _). recall (e (inr tt)) as y eqn:p. assert (p' := (moveL_equiv_V _ _ p)^). exists y. destruct y as [y|[]]. + simple refine (equiv_unfunctor_sum_l@{Set Set Set Set Set Set} (fin_transpose_last_with m (inl y) oE e) _ _ ; _). { intros a. ev_equiv. assert (q : inl y <> e (inl a)) by exact (fun z => inl_ne_inr _ _ (equiv_inj e (z^ @ p^))). set (z := e (inl a)) in *. destruct z as [z|[]]. - rewrite fin_transpose_last_with_rest; try exact tt; try assumption. - rewrite fin_transpose_last_with_last; exact tt. } { intros []. ev_equiv. rewrite p. rewrite fin_transpose_last_with_with; exact tt. } intros x. unfold fst, snd; ev_equiv. simpl. destruct x as [x|[]]; simpl. * rewrite unfunctor_sum_l_beta. apply fin_transpose_last_with_invol. * refine (fin_transpose_last_with_last _ _ @ p^). + simple refine (equiv_unfunctor_sum_l@{Set Set Set Set Set Set} e _ _ ; _). { intros a. destruct (is_inl_or_is_inr (e (inl a))) as [l|r]. - exact l. - assert (q := inr_un_inr (e (inl a)) r). apply moveR_equiv_V in q. assert (s := q^ @ ap (e^-1 o inr) (path_unit _ _) @ p'). elim (inl_ne_inr _ _ s). } { intros []; exact (p^ # tt). } intros x. unfold fst, snd; ev_equiv. simpl. destruct x as [a|[]]. * rewrite fin_transpose_last_with_last_other. apply unfunctor_sum_l_beta. * simpl. rewrite fin_transpose_last_with_last. symmetry; apply p. Qed. Definition fin_equiv_inv (n m : nat) (e : Fin n.+1 <~> Fin m.+1) : (Fin m.+1) * (Fin n <~> Fin m) := (fin_equiv_hfiber n m e).1. Definition fin_equiv_issect (n m : nat) (e : Fin n.+1 <~> Fin m.+1) : fin_equiv' n m (fin_equiv_inv n m e) == e := (fin_equiv_hfiber n m e).2. Definition fin_equiv_inj_fst (n m : nat) (k l : Fin m.+1) (e f : Fin n <~> Fin m) : (fin_equiv n m k e == fin_equiv n m l f) -> (k = l). Proof. intros p. refine (_ @ p (inr tt) @ _); simpl; rewrite fin_transpose_last_with_last; reflexivity. Qed. Definition fin_equiv_inj_snd (n m : nat) (k l : Fin m.+1) (e f : Fin n <~> Fin m) : (fin_equiv n m k e == fin_equiv n m l f) -> (e == f). Proof. intros p. intros x. assert (q := p (inr tt)); simpl in q. rewrite !fin_transpose_last_with_last in q. rewrite <- q in p; clear q l. exact (path_sum_inl _ (equiv_inj (fin_transpose_last_with m k) (p (inl x)))). Qed. (** Now it's time for funext. *) Global Instance isequiv_fin_equiv `{Funext} (n m : nat) : IsEquiv (fin_equiv' n m). Proof. refine (isequiv_pathsplit 0 _); split. - intros e; exists (fin_equiv_inv n m e). apply path_equiv, path_arrow, fin_equiv_issect. - intros [k e] [l f]; simpl. refine (_ , fun _ _ => tt). intros p; refine (_ ; path_ishprop _ _). apply (ap equiv_fun) in p. apply ap10 in p. apply path_prod'. + refine (fin_equiv_inj_fst n m k l e f p). + apply path_equiv, path_arrow. refine (fin_equiv_inj_snd n m k l e f p). Defined. Definition equiv_fin_equiv `{Funext} (n m : nat) : ((Fin m.+1) * (Fin n <~> Fin m)) <~> (Fin n.+1 <~> Fin m.+1) := Build_Equiv _ _ (fin_equiv' n m) _. (** In particular, this implies that if two canonical finite sets are equivalent, then their cardinalities are equal. *) Definition nat_eq_fin_equiv (n m : nat) : (Fin n <~> Fin m) -> (n = m). Proof. revert m; simple_induction n n IHn; intro m; simple_induction m m IHm; intros e. - exact idpath. - elim (e^-1 (inr tt)). - elim (e (inr tt)). - refine (ap S (IHn m _)). exact (snd (fin_equiv_inv n m e)). Defined. (** ** Initial segments of [nat] *) Definition nat_fin (n : nat) (k : Fin n) : nat. Proof. simple_induction n n nf; intro k. - contradiction. - destruct k as [k|_]. + exact (nf k). + exact n. Defined. Definition nat_fin_inl (n : nat) (k : Fin n) : nat_fin n.+1 (inl k) = nat_fin n k := 1. Definition nat_fin_compl (n : nat) (k : Fin n) : nat. Proof. simple_induction n n nfc; intro k. - contradiction. - destruct k as [k|_]. + exact (nfc k).+1. + exact 0. Defined. Definition nat_fin_compl_compl n k : (nat_fin n k + nat_fin_compl n k).+1 = n. Proof. simple_induction n n IHn; intro k. - contradiction. - destruct k as [k|?]; simpl. + rewrite nat_add_comm. specialize (IHn k). rewrite nat_add_comm in IHn. exact (ap S IHn). + rewrite nat_add_comm; reflexivity. Qed. (** [fsucc_mod] is the successor function mod n *) Definition fsucc_mod@{} {n : nat} : Fin n -> Fin n. Proof. destruct n. 1: exact idmap. intros [x|]. - exact (fsucc x). - exact fin_zero. Defined. (** fsucc allows us to convert a natural number into an element of a finite set. This can be thought of as the modulo map. *) Fixpoint fin_nat {n : nat} (m : nat) : Fin n.+1 := match m with | 0 => fin_zero | S m => fsucc_mod (fin_nat m) end. (** The 1-dimensional version of Sperner's lemma says that given any finite sequence of decidable hProps, where the sequence starts with true and ends with false, we can find a point in the sequence where the sequence changes from true to false. This is like a discrete intermediate value theorem. *) Fixpoint sperners_lemma_1d {n} : forall (f : Fin (n.+2) -> Type) {dprop : forall i, Decidable (f i)} (left_true : f fin_zero) (right_false : ~ f fin_last), {k : Fin n.+1 & f (fin_incl k) /\ ~ f (fsucc k)}. Proof. intros ???. destruct n as [|n]. - exists fin_zero. split; assumption. - destruct (dec (f (fin_incl fin_last))) as [prev_true|prev_false]. + exists fin_last. split; assumption. + destruct (sperners_lemma_1d _ (f o fin_incl) _ left_true prev_false) as [k' [fleft fright]]. exists (fin_incl k'). split; assumption. Defined. Coq-HoTT-9.0/theories/Spaces/Finite/FinInduction.v000066400000000000000000000045531474641544500220030ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types HoTT.Universes.HSet HoTT.Spaces.Nat.Core HoTT.Spaces.Finite.FinNat HoTT.Spaces.Finite.Fin. Local Open Scope nat_scope. Definition fin_ind (P : forall n : nat, Fin n -> Type) (z : forall n : nat, P n.+1 fin_zero) (s : forall (n : nat) (k : Fin n), P n k -> P n.+1 (fsucc k)) {n : nat} (k : Fin n) : P n k. Proof. refine (transport (P n) (path_fin_to_finnat_to_fin k) _). refine (finnat_ind (fun n u => P n (finnat_to_fin u)) _ _ _). - intro. apply z. - intros n' u c. refine ((path_finnat_to_fin_succ _)^ # _). by apply s. Defined. Lemma fin_ind_beta_zero (P : forall n : nat, Fin n -> Type) (z : forall n : nat, P n.+1 fin_zero) (s : forall (n : nat) (k : Fin n), P n k -> P n.+1 (fsucc k)) (n : nat) : fin_ind P z s fin_zero = z n. Proof. unfold fin_ind. generalize (path_fin_to_finnat_to_fin (@fin_zero n)). induction (path_fin_to_finnat_fin_zero n)^. intro p. destruct (hset_path2 1 p). lhs nrapply transport_1. nrapply finnat_ind_beta_zero. Defined. Lemma fin_ind_beta_fsucc (P : forall n : nat, Fin n -> Type) (z : forall n : nat, P n.+1 fin_zero) (s : forall (n : nat) (k : Fin n), P n k -> P n.+1 (fsucc k)) {n : nat} (k : Fin n) : fin_ind P z s (fsucc k) = s n k (fin_ind P z s k). Proof. unfold fin_ind. generalize (path_fin_to_finnat_to_fin (fsucc k)). induction (path_fin_to_finnat_fsucc k)^. intro p. refine (ap (transport (P n.+1) p) (finnat_ind_beta_succ _ _ _ _) @ _). generalize dependent p. induction (path_fin_to_finnat_to_fin k). induction (path_fin_to_finnat_to_fin k)^. intro p. induction (hset_path2 p (path_finnat_to_fin_succ (fin_to_finnat k))). apply transport_pV. Defined. Definition fin_rec (B : nat -> Type) : (forall n : nat, B n.+1) -> (forall (n : nat), Fin n -> B n -> B n.+1) -> forall {n : nat}, Fin n -> B n := fin_ind (fun n _ => B n). Lemma fin_rec_beta_zero (B : nat -> Type) (z : forall n : nat, B n.+1) (s : forall (n : nat) (k : Fin n), B n -> B n.+1) (n : nat) : fin_rec B z s fin_zero = z n. Proof. apply (fin_ind_beta_zero (fun n _ => B n)). Defined. Lemma fin_rec_beta_fsucc (B : nat -> Type) (z : forall n : nat, B n.+1) (s : forall (n : nat) (k : Fin n), B n -> B n.+1) {n : nat} (k : Fin n) : fin_rec B z s (fsucc k) = s n k (fin_rec B z s k). Proof. apply (fin_ind_beta_fsucc (fun n _ => B n)). Defined. Coq-HoTT-9.0/theories/Spaces/Finite/FinNat.v000066400000000000000000000114441474641544500205660ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.Trunc Basics.PathGroupoids Basics.Equivalences Basics.Decidable Basics.Classes. Require Import Types.Empty Types.Sigma Types.Sum Types.Prod Types.Equiv. Require Import Spaces.Nat.Core. Require Import Finite.Fin. Local Open Scope nat_scope. Set Universe Minimization ToSet. Definition FinNat@{} (n : nat) : Type0 := {x : nat | x < n}. Definition zero_finnat@{} (n : nat) : FinNat n.+1 := (0; _ : 0 < n.+1). Definition succ_finnat@{} {n : nat} (u : FinNat n) : FinNat n.+1 := (u.1.+1; leq_succ u.2). Definition path_succ_finnat {n : nat} (x : nat) (h : x.+1 < n.+1) : succ_finnat (x; leq_pred' h) = (x.+1; h). Proof. by apply path_sigma_hprop. Defined. Definition last_finnat@{} (n : nat) : FinNat n.+1 := exist (fun x => x < n.+1) n (leq_refl n.+1). Definition incl_finnat@{} {n : nat} (u : FinNat n) : FinNat n.+1 := (u.1; leq_trans u.2 (leq_succ_r (leq_refl n))). Definition finnat_ind@{u} (P : forall n : nat, FinNat n -> Type@{u}) (z : forall n : nat, P n.+1 (zero_finnat n)) (s : forall (n : nat) (u : FinNat n), P n u -> P n.+1 (succ_finnat u)) {n : nat} (u : FinNat n) : P n u. Proof. simple_induction n n IHn; intro u. - elim (not_lt_zero_r u.1 u.2). - destruct u as [x h]. destruct x as [| x]. + nrefine (transport (P n.+1) _ (z _)). by apply path_sigma_hprop. + refine (transport (P n.+1) (path_succ_finnat _ _) _). apply s. apply IHn. Defined. Definition finnat_ind_beta_zero@{u} (P : forall n : nat, FinNat n -> Type@{u}) (z : forall n : nat, P n.+1 (zero_finnat n)) (s : forall (n : nat) (u : FinNat n), P n u -> P n.+1 (succ_finnat u)) (n : nat) : finnat_ind P z s (zero_finnat n) = z n. Proof. snrapply (transport2 _ (q:=idpath@{Set})). rapply path_ishprop. Defined. Definition finnat_ind_beta_succ@{u} (P : forall n : nat, FinNat n -> Type@{u}) (z : forall n : nat, P n.+1 (zero_finnat n)) (s : forall (n : nat) (u : FinNat n), P n u -> P n.+1 (succ_finnat u)) {n : nat} (u : FinNat n) : finnat_ind P z s (succ_finnat u) = s n u (finnat_ind P z s u). Proof. destruct u as [u1 u2]; simpl; unfold path_succ_finnat. destruct (path_ishprop u2 (leq_pred' (leq_succ u2))). refine (transport2 _ (q:=idpath@{Set}) _ _). rapply path_ishprop. Defined. Definition is_bounded_fin_to_nat@{} {n} (k : Fin n) : fin_to_nat k < n. Proof. induction n as [| n IHn]. - elim k. - destruct k as [k | []]; exact _. Defined. Definition fin_to_finnat {n} (k : Fin n) : FinNat n := (fin_to_nat k; is_bounded_fin_to_nat k). Fixpoint finnat_to_fin@{} {n : nat} : FinNat n -> Fin n := match n with | 0 => fun u => Empty_rec (not_lt_zero_r _ u.2) | n.+1 => fun u => match u with | (0; _) => fin_zero | (x.+1; h) => fsucc (finnat_to_fin (x; leq_pred' h)) end end. Definition path_fin_to_finnat_fsucc@{} {n : nat} (k : Fin n) : fin_to_finnat (fsucc k) = succ_finnat (fin_to_finnat k). Proof. apply path_sigma_hprop. apply path_nat_fsucc. Defined. Definition path_fin_to_finnat_fin_zero@{} (n : nat) : fin_to_finnat (@fin_zero n) = zero_finnat n. Proof. apply path_sigma_hprop. apply path_nat_fin_zero. Defined. Definition path_finnat_to_fin_succ@{} {n : nat} (u : FinNat n) : finnat_to_fin (succ_finnat u) = fsucc (finnat_to_fin u). Proof. cbn. do 2 f_ap. by apply path_sigma_hprop. Defined. Definition path_finnat_to_fin_incl@{} {n : nat} (u : FinNat n) : finnat_to_fin (incl_finnat u) = fin_incl (finnat_to_fin u). Proof. revert n u. snrapply finnat_ind. 1: reflexivity. intros n u; cbn beta; intros p. lhs nrapply (path_finnat_to_fin_succ (incl_finnat u)). lhs nrapply (ap fsucc p). exact (ap fin_incl (path_finnat_to_fin_succ _))^. Defined. Definition path_finnat_to_fin_last@{} (n : nat) : finnat_to_fin (last_finnat n) = fin_last. Proof. induction n as [| n IHn]. - reflexivity. - exact (ap fsucc IHn). Defined. Definition path_finnat_to_fin_to_finnat@{} {n : nat} (u : FinNat n) : fin_to_finnat (finnat_to_fin u) = u. Proof. induction n as [| n IHn]. - elim (not_lt_zero_r _ u.2). - destruct u as [x h]. apply path_sigma_hprop. destruct x as [| x]. + exact (ap pr1 (path_fin_to_finnat_fin_zero n)). + refine ((path_fin_to_finnat_fsucc _)..1 @ _). exact (ap S (IHn (x; leq_pred' h))..1). Defined. Definition path_fin_to_finnat_to_fin@{} {n : nat} (k : Fin n) : finnat_to_fin (fin_to_finnat k) = k. Proof. induction n as [| n IHn]. - elim k. - destruct k as [k | []]. + specialize (IHn k). refine (path_finnat_to_fin_incl (fin_to_finnat k) @ _). exact (ap fin_incl IHn). + apply path_finnat_to_fin_last. Defined. Definition equiv_fin_finnat@{} (n : nat) : Fin n <~> FinNat n := equiv_adjointify fin_to_finnat finnat_to_fin path_finnat_to_fin_to_finnat path_fin_to_finnat_to_fin. Coq-HoTT-9.0/theories/Spaces/Finite/FinSeq.v000066400000000000000000000157201474641544500205750ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types HoTT.Universes.HSet HoTT.Spaces.Finite.Fin HoTT.Spaces.Finite.FinInduction HoTT.Spaces.Nat.Core. Local Open Scope nat_scope. (** Finite-dimensional sequence. It is often referred to as vector, but we call it finite sequence [FinSeq] to avoid confusion with vector from linear algebra. Note that the induction principle [finseq_]*) Definition FinSeq@{u} (n : nat) (A : Type@{u}) : Type@{u} := Fin n -> A. (** The empty finite sequence. *) Definition fsnil {A : Type} : FinSeq 0 A := Empty_rec. Definition path_fsnil `{Funext} {A : Type} (v : FinSeq 0 A) : fsnil = v. Proof. apply path_contr. Defined. (** Add an element in the end of a finite sequence, [fscons'] and [fscons]. *) Definition fscons' {A : Type} (n : nat) (a : A) (v : FinSeq (nat_pred n) A) : FinSeq n A := fun i => fin_rec (fun n => FinSeq (nat_pred n) A -> A) (fun _ _ => a) (fun n' i _ v => v i) i v. Definition fscons {A : Type} {n : nat} : A -> FinSeq n A -> FinSeq n.+1 A := fscons' n.+1. (** Take the first element of a non-empty finite sequence, [fshead'] and [fshead]. *) Definition fshead' {A} (n : nat) : 0 < n -> FinSeq n A -> A := match n with | 0 => fun N _ => Empty_rec (not_lt_zero_r _ N) | n'.+1 => fun _ v => v fin_zero end. Definition fshead {A} {n : nat} : FinSeq n.+1 A -> A := fshead' n.+1 _. Definition fshead'_beta_fscons' {A} n (N : n > 0) (a : A) (v : FinSeq (nat_pred n) A) : fshead' n N (fscons' n a v) = a. Proof. destruct n; [elim (lt_irrefl _ N)|]. exact (apD10 (fin_rec_beta_zero _ _ _ _) v). Defined. Definition fshead_beta_fscons {A} {n} (a : A) (v : FinSeq n A) : fshead (fscons a v) = a. Proof. apply fshead'_beta_fscons'. Defined. (** If the sequence is non-empty, then remove the first element. *) Definition fstail' {A} (n : nat) : FinSeq n A -> FinSeq (nat_pred n) A := match n with | 0 => fun _ => Empty_rec | n'.+1 => fun v i => v (fsucc i) end. (** Remove the first element from a non-empty sequence. *) Definition fstail {A} {n : nat} : FinSeq n.+1 A -> FinSeq n A := fstail' n.+1. Definition fstail'_beta_fscons' {A} n (a : A) (v : FinSeq (nat_pred n) A) : fstail' n (fscons' n a v) == v. Proof. intro i. destruct n; [elim i|]. exact (apD10 (fin_rec_beta_fsucc _ _ _ _) v). Defined. Definition fstail_beta_fscons `{Funext} {A} {n} (a : A) (v : FinSeq n A) : fstail (fscons a v) = v. Proof. funext i. apply fstail'_beta_fscons'. Defined. (** A non-empty finite sequence is equal to [fscons] of head and tail, [path_expand_fscons'] and [path_expand_fscons]. *) Lemma path_expand_fscons' {A : Type} (n : nat) (i : Fin n) (N : n > 0) (v : FinSeq n A) : fscons' n (fshead' n N v) (fstail' n v) i = v i. Proof. induction i using fin_ind. - apply fshead_beta_fscons. - apply (fstail'_beta_fscons' n.+1 (fshead v) (fstail v)). Defined. Lemma path_expand_fscons `{Funext} {A} {n} (v : FinSeq n.+1 A) : fscons (fshead v) (fstail v) = v. Proof. funext i. apply path_expand_fscons'. Defined. (** The following [path_fscons'] and [path_fscons] gives a way to construct a path between [fscons] finite sequences. They cooperate nicely with [path_expand_fscons'] and [path_expand_fscons]. *) Definition path_fscons' {A} n {a1 a2 : A} {v1 v2 : FinSeq (nat_pred n) A} (p : a1 = a2) (q : forall i, v1 i = v2 i) (i : Fin n) : fscons' n a1 v1 i = fscons' n a2 v2 i. Proof. induction i using fin_ind. - exact (fshead_beta_fscons _ _ @ p @ (fshead_beta_fscons _ _)^). - refine (_ @ (fstail'_beta_fscons' n.+1 a2 v2 i)^). exact (fstail'_beta_fscons' n.+1 a1 v1 i @ q i). Defined. Definition path_fscons'_beta {A} (n : nat) (a : A) (v : FinSeq (nat_pred n) A) (i : Fin n) : path_fscons' n (idpath a) (fun j => idpath (v j)) i = idpath. Proof. induction i using fin_ind; unfold path_fscons'. - rewrite fin_ind_beta_zero. refine (ap (fun p => p @ _) (concat_p1 _) @ _). apply concat_pV. - rewrite fin_ind_beta_fsucc. refine (ap (fun p => p @ _) (concat_p1 _) @ _). apply concat_pV. Qed. Definition path_fscons `{Funext} {A} {n} {a1 a2 : A} (p : a1 = a2) {v1 v2 : FinSeq n A} (q : v1 = v2) : fscons a1 v1 = fscons a2 v2. Proof. funext i. apply path_fscons'. - assumption. - intro j. exact (apD10 q j). Defined. Lemma path_fscons_beta `{Funext} {A} {n} (a : A) (v : FinSeq n A) : path_fscons (idpath a) (idpath v) = idpath. Proof. refine (ap (path_forall _ _) _ @ eta_path_forall _ _ _). funext i. exact (path_fscons'_beta n.+1 a v i). Defined. (** The lemmas [path_expand_fscons_fscons'] and [path_expand_fscons_fscons] identify [path_expand_fscons'] with [path_fscons'] and [path_expand_fscons] with [path_fscons]. *) Lemma path_expand_fscons_fscons' {A : Type} (n : nat) (N : n > 0) (a : A) (v : FinSeq (nat_pred n) A) (i : Fin n) : path_expand_fscons' n i N (fscons' n a v) = path_fscons' n (fshead'_beta_fscons' n N a v) (fstail'_beta_fscons' n a v) i. Proof. induction i using fin_ind; unfold path_fscons', path_expand_fscons'. - do 2 rewrite fin_ind_beta_zero. refine (_ @ concat_p_pp _ _ _). refine (_ @ (ap (fun p => _ @ p) (concat_pV _))^). exact (concat_p1 _)^. - do 2 rewrite fin_ind_beta_fsucc. refine (_ @ concat_p_pp _ _ _). refine (_ @ (ap (fun p => _ @ p) (concat_pV _))^). exact (concat_p1 _)^. Qed. Lemma path_expand_fscons_fscons `{Funext} {A : Type} {n : nat} (a : A) (v : FinSeq n A) : path_expand_fscons (fscons a v) = path_fscons (fshead_beta_fscons a v) (fstail_beta_fscons a v). Proof. refine (ap (path_forall _ _) _). funext i. pose (p := eisretr apD10 (fstail'_beta_fscons' n.+1 a v)). refine (_ @ (ap (fun f => _ f i) p)^). exact (path_expand_fscons_fscons' n.+1 _ a v i). Defined. (** The induction principle for finite sequence, [finseq_ind]. Note that it uses funext and does not compute. *) Lemma finseq_ind `{Funext} {A : Type} (P : forall n, FinSeq n A -> Type) (z : P 0 fsnil) (s : forall n a (v : FinSeq n A), P n v -> P n.+1 (fscons a v)) {n : nat} (v : FinSeq n A) : P n v. Proof. induction n. - exact (transport (P 0) (path_fsnil v) z). - refine (transport (P n.+1) (path_expand_fscons v) _). apply s. apply IHn. Defined. Lemma finseq_ind_beta_fsnil `{Funext} {A : Type} (P : forall n, FinSeq n A -> Type) (z : P 0 fsnil) (s : forall (n : nat) (a : A) (v : FinSeq n A), P n v -> P n.+1 (fscons a v)) : finseq_ind P z s fsnil = z. Proof. exact (ap (fun x => _ x z) (hset_path2 1 (path_fsnil fsnil)))^. Defined. Lemma finseq_ind_beta_fscons `{Funext} {A : Type} (P : forall n, FinSeq n A -> Type) (z : P 0 fsnil) (s : forall (n : nat) (a : A) (v : FinSeq n A), P n v -> P n.+1 (fscons a v)) {n : nat} (a : A) (v : FinSeq n A) : finseq_ind P z s (fscons a v) = s n a v (finseq_ind P z s v). Proof. simpl. induction (path_expand_fscons_fscons a v)^. set (p1 := fshead_beta_fscons a v). set (p2 := fstail_beta_fscons a v). induction p1, p2. exact (ap (fun p => transport _ p _) (path_fscons_beta _ _)). Defined. Coq-HoTT-9.0/theories/Spaces/Finite/Finite.v000066400000000000000000000647451474641544500206410ustar00rootroot00000000000000Require Import Basics. Require Import Types. Require Import HSet. Require Import Spaces.Nat.Core Spaces.Nat.Factorial. Require Import HFiber. Require Import Factorization. Require Import Truncations. Require Import Colimits.Quotient. Require Import Projective. Require Import Fin. Local Open Scope path_scope. Local Open Scope nat_scope. (** ** Definition of general finite sets *) Class Finite (X : Type) := { fcard : nat ; merely_equiv_fin : merely (X <~> Fin fcard) }. Arguments fcard X {_}. Arguments merely_equiv_fin X {_}. Definition issig_finite X : { n : nat & merely (X <~> Fin n) } <~> Finite X. Proof. issig. Defined. (** Note that the sigma over cardinalities is not truncated. Nevertheless, because canonical finite sets of different cardinalities are not isomorphic, being finite is still an hprop. (Thus, we could have truncated the sigma and gotten an equivalent definition, but it would be less convenient to reason about.) *) Global Instance ishprop_finite X : IsHProp (Finite X). Proof. refine (istrunc_equiv_istrunc _ (issig_finite X)). apply ishprop_sigma_disjoint; intros n m Hn Hm. strip_truncations. refine (nat_eq_fin_equiv n m (Hm oE Hn^-1)). Defined. (** ** Preservation of finiteness by equivalences *) Definition finite_equiv X {Y} (e : X -> Y) `{IsEquiv X Y e} : Finite X -> Finite Y. Proof. intros ?. refine (Build_Finite Y (fcard X) _). assert (f := merely_equiv_fin X); strip_truncations. apply tr. exact (equiv_compose f e^-1). Defined. Definition finite_equiv' X {Y} (e : X <~> Y) : Finite X -> Finite Y := finite_equiv X e. Corollary finite_equiv_equiv X Y : (X <~> Y) -> (Finite X <~> Finite Y). Proof. intros ?; apply equiv_iff_hprop; apply finite_equiv'; [ assumption | symmetry; assumption ]. Defined. Definition fcard_equiv {X Y} (e : X -> Y) `{IsEquiv X Y e} `{Finite X} `{Finite Y} : fcard X = fcard Y. Proof. transitivity (@fcard Y (finite_equiv X e _)). - reflexivity. - exact (ap (@fcard Y) (path_ishprop _ _)). Defined. Definition fcard_equiv' {X Y} (e : X <~> Y) `{Finite X} `{Finite Y} : fcard X = fcard Y := fcard_equiv e. (** ** Simple examples of finite sets *) (** Canonical finite sets are finite *) Global Instance finite_fin n : Finite (Fin n) := Build_Finite _ n (tr (equiv_idmap _)). (** This includes the empty set. *) Global Instance finite_empty : Finite Empty := finite_fin 0. (** The unit type is finite, since it's equivalent to [Fin 1]. *) Global Instance finite_unit : Finite Unit. Proof. refine (finite_equiv' (Fin 1) _ _); simpl. apply sum_empty_l. Defined. (** Thus, any contractible type is finite. *) Global Instance finite_contr X `{Contr X} : Finite X := finite_equiv Unit equiv_contr_unit^-1 _. (** Any decidable hprop is finite, since it must be equivalent to [Empty] or [Unit]. *) Definition finite_decidable_hprop X `{IsHProp X} `{Decidable X} : Finite X. Proof. destruct (dec X) as [x|nx]. - assert (Contr X) by exact (contr_inhabited_hprop X x). exact _. - refine (finite_equiv Empty nx^-1 _). Defined. #[export] Hint Immediate finite_decidable_hprop : typeclass_instances. (** It follows that the propositional truncation of any finite set is finite. *) Global Instance finite_merely X {fX : Finite X} : Finite (merely X). Proof. (** As in decidable_finite_hprop, we case on cardinality first to avoid needing funext. *) destruct fX as [[|n] e]; refine (finite_decidable_hprop _). - right. intros x; strip_truncations; exact (e x). - left. strip_truncations; exact (tr (e^-1 (inr tt))). Defined. (** Finite sets are closed under path-spaces. *) Global Instance finite_paths {X} `{Finite X} (x y : X) : Finite (x = y). Proof. (** If we assume [Funext], then typeclass inference produces this automatically, since [X] has decidable equality and (hence) is a set, so [x=y] is a decidable hprop. But we can also deduce it without funext, since [Finite] is an hprop even without funext. *) assert (e := merely_equiv_fin X). strip_truncations. refine (finite_equiv _ (ap e)^-1 _). apply finite_decidable_hprop; exact _. Defined. (** Finite sets are also closed under successors. *) Global Instance finite_succ X `{Finite X} : Finite (X + Unit). Proof. refine (Build_Finite _ (fcard X).+1 _). pose proof (merely_equiv_fin X). strip_truncations; apply tr. refine (_ +E 1); assumption. Defined. Definition fcard_succ X `{Finite X} : fcard (X + Unit) = (fcard X).+1 := 1. (** ** Decidability *) (** Like canonical finite sets, finite sets have decidable equality. *) Global Instance decidablepaths_finite `{Funext} X `{Finite X} : DecidablePaths X. Proof. assert (e := merely_equiv_fin X). strip_truncations. refine (decidablepaths_equiv _ e^-1 _). Defined. (** However, contrary to what you might expect, we cannot assert that "every finite set is decidable"! That would be claiming a *uniform* way to select an element from every nonempty finite set, which contradicts univalence. *) (** One thing we can prove is that any finite hprop is decidable. *) Global Instance decidable_finite_hprop X `{IsHProp X} {fX : Finite X} : Decidable X. Proof. (** To avoid having to use [Funext], we case on the cardinality of [X] before stripping the truncation from its equivalence to [Fin n]; if we did things in the other order then we'd have to know that [Decidable X] is an hprop, which requires funext. *) destruct fX as [[|n] e]. - right; intros x. strip_truncations; exact (e x). - left. strip_truncations; exact (e^-1 (inr tt)). Defined. (** It follows that if [X] is finite, then its propositional truncation is decidable. *) Global Instance decidable_merely_finite X {fX : Finite X} : Decidable (merely X). Proof. exact _. Defined. (** From this, it follows that any finite set is *merely* decidable. *) Definition merely_decidable_finite X `{Finite X} : merely (Decidable X). Proof. apply O_decidable; exact _. Defined. (** ** Induction over finite sets *) (** Most concrete applications of this don't actually require univalence, but the general version does. For this reason the general statement is less useful (and less used in the sequel) than it might be. *) Definition finite_ind_hprop `{Univalence} (P : forall X, Finite X -> Type) `{forall X (fX:Finite X), IsHProp (P X _)} (f0 : P Empty _) (fs : forall X (fX:Finite X), P X _ -> P (X + Unit)%type _) (X : Type) `{Finite X} : P X _. Proof. assert (e := merely_equiv_fin X). strip_truncations. assert (p := transportD Finite P (path_universe e^-1) _). refine (transport (P X) (path_ishprop _ _) (p _)). generalize (fcard X); intros n. induction n as [|n IH]. - exact f0. - refine (transport (P (Fin n.+1)) (path_ishprop _ _) (fs _ _ IH)). Defined. (** ** The finite axiom of choice, and projectivity *) Definition finite_choice {X} `{Finite X} : HasChoice X. Proof. intros P oP f; clear oP. assert (e := merely_equiv_fin X). strip_truncations. set (P' := P o e^-1). assert (f' := (fun x => f (e^-1 x)) : forall x, merely (P' x)). refine (Trunc_functor (X := forall x:Fin (fcard X), P' x) (-1) _ _). - intros g x; exact (eissect e x # g (e x)). - clearbody P'; clear f P e. generalize dependent (fcard X); intros n P f. induction n as [|n IH]. + exact (tr (Empty_ind P)). + specialize (IH (P o inl) (f o inl)). assert (e := f (inr tt)). strip_truncations. exact (tr (sum_ind P IH (Unit_ind e))). Defined. Corollary isprojective_fin_n (n : nat) : IsProjective (Fin n). Proof. apply (iff_isoprojective_hasochoice _ (Fin n)). rapply finite_choice. Defined. (** ** Constructions on finite sets *) (** Finite sets are closed under sums, products, function spaces, and equivalence spaces. There are multiple choices we could make regarding how to prove these facts. Since we know what the cardinalities ought to be in all cases (since we know how to add, multiply, exponentiate, and take factorials of natural numbers), we could specify those off the bat, and then reduce to the case of canonical finite sets. However, it's more amusing to instead prove finiteness of these constructions by "finite-set induction", and then *deduce* that their cardinalities are given by the corresponding operations on natural numbers (because they satisfy the same recurrences). *) (** *** Binary sums *) Global Instance finite_sum X Y `{Finite X} `{Finite Y} : Finite (X + Y). Proof. assert (e := merely_equiv_fin Y). strip_truncations. refine (finite_equiv _ (functor_sum idmap e^-1) _). generalize (fcard Y); intros n. induction n as [|n IH]. - refine (finite_equiv _ (sum_empty_r X)^-1 _). - refine (finite_equiv _ (equiv_sum_assoc X _ Unit) _). Defined. (** Note that the cardinality function [fcard] actually computes. The same will be true of all the other proofs in this section, though we don't always verify it. *) Goal fcard (Fin 3 + Fin 4) = 7. reflexivity. Abort. Definition fcard_sum X Y `{Finite X} `{Finite Y} : fcard (X + Y) = (fcard X + fcard Y). Proof. refine (_ @ nat_add_comm _ _). assert (e := merely_equiv_fin Y). strip_truncations. refine (fcard_equiv' (1 +E e) @ _). refine (_ @ ap (fun y => (y + fcard X)) (fcard_equiv e^-1)). generalize (fcard Y); intros n. induction n as [|n IH]. - refine (fcard_equiv (sum_empty_r X)^-1). - refine (fcard_equiv (equiv_sum_assoc _ _ _)^-1 @ _). exact (ap S IH). Defined. (** *** Binary products *) Global Instance finite_prod X Y `{Finite X} `{Finite Y} : Finite (X * Y). Proof. assert (e := merely_equiv_fin Y). strip_truncations. refine (finite_equiv _ (functor_prod idmap e^-1) _). generalize (fcard Y); intros n. induction n as [|n IH]. - refine (finite_equiv _ (prod_empty_r X)^-1 _). - refine (finite_equiv _ (sum_distrib_l X _ Unit)^-1 (finite_sum _ _)). refine (finite_equiv _ (prod_unit_r X)^-1 _). Defined. Definition fcard_prod X Y `{Finite X} `{Finite Y} : fcard (X * Y) = fcard X * fcard Y. Proof. assert (e := merely_equiv_fin X). strip_truncations. refine (fcard_equiv' (e *E 1) @ _). refine (_ @ ap (fun x => x * fcard Y) (fcard_equiv e^-1)). generalize (fcard X); intros n. induction n as [|n IH]. - refine (fcard_equiv (prod_empty_l Y)). - refine (fcard_equiv (sum_distrib_r Y (Fin n) Unit) @ _). refine (fcard_sum _ _ @ _). simpl. refine (_ @ nat_add_comm _ _). refine (ap011 nat_add _ _). + apply IH. + apply fcard_equiv', prod_unit_l. Defined. (** *** Function types *) (** Finite sets are closed under function types, and even dependent function types. *) Global Instance finite_forall `{Funext} {X} (Y : X -> Type) `{Finite X} `{forall x, Finite (Y x)} : Finite (forall x:X, Y x). Proof. assert (e := merely_equiv_fin X). strip_truncations. simple refine (finite_equiv' _ (equiv_functor_forall' (P := fun x => Y (e^-1 x)) e _) _); try exact _. { intros x; refine (equiv_transport _ (eissect e x)). } set (Y' := Y o e^-1); change (Finite (forall x, Y' x)). assert (forall x, Finite (Y' x)) by exact _; clearbody Y'; clear e. generalize dependent (fcard X); intros n Y' ?. induction n as [|n IH]. - exact _. - refine (finite_equiv _ (equiv_sum_ind Y') _). apply finite_prod. + apply IH; exact _. + refine (finite_equiv _ (@Unit_ind (fun u => Y' (inr u))) _). refine (isequiv_unit_ind (Y' o inr)). Defined. #[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances. Definition fcard_arrow `{Funext} X Y `{Finite X} `{Finite Y} : fcard (X -> Y) = nat_pow (fcard Y) (fcard X). Proof. assert (e := merely_equiv_fin X). strip_truncations. refine (fcard_equiv (functor_arrow e idmap)^-1 @ _). refine (_ @ ap (fun x => nat_pow (fcard Y) x) (fcard_equiv e)). generalize (fcard X); intros n. induction n as [|n IH]. - reflexivity. - refine (fcard_equiv (equiv_sum_ind (fun (_:Fin n.+1) => Y))^-1 @ _). refine (fcard_prod _ _ @ _). lhs nrapply nat_mul_comm. apply (ap011 nat_mul). + refine (fcard_equiv (@Unit_ind (fun (_:Unit) => Y))^-1). + assumption. Defined. (** [fcard] still computes, despite the funext: *) Goal forall fs:Funext, fcard (Fin 3 -> Fin 4) = 64. reflexivity. Abort. (** *** Automorphism types (i.e. symmetric groups) *) Global Instance finite_aut `{Funext} X `{Finite X} : Finite (X <~> X). Proof. assert (e := merely_equiv_fin X). strip_truncations. refine (finite_equiv _ (equiv_functor_equiv e^-1 e^-1) _). generalize (fcard X); intros n. induction n as [|n IH]. - exact _. - refine (finite_equiv _ (equiv_fin_equiv n n) _). Defined. Definition fcard_aut `{Funext} X `{Finite X} : fcard (X <~> X) = factorial (fcard X). Proof. assert (e := merely_equiv_fin X). strip_truncations. refine (fcard_equiv (equiv_functor_equiv e^-1 e^-1)^-1 @ _). generalize (fcard X); intros n. induction n as [|n IH]. - reflexivity. - refine (fcard_equiv (equiv_fin_equiv n n)^-1 @ _). refine (fcard_prod _ _ @ _). apply ap011. + reflexivity. + assumption. Defined. (** [fcard] still computes: *) Goal forall fs:Funext, fcard (Fin 4 <~> Fin 4) = 24. reflexivity. Abort. (** ** Finite sums of natural numbers *) (** Perhaps slightly less obviously, finite sets are also closed under sigmas. *) Global Instance finite_sigma {X} (Y : X -> Type) `{Finite X} `{forall x, Finite (Y x)} : Finite { x:X & Y x }. Proof. assert (e := merely_equiv_fin X). strip_truncations. refine (finite_equiv' _ (equiv_functor_sigma (equiv_inverse e) (fun x (y:Y (e^-1 x)) => y)) _). (** Unfortunately, because [compose] is currently beta-expanded, [set (Y' := Y o e^-1)] doesn't change the goal. *) set (Y' := fun x => Y (e^-1 x)). assert (forall x, Finite (Y' x)) by exact _; clearbody Y'; clear e. generalize dependent (fcard X); intros n Y' ?. induction n as [|n IH]. - refine (finite_equiv Empty pr1^-1 _). - refine (finite_equiv _ (equiv_sigma_sum (Fin n) Unit Y')^-1 _). apply finite_sum. + apply IH; exact _. + refine (finite_equiv _ (equiv_contr_sigma _)^-1 _). Defined. (** Amusingly, this automatically gives us a way to add up a family of natural numbers indexed by any finite set. (We could of course also define such an operation directly, probably using [merely_ind_hset].) *) Definition finadd {X} `{Finite X} (f : X -> nat) : nat := fcard { x:X & Fin (f x) }. Definition fcard_sigma {X} (Y : X -> Type) `{Finite X} `{forall x, Finite (Y x)} : fcard { x:X & Y x } = finadd (fun x => fcard (Y x)). Proof. set (f := fun x => fcard (Y x)). set (g := fun x => merely_equiv_fin (Y x) : merely (Y x <~> Fin (f x))). apply finite_choice in g; [| exact _]. strip_truncations. unfold finadd. refine (fcard_equiv' (equiv_functor_sigma_id g)). Defined. (** The sum of a finite constant family is the product by its cardinality. *) Definition finadd_const X `{Finite X} n : finadd (fun x:X => n) = fcard X * n. Proof. transitivity (fcard (X * Fin n)). - exact (fcard_equiv' (equiv_sigma_prod0 X (Fin n))). - exact (fcard_prod X (Fin n)). Defined. (** Closure under sigmas and paths also implies closure under hfibers. *) Definition finite_hfiber {X Y} (f : X -> Y) (y : Y) `{Finite X} `{Finite Y} : Finite (hfiber f y). Proof. exact _. Defined. (** Therefore, the cardinality of the domain of a map between finite sets is the sum of the cardinalities of its hfibers. *) Definition fcard_domain {X Y} (f : X -> Y) `{Finite X} `{Finite Y} : fcard X = finadd (fun y => fcard (hfiber f y)). Proof. refine (_ @ fcard_sigma (hfiber f)). refine (fcard_equiv' (equiv_fibration_replacement f)). Defined. (** In particular, the image of a map between finite sets is finite. *) Definition finite_image {X Y} `{Finite X} `{Finite Y} (f : X -> Y) : Finite (himage f). Proof. exact _. Defined. (** ** Finite products of natural numbers *) (** Similarly, closure of finite sets under [forall] automatically gives us a way to multiply a family of natural numbers indexed by any finite set. Of course, if we defined this explicitly, it wouldn't need funext. *) Definition finmult `{Funext} {X} `{Finite X} (f : X -> nat) : nat := fcard (forall x:X, Fin (f x)). Definition fcard_forall `{Funext} {X} (Y : X -> Type) `{Finite X} `{forall x, Finite (Y x)} : fcard (forall x:X, Y x) = finmult (fun x => fcard (Y x)). Proof. set (f := fun x => fcard (Y x)). set (g := fun x => merely_equiv_fin (Y x) : merely (Y x <~> Fin (f x))). apply finite_choice in g; [| exact _]. strip_truncations. unfold finmult. refine (fcard_equiv' (equiv_functor_forall' (equiv_idmap X) g)). Defined. (** The product of a finite constant family is the exponential by its cardinality. *) Definition finmult_const `{Funext} X `{Finite X} n : finmult (fun x:X => n) = nat_pow n (fcard X). Proof. refine (fcard_arrow X (Fin n)). Defined. (** ** Finite subsets *) (** Closure under sigmas implies that a detachable subset of a finite set is finite. *) Global Instance finite_detachable_subset {X} `{Finite X} (P : X -> Type) `{forall x, IsHProp (P x)} `{forall x, Decidable (P x)} : Finite { x:X & P x }. Proof. exact _. Defined. (** Conversely, if a subset of a finite set is finite, then it is detachable. We show first that an embedding between finite subsets has detachable image. *) Definition detachable_image_finite {X Y} `{Finite X} `{Finite Y} (f : X -> Y) `{IsEmbedding f} : forall y, Decidable (hfiber f y). Proof. intros y. assert (ff : Finite (hfiber f y)) by exact _. destruct ff as [[|n] e]. - right; intros u; strip_truncations; exact (e u). - left; strip_truncations; exact (e^-1 (inr tt)). Defined. Definition detachable_finite_subset {X} `{Finite X} (P : X -> Type) `{forall x, IsHProp (P x)} {Pf : Finite ({ x:X & P x })} : forall x, Decidable (P x). Proof. intros x. nrefine (decidable_equiv' _ (hfiber_fibration x P)^-1%equiv _). nrefine (detachable_image_finite pr1 x). 1,2: exact _. apply (mapinO_pr1 (Tr (-1))). (** Why doesn't Coq find this? *) Defined. (** ** Quotients *) (** The quotient of a finite set by a detachable equivalence relation is finite. *) Section DecidableQuotients. Context `{Univalence} {X} `{Finite X} (R : Relation X) `{is_mere_relation X R} `{Reflexive _ R} `{Transitive _ R} `{Symmetric _ R} {Rd : forall x y, Decidable (R x y)}. Global Instance finite_quotient : Finite (Quotient R). Proof. assert (e := merely_equiv_fin X). strip_truncations. pose (R' x y := R (e^-1 x) (e^-1 y)). assert (is_mere_relation _ R') by exact _. assert (Reflexive R') by (intros ?; unfold R'; apply reflexivity). assert (Symmetric R') by (intros ? ?; unfold R'; apply symmetry). assert (Transitive R') by (intros ? ? ?; unfold R'; apply transitivity). assert (R'd : forall x y, Decidable (R' x y)) by (intros ? ?; unfold R'; apply Rd). srefine (finite_equiv' _ (equiv_quotient_functor R' R e^-1 _) _). 1: by try (intros; split). clearbody R'; clear e. generalize dependent (fcard X); intros n; induction n as [|n IH]; intros R' ? ? ? ? ?. - refine (finite_equiv Empty _^-1 _). refine (Quotient_rec R' _ Empty_rec (fun x _ _ => match x with end)). - pose (R'' x y := R' (inl x) (inl y)). assert (is_mere_relation _ R'') by exact _. assert (Reflexive R'') by (intros ?; unfold R''; apply reflexivity). assert (Symmetric R'') by (intros ? ?; unfold R''; apply symmetry). assert (Transitive R'') by (intros ? ? ?; unfold R''; apply transitivity). assert (forall x y, Decidable (R'' x y)) by (intros ? ?; unfold R''; apply R'd). assert (inlresp := (fun x y => idmap) : forall x y, R'' x y -> R' (inl x) (inl y)). destruct (dec (merely {x:Fin n & R' (inl x) (inr tt)})) as [p|np]. { strip_truncations. destruct p as [x r]. refine (finite_equiv' (Quotient R'') _ _). refine (Build_Equiv _ _ (Quotient_functor R'' R' inl inlresp) _). apply isequiv_surj_emb. - apply BuildIsSurjection. refine (Quotient_ind_hprop R' _ _). intros [y|[]]; apply tr. + exists (class_of R'' y); reflexivity. + exists (class_of R'' x); simpl. apply qglue, r. - apply isembedding_isinj_hset; intros u. refine (Quotient_ind_hprop R'' _ _); intros v. revert u; refine (Quotient_ind_hprop R'' _ _); intros u. simpl; intros q. apply qglue; unfold R''. exact (related_quotient_paths R' (inl u) (inl v) q). } { refine (finite_equiv' (Quotient R'' + Unit) _ _). refine (Build_Equiv _ _ (sum_ind (fun _ => Quotient R') (Quotient_functor R'' R' inl inlresp) (fun _ => class_of R' (inr tt))) _). apply isequiv_surj_emb. - apply BuildIsSurjection. refine (Quotient_ind_hprop R' _ _). intros [y|[]]; apply tr. + exists (inl (class_of R'' y)); reflexivity. + exists (inr tt); reflexivity. - apply isembedding_isinj_hset; intros u. refine (sum_ind _ _ _). + refine (Quotient_ind_hprop R'' _ _); intros v. revert u; refine (sum_ind _ _ _). * refine (Quotient_ind_hprop R'' _ _); intros u. simpl; intros q. apply ap, qglue; unfold R''. exact (related_quotient_paths R' (inl u) (inl v) q). * intros []; simpl. intros q. apply related_quotient_paths in q; try exact _. apply symmetry in q. elim (np (tr (v ; q))). + intros []; simpl. destruct u as [u|[]]; simpl. * revert u; refine (Quotient_ind_hprop R'' _ _); intros u; simpl. intros q. apply related_quotient_paths in q; try exact _. elim (np (tr (u;q))). * intros; reflexivity. } Defined. (** Therefore, the cardinality of [X] is the sum of the cardinalities of its equivalence classes. *) Definition fcard_quotient : fcard X = finadd (fun z:Quotient R => fcard {x:X & in_class R z x}). Proof. refine (fcard_domain (class_of R) @ _). apply ap, path_arrow; intros z; revert z. refine (Quotient_ind_hprop _ _ _); intros x; simpl. apply fcard_equiv'; unfold hfiber. refine (equiv_functor_sigma_id _); intros y; simpl. symmetry. refine (path_quotient R y x oE _). apply equiv_iff_hprop; apply symmetry. Defined. End DecidableQuotients. (** ** Injections *) (** An injection between finite sets induces an inequality between their cardinalities. *) Definition leq_inj_finite {X Y} {fX : Finite X} {fY : Finite Y} (f : X -> Y) (i : IsEmbedding f) : fcard X <= fcard Y. Proof. assert (MapIn (Tr (-1)) f) by exact _. clear i. destruct fX as [n e]; simpl. destruct fY as [m e']; simpl. strip_truncations. pose (g := e' o f o e^-1). assert (MapIn (Tr (-1)) g) by (unfold g; exact _). clearbody g. clear e e'. generalize dependent m. induction n as [|n IHn]. 1: exact _. intros m g ?. assert (i : IsInjective g) by (apply isinj_embedding; exact _). destruct m as [|m]. { elim (g (inr tt)). } pose (h := (fin_transpose_last_with m (g (inr tt)))^-1 o g). assert (MapIn (Tr (-1)) h) by (unfold h; exact _). assert (Ha : forall a:Fin n, is_inl (h (inl a))). { intros a. remember (g (inl a)) as b eqn:p. destruct b as [b|[]]. - assert (q : g (inl a) <> (g (inr tt))). { intros r. exact (inl_ne_inr _ _ (i _ _ r)). } rewrite p in q; apply symmetric_neq in q. assert (r : h (inl a) = inl b). { unfold h; apply moveR_equiv_V; symmetry. refine (fin_transpose_last_with_rest m (g (inr tt)) b q @ p^). } rewrite r; exact tt. - assert (q : h (inl a) = g (inr tt)). { unfold h; apply moveR_equiv_V; symmetry. refine (_ @ p^); apply fin_transpose_last_with_with. } rewrite q. destruct (is_inl_or_is_inr (g (inr tt))) as [l|r]; try assumption. assert (s := inr_un_inr _ r). revert s; generalize (un_inr (g (inr tt)) r); intros [] s. elim (inl_ne_inr _ _ (i _ _ (p @ s))). } assert (Hb : forall b:Unit, is_inr (h (inr b))). { intros []. assert (q : h (inr tt) = inr tt). { unfold h; apply moveR_equiv_V; symmetry. apply fin_transpose_last_with_last. } rewrite q; exact tt. } apply leq_succ. exact (IHn m (unfunctor_sum_l h Ha) (mapinO_unfunctor_sum_l (Tr (-1)) h Ha Hb)). Qed. (** ** Surjections *) (** A surjection between finite sets induces an inequality between their cardinalities. *) Definition geq_surj_finite {X Y} {fX : Finite X} {fY : Finite Y} (f : X -> Y) (i : IsSurjection f) : fcard X >= fcard Y. Proof. destruct fX as [n e], fY as [m e']; simpl. assert (k := isprojective_fin_n m). strip_truncations. pose (g := e' o f o e^-1). assert (k' : IsSurjection g) by exact _ . clearbody g; clear i f. assert (j := k (Fin n) _ (Fin m) _ idmap g k'). strip_truncations. simpl; destruct j as [s is_section]. change n with (fcard (Fin n)). change m with (fcard (Fin m)). apply (leq_inj_finite s). apply isembedding_isinj_hset, (isinj_section is_section). Defined. (** ** Enumerations *) (** A function from [nat] to a finite set must repeat itself eventually. *) Section Enumeration. Context `{Funext} {X} `{Finite@{_ Set _} X} (e : nat -> X). Let er (n : nat) : Fin n -> X := fun k => e (nat_fin n k). Lemma finite_enumeration_stage (n : nat) : IsEmbedding (er n) + { n : nat & { k : nat & e n = e (n + k).+1 }}. Proof. induction n as [|n [IH|IH]]. - left. intros x. apply hprop_inhabited_contr; intros [[] _]. - destruct (detachable_image_finite (er n) (er n.+1 (inr tt))) as [[k p]|ne]. + right. exists (nat_fin n k). exists (nat_fin_compl n k). rewrite nat_fin_compl_compl. exact p. + left. intros x. apply hprop_allpath. intros k l. apply path_sigma_hprop. destruct k as [[k|[]] p], l as [[l|[]] q]; simpl. * apply isinj_embedding in IH. apply ap. apply IH. unfold er in p, q. simpl in p, q. exact (p @ q^). * refine (Empty_rec (ne _)). exists k. exact (p @ q^). * refine (Empty_rec (ne _)). exists l. exact (q @ p^). * reflexivity. - right; exact IH. Defined. Definition finite_enumeration_repeats : { n : nat & { k : nat & e n = e (n + k).+1 }}. Proof. destruct (finite_enumeration_stage (fcard X).+1) as [p|?]. - assert (q := leq_inj_finite (er (fcard X).+1) p); simpl in q. elim (lt_irrefl _ q). - assumption. Defined. End Enumeration. Coq-HoTT-9.0/theories/Spaces/Finite/Tactics.v000066400000000000000000000006171474641544500210010ustar00rootroot00000000000000Require Import HoTT.Basics Fin. (** ** Tactics *) Ltac FinIndOn X := repeat match type of X with | Fin 0 => destruct X | Empty => destruct X | Unit => destruct X | Fin ?n => destruct X as [X|X] | ?L + Unit => destruct X as [X|X] end. (** This tactic can be used to generate n cases from a goal like forall (x : Fin n), _ *) Ltac FinInd := let X := fresh "X" in intro X; FinIndOn X. Coq-HoTT-9.0/theories/Spaces/FreeInt.v000066400000000000000000000053211474641544500175220ustar00rootroot00000000000000Require Import Basics Types WildCat.Core Truncations.Core Spaces.Int AbelianGroup AbHom Centralizer AbProjective Groups.FreeGroup AbGroups.Z. (** * The free group on one generator *) (** We can define the integers as the free group on one generator, which we denote [Z1] below. Results from Centralizer.v and Groups.FreeGroup let us show that [Z1] is abelian. *) (** We define [Z1] as the free group with a single generator. *) Definition Z1 := FreeGroup Unit. Definition Z1_gen : Z1 := freegroup_in tt. (* The generator *) (** The recursion principle of [Z1] and its computation rule. *) Definition Z1_rec {G : Group} (g : G) : Z1 $-> G := FreeGroup_rec (unit_name g). Definition Z1_rec_beta {G : Group} (g : G) : Z1_rec g Z1_gen = g := FreeGroup_rec_beta _ _ _. (** The free group [Z1] on one generator is isomorphic to the subgroup of [Z1] generated by the generator. And such cyclic subgroups are known to be commutative, by [commutative_cyclic_subgroup]. *) Global Instance Z1_commutative `{Funext} : Commutative (@group_sgop Z1) := commutative_iso_commutative iso_subgroup_incl_freegroupon. (* TODO: [Funext] is used in [isfreegroupon_freegroup], but there is a comment there saying that it can be removed. If that is done, can remove it from many results in this file. A different proof of this result, directly using the construction of the free group, could probably also avoid [Funext]. *) Definition ab_Z1 `{Funext} : AbGroup := Build_AbGroup Z1 _. (** The universal property of [ab_Z1]. *) Lemma equiv_Z1_hom@{u v | u < v} `{Funext} (A : AbGroup@{u}) : GroupIsomorphism (ab_hom@{u v} ab_Z1@{u v} A) A. Proof. snrapply Build_GroupIsomorphism'. - refine (_ oE (equiv_freegroup_rec@{u u u v} A Unit)^-1). symmetry. refine (Build_Equiv _ _ (fun a => unit_name a) _). - intros f g. cbn. reflexivity. Defined. Definition nat_to_Z1 : nat -> Z1 := fun n => grp_pow Z1_gen n. Definition Z1_mul_nat `{Funext} (n : nat) : ab_Z1 $-> ab_Z1 := Z1_rec (nat_to_Z1 n). Lemma Z1_mul_nat_beta {A : AbGroup} (a : A) (n : nat) : Z1_rec a (nat_to_Z1 n) = ab_mul n a. Proof. induction n as [|n H]. 1: done. exact (grp_pow_natural _ _ _). Defined. (** [ab_Z1] is projective. *) Global Instance ab_Z1_projective `{Funext} : IsAbProjective ab_Z1. Proof. intros A B p f H1. pose proof (a := @center _ (H1 (f Z1_gen))). strip_truncations. snrefine (tr (Z1_rec a.1; _)). cbn beta. apply ap10. apply ap. (* of the coercion [grp_homo_map] *) apply path_homomorphism_from_free_group. simpl. intros []. exact a.2. Defined. (** The map sending the generator to [1 : Int]. *) Definition Z1_to_Z `{Funext} : ab_Z1 $-> abgroup_Z := Z1_rec (G:=abgroup_Z) 1%int. (** TODO: Prove that [Z1_to_Z] is a group isomorphism. *) Coq-HoTT-9.0/theories/Spaces/Int.v000066400000000000000000000552711474641544500167310ustar00rootroot00000000000000Require Import Basics.Overture Basics.Nat Basics.Tactics Basics.Decidable Basics.Equivalences Basics.PathGroupoids Types.Paths Types.Universe. Require Basics.Numerals.Decimal. Require Import Spaces.Nat.Core. Unset Elimination Schemes. Set Universe Minimization ToSet. Declare Scope int_scope. Delimit Scope int_scope with int. Local Open Scope int_scope. (** * The Integers *) (** ** Definition *) (** We define the integers as two copies of [nat] stuck together around a [zero]. *) Inductive Int : Type0 := | negS : nat -> Int | zero : Int | posS : nat -> Int. (** We can convert a [nat] to an [Int] by mapping [0] to [zero] and [S n] to [posS n]. Various operations on [nat] are preserved by this function. See the section on conversion functions starting with [int_nat_succ]. *) Definition int_of_nat (n : nat) := match n with | O => zero | S n => posS n end. (** We declare this conversion as a coercion so we can freely use [nat]s in statements about integers. *) Coercion int_of_nat : nat >-> Int. (** ** Number Notations *) (** Here we define some printing and parsing functions that convert the integers between numeral representations so that we can use notations such as [123] for [posS 122] and [-123] for [negS 122]. *) (** Printing *) Definition int_to_number_int (n : Int) : Numeral.int := match n with | posS n => Numeral.IntDec (Decimal.Pos (Nat.to_uint (S n))) | zero => Numeral.IntDec (Decimal.Pos (Nat.to_uint 0)) | negS n => Numeral.IntDec (Decimal.Neg (Nat.to_uint (S n))) end. (** Parsing *) Definition int_of_number_int (d : Numeral.int) := match d with | Numeral.IntDec (Decimal.Pos d) => int_of_nat (Nat.of_uint d) | Numeral.IntDec (Decimal.Neg d) => negS (nat_pred (Nat.of_uint d)) | Numeral.IntHex (Hexadecimal.Pos u) => int_of_nat (Nat.of_hex_uint u) | Numeral.IntHex (Hexadecimal.Neg u) => negS (nat_pred (Nat.of_hex_uint u)) end. Number Notation Int int_of_number_int int_to_number_int : int_scope. (** ** Successor, Predecessor and Negation *) (** These operations will be used in the induction principle we derive for [Int] so we need to define them early on. *) (** *** Successor and Predecessor *) Definition int_succ (n : Int) : Int := match n with | posS n => posS (S n) | 0 => 1 | -1 => 0 | negS (S n) => negS n end. Notation "n .+1" := (int_succ n) : int_scope. Definition int_pred (n : Int) : Int := match n with | posS (S n) => posS n | 1 => 0 | 0 => -1 | negS n => negS (S n) end. Notation "n .-1" := (int_pred n) : int_scope. (** *** Negation *) Definition int_neg@{} (x : Int) : Int := match x with | posS x => negS x | zero => zero | negS x => posS x end. Notation "- x" := (int_neg x) : int_scope. (** ** Basic Properties *) (** *** Integer induction *) (** The induction principle for integers is similar to the induction principle for natural numbers. However we have two induction hypotheses going in either direction starting from 0. *) Definition Int_ind@{i} (P : Int -> Type@{i}) (H0 : P 0) (HP : forall n : nat, P n -> P (int_succ n)) (HN : forall n : nat, P (- n) -> P (int_pred (-n))) : forall x, P x. Proof. intros[x | | x]. - induction x as [|x IHx]. + apply (HN 0%nat), H0. + apply (HN x.+1%nat), IHx. - exact H0. - induction x as [|x IHx]. * apply (HP 0%nat), H0. * apply (HP x.+1%nat), IHx. Defined. (** We record these so that they can be used with the [induction] tactic. *) Definition Int_rect := Int_ind. Definition Int_rec := Int_ind. (** *** Decidable Equality *) (** The integers have decidable equality. *) Global Instance decidable_paths_int@{} : DecidablePaths Int. Proof. intros x y. destruct x as [x | | x], y as [y | | y]. 2-4,6-8: right; intros; discriminate. 2: by left. 1,2: nrapply decidable_iff. 1,3: split. 1,3: nrapply ap. 1,2: intros H; by injection H. 1,2: exact _. Defined. (** By Hedberg's theorem, we have that the integers are a set. *) Global Instance ishset_int@{} : IsHSet Int := _. (** *** Pointedness *) (** We sometimes want to treat the integers as a pointed type with basepoint given by 0. *) Global Instance ispointed_int : IsPointed Int := 0. (** ** Operations *) (** *** Addition *) (** Addition for integers is defined by integer inductionn on the first argument. *) Definition int_add@{} (x y : Int) : Int. Proof. induction x as [|x IHx|x IHx] in y |- *. (** [0 + y = y] *) - exact y. (** [x.+1 + y = (x + y).+1] *) - exact (int_succ (IHx y)). (** [x.-1 + y = (x + y).-1] *) - exact (int_pred (IHx y)). Defined. Infix "+" := int_add : int_scope. Infix "-" := (fun x y => x + -y) : int_scope. (** *** Multiplication *) (** Multiplication for integers is defined by integer induction on the first argument. *) Definition int_mul@{} (x y : Int) : Int. Proof. induction x as [|x IHx|x IHx] in y |- *. (** [0 * y = 0] *) - exact 0. (** [x.+1 * y = y + x * y] *) - exact (y + IHx y). (** [x.-1 * y = -y + x * y] *) - exact (-y + IHx y). Defined. Infix "*" := int_mul : int_scope. (** ** Properties of Operations *) (** *** Negation *) (** Negation is involutive. *) Definition int_neg_neg@{} (x : Int) : - - x = x. Proof. by destruct x. Defined. (** Negation is an equivalence. *) Global Instance isequiv_int_neg@{} : IsEquiv int_neg. Proof. snrapply (isequiv_adjointify int_neg int_neg). 1,2: nrapply int_neg_neg. Defined. (** Negation is injective. *) Definition isinj_int_neg@{} (x y : Int) : - x = - y -> x = y := equiv_inj int_neg. (** The negation of a successor is the predecessor of the negation. *) Definition int_neg_succ (x : Int) : - x.+1 = (- x).-1. Proof. by destruct x as [[] | | ]. Defined. (** The negation of a predecessor is the successor of the negation. *) Definition int_neg_pred (x : Int) : - x.-1 = (- x).+1. Proof. by destruct x as [ | | []]. Defined. (** The successor of a predecessor is the identity. *) Definition int_pred_succ@{} (x : Int) : x.-1.+1 = x. Proof. by destruct x as [ | | []]. Defined. (** The predecessor of a successor is the identity. *) Definition int_succ_pred@{} (x : Int) : x.+1.-1 = x. Proof. by destruct x as [[] | | ]. Defined. (** The successor is an equivalence on [Int] *) Global Instance isequiv_int_succ@{} : IsEquiv int_succ := isequiv_adjointify int_succ int_pred int_pred_succ int_succ_pred. (** The predecessor is an equivalence on [Int] *) Global Instance isequiv_int_pred@{} : IsEquiv int_pred := isequiv_inverse int_succ. (** *** Addition *) (** Integer addition with zero on the left is the identity by definition. *) Definition int_add_0_l@{} (x : Int) : 0 + x = x := 1. (** Integer addition with zero on the right is the identity. *) Definition int_add_0_r@{} (x : Int) : x + 0 = x. Proof. induction x as [|[|x] IHx|[|x] IHx]. - reflexivity. - reflexivity. - change (?z.+1 + 0) with (z + 0).+1. exact (ap _ IHx). - reflexivity. - change (?z.-1 + 0) with (z + 0).-1. exact (ap _ IHx). Defined. (** Adding a successor on the left is the successor of the sum. *) Definition int_add_succ_l@{} (x y : Int) : x.+1 + y = (x + y).+1. Proof. induction x as [|[|x] IHx|[|x] IHx] in y |- *. 1-3: reflexivity. all: symmetry; apply int_pred_succ. Defined. (** Adding a predecessor on the left is the predecessor of the sum. *) Definition int_add_pred_l@{} (x y : Int) : x.-1 + y = (x + y).-1. Proof. induction x as [|[|x] IHx|[|x] IHx] in y |- *. 1,4,5: reflexivity. all: symmetry; apply int_succ_pred. Defined. (** Adding a successor on the right is the successor of the sum. *) Definition int_add_succ_r@{} (x y : Int) : x + y.+1 = (x + y).+1. Proof. induction x as [|x IHx|[] IHx] in y |- *. - reflexivity. - by rewrite 2 int_add_succ_l, IHx. - cbn; by rewrite int_succ_pred, int_pred_succ. - change ((- (n.+1%nat)).-1 + y.+1 = ((- (n.+1%nat)).-1 + y).+1). rewrite int_add_pred_l. rewrite IHx. rewrite <- 2 int_add_succ_l. rewrite <- int_add_pred_l. by rewrite int_pred_succ, int_succ_pred. Defined. (** Adding a predecessor on the right is the predecessor of the sum. *) Definition int_add_pred_r (x y : Int) : x + y.-1 = (x + y).-1. Proof. induction x as [|x IHx|[] IHx] in y |- *. - reflexivity. - rewrite 2 int_add_succ_l. rewrite IHx. by rewrite int_pred_succ, int_succ_pred. - reflexivity. - rewrite 2 int_add_pred_l. by rewrite IHx. Defined. (** Integer addition is commutative. *) Definition int_add_comm@{} (x y : Int) : x + y = y + x. Proof. induction y as [|y IHy|y IHy] in x |- *. - apply int_add_0_r. - rewrite int_add_succ_l. rewrite <- IHy. by rewrite int_add_succ_r. - rewrite int_add_pred_r. rewrite int_add_pred_l. f_ap. Defined. (** Integer addition is associative. *) Definition int_add_assoc@{} (x y z : Int) : x + (y + z) = x + y + z. Proof. induction x as [|x IHx|x IHx] in y, z |- *. - reflexivity. - by rewrite !int_add_succ_l, IHx. - by rewrite !int_add_pred_l, IHx. Defined. (** Negation is a left inverse with respect to integer addition. *) Definition int_add_neg_l@{} (x : Int) : - x + x = 0. Proof. induction x as [|x IHx|x IHx]. - reflexivity. - by rewrite int_neg_succ, int_add_pred_l, int_add_succ_r, IHx. - by rewrite int_neg_pred, int_add_succ_l, int_add_pred_r, IHx. Defined. (** Negation is a right inverse with respect to integer addition. *) Definition int_add_neg_r@{} (x : Int) : x - x = 0. Proof. unfold "-"; by rewrite int_add_comm, int_add_neg_l. Defined. (** Negation distributes over addition. *) Definition int_neg_add@{} (x y : Int) : - (x + y) = - x - y. Proof. induction x as [|x IHx|x IHx] in y |- *. - reflexivity. - rewrite int_add_succ_l. rewrite 2 int_neg_succ. rewrite int_add_pred_l. f_ap. - rewrite int_neg_pred. rewrite int_add_succ_l. rewrite int_add_pred_l. rewrite int_neg_pred. f_ap. Defined. (** *** Multiplication *) (** Multiplication with a successor on the left is the sum of the multplication without the sucesseor and the multiplicand which was not a successor. *) Definition int_mul_succ_l@{} (x y : Int) : x.+1 * y = y + x * y. Proof. induction x as [|[|x] IHx|[] IHx] in y |- *. - reflexivity. - reflexivity. - reflexivity. - cbn. rewrite int_add_0_r. by rewrite int_add_neg_r. - rewrite int_pred_succ. cbn. rewrite int_add_assoc. rewrite int_add_neg_r. by rewrite int_add_0_l. Defined. (** Similarly, multiplication with a predecessor on the left is the sum of the multiplication without the predecessor and the negation of the multiplicand which was not a predecessor. *) Definition int_mul_pred_l@{} (x y : Int) : x.-1 * y = -y + x * y. Proof. induction x as [|x IHx|[] IHx] in y |- *. - reflexivity. - rewrite int_mul_succ_l. rewrite int_succ_pred. rewrite int_add_assoc. by rewrite int_add_neg_l. - reflexivity. - reflexivity. Defined. (** Integer multiplication with zero on the left is zero by definition. *) Definition int_mul_0_l@{} (x : Int) : 0 * x = 0 := 1. (** Integer multiplication with zero on the right is zero. *) Definition int_mul_0_r@{} (x : Int) : x * 0 = 0. Proof. induction x as [|x IHx|x IHx]. - reflexivity. - by rewrite int_mul_succ_l, int_add_0_l. - by rewrite int_mul_pred_l, int_add_0_l. Defined. (** Integer multiplication with one on the left is the identity. *) Definition int_mul_1_l@{} (x : Int) : 1 * x = x. Proof. apply int_add_0_r. Defined. (** Integer multiplication with one on the right is the identity. *) Definition int_mul_1_r@{} (x : Int) : x * 1 = x. Proof. induction x as [|x IHx|x IHx]. - reflexivity. - by rewrite int_mul_succ_l, IHx. - by rewrite int_mul_pred_l, IHx. Defined. (** Multiplying with a negation on the left is the same as negating the product. *) Definition int_mul_neg_l@{} (x y : Int) : - x * y = - (x * y). Proof. induction x as [|x IHx|x IHx] in y |- *. - reflexivity. - rewrite int_neg_succ. rewrite int_mul_pred_l. rewrite int_mul_succ_l. rewrite int_neg_add. by rewrite IHx. - rewrite int_neg_pred. rewrite int_mul_succ_l. rewrite int_mul_pred_l. rewrite int_neg_add. rewrite IHx. by rewrite int_neg_neg. Defined. (** Multiplying with a successor on the right is the sum of the multiplication without the successor and the product of the multiplicand which was not a successor and the multiplicand. *) Definition int_mul_succ_r@{} (x y : Int) : x * y.+1 = x + x * y. Proof. induction x as [|x IHx|x IHx] in y |- *. - reflexivity. - rewrite 2 int_mul_succ_l. rewrite 2 int_add_succ_l. f_ap. rewrite IHx. rewrite !int_add_assoc; f_ap. by rewrite int_add_comm. - rewrite 2 int_mul_pred_l. rewrite int_neg_succ. rewrite int_mul_neg_l. rewrite 2 int_add_pred_l. f_ap. rewrite <- int_mul_neg_l. rewrite IHx. rewrite !int_add_assoc; f_ap. by rewrite int_add_comm. Defined. (** Multiplying with a predecessor on the right is the sum of the multiplication without the predecessor and the product of the multiplicand which was not a predecessor and the negation of the multiplicand which was not a predecessor. *) Definition int_mul_pred_r@{} (x y : Int) : x * y.-1 = -x + x * y. Proof. induction x as [|x IHx|x IHx] in y |- *. - reflexivity. - rewrite 2 int_mul_succ_l. rewrite IHx. rewrite !int_add_assoc; f_ap. rewrite <- (int_neg_neg y.-1). rewrite <- int_neg_add. rewrite int_neg_pred. rewrite int_add_succ_l. rewrite int_add_comm. rewrite <- int_add_succ_l. rewrite int_neg_add. by rewrite int_neg_neg. - rewrite int_neg_pred. rewrite int_neg_neg. rewrite 2 int_mul_pred_l. rewrite IHx. rewrite !int_add_assoc; f_ap. rewrite int_neg_pred. rewrite int_neg_neg. rewrite 2 int_add_succ_l; f_ap. by rewrite int_add_comm. Defined. (** Integer multiplication is commutative. *) Definition int_mul_comm@{} (x y : Int) : x * y = y * x. Proof. induction y as [|y IHy|y IHy] in x |- *. - apply int_mul_0_r. - rewrite int_mul_succ_l. rewrite int_mul_succ_r. by rewrite IHy. - rewrite int_mul_pred_l. rewrite int_mul_pred_r. by rewrite IHy. Defined. (** Multiplying with a negation on the right is the same as negating the product. *) Definition int_mul_neg_r@{} (x y : Int) : x * - y = - (x * y). Proof. rewrite !(int_mul_comm x). apply int_mul_neg_l. Defined. (** Multiplication distributes over addition on the left. *) Definition int_dist_l@{} (x y z : Int) : x * (y + z) = x * y + x * z. Proof. induction x as [|x IHx|x IHx] in y, z |- *. - reflexivity. - rewrite 3 int_mul_succ_l. rewrite IHx. rewrite !int_add_assoc; f_ap. rewrite <- !int_add_assoc; f_ap. by rewrite int_add_comm. - rewrite 3 int_mul_pred_l. rewrite IHx. rewrite !int_add_assoc; f_ap. rewrite int_neg_add. rewrite <- !int_add_assoc; f_ap. by rewrite int_add_comm. Defined. (** Multiplication distributes over addition on the right. *) Definition int_dist_r@{} (x y z : Int) : (x + y) * z = x * z + y * z. Proof. by rewrite int_mul_comm, int_dist_l, !(int_mul_comm z). Defined. (** Multiplication is associative. *) Definition int_mul_assoc@{} (x y z : Int) : x * (y * z) = x * y * z. Proof. induction x as [|x IHx|x IHx] in y, z |- *. - reflexivity. - rewrite 2 int_mul_succ_l. rewrite int_dist_r. by rewrite IHx. - rewrite 2 int_mul_pred_l. rewrite int_dist_r. rewrite <- int_mul_neg_l. by rewrite IHx. Defined. (** ** Iteration of equivalences *) (** *** Iteration by arbitrary integers *) (** Iteration by arbitrary integers requires the endofunction to be an equivalence, so that we can define a negative iteration by using its inverse. *) Definition int_iter {A} (f : A -> A) `{!IsEquiv f} (n : Int) : A -> A := match n with | negS n => fun x => nat_iter n.+1%nat f^-1 x | zero => idmap | posS n => fun x => nat_iter n.+1%nat f x end. Definition int_iter_neg {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A) : int_iter f (- n) a = int_iter f^-1 n a. Proof. by destruct n. Defined. Definition int_iter_succ_l {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A) : int_iter f (int_succ n) a = f (int_iter f n a). Proof. induction n as [|n|n]. - reflexivity. - by destruct n. - rewrite int_pred_succ. destruct n. all: symmetry; apply eisretr. Defined. Definition int_iter_succ_r {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A) : int_iter f (int_succ n) a = int_iter f n (f a). Proof. induction n as [|n|n]. - reflexivity. - destruct n. 1: reflexivity. cbn; f_ap. - destruct n. 1: symmetry; apply eissect. rewrite int_pred_succ. apply (ap f^-1). rhs_V nrapply IHn. by destruct n. Defined. Definition int_iter_pred_l {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A) : int_iter f (int_pred n) a = f^-1 (int_iter f n a). Proof. (* Convert the problem to be a problem about [f^-1] and [-n]. *) lhs_V exact (int_iter_neg f^-1 (n.-1) a). rhs_V exact (ap f^-1 (int_iter_neg f^-1 n a)). (* Then [int_iter_succ_l] applies, after changing [- n.-1] to [(-n).+1]. *) rewrite int_neg_pred. apply int_iter_succ_l. Defined. Definition int_iter_pred_r {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A) : int_iter f (int_pred n) a = int_iter f n (f^-1 a). Proof. (* Convert the problem to be a problem about [f^-1] and [-n]. *) lhs_V exact (int_iter_neg f^-1 (n.-1) a). rhs_V exact (int_iter_neg f^-1 n (f^-1 a)). (* Then [int_iter_succ_r] applies, after changing [- n.-1] to [(-n).+1]. *) rewrite int_neg_pred. apply int_iter_succ_r. Defined. Definition int_iter_add {A} (f : A -> A) `{IsEquiv _ _ f} (m n : Int) : int_iter f (m + n) == int_iter f m o int_iter f n. Proof. intros a. induction m as [|m|m]. - reflexivity. - rewrite int_add_succ_l. rewrite 2 int_iter_succ_l. f_ap. - rewrite int_add_pred_l. rewrite 2 int_iter_pred_l. f_ap. Defined. (** If [g : A -> A'] commutes with automorphisms of [A] and [A'], then it commutes with iteration. *) Definition int_iter_commute_map {A A'} (f : A -> A) `{!IsEquiv f} (f' : A' -> A') `{!IsEquiv f'} (g : A -> A') (p : g o f == f' o g) (n : Int) (a : A) : g (int_iter f n a) = int_iter f' n (g a). Proof. induction n as [|n IHn|n IHn] in a |- *. - reflexivity. - rewrite 2 int_iter_succ_r. rewrite IHn. f_ap. - rewrite 2 int_iter_pred_r. rewrite IHn. f_ap. apply moveL_equiv_V. lhs_V nrapply p. f_ap. apply eisretr. Defined. (** In particular, homotopic maps have homotopic iterations. *) Definition int_iter_homotopic (n : Int) {A} (f f' : A -> A) `{!IsEquiv f} `{!IsEquiv f'} (h : f == f') : int_iter f n == int_iter f' n := int_iter_commute_map f f' idmap h n. (** [int_iter f n x] doesn't depend on the proof that [f] is an equivalence. *) Definition int_iter_agree (n : Int) {A} (f : A -> A) {ief ief' : IsEquiv f} : forall x, @int_iter A f ief n x = @int_iter A f ief' n x := int_iter_homotopic n f f (fun _ => idpath). Definition int_iter_invariant (n : Int) {A} (f : A -> A) `{!IsEquiv f} (P : A -> Type) (Psucc : forall x, P x -> P (f x)) (Ppred : forall x, P x -> P (f^-1 x)) : forall x, P x -> P (int_iter f n x). Proof. induction n as [|n IHn|n IHn]; intro x. - exact idmap. - intro H. rewrite int_iter_succ_l. apply Psucc, IHn, H. - intro H. rewrite int_iter_pred_l. apply Ppred, IHn, H. Defined. (** ** Exponentiation of loops *) Definition loopexp {A : Type} {x : A} (p : x = x) (z : Int) : (x = x) := int_iter (equiv_concat_r p x) z idpath. Definition loopexp_succ_r {A : Type} {x : A} (p : x = x) (z : Int) : loopexp p z.+1 = loopexp p z @ p := int_iter_succ_l _ _ _. Definition loopexp_pred_r {A : Type} {x : A} (p : x = x) (z : Int) : loopexp p z.-1 = loopexp p z @ p^ := int_iter_pred_l _ _ _. Definition loopexp_succ_l {A : Type} {x : A} (p : x = x) (z : Int) : loopexp p z.+1 = p @ loopexp p z. Proof. lhs nrapply loopexp_succ_r. induction z as [|z|z]. - nrapply concat_1p_p1. - rewrite loopexp_succ_r. rhs nrapply concat_p_pp. f_ap. - rewrite loopexp_pred_r. lhs nrapply concat_pV_p. rhs nrapply concat_p_pp. by apply moveL_pV. Defined. Definition loopexp_pred_l {A : Type} {x : A} (p : x = x) (z : Int) : loopexp p z.-1 = p^ @ loopexp p z. Proof. rewrite loopexp_pred_r. induction z as [|z|z]. - exact (concat_1p _ @ (concat_p1 _)^). - rewrite loopexp_succ_r. lhs nrapply concat_pp_V. rhs nrapply concat_p_pp. by apply moveL_pM. - rewrite loopexp_pred_r. rhs nrapply concat_p_pp. f_ap. Defined. Definition ap_loopexp {A B} (f : A -> B) {x : A} (p : x = x) (z : Int) : ap f (loopexp p z) = loopexp (ap f p) z. Proof. nrapply int_iter_commute_map. intro q; apply ap_pp. Defined. Definition loopexp_add {A : Type} {x : A} (p : x = x) m n : loopexp p (m + n) = loopexp p m @ loopexp p n. Proof. induction m as [|m|m]. - symmetry; apply concat_1p. - rewrite int_add_succ_l. rewrite 2 loopexp_succ_l. by rewrite IHm, concat_p_pp. - rewrite int_add_pred_l. rewrite 2 loopexp_pred_l. by rewrite IHm, concat_p_pp. Defined. (** Under univalence, exponentiation of loops corresponds to iteration of autoequivalences. *) Definition equiv_path_loopexp {A : Type} (p : A = A) (z : Int) (a : A) : equiv_path A A (loopexp p z) a = int_iter (equiv_path A A p) z a. Proof. refine (int_iter_commute_map _ _ (fun p => equiv_path A A p a) _ _ _). intro q; cbn. nrapply transport_pp. Defined. Definition loopexp_path_universe `{Univalence} {A : Type} (f : A <~> A) (z : Int) (a : A) : transport idmap (loopexp (path_universe f) z) a = int_iter f z a. Proof. revert f. equiv_intro (equiv_path A A) p. refine (_ @ equiv_path_loopexp p z a). refine (ap (fun q => equiv_path A A (loopexp q z) a) _). apply eissect. Defined. (** ** Converting between integers and naturals *) (** [int_of_nat] preserves successors. *) Definition int_nat_succ (n : nat) : (n.+1)%int = (n.+1)%nat :> Int. Proof. by induction n. Defined. (** [int_of_nat] preserves addition. Hence is a monoid homomorphism. *) Definition int_nat_add (n m : nat) : (n + m)%int = (n + m)%nat :> Int. Proof. induction n as [|n IHn]. - reflexivity. - rewrite <- 2 int_nat_succ. rewrite int_add_succ_l. exact (ap _ IHn). Defined. (** [int_of_nat] preserves subtraction when not truncated. *) Definition int_nat_sub (n m : nat) : (m <= n)%nat -> (n - m)%int = (n - m)%nat :> Int. Proof. intros H. induction H as [|n H IHn]. - lhs nrapply int_add_neg_r. by rewrite nat_sub_cancel. - rewrite nat_sub_succ_l; only 2: exact _. rewrite <- 2 int_nat_succ. rewrite int_add_succ_l. exact (ap _ IHn). Defined. (** [int_of_nat] preserves multiplication. This makes [int_of_nat] a semiring homomorphism. *) Definition int_nat_mul (n m : nat) : (n * m)%int = (n * m)%nat :> Int. Proof. induction n as [|n IHn]. - reflexivity. - rewrite <- int_nat_succ. rewrite int_mul_succ_l. rewrite nat_mul_succ_l. rhs_V nrapply int_nat_add. exact (ap _ IHn). Defined. Coq-HoTT-9.0/theories/Spaces/List/000077500000000000000000000000001474641544500167115ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/List/Core.v000066400000000000000000000144541474641544500200000ustar00rootroot00000000000000Require Import Basics.Overture. Local Unset Elimination Schemes. Local Set Universe Minimization ToSet. Local Set Polymorphic Inductive Cumulativity. (** * Lists *) (** ** Definition *) Declare Scope list_scope. Local Open Scope list_scope. (** A list is a sequence of elements from a type [A]. This is a very useful datatype and has many applications ranging from programming to algebra. It can be thought of a free monoid. *) Inductive list@{i|} (A : Type@{i}) : Type@{i} := | nil : list A | cons : A -> list A -> list A. Arguments nil {A}. Arguments cons {A} _ _. Delimit Scope list_scope with list. Bind Scope list_scope with list. (** This messes with Coq's parsing of [] in ltac. Therefore we keep it commented out. It's not difficult to write [nil] instead. *) (* Notation "[]" := nil : list_scope. *) Infix "::" := cons : list_scope. Scheme list_rect := Induction for list Sort Type. Scheme list_ind := Induction for list Sort Type. Scheme list_rec := Minimality for list Sort Type. (** A tactic for doing induction over a list that avoids spurious universes. *) Ltac simple_list_induction l h t IH := try generalize dependent l; fix IH 1; intros [| h t]; [ clear IH | specialize (IH t) ]. (** Syntactic sugar for creating lists. [ [a1, b2, ..., an] = a1 :: b2 :: ... :: an :: nil ]. *) Notation "[ x ]" := (x :: nil) : list_scope. Notation "[ x , y , .. , z ]" := (x :: (y :: .. (z :: nil) ..)) : list_scope. (** ** Length *) (** Notice that the definition of a list looks very similar to the definition of [nat]. It is as if each [S] constructor from [nat] has an element of [A] attached to it. We can discard this extra element and get a list invariant that we call [length]. *) (** The length (number of elements) of a list. *) Fixpoint length {A : Type} (l : list A) := match l with | nil => O | _ :: l => S (length l) end. (** ** Concatenation *) (** Given two lists [ [a1; a2; ...; an] ] and [ [b1; b2; ...; bm] ], we can concatenate them to get [ [a1; a2; ...; an; b1; b2; ...; bm] ]. *) Definition app {A : Type} : list A -> list A -> list A := fix app l m := match l with | nil => m | a :: l1 => a :: app l1 m end. Infix "++" := app : list_scope. (** ** Folding *) (** Folding is a very important operation on lists. It is a way to reduce a list to a single value. The [fold_left] function starts from the left and the [fold_right] function starts from the right. *) (** [fold_left f l a0] computes [f (... (f (f a0 x1) x2) ...) xn] where [l = [x1; x2; ...; xn]]. *) Fixpoint fold_left {A B} (f : A -> B -> A) (l : list B) (default : A) : A := match l with | nil => default | cons b l => fold_left f l (f default b) end. (** [fold_right f a0 l] computes [f x1 (f x2 ... (f xn a0) ...)] where [l = [x1; x2; ...; xn]]. *) Fixpoint fold_right {A B} (f : B -> A -> A) (default : A) (l : list B) : A := match l with | nil => default | cons b l => f b (fold_right f default l) end. (** ** Maps - Functoriality of Lists *) (** The [list_map] function applies a function to each element of a list. In other words [ list_map f [a1; a2; ...; an] = [f a1; f a2; ...; f an] ]. *) Fixpoint list_map {A B : Type} (f : A -> B) (l : list A) := match l with | nil => nil | x :: l => (f x) :: (list_map f l) end. (** The [list_map2] function applies a binary function to corresponding elements of two lists. When one of the lists run out, it uses one of the default functions to fill in the rest. *) Fixpoint list_map2 {A B C : Type} (f : A -> B -> C) (def_l : list A -> list C) (def_r : list B -> list C) l1 l2 := match l1, l2 with | nil, nil => nil | nil, _ => def_r l2 | _, nil => def_l l1 | x :: l1, y :: l2 => (f x y) :: (list_map2 f def_l def_r l1 l2) end. (** ** Reversal *) (** Tail-recursive list reversal. *) Fixpoint reverse_acc {A : Type} (acc : list A) (l : list A) : list A := match l with | nil => acc | x :: l => reverse_acc (x :: acc) l end. (** Reversing the order of a list. The list [ [a1; a2; ...; an] ] becomes [ [an; ...; a2; a1] ]. *) Definition reverse {A : Type} (l : list A) : list A := reverse_acc nil l. (** ** Getting Elements *) (** The head of a list is its first element. Returns [None] If the list is empty. *) Definition head {A : Type} (l : list A) : option A := match l with | nil => None | a :: _ => Some a end. (** The tail of a list is the list without its first element. *) Definition tail {A : Type} (l : list A) : list A := match l with | nil => nil | a :: m => m end. (** The last element of a list. If the list is empty, it returns [None]. *) Fixpoint last {A : Type} (l : list A) : option A := match l with | nil => None | a :: nil => Some a | _ :: l => last l end. (** The [n]-th element of a list. If the list is too short, it returns [None]. *) Fixpoint nth {A : Type} (l : list A) (n : nat) : option A := match n, l with | O, x :: _ => Some x | S n, _ :: l => nth l n | _, _ => None end. (** ** Removing Elements *) (** Remove the last element of a list and do nothing if it is empty. *) Fixpoint remove_last {A : Type} (l : list A) : list A := match l with | nil => nil | _ :: nil => nil | x :: l => x :: remove_last l end. (** ** Sequences *) (** Descending sequence of natural numbers starting from [n.-1] to [0]. *) Fixpoint seq_rev (n : nat) : list nat := match n with | O => nil | S n => n :: seq_rev n end. (** Ascending sequence of natural numbers [< n]. *) Definition seq (n : nat) : list nat := reverse (seq_rev n). (** ** Repeat *) (** Repeat an element [n] times. *) Fixpoint repeat {A : Type} (x : A) (n : nat) : list A := match n with | O => nil | S n => x :: repeat x n end. (** ** Membership Predicate *) (** The "In list" predicate *) Fixpoint InList@{i|} {A : Type@{i}} (a : A) (l : list A) : Type@{i} := match l with | nil => Empty | b :: m => (b = a) + InList a m end. (** ** Forall *) (** Apply a predicate to all elements of a list and take their conjunction. *) Fixpoint for_all@{i j|} {A : Type@{i}} (P : A -> Type@{j}) l : Type@{j} := match l with | nil => Unit | x :: l => P x /\ for_all P l end. (** ** Exists *) (** Apply a predicate to all elements of a list and take their disjunction. *) Fixpoint list_exists@{i j|} {A : Type@{i}} (P : A -> Type@{j}) l : Type@{j} := match l with | nil => Empty | x :: l => P x + list_exists P l end. Coq-HoTT-9.0/theories/Spaces/List/Paths.v000066400000000000000000000057111474641544500201630ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Trunc. Require Import Basics.Equivalences Types.Empty Types.Unit Types.Prod. Require Import Modalities.ReflectiveSubuniverse Truncations.Core. Require Import Spaces.List.Core. (** * Path spaces of lists *) (** This proof was adapted from a proof given in agda/cubical by Evan Cavallo. *) Section PathList. Context {A : Type}. (** We'll show that this type is equivalent to the path space [l = l'] in [list A]. *) Fixpoint ListEq (l l' : list A) : Type := match l, l' with | nil, nil => Unit | cons x xs, cons x' xs' => (x = x') * ListEq xs xs' | _, _ => Empty end. Global Instance reflexive_listeq : Reflexive ListEq. Proof. intros l. induction l as [| a l IHl]. - exact tt. - exact (idpath, IHl). Defined. Local Definition encode {l1 l2} (p : l1 = l2) : ListEq l1 l2. Proof. by destruct p. Defined. Local Definition decode {l1 l2} (q : ListEq l1 l2) : l1 = l2. Proof. induction l1 as [| a l1 IHl1 ] in l2, q |- *. 1: by destruct l2. destruct l2. 1: contradiction. destruct q as [p q]. exact (ap011 (cons (A:=_)) p (IHl1 _ q)). Defined. Local Definition decode_refl {l} : decode (reflexivity l) = idpath. Proof. induction l. 1: reflexivity. exact (ap02 (cons a) IHl). Defined. Local Definition decode_encode {l1 l2} (p : l1 = l2) : decode (encode p) = p. Proof. destruct p. apply decode_refl. Defined. (** By case analysis on both lists, it's easy to show that [ListEq] is [n.+1]-truncated if [A] is [n.+2]-truncated. *) Global Instance istrunc_listeq n {l1 l2} {H : IsTrunc n.+2 A} : IsTrunc n.+1 (ListEq l1 l2). Proof. induction l1 in l2 |- *. - destruct l2. 1,2: exact _. - destruct l2. 1: exact _. rapply istrunc_prod. Defined. (** The path space of lists is a retract of [ListEq], therefore it is [n.+1]-truncated if [ListEq] is [n.+1]-truncated. By the previous result, this holds when [A] is [n.+2]-truncated. *) Global Instance istrunc_list n {H : IsTrunc n.+2 A} : IsTrunc n.+2 (list A). Proof. apply istrunc_S. intros x y. rapply (inO_retract_inO n.+1 _ _ encode decode decode_encode). Defined. (** With a little more work, we can show that [ListEq] is also a retract of the path space. *) Local Definition encode_decode {l1 l2} (p : ListEq l1 l2) : encode (decode p) = p. Proof. induction l1 in l2, p |- *. 1: destruct l2; by destruct p. destruct l2. 1: by destruct p. cbn in p. destruct p as [r p]. apply path_prod. - simpl. destruct (decode p). by destruct r. - rhs_V nrapply IHl1. simpl. destruct (decode p). by destruct r. Defined. (** Giving us a way of characterising paths in lists. *) Definition equiv_path_list {l1 l2} : ListEq l1 l2 <~> l1 = l2 := equiv_adjointify decode encode decode_encode encode_decode. End PathList. Coq-HoTT-9.0/theories/Spaces/List/Theory.v000066400000000000000000001124321474641544500203550ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Trunc Basics.Equivalences Basics.Decidable Basics.Iff. Require Import Types.Paths Types.Unit Types.Prod Types.Sigma Types.Sum Types.Empty Types.Option. Require Export Spaces.List.Core Spaces.Nat.Core. Local Set Universe Minimization ToSet. Local Set Polymorphic Inductive Cumulativity. (** * Theory of Lists and List Operations *) (** In this file we collect lemmas about lists and their operations. We don't include those in [List.Core] so that file can stay lightweight on dependencies. *) (** We generally try to keep the order the same as the concepts appeared in [List.Core]. *) Local Open Scope list_scope. Local Open Scope nat_scope. (** ** Length *) (** A list of length zero must be the empty list. *) Definition length_0 {A : Type} (l : list A) (H : length l = 0) : l = nil. Proof. destruct l. - reflexivity. - discriminate. Defined. (** ** Concatenation *) (** Concatenating the empty list on the right is the identity. *) Definition app_nil {A : Type} (l : list A) : l ++ nil = l. Proof. induction l as [|a l IHl]. 1: reflexivity. simpl; f_ap. Defined. (** Associativity of list concatenation. *) Definition app_assoc {A : Type} (x y z : list A) : app x (app y z) = app (app x y) z. Proof. induction x as [|a x IHx] in |- *. - reflexivity. - exact (ap (cons a) IHx). Defined. (** The type of lists has a monoidal structure given by concatenation. *) Definition list_pentagon {A : Type} (w x y z : list A) : app_assoc w x (y ++ z) @ app_assoc (w ++ x) y z = ap (fun l => w ++ l) (app_assoc x y z) @ app_assoc w (x ++ y) z @ ap (fun l => l ++ z) (app_assoc w x y). Proof. symmetry. induction w as [|? w IHw] in x, y, z |- *. - simpl. apply equiv_p1_1q. lhs nrapply concat_p1. apply ap_idmap. - simpl. rhs_V nrapply ap_pp. rhs_V nrapply (ap (ap (cons a)) (IHw x y z)). rhs nrapply ap_pp. f_ap. { rhs nrapply ap_pp. f_ap. apply ap_compose. } lhs_V nrapply ap_compose. nrapply (ap_compose (fun l => l ++ z)). Defined. (** The length of a concatenated list is the sum of the lengths of the two lists. *) Definition length_app {A : Type} (l l' : list A) : length (l ++ l') = length l + length l'. Proof. induction l as [|a l IHl] using list_ind. 1: reflexivity. simpl. exact (ap S IHl). Defined. (** An element of a concatenated list is equivalently either in the first list or in the second list. *) Definition equiv_inlist_app {A : Type} (l l' : list A) (x : A) : InList x l + InList x l' <~> InList x (l ++ l'). Proof. induction l as [|a l IHl]. - apply sum_empty_l. - cbn; nrefine (_ oE equiv_sum_assoc _ _ _). by apply equiv_functor_sum_l. Defined. (** ** Folding *) (** A left fold over a concatenated list is equivalent to folding over the first followed by folding over the second. *) Lemma fold_left_app {A B : Type} (f : A -> B -> A) (l l' : list B) (i : A) : fold_left f (l ++ l') i = fold_left f l' (fold_left f l i). Proof. induction l in i |- *. 1: reflexivity. apply IHl. Defined. (** A right fold over a concatenated list is equivalent to folding over the second followed by folding over the first. *) Lemma fold_right_app {A B : Type} (f : B -> A -> A) (i : A) (l l' : list B) : fold_right f i (l ++ l') = fold_right f (fold_right f i l') l. Proof. induction l in i |- *. 1: reflexivity. exact (ap (f a) (IHl _)). Defined. (** ** Maps *) (** The length of a mapped list is the same as the length of the original list. *) Definition length_list_map {A B : Type} (f : A -> B) (l : list A) : length (list_map f l) = length l. Proof. induction l as [|x l IHl] using list_ind. - reflexivity. - simpl. exact (ap S IHl). Defined. (** A function applied to an element of a list is an element of the mapped list. *) Definition inlist_map {A B : Type} (f : A -> B) (l : list A) (x : A) : InList x l -> InList (f x) (list_map f l). Proof. simple_list_induction l y l IHl. 1: contradiction. intros [p | i]. - left. exact (ap f p). - right. exact (IHl i). Defined. (** An element of a mapped list is equal to the function applied to some element of the original list. *) Definition inlist_map' {A B : Type} (f : A -> B) (l : list A) (x : B) : InList x (list_map f l) -> { y : A & prod (f y = x) (InList y l) }. Proof. induction l as [|y l IHl]. 1: contradiction. intros [p | i]. - exact (y; (p, inl idpath)). - destruct (IHl i) as [y' [p i']]. exact (y'; (p, inr i')). Defined. (** Mapping a function over a concatenated list is the concatenation of the mapped lists. *) Definition list_map_app {A B : Type} (f : A -> B) (l l' : list A) : list_map f (l ++ l') = list_map f l ++ list_map f l'. Proof. induction l as [|a l IHl]. 1: reflexivity. simpl; f_ap. Defined. (** A function that acts as the identity on the elements of a list is the identity on the mapped list. *) Lemma list_map_id {A : Type} (f : A -> A) (l : list A) (Hf : forall x, InList x l -> f x = x) : list_map f l = l. Proof. induction l as [|x l IHl]. - reflexivity. - simpl. nrapply ap011. + exact (Hf _ (inl idpath)). + apply IHl. intros y Hy. apply Hf. by right. Defined. (** A [list_map] of a composition is the composition of the maps. *) Definition list_map_compose {A B C} (f : A -> B) (g : B -> C) (l : list A) : list_map (fun x => g (f x)) l = list_map g (list_map f l). Proof. induction l as [|a l IHl]. 1: reflexivity. simpl; f_ap. Defined. (** TODO: generalize as max *) (** The length of a [list_map2] is the same as the length of the original lists. *) Definition length_list_map2@{i j k|} {A : Type@{i}} {B : Type@{j}} {C : Type@{k}} (f : A -> B -> C) defl defr l1 l2 : length l1 = length l2 -> length (list_map2 f defl defr l1 l2) = length l1. Proof. intros p. induction l1 as [|x l1 IHl1] in l2, p |- * using list_ind@{i j}. - destruct l2. + reflexivity. + inversion p. - destruct l2. + inversion p. + cbn; f_ap. by apply IHl1, path_nat_succ. Defined. (** An element of a [list_map2] is the result of applying the function to some elements of the original lists. *) Definition inlist_map2@{i j k u | i <= u, j <= u, k <= u} {A : Type@{i}} {B : Type@{j}} {C : Type@{k}} (f : A -> B -> C) defl defr l1 l2 x : InList x (list_map2 f defl defr l1 l2) -> length l1 = length l2 -> { y : A & { z : B & prod@{k u} ((f y z) = x) (InList y l1 * InList z l2) } }. Proof. intros H p. induction l1 as [|y l1 IHl1] in l2, x, H, p |- * using list_ind@{i u}. - destruct l2. 1: contradiction. inversion p. - destruct l2 as [| z]. 1: inversion p. destruct H as [q | i]. 1: exact (y; z; (q, (inl idpath, inl idpath))). destruct (IHl1 l2 x i) as [y' [z' [q [r s]]]]. 1: apply path_nat_succ, p. exact (y'; z'; (q, (inr r, inr s))). Defined. (** [list_map2] is a [list_map] if the first list is a repeated value. *) Definition list_map2_repeat_l {A B C} (f : A -> B -> C) (x : A) l {defl defr} : list_map2 f defl defr (repeat x (length l)) l = list_map (f x) l. Proof. induction l as [|y l IHl]. - reflexivity. - cbn; f_ap. Defined. (** [list_map2] is a [list_map] if the second list is a repeated value. *) Definition list_map2_repeat_r {A B C} (f : A -> B -> C) (y : B) l {defl defr} : list_map2 f defl defr l (repeat y (length l)) = list_map (fun x => f x y) l. Proof. induction l as [|x l IHl]. - reflexivity. - cbn; f_ap. Defined. (** ** Reversal *) (** The length of [reverse_acc] is the sum of the lengths of the two lists. *) Definition length_reverse_acc@{i|} {A : Type@{i}} (acc l : list A) : length (reverse_acc acc l) = length acc + length l. Proof. symmetry. induction l as [|x l IHl] in acc |- * using list_ind@{i i}. - apply nat_add_zero_r. - rhs_V nrapply IHl. apply nat_add_succ_r. Defined. (** The length of [reverse] is the same as the length of the original list. *) Definition length_reverse {A : Type} (l : list A) : length (reverse l) = length l. Proof. rapply length_reverse_acc. Defined. (** The [list_map] of a [reverse_acc] is the [reverse_acc] of the [list_map] of the two lists. *) Definition list_map_reverse_acc {A B : Type} (f : A -> B) (l l' : list A) : list_map f (reverse_acc l' l) = reverse_acc (list_map f l') (list_map f l). Proof. revert l'; simple_list_induction l a l IHl; intro l'. 1: reflexivity. apply IHl. Defined. (** The [list_map] of a reversed list is the reversed [list_map]. *) Definition list_map_reverse {A B} (f : A -> B) (l : list A) : list_map f (reverse l) = reverse (list_map f l). Proof. nrapply list_map_reverse_acc. Defined. (** [reverse_acc] is the same as concatenating the reversed list with the accumulator. *) Definition reverse_acc_cons {A : Type} (l l' : list A) : reverse_acc l' l = reverse l ++ l'. Proof. induction l as [|a l IHl] in l' |- *. 1: reflexivity. lhs nrapply IHl. lhs nrapply (app_assoc _ [a]). f_ap; symmetry. apply IHl. Defined. (** The [reverse] of a [cons] is the concatenation of the [reverse] with the head. *) Definition reverse_cons {A : Type} (a : A) (l : list A) : reverse (a :: l) = reverse l ++ [a]. Proof. induction l as [|b l IHl] in a |- *. 1: reflexivity. rewrite IHl. rewrite <- app_assoc. cbn; apply reverse_acc_cons. Defined. (** The [reverse] of a concatenated list is the concatenation of the reversed lists in reverse order. *) Definition reverse_app {A : Type} (l l' : list A) : reverse (l ++ l') = reverse l' ++ reverse l. Proof. induction l as [|a l IHl] in l' |- *. 1: symmetry; apply app_nil. simpl. lhs nrapply reverse_cons. rhs nrapply ap. 2: nrapply reverse_cons. rhs nrapply app_assoc. nrapply (ap (fun l => l ++ [a])). exact (IHl l'). Defined. (** [reverse] is involutive. *) Definition reverse_reverse {A : Type} (l : list A) : reverse (reverse l) = l. Proof. induction l. 1: reflexivity. lhs nrapply ap. 1: nrapply reverse_cons. lhs nrapply reverse_app. exact (ap _ IHl). Defined. (** ** Getting elements *) (** A variant of [nth] that returns an element of the list and a proof that it is the [n]-th element. *) Definition nth_lt@{i|} {A : Type@{i}} (l : list A) (n : nat) (H : n < length l) : { x : A & nth l n = Some x }. Proof. induction l as [|a l IHa] in n, H |- * using list_ind@{i i}. 1: destruct (not_lt_zero_r _ H). destruct n. 1: by exists a. apply IHa. apply leq_pred'. exact H. Defined. (** A variant of [nth] that always returns an element when we know that the index is in the list. *) Definition nth' {A : Type} (l : list A) (n : nat) (H : n < length l) : A := pr1 (nth_lt l n H). (** The [nth'] element doesn't depend on the proof that [n < length l]. *) Definition nth'_nth' {A} (l : list A) (n : nat) (H H' : n < length l) : nth' l n H = nth' l n H'. Proof. apply ap, path_ishprop. Defined. (** Two equal lists have the same elements in the same positions. *) Definition nth'_path_list {A : Type} {l1 l2 : list A} (p : l1 = l2) {n : nat} (Hn1 : n < length l1) (Hn2 : n < length l2) : nth' l1 n Hn1 = nth' l2 n Hn2. Proof. destruct p. by apply nth'_nth'. Defined. (** The [nth'] element of a list is in the list. *) Definition inlist_nth'@{i|} {A : Type@{i}} (l : list A) (n : nat) (H : n < length l) : InList (nth' l n H) l. Proof. induction l as [|a l IHa] in n, H |- * using list_ind@{i i}. 1: destruct (not_lt_zero_r _ H). destruct n. 1: by left. right. apply IHa. Defined. (** The [nth'] element of a list is the same as the one given by [nth]. *) Definition nth_nth' {A} (l : list A) (n : nat) (H : n < length l) : nth l n = Some (nth' l n H). Proof. exact (nth_lt l n H).2. Defined. (** The [nth'] element of a [cons] indexed at [n.+1] is the same as the [nth'] element of the tail indexed at [n]. *) Definition nth'_cons {A : Type} (l : list A) (n : nat) (x : A) (H : n < length l) (H' : n.+1 < length (x :: l)) : nth' (x :: l) n.+1 H' = nth' l n H. Proof. apply isinj_some. nrefine (_^ @ _ @ _). 1,3: rapply nth_nth'. reflexivity. Defined. (** The index of an element in a list is the [n] such that the [nth'] element is the element. *) Definition index_of@{i|} {A : Type@{i}} (l : list A) (x : A) : InList x l -> sig@{Set i} (fun n : nat => { H : n < length l & nth' l n H = x }). Proof. induction l as [|a l IHl] using list_ind@{i i}. 1: intros x'; destruct x'. intros [| i]. - revert a p. snrapply paths_ind_r@{i i}. snrefine (exist@{i i} _ 0 _). snrefine (exist _ _ idpath). apply leq_succ. exact _. - destruct (IHl i) as [n [H H']]. snrefine (exist@{i i} _ n.+1 _). snrefine (_; _); cbn. 1: apply leq_succ, H. refine (_ @ H'). apply nth'_cons. Defined. (** The [nth] element of a map is the function applied optionally to the [nth] element of the original list. *) Definition nth_list_map@{i j|} {A : Type@{i}} {B : Type@{j}} (f : A -> B) (l : list A) (n : nat) : nth (list_map f l) n = functor_option f (nth l n). Proof. induction l as [|a l IHl] in n |- * using list_ind@{i j}. 1: by destruct n. destruct n. 1: reflexivity. apply IHl. Defined. (** The [nth'] element of a [list_map] is the function applied to the [nth'] element of the original list. *) Definition nth'_list_map@{i j|} {A : Type@{i}} {B : Type@{j}} (f : A -> B) (l : list A) (n : nat) (H : n < length l) (H' : n < length (list_map f l)) : nth' (list_map f l) n H' = f (nth' l n H). Proof. induction l as [|a l IHl] in n, H, H' |- * using list_ind@{i j}. 1: destruct (not_lt_zero_r _ H). destruct n. 1: reflexivity. apply IHl. Defined. (** The [nth'] element of a [list_map2] is the function applied to the [nth'] elements of the original lists. The length of the two lists is required to be the same. *) Definition nth'_list_map2 {A B C : Type} (f : A -> B -> C) (l1 : list A) (l2 : list B) (n : nat) defl defr (H : n < length l1) (H' : n < length l2) (H'' : n < length (list_map2 f defl defr l1 l2)) (p : length l1 = length l2) : f (nth' l1 n H) (nth' l2 n H') = nth' (list_map2 f defl defr l1 l2) n H''. Proof. revert l2 n defl defr H H' H'' p; simple_list_induction l1 a l1 IHl1; intros l2 n defl defr H H' H'' p. - destruct l2 as [|b l2]. + destruct (not_lt_zero_r _ H). + inversion p. - destruct l2 as [|b l2]. + inversion p. + destruct n. * reflexivity. * erewrite 3 nth'_cons. apply IHl1. by apply path_nat_succ. Defined. (** The [nth'] element of a [repeat] is the repeated value. *) Definition nth'_repeat@{i|} {A : Type@{i}} (x : A) (i n : nat) (H : i < length (repeat x n)) : nth' (repeat x n) i H = x. Proof. induction n as [|n IHn] in i, H |- * using nat_ind@{i}. 1: destruct (not_lt_zero_r _ H). destruct i. 1: reflexivity. apply IHn. Defined. (** Two lists are equal if their [nth'] elements are equal. *) Definition path_list_nth'@{i|} {A : Type@{i}} (l l' : list A) (p : length l = length l') : (forall n (H : n < length l), nth' l n H = nth' l' n (p # H)) -> l = l'. Proof. intros H. induction l as [|a l IHl] in l', p, H |- * using list_ind@{i i}. { destruct l'. - reflexivity. - discriminate. } destruct l' as [|a' l']. 1: discriminate. f_ap. - exact (H 0 _). - snrapply IHl. 1: by apply path_nat_succ. intros n Hn. snrefine ((nth'_cons l n a Hn _)^ @ _). 1: apply leq_succ, Hn. lhs nrapply H. nrapply nth'_cons. Defined. (** The [nth n] element of a concatenated list [l ++ l'] where [n < length l] is the [nth] element of [l]. *) Definition nth_app@{i|} {A : Type@{i}} (l l' : list A) (n : nat) (H : n < length l) : nth (l ++ l') n = nth l n. Proof. induction l as [|a l IHl] in l', n, H |- * using list_ind@{i i}. 1: destruct (not_lt_zero_r _ H). destruct n. 1: reflexivity. by apply IHl, leq_pred'. Defined. (** The [nth i] element where [pred (length l) = i] is the last element of the list. *) Definition nth_last {A : Type} (l : list A) (i : nat) (p : nat_pred (length l) = i) : nth l i = last l. Proof. destruct p. induction l as [|a l IHl]. 1: reflexivity. destruct l as [|b l]. 1: reflexivity. cbn; apply IHl. Defined. (** The last element of a list with an element appended is the appended element. *) Definition last_app {A : Type} (l : list A) (x : A) : last (l ++ [x]) = Some x. Proof. induction l as [|a l IHl] in x |- *. 1: reflexivity. destruct l. 1: reflexivity. cbn; apply IHl. Defined. (** ** Removing elements *) (** These functions allow surgery to be perfomed on a given list. *) (** *** Drop *) (** [drop n l] removes the first [n] elements of [l]. *) Fixpoint drop {A : Type} (n : nat) (l : list A) : list A := match n with | 0 => l | n.+1 => drop n (tail l) end. (** A [drop] of zero elements is the identity, by definition. *) Definition drop_0 {A : Type} (l : list A) : drop 0 l = l := idpath. (** A [drop] of one element is the tail of the list, by definition. *) Definition drop_1 {A : Type} (l : list A) : drop 1 l = tail l := idpath. (** A [drop] of the empty list is the empty list. *) Definition drop_nil {A : Type} (n : nat) : drop n (@nil A) = nil. Proof. by induction n. Defined. (** A [drop] of [n] elements with [length l <= n] is the empty list. *) Definition drop_length_leq@{i|} {A : Type@{i}} (n : nat) (l : list A) (H : length l <= n) : drop n l = nil. Proof. induction l as [|a l IHl] in H, n |- * using list_ind@{i i}. 1: apply drop_nil. destruct n. 1: destruct (not_lt_zero_r _ H). cbn; apply IHl. apply leq_pred'. exact H. Defined. (** The length of a [drop n] is the length of the original list minus [n]. *) Definition length_drop@{i|} {A : Type@{i}} (n : nat) (l : list A) : length (drop n l) = length l - n. Proof. induction l as [|a l IHl] in n |- * using list_ind@{i i}. 1: by rewrite drop_nil. destruct n. 1: reflexivity. exact (IHl n). Defined. (** An element of a [drop] is an element of the original list. *) Definition drop_inlist@{i|} {A : Type@{i}} (n : nat) (l : list A) (x : A) : InList x (drop n l) -> InList x l. Proof. intros H. induction l as [|a l IHl] in n, H, x |- * using list_ind@{i i}. 1: rewrite drop_nil in H; contradiction. destruct n. 1: exact H. right; nrapply (IHl _ _ H). Defined. (** *** Take *) (** [take n l] keeps the first [n] elements of [l] and returns [l] if [n >= length l]. *) Fixpoint take {A : Type} (n : nat) (l : list A) : list A := match n, l with | n.+1, x :: l => x :: take n l | _, _ => nil end. (** A [take] of zero elements is the empty list, by definition. *) Definition take_0 {A : Type} (l : list A) : take 0 l = nil := idpath. (** A [take] of the empty list is the empty list. *) Definition take_nil {A : Type} (n : nat) : take n (@nil A) = nil. Proof. by destruct n. Defined. (** A [take] of [n] elements with [length l <= n] is the original list. *) Definition take_length_leq@{i|} {A : Type@{i}} (n : nat) (l : list A) (H : length l <= n) : take n l = l. Proof. induction l as [|a l IHl] in H, n |- * using list_ind@{i i}. 1: apply take_nil. destruct n. 1: destruct (not_lt_zero_r _ H). cbn; f_ap. by apply IHl, leq_pred'. Defined. (** The length of a [take n] is the minimum of [n] and the length of the original list. *) Definition length_take@{i|} {A : Type@{i}} (n : nat) (l : list A) : length (take n l) = nat_min n (length l). Proof. induction l as [|a l IHl] in n |- * using list_ind@{i i}. { rewrite take_nil. rewrite nat_min_r. 1: reflexivity. cbn; exact _. } destruct n. 1: reflexivity. cbn; f_ap. Defined. (** The length of a [take] is less than or equal to the length of the list. *) Definition length_take_leq {A : Type} {n : nat} (l : list A) : length (take n l) <= length l := transport (fun x => x <= length l) (length_take n l)^ (leq_nat_min_r _ _). (** An element of a [take] is an element of the original list. *) Definition take_inlist@{i|} {A : Type@{i}} (n : nat) (l : list A) (x : A) : InList x (take n l) -> InList x l. Proof. intros H. induction l as [|a l IHl] in n, H, x |- * using list_ind@{i i}. 1: rewrite take_nil in H; contradiction. destruct n. { cbn in H. contradiction. } destruct H as [-> | H]. - left; reflexivity. - right; exact (IHl _ _ H). Defined. (** Applying a [take] twice with [m] and [n] is the same as applying it once with [nat_min m n]. *) Definition take_take_min {A : Type} {m n : nat} (l : list A) : take n (take m l) = take (nat_min n m) l. Proof. induction n in m, l |- *. 1: reflexivity. destruct m. 1: reflexivity. destruct l as [|a l']. 1: by rewrite !take_nil. cbn. apply ap, IHn. Defined. (** [take] is commutative in [n]. *) Definition take_comm {A : Type} {m n : nat} (l : list A) : take n (take m l) = take m (take n l). Proof. by rewrite !take_take_min, nat_min_comm. Defined. (** A [take n] does not change under concatenation if [n] is less than or equal to the length of the first list. *) Definition take_app {A : Type} {n : nat} (l1 l2 : list A) (hn : n <= length l1) : take n l1 = take n (l1 ++ l2). Proof. induction n in l1, l2, hn |- *. - reflexivity. - destruct l1 as [|a l1]. + contradiction (not_lt_zero_r _ hn). + cbn. apply ap, IHn, leq_pred', hn. Defined. (** *** Remove *) (** [remove n l] removes the [n]-th element of [l]. *) Definition remove {A : Type} (n : nat) (l : list A) : list A := take n l ++ drop n.+1 l. (** Removing the first element of a list is the tail of the list. *) Definition remove_0 {A : Type} (l : list A) : remove 0 l = tail l := idpath. (** Removing the [n]-th element of a list with [length l <= n] is the original list. *) Definition remove_length_leq {A : Type} (n : nat) (l : list A) (H : length l <= n) : remove n l = l. Proof. unfold remove. rewrite take_length_leq. 2: exact _. rewrite drop_length_leq. 2: exact _. apply app_nil. Defined. (** The length of a [remove n] is the length of the original list minus one. *) Definition length_remove@{i|} {A : Type@{i}} (n : nat) (l : list A) (H : n < length l) : length (remove n l) = nat_pred (length l). Proof. unfold remove. rewrite length_app@{i}. rewrite length_take. rewrite length_drop. rewrite nat_min_l. 2: exact (leq_trans _ H). rewrite <- nat_sub_l_add_r. 2: exact _. lhs nrapply nat_sub_succ_r. apply ap. apply nat_add_sub_cancel_l. Defined. (** An element of a [remove] is an element of the original list. *) Definition remove_inlist {A : Type} (n : nat) (l : list A) (x : A) : InList x (remove n l) -> InList x l. Proof. unfold remove. intros p. apply equiv_inlist_app in p. revert p. snrapply sum_rec. - apply take_inlist. - apply drop_inlist. Defined. (** *** Filter *) (** Produce the list of elements of a list that satisfy a decidable predicate. *) Fixpoint list_filter@{u v|} {A : Type@{u}} (l : list A) (P : A -> Type@{v}) (dec : forall x, Decidable (P x)) : list A := match l with | nil => nil | x :: l => if dec x then x :: list_filter l P dec else list_filter l P dec end. Definition inlist_filter@{u v k | u <= k, v <= k} {A : Type@{u}} (l : list A) (P : A -> Type@{v}) (dec : forall x, Decidable (P x)) (x : A) : iff@{u k k} (InList x (list_filter l P dec)) (InList x l /\ P x). Proof. simple_list_induction l a l IHl. - simpl. apply iff_inverse. apply iff_equiv. snrapply prod_empty_l@{v}. - simpl. nrapply iff_compose. 2: { apply iff_inverse. apply iff_equiv. exact (sum_distrib_r@{k k k _ _ _ k k} _ _ _). } destruct (dec a) as [p|p]. + simpl. snrapply iff_compose. 1: exact (sum (a = x) (prod (InList@{u} x l) (P x))). 1: split; apply functor_sum; only 1,3: exact idmap; apply IHl. split; apply functor_sum@{k k k k}; only 2,4: apply idmap. * intros []. exact (idpath, p). * exact fst. + nrapply iff_compose. 1: apply IHl. apply iff_inverse. apply iff_equiv. nrefine (equiv_compose'@{k k k} (sum_empty_l@{k} _) _). snrapply equiv_functor_sum'@{k k k k k k}. 2: exact equiv_idmap. apply equiv_to_empty. by intros [[] r]. Defined. Definition list_filter_app {A : Type} (l l' : list A) (P : A -> Type) (dec : forall x, Decidable (P x)) : list_filter (l ++ l') P dec = list_filter l P dec ++ list_filter l' P dec. Proof. simple_list_induction l a l IHl. - reflexivity. - simpl; destruct (dec a); trivial. simpl; f_ap. Defined. (** ** Sequences *) (** The length of a reverse sequence of [n] numbers is [n]. *) Definition length_seq_rev@{} (n : nat) : length (seq_rev n) = n. Proof. induction n as [|n IHn]. 1: reflexivity. cbn; f_ap. Defined. (** The length of a sequence of [n] numbers is [n]. *) Definition length_seq@{} (n : nat) : length (seq n) = n. Proof. lhs nrapply length_reverse. apply length_seq_rev. Defined. (** The reversed sequence of [n.+1] numbers is the [n] followed by the rest of the reversed sequence. *) Definition seq_rev_cons@{} (n : nat) : seq_rev n.+1 = n :: seq_rev n := idpath. (** The sequence of [n.+1] numbers is the sequence of [n] numbers concatenated with [[n]]. *) Definition seq_succ@{} (n : nat) : seq n.+1 = seq n ++ [n]. Proof. apply reverse_cons. Defined. (** Alternate definition of [seq_rev] that keeps the proofs of the entries being [< n]. *) Definition seq_rev'@{} (n : nat) : list {k : nat & k < n}. Proof. transparent assert (f : (forall n, {k : nat & k < n} -> {k : nat & k < n.+1})). { intros m. snrapply (functor_sigma idmap). intros k H. exact (leq_succ_r H). } induction n as [|n IHn]. 1: exact nil. nrefine ((n; _) :: list_map (f n) IHn). exact _. Defined. (** Alternate definition of [seq] that keeps the proofs of the entries being [< n]. *) Definition seq'@{} (n : nat) : list {k : nat & k < n} := reverse (seq_rev' n). (** The length of [seq_rev' n] is [n]. *) Definition length_seq_rev'@{} (n : nat) : length (seq_rev' n) = n. Proof. induction n as [|n IHn]. 1: reflexivity. cbn; f_ap. lhs nrapply length_list_map. exact IHn. Defined. (** The length of [seq' n] is [n]. *) Definition length_seq'@{} (n : nat) : length (seq' n) = n. Proof. lhs nrapply length_reverse. apply length_seq_rev'. Defined. (** The [list_map] of first projections on [seq_rev' n] is [seq_rev n]. *) Definition seq_rev_seq_rev'@{} (n : nat) : list_map pr1 (seq_rev' n) = seq_rev n. Proof. induction n as [|n IHn]. 1: reflexivity. simpl; f_ap. lhs_V nrapply list_map_compose. apply IHn. Defined. (** The [list_map] of first projections on [seq' n] is [seq n]. *) Definition seq_seq'@{} (n : nat) : list_map pr1 (seq' n) = seq n. Proof. lhs nrapply list_map_reverse_acc. apply (ap reverse). apply seq_rev_seq_rev'. Defined. (** The [nth] element of a [seq_rev] is [n - i.+1]. *) Definition nth_seq_rev@{} {n i} (H : i < n) : nth (seq_rev n) i = Some (n - i.+1). Proof. induction i as [|i IHi] in n, H |- *. - induction n. 1: destruct (not_lt_zero_r _ H). cbn; by rewrite nat_sub_zero_r. - induction n as [|n IHn]. 1: destruct (not_lt_zero_r _ H). by apply IHi, leq_pred'. Defined. (** The [nth] element of a [seq] is [i]. *) Definition nth_seq@{} {n i} (H : i < n) : nth (seq n) i = Some i. Proof. induction n. 1: destruct (not_lt_zero_r _ H). rewrite seq_succ. destruct (dec (i < n)) as [H'|H']. - lhs nrapply nth_app. 1: by rewrite length_seq. by apply IHn. - apply geq_iff_not_lt in H'. apply leq_pred' in H. destruct (leq_antisym H H'). lhs nrapply nth_last. { rewrite length_app. rewrite nat_add_comm. apply length_seq. } nrapply last_app. Defined. (** The [nth'] element of a [seq'] is [i]. *) Definition nth'_seq'@{} (n i : nat) (H : i < length (seq' n)) : (nth' (seq' n) i H).1 = i. Proof. unshelve lhs_V nrapply nth'_list_map. 1: by rewrite length_list_map. unshelve lhs nrapply (ap011D (fun x y => nth' x _ y) _ idpath). 2: apply seq_seq'. apply isinj_some. lhs_V nrapply nth_nth'. apply nth_seq. by rewrite length_seq' in H. Defined. Definition inlist_seq@{} (n : nat) x : InList x (seq n) <~> (x < n). Proof. simple_induction n n IHn. { symmetry; apply equiv_to_empty. apply not_lt_zero_r. } refine (_ oE equiv_transport _ (seq_succ _)). nrefine (_ oE (equiv_inlist_app _ _ _)^-1). nrefine (_ oE equiv_functor_sum' (B':=x = n) IHn _). 2: { simpl. exact (equiv_path_inverse _ _ oE sum_empty_r@{Set} _). } nrefine (_ oE equiv_leq_lt_or_eq^-1). rapply equiv_iff_hprop. Defined. (** Turning a finite sequence into a list. *) Definition Build_list {A : Type} (n : nat) (f : forall (i : nat), (i < n) -> A) : list A := list_map (fun '(i; Hi) => f i Hi) (seq' n). Definition length_Build_list {A : Type} (n : nat) (f : forall (i : nat), (i < n) -> A) : length (Build_list n f) = n. Proof. lhs nrapply length_list_map. apply length_seq'. Defined. Definition nth'_Build_list {A : Type} {n : nat} (f : forall (i : nat), (i < n) -> A) {i : nat} (Hi : i < n) (Hi' : i < length (Build_list n f)) : nth' (Build_list n f) i Hi' = f i Hi. Proof. unshelve lhs snrefine (nth'_list_map _ _ _ (_^ # Hi) _). 1: nrapply length_seq'. snrapply ap011D. 1: nrapply nth'_seq'. rapply path_ishprop. Defined. (** Restriction of an infinite sequence to a list of specified length. *) Definition list_restrict {A : Type} (s : nat -> A) (n : nat) : list A := Build_list n (fun m _ => s m). Definition length_list_restrict {A : Type} (s : nat -> A) (n : nat) : length (list_restrict s n) = n := length_Build_list _ _. (** [nth'] of the restriction of a sequence is the corresponding term of the sequence. *) Definition nth'_list_restrict {A : Type} (s : nat -> A) (n : nat) {i : nat} (Hi : i < n) (Hi' : i < length (list_restrict s n)) : nth' (list_restrict s n) i Hi' = s i. Proof. unshelve lhs snrefine (nth'_list_map _ _ _ (_^ # Hi) _). - nrapply length_seq'. - exact (ap s (nth'_seq' _ _ _)). Defined. (** ** Repeat *) (** The length of a repeated list is the number of repetitions. *) Definition length_repeat@{i|} {A : Type@{i}} (n : nat) (x : A) : length (repeat x n) = n. Proof. induction n using nat_ind@{i}. - reflexivity. - exact (ap S IHn). Defined. (** An element of a repeated list is equal to the repeated element. *) Definition inlist_repeat@{i|} {A : Type@{i}} (n : nat) (x y : A) : InList y (repeat x n) -> y = x. Proof. induction n as [|n IHn]. 1:contradiction. intros [p | i]. - by symmetry. - by apply IHn. Defined. (** ** Forall *) (** If a predicate holds for all elements of a list, the the [for_all] predicate holds for the list. *) Definition for_all_inlist {A : Type} (P : A -> Type) l : (forall x, InList x l -> P x) -> for_all P l. Proof. simple_list_induction l h t IHl; intros H; cbn; trivial; split. - apply H. by left. - apply IHl. intros y i. apply H. by right. Defined. (** Conversely, if [for_all P l] then each element of the list satisfies [P]. *) Definition inlist_for_all {A : Type} {P : A -> Type} (l : list A) : for_all P l -> forall x, InList x l -> P x. Proof. simple_list_induction l x l IHl. - contradiction. - intros [Hx Hl] y [-> | i]. + exact Hx. + apply IHl. 1: exact Hl. exact i. Defined. (** If a predicate [P] implies a predicate [Q] composed with a function [f], then [for_all P l] implies [for_all Q (list_map f l)]. *) Definition for_all_list_map {A B : Type} (P : A -> Type) (Q : B -> Type) (f : A -> B) (Hf : forall x, P x -> Q (f x)) : forall l, for_all P l -> for_all Q (list_map f l). Proof. simple_list_induction l x l IHl; simpl; trivial. intros [Hx Hl]. split; auto. Defined. (** A variant of [for_all_map P Q f] where [Q] is [P o f]. *) Definition for_all_list_map' {A B : Type} (P : B -> Type) (f : A -> B) : forall l, for_all (P o f) l -> for_all P (list_map f l). Proof. by apply for_all_list_map. Defined. (** If a predicate [P] and a predicate [Q] together imply a predicate [R], then [for_all P l] and [for_all Q l] together imply [for_all R l]. There are also some side conditions for the default elements. *) Lemma for_all_list_map2 {A B C : Type} (P : A -> Type) (Q : B -> Type) (R : C -> Type) (f : A -> B -> C) (Hf : forall x y, P x -> Q y -> R (f x y)) def_l (Hdefl : forall l1, for_all P l1 -> for_all R (def_l l1)) def_r (Hdefr : forall l2, for_all Q l2 -> for_all R (def_r l2)) (l1 : list A) (l2 : list B) : for_all P l1 -> for_all Q l2 -> for_all R (list_map2 f def_l def_r l1 l2). Proof. revert l2; simple_list_induction l1 x l1 IHl1; intro l2. - destruct l2 as [|y l2]; cbn; auto. - simpl. destruct l2 as [|y l2]; intros [Hx Hl1]; [intros _ | intros [Hy Hl2] ]; simpl; auto. apply Hdefl. simpl; auto. Defined. (** A simpler variant of [for_all_map2] where both lists have the same length and the side conditions on the default elements can be avoided. *) Definition for_all_list_map2' {A B C : Type} (P : A -> Type) (Q : B -> Type) (R : C -> Type) (f : A -> B -> C) (Hf : forall x y, P x -> Q y -> R (f x y)) {def_l def_r} {l1 : list A} {l2 : list B} (p : length l1 = length l2) : for_all P l1 -> for_all Q l2 -> for_all R (list_map2 f def_l def_r l1 l2). Proof. revert l2 p; simple_list_induction l1 x l1 IHl1; intros l2 p. - destruct l2. + reflexivity. + discriminate. - destruct l2 as [|y l2]. + discriminate. + intros [Hx Hl1] [Hy Hl2]. split. * by apply Hf. * apply IHl1; trivial. apply path_nat_succ. exact p. Defined. (** The left fold of [f] on a list [l] for which [for_all Q l] satisfies [P] if [P] and [Q] imply [P] composed with [f]. *) Lemma fold_left_preserves {A B : Type} (P : A -> Type) (Q : B -> Type) (f : A -> B -> A) (Hf : forall x y, P x -> Q y -> P (f x y)) (acc : A) (Ha : P acc) (l : list B) (Hl : for_all Q l) : P (fold_left f l acc). Proof. revert acc Ha Hl; simple_list_induction l x l IHl; intros acc Ha Hl. - exact Ha. - simpl. destruct Hl as [Qx Hl]. apply IHl; auto. Defined. (** [for_all] preserves the truncation predicate. *) Definition istrunc_for_all {A : Type} {n : trunc_index} (P : A -> Type) (l : list A) : for_all (fun x => IsTrunc n (P x)) l -> IsTrunc n (for_all P l). Proof. induction l as [|x l IHl]; simpl. - destruct n; exact _. - intros [Hx Hl]. apply IHl in Hl. exact _. Defined. Global Instance istrunc_for_all' {A : Type} {n : trunc_index} (P : A -> Type) (l : list A) `{forall x, IsTrunc n (P x)} : IsTrunc n (for_all P l). Proof. by apply istrunc_for_all, for_all_inlist. Defined. (** If a predicate holds for an element, then it holds [for_all] the elements of the repeated list. *) Definition for_all_repeat {A : Type} {n : nat} (P : A -> Type) (x : A) : P x -> for_all P (repeat x n). Proof. intros H. induction n as [|n IHn]. 1: exact tt. exact (H, IHn). Defined. (** We can form a list of pairs of a sigma type given a list and a for_all predicate over it. *) Definition list_sigma {A : Type} (P : A -> Type) (l : list A) (p : for_all P l) : list {x : A & P x}. Proof. induction l as [|x l IHl] in p |- *. 1: exact nil. destruct p as [Hx Hl]. exact ((x; Hx) :: IHl Hl). Defined. (** The length of a list of sigma types is the same as the original list. *) Definition length_list_sigma {A : Type} {P : A -> Type} {l : list A} {p : for_all P l} : length (list_sigma P l p) = length l. Proof. revert p; simple_list_induction l x l IHl; intro p. 1: reflexivity. destruct p as [Hx Hl]. cbn; f_ap. apply IHl. Defined. (** If a predicate [P] is decidable then so is [for_all P]. *) Global Instance decidable_for_all {A : Type} (P : A -> Type) `{forall x, Decidable (P x)} (l : list A) : Decidable (for_all P l). Proof. simple_list_induction l x l IHl; exact _. Defined. (** If a predicate [P] is decidable then so is [list_exists P]. *) Global Instance decidable_list_exists {A : Type} (P : A -> Type) `{forall x, Decidable (P x)} (l : list A) : Decidable (list_exists P l). Proof. simple_list_induction l x l IHl; exact _. Defined. Definition inlist_list_exists {A : Type} (P : A -> Type) (l : list A) : list_exists P l -> exists (x : A), InList x l /\ P x. Proof. simple_list_induction l x l IHl. 1: done. simpl. intros [Px | ex]. - exists x. by split; [left|]. - destruct (IHl ex) as [x' [H Px']]. exists x'. by split; [right|]. Defined. Definition list_exists_inlist {A : Type} (P : A -> Type) (l : list A) : forall (x : A), InList x l -> P x -> list_exists P l. Proof. simple_list_induction l x l IHl. 1: trivial. simpl; intros y H p; revert H. apply functor_sum. - exact (fun r => r^ # p). - intros H. by apply (IHl y). Defined. Definition list_exists_seq {n : nat} (P : nat -> Type) (H : forall k, P k -> k < n) : (exists k, P k) <-> list_exists P (seq n). Proof. split. - intros [k p]. snrapply (list_exists_inlist P _ k _ p). apply inlist_seq, H. exact p. - intros H1. apply inlist_list_exists in H1. destruct H1 as [k [Hk p]]. exists k. exact p. Defined. (** An upper bound on witnesses of a decidable predicate makes the sigma type decidable. *) Definition decidable_exists_nat (n : nat) (P : nat -> Type) (H1 : forall k, P k -> k < n) (H2 : forall k, Decidable (P k)) : Decidable (exists k, P k). Proof. nrapply decidable_iff. 1: apply iff_inverse; nrapply list_exists_seq. 1: exact H1. exact _. Defined. (** A common special case. See also [decidable_search] in BoundedSearch.v for a similar result with different dependencies. *) Definition decidable_exists_bounded_nat (n : nat) (P : nat -> Type) (H2 : forall k, Decidable (P k)) : Decidable { k : nat & prod (k < n) (P k) } := decidable_exists_nat n _ (fun k => fst) _. Coq-HoTT-9.0/theories/Spaces/Nat.v000066400000000000000000000003301474641544500167030ustar00rootroot00000000000000(** Nat.Paths has many dependencies, so if you do not need it, it is better to explicitly require only those files that you need. *) Require Export Nat.Core. Require Export Nat.Arithmetic. Require Export Nat.Paths. Coq-HoTT-9.0/theories/Spaces/Nat/000077500000000000000000000000001474641544500165205ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/Nat/Arithmetic.v000066400000000000000000000205461474641544500210070ustar00rootroot00000000000000Require Import Basics. Require Import Spaces.Nat.Core. Local Set Universe Minimization ToSet. Local Close Scope trunc_scope. Local Open Scope nat_scope. (** TODO: The results in this file are in the process of being moved over to Core.v *) (** TODO: move, rename *) Proposition nataddsub_comm_ineq_lemma (n m : nat) : n.+1 - m <= (n - m).+1. Proof. revert m. simple_induction n n IHn. - simple_induction m m IHm; exact _. - intro m; simple_induction m m IHm. + apply leq_refl. + apply IHn. Defined. (** TODO: move, rename *) Proposition nataddsub_comm_ineq (n m k : nat) : (n + k) - m <= (n - m) + k. Proof. simple_induction k k IHk. - destruct (nat_add_zero_r n)^, (nat_add_zero_r (n - m))^; constructor. - destruct (nat_add_succ_r n k)^. refine (leq_trans (nataddsub_comm_ineq_lemma (n+k) m) _). destruct (nat_add_succ_r (n - m) k)^. by apply leq_succ. Defined. (** TODO: move, rename *) Proposition nat_sub_add_ineq (n m : nat) : n <= n - m + m. Proof. destruct (@leq_dichotomy m n) as [l | gt]. - rewrite <- nat_sub_l_add_l; trivial. destruct (nat_add_sub_cancel_r n m)^. apply leq_refl; done. - apply leq_lt in gt. destruct (equiv_nat_sub_leq _)^. assumption. Defined. (** TODO: move, rename *) Proposition i_lt_n_sum_m (n m i : nat) : i < n - m -> m <= n. Proof. revert m i; simple_induction n n IHn. - intros m i l. simpl in l. contradiction (not_lt_zero_r _ _). - intros m i l. destruct m. + apply leq_zero_l. + apply leq_succ. simpl in l. apply (IHn m i l). Defined. (** TODO: move, rename *) Proposition predeqminus1 { n : nat } : n - 1 = nat_pred n. Proof. simple_induction' n. - reflexivity. - apply nat_sub_zero_r. Defined. (** TODO: move, rename *) Proposition predn_leq_n (n : nat) : nat_pred n <= n. Proof. destruct n; exact _. Defined. (** TODO: move, rename *) Proposition pred_equiv (k n : nat) : k < n -> k < S (nat_pred n). Proof. intro ineq; destruct n. - contradiction (not_lt_zero_r _ _). - assumption. Defined. (** TODO: move, rename *) Proposition n_leq_pred_Sn (n : nat) : n <= S (nat_pred n). Proof. destruct n; exact _. Defined. (** TODO: move, rename *) Proposition leq_implies_pred_lt (i n k : nat) : (n > i) -> n <= k -> nat_pred n < k. Proof. intro ineq; destruct n. - contradiction (not_lt_zero_r i). - intro; assumption. Defined. (** TODO: move, rename *) Proposition pred_lt_implies_leq (n k : nat) : nat_pred n < k -> n <= k. Proof. intro l; destruct n. - apply leq_zero_l. - assumption. Defined. (** TODO: move, rename *) Proposition lt_implies_pred_geq (i j : nat) : i < j -> i <= nat_pred j. Proof. intro l; apply leq_pred in l; assumption. Defined. (** TODO: move, rename *) Proposition j_geq_0_lt_implies_pred_geq (i j k : nat) : i < j -> k.+1 <= j -> k <= nat_pred j. Proof. intros l ineq. destruct j. - contradiction (not_lt_zero_r i). - by simpl; apply leq_pred'. Defined. (** TODO: move, rename *) Proposition pred_gt_implies_lt (i j : nat) : i < nat_pred j -> i.+1 < j. Proof. intros ineq. assert (H := leq_succ ineq). assert (i < j) as X. { apply (@lt_lt_leq_trans _ (nat_pred j) _); [assumption | apply predn_leq_n]. } by rewrite <- (nat_succ_pred' j i). Defined. (** TODO: move, rename *) Proposition pred_preserves_lt {i n: nat} (p : i < n) m : (n < m) -> (nat_pred n < nat_pred m). Proof. intro l. apply leq_pred'. destruct (symmetric_paths _ _ (nat_succ_pred' n i _)). set (k := transitive_lt i n m p l). destruct (symmetric_paths _ _ (nat_succ_pred' m i _)). assumption. Defined. (** TODO: move, rename *) Proposition sub_less { n k : nat } : n - k <= n. Proof. revert k. simple_induction n n IHn. - intros; apply leq_zero_l. - destruct k. + apply leq_refl. + simpl; apply (@leq_trans _ n _); [ apply IHn | apply leq_succ_r, leq_refl]. Defined. (** TODO: move, rename *) Proposition sub_less_strict { n k : nat } : 0 < n -> 0 < k -> n - k < n. Proof. intros l l'. unfold "<". destruct k, n; try (contradiction (not_lt_zero_r _ _)). simpl; apply leq_succ, sub_less. Defined. (** TODO: move, rename *) Proposition n_leq_m_n_leq_plus_m_k (n m k : nat) : n <= m -> n <= m + k. Proof. intro l; apply (leq_trans l); exact (leq_add_r m k). Defined. (** This inductive type is defined because it lets you loop from [i = 0] up to [i = n] by structural induction on a proof of [increasing_geq n 0]. With the existing [leq] type and the inductive structure of [n], it is easier and more natural to loop downwards from [i = n] to [i = 0], but harder to find the least natural number in the interval $[0,n]$ satisfying a given property. *) Local Unset Elimination Schemes. Inductive increasing_geq (n : nat) : nat -> Type0 := | increasing_geq_n : increasing_geq n n | increasing_geq_S (m : nat) : increasing_geq n m.+1 -> increasing_geq n m. Scheme increasing_geq_ind := Induction for increasing_geq Sort Type. Scheme increasing_geq_rec := Minimality for increasing_geq Sort Type. Definition increasing_geq_rect := increasing_geq_rec. Local Set Elimination Schemes. Proposition increasing_geq_S_n (n m : nat) : increasing_geq n m -> increasing_geq n.+1 m.+1. Proof. intro a. induction a. - constructor. - by constructor. Defined. Proposition increasing_geq_n_0 (n : nat) : increasing_geq n 0. Proof. simple_induction n n IHn. - constructor. - induction IHn. + constructor; by constructor. + constructor; by assumption. Defined. Lemma increasing_geq_minus (n k : nat) : increasing_geq n (n - k). Proof. simple_induction k k IHk. - destruct (symmetric_paths _ _ (nat_sub_zero_r n)); constructor. - destruct (@leq_dichotomy n k) as [l | g]. + destruct (equiv_nat_sub_leq _)^ in IHk. apply leq_succ_r in l. destruct (equiv_nat_sub_leq _)^. exact IHk. + change k.+1 with (1 + k). destruct (nat_add_comm k 1). destruct (symmetric_paths _ _ (nat_sub_r_add n k 1)). destruct (symmetric_paths _ _ (@predeqminus1 (n - k))). apply increasing_geq_S. unfold ">", "<" in *. apply equiv_lt_lt_sub in g. by (destruct (symmetric_paths _ _ (nat_succ_pred (n - k) _))). Defined. Lemma ineq_sub' (n k : nat) : k < n -> n - k = (n - k.+1).+1. Proof. intro ineq. destruct n. - contradiction (not_lt_zero_r k). - change (n.+1 - k.+1) with (n - k). apply leq_pred' in ineq. by apply nat_sub_succ_l. Defined. Lemma ineq_sub (n m : nat) : n <= m -> m - (m - n) = n. Proof. revert m; simple_induction n n IHn. - intros. destruct (symmetric_paths _ _ (nat_sub_zero_r m)), (symmetric_paths _ _ (nat_sub_cancel m)); reflexivity. - intros m ineq. change (m - n.+1) with (m - (1 + n)). (destruct (nat_add_comm n 1)). destruct (symmetric_paths _ _ (nat_sub_r_add m n 1)). destruct (nat_succ_pred (m - n) (equiv_lt_lt_sub _ _ ineq)); simpl; destruct (symmetric_paths _ _ (nat_sub_zero_r (nat_pred (m - n)))). assert (0 < m - n) as dp by exact (equiv_lt_lt_sub _ _ ineq). assert (nat_pred (m - n) < m) as sh by ( unfold "<"; destruct (symmetric_paths _ _ (nat_succ_pred _ _)); exact sub_less). destruct (symmetric_paths _ _ (ineq_sub' _ _ _)). destruct (symmetric_paths _ _ (nat_succ_pred _ _)). apply (ap S), IHn, leq_succ_l, ineq. Defined. Proposition leq_equivalent (n m : nat) : n <= m <-> increasing_geq m n. Proof. split. - intro ineq. induction ineq. + constructor. + apply increasing_geq_S_n in IHineq; constructor; assumption. - intro a. induction a. + constructor. + exact (leq_succ_l _). Defined. (** TODO: remove *) (** This tautology accepts a (potentially opaqued or QED'ed) proof of [n <= m], and returns a transparent proof which can be computed with (i.e., one can loop from n to m) *) Definition leq_wrapper {n m : nat} : n <= m -> n <= m. Proof. intro ineq. destruct (@leq_dichotomy n m) as [l | g]. - exact l. - contradiction (lt_irrefl m (lt_lt_leq_trans g ineq)). Defined. Proposition symmetric_rel_total_order (R : nat -> nat -> Type) {p : Symmetric R} {p' : Reflexive R} : (forall n m : nat, n < m -> R n m) -> (forall n m : nat, R n m). Proof. intros A n m. destruct (@leq_dichotomy m n) as [m_leq_n | m_gt_n]. - apply symmetry. destruct m_leq_n. + apply reflexivity. + apply A. apply leq_succ. assumption. - apply A, m_gt_n. Defined. Coq-HoTT-9.0/theories/Spaces/Nat/Binomial.v000066400000000000000000000127651474641544500204540ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Decidable Spaces.Nat.Core Spaces.Nat.Division Spaces.Nat.Factorial Tactics.EvalIn. Local Set Universe Minimization ToSet. Local Unset Elimination Schemes. Local Open Scope nat_scope. (** * Binomial coefficients *) (** ** Definition *) (** The binomial coefficient [nat_choose n m] is the number of ways to choose [m] elements from a set of [n] elements. We define it recursively using Pascal's identity. We use nested [Fixpoint]s in order to get a function that computes definitionally on the edge cases as well as the inductive case. *) (** We separate out this helper result to prevent Coq from unfolding things into a larger term. This computes [n] choose [m.+1] given a function [f] that computes [n] choose [m]. *) Fixpoint nat_choose_step n f := match n with | 0 => 0 | S n' => f n' + nat_choose_step n' f end. Fixpoint nat_choose (n m : nat) {struct m} : nat := match m with | 0 => 1 | S m' => nat_choose_step n (fun n => nat_choose n m') end. (** We make sure we never unfold binomial coefficients with [simpl] or [cbn] since the terms do not look good. Instead, we should use lemmas we prove about it to make proofs clearer to read. *) Arguments nat_choose n m : simpl never. (** ** Properties *) (** The three defining properties of [nat_choose] hold definitionally. *) (** By definition, we have Pascal's identity. *) Definition nat_choose_succ@{} n m : nat_choose n.+1 m.+1 = nat_choose n m + nat_choose n m.+1 := idpath. (** There is only one way to choose [0] elements from any number of elements. *) Definition nat_choose_zero_r@{} n : nat_choose n 0 = 1 := idpath. (** There are no ways to choose a non-zero number of elements from [0] elements. *) Definition nat_choose_zero_l@{} m : nat_choose 0 m.+1 = 0 := idpath. (** The binomial coefficient is zero if [m] is greater than [n]. *) Definition nat_choose_lt@{} n m : n < m -> nat_choose n m = 0. Proof. revert m; induction n; hnf; intros m H; destruct H. 1, 2: reflexivity. 1, 2: rewrite_refl nat_choose_succ; exact (ap011 nat_add (IHn _ _) (IHn _ _)). Defined. (** There is only one way to choose [n] elements from [n] elements. *) Definition nat_choose_diag@{} n : nat_choose n n = 1. Proof. induction n as [|n IHn]; only 1: reflexivity. rewrite_refl nat_choose_succ. rhs_V nrapply nat_add_zero_r. nrapply ap011. - exact IHn. - rapply nat_choose_lt. Defined. (** There are [n] ways to choose [1] element from [n] elements. *) Definition nat_choose_one_r@{} n : nat_choose n 1 = n. Proof. induction n as [|n IHn]; only 1: reflexivity. rewrite_refl nat_choose_succ. exact (ap nat_succ IHn). Defined. (** There are [n.+1] ways to choose [n] elements from [n.+1] elements. *) Definition nat_choose_succ_l_diag@{} n : nat_choose n.+1 n = n.+1. Proof. induction n as [|n IHn]; only 1: reflexivity. rewrite_refl nat_choose_succ. rhs_V nrapply (nat_add_comm _ 1). nrapply ap011. - exact IHn. - apply nat_choose_diag. Defined. (** The binomial coefficients can be written as a quotient of factorials. This is typically used as a definition of the binomial coefficients. *) Definition nat_choose_factorial@{} n m : m <= n -> nat_choose n m = factorial n / (factorial m * factorial (n - m)). Proof. revert n m; apply nat_double_ind_leq; intro n. (* The case when [m = 0]. *) { rewrite nat_mul_one_l. rewrite nat_sub_zero_r. symmetry; rapply nat_div_cancel. } (* The case when [m = n]. *) { rewrite nat_sub_cancel. rewrite nat_mul_one_r. rewrite nat_div_cancel. 1: nrapply nat_choose_diag. exact _. } (* The case with [n.+1] and [m.+1] with [m < n] and an induction hypothesis. *) intros m H IHn. rewrite_refl nat_choose_succ. rewrite 2 IHn. 2,3: exact _. rewrite <- (nat_div_cancel_mul_l _ _ m.+1). 2: exact _. rewrite nat_mul_assoc. rewrite <- nat_factorial_succ. rewrite <- (nat_div_cancel_mul_l (factorial n) _ (n - m)). 2: rapply equiv_lt_lt_sub. rewrite nat_mul_assoc. rewrite (nat_mul_comm (n - m) (factorial m.+1)). rewrite <- nat_mul_assoc. rewrite nat_sub_succ_r. rewrite <- nat_factorial_pred. 2: rapply equiv_lt_lt_sub. lhs_V nrapply nat_div_dist. - rewrite nat_factorial_succ. rewrite <- nat_mul_assoc. exact _. - rewrite <- nat_dist_r. rewrite nat_add_succ_l. rewrite nat_add_sub_r_cancel. 2: exact _. rewrite <- nat_factorial_succ. reflexivity. Defined. (** Another recursive property of the binomial coefficients. To choose [m+1] elements from a set of size [n+1], one has [n+1] choices for the first element and then can make the remaining [m] choices from the remaining [n] elements. This overcounts by a factor of [m+1], since there are [m+1] elements that could have been called the "first" element. *) Definition nat_choose_succ_mul@{} n m : nat_choose n.+1 m.+1 = (n.+1 * nat_choose n m) / m.+1. Proof. destruct (leq_dichotomy m n) as [H | H]. 2: { rewrite 2 nat_choose_lt; only 2, 3: exact _. rewrite nat_mul_zero_r. symmetry; apply nat_div_zero_l. } rewrite 2 nat_choose_factorial. 2,3: exact _. rewrite nat_div_mul_l. 2: exact _. rewrite nat_div_div_l. by rewrite (nat_mul_comm _ m.+1), nat_mul_assoc. Defined. (** The binomial coefficients are symmetric about the middle of the range [0 <= n]. *) Definition nat_choose_sub@{} n m : m <= n -> nat_choose n m = nat_choose n (n - m). Proof. intros H. rewrite 2 nat_choose_factorial. 2,3: exact _. rewrite nat_sub_sub_cancel_r. 2: exact _. by rewrite nat_mul_comm. Defined. Coq-HoTT-9.0/theories/Spaces/Nat/Core.v000066400000000000000000001313271474641544500176060ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Decidable Basics.Trunc Basics.Equivalences Basics.Nat Basics.Classes Basics.Iff Types.Prod Types.Sum Types.Sigma. Export Basics.Nat. Local Set Universe Minimization ToSet. Local Unset Elimination Schemes. (** * Natural numbers *) (** We want to close the trunc_scope so that notations from there don't conflict here. *) Local Close Scope trunc_scope. Local Open Scope nat_scope. (** ** Basic operations on naturals *) (** *** Iteration *) (** [n]th iteration of the function [f : A -> A]. We have definitional equalities [nat_iter 0 f x = x] and [nat_iter n.+1 f x = f (nat_iter n f x)]. We make this a notation, so it doesn't add a universe variable for the universe containing [A]. *) Notation nat_iter n f x := ((fix F (m : nat) := match m with | 0 => x | m'.+1 => f (F m') end) n). (** *** Successor and predecessor *) (** [nat_succ n] is the successor of a natural number [n]. We defined a notation [x.+1] for it in Overture.v. *) Notation nat_succ := S (only parsing). (** [nat_pred n] is the predecessor of a natural number [n]. When [n] is [0] we return [0]. *) Definition nat_pred n : nat := match n with | 0 => n | S n' => n' end. (** *** Arithmetic operations *) (** Addition of natural numbers *) Definition nat_add n m : nat := nat_iter n nat_succ m. Notation "n + m" := (nat_add n m) : nat_scope. (** Multiplication of natural numbers *) Definition nat_mul n m : nat := nat_iter n (nat_add m) 0. Notation "n * m" := (nat_mul n m) : nat_scope. (** Truncated subtraction: [n - m] is [0] if [n <= m] *) Fixpoint nat_sub n m : nat := match n, m with | S n' , S m' => nat_sub n' m' | _ , _ => n end. Notation "n - m" := (nat_sub n m) : nat_scope. (** Powers or exponentiation of natural numbers. *) Definition nat_pow n m := nat_iter m (nat_mul n) 1. (** *** Maximum and minimum *) (** The maximum [nat_max n m] of two natural numbers [n] and [m]. *) Fixpoint nat_max n m := match n, m with | 0 , _ => m | S n' , 0 => n'.+1 | S n' , S m' => (nat_max n' m').+1 end. (** The minimum [nat_min n m] of two natural numbers [n] and [m]. *) Fixpoint nat_min n m := match n, m with | 0 , _ => 0 | S n' , 0 => 0 | S n' , S m' => S (nat_min n' m') end. (** *** Euclidean division *) (** This division takes time linear in `x` and is tail-recursive. In [nat_div_mod x y q u], [x + y.+1 * q + (y - u)] is the quantity being divided and [y] is the predecessor of the divisor. It will be called with [q] zero and [u] equal to [y], so that [x] is the quantity being divided. The return value is a pair [(q', u')] with [x + y.+1 * q + (y - u) = y.+1 * q' + (y - u')], at least when [u <= y], as shown in [nat_div_mod_spec_helper] in Nat/Divison.v. *) Fixpoint nat_div_mod x y q u : nat * nat := match x with | 0 => (q , u) | S x' => match u with | 0 => nat_div_mod x' y (S q) y | S u' => nat_div_mod x' y q u' end end. Definition nat_div x y : nat := match y with | 0 => y | S y' => fst (nat_div_mod x y' 0 y') end. Infix "/" := nat_div : nat_scope. (** [nat_mod x y] is the remainder when [x] is divided by [y]. When [y] is zero, it is defined to be [x]. See [nat_div_mod_spec] and related results below. *) Definition nat_mod x y : nat := match y with | 0 => x | S y' => y' - snd (nat_div_mod x y' 0 y') end. Infix "mod" := nat_mod : nat_scope. (** For results about division and modulo, see Nat/Division.v. *) (** *** Greatest common divisor *) (** We use Euclid algorithm, which is normally not structural, but Coq is now clever enough to accept this (behind modulo there is a subtraction, which now preserves being a subterm) *) Fixpoint nat_gcd a b := match a with | O => b | S a' => nat_gcd (b mod a'.+1) a'.+1 end. (** ** Comparison predicates *) (** *** Less than or equal To [<=] *) Inductive leq (n : nat) : nat -> Type0 := | leq_refl : leq n n | leq_succ_r m : leq n m -> leq n (S m). Arguments leq_succ_r {n m} _. Scheme leq_ind := Induction for leq Sort Type. Scheme leq_rect := Induction for leq Sort Type. Scheme leq_rec := Induction for leq Sort Type. Notation "n <= m" := (leq n m) : nat_scope. Existing Class leq. Global Existing Instances leq_refl leq_succ_r. (** *** Less than [<] *) (** We define the less-than relation [lt] in terms of [leq] *) Definition lt n m : Type0 := leq (S n) m. (** We declare it as an existing class so typeclass search is performed on its goals. *) Existing Class lt. #[export] Hint Unfold lt : typeclass_instances. Infix "<" := lt : nat_scope. Global Instance lt_is_leq n m : leq n.+1 m -> lt n m | 100 := idmap. (** *** Greater than or equal To [>=] *) Definition geq n m := leq m n. Existing Class geq. #[export] Hint Unfold geq : typeclass_instances. Infix ">=" := geq : nat_scope. Global Instance geq_is_leq n m : leq m n -> geq n m | 100 := idmap. (*** Greater Than [>] *) Definition gt n m := lt m n. Existing Class gt. #[export] Hint Unfold gt : typeclass_instances. Infix ">" := gt : nat_scope. Global Instance gt_is_leq n m : leq m.+1 n -> gt n m | 100 := idmap. (** *** Combined comparison predicates *) Notation "x <= y <= z" := (x <= y /\ y <= z) : nat_scope. Notation "x <= y < z" := (x <= y /\ y < z) : nat_scope. Notation "x < y < z" := (x < y /\ y < z) : nat_scope. Notation "x < y <= z" := (x < y /\ y <= z) : nat_scope. (** ** Properties of [nat_iter]. *) Definition nat_iter_succ_r n {A} (f : A -> A) (x : A) : nat_iter (S n) f x = nat_iter n f (f x). Proof. simple_induction n n IHn; simpl; trivial. exact (ap f IHn). Defined. Definition nat_iter_add (n m : nat) {A} (f : A -> A) (x : A) : nat_iter (n + m) f x = nat_iter n f (nat_iter m f x). Proof. simple_induction n n IHn; simpl; trivial. exact (ap f IHn). Defined. (** Preservation of invariants : if [f : A -> A] preserves the invariant [P], then the iterates of [f] also preserve it. *) Definition nat_iter_invariant (n : nat) {A} (f : A -> A) (P : A -> Type) : (forall x, P x -> P (f x)) -> forall x, P x -> P (nat_iter n f x). Proof. simple_induction n n IHn; simpl; trivial. intros Hf x Hx. apply Hf, IHn; trivial. Defined. (** ** Properties of successors *) (** The predecessor of a successor is the original number. *) Definition nat_pred_succ@{} n : nat_pred (nat_succ n) = n := idpath. (** The successor of a predecessor is the original as long as there is a strict lower bound. *) Definition nat_succ_pred'@{} n i : i < n -> nat_succ (nat_pred n) = n. Proof. by intros []. Defined. (** The most common lower bound is to take [0]. *) Definition nat_succ_pred@{} n : 0 < n -> nat_succ (nat_pred n) = n := nat_succ_pred' n 0. (** Injectivity of successor. *) Definition path_nat_succ@{} n m (H : S n = S m) : n = m := ap nat_pred H. Global Instance isinj_succ : IsInjective nat_succ := path_nat_succ. (** Inequality of sucessors is implied with inequality of the arguments. *) Definition neq_nat_succ@{} n m : n <> m -> S n <> S m. Proof. intros np q. apply np. exact (path_nat_succ _ _ q). Defined. (** Zero is not the successor of a number. *) Definition neq_nat_zero_succ@{} n : 0 <> S n. Proof. discriminate. Defined. (** A natural number cannot be equal to its own successor. *) Definition neq_nat_succ'@{} n : n <> S n. Proof. simple_induction' n. - apply neq_nat_zero_succ. - by apply neq_nat_succ. Defined. (** ** Truncatedness of natural numbers *) (** [nat] has decidable paths. *) Global Instance decidable_paths_nat@{} : DecidablePaths nat. Proof. intros n m. induction n as [|n IHn] in m |- *; destruct m. - exact (inl idpath). - exact (inr (neq_nat_zero_succ m)). - exact (inr (fun p => neq_nat_zero_succ n p^)). - destruct (IHn m) as [p|q]. + exact (inl (ap S p)). + exact (inr (fun p => q (path_nat_succ _ _ p))). Defined. (** [nat] is therefore a hset. *) Global Instance ishset_nat : IsHSet nat := _. (** ** Properties of addition *) (** [0] is the left identity of addition. *) Definition nat_add_zero_l@{} n : 0 + n = n := idpath. (** [0] is the right identity of addition. *) Definition nat_add_zero_r@{} n : n + 0 = n. Proof. induction n as [|n IHn]. - reflexivity. - apply (ap nat_succ). exact IHn. Defined. (** Adding a successor on the left is the same as adding and then taking the successor. *) Definition nat_add_succ_l@{} n m : n.+1 + m = (n + m).+1 := idpath. (** Adding a successor on the right is the same as adding and then taking the successor. *) Definition nat_add_succ_r@{} n m : n + m.+1 = (n + m).+1. Proof. simple_induction' n; simpl. 1: reflexivity. exact (ap S IH). Defined. (** Addition of natural numbers is commutative. *) Definition nat_add_comm@{} n m : n + m = m + n. Proof. induction n. - exact (nat_add_zero_r m)^. - rhs nrapply nat_add_succ_r. apply (ap nat_succ). exact IHn. Defined. (** Addition of natural numbers is associative. *) Definition nat_add_assoc@{} n m k : n + (m + k) = (n + m) + k. Proof. induction n as [|n IHn]. - reflexivity. - nrapply (ap nat_succ). exact IHn. Defined. (** Addition on the left is injective. *) Global Instance isinj_nat_add_l@{} k : IsInjective (nat_add k). Proof. simple_induction k k Ik; exact _. Defined. (** Addition on the right is injective. *) Definition isinj_nat_add_r@{} k : IsInjective (fun x => nat_add x k). Proof. intros x y H. nrapply (isinj_nat_add_l k). lhs nrapply nat_add_comm. lhs nrapply H. nrapply nat_add_comm. Defined. (** A sum being zero is equivalent to both summands being zero. *) Definition equiv_nat_add_zero n m : n = 0 /\ m = 0 <~> n + m = 0. Proof. srapply equiv_iff_hprop. - intros [-> ->]; reflexivity. - destruct n. + by split. + intros H; symmetry in H. by apply neq_nat_zero_succ in H. Defined. (** ** Properties of multiplication *) (** Multiplication by [0] on the left is [0]. *) Definition nat_mul_zero_l@{} n : 0 * n = 0 := idpath. (** Multiplicaiton by [0] on the right is [0]. *) Definition nat_mul_zero_r@{} n : n * 0 = 0. Proof. by induction n. Defined. Definition nat_mul_succ_l@{} n m : n.+1 * m = m + n * m := idpath. Definition nat_mul_succ_r@{} n m : n * m.+1 = n * m + n. Proof. induction n as [|n IHn]. - reflexivity. - rhs nrapply nat_add_succ_r. nrapply (ap nat_succ). rhs_V nrapply nat_add_assoc. nrapply (ap (nat_add m)). exact IHn. Defined. (** Multiplication of natural numbers is commutative. *) Definition nat_mul_comm@{} n m : n * m = m * n. Proof. induction m as [|m IHm]; simpl. - nrapply nat_mul_zero_r. - lhs nrapply nat_mul_succ_r. lhs nrapply nat_add_comm. snrapply (ap (nat_add n)). exact IHm. Defined. (** Multiplication of natural numbers distributes over addition on the left. *) Definition nat_dist_l@{} n m k : n * (m + k) = n * m + n * k. Proof. induction n as [|n IHn]; simpl. - reflexivity. - lhs_V nrapply nat_add_assoc. rhs_V nrapply nat_add_assoc. nrapply (ap (nat_add m)). lhs nrapply nat_add_comm. rewrite IHn. lhs_V nrapply nat_add_assoc. nrapply (ap (nat_add (n * m))). nrapply nat_add_comm. Defined. (** Multiplication of natural numbers distributes over addition on the right. *) Definition nat_dist_r@{} n m k : (n + m) * k = n * k + m * k. Proof. lhs nrapply nat_mul_comm. lhs nrapply nat_dist_l. nrapply ap011; nrapply nat_mul_comm. Defined. (** Multiplication of natural numbers is associative. *) Definition nat_mul_assoc@{} n m k : n * (m * k) = n * m * k. Proof. induction n as [|n IHn]; simpl. - reflexivity. - rhs nrapply nat_dist_r. nrapply (ap (nat_add (m * k))). exact IHn. Defined. (** Multiplication by [1] on the left is the identity. *) Definition nat_mul_one_l@{} n : 1 * n = n := nat_add_zero_r _. (** Multiplication by [1] on the right is the identity. *) Definition nat_mul_one_r@{} n : n * 1 = n := nat_mul_comm _ _ @ nat_mul_one_l _. (** ** Basic properties of comparison predicates *) (** *** Basic properties of [<=] *) (** [<=] is reflexive by definition. *) Global Instance reflexive_leq : Reflexive leq := leq_refl. (** Being less than or equal to is a transitive relation. *) Definition leq_trans {x y z} : x <= y -> y <= z -> x <= z. Proof. intros H1 H2; induction H2; exact _. Defined. Hint Immediate leq_trans : typeclass_instances. (** [<=] is transtiive. *) Global Instance transitive_leq : Transitive leq := @leq_trans. (** [0] is less than or equal to any natural number. *) Definition leq_zero_l n : 0 <= n. Proof. simple_induction' n; exact _. Defined. Global Existing Instance leq_zero_l | 10. Global Instance pred_leq {m} : nat_pred m <= m. Proof. destruct m; exact _. Defined. (** A predecessor is less than or equal to a predecessor if the original number is less than or equal. *) Global Instance leq_pred {n m} : n <= m -> nat_pred n <= nat_pred m. Proof. intros H; induction H; exact _. Defined. (** A successor is less than or equal to a successor if the original numbers are less than or equal. *) Definition leq_succ {n m} : n <= m -> n.+1 <= m.+1. Proof. induction 1; exact _. Defined. Global Existing Instance leq_succ | 100. (** The converse to [leq_succ] also holds. *) Definition leq_pred' {n m} : n.+1 <= m.+1 -> n <= m := leq_pred. Hint Immediate leq_pred' : typeclass_instances. (** [<] is an irreflexive relation. *) Definition lt_irrefl n : ~ (n < n). Proof. induction n as [|n IHn]. 1: intro p; inversion p. intros p; by apply IHn, leq_pred'. Defined. Global Instance irreflexive_lt : Irreflexive lt := lt_irrefl. Global Instance irreflexive_gt : Irreflexive gt := lt_irrefl. (** [<=] is an antisymmetric relation. *) Definition leq_antisym {x y} : x <= y -> y <= x -> x = y. Proof. intros p q. destruct p. 1: reflexivity. destruct x; [inversion q|]. apply leq_pred' in q. contradiction (lt_irrefl _ (leq_trans p q)). Defined. Global Instance antisymmetric_leq : AntiSymmetric leq := @leq_antisym. Global Instance antisymemtric_geq : AntiSymmetric geq := fun _ _ p q => leq_antisym q p. (** Every natural number is zero or greater than zero. *) Definition nat_zero_or_gt_zero n : (0 = n) + (0 < n). Proof. induction n as [|n IHn]. 1: left; reflexivity. right; exact _. Defined. (** Being less than or equal to [0] implies being [0]. *) Definition path_zero_leq_zero_r n : n <= 0 -> n = 0. Proof. intros H; rapply leq_antisym. Defined. (** Nothing can be less than [0]. *) Definition not_lt_zero_r n : ~ (n < 0). Proof. intros p. apply (lt_irrefl n), (leq_trans p). exact _. Defined. (** [n.+1 <= m] implies [n <= m]. *) Definition leq_succ_l {n m} : n.+1 <= m -> n <= m. Proof. intro l; apply leq_pred'; exact _. Defined. (** A general form for injectivity of this constructor *) Definition leq_refl_inj_gen n k (p : n <= k) (r : n = k) : p = r # leq_refl n. Proof. destruct p. + assert (c : idpath = r) by apply path_ishprop. destruct c. reflexivity. + destruct r^. contradiction (lt_irrefl _ p). Defined. (** Which we specialise to this lemma *) Definition leq_refl_inj n (p : n <= n) : p = leq_refl n := leq_refl_inj_gen n n p idpath. Fixpoint leq_succ_r_inj_gen n m k (p : n <= k) (q : n <= m) (r : m.+1 = k) : p = r # leq_succ_r q. Proof. revert m q r. destruct p. + intros k p r. destruct r. contradiction (lt_irrefl _ p). + intros m' q r. pose (r' := path_nat_succ _ _ r). destruct r'. assert (t : idpath = r) by apply path_ishprop. destruct t. cbn. apply ap. destruct q. 1: apply leq_refl_inj. apply (leq_succ_r_inj_gen n m _ p q idpath). Defined. Definition leq_succ_r_inj n m (p : n <= m.+1) (q : n <= m) : p = leq_succ_r q := leq_succ_r_inj_gen n m m.+1 p q idpath. Global Instance ishprop_leq n m : IsHProp (n <= m). Proof. apply hprop_allpath. intros p q; revert p. induction q. + intros y. rapply leq_refl_inj. + intros y. rapply leq_succ_r_inj. Defined. Definition equiv_leq_succ n m : n.+1 <= m.+1 <~> n <= m. Proof. srapply equiv_iff_hprop. Defined. Global Instance decidable_leq n m : Decidable (n <= m). Proof. revert n. simple_induction' m; intros n. - destruct n. + left; exact _. + right; apply not_lt_zero_r. - destruct n. + left; exact _. + rapply decidable_equiv'. symmetry. apply equiv_leq_succ. Defined. (** The default induction principle for [leq] applies to a type family depending on the second variable. Here is a version involving a type family depending on the first variable. *) Definition leq_ind_l {n : nat} (Q : forall (m : nat) (l : m <= n.+1), Type) (H_Sn : Q n.+1 (leq_refl n.+1)) (H_m : forall (m : nat) (l : m <= n), Q m (leq_succ_r l)) : forall (m : nat) (l : m <= n.+1), Q m l. Proof. intros m leq_m_Sn. inversion leq_m_Sn as [p | k H p]; destruct p^; clear p. - exact (path_ishprop _ _ # H_Sn). - exact (path_ishprop _ _ # H_m _ _). Defined. (** *** Basic properties of [<] *) (** [<=] and [<] imply [<] *) Definition lt_leq_lt_trans {n m k} : n <= m -> m < k -> n < k := fun leq lt => leq_trans (leq_succ leq) lt. (** [<=] and [<] imply [<] *) Definition lt_lt_leq_trans {n m k} : n < m -> m <= k -> n < k := fun lt leq => leq_trans lt leq. Definition leq_lt {n m} : n < m -> n <= m := leq_succ_l. Hint Immediate leq_lt : typeclass_instances. Definition lt_trans {n m k} : n < m -> m < k -> n < k := fun H1 H2 => leq_lt (lt_leq_lt_trans H1 H2). Hint Immediate lt_trans : typeclass_instances. Global Instance transitive_lt : Transitive lt := @lt_trans. Global Instance ishprop_lt n m : IsHProp (n < m) := _. Global Instance decidable_lt n m : Decidable (lt n m) := _. (** *** Basic properties of [>=] *) Global Instance reflexive_geq : Reflexive geq := leq_refl. Global Instance transitive_geq : Transitive geq := fun x y z p q => leq_trans q p. Global Instance ishprop_geq n m : IsHProp (geq n m) := _. Global Instance decidable_geq n m : Decidable (geq n m) := _. (** *** Basic properties of [>] *) Global Instance transitive_gt : Transitive gt := fun x y z p q => transitive_lt _ _ _ q p. Global Instance ishprop_gt n m : IsHProp (gt n m) := _. Global Instance decidable_gt n m : Decidable (gt n m) := _. (** ** Properties of subtraction *) (** Subtracting a number from [0] is [0]. *) Definition nat_sub_zero_l@{} n : 0 - n = 0 := idpath. (** Subtracting [0] from a number is the number itself. *) Definition nat_sub_zero_r@{} (n : nat) : n - 0 = n. Proof. destruct n; reflexivity. Defined. (** Subtracting a number from itself is [0]. *) Definition nat_sub_cancel@{} (n : nat) : n - n = 0. Proof. simple_induction n n IHn. - reflexivity. - exact IHn. Defined. (** Subtracting an addition is the same as subtracting the two numbers separately. *) Definition nat_sub_r_add@{} n m k : n - (m + k) = n - m - k. Proof. induction n as [|n IHn] in m, k |- *. - reflexivity. - destruct m. + reflexivity. + nrapply IHn. Defined. (** The order in which two numbers are subtracted does not matter. *) Definition nat_sub_comm_r@{} n m k : n - m - k = n - k - m. Proof. lhs_V nrapply nat_sub_r_add. rewrite nat_add_comm. nrapply nat_sub_r_add. Defined. (** Subtracting a larger number from a smaller number is [0]. *) Definition equiv_nat_sub_leq {n m} : n <= m <~> n - m = 0. Proof. srapply equiv_iff_hprop. - intro l; induction l. + exact (nat_sub_cancel n). + change (m.+1) with (1 + m). lhs nrapply nat_sub_r_add. lhs nrapply nat_sub_comm_r. by destruct IHl^. - induction n as [|n IHn] in m |- *. 1: intro; exact _. destruct m. + intros p; by destruct p. + intros p. apply leq_succ, IHn. exact p. Defined. (** We can cancel a left summand when subtracting it from a sum. *) Definition nat_add_sub_cancel_l m n : n + m - n = m. Proof. induction n as [|n IHn]. - nrapply nat_sub_zero_r. - exact IHn. Defined. (** We can cancel a right summand when subtracting it from a sum. *) Definition nat_add_sub_cancel_r m n : m + n - n = m. Proof. rhs_V nrapply (nat_add_sub_cancel_l m n). nrapply (ap (fun x => x - n)). nrapply nat_add_comm. Defined. (** We can cancel a right subtrahend when adding it on the right to a subtraction if the subtrahend is less than the number being subtracted from. *) Definition nat_add_sub_l_cancel {n m} : n <= m -> (m - n) + n = m. Proof. intros H. induction n as [|n IHn] in m, H |- *. - lhs nrapply nat_add_zero_r. nrapply nat_sub_zero_r. - destruct m. 1: contradiction (not_lt_zero_r n). lhs nrapply nat_add_succ_r. nrapply (ap nat_succ). nrapply IHn. exact (leq_pred' H). Defined. (** We can cancel a right subtrahend when adding it on the left to a subtraction if the subtrahend is less than the nubmer being subtracted from. *) Definition nat_add_sub_r_cancel {n m} : n <= m -> n + (m - n) = m. Proof. intros H. rhs_V nrapply (nat_add_sub_l_cancel H). apply nat_add_comm. Defined. (** We can move a subtracted number to the left-hand side of an equation. *) Definition nat_moveL_nV {n m} k : n + k = m -> n = m - k. Proof. intros p. destruct p. symmetry. apply nat_add_sub_cancel_r. Defined. (** We can move a subtracted number to the right-hand side of an equation. *) Definition nat_moveR_nV {n m} k : n = m + k -> n - k = m := fun p => (nat_moveL_nV _ p^)^. (** Subtracting a successor is the predecessor of subtracting the original number. *) Definition nat_sub_succ_r n m : n - m.+1 = nat_pred (n - m). Proof. induction n as [|n IHn] in m |- *. 1: reflexivity. destruct m. 1: apply nat_sub_zero_r. apply IHn. Defined. (** ** Properties of maximum and minimum *) (** *** Properties of maximum *) (** [nat_max] is idempotent. *) Definition nat_max_idem@{} n : nat_max n n = n. Proof. simple_induction' n; cbn. 1: reflexivity. exact (ap S IH). Defined. (** The defining properties of [nat_max]: [m] and [n] are less than or equal to [nat_max n m] and [nat_max n m] is less than or equal to any number greater than or equal to [m] and [n]. *) Definition leq_nat_max_l@{} n m : n <= nat_max n m. Proof. induction n as [|n IHn] in m |- *. 1: exact (leq_zero_l _). destruct m; cbn. 1: cbn; reflexivity. exact (leq_succ (IHn m)). Defined. Definition leq_nat_max_r@{} n m : m <= nat_max n m. Proof. induction n as [|n IHn] in m |- *. 1: cbn; reflexivity. destruct m; cbn. 1: exact (leq_zero_l _). exact (leq_succ (IHn m)). Defined. Definition leq_nat_max@{} {n m k : nat} (Hn : n <= k) (Hm : m <= k) : nat_max n m <= k. Proof. induction k in m, n, Hn, Hm |- *; destruct m, n; cbn. 1-3, 5-7: exact _. - contradiction (not_lt_zero_r _ _). - exact (leq_succ (IHk n m _ _)). Defined. (** [nat_max] is commutative. *) Definition nat_max_comm@{} n m : nat_max n m = nat_max m n. Proof. induction n as [|n IHn] in m |- *; destruct m; cbn. 1-3: reflexivity. exact (ap S (IHn _)). Defined. (** The maximum of [n.+1] and [n] is [n.+1]. *) Definition nat_max_succ_l@{} n : nat_max n.+1 n = n.+1. Proof. simple_induction' n; cbn. 1: reflexivity. exact (ap S IH). Defined. (** The maximum of [n] and [n.+1] is [n.+1]. *) Definition nat_max_succ_r@{} n : nat_max n n.+1 = n.+1 := nat_max_comm _ _ @ nat_max_succ_l _. (** [0] is the left identity of [nat_max]. *) Definition nat_max_zero_l@{} n : nat_max 0 n = n := idpath. (** [0] is the right identity of [nat_max]. *) Definition nat_max_zero_r@{} n : nat_max n 0 = n := nat_max_comm _ _ @ nat_max_zero_l _. (** [nat_max n m] is [n] if [m <= n]. *) Definition nat_max_l@{} {n m} : m <= n -> nat_max n m = n. Proof. intros H. induction m as [|m IHm] in n, H |- *. 1: nrapply nat_max_zero_r. destruct n. 1: inversion H. cbn; by apply (ap S), IHm, leq_pred'. Defined. (** [nat_max n m] is [m] if [n <= m]. *) Definition nat_max_r {n m} : n <= m -> nat_max n m = m := fun _ => nat_max_comm _ _ @ nat_max_l _. (** [nat_max n m] is associative. *) Definition nat_max_assoc@{} n m k : nat_max n (nat_max m k) = nat_max (nat_max n m) k. Proof. induction n as [|n IHn] in m, k |- *. 1: reflexivity. destruct m, k. 1-3: reflexivity. by apply (ap S), IHn. Defined. (** Properties of Minima *) (** [nat_min] is idempotent. *) Definition nat_min_idem n : nat_min n n = n. Proof. simple_induction' n; cbn. 1: reflexivity. exact (ap S IH). Defined. (** The defining properties of [nat_min]: [nat_min n m] is less than or equal to [m] and [n] and any number less than or equal to [m] and [n] is less than or equal to [nat_min n m]. *) Definition leq_nat_min_l@{} n m : nat_min n m <= n. Proof. induction n as [|n IHn] in m |- *. 1: cbn; reflexivity. destruct m; cbn. 1: exact (leq_zero_l _). exact (leq_succ (IHn m)). Defined. Definition leq_nat_min_r@{} n m : nat_min n m <= m. Proof. induction n as [|n IHn] in m |- *. 1: exact (leq_zero_l _). destruct m; cbn. 1: cbn; reflexivity. exact (leq_succ (IHn m)). Defined. Definition leq_nat_min@{} {n m k : nat} (Hn : k <= n) (Hm : k <= m) : k <= nat_min n m. Proof. induction k in m, n, Hn, Hm |- *; destruct m, n; cbn. 1-7: exact _. exact (leq_succ (IHk n m _ _)). Defined. (** [nat_min] is commutative. *) Definition nat_min_comm n m : nat_min n m = nat_min m n. Proof. induction n as [|n IHn] in m |- *; destruct m; cbn. 1-3: reflexivity. exact (ap S (IHn _)). Defined. (** [nat_min] of [0] and [n] is [0]. *) Definition nat_min_zero_l n : nat_min 0 n = 0 := idpath. (** [nat_min] of [n] and [0] is [0]. *) Definition nat_min_zero_r n : nat_min n 0 = 0:= nat_min_comm _ _ @ nat_min_zero_l _. (** [nat_min n m] is [n] if [n <= m]. *) Definition nat_min_l {n m} : n <= m -> nat_min n m = n. Proof. revert n m. simple_induction n n IHn; auto. intros [] p. 1: inversion p. cbn; by apply (ap S), IHn, leq_pred'. Defined. (** [nat_min n m] is [m] if [m <= n]. *) Definition nat_min_r {n m} : m <= n -> nat_min n m = m := fun _ => nat_min_comm _ _ @ nat_min_l _. (** [nat_min n m] is associative. *) Definition nat_min_assoc n m k : nat_min n (nat_min m k) = nat_min (nat_min n m) k. Proof. induction n as [|n IHn] in m, k |- *. 1: reflexivity. destruct m, k. 1-3: reflexivity. by apply (ap S), IHn. Defined. (** ** More theory of comparison predicates *) (** *** Addition lemmas *) (** The second summand is less than or equal to the sum. *) Global Instance leq_add_l n m : n <= m + n. Proof. simple_induction m m IH. - exact (leq_refl n). - exact (leq_succ_r IH). Defined. (** The first summand is less than or equal to the sum. *) Global Instance leq_add_r n m : n <= n + m. Proof. simple_induction n n IHn. - exact (leq_zero_l m). - exact (leq_succ IHn). Defined. (** *** Multiplication lemmas *) (** The second multiplicand is less than or equal to the product. *) Global Instance leq_mul_l n m l : l < m -> n <= m * n. Proof. intros H; induction H; exact _. Defined. (** The first multiplicand is less than or equal to the product. *) Global Instance leq_mul_r n m l : l < m -> n <= n * m. Proof. rewrite nat_mul_comm; exact _. Defined. (** ** Eliminating positive assumptions *) (** Sometimes we want to prove a predicate which assumes that [0 < x]. In that case, it suffices to prove it for [x.+1] instead. *) Definition gt_zero_ind (P : nat -> Type) (H : forall x, P x.+1) : forall x (l : 0 < x), P x. Proof. intros x l. destruct x. 1: contradiction (lt_irrefl _ l). apply H. Defined. (** Alternative Characterizations of [<=] *) (** [n <= m] is equivalent to [(n < m) + (n = m)]. This justifies the name "less than or equal to". Note that it is not immediately obvious that the latter type is a hprop. *) Definition equiv_leq_lt_or_eq {n m} : (n <= m) <~> (n < m) + (n = m). Proof. srapply equiv_iff_hprop. - nrapply ishprop_sum. 1,2: exact _. intros H1 p; destruct p. contradiction (lt_irrefl _ _). - intro l; induction l. + by right. + left; exact (leq_succ l). - intros [l|p]. + exact (leq_succ_l l). + destruct p. exact (leq_refl _). Defined. (** Here is an alternative characterization of [<=] in terms of an existence predicate and addition. *) Definition equiv_leq_add n m : n <= m <~> exists k, k + n = m. Proof. srapply equiv_iff_hprop. - apply hprop_allpath. intros [x p] [y q]. pose (r := nat_moveL_nV _ p @ (nat_moveL_nV _ q)^). destruct r. apply ap. apply path_ishprop. - intros p. exists (m - n). apply nat_add_sub_l_cancel, p. - intros [k p]. destruct p. apply leq_add_l. Defined. (** *** Dichotomy of [<=] *) Definition leq_dichotomy m n : (m <= n) + (m > n). Proof. induction m as [|m IHm] in n |- *. 1: left; exact _. destruct n. 1: right; exact _. destruct (IHm n). 1: left; exact _. 1: right; exact _. Defined. (** A variant. *) Definition leq_succ_dichotomy {n m : nat} (l : m <= n.+1) : (m = n.+1) + (m <= n). Proof. inversion l. - left; reflexivity. - right; assumption. Defined. (** *** Trichotomy *) (** Any two natural numbers are either equal, less than, or greater than each other. *) Definition nat_trichotomy m n : (m < n) + (m = n) + (m > n). Proof. generalize (leq_dichotomy m n). snrapply (functor_sum _ idmap). snrapply equiv_leq_lt_or_eq. Defined. (** *** Negation lemmas *) (** There are various lemmas we can state about negating the comparison operators on [nat]. To aid readability, we opt to keep the order of the variables in each statement consistent. *) Definition geq_iff_not_lt {n m} : ~(n < m) <-> n >= m. Proof. split. - intro; by destruct (leq_dichotomy m n). - intros ? ?; contradiction (lt_irrefl n); exact _. Defined. Definition gt_iff_not_leq {n m} : ~(n <= m) <-> n > m. Proof. split. - intro; by destruct (leq_dichotomy n m). - intros ? ?; contradiction (lt_irrefl m); exact _. Defined. Definition leq_iff_not_gt {n m} : ~(n > m) <-> n <= m := geq_iff_not_lt. Definition lt_iff_not_geq {n m} : ~(n >= m) <-> n < m := gt_iff_not_leq. (** *** Dichotomy of [<>] *) (** The inequality of natural numbers is equivalent to [n < m] or [n > m]. This could be an equivalence however one of the sections requires funext since we are comparing two inequality proofs. It is therefore more useful to keep it as a biimplication. Note that this is a negated version of antisymmetry of [<=]. *) Definition neq_iff_lt_or_gt {n m} : n <> m <-> (n < m) + (n > m). Proof. split. - intros diseq. destruct (dec (n < m)) as [| a]; [ by left |]. apply geq_iff_not_lt in a. apply equiv_leq_lt_or_eq in a. destruct a as [lt | eq]. 1: by right. symmetry in eq. contradiction. - intros [H' | H'] nq; destruct nq; exact (lt_irrefl _ H'). Defined. (** ** Arithmetic relations between [trunc_index] and [nat]. *) Definition trunc_index_add_nat_add {n : nat}: trunc_index_add n n = n.+1 + n.+1. Proof. induction n as [|n IHn]. 1: reflexivity. lhs nrapply trunc_index_add_succ. rhs nrapply (ap nat_to_trunc_index). 2: nrapply nat_add_succ_r. exact (ap (fun x => x.+2%trunc) IHn). Defined. (** *** Subtraction *) Global Instance leq_sub_add_l n m : n <= n - m + m. Proof. destruct (@leq_dichotomy m n) as [l | g]. - by rewrite nat_add_sub_l_cancel. - apply leq_lt in g. by destruct (equiv_nat_sub_leq _)^. Defined. Global Instance leq_sub_add_r n m : n <= m + (n - m). Proof. rewrite nat_add_comm; exact _. Defined. (** A number being less than another is equivalent to their difference being greater than zero. *) Definition equiv_lt_lt_sub n m : m < n <~> 0 < n - m. Proof. induction n as [|n IHn] in m |- *. 1: srapply equiv_iff_hprop; intro; contradiction (not_lt_zero_r _ _). destruct m; only 1: reflexivity. nrefine (IHn m oE _). srapply equiv_iff_hprop. Defined. (** *** Monotonicity of addition *) (** TODO: use OrderPreserving from canonical_names *) (** Addition on the left is monotone. *) Definition nat_add_l_monotone {n m} k : n <= m -> k + n <= k + m. Proof. intros H; induction k; exact _. Defined. Hint Immediate nat_add_l_monotone : typeclass_instances. (** Addition on the right is monotone. *) Definition nat_add_r_monotone {n m} k : n <= m -> n + k <= m + k. Proof. intros H; rewrite 2 (nat_add_comm _ k); exact _. Defined. Hint Immediate nat_add_r_monotone : typeclass_instances. (** Addition is monotone in both arguments. (This makes [+] a bifunctor when treating [nat] as a category (as a preorder)). *) Definition nat_add_monotone {n n' m m'} : n <= m -> n' <= m' -> n + n' <= m + m'. Proof. intros H1 H2; induction H1; exact _. Defined. Hint Immediate nat_add_monotone : typeclass_instances. (** *** Strict monotonicity of addition *) (** [nat_succ] is strictly monotone. *) Global Instance lt_succ {n m} : n < m -> n.+1 < m.+1 := _. Global Instance lt_succ_r {n m} : n < m -> n < m.+1 := _. (** Addition on the left is strictly monotone. *) Definition nat_add_l_strictly_monotone {n m} k : n < m -> k + n < k + m. Proof. intros H; induction k; exact _. Defined. Hint Immediate nat_add_l_strictly_monotone : typeclass_instances. (** Addition on the right is strictly monotone. *) Definition nat_add_r_strictly_monotone {n m} k : n < m -> n + k < m + k. Proof. intros H; rewrite 2 (nat_add_comm _ k); exact _. Defined. Hint Immediate nat_add_r_strictly_monotone : typeclass_instances. (** Addition is strictly monotone in both arguments. *) Definition nat_add_strictly_monotone {n n' m m'} : n < m -> n' < m' -> n + n' < m + m'. Proof. intros H1 H2; induction H1; exact _. Defined. Hint Immediate nat_add_strictly_monotone : typeclass_instances. (** *** Monotonicity of multiplication *) (** Multiplication on the left is monotone. *) Definition nat_mul_l_monotone {n m} k : n <= m -> k * n <= k * m. Proof. intros H; induction k; exact _. Defined. Hint Immediate nat_mul_l_monotone : typeclass_instances. (** Multiplication on the right is monotone. *) Definition nat_mul_r_monotone {n m} k : n <= m -> n * k <= m * k. Proof. intros H; rewrite 2 (nat_mul_comm _ k); exact _. Defined. Hint Immediate nat_mul_r_monotone : typeclass_instances. (** Multiplication is monotone in both arguments. *) Definition nat_mul_monotone {n n' m m'} : n <= m -> n' <= m' -> n * n' <= m * m'. Proof. intros H1 H2; induction H1; exact _. Defined. Hint Immediate nat_mul_monotone : typeclass_instances. (** *** Strict monotonicity of multiplication *) (** Multiplication on the left by a positive number is strictly monotone. *) Definition nat_mul_l_strictly_monotone {n m l} k : l < k -> n < m -> k * n < k * m. Proof. destruct k. 1: intro; contradiction (not_lt_zero_r _ H). intros _ H; induction k as [|k IHk] in |- *; exact _. Defined. Hint Immediate nat_mul_l_strictly_monotone : typeclass_instances. (** Multiplication on the right by a positive number is strictly monotone. *) Definition nat_mul_r_strictly_monotone {n m l} k : l < k -> n < m -> n * k < m * k. Proof. intros ? H; rewrite 2 (nat_mul_comm _ k); exact _. Defined. Hint Immediate nat_mul_r_strictly_monotone : typeclass_instances. (** Multiplication is strictly monotone in both arguments. *) Definition nat_mul_strictly_monotone {n n' m m'} : n < m -> n' < m' -> n * n' < m * m'. Proof. intros H1 H2. nrapply (lt_leq_lt_trans (m:=n * m')). 1: rapply nat_mul_l_monotone. rapply nat_mul_r_strictly_monotone. Defined. Hint Immediate nat_mul_strictly_monotone : typeclass_instances. (** *** Order-reflection *) (** Addition on the left is order-reflecting. *) Definition leq_reflects_add_l {n m} k : k + n <= k + m -> n <= m. Proof. intros H; induction k; exact _. Defined. (** Addition on the right is order-reflecting. *) Definition leq_reflects_add_r {n m} k : n + k <= m + k -> n <= m. Proof. rewrite 2 (nat_add_comm _ k); nrapply leq_reflects_add_l. Defined. (** Addition on the left is strictly order-reflecting. *) Definition lt_reflects_add_l {n m} k : k + n < k + m -> n < m. Proof. intros H; induction k; exact _. Defined. (** Addition on the right is strictly order-reflecting. *) Definition lt_reflects_add_r {n m} k : n + k < m + k -> n < m. Proof. rewrite 2 (nat_add_comm _ k); nrapply lt_reflects_add_l. Defined. (** ** Further properties of subtraction *) Global Instance leq_sub_l n m : n - m <= n. Proof. apply equiv_nat_sub_leq. rewrite nat_sub_comm_r. rewrite nat_sub_cancel. apply nat_sub_zero_l. Defined. (** Subtracting from a successor is the successor of subtracting from the original number, as long as the amount being subtracted is less than or equal to the original number. *) Definition nat_sub_succ_l n m : m <= n -> n.+1 - m = (n - m).+1. Proof. intros H. induction m as [|m IHm] in n, H |- *. - by rewrite 2 nat_sub_zero_r. - simpl. rewrite nat_sub_succ_r. symmetry. apply nat_succ_pred. by apply equiv_lt_lt_sub. Defined. (** Under certain conditions, subtracting a predecessor is the successor of the subtraction. *) Definition nat_sub_pred_r n m : 0 < m -> m < n -> n - nat_pred m = (n - m).+1. Proof. revert m; snrapply gt_zero_ind. intros m H1. rewrite nat_sub_succ_r. rewrite nat_succ_pred. 1: reflexivity. apply equiv_lt_lt_sub. exact (lt_trans _ H1). Defined. (** Subtracting from a sum is the sum of subtracting from the second summand. *) Definition nat_sub_l_add_r m n k : k <= m -> (n + m) - k = n + (m - k). Proof. intros H; induction n as [|n IHn] in |- *. - reflexivity. - change (?n.+1 + ?m) with (n + m).+1. lhs nrapply nat_sub_succ_l. 2: exact (ap nat_succ IHn). exact _. Defined. (** Subtracting from a sum is the sum of subtracting from the first summand. *) Definition nat_sub_l_add_l n m k : k <= n -> (n + m) - k = (n - k) + m. Proof. intro l. rewrite nat_add_comm. lhs rapply nat_sub_l_add_r. apply nat_add_comm. Defined. (** Subtracting a subtraction is the subtrahend. *) Definition nat_sub_sub_cancel_r {n m} : n <= m -> m - (m - n) = n. Proof. intros H; induction H. - by rewrite nat_sub_cancel, nat_sub_zero_r. - rewrite (nat_sub_succ_l m n); only 2: exact _. exact IHleq. Defined. (** Multiplication on the left distributes over subtraction. *) Definition nat_dist_sub_l n m k : n * (m - k) = n * m - n * k. Proof. induction n as [|n IHn] in m, k |- *. 1: reflexivity. destruct (leq_dichotomy k m) as [l|r]. - simpl; rewrite IHn, <- nat_sub_l_add_r, <- nat_sub_l_add_l, nat_sub_r_add; trivial; exact _. - apply leq_lt in r. apply equiv_nat_sub_leq in r. rewrite r. rewrite nat_mul_zero_r. symmetry. apply equiv_nat_sub_leq. apply nat_mul_l_monotone. by apply equiv_nat_sub_leq. Defined. (** Multiplication on the right distributes over subtraction. *) Definition nat_dist_sub_r n m k : (n - m) * k = n * k - m * k. Proof. rewrite 3 (nat_mul_comm _ k). apply nat_dist_sub_l. Defined. (** *** Monotonicity of subtraction *) (** Subtraction is monotone in the left argument. *) Definition nat_sub_monotone_l {n m} k : n <= m -> n - k <= m - k. Proof. intros H. destruct (leq_dichotomy k n) as [l|r]. - apply (leq_reflects_add_l k). rewrite 2 nat_add_sub_r_cancel. + exact H. + rapply leq_trans. + exact l. - apply leq_succ_l in r. apply equiv_nat_sub_leq in r. destruct r^. exact _. Defined. Hint Immediate nat_sub_monotone_l : typeclass_instances. (** Subtraction is contravariantly monotone in the right argument. *) Definition nat_sub_monotone_r {n m} k : n <= m -> k - m <= k - n. Proof. intros H. induction k. - by rewrite nat_sub_zero_l. - destruct (leq_dichotomy m k) as [l|r]. + rewrite 2 nat_sub_succ_l; exact _. + apply equiv_nat_sub_leq in r. destruct r^. exact _. Defined. Hint Immediate nat_sub_monotone_r : typeclass_instances. (** *** Order-reflection lemmas *) (** Subtraction reflects [<=] in the left argument. *) Definition leq_reflects_sub_l {n m} k : k <= m -> n - k <= m - k -> n <= m. Proof. intros ineq1 ineq2. apply (nat_add_r_monotone k) in ineq2. apply (@leq_trans _ (n - k + k) _ (leq_sub_add_l _ _)). apply (@leq_trans _ (m - k + k) _ _). by rewrite nat_add_sub_l_cancel. Defined. (** Subtraction reflects [<=] in the right argument contravariantly. *) Definition leq_reflects_sub_r {n m} k : m <= k -> n <= k -> k - n <= k - m -> m <= n. Proof. intros H1 H2 H3. apply (nat_sub_monotone_r k) in H3. rewrite 2 nat_sub_sub_cancel_r in H3; exact _. Defined. (** *** Movement lemmas *) (** Given an inequality [n < m] we can move around a summand or subtrahend [k] from either side. *) Definition leq_moveL_Mn {n m} k : n - k <= m -> n <= k + m. Proof. intros H. rewrite nat_add_comm. apply (nat_add_r_monotone k) in H. rapply leq_trans. Defined. Definition leq_moveL_nM {n m} k : n - k <= m -> n <= m + k. Proof. rewrite nat_add_comm. apply leq_moveL_Mn. Defined. Definition leq_moveR_Mn {n m} k : k <= m -> n <= m - k -> k + n <= m. Proof. intros H1 H2. rapply (leq_reflects_sub_l k). by rewrite nat_add_sub_cancel_l. Defined. Definition leq_moveR_nM {n m} k : k <= m -> n <= m - k -> n + k <= m. Proof. rewrite nat_add_comm. apply leq_moveR_Mn. Defined. Definition leq_moveL_nV {n m} k : n + k <= m -> n <= m - k. Proof. intros H. apply (leq_reflects_add_r k). rapply leq_trans. Defined. Definition leq_moveR_nV {n m} k : n <= m + k -> n - k <= m. Proof. intros H. apply (nat_sub_monotone_l k) in H. by rewrite nat_add_sub_cancel_r in H. Defined. Definition lt_moveL_Mn {n m} k : n - k < m -> n < k + m. Proof. intros H. apply (nat_add_l_strictly_monotone k) in H. rapply lt_leq_lt_trans. Defined. Definition lt_moveL_nM {n m} k : n - k < m -> n < m + k. Proof. rewrite nat_add_comm. apply lt_moveL_Mn. Defined. Definition lt_moveR_Mn {n m} k : k < m -> n < m - k -> k + n < m. Proof. intros H1 H2. rewrite nat_add_comm. rapply (leq_moveR_nM (n:=n.+1) k). Defined. Definition lt_moveR_nM {n m} k : k < m -> n < m - k -> n + k < m. Proof. rewrite nat_add_comm. apply lt_moveR_Mn. Defined. Definition lt_moveL_nV {n m} k : n + k < m -> n < m - k. Proof. intros H. rapply leq_moveL_nV. Defined. Definition lt_moveR_nV {n m} k : k <= n -> n < k + m -> n - k < m. Proof. intros H1 H2; unfold lt. rewrite <- nat_sub_succ_l; only 2: exact _. rewrite <- (nat_add_sub_cancel_l m k). by apply nat_sub_monotone_l. Defined. (** ** Properties of powers *) (** [0] to any power is [0] unless that power is [0] in which case it is [1]. *) Definition nat_pow_zero_l@{} n : nat_pow 0 n = if dec (n = 0) then 1 else 0. Proof. destruct n; reflexivity. Defined. (** Any number to the power of [0] is [1]. *) Definition nat_pow_zero_r@{} n : nat_pow n 0 = 1 := idpath. (** [1] to any power is [1]. *) Definition nat_pow_one_l@{} n : nat_pow 1 n = 1. Proof. induction n as [|n IHn]; simpl. 1: reflexivity. lhs nrapply nat_add_zero_r. exact IHn. Defined. (** Any number to the power of [1] is itself. *) Definition nat_pow_one_r@{} n : nat_pow n 1 = n := nat_mul_one_r _. (** Exponentiation of natural numbers is distributive over addition on the left. *) Definition nat_pow_add_r@{} n m k : nat_pow n (m + k) = nat_pow n m * nat_pow n k. Proof. induction m as [|m IHm]; simpl. - symmetry. apply nat_add_zero_r. - rhs_V nrapply nat_mul_assoc. exact (ap _ IHm). Defined. (** Exponentiation of natural numbers is distributive over multiplication on the right. *) Definition nat_pow_mul_l@{} n m k : nat_pow (n * m) k = nat_pow n k * nat_pow m k. Proof. induction k as [|k IHk]; simpl. 1: reflexivity. lhs_V nrapply nat_mul_assoc. rhs_V nrapply nat_mul_assoc. nrapply ap. rhs nrapply nat_mul_comm. rhs_V nrapply nat_mul_assoc. nrapply ap. rhs nrapply nat_mul_comm. exact IHk. Defined. (** Exponentiation of natural numbers is distributive over multiplication on the left. *) Definition nat_pow_mul_r@{} n m k : nat_pow n (m * k) = nat_pow (nat_pow n m) k. Proof. induction m as [|m IHm]; simpl. - exact (nat_pow_one_l _)^. - lhs nrapply nat_pow_add_r. rhs nrapply nat_pow_mul_l. nrapply ap. exact IHm. Defined. (** *** Monotonicity of powers *) Definition nat_pow_l_monotone {n m} k : n <= m -> nat_pow k.+1 n <= nat_pow k.+1 m. Proof. intros H; induction H; exact _. Defined. Definition nat_pow_r_monotone {n m} k : n <= m -> nat_pow n k <= nat_pow m k. Proof. intros H; induction k; exact _. Defined. (** ** Strong induction *) (** Sometimes using [nat_ind] is not sufficient to prove a statement as it may be difficult to prove [P n -> P n.+1]. We can strengthen the induction hypothesis by assuming that [P m] holds for all [m] less than [n]. This is known as strong induction. *) Definition nat_ind_strong@{u} (P : nat -> Type@{u}) (IH_strong : forall n, (forall m, m < n -> P m) -> P n) : forall n, P n. Proof. intros n. apply IH_strong. simple_induction n n IHn; intros m H. 1: contradiction (not_lt_zero_r m). apply leq_pred' in H. apply equiv_leq_lt_or_eq in H. destruct H as [H|p]. - by apply IHn. - destruct p. by apply IH_strong. Defined. (** ** An induction principle for two variables with a constraint. *) Definition nat_double_ind_leq@{u} (P : nat -> nat -> Type@{u}) (Hn0 : forall n, P n 0) (Hnn : forall n, P n n) (IH : forall n m, m < n -> (forall m', m' <= n -> P n m') -> P n.+1 m.+1) : forall n m, m <= n -> P n m. Proof. intro n; simple_induction n n IHn; intros m H. - destruct (path_zero_leq_zero_r m H)^; clear H. apply Hn0. - destruct m. + apply Hn0. + apply equiv_leq_lt_or_eq in H. destruct H as [H | []]. 2: apply Hnn. rapply IH. rapply IHn. Defined. Coq-HoTT-9.0/theories/Spaces/Nat/Division.v000066400000000000000000001102321474641544500204720ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.Trunc Basics.Classes Basics.PathGroupoids Basics.Equivalences Types.Sigma Spaces.Nat.Core Basics.Decidable Basics.Iff Types.Prod List.Theory Types.Sum Types.Arrow. Local Set Universe Minimization ToSet. Local Open Scope nat_scope. (** * Division of natural numbers *) (** ** Divisibility *) (** We define divisibility as a relation between natural numbers. *) Class NatDivides (n m : nat) : Type0 := nat_divides : {k : nat & k * n = m}. Notation "( n | m )" := (NatDivides n m) : nat_scope. (** Any number divides [0]. *) Global Instance nat_divides_zero_r n : (n | 0) := (0; idpath). (** [1] divides any number. *) Global Instance nat_divides_one_l n : (1 | n) := (n; nat_mul_one_r _). (** Any number divides itself. Divisibility is a reflexive relation. *) Global Instance nat_divides_refl n : (n | n) := (1; nat_mul_one_l _). Global Instance reflexive_nat_divides : Reflexive NatDivides := nat_divides_refl. (** Divisibility is transitive. *) Definition nat_divides_trans {n m l} : (n | m) -> (m | l) -> (n | l). Proof. intros [x p] [y q]. exists (y * x). lhs_V nrapply nat_mul_assoc. lhs nrapply (ap _ p). exact q. Defined. Hint Immediate nat_divides_trans : typeclass_instances. Global Instance transitive_nat_divides : Transitive NatDivides := @nat_divides_trans. (** A left factor divides a product. *) Global Instance nat_divides_mul_l' n m : (n | n * m) := (m; nat_mul_comm _ _). (** A right factor divides a product. *) Global Instance nat_divides_mul_r' n m : (m | n * m) := (n; idpath). (** Divisibility of the product is implied by divisibility of the left factor. *) Global Instance nat_divides_mul_l {n m} l : (n | m) -> (n | m * l) := fun H => nat_divides_trans _ _. (** Divisibility of the product is implied by divisibility of the right factor. *) Global Instance nat_divides_mul_r {n m} l : (n | m) -> (n | l * m) := fun H => nat_divides_trans _ _. (** Multiplication is monotone with respect to divisibility. *) Global Instance nat_divides_mul_monotone n m l p : (n | m) -> (l | p) -> (n * l | m * p). Proof. intros [x r] [y q]. exists (x * y). destruct r, q. lhs nrapply nat_mul_assoc. rhs nrapply nat_mul_assoc. nrapply (ap (fun x => nat_mul x _)). lhs_V nrapply nat_mul_assoc. rhs_V nrapply nat_mul_assoc. nrapply ap. apply nat_mul_comm. Defined. (** Divisibility of the sum is implied by divisibility of the summands. *) Global Instance nat_divides_add n m l : (n | m) -> (n | l) -> (n | m + l). Proof. intros [x p] [y q]. exists (x + y). destruct p, q. nrapply nat_dist_r. Defined. (** If [n] divides a sum and the left summand, then [n] divides the right summand. *) Definition nat_divides_add_r n m l : (n | m) -> (n | m + l) -> (n | l). Proof. intros [x p] [y q]. exists (y - x). lhs nrapply nat_dist_sub_r. apply nat_moveR_nV. lhs nrapply q. lhs nrapply nat_add_comm. exact (ap _ p^). Defined. (** If [n] divides a sum and the right summand, then [n] divides the left summand. *) Definition nat_divides_add_l n m l : (n | l) -> (n | m + l) -> (n | m). Proof. rewrite nat_add_comm; apply nat_divides_add_r. Defined. (** Divisibility of the difference is implied by divisibility of the minuend and subtrahend. *) Global Instance nat_divides_sub n m l : (n | m) -> (n | l) -> (n | m - l). Proof. intros [x p] [y q]. exists (x - y). destruct p, q. nrapply nat_dist_sub_r. Defined. (** The divisor is greater than zero when the divident is greater than zero. *) Definition gt_zero_divides n m (d : (n | m)) (gt0 : 0 < m) : 0 < n. Proof. destruct d as [d H]. destruct H. destruct (nat_zero_or_gt_zero n) as [z | s]. 2: exact s. (* The remaining case is impossible. *) destruct z; cbn in gt0. rewrite nat_mul_zero_r in gt0. exact gt0. Defined. (** Divisibility implies that the divisor is less than or equal to the dividend. *) Definition leq_divides n m : 0 < m -> (n | m) -> n <= m. Proof. intros H1 [x p]. destruct p, x. 1: contradiction (not_lt_zero_r _ H1). rapply (leq_mul_l _ _ 0). Defined. (** The divisor is strictly less than the dividend when the other factor is greater than one. *) Definition lt_divides n m (d : (n | m)) (gt0 : 0 < m) (gt1 : 1 < d.1) : n < m. Proof. rewrite <- d.2. snrapply (lt_leq_lt_trans (m:=1*n)). 1: rapply (leq_mul_l _ _ 0). srapply (nat_mul_r_strictly_monotone (l:=0)). rapply (gt_zero_divides n m). Defined. (** Divisibility is antisymmetric *) Definition nat_divides_antisym n m : (n | m) -> (m | n) -> n = m. Proof. intros H1 H2. destruct m; only 1: exact (H2.2^ @ nat_mul_zero_r _). destruct n; only 1: exact ((nat_mul_zero_r _)^ @ H1.2). snrapply leq_antisym; nrapply leq_divides; exact _. Defined. Global Instance antisymmetric_divides : AntiSymmetric NatDivides := nat_divides_antisym. (** If [n] divides [m], then the other factor also divides [m]. *) Global Instance divides_divisor n m (H : (n | m)) : (H.1 | m). Proof. exists n. lhs nrapply nat_mul_comm. exact H.2. Defined. (** ** Properties of division *) Local Definition nat_div_mod_unique_helper b q1 q2 r1 r2 : r1 < b -> r2 < b -> q1 < q2 -> b * q1 + r1 <> b * q2 + r2. Proof. intros H1 H2 H3 p. rewrite 2 (nat_add_comm (b * _)) in p. apply nat_moveL_nV in p. rewrite nat_sub_l_add_r in p; only 2: rapply nat_mul_l_monotone. rewrite <- nat_dist_sub_l in p. rewrite nat_add_comm in p. apply nat_moveR_nV in p. nrapply (snd (@leq_iff_not_gt b (r1 - r2))). 2: exact (lt_leq_lt_trans _ H1). rewrite p. snrapply (leq_mul_r _ _ 0). by apply equiv_lt_lt_sub. Defined. (** Quotients and remainders are uniquely determined. *) Definition nat_div_mod_unique d q1 q2 r1 r2 : r1 < d -> r2 < d -> d * q1 + r1 = d * q2 + r2 -> q1 = q2 /\ r1 = r2. Proof. intros H1 H2 p. destruct (nat_trichotomy q1 q2) as [[q | q] | q]. - contradiction (nat_div_mod_unique_helper d q1 q2 r1 r2). - split; trivial. destruct q. by apply isinj_nat_add_l in p. - by contradiction (nat_div_mod_unique_helper d q2 q1 r2 r1). Defined. (** Divisibility by a positive natural number is a hprop. *) Global Instance ishprop_nat_divides n m : 0 < n -> IsHProp (n | m). Proof. intros H. apply hprop_allpath. intros [x p] [y q]. rapply path_sigma_hprop. destruct H as [|n]; simpl. 1: exact ((nat_mul_one_r _)^ @ p @ q^ @ nat_mul_one_r _). refine (fst (nat_div_mod_unique n.+1 x y 0 0 _ _ _)). lhs nrapply nat_add_zero_r. rhs nrapply nat_add_zero_r. rewrite 2 (nat_mul_comm n.+1). exact (p @ q^). Defined. (** This specifies the behaviour of [nat_div_mod_helper] when [u <= y]. *) Definition nat_div_mod_helper_spec x y q u (H : u <= y) : let (q', u') := nat_div_mod x y q u in x + y.+1 * q + (y - u) = y.+1 * q' + (y - u') /\ u' <= y. Proof. intros d r. induction x as [|x IHx] in y, q, u, H, d, r |- *; only 1: by split. destruct u as [|u]. - destruct (IHx y q.+1 y _) as [p H']. split; trivial. rewrite <- p, nat_sub_zero_r, nat_sub_cancel, nat_add_zero_r. simpl. by rewrite nat_add_succ_r, <- 2 nat_add_assoc, nat_mul_succ_r. - destruct (IHx y q u _) as [p H']. split; trivial. rewrite <- p, 2 nat_add_succ_l, <- nat_add_succ_r. snrapply ap. rewrite nat_sub_succ_r. apply nat_succ_pred. rapply lt_moveL_nV. Defined. (** Division and modulo can be put in quotient-remainder form. *) Definition nat_div_mod_spec x y : x = y * (x / y) + x mod y. Proof. destruct y as [|y]; only 1: reflexivity. pose proof (p := fst (nat_div_mod_helper_spec x y 0 y _)). by rewrite nat_mul_zero_r, nat_sub_cancel, 2 nat_add_zero_r in p. Defined. Definition nat_div_mod_spec' x y : x - y * (x / y) = x mod y. Proof. apply nat_moveR_nV. rhs nrapply nat_add_comm. apply nat_div_mod_spec. Defined. Definition nat_div_mod_spec'' x y : x - x mod y = y * (x / y). Proof. apply nat_moveR_nV. apply nat_div_mod_spec. Defined. Definition nat_mod_lt_r' n m r : r < m -> n mod m < m. Proof. intros H; destruct H; only 1: exact _. rapply (lt_leq_lt_trans (m:=m)). Defined. Hint Immediate nat_mod_lt_r' : typeclass_instances. (** [n] modulo [m] is less than [m]. *) Global Instance nat_mod_lt_r n m : 0 < m -> n mod m < m := nat_mod_lt_r' n m 0. (** [n] modulo [m] is less than or equal to [m]. *) Global Instance nat_mod_leq_l n m : n mod m <= n. Proof. rewrite <- nat_div_mod_spec'. rapply leq_moveR_nV. Defined. (** Division is unique. *) Definition nat_div_unique x y q r (H : r < y) (p : y * q + r = x) : x / y = q := fst (nat_div_mod_unique y (x / y) q (x mod y) r _ _ (p @ nat_div_mod_spec x y)^). (** Modulo is unique. *) Definition nat_mod_unique x y q r (H : r < y) (p : y * q + r = x) : x mod y = r := snd (nat_div_mod_unique y (x / y) q (x mod y) r _ _ (p @ nat_div_mod_spec x y)^). (** [0] divided by any number is [0]. *) Definition nat_div_zero_l n : 0 / n = 0. Proof. by induction n. Defined. (** [n] divided by [0] is [0] by convention. *) Definition nat_div_zero_r n : n / 0 = 0 := idpath. (** [n] divided by [1] is [n]. *) Definition nat_div_one_r n : n / 1 = n. Proof. lhs_V nrapply nat_mul_one_l. lhs_V nrapply nat_add_zero_r. symmetry; apply nat_div_mod_spec. Defined. (** [n] divided by [n] is [1]. *) Definition nat_div_cancel n : 0 < n -> n / n = 1. Proof. intros [|m _]; trivial. nrapply (nat_div_unique _ _ _ 0); only 1: exact _. lhs nrapply nat_add_zero_r. nrapply nat_mul_one_r. Defined. (** A number divided by a larger number is 0. *) Definition nat_div_lt n m : n < m -> n / m = 0. Proof. intros H. snrapply (nat_div_unique _ _ _ _ H). by rewrite nat_mul_zero_r, nat_add_zero_l. Defined. (** [n * m] divided by [n] is [m]. *) Definition nat_div_mul_cancel_l n m : 0 < n -> (n * m) / n = m. Proof. intros H. nrapply (nat_div_unique _ _ _ _ H). apply nat_add_zero_r. Defined. (** [n * m] divided by [n] is [m]. *) Definition nat_div_mul_cancel_r n m : 0 < m -> (n * m) / m = n. Proof. rewrite nat_mul_comm. apply nat_div_mul_cancel_l. Defined. (** More generally, [n * m + k] divided by [n] is [m + k / n]. *) Definition nat_div_mul_add_cancel_l n m k : 0 < n -> (n * m + k) / n = m + k / n. Proof. intros H. rapply (nat_div_unique _ _ _ (k mod n) _). rewrite nat_dist_l. lhs_V nrapply nat_add_assoc. f_ap. symmetry; apply nat_div_mod_spec. Defined. Definition nat_div_mul_add_cancel_r n m k : 0 < m -> (n * m + k) / m = n + k / m. Proof. rewrite nat_mul_comm. apply nat_div_mul_add_cancel_l. Defined. (** If [k] is positive, then multiplication on the left is injective; that is, if [k * m = k * n], then [m = n]. *) Definition isinj_nat_mul_l k : 0 < k -> IsInjective (nat_mul k). Proof. intros kp m n p. lhs_V rapply (nat_div_mul_cancel_l k). rhs_V rapply (nat_div_mul_cancel_l k). exact (ap (fun x => x / k) p). Defined. (** If [k] is positive, then multiplication on the right is injective; that is, if [m * k = n * k], then [m = n]. *) Definition isinj_nat_mul_r k : 0 < k -> IsInjective (fun n => nat_mul n k). Proof. intros kp m n p. lhs_V rapply (nat_div_mul_cancel_r _ k). rhs_V rapply (nat_div_mul_cancel_r _ k). exact (ap (fun x => x / k) p). Defined. (** When [d] divides one of the summands, division distributes over addition. *) Definition nat_div_dist n m d : (d | n) -> (n + m) / d = n / d + m / d. Proof. destruct d. 1: reflexivity. intros [x []]. rewrite nat_div_mul_cancel_r. 2: exact _. rapply nat_div_mul_add_cancel_r. Defined. Definition nat_div_dist' n m d : (d | m) -> (n + m) / d = n / d + m / d. Proof. intros H. rewrite (nat_add_comm n m). rhs_V nrapply nat_add_comm. rapply nat_div_dist. Defined. (** In general, [n * (m / n)] is less than or equal to [m]. *) Definition nat_leq_mul_div_l n m : n * (m / n) <= m. Proof. set (tmp := n * (m / n)); rewrite (nat_div_mod_spec m n); unfold tmp; clear tmp. exact _. Defined. (** When [n] divides [m], they are equal. *) Definition nat_mul_div_cancel_r n m : (n | m) -> (m / n) * n = m. Proof. destruct n. { intros [k []]. cbn. symmetry; apply nat_mul_zero_r. } intros [k []]. f_ap. rapply nat_div_mul_cancel_r. Defined. Definition nat_mul_div_cancel_l n m : (n | m) -> n * (m / n) = m. Proof. rewrite nat_mul_comm. apply nat_mul_div_cancel_r. Defined. (** Division by non-zero [k] is strictly monotone if [k] divides the larger number. *) Definition nat_div_strictly_monotone_r {n m l} k : l < k -> n < m -> (k | m) -> n / k < m / k. Proof. intros lk nm km. apply gt_iff_not_leq. intro mknk. apply (@gt_iff_not_leq m n); only 1: apply nm. rewrite <- (nat_mul_div_cancel_l k m km). nrapply (leq_trans (y:=k * (n / k))). - rapply nat_mul_l_monotone. - apply nat_leq_mul_div_l. Defined. (** [0] modulo [n] is [0]. *) Definition nat_mod_zero_l n : 0 mod n = 0. Proof. induction n; trivial. apply nat_sub_cancel. Defined. (** [n] modulo [0] is [n]. *) Definition nat_mod_zero_r n : n mod 0 = n := idpath. Definition nat_mod_lt n k : k < n -> k mod n = k. Proof. intros H. lhs_V nrapply nat_div_mod_spec'. rewrite nat_div_lt. - rewrite nat_mul_zero_r. apply nat_sub_zero_r. - exact H. Defined. (** [n] modulo [1] is [0]. *) Definition nat_mod_one_r n : n mod 1 = 0. Proof. by induction n. Defined. (** If [m] divides [n], then [n mod m = 0]. *) Definition nat_mod_divides n m : (m | n) -> n mod m = 0. Proof. intros [x p]. destruct p. destruct m. { simpl. apply nat_mul_zero_r. } lhs_V nrapply nat_div_mod_spec'. rewrite nat_div_mul_cancel_r; only 2: exact _. apply nat_moveR_nV, nat_mul_comm. Defined. (** [n mod m = 0] iff [m] divides [n]. *) Definition nat_mod_iff_divides n m : n mod m = 0 <-> (m | n) . Proof. split. 2: exact (nat_mod_divides _ _). intros p. exists (n / m). rewrite nat_mul_comm. lhs_V nrapply nat_add_zero_r. rewrite <- p. symmetry. nrapply nat_div_mod_spec. Defined. (** Divisibility is therefore decidable. *) Global Instance decidable_nat_divides n m : Decidable (n | m). Proof. nrapply decidable_iff. 1: apply nat_mod_iff_divides. exact _. Defined. (** [n] modulo [n] is [0]. *) Definition nat_mod_cancel n : n mod n = 0. Proof. destruct n; trivial. snrapply (nat_mod_unique _ _ 1); only 1: exact _. lhs nrapply nat_add_zero_r. nrapply nat_mul_one_r. Defined. (** A number can be corrected so that it is divisible by subtracting the modulo. *) Global Instance nat_divides_sub_mod n m : (n | m - m mod n). Proof. rewrite nat_div_mod_spec''. exact _. Defined. (** ** Further Properties of division and modulo *) (** We can cancel common factors on the left in a division. *) Definition nat_div_cancel_mul_l n m k : 0 < k -> (k * n) / (k * m) = n / m. Proof. intro kp. destruct (nat_zero_or_gt_zero m) as [[] | mp]. 1: by rewrite nat_mul_zero_r. nrapply (nat_div_unique _ _ _ (k * (n mod m))). 1: rapply nat_mul_l_strictly_monotone. rewrite <- nat_mul_assoc. rewrite <- nat_dist_l. apply ap. symmetry; apply nat_div_mod_spec. Defined. (** We can cancel common factors on the right in a division. *) Definition nat_div_cancel_mul_r n m k : 0 < k -> (n * k) / (m * k) = n / m. Proof. rewrite 2 (nat_mul_comm _ k). nrapply nat_div_cancel_mul_l. Defined. (** We can swap the order of division and multiplication on the left under certain conditions. *) Definition nat_div_mul_l n m k : (m | n) -> k * (n / m) = (k * n) / m. Proof. intros H. destruct (nat_zero_or_gt_zero m) as [[] | mp]. 1: snrapply nat_mul_zero_r. rapply (nat_div_unique _ _ _ 0 _ _)^. lhs nrapply nat_add_zero_r. lhs nrapply nat_mul_assoc. lhs nrapply (ap (fun x => x * _)). 1: nrapply nat_mul_comm. lhs_V nrapply nat_mul_assoc. snrapply ap. lhs_V nrapply nat_add_zero_r. rhs nrapply (nat_div_mod_spec n m). snrapply ap. symmetry. rapply nat_mod_divides. Defined. (** We can swap the order of division and multiplication on the right under certain conditions. *) Definition nat_div_mul_r n m k : (m | n) -> (n / m) * k = (n * k) / m. Proof. rewrite 2 (nat_mul_comm _ k). snrapply nat_div_mul_l. Defined. Definition nat_div_sub_mod n m : n / m = (n - n mod m) / m. Proof. destruct (nat_zero_or_gt_zero m) as [[] | mp]. 1: reflexivity. symmetry. rewrite nat_div_mod_spec''. rapply nat_div_mul_cancel_l. Defined. (** Dividing a quotient is the same as dividing by the product of the divisors. *) Definition nat_div_div_l n m k : (n / m) / k = n / (m * k). Proof. destruct (nat_zero_or_gt_zero k) as [[] | kp]. 1: by rewrite nat_mul_zero_r. destruct (nat_zero_or_gt_zero m) as [[] | mp]. 1: snrapply nat_div_zero_l. apply nat_div_unique with (r := (n mod (m * k)) / m). { apply (lt_lt_leq_trans (m:=(m * k)/m)). - rapply nat_div_strictly_monotone_r. nrapply (nat_mod_lt_r' _ _ 0 _). exact (nat_mul_strictly_monotone mp kp). - by rewrite nat_div_mul_cancel_l. } transitivity ((m * (k * (n / (m * k)))) / m + (n mod (m * k)) / m). - f_ap. symmetry; rapply nat_div_mul_cancel_l. - rewrite nat_mul_assoc. lhs_V nrapply nat_div_dist. 1: exact _. apply (ap (fun x => x / m)). symmetry; apply nat_div_mod_spec. Defined. (** Dividing a number by a quotient is the same as dividing the product of the number with the denominator of the quotient by the numerator of the quotient. *) Definition nat_div_div_r n m k : (k | m) -> n / (m / k) = (n * k) / m. Proof. intros [d r]. destruct (nat_zero_or_gt_zero k) as [[] | kp]. 1: by rewrite nat_mul_zero_r, nat_div_zero_l. destruct r. rhs nrapply nat_div_cancel_mul_r. 2: exact _. apply ap. rapply nat_div_mul_cancel_r. Defined. (** A variant of [nat_div_div_r] without the divisibility assumption, by modifying [m] to become divisible. *) Definition nat_div_div_r' n m k : n / (m / k) = (n * k) / (m - m mod k). Proof. rewrite (nat_div_sub_mod m k). rapply nat_div_div_r. Defined. (** We can cancel common factors on the left in a modulo. *) Definition nat_mod_mul_l n m k : (k * n) mod (k * m) = k * (n mod m). Proof. destruct (nat_zero_or_gt_zero k) as [[] | kp]. 1: reflexivity. destruct (nat_zero_or_gt_zero m) as [[] | mp]. 1: by rewrite nat_mul_zero_r. apply (nat_mod_unique _ _ (n / m)). 1: rapply nat_mul_l_strictly_monotone. rewrite <- nat_mul_assoc. rewrite <- nat_dist_l. apply ap. symmetry; apply nat_div_mod_spec. Defined. (** We can cancel common factors on the right in a modulo. *) Definition nat_mod_mul_r n m k : (n * k) mod (m * k) = (n mod m) * k. Proof. rewrite 3 (nat_mul_comm _ k). nrapply nat_mod_mul_l. Defined. (** We can move a divisor from the right to become a factor on the left of an equation. *) Definition nat_div_moveL_nV n m k : 0 < k -> n * k = m -> n = m / k. Proof. intros H p. rewrite <- p. symmetry. rapply nat_div_mul_cancel_r. Defined. (** ** Greatest Common Divisor *) (** The greatest common divisor of [0] and a number is the number itself. *) Definition nat_gcd_zero_l n : nat_gcd 0 n = n := idpath. (** The greatest common divisor of a number and [0] is the number itself. *) Definition nat_gcd_zero_r n : nat_gcd n 0 = n. Proof. induction n; simpl; only 1: reflexivity. by rewrite nat_sub_cancel. Defined. (** The greatest common divisor of [1] and any number is [1]. *) Definition nat_gcd_one_l n : nat_gcd 1 n = 1 := idpath. (** The greatest common divisor of any number and [1] is [1]. *) Definition nat_gcd_one_r n : nat_gcd n 1 = 1. Proof. destruct n; trivial. simpl. destruct n; trivial. rewrite nat_sub_succ_l; only 2: exact _. by rewrite nat_sub_cancel. Defined. (** Idempotency. *) Definition nat_gcd_idem n : nat_gcd n n = n. Proof. induction n. 1: reflexivity. unfold nat_gcd; fold nat_gcd. by rewrite nat_mod_cancel. Defined. (** We can prove that the greatest common divisor of [n] and [m] divides both [n] and [m]. This proof requires strong induction. *) Definition nat_divides_l_gcd n m : (nat_gcd n m | n) /\ (nat_gcd n m | m). Proof. revert n m; snrapply nat_ind_strong; intros n IHn m. destruct n. 1: split; exact _. destruct (IHn (m mod n.+1) _ n.+1) as [H1 H2]. unfold nat_gcd; fold nat_gcd. set (n' := n.+1) in *. split; only 1: exact H2. set (r := m mod n'); rewrite (nat_div_mod_spec m n'); unfold r; clear r. exact _. Defined. (** The greatest common divisor of [n] and [m] divides [n]. *) Global Instance nat_divides_l_gcd_l n m : (nat_gcd n m | n) := fst (nat_divides_l_gcd n m). (** The greatest common divisor of [n] and [m] divides [m]. *) Global Instance divides_l_nat_gcd_r n m : (nat_gcd n m | m) := snd (nat_divides_l_gcd n m). (** We can prove that any common divisor of [n] and [m] divides the greatest common divisor of [n] and [m]. It is in that sense the greatest. *) Global Instance nat_divides_r_gcd n m p : (p | n) -> (p | m) -> (p | nat_gcd n m). Proof. revert n m p; snrapply nat_ind_strong; intros n IHn m p H1 H2. destruct n; only 1: exact _. unfold nat_gcd; fold nat_gcd. apply IHn; only 1,3: exact _. rewrite (nat_div_mod_spec m n.+1) in H2. apply nat_divides_add_r in H2; exact _. Defined. Definition nat_divides_r_iff_divides_r_gcd n m p : (p | n) * (p | m) <-> (p | nat_gcd n m). Proof. split; [intros [H1 H2] | intros H; split]; exact _. Defined. (** If [p] is divisible by all common divisors of [n] and [m], and [p] is also a common divisor, then it must necesserily be equal to the greatest common divisor. *) Definition nat_gcd_unique n m p (H : forall q, (q | n) -> (q | m) -> (q | p)) : (p | n) -> (p | m) -> nat_gcd n m = p. Proof. intros H1 H2. rapply nat_divides_antisym. Defined. (** As a corollary of uniquness, we get that the greatest common divisor operation is commutative. *) Definition nat_gcd_comm n m : nat_gcd n m = nat_gcd m n. Proof. rapply nat_gcd_unique. Defined. (** [nat_gcd] is associative. *) Definition nat_gcd_assoc n m k : nat_gcd n (nat_gcd m k) = nat_gcd (nat_gcd n m) k. Proof. nrapply nat_gcd_unique. - intros q H1 H2. rapply nat_divides_r_gcd. - rapply (nat_divides_trans (nat_divides_l_gcd_l _ _)). - apply nat_divides_r_gcd; rapply nat_divides_trans. Defined. (** If [nat_gcd n m] is [0], then [n] must also be [0]. *) Definition nat_gcd_is_zero_l n m : nat_gcd n m = 0 -> n = 0. Proof. intros H. generalize (nat_divides_l_gcd_l n m). rewrite H. intros [x p]. exact (p^ @ nat_mul_zero_r _). Defined. (** If [nat_gcd n m] is [0], then [m] must also be [0]. *) Definition nat_gcd_is_zero_r n m : nat_gcd n m = 0 -> m = 0. Proof. rewrite nat_gcd_comm. apply nat_gcd_is_zero_l. Defined. (** [nat_gcd n m] is [0] if and only if both [n] and [m] are [0]. *) Definition nat_gcd_zero_iff_zero n m : nat_gcd n m = 0 <-> n = 0 /\ m = 0. Proof. split. - split. + by apply (nat_gcd_is_zero_l _ m). + by apply (nat_gcd_is_zero_r n). - intros [-> ->]. reflexivity. Defined. (** [nat_gcd] is positive for positive inputs. *) Global Instance nat_gcd_pos n m : 0 < n -> 0 < m -> 0 < nat_gcd n m. Proof. intros H1 H2. apply lt_iff_not_geq. intros H3; hnf in H3. apply path_zero_leq_zero_r in H3. apply nat_gcd_zero_iff_zero in H3. destruct H3 as [->]. contradiction (not_lt_zero_r _ H1). Defined. Definition nat_gcd_l_add_r_mul n m k : nat_gcd (n + k * m) m = nat_gcd n m. Proof. rapply nat_gcd_unique. intros q H1 H2. rapply nat_divides_r_gcd. rapply (nat_divides_add_l _ _ (k * m)). Defined. Definition nat_gcd_r_add_r_mul n m k : nat_gcd n (m + k * n) = nat_gcd n m. Proof. lhs nrapply nat_gcd_comm. rhs nrapply nat_gcd_comm. nrapply nat_gcd_l_add_r_mul. Defined. Definition nat_gcd_l_add_r n m : nat_gcd (n + m) m = nat_gcd n m. Proof. rhs_V nrapply (nat_gcd_l_add_r_mul n m 1). by rewrite nat_mul_one_l. Defined. Definition nat_gcd_r_add_r n m : nat_gcd n (m + n) = nat_gcd n m. Proof. lhs nrapply nat_gcd_comm. rhs nrapply nat_gcd_comm. nrapply nat_gcd_l_add_r. Defined. Definition nat_gcd_l_sub n m : m <= n -> nat_gcd (n - m) m = nat_gcd n m. Proof. intros H. lhs_V nrapply nat_gcd_l_add_r. by rewrite (nat_add_sub_l_cancel H). Defined. Definition nat_gcd_r_sub n m : n <= m -> nat_gcd n (m - n) = nat_gcd n m. Proof. intros H. lhs nrapply nat_gcd_comm. rhs nrapply nat_gcd_comm. rapply nat_gcd_l_sub. Defined. (** ** Bezout's Identity *) (** Bezout's identity states that for any two numbers [n] and [m], their greatest common divisor can be written as a linear combination of [n] and [m]. This is easy to state for the integers, however since we are working with the natural numbers, we need to be more careful. This is why we write the linear combination as [a * n = d + b * m] rather than the usual [a * n + b * m = d]. *) (** We define a predicate for triples of integers satisfying Bezout's identity. *) Definition NatBezout n m d : Type0 := exists a b, a * n = d + b * m. Existing Class NatBezout. Global Instance nat_bezout_refl_l n k : NatBezout n k n. Proof. by exists 1, 0. Defined. (** If [a * n = 1 + b * m], then the gcd of [n] and [m] is [1]. *) Definition nat_bezout_coprime n m : NatBezout n m 1 -> nat_gcd n m = 1. Proof. intros [a [b p]]. rapply nat_gcd_unique. intros q H1 H2. rapply (nat_divides_add_l _ _ (b * m)). destruct p; exact _. Defined. Definition nat_bezout_comm n m d : 0 < m -> NatBezout n m d -> NatBezout m n d. Proof. intros H [a [b p]]. destruct (@equiv_leq_lt_or_eq 0 a _) as [|q]. - exists (n * a.+1 * b.+1 - b), (m * a.+1 * b.+1 - a). rewrite 2 nat_dist_sub_r. apply nat_moveR_nV. rewrite <- nat_add_comm, nat_add_assoc, <- (nat_add_comm d). rewrite <- nat_sub_l_add_r. 2: { apply nat_mul_r_monotone. rewrite 2 nat_mul_succ_r. nrapply (leq_trans _ (leq_add_l _ _)). rapply (leq_trans _ (leq_add_r _ _)). } apply nat_moveL_nV. rewrite nat_add_comm. snrapply (ap011 nat_add p). lhs nrapply nat_mul_comm. rhs_V nrapply nat_mul_assoc. rhs_V nrapply nat_mul_assoc. snrapply ap. lhs_V nrapply nat_mul_assoc. rhs nrapply nat_mul_assoc. apply nat_mul_comm. - destruct q. exists 0, 0. rewrite 2 nat_mul_zero_l, nat_add_zero_r in *. symmetry in p; symmetry. apply equiv_nat_add_zero in p. by destruct p. Defined. Hint Immediate nat_bezout_comm : typeclass_instances. Global Instance nat_bezout_pos_l n m : 0 < n -> NatBezout n m (nat_gcd n m). Proof. pose (k := n + m); assert (p : n + m = k) by reflexivity; clearbody k. revert k n m p; snrapply nat_ind_strong; hnf; intros k IHk n m q H. (** Given a sum [n + m], we can always find another pair [n' + m'] equal to that sum such that [n' < m']. This extra hypothesis lets us prove the statement more directly. *) assert (H' : forall n' m', n + m = n' + m' -> 0 < n' -> n' < m' -> NatBezout n' m' (nat_gcd n' m')). { intros n' m' p H1 H2; destruct q. assert (m' < n + m) by (rewrite p; change (0 + m' < n' + m'); exact _). destruct (IHk m' _ n' (m' - n') (nat_add_sub_r_cancel _) _) as [a [b r]]. exists (a + b), b. rewrite nat_dist_r, r, nat_dist_sub_l, <- nat_add_assoc. rewrite nat_add_sub_l_cancel; only 2: rapply nat_mul_l_monotone. snrapply (ap (fun x => x + _)). rapply nat_gcd_r_sub. } destruct (nat_trichotomy n m) as [[l | p] | r]. - by apply H'. - destruct p. rewrite nat_gcd_idem; exact _. - destruct (@equiv_leq_lt_or_eq 0 m _). + rewrite nat_gcd_comm. rapply nat_bezout_comm. rapply H'. apply nat_add_comm. + destruct p. rewrite nat_gcd_zero_r; exact _. Defined. (** For strictly positive numbers, we have Bezout's identity in both directions. *) Definition nat_bezout_pos n m : 0 < n -> 0 < m -> NatBezout n m (nat_gcd n m) /\ NatBezout m n (nat_gcd n m). Proof. intros H1 H2; split; [| apply nat_bezout_comm]; exact _. Defined. (** For arbitrary natural numbers, we have Bezout's identity in at least one direction. *) Definition nat_bezout n m : NatBezout n m (nat_gcd n m) + NatBezout m n (nat_gcd n m). Proof. destruct n; [ right | left ]; exact _. Defined. (** ** Prime Numbers *) (** A prime number is a number greater than [1] that is only divisible by [1] and itself. *) Class IsPrime (n : nat) : Type0 := { gt_one_isprime :: 1 < n; isprime : forall m, (m | n) -> (m = 1) + (m = n); }. Definition issig_IsPrime n : _ <~> IsPrime n := ltac:(issig). Global Instance ishprop_isprime `{Funext} n : IsHProp (IsPrime n). Proof. nrapply istrunc_equiv_istrunc. 1: apply issig_IsPrime. rapply istrunc_sigma. intros H1. snrapply istrunc_forall. intros m. snrapply istrunc_forall. intros d. rapply ishprop_sum. intros p q. nrapply (snd neq_iff_lt_or_gt _ (p^ @ q)). by left. Defined. (** [0] is not a prime number. *) Definition not_isprime_zero : ~ IsPrime 0. Proof. intros H. rapply not_lt_zero_r. Defined. (** [1] is not a prime number. *) Definition not_isprime_one : ~ IsPrime 1. Proof. intros H. rapply (lt_irrefl 1). Defined. (** Being prime is a decidable property. We give an inefficient procedure for determining primality. More efficient procedures can be given, but for proofs this suffices. *) Global Instance decidable_isprime@{} n : Decidable (IsPrime n). Proof. (** First we begin by discarding the [n = 0] case as we can easily prove that [0] is not prime. *) destruct n. 1: right; apply not_isprime_zero. (** Next, we rewrite [IsPrime n.+1] as the equivalent sigma type. *) nrapply decidable_equiv'. 1: nrapply issig_IsPrime. (** The condition in the first component in [IsPrime] is clearly decidable, so we can proceed to the second component. *) nrapply decidable_equiv'. 1: exact (equiv_sigma_prod0 _ _)^-1%equiv. snrapply decidable_prod. 1: exact _. (** In order to show that this [forall] is decidable, we will exhibit it as a [for_all] statement over a given list. The predicate will be the conclusion we wish to reach here, and the list will consist of all numbers with a condition equivalent to the divisibility condition. *) pose (P := fun m => ((m = 1) + (m = n.+1))%type : Type0). pose (l := list_filter (seq n.+2) (fun x => (x | n.+1)) _). rapply (decidable_iff (A := for_all P l)). split. - intros Pl x d. apply inlist_for_all with l x in Pl. 1: exact Pl. apply inlist_filter. split; only 2: assumption. apply inlist_seq. apply leq_divides in d. 1,2: exact _. - intros H. apply for_all_inlist. intros x H'. apply inlist_filter in H'. destruct H' as [p H']. apply inlist_seq in p. rapply H. Defined. (** We can show that the first 8 primes are prime as expected. *) Global Instance isprime_2 : IsPrime 2 := ltac:(decide). Global Instance isprime_3 : IsPrime 3 := ltac:(decide). Global Instance isprime_5 : IsPrime 5 := ltac:(decide). Global Instance isprime_7 : IsPrime 7 := ltac:(decide). Global Instance isprime_11 : IsPrime 11 := ltac:(decide). Global Instance isprime_13 : IsPrime 13 := ltac:(decide). Global Instance isprime_17 : IsPrime 17 := ltac:(decide). Global Instance isprime_19 : IsPrime 19 := ltac:(decide). (** Similarly, we can see that other natural numbers are not prime. *) Definition not_isprime_0 : not (IsPrime 0) := ltac:(decide). Definition not_isprime_1 : not (IsPrime 1) := ltac:(decide). Definition not_isprime_4 : not (IsPrime 4) := ltac:(decide). (** We can define the type of prime numbers as a subtype of natural numbers. *) Definition Prime : Type0 := {n : nat & IsPrime n}. Coercion nat_of_prime (p : Prime) : nat := p.1. Global Instance isprime_prime (p : Prime) : IsPrime p := p.2. Global Instance lt_zero_prime (p : Prime) : 0 < p := lt_trans _ gt_one_isprime. (** A prime [p] is coprime to a natural number [n] iff [p] does not divide [n]. *) Definition nat_coprime_iff_not_divides (p : Prime) n : nat_gcd p n = 1 <-> ~ (p | n). Proof. split. - intros q [d r]. destruct r. rewrite (nat_gcd_r_add_r_mul p 0) in q. rewrite nat_gcd_zero_r in q. apply (@neq_iff_lt_or_gt p 1). 1: right; exact _. exact q. - intros nd. rapply nat_gcd_unique. intros q H1 H2. apply isprime in H1. destruct H1 as [H1|H1]. + destruct H1; exact _. + destruct H1; contradiction. Defined. (** When a prime number divides a multiple, then the prime must divide one of the factors. *) Definition nat_divides_prime_l (p : Prime) n m : (p | n * m) -> (p | n) + (p | m). Proof. intros d. destruct (dec (p | n)) as [H|H]. 1: by left. right. apply nat_coprime_iff_not_divides in H. destruct (nat_bezout_pos_l p n _) as [x [y q]]. destruct H^; clear H. destruct d as [d r]. exists (x * m - y * d). lhs nrapply nat_dist_sub_r. rewrite <- 2 nat_mul_assoc. rewrite <- (nat_mul_comm p). destruct r^; clear r. rewrite 2 nat_mul_assoc. lhs_V nrapply nat_dist_sub_r. rhs_V nrapply nat_mul_one_l. apply (ap (fun x => nat_mul x m)). apply nat_moveR_nV. exact q. Defined. (** ** Composite Numbers *) (** A natural number larger than [1] is composite if it has a divisor other than [1] and itself. *) Class IsComposite n : Type0 := iscomposite : exists a, 1 < a < n /\ (a | n). Definition gt_1_iscomposite@{} n : IsComposite n -> 1 < n. Proof. intros [a [[H1 H2] H3]]. exact _. Defined. Hint Immediate gt_1_iscomposite : typeclass_instances. (** Being composite is a decidable property. *) Global Instance decidable_iscomposite@{} n : Decidable (IsComposite n). Proof. unfold IsComposite. rapply (decidable_exists_nat n). intros k c. exact (snd (fst c)). Defined. (** For a number larger than [1], being prime is equivalent to not being composite. *) Definition isprime_iff_not_iscomposite@{} n : IsPrime n <-> 1 < n /\ ~ IsComposite n. Proof. split. - intros H. split; only 1: exact _. intros [a [[H2 H3] H4]]. apply isprime in H4. destruct H4 as [H4|H4]; destruct H4; exact (lt_irrefl _ _). - intros [H1 H]. rapply Build_IsPrime. intros m d. destruct (dec (1 < d.1)) as [H2|H2]. + pose proof (divides_divisor _ _ d) as d'. apply leq_divides in d'. 2: exact _. apply equiv_leq_lt_or_eq in d'. destruct d' as [d'|d']. * assert (H' : IsComposite n). { exists d.1. split; only 1: split; exact _. } contradiction H. * destruct d as [d r]. simpl in *. destruct d'. left. rewrite <- nat_div_cancel with d. 2: exact _. rewrite <- nat_div_mul_cancel_l with d m. 2: exact _. by apply (ap (fun x => x / d)). + apply geq_iff_not_lt in H2. destruct d as [d r]. simpl in *; hnf in H2. destruct d. { rewrite nat_mul_zero_l in r. destruct n. 1: contradiction (not_lt_zero_r _ H1). contradiction (neq_nat_zero_succ _ r). } destruct d. { rewrite nat_mul_one_l in r. by right. } apply leq_pred' in H2. contradiction (not_lt_zero_r d). Defined. (** And since [IsComposite] is decidable, we can show that being not prime is equivalent to being composite. *) Definition not_isprime_iff_iscomposite@{} n : 1 < n /\ ~ IsPrime n <-> IsComposite n. Proof. nrapply iff_compose. - nrapply iff_functor_prod. 1: nrapply iff_refl. nrapply iff_compose. + apply iff_not. rapply isprime_iff_not_iscomposite. + rapply iff_not_prod. - nrapply iff_compose. 1: nrapply sum_distrib_l. nrapply iff_compose. + nrapply iff_functor_sum. 1: apply iff_contradiction. nrapply iff_functor_prod. 1: nrapply iff_refl. rapply iff_stable. + nrapply iff_compose. 1: rapply sum_empty_l. split; only 1: exact snd. intros H; split; only 2: exact H. exact _. Defined. (** ** Fundamental theorem of arithmetic *) (** Every natural number greater than [1] has a prime divisor. *) Definition exists_prime_divisor@{} n : 1 < n -> exists (p : Prime), (p | n). Proof. revert n; snrapply nat_ind_strong; hnf; intros n IHn H. destruct (dec (IsPrime n)) as [x|x]. 1: exists (_; x); exact _. pose (r := (H, x)). apply not_isprime_iff_iscomposite in r. destruct r as [d [[H1 H2] H3]]. destruct (IHn d _ _) as [p r]. exists p. exact _. Defined. (** Any natural number can either be written as a product of primes or is zero. *) Definition prime_factorization@{} n : 0 < n -> exists (l : list Prime), n = fold_right (fun (p : Prime) n => nat_mul p n) 1 l. Proof. revert n; snrapply nat_ind_strong; hnf; intros n IHn H. destruct H as [|n IH]. 1: exists nil; reflexivity. destruct (exists_prime_divisor n.+1 _) as [p d]. pose proof (l := lt_divides d.1 n.+1 _ _ _). destruct d as [k H]. destruct (IHn k l) as [f r]. { destruct H, k. 1: contradiction (lt_irrefl 0). exact _. } exists (p :: f)%list. simpl; destruct r. symmetry. lhs nrapply nat_mul_comm. exact H. Defined. (** TODO: show that any two prime factorizations are unique up to permutation of the lists. *) Coq-HoTT-9.0/theories/Spaces/Nat/Factorial.v000066400000000000000000000064511474641544500206210ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Decidable Spaces.Nat.Core Spaces.Nat.Division Tactics.EvalIn. Local Set Universe Minimization ToSet. Local Open Scope nat_scope. (** * Factorials *) (** ** Definition *) Fixpoint factorial n := match n with | 0 => 1 | S n => S n * factorial n end. (** ** Properties *) (** The factorial of [0] is [1]. *) Definition nat_factorial_zero : factorial 0 = 1 := idpath. (** The factorial of [n + 1] is [n + 1] times the factorial of [n]. *) Definition nat_factorial_succ n : factorial n.+1 = n.+1 * factorial n := idpath. (** A variant of [nat_factorial_succ]. *) Definition nat_factorial_pred n : 0 < n -> factorial n = n * factorial (nat_pred n). Proof. intros []; reflexivity. Defined. (** Every factorial is positive. *) Global Instance lt_zero_factorial n : 0 < factorial n. Proof. induction n; exact _. Defined. (** Except for [factorial 0 = factorial 1], the [factorial] function is strictly monotone. We separate out the successor case since it is used twice in the proof of the general result. *) Definition nat_factorial_strictly_monotone_succ n : 0 < n -> factorial n < factorial n.+1. Proof. intro H. rewrite <- (nat_mul_one_l (factorial n)). rapply (nat_mul_r_strictly_monotone _). Defined. Global Instance nat_factorial_strictly_monotone n m : 0 < n -> n < m -> factorial n < factorial m. Proof. intros H1 H2; induction H2. - rapply nat_factorial_strictly_monotone_succ. - apply (lt_trans IHleq). rapply nat_factorial_strictly_monotone_succ. Defined. (** ** Divisibility *) (** Any number less than or equal to [n] divides [factorial n]. *) Global Instance nat_divides_factorial_factor n m : 0 < n -> n <= m -> (n | factorial m). Proof. intros [] H2. 1: exact _. induction H2; exact _. Defined. (** [factorial] is a monotone function from [nat] to [nat] with respect to [<=] and divides. *) Global Instance nat_divides_factorial_lt n m : n <= m -> (factorial n | factorial m). Proof. intros H; induction H; exact _. Defined. (** A product of factorials divides the factorial of the sum. *) Global Instance nat_divides_factorial_mul_factorial_add n m : (factorial n * factorial m | factorial (n + m)). Proof. remember (n + m) as k eqn:p. revert k n m p; snrapply nat_ind_strong; hnf; intros k IH n m p. destruct k. { apply equiv_nat_add_zero in p. destruct p as [p q]. destruct p^, q^. exact _. } rewrite_refl nat_factorial_succ. rewrite <- p. rewrite nat_dist_r. assert (helper : forall n' m' (p' : n' + m' = k.+1), (factorial n' * factorial m' | n' * factorial k)). - intros n' m' p'. destruct n'; only 1: exact _. rewrite nat_factorial_succ. rewrite <- nat_mul_assoc. rapply nat_divides_mul_monotone. rapply IH. exact (ap nat_pred p'). - nrapply nat_divides_add. + apply helper, p. + rewrite nat_mul_comm. apply helper. lhs nrapply nat_add_comm; exact p. Defined. (** Here is a variant of [nat_divides_factorial_mul_factorial_add] that is more suitable for binomial coefficients. *) Global Instance nat_divides_factorial_mul_factorial_add' n m : m <= n -> (factorial m * factorial (n - m) | factorial n). Proof. intros H. rewrite <- (ap factorial (nat_add_sub_r_cancel H)). apply nat_divides_factorial_mul_factorial_add. Defined. Coq-HoTT-9.0/theories/Spaces/Nat/Paths.v000066400000000000000000000025271474641544500177740ustar00rootroot00000000000000Require Import Basics. Require Export Basics.Nat. Require Export HoTT.Universes.DProp. (** * Characterization of the path types of [nat] *) (** We characterize the path types of [nat]. We put this in its own file because it uses DProp, which has a lot of dependencies. *) Local Set Universe Minimization ToSet. Local Close Scope trunc_scope. Local Open Scope nat_scope. Fixpoint code_nat (m n : nat) {struct m} : DHProp@{Set} := match m, n with | 0, 0 => True | m'.+1, n'.+1 => code_nat m' n' | _, _ => False end. Infix "=n" := code_nat : nat_scope. Fixpoint idcode_nat {n} : (n =n n) := match n as n return (n =n n) with | 0 => tt | S n' => @idcode_nat n' end. Fixpoint path_nat {n m} : (n =n m) -> (n = m) := match m as m, n as n return (n =n m) -> (n = m) with | 0, 0 => fun _ => idpath | m'.+1, n'.+1 => fun H : (n' =n m') => ap S (path_nat H) | _, _ => fun H => match H with end end. Global Instance isequiv_path_nat {n m} : IsEquiv (@path_nat n m). Proof. refine (isequiv_adjointify (@path_nat n m) (fun H => transport (fun m' => (n =n m')) H idcode_nat) _ _). { intros []; simpl. induction n; simpl; trivial. by destruct (IHn^)%path. } { intro. apply path_ishprop. } Defined. Definition equiv_path_nat {n m} : (n =n m) <~> (n = m) := Build_Equiv _ _ (@path_nat n m) _. Coq-HoTT-9.0/theories/Spaces/No.v000066400000000000000000000002121474641544500165340ustar00rootroot00000000000000Require HoTT.Spaces.No.Core. Include HoTT.Spaces.No.Core. Require Export HoTT.Spaces.No.Negation. Require Export HoTT.Spaces.No.Addition. Coq-HoTT-9.0/theories/Spaces/No/000077500000000000000000000000001474641544500163525ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/No/Addition.v000066400000000000000000000413711474641544500203020ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HoTT.Spaces.No.Core HoTT.Spaces.No.Negation. Local Open Scope path_scope. Local Open Scope surreal_scope. (** * Addition of surreal numbers *) (** Addition requires the option sorts to be closed under finite sums. *) Class HasAddition (S : OptionSort) := { empty_options : InSort S Empty Empty ; sum_options : forall L R L' R', InSort S L R -> InSort S L' R' -> InSort S (L + L') (R + R') }. Global Existing Instance empty_options. Global Existing Instance sum_options. Global Instance hasaddition_maxsort : HasAddition MaxSort := { empty_options := tt ; sum_options := fun _ _ _ _ _ _ => tt }. Global Instance hasaddition_ordsort : HasAddition OrdSort := { empty_options := idmap ; sum_options := fun _ _ _ _ f g => sum_ind _ f g }. Global Instance hasaddition_decsort : HasAddition DecSort. Proof. constructor. - apply insort_decsort. - intros L R L' R' [? ?] [? ?]; split; exact _. Qed. Section Addition. Context `{Univalence}. Universe i. Context {S : OptionSort@{i}} `{HasAddition S}. Let No := GenNo S. Section Inner. Context {L R : Type@{i} } {Sx : InSort S L R} (xL : L -> No) (xR : R -> No) (xcut : forall (l : L) (r : R), xL l < xR r). Let A := {g : No -> No & (forall x y : No, x <= y -> g x <= g y) * (forall x y : No, x < y -> g x < g y)}. Context (xL_plus : L -> A) (xR_plus : R -> A) (xL_lt_xR_plus : forall (l : L) (r : R) (x : No), (xL_plus l).1 x < (xR_plus r).1 x). Definition plus_inner : { g : forall (y : No), { x_plus_y : No & (forall l, (xL_plus l).1 y < x_plus_y) * (forall r, x_plus_y < (xR_plus r).1 y) } & (forall y z : No, y <= z -> (g y).1 <= (g z).1) * (forall y z : No, y < z -> (g y).1 < (g z).1) }. Proof. simple refine (No_ind_package (fun y => { x_plus_y : No & (forall l, (xL_plus l).1 y < x_plus_y) * (forall r, x_plus_y < (xR_plus r).1 y) }) (fun _ _ _ z w => z.1 <= w.1) (fun _ _ _ z w => z.1 < w.1) _ _ _ _ _). - intros L' R' ? yL yR ycut x_plus_yL x_plus_yR x_plus_yL_lt_yR. pose (L'' := L + L'). pose (R'' := R + R'). pose (zL := sum_ind (fun _ => No) (fun l => (xL_plus l).1 {{ yL | yR // ycut }}) (fun l => (x_plus_yL l).1) : L'' -> No). pose (zR := sum_ind (fun _ => No) (fun r => (xR_plus r).1 {{ yL | yR // ycut }}) (fun r => (x_plus_yR r).1) : R'' -> No). assert (zcut : forall (l:L'') (r:R''), zL l < zR r). { abstract ( intros [l|l] [r|r]; cbn; [ apply xL_lt_xR_plus | transitivity ((xL_plus l).1 (yR r)); [ apply (snd (xL_plus l).2), lt_ropt; exact _ | exact (fst (x_plus_yR r).2 l) ] | transitivity ((xR_plus r).1 (yL l)); [ exact (snd (x_plus_yL l).2 r) | apply (snd (xR_plus r).2), lt_lopt; exact _ ] | apply x_plus_yL_lt_yR ]). } assert (InSort S L'' R'') by (apply sum_options; exact _). exists ({{ zL | zR // zcut }}); split. + intros l. refine (lt_lopt zL zR zcut (inl l)). + intros r. refine (lt_ropt zL zR zcut (inl r)). - abstract ( intros x y [a ?] [b ?] p q r s; rewrite transport_sigma; cbn in *; apply path_sigma_hprop, path_No; cbn; rewrite transport_const; assumption). - abstract ( intros L' R' ? yL yR ycut x_plus_yL x_plus_yR x_plus_yL_lt_yR L'' R'' ? zL zR zcut x_plus_zL x_plus_zR x_plus_zL_lt_zR yL_lt_z x_plus_yL_lt_z y_lt_zR x_plus_y_lt_zR; cbn in *; apply le_lr; [ intros [l|l] | intros [r|r] ]; cbn; [ refine (le_lt_trans (fst (xL_plus l).2 _ {{ zL | zR // zcut}} _) _); [ by (apply le_lr; assumption) | refine (lt_lopt _ _ _ (inl l)) ] | exact (x_plus_yL_lt_z l) | refine (lt_le_trans _ (fst (xR_plus r).2 {{ yL | yR // ycut}} _ _)); [ refine (lt_ropt _ _ _ (inl r)) | by (apply le_lr; assumption) ] | exact (x_plus_y_lt_zR r) ] ). - abstract ( intros L' R' ? yL yR ycut x_plus_yL x_plus_yR x_plus_yL_lt_yR L'' R'' ? zL zR zcut x_plus_zL x_plus_zR x_plus_zL_lt_zR l y_le_zL x_plus_y_le_zL; cbn; apply lt_l with (inr l); apply x_plus_y_le_zL ). - abstract ( intros L' R' ? yL yR ycut x_plus_yL x_plus_yR x_plus_yL_lt_yR L'' R'' ? zL zR zcut x_plus_zL x_plus_zR x_plus_zL_lt_zR r yR_le_z x_plus_yR_le_z; cbn; apply lt_r with (inr r); apply x_plus_yR_le_z). Defined. (** We now prove a computation law for [plus_inner]. It holds definitionally, so we would like to prove it with just [:= 1] and then rewrite along it later, as we did above. However, there is a subtlety in that the output should be a surreal defined by a cut, which in particular includes a proof of cut-ness, and that proof is rather long, so we would not like to see it in the type of this lemma. Thus, instead we assert only that there *exists* some proof of cut-ness and an equality. *) Definition plus_inner_cut {L' R' : Type@{i} } {Sy : InSort S L' R'} (yL : L' -> No) (yR : R' -> No) (ycut : forall (l : L') (r : R'), yL l < yR r) : let L'' := L + L' in let R'' := R + R' in let zL := sum_ind (fun _ => No) (fun l => (xL_plus l).1 {{ yL | yR // ycut }}) (fun l => (plus_inner.1 (yL l)).1) : L'' -> No in let zR := sum_ind (fun _ => No) (fun r => (xR_plus r).1 {{ yL | yR // ycut }}) (fun r => (plus_inner.1 (yR r)).1) : R'' -> No in let Sz := sum_options L R L' R' _ _ in { zcut : forall (l:L'') (r:R''), zL l < zR r & (plus_inner.1 {{ yL | yR // ycut }}).1 = (@No_cut _ _ _ Sz zL zR zcut) }. Proof. (** Now we tell Coq that we want the equality to be definitional, and let it figure out what the proof of cut-ness has to be. *) eexists. (** Adding [rel_hnf] here speeds things up considerably, possibly because it puts the terms in a form where the evar can be instantiated without unfolding or reduction, preventing backtracking across the evar instantiation. *) rel_hnf. reflexivity. Qed. End Inner. Definition plus_outer : { f : No -> { g : No -> No & (forall x y, x <= y -> g x <= g y) * (forall x y, x < y -> g x < g y) } & (forall x y, x <= y -> forall z, (f x).1 z <= (f y).1 z) * (forall x y, x < y -> forall z, (f x).1 z < (f y).1 z) }. Proof. refine (No_rec_package {g : No -> No & (forall x y, x <= y -> g x <= g y) * (forall x y, x < y -> g x < g y) } (fun g h => forall x, g.1 x <= h.1 x) (fun g h => forall x, g.1 x < h.1 x) (fun L R Sx xL xR xcut xL_plus xR_plus xL_lt_xR_plus => let g := plus_inner xL_plus xR_plus xL_lt_xR_plus in ((fun y => (g.1 y).1) ; (g.2))) _ _ _ _). - abstract ( intros [g ?] [h ?] p q; apply path_sigma_hprop; cbn in *; apply path_arrow; intros x; apply path_No; [ apply p | apply q ] ). - abstract ( intros L R ? xL xR xcut xL_plus xR_plus xL_lt_xR_plus L' R' ? yL yR ycut yL_plus yR_plus yL_lt_yR_plus; intros xL_lt_y xL_lt_y_plus x_lt_yR x_lt_yR_plus z; lazy beta zeta in *; cbn [pr1] in *; pattern z; refine (No_ind_hprop _ _ z); intros L'' R'' ? zL zR zcut x_le_y_plus_zL x_le_y_plus_zR; destruct (plus_inner_cut xL_plus xR_plus xL_lt_xR_plus zL zR zcut) as [xzcut p]; rewrite p; destruct (plus_inner_cut yL_plus yR_plus yL_lt_yR_plus zL zR zcut) as [yzcut q];rewrite q; apply le_lr; [ intros [l|l] | intros [r|r] ]; [ (** x^L + z < y + z *) specialize (xL_lt_y_plus l {{ zL | zR // zcut }}); rewrite q in xL_lt_y_plus; exact xL_lt_y_plus | (** x + z^L < y + z *) refine (le_lt_trans (x_le_y_plus_zL l) _); refine (lt_lopt _ _ _ (inr l)) | (** x + z < y^R + z *) specialize (x_lt_yR_plus r {{ zL | zR // zcut }}); rewrite p in x_lt_yR_plus; exact x_lt_yR_plus | (** x + z < y + z^R *) refine (lt_le_trans _ (x_le_y_plus_zR r)); refine (lt_ropt _ _ _ (inr r)) ]). - abstract ( intros L R ? xL xR xcut xL_plus xR_plus xL_lt_xR_plus L' R' ? yL yR ycut yL_plus yR_plus yL_lt_yR_plus; intros l x_le_yL x_le_yL_plus z; lazy beta zeta in *; cbn [pr1] in *; pattern z; refine (No_ind_hprop _ _ z); intros L'' R'' ? zL zR zcut x_le_y_plus_zL x_le_y_plus_zR; destruct (plus_inner_cut xL_plus xR_plus xL_lt_xR_plus zL zR zcut) as [xzcut p]; rewrite p; destruct (plus_inner_cut yL_plus yR_plus yL_lt_yR_plus zL zR zcut) as [yzcut q];rewrite q; refine (le_lt_trans (x_le_yL_plus {{ zL | zR // zcut }}) _); refine (lt_lopt _ _ _ (inl l)) ). - abstract ( intros L R ? xL xR xcut xL_plus xR_plus xL_lt_xR_plus L' R' ? yL yR ycut yL_plus yR_plus yL_lt_yR_plus; intros r xR_le_y xR_le_y_plus z; lazy beta zeta in *; cbn [pr1] in *; pattern z; refine (No_ind_hprop _ _ z); intros L'' R'' ? zL zR zcut x_le_y_plus_zL x_le_y_plus_zR; destruct (plus_inner_cut xL_plus xR_plus xL_lt_xR_plus zL zR zcut) as [xzcut p]; rewrite p; destruct (plus_inner_cut yL_plus yR_plus yL_lt_yR_plus zL zR zcut) as [yzcut q];rewrite q; refine (lt_le_trans _ (xR_le_y_plus {{ zL | zR // zcut }})); refine (lt_ropt _ _ _ (inl r)) ). Defined. Definition plus (x y : No) : No := (plus_outer.1 x).1 y. Infix "+" := plus : surreal_scope. Definition plus_le_l (x x' y : No) (p : x <= x') : (x + y) <= (x' + y) := fst (plus_outer.2) x x' p y. Definition plus_lt_l (x x' y : No) (p : x < x') : (x + y) < (x' + y) := snd (plus_outer.2) x x' p y. Definition plus_le_r (x y y' : No) (p : y <= y') : (x + y) <= (x + y') := fst (plus_outer.1 x).2 y y' p. Definition plus_lt_r (x y y' : No) (p : y < y') : (x + y) < (x + y') := snd (plus_outer.1 x).2 y y' p. (** See the remarks above [plus_inner_cut] to explain the type of this lemma. *) Definition plus_cut {L R : Type@{i} } {Sx : InSort S L R} (xL : L -> No) (xR : R -> No) (xcut : forall (l : L) (r : R), xL l < xR r) {L' R' : Type@{i} } {Sy : InSort S L' R'} (yL : L' -> No) (yR : R' -> No) (ycut : forall (l : L') (r : R'), yL l < yR r) : let L'' := (L + L')%type in let R'' := (R + R')%type in let x := {{ xL | xR // xcut }} in let y := {{ yL | yR // ycut }} in let zL := sum_ind (fun _ => No) (fun l => (xL l) + y) (fun l => x + (yL l)) : L'' -> No in let zR := sum_ind (fun _ => No) (fun r => (xR r) + y) (fun r => x + (yR r)) : R'' -> No in let Sz := sum_options L R L' R' _ _ in { zcut : forall (l:L'') (r:R''), zL l < zR r & x + y = @No_cut _ _ _ Sz zL zR zcut } := plus_inner_cut (Sx := Sx) (fun l => plus_outer.1 (xL l)) (fun r => plus_outer.1 (xR r)) (fun l r => snd plus_outer.2 (xL l) (xR r) (xcut l r)) yL yR ycut. (** Because the conclusion of [plus_cut] is a sigma-type whose second component is the real equality we want to rewrite along, in order to rewrite along it we have to first destruct it. This tactic takes care of that for us. *) Ltac do_plus_cut := repeat match goal with | [ |- context ctx [ {{ ?xL | ?xR // ?xcut }} + {{ ?yL | ?yR // ?ycut }} ] ] => let xycut := fresh "cut" in let p := fresh "p" in destruct (plus_cut xL xR xcut yL yR ycut) as [xycut p]; rewrite p; clear p end. (** Conway proves the basic properties of arithmetic using "one-line proofs". We can't quite do them in one line of Ltac, but the following tactic does help a lot. Note that it is specific to addition. It requires the caller to specify the equivalences along which to identify the indexing types for the options, as well as a rewriting tactic for evaluating those equivalences on constructors. Unfortunately, it doesn't usually manage to finish the whole proof, since in general it can't guess how to use the inductive hypotheses. It's usually fairly easy to finish all the cases it leaves over, but we do generally have to refer by name to the inductive hypotheses that were automatically named by [intros] here. I haven't thought of a good solution to that. *) Local Opaque No_cut plus. (* required to make [rewrite] fail quickly *) Local Unset Keyed Unification. (* shaves another second or two off of [rewrite] *) Tactic Notation "one_line_proof" uconstr(eL) uconstr(eR) := unfold No in *; repeat_No_ind_hprop; do_plus_cut; refine (path_No_easy _ _ _ _ eL eR _ _ _ _); intros; repeat match goal with | [ H : (?A + ?B) |- _ ] => destruct H end; repeat match goal with | [ |- context[@equiv_fun ?A ?B ?e ?v] ] => (* first check that we picked up either [eL] or [eR]; we can't use [unify] because it doesn't infer holes, and we can't Ltac-match on [eL] / [eR] because apparently matching on uconstr doesn't work when there are holes in the uconstr *) first [ let unif := constr:(idpath : e = eL) in idtac | let unif := constr:(idpath : e = eR) in idtac ]; (* assume that the term reduces to a constructor; use [hnf] to get that constructor *) let ef := constr:(@equiv_fun A B e v) in let ef' := (eval hnf in ef) in progress change ef with ef' end; repeat cbn [sum_ind]; (* rewrite with induction hypotheses from [repeat_No_ind_hprop] and [do_plus_cut] *) repeat match goal with | [ |- ?x = ?x ] => reflexivity | [ |- ?a + _ = ?a + _ ] => apply ap | [ |- _ + ?a = _ + ?a ] => apply (ap (fun x => x + a)) | [ e : Empty |- _ ] => elim e | [ IH : (forall lr, _ + _ = _) |- _ ] => rewrite IH; clear IH | [ IH : (forall lr, _ + _ = _ + _) |- _ ] => first [ rewrite IH | rewrite <- IH ]; clear IH | [ IH : (forall lr (y : GenNo _), _ + _ = _ + _) |- _ ] => first [ rewrite IH | rewrite <- IH ]; clear IH | [ IH : (forall lr (y z : GenNo _), _ + _ = _ + _) |- _ ] => first [ rewrite IH | rewrite <- IH ]; clear IH end. (** At last we are ready to prove that the surreal numbers are a commutative monoid under addition. *) Theorem plus_comm (x y : No) : x + y = y + x. Proof. one_line_proof (equiv_sum_symm _ _) (equiv_sum_symm _ _). Defined. Theorem plus_assoc (x y z : No) : (x + y) + z = x + (y + z). Proof. one_line_proof (equiv_sum_assoc _ _ _) (equiv_sum_assoc _ _ _); one_line_proof 1%equiv 1%equiv. Defined. Theorem plus_zero (x : No) : x + zero = x. Proof. unfold zero. one_line_proof (sum_empty_r _) (sum_empty_r _). Defined. Theorem zero_plus (x : No) : zero + x = x. Proof. unfold zero. one_line_proof (sum_empty_l _) (sum_empty_l _). Defined. (** If we also have negation, we can prove that it gives additive inverses, so that we have an abelian group. *) Context `{HasNegation S}. Definition plus_negate (x : No) : x + negate x = zero. Proof. unfold No in *; repeat_No_ind_hprop; destruct (negate_cut xL xR xcut) as [nxcut p]; rewrite p; clear p; do_plus_cut. apply path_No. - apply le_lr; [ intros [l|r]; cbn [sum_ind] | intros [] ]. + unfold zero in IHL; rewrite <- (IHL l); clear IHL. apply plus_lt_r. refine (lt_ropt _ _ _ l). + unfold zero in IHR; rewrite <- (IHR r); clear IHR. apply plus_lt_l. refine (lt_ropt _ _ _ r). - apply le_lr; [ intros [] | intros [r|l] ]; cbn [sum_ind]. + unfold zero in IHR; rewrite <- (IHR r); clear IHR. apply plus_lt_r. refine (lt_lopt _ _ _ r). + unfold zero in IHL; rewrite <- (IHL l); clear IHL. apply plus_lt_l. refine (lt_lopt _ _ _ l). Defined. Definition sub (x y : No) : No := x + (negate y). Infix "-" := sub : surreal_scope. End Addition. Coq-HoTT-9.0/theories/Spaces/No/Core.v000066400000000000000000001422551474641544500174420ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import TruncType HSet. Require Import HoTT.Truncations.Core. Local Open Scope nat_scope. Local Open Scope path_scope. (** * The surreal numbers *) (** Based on section 11.6 of the HoTT Book. *) Declare Scope surreal_scope. Delimit Scope surreal_scope with No. Local Open Scope surreal_scope. (** ** Option sorts *) (** We refine the surreal numbers by parametrizing them by "option sorts", which are predicates on the types that index the options. A surreal number with given option sorts "hereditarily" has all options parametrized by types belonging to that sort. *) Definition OptionSort@{i} := Type@{i} -> Type@{i} -> Type@{i}. Class InSort (S : OptionSort@{i}) (I J : Type@{i}) := insort : S I J. (** The surreal numbers use a lot of universes. We include some universe annotations here and there to reduce the number of overall universe parameters from an unmanageable number to a slightly less unmanageable number. This improves performance significantly. We also use [abstract] and [Qed] whenever possible, for the same reason. *) (** ** Definition *) Module Export Surreals. Section OptionSort. (** We will use this to assert that certain inequalities below hold. We locate it here, so that it depends on no universe variables. See the longer explanation below. *) Inductive No_Empty_for_admitted : Type0 := . Axiom No_Empty_admitted : No_Empty_for_admitted. Universe i. Context {S : OptionSort@{i}}. (** *** Games first *) (** Since Coq doesn't support inductive-inductive types natively, we have to hack a bit. Inspired by Conway, we define [Game]s to be constructed by the point-constructor of [No] but without the hypothesis on inequality of options. Then we define the inequalities as a mutual inductive family over [Game], and put an inductive predicate on [Game] characterizing those that are Numbers. (This is roughly a standard technique described by Fredrik Nordvall Forsberg for reducing induction-induction to parametrized induction.) We then proceed to add axioms for the path-constructors of [No]. It should be emphasized that this is *not* currently a correct higher inductive-inductive definition of games; these "games" are only being used inside this module as a trick to produce [No] in a way that computes on the point-constructor. It should be possible to make a higher inductive-inductive definition of games, but this is not it. *) Private Inductive Game : Type := | opt : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> Game) (xR : R -> Game), Game. Arguments opt {L R s} xL xR. Private Inductive game_le : Game -> Game -> Type := | game_le_lr : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> Game) (xR : R -> Game) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> Game) (yR : R' -> Game), (forall (l:L), game_lt (xL l) (opt yL yR)) -> (forall (r:R'), game_lt (opt xL xR) (yR r)) -> game_le (opt xL xR) (opt yL yR) with game_lt : Game -> Game -> Type := | game_lt_l : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> Game) (xR : R -> Game) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> Game) (yR : R' -> Game) (l : L'), (game_le (opt xL xR) (yL l)) -> game_lt (opt xL xR) (opt yL yR) | game_lt_r : forall (L R : Type@{i}) (s : InSort@{i} S L R) (xL : L -> Game) (xR : R -> Game) (L' R' : Type@{i}) (s' : InSort@{i} S L' R') (yL : L' -> Game) (yR : R' -> Game) (r : R), (game_le (xR r) (opt yL yR)) -> game_lt (opt xL xR) (opt yL yR). Arguments game_le_lr {L R s} xL xR {L' R' s'} yL yR _ _. Arguments game_lt_l {L R s} xL xR {L' R' s'} yL yR l _. Arguments game_lt_r {L R s} xL xR {L' R' s'} yL yR r _. (** *** Now the surreals *) Private Inductive is_surreal : Game -> Type := | isno : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> Game) (xR : R -> Game), (forall l, is_surreal (xL l)) -> (forall r, is_surreal (xR r)) -> (forall (l:L) (r:R), game_lt (xL l) (xR r)) -> is_surreal (opt xL xR). Unset Nonrecursive Elimination Schemes. (** We call these "general surreal numbers" since they are parametrized by an option sort. *) Record GenNo : Type := Build_No { game_of : Game ; isno_game_of : is_surreal (game_of) }. Bind Scope surreal_scope with GenNo. Definition lt (x y : GenNo) := game_lt (game_of x) (game_of y). Definition le (x y : GenNo) := game_le (game_of x) (game_of y). Local Infix "<" := lt : surreal_scope. Local Infix "<=" := le : surreal_scope. Definition No_cut {L R : Type@{i}} {s : InSort S L R} (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) : GenNo := Build_No (opt (game_of o xL) (game_of o xR)) (isno _ _ _ _ _ (isno_game_of o xL) (isno_game_of o xR) xcut). Notation "{ { xL | xR // xcut } }" := (No_cut xL xR xcut) : surreal_scope. Axiom path_No : forall (x y : GenNo), (x <= y) -> (y <= x) -> (x = y). Arguments path_No {x y} _ _. Definition le_lr {L R : Type@{i} } {s : InSort S L R} (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) {L' R' : Type@{i} } {s' : InSort S L' R'} (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) : (forall (l:L), xL l < {{ yL | yR // ycut }}) -> (forall (r:R'), {{ xL | xR // xcut }} < yR r) -> {{ xL | xR // xcut }} <= {{ yL | yR // ycut }} := game_le_lr (game_of o xL) (game_of o xR) (game_of o yL) (game_of o yR). Definition lt_l {L R : Type@{i} } {s : InSort S L R} (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) {L' R' : Type@{i} } {s' : InSort S L' R'} (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (l : L') : ({{ xL | xR // xcut }} <= yL l) -> {{ xL | xR // xcut }} < {{ yL | yR // ycut }} := game_lt_l (game_of o xL) (game_of o xR) (game_of o yL) (game_of o yR) l. Definition lt_r {L R : Type@{i} } {s : InSort S L R} (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) {L' R' : Type@{i} } {s' : InSort S L' R'} (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (r : R) : (xR r <= {{ yL | yR // ycut }}) -> {{ xL | xR // xcut }} < {{ yL | yR // ycut }} := game_lt_r (game_of o xL) (game_of o xR) (game_of o yL) (game_of o yR) r. Global Instance ishprop_No_le {x y : GenNo} : IsHProp (x <= y). Admitted. Global Instance ishprop_No_lt {x y : GenNo} : IsHProp (x < y). Admitted. (** *** Now the induction principle. *) Section NoInd. Context (A : GenNo -> Type) (dle : forall (x y : GenNo), (x <= y) -> A x -> A y -> Type) (dlt : forall (x y : GenNo), (x < y) -> A x -> A y -> Type) {ishprop_le : forall x y a b p, IsHProp (dle x y p a b)} {ishprop_lt : forall x y a b p, IsHProp (dlt x y p a b)} (dcut : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)), A {{ xL | xR // xcut }}) (dpath : forall (x y : GenNo) (a:A x) (b:A y) (p : x <= y) (q : y <= x) (dp : dle x y p a b) (dq : dle y x q b a), path_No p q # a = b) (dle_lr : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (p : forall (l:L), xL l < {{ yL | yR // ycut }}) (dp : forall (l:L), dlt _ _ (p l) (fxL l) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (q : forall (r:R'), {{ xL | xR // xcut }} < yR r) (dq : forall (r:R'), dlt _ _ (q r) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyR r)), dle {{ xL | xR // xcut }} {{ yL | yR // ycut }} (le_lr xL xR xcut yL yR ycut p q) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_l : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (l : L') (p : {{ xL | xR // xcut }} <= yL l) (dp : dle _ _ p (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyL l)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_l xL xR xcut yL yR ycut l p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_r : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : forall l, A (xL l)) (fxR : forall r, A (xR r)) (fxcut : forall l r, dlt _ _ (xcut l r) (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> GenNo) (yR : R' -> GenNo) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : forall l, A (yL l)) (fyR : forall r, A (yR r)) (fycut : forall l r, dlt _ _ (ycut l r) (fyL l) (fyR r)) (r : R) (p : (xR r) <= {{ yL | yR // ycut }}) (dp : dle _ _ p (fxR r) (dcut _ _ _ yL yR ycut fyL fyR fycut)), dlt {{ xL | xR // xcut }} {{ yL | yR // ycut }} (lt_r xL xR xcut yL yR ycut r p) (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)). (** As usual for HITs implemented with [Private Inductive], we will define [No_ind] inside this module using a fixpoint over [No], thereby obtaining a judgmental computation rule for the point-constructor [No_cut], and then assert the other computation rules as axioms. In this case, the relevant other rules are the preservation of inequalities. However, it turns out that in defining [No_cut] we already need to know that it preserves inequalities. Since this is eventually an axiom anyway, we could just assert it with [admit] in the proof. However, if we did this then the [admit] would not be *judgmentally* equal to the axiom [No_ind_lt] that we assert afterwards. Instead, we make use of the fact that [admit] is essentially by definition [match proof_admitted with end] for a global axiom [proof_admitted : Empty], so that if we use the same [admit] both inside the definition of [No_ind] and in asserting [No_ind_lt] as an axiom, they will be the same term judgmentally. Finally, for conceptual isolation, and so as not to depend on the particular implementation of [admit], we use local copies of [Empty] and [proof_admitted]. These were defined at the start of the Section, because otherwise they depend on six universe variables. *) (** Technically, we induct over the inductive predicate witnessing Numberhood of games. We prove the "induction step" separately to improve performance, possibly by preventing bare [fix]s from appearing upon simplification. *) Local Definition No_ind_internal_step (No_ind_internal : forall (x : Game) (xno : is_surreal x), A (Build_No x xno)) (x : Game) (xno : is_surreal x) : A (Build_No x xno). Proof. (* We use [revert] and [intros] as a way to ensure that the definition depends on all of the variables in the context. *) revert ishprop_le ishprop_lt dpath dle_lr dlt_l dlt_r. destruct xno as [L R ? xL xR Lno Rno xcut]. intros ishprop_le ishprop_lt dpath dle_lr dlt_l dlt_r. simple refine (dcut L R _ (fun l => Build_No (xL l) (Lno l)) (fun r => Build_No (xR r) (Rno r)) xcut _ _ _). - intros l; exact (No_ind_internal (xL l) (Lno l)). - intros r; exact (No_ind_internal (xR r) (Rno r)). - intros; exact (match No_Empty_admitted with end). Defined. Local Fixpoint No_ind_internal (x : Game) (xno : is_surreal x) {struct xno} : A (Build_No x xno). Proof. exact (No_ind_internal_step No_ind_internal x xno). Defined. Definition No_ind (x : GenNo) : A x. Proof. destruct x as [x xno]. exact (No_ind_internal x xno). Defined. Definition No_ind_le (x y : GenNo) (p : x <= y) : dle x y p (No_ind x) (No_ind y) := match No_Empty_admitted with end. Definition No_ind_lt (x y : GenNo) (p : x < y) : dlt x y p (No_ind x) (No_ind y) := match No_Empty_admitted with end. (** Sometimes it's convenient to have all three parts of [No_ind] in one package, so that we only have to verify the hypotheses once. *) Definition No_ind_package : { f : forall x, A x & (forall (x y : GenNo) (p : x <= y), dle x y p (f x) (f y)) * (forall (x y : GenNo) (p : x < y), dlt x y p (f x) (f y)) } := ( No_ind ; (No_ind_le , No_ind_lt) ). (** It's also sometimes convenient to have just the inequality parts together. *) Definition No_ind_le_lt (x y : GenNo) : (forall (p : x <= y), dle x y p (No_ind x) (No_ind y)) * (forall (p : x < y), dlt x y p (No_ind x) (No_ind y)) := (No_ind_le x y , No_ind_lt x y). (** We verify that our definition computes judgmentally. *) Definition No_ind_cut (L R : Type@{i}) (s : InSort S L R) (xL : L -> GenNo) (xR : R -> GenNo) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) : No_ind {{ xL | xR // xcut }} = dcut L R _ xL xR xcut (fun l => No_ind (xL l)) (fun r => No_ind (xR r)) (fun l r => No_ind_lt (xL l) (xR r) (xcut l r)) := 1. End NoInd. End OptionSort. Arguments GenNo S : clear implicits. Infix "<" := lt : surreal_scope. Infix "<=" := le : surreal_scope. Notation "{ { xL | xR // xcut } }" := (No_cut xL xR xcut) : surreal_scope. End Surreals. Section OptionSort. Universe i. Context {S : OptionSort@{i}}. Let No := GenNo S. (** ** A few surreal numbers *) Definition rempty_cut {L : Type} {xL : L -> No} : forall (l:L) (r:Empty), xL l < Empty_rec r := fun l => Empty_ind _. Definition lempty_cut {R : Type} {xR : R -> No} : forall (l:Empty) (r:R), Empty_rec l < xR r := Empty_ind _. Definition zero `{InSort S Empty Empty} : No := {{ Empty_rec | Empty_rec // lempty_cut }}. Definition one `{InSort S Empty Empty} `{InSort S Unit Empty} : No := {{ unit_name zero | Empty_rec // rempty_cut }}. Definition minusone `{InSort S Empty Empty} `{InSort S Empty Unit} : No := {{ Empty_rec | unit_name zero // lempty_cut }}. (** ** More induction principles *) (** *** The simplified induction principle for hprops *) Definition No_ind_hprop (P : No -> Type) `{forall x, IsHProp (P x)} (dcut : forall (L R : Type) (s : InSort S L R) (xL : L -> No) (xR : R -> No) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (IHL : forall l, P (xL l)) (IHR : forall r, P (xR r)), P {{ xL | xR // xcut }}) (x : No) : P x. Proof. revert x; refine (No_ind P (fun _ _ _ _ _ => Unit) (fun _ _ _ _ _ => Unit) _ _ _ _ _); intros; try apply path_ishprop; try exact tt. apply dcut; assumption. Defined. (** See also [repeat_No_ind_hprop], below *) (** *** The non-dependent recursion principle *) Section NoRec. Context `{Funext}. Context (A : Type) (dle : A -> A -> Type) `{is_mere_relation A dle} (dlt : A -> A -> Type) `{is_mere_relation A dlt} (dcut : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> No) (xR : R -> No) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : L -> A) (fxR : R -> A) (fxcut : forall l r, dlt (fxL l) (fxR r)), A) (dpath : forall a b, dle a b -> dle b a -> a = b) (dle_lr : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> No) (xR : R -> No) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : L -> A) (fxR : R -> A) (fxcut : forall l r, dlt (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> No) (yR : R' -> No) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : L' -> A) (fyR : R' -> A) (fycut : forall l r, dlt (fyL l) (fyR r)) (p : forall (l:L), xL l < {{ yL | yR // ycut }}) (dp : forall (l:L), dlt (fxL l) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (q : forall (r:R'), {{ xL | xR // xcut }} < yR r) (dq : forall (r:R'), dlt (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyR r)), dle (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_l : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> No) (xR : R -> No) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : L -> A) (fxR : R -> A) (fxcut : forall l r, dlt (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> No) (yR : R' -> No) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : L' -> A) (fyR : R' -> A) (fycut : forall l r, dlt (fyL l) (fyR r)) (l : L') (p : {{ xL | xR // xcut }} <= yL l) (dp : dle (dcut _ _ _ xL xR xcut fxL fxR fxcut) (fyL l)), dlt (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)) (dlt_r : forall (L R : Type@{i}) (s : InSort S L R) (xL : L -> No) (xR : R -> No) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (fxL : L -> A) (fxR : R -> A) (fxcut : forall l r, dlt (fxL l) (fxR r)) (L' R' : Type@{i}) (s' : InSort S L' R') (yL : L' -> No) (yR : R' -> No) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (fyL : L' -> A) (fyR : R' -> A) (fycut : forall l r, dlt (fyL l) (fyR r)) (r : R) (p : (xR r) <= {{ yL | yR // ycut }}) (dp : dle (fxR r) (dcut _ _ _ yL yR ycut fyL fyR fycut)), dlt (dcut _ _ _ xL xR xcut fxL fxR fxcut) (dcut _ _ _ yL yR ycut fyL fyR fycut)). Definition No_rec (x : No) : A. Proof. revert x; simple refine (No_ind (fun _ => A) (fun _ _ _ a b => dle a b) (fun _ _ _ a b => dlt a b) _ _ _ _ _); intros. - exact (dcut L R _ xL xR xcut fxL fxR fxcut). - refine (transport_const _ _ @ _). apply dpath; assumption. - cbn. apply dle_lr; assumption. - cbn. apply dlt_l with l; assumption. - cbn. apply dlt_r with r; assumption. Defined. Definition No_rec_le (x y : No) (p : x <= y) : dle (No_rec x) (No_rec y) := No_ind_le (fun _ => A) (fun _ _ _ a b => dle a b) (fun _ _ _ a b => dlt a b) _ _ _ _ _ x y p. Definition No_rec_lt (x y : No) (p : x < y) : dlt (No_rec x) (No_rec y) := No_ind_lt (fun _ => A) (fun _ _ _ a b => dle a b) (fun _ _ _ a b => dlt a b) _ _ _ _ _ x y p. Definition No_rec_package : { f : No -> A & (forall (x y : No) (p : x <= y), dle (f x) (f y)) * (forall (x y : No) (p : x < y), dlt (f x) (f y)) } := ( No_rec ; (No_rec_le , No_rec_lt) ). Definition No_rec_cut (L R : Type@{i}) (s : InSort S L R) (xL : L -> No) (xR : R -> No) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) : No_rec {{ xL | xR // xcut }} = dcut L R _ xL xR xcut (fun l => No_rec (xL l)) (fun r => No_rec (xR r)) (fun l r => No_rec_lt (xL l) (xR r) (xcut l r)) := 1. End NoRec. (** ** Conway's Theorem 0 *) (** First we prove that *if* a left option of [y] is [<=] itself, then it is [< y]. *) Lemma Conway_theorem0_lemma1 `{Funext} (x : No) (xle : x <= x) {L' R' : Type@{i}} {s' : InSort S L' R'} (yL : L' -> No) (yR : R' -> No) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (l : L') (p : x = yL l) : x < {{ yL | yR // ycut }}. Proof. generalize dependent x; refine (No_ind_hprop _ _); intros. apply lt_l with l. exact (transport (fun z => {{ xL | xR // xcut}} <= z) p xle). Defined. (** And dually *) Lemma Conway_theorem0_lemma2 `{Funext} (x : No) (xle : x <= x) {L' R' : Type@{i}} {s' : InSort S L' R'} (yL : L' -> No) (yR : R' -> No) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) (r : R') (p : x = yR r) : {{ yL | yR // ycut }} < x. Proof. generalize dependent x; refine (No_ind_hprop _ _); intros. apply lt_r with r. exact (transport (fun z => z <= {{ xL | xR // xcut}}) p xle). Defined. (** Theorem 0 Part (i) *) Theorem le_reflexive `{Funext} (x : No) : x <= x. Proof. revert x; refine (No_ind_hprop _ _); intros. apply le_lr. - intros l. refine (Conway_theorem0_lemma1 (xL l) (IHL l) _ _ _ _ 1). - intros r. refine (Conway_theorem0_lemma2 (xR r) (IHR r) _ _ _ _ 1). Defined. Instance reflexive_le `{Funext} : Reflexive le := le_reflexive. (** Theorem 0 Part (ii), left half *) Theorem lt_lopt `{Funext} {L R : Type@{i}} {s : InSort S L R} (xL : L -> No) (xR : R -> No) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (l : L) : xL l < {{ xL | xR // xcut }}. Proof. refine (Conway_theorem0_lemma1 (xL l) _ _ _ _ _ 1). apply le_reflexive. Defined. (** Theorem 0 Part (ii), right half *) Theorem lt_ropt `{Funext} {L R : Type@{i}} {s : InSort S L R} (xL : L -> No) (xR : R -> No) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (r : R) : {{ xL | xR // xcut }} < xR r. Proof. refine (Conway_theorem0_lemma2 (xR r) _ _ _ _ _ 1). apply le_reflexive. Defined. Global Instance isset_No `{Funext} : IsHSet No. Proof. refine (@ishset_hrel_subpaths No (fun (x y:No) => (x <= y) * (y <= x)) _ _ _). - intros x; split; apply le_reflexive. - intros x y [xley ylex]; apply path_No; assumption. Defined. (** ** "One-line proofs" *) (** In particular, the proofs of cut-ness don't impact equality of surreals. However, in practice we generally need more than this: we need to be able to modify the indexing types along equivalences. *) Definition path_No_easy `{Funext} {L R : Type} {s : InSort S L R} (xL : L -> No) (xR : R -> No) {L' R' : Type} {s' : InSort S L' R'} (xL' : L' -> No) (xR' : R' -> No) (eL : L <~> L') (eR : R <~> R') (xLeq : forall l, xL l = xL' (eL l)) (xReq : forall r, xR r = xR' (eR r)) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) (xcut' : forall (l:L') (r:R'), (xL' l) < (xR' r)) : {{ xL | xR // xcut }} = {{ xL' | xR' // xcut' }}. Proof. apply path_No; apply le_lr; [ intros l; rewrite xLeq | intros r; rewrite <- (eisretr eR r), <- xReq | intros l; rewrite <- (eisretr eL l), <- xLeq | intros r; rewrite xReq ]; try apply lt_lopt; try apply lt_ropt. Qed. Definition path_No_easy' `{Funext} {L R : Type} {s : InSort S L R} (xL xL' : L -> No) (xR xR' : R -> No) (xLeq : forall l, xL l = xL' l) (xReq : forall r, xR r = xR' r) (xcut : forall (l:L) (r:R), (xL l) < (xR r)) : {{ xL | xR // xcut }} = {{ xL' | xR' // (fun l r => transport (fun xy => fst xy < snd xy) (path_prod' (xLeq l) (xReq r)) (xcut l r)) }} := path_No_easy xL xR xL' xR' 1 1 xLeq xReq xcut _. End OptionSort. (** When we want to do induction on several variables at once, we have to be careful to do them in the right order. This tactic does that, by calling itself recursively (although it doesn't choose useful names for all the hypotheses it introduces). We have to define this here outside of all sections so that it will be visible globally. *) Ltac repeat_No_ind_hprop := try match goal with | [ x : GenNo ?S |- _ ] => revert x; repeat_No_ind_hprop; refine (No_ind_hprop _ _); intros ? ? ? ? ? ? ? ? end. (** ** Encode-decode to characterize [<] and [<=] recursively (Theorem 11.6.7). *) Section NoCodes. Context `{Univalence}. Universe i. Context {S : OptionSort@{i}}. Let No := GenNo S. Let A := {le'_x : No -> HProp & {lt'_x : No -> HProp & (forall y : No, lt'_x y -> le'_x y) * (forall y z : No, le'_x y -> y <= z -> le'_x z) * (forall y z : No, le'_x y -> y < z -> lt'_x z) * (forall y z : No, lt'_x y -> y <= z -> lt'_x z)} }. Section Inner. Context {L R : Type@{i} } {s : InSort S L R} (xL : L -> No) (xR : R -> No) (xcut : forall (l : L) (r : R), xL l < xR r) (xL_let : L -> A) (xR_let : R -> A) (x_lt_le : forall (l : L) (r : R) (y : No), (xR_let r).1 y -> ((xL_let l).2).1 y). Let A' (y : No) : Type := { lelt'_x_y : HProp * HProp & (snd lelt'_x_y -> fst lelt'_x_y) * (forall l : L, fst lelt'_x_y -> ((xL_let l).2).1 y) * (forall r : R, (xR_let r).1 y -> snd lelt'_x_y) }. Let A'le (y z : No) (p : y <= z) (tr : A' y) (sq : A' z) : Type := (fst tr.1 -> fst sq.1) * (snd tr.1 -> snd sq.1). Let A'lt (y z : No) (p : y < z) (tr : A' y) (sq : A' z) : Type := (fst tr.1 -> snd sq.1). Local Definition inner_package : { inner : forall (y : No), A' y & (forall y z p, A'le y z p (inner y) (inner z)) * (forall y z p, A'lt y z p (inner y) (inner z)) }. Proof. simple refine (No_ind_package A' A'le A'lt _ _ _ _ _ ); unfold A', A'le, A'lt; try exact _. - intros L' R' ? yL yR ycut x_let_yL x_let_yR y_lt_le. set (y := {{ yL | yR // ycut }}). exists (Build_HProp ((forall l, (xL_let l).2.1 y) * (forall r', snd (x_let_yR r').1)) , (hor {l':L' & fst (x_let_yL l').1} {r:R & (xR_let r).1 y})). abstract ( refine ((_,_),_); [ intros h; strip_truncations; destruct h as [[l' h]|[r h]]; split; intros; [ refine (snd (fst (xL_let l).2.2) (yL l') y _ _); [ refine (fst (fst (fst (xL_let l).2.2)) (yL l') _); exact (snd (fst (x_let_yL l').2) l h) | by (apply lt_lopt; exact _) ] | exact (y_lt_le l' r' h) | exact (x_lt_le l r y h) | refine (snd (x_let_yR r').2 r _); refine (fst (fst (fst (xR_let r).2.2)) _ _); refine (snd (fst (xR_let r).2.2) y (yR r') h _); apply lt_ropt; exact _ ] | intros l [h k]; apply h | intros r h; apply tr, inr; exact (r;h) ] ). - abstract ( intros y z [[x_le_y x_lt_y] ?] [[x_le_z x_lt_z] ?] p q; cbn; intros [p1 p2] [q1 q2]; rewrite transport_sigma'; (* cbn; *) refine (path_sigma' _ (path_prod' (path_hprop (equiv_iff_hprop p1 q1)) (path_hprop (equiv_iff_hprop p2 q2))) _); apply path_ishprop ). - abstract ( cbn; intros L' R' ? yL yR ycut x_let_yL x_let_yR y_lt_le; set (y := {{ yL | yR // ycut }}); intros L'' R'' ? zL zR zcut x_let_zL x_let_zR z_lt_le; set (z := {{ zL | zR // zcut }}); intros yL_lt_z h1 y_lt_zR h2; assert (y_le_z := le_lr yL yR ycut zL zR zcut yL_lt_z y_lt_zR); split; [ intros [h3 h4]; split | intros h3; strip_truncations; destruct h3 as [[l' h3]|[r h3]] ] ; [ intros l; refine (snd (xL_let l).2.2 y z (h3 l) y_le_z) | intros r''; refine (h2 r'' (h3 , h4)) | refine (h1 l' h3) | apply tr, inr; exists r; refine (snd (fst (fst (xR_let r).2.2)) y z h3 y_le_z) ] ). - abstract ( cbn; intros L' R' ? yL yR ycut x_let_yL x_let_yR y_lt_le; set (y := {{ yL | yR // ycut }}); intros L'' R'' ? zL zR zcut x_let_zL x_let_zR z_lt_le; set (z := {{ zL | zR // zcut }}); intros l'' y_le_zL [h1 h2] x_le_y; apply tr, inl; exact (l''; h1 x_le_y) ). - abstract ( cbn; intros L' R' ? yL yR ycut x_let_yL x_let_yR y_lt_le; set (y := {{ yL | yR // ycut }}); intros L'' R'' ? zL zR zcut x_let_zL x_let_zR z_lt_le; set (z := {{ zL | zR // zcut }}); intros r' yR_le_z [h1 h2] x_le_y; apply h2; exact (snd x_le_y r') ). Defined. Local Definition inner (y : No) : A' y := inner_package.1 y. (** These computation laws hold definitionally, but it helps Coq out if we prove them explicitly and then rewrite along them later. *) Definition inner_cut_le (L' R' : Type@{i}) {s : InSort S L' R'} (yL : L' -> No) (yR : R' -> No) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) : fst (inner {{ yL | yR // ycut }}).1 = (Build_HProp ((forall l, (xL_let l).2.1 {{ yL | yR // ycut }}) * (forall r', snd (inner (yR r')).1))) := 1. Definition inner_cut_lt (L' R' : Type@{i}) {s : InSort S L' R'} (yL : L' -> No) (yR : R' -> No) (ycut : forall (l:L') (r:R'), (yL l) < (yR r)) : snd (inner {{ yL | yR // ycut }}).1 = (hor {l':L' & fst (inner (yL l')).1} {r:R & (xR_let r).1 {{ yL | yR // ycut }} }) := 1. Local Definition inner_le y z p : A'le y z p (inner y) (inner z) := fst (inner_package.2) y z p. Local Definition inner_lt y z p : A'lt y z p (inner y) (inner z) := snd (inner_package.2) y z p. End Inner. (** We instruct [simpl]/[cbn] not to unfold [inner]. We will do the "unfolding" ourselves by rewriting along [inner_cut_le] and [inner_cut_lt], so as to keep better control over the resulting terms (and particularly their size). *) Arguments inner : simpl never. Definition No_codes_package : { lelt : No -> A & (forall (x y : No), (x <= y) -> forall z, ((lelt y).1 z -> (lelt x).1 z) * ((lelt y).2.1 z -> (lelt x).2.1 z)) * (forall (x y : No), (x < y) -> forall z, ((lelt y).1 z -> (lelt x).2.1 z)) }. Proof. simple refine (No_rec_package A (fun dm ht => forall y, (ht.1 y -> dm.1 y) * (ht.2.1 y -> dm.2.1 y)) (fun dm ht => forall y, (ht.1 y -> dm.2.1 y)) _ _ _ _ _). - intros L R ? xL xR xcut xL_let xR_let x_lt_le. pose (x := {{ xL | xR // xcut }}). exists (fun y => fst (inner xL_let xR_let x_lt_le y).1). exists (fun y => snd (inner xL_let xR_let x_lt_le y).1). abstract ( repeat split; [ intros y; exact (fst (fst (inner xL_let xR_let x_lt_le y).2)) | intros y z x_le_y y_le_z; exact (fst (inner_le xL_let xR_let x_lt_le y z y_le_z) x_le_y) | intros y z x_le_y y_lt_z; exact (inner_lt xL_let xR_let x_lt_le y z y_lt_z x_le_y) | intros y z x_lt_y y_le_z; exact (snd (inner_le xL_let xR_let x_lt_le y z y_le_z) x_lt_y) ]). - abstract ( intros [x_le [x_lt ?]] [x_le' [x_lt' ?]] p q; cbn in p, q; simple refine (path_sigma' _ _ _); [ apply path_arrow; intros y; apply path_hprop, equiv_iff_hprop; [ exact (fst (q y)) | exact (fst (p y)) ] | rewrite transport_sigma'; cbn; simple refine (path_sigma' _ _ _); [ apply path_arrow; intros y; apply path_hprop, equiv_iff_hprop; [ exact (snd (q y)) | exact (snd (p y)) ] | apply path_ishprop ] ] ). - abstract ( intros L R ? xL xR xcut xL_let xR_let x_le_lt L' R' ? yL yR ycut yL_let yR_let y_le_lt; set (x := {{ xL | xR // xcut }}); set (y := {{ yL | yR // ycut }}); cbn; intros xL_lt_y xL_lt_z x_lt_yR le_lt_y; refine (No_ind_hprop _ _); intros L'' R'' ? zL zR zcut zLH zRH; split; [ rewrite !inner_cut_le; intros y_le_z; split; [ intros l; refine (xL_lt_z l {{ zL | zR // zcut }} y_le_z) | intros r; refine (snd (zRH r) (snd y_le_z r)) ] | rewrite !inner_cut_lt; intros y_lt_z; strip_truncations; destruct y_lt_z as [[l y_le_zL]|[r yR_le_z]]; [ apply tr; left; exact (l; fst (zLH l) y_le_zL) | refine (le_lt_y r {{ zL | zR // zcut }} yR_le_z) ]] ). - abstract ( intros L R ? xL xR xcut xL_let xR_let x_le_lt L' R' ? yL yR ycut yL_let yR_let y_le_lt; set (x := {{ xL | xR // xcut }}); set (y := {{ yL | yR // ycut }}); cbn; intros l x_le_yL zH; refine (No_ind_hprop _ _); intros L'' R'' ? zL zR zcut zLH zRH y_le_z; refine (snd (zH {{ zL | zR // zcut }}) _); rewrite inner_cut_le in y_le_z; exact (fst y_le_z l) ). - abstract ( intros L R ? xL xR xcut xL_let xR_let x_le_lt L' R' ? yL yR ycut yL_let yR_let y_le_lt; set (x := {{ xL | xR // xcut }}); set (y := {{ yL | yR // ycut }}); cbn; intros r xR_le_y zH; refine (No_ind_hprop _ _); intros L'' R'' ? zL zR zcut zLH zRH y_le_z; rewrite inner_cut_lt; apply tr; right; exists r; refine (fst (zH {{ zL | zR // zcut }}) y_le_z) ). Defined. Definition le' (x y : No) : HProp := (No_codes_package.1 x).1 y. Definition lt' (x y : No) : HProp := (No_codes_package.1 x).2.1 y. Definition lt'_le' x y : lt' x y -> le' x y := (fst (fst (fst (No_codes_package.1 x).2.2)) y). Definition le_le'_trans x y z : x <= y -> le' y z -> le' x z := fun p q => (fst (fst (No_codes_package.2) x y p z) q). Definition le_lt'_trans x y z : x <= y -> lt' y z -> lt' x z := fun p q => (snd (fst (No_codes_package.2) x y p z) q). Definition lt_le'_trans x y z : x < y -> le' y z -> lt' x z := fun p q => (snd (No_codes_package.2) x y p z q). Definition le'_le_trans x y z : le' x y -> y <= z -> le' x z := fun p q => (snd (fst (fst (No_codes_package.1 x).2.2)) y z p q). Definition le'_lt_trans x y z : le' x y -> y < z -> lt' x z := fun p q => (snd (fst (No_codes_package.1 x).2.2) y z p q). Definition lt'_le_trans x y z : lt' x y -> y <= z -> lt' x z := fun p q => (snd (No_codes_package.1 x).2.2 y z p q). (** These computation laws hold definitionally, but it takes Coq a little while to verify that. Thus, we prove them once and then [rewrite] along them later, so we don't have to do the verification every time. *) Definition le'_cut (L R : Type) (s : InSort S L R) (xL : L -> No) (xR : R -> No) (xcut : forall (l : L) (r : R), xL l < xR r) (L' R' : Type) (s' : InSort S L' R') (yL : L' -> No) (yR : R' -> No) (ycut : forall (l : L') (r : R'), yL l < yR r) : le' {{xL | xR // xcut}} {{yL | yR // ycut}} = ((forall l, lt' (xL l) {{ yL | yR // ycut }}) * (forall r', lt' {{ xL | xR // xcut }} (yR r'))) (** For some reason, Coq has a really hard time checking the version of this that asserts an equality in [HProp]. But fortunately, we only ever really need the equality of types. *) :> Type := 1. Definition lt'_cut (L R : Type) (s : InSort S L R) (xL : L -> No) (xR : R -> No) (xcut : forall (l : L) (r : R), xL l < xR r) (L' R' : Type) (s' : InSort S L' R') (yL : L' -> No) (yR : R' -> No) (ycut : forall (l : L') (r : R'), yL l < yR r) : lt' {{xL | xR // xcut}} {{yL | yR // ycut}} = (hor {l':L' & le' {{ xL | xR // xcut }} (yL l')} {r:R & le' (xR r) {{ yL | yR // ycut }} }) := 1. Definition No_encode_le_lt (x y : No) : ((x <= y) -> (le' x y)) * ((x < y) -> (lt' x y)). Proof. refine (No_ind_le_lt (fun _ => Unit) (fun x y _ _ _ => le' x y) (fun x y _ _ _ => lt' x y) _ _ _ _ _ x y). + intros; exact tt. + intros; apply path_contr. + intros L R ? xL xR xcut _ _ xcut' L' R' ? yL yR ycut _ _ ycut' xL_lt_y xL_lt_y' x_lt_yR x_lt_yR'. rewrite le'_cut. exact (xL_lt_y' , x_lt_yR'). + intros L R ? xL xR xcut _ _ xcut' L' R' ? yL yR ycut _ _ ycut' l x_le_yL x_le_yL'. rewrite lt'_cut. apply tr; left. exists l. exact x_le_yL'. + intros L R ? xL xR xcut _ _ xcut' L' R' ? yL yR ycut _ _ ycut' r xR_le_y xR_le_y'. rewrite lt'_cut. apply tr; right. exists r. exact xR_le_y'. Qed. Definition No_decode_le_lt (x y : No) : ((le' x y) -> (x <= y)) * ((lt' x y) -> (x < y)). Proof. revert x y. refine (No_ind_hprop _ _); intros L R ? xL xR xcut xHL xHR. nrefine (No_ind_hprop _ _). (* Coq can find this proof by typeclass search, but helping it out makes this faster. *) { intro x; nrapply istrunc_prod; nrapply istrunc_arrow; exact _. } intros L' R' ? yL yR ycut yHL yHR. split. - intros x_le_y. rewrite le'_cut in x_le_y. exact (le_lr xL xR xcut yL yR ycut (fun l => snd (xHL l _) (fst x_le_y l)) (fun r => snd (yHR r) (snd x_le_y r))). - intros x_lt_y. rewrite lt'_cut in x_lt_y. strip_truncations; destruct x_lt_y as [[l x_le_yL]|[r xR_le_y]]. + apply lt_l with l. exact (fst (yHL l) x_le_yL). + apply lt_r with r. exact (fst (xHR r _) xR_le_y). Qed. Definition No_encode_le x y := fst (No_encode_le_lt x y). Definition No_encode_lt x y := snd (No_encode_le_lt x y). Definition No_decode_le x y := fst (No_decode_le_lt x y). Definition No_decode_lt x y := snd (No_decode_le_lt x y). Corollary lt_le {x y : No} (p : x < y) : x <= y. Proof. apply No_decode_le. apply lt'_le'. apply No_encode_lt. assumption. Qed. (** Conway's theorem 1 *) Corollary le_le_trans {x y z : No} : (x <= y) -> (y <= z) -> (x <= z). Proof. intros p q. apply No_decode_le. refine (le_le'_trans x y z p _). apply No_encode_le. assumption. Qed. Global Instance trans_le : Transitive le := @le_le_trans. Corollary le_lt_trans {x y z : No} : (x <= y) -> (y < z) -> (x < z). Proof. intros p q. apply No_decode_lt. refine (le_lt'_trans x y z p _). apply No_encode_lt. assumption. Qed. Corollary lt_le_trans {x y z : No} : (x < y) -> (y <= z) -> (x < z). Proof. intros p q. apply No_decode_lt. refine (lt_le'_trans x y z p _). apply No_encode_le. assumption. Qed. Definition lt_lt_trans {x y z : No} : (x < y) -> (y < z) -> (x < z) := fun p q => lt_le_trans p (lt_le q). Global Instance trans_lt : Transitive lt := @lt_lt_trans. End NoCodes. (** ** Changing option sorts *) (** There is of course a "maximal" option sort, which defines "the" surreal numbers as in the book. *) Definition MaxSort : OptionSort := fun _ _ => Unit. Definition No : Type := GenNo MaxSort. (** This instance should be the one found by default, so that cuts live in [No] unless otherwise specified. Thus, all other global instances of [InSort] should be declared with higher priority. *) Global Instance insort_maxsort {L R : Type} : InSort MaxSort L R | 0 := tt. (** Furthermore, every other kind of surreal number *embeds* into the maximal ones. So the other kinds of surreal numbers are really just subsets of the usual set of surreal numbers; but I don't know of a good way to define them except as their own HIITs. *) Section RaiseSort. Context `{ua: Univalence} `{S : OptionSort}. Definition No_raise : GenNo S -> No. Proof. simple refine (No_rec No le lt _ _ _ _ _). - intros L R ? xL xR xcut fxL fxR fxcut. exact {{ fxL | fxR // fxcut }}. - apply path_No. - intros; apply le_lr; assumption. - intros; apply lt_l with l; assumption. - intros; apply lt_r with r; assumption. Defined. (** See discussion at [plus_inner_cut] in [Addition.v]. *) Definition No_raise_cut {L R : Type} {s : InSort S L R} (xL : L -> GenNo S) (xR : R -> GenNo S) (xcut : forall l r, xL l < xR r) : { rxcut : forall l r, No_raise (xL l) < No_raise (xR r) & No_raise {{ xL | xR // xcut }} = {{ (fun l => No_raise (xL l)) | (fun r => No_raise (xR r)) // rxcut }} }. Proof. eexists. (* Manual rewrite instead of letting unification handle it as it would expose the case analysis on the private type. *) unfold No_raise at 1. rewrite No_rec_cut. reflexivity. Qed. Definition No_raise_le (x y : GenNo S) : (x <= y) -> (No_raise x <= No_raise y) := No_rec_le _ _ _ _ _ _ _ _ x y. Definition No_raise_lt (x y : GenNo S) : (x < y) -> (No_raise x < No_raise y) := No_rec_lt _ _ _ _ _ _ _ _ x y. Definition No_raise_reflects_lelt (x y : GenNo S) : ((No_raise x <= No_raise y) -> (x <= y)) * ((No_raise x < No_raise y) -> (x < y)). Proof. repeat_No_ind_hprop. destruct (No_raise_cut xL xR xcut) as [rxcut p]; rewrite p. destruct (No_raise_cut xL0 xR0 xcut0) as [rxcut0 q]; rewrite q. split; intros sh. - apply No_encode_le in sh; rewrite le'_cut in sh. apply le_lr. + intros l. apply IHL, No_decode_lt. rewrite q; exact (fst sh l). + intros r. apply IHR0, No_decode_lt. rewrite p; exact (snd sh r). - apply No_encode_lt in sh; rewrite lt'_cut in sh. strip_truncations. destruct sh as [[l sh]|[r sh]]. + apply lt_l with l. apply IHL0, No_decode_le. rewrite p; exact sh. + apply lt_r with r. apply IHR, No_decode_le. rewrite q; exact sh. Qed. Definition No_raise_reflects_le (x y : GenNo S) : (No_raise x <= No_raise y) -> (x <= y) := fst (No_raise_reflects_lelt x y). Definition No_raise_reflects_lt (x y : GenNo S) : (No_raise x < No_raise y) -> (x < y) := snd (No_raise_reflects_lelt x y). Global Instance isemb_No_raise : IsEmbedding No_raise. Proof. apply isembedding_isinj_hset. intros x y e; apply path_No. - refine (No_raise_reflects_le x y _). rewrite e; apply reflexive_le. - refine (No_raise_reflects_le y x _). rewrite e; apply reflexive_le. Qed. End RaiseSort. (** ** Ordinals *) (** The type of "plump ordinals" can be identified with surreal numbers that hereditarily have no right options. *) Definition OrdSort : OptionSort := fun L R => ~R. Definition POrd := GenNo OrdSort. Global Instance insort_ordsort {L : Type} : InSort OrdSort L Empty | 100 := idmap. (** ** Decidable options *) (** A particularly interesting option sort restricts [L] and [R] to be decidable, i.e. either inhabited or empty. *) Definition DecSort : OptionSort := fun L R => Decidable L * Decidable R. Definition DecNo : Type := GenNo DecSort. Global Instance insort_decsort {L R : Type} {dl : Decidable L} {dr : Decidable R} : InSort DecSort L R | 100 := (dl , dr). (** Perhaps surprisingly, this is not a restriction at all! Any surreal number can be presented by a cut in which all the option sorts are hereditarily decidable. The basic idea is that we can always add a "sufficiently large" right option and a "sufficiently small" left option in order to make both families of options inhabited without changing the value of the cut, but the details are a bit tricky. *) Global Instance isequiv_DecNo_raise `{Univalence} : IsEquiv (@No_raise DecSort). Proof. apply isequiv_surj_emb; try exact _. apply BuildIsSurjection; intros x. apply tr. revert x; refine (No_ind_hprop _ _). intros L R s xL xR xcut IHL IHR. pose (uLR := Unit + (L + R)). assert (Decidable uLR) by exact (inl (inl tt)). pose (xLR := sum_ind _ (fun _ => zero) (sum_ind (fun _ => DecNo) (fun l => (IHL l).1) (fun r => (IHR r).1)) : uLR -> DecNo). pose (z := {{ xLR | Empty_rec // rempty_cut }}). pose (z' := {{ unit_name z | Empty_rec // rempty_cut }}). pose (y := {{ Empty_rec | xLR // lempty_cut }}). pose (y' := {{ Empty_rec | unit_name y // lempty_cut }} ). pose (L' := Unit + L). assert (Decidable L') by exact (inl (inl tt)). pose (wL := sum_ind _ (fun _ => y') (fun l => (IHL l).1) : L' -> DecNo). pose (R' := Unit + R). assert (Decidable R') by exact (inl (inl tt)). pose (wR := sum_ind _ (fun _ => z') (fun r => (IHR r).1) : R' -> DecNo). assert (wcut : forall l r, wL l < wR r). { intros [[]|l] [[]|r]; cbn. - transitivity y. { refine (lt_ropt _ _ _ tt). } transitivity z. { apply lt_l with (inl tt); cbn. apply le_lr; intros []. } { refine (lt_lopt _ _ _ tt). } - transitivity y. { refine (lt_ropt _ _ _ tt). } { refine (lt_ropt _ _ _ (inr (inr r))). } - transitivity z. { refine (lt_lopt _ _ _ (inr (inl l))). } { refine (lt_lopt _ _ _ tt). } - apply No_raise_reflects_lt. rewrite (IHL l).2, (IHR r).2. apply xcut. } exists ({{ wL | wR // wcut }}). destruct (No_raise_cut wL wR wcut) as [rwcut p]. rewrite p; clear p. apply path_No; apply le_lr. - intros [[]|l]. + apply (lt_le_trans (y := No_raise y)). * apply No_raise_lt. refine (lt_ropt _ _ _ tt). * unfold y. rewrite (No_raise_cut _ _ _).2. apply le_lr; [ intros [] | intros r ]. rewrite <- (IHR r).2. refine (lt_ropt _ _ _ (inr (inr r))). + rewrite (IHL l).2. refine (lt_lopt _ _ _ l). - intros r. rewrite <- (IHR r).2. refine (lt_ropt _ _ _ (inr r)). - intros l. rewrite <- (IHL l).2. refine (lt_lopt _ _ _ (inr l)). - intros [[]|r]. + apply (le_lt_trans (y := No_raise z)). * unfold z. rewrite (No_raise_cut _ _ _).2. apply le_lr; [ intros l | intros [] ]. rewrite <- (IHL l).2. refine (lt_lopt _ _ _ (inr (inl l))). * apply No_raise_lt. refine (lt_lopt _ _ _ tt). + rewrite (IHR r).2. refine (lt_ropt _ _ _ r). Defined. Definition equiv_DecNo_raise `{Univalence} : DecNo <~> No := Build_Equiv _ _ No_raise _. (** Note that this does not extend to other sorts. For instance, it is *not* true that any plump ordinal is equal to a cut whose types of left and right options are respectively hereditarily decidable and hereditarily empty. In particular, when making the type of left options inhabited, we have to use surreals whose type of right options is also inhabited. For instance, [{{ fun _:P => zero | Empty_rec // rempty_cut }}], for a proposition [P], is a plump ordinal, but to make its left options inhabited we have to use a negative surreal, which is not itself a plump ordinal. *) Coq-HoTT-9.0/theories/Spaces/No/Negation.v000066400000000000000000000044741474641544500203160ustar00rootroot00000000000000Require Import HoTT.Basics. Require Import HoTT.Spaces.No.Core. Local Open Scope path_scope. Local Open Scope surreal_scope. (** * Negation of surreal numbers *) (** Negation requires the option sorts to be symmetric. *) Class HasNegation (S : OptionSort) := symmetric_options : forall L R, InSort S L R -> InSort S R L. Global Existing Instance symmetric_options. Global Instance hasnegation_maxsort : HasNegation MaxSort := fun _ _ _ => tt. Global Instance hasnegation_decsort : HasNegation DecSort. Proof. intros L R [? ?]; split; assumption. Qed. Section HasNegation. Universe i. Context {S : OptionSort@{i}} `{HasNegation S}. Let No := GenNo S. Definition negate : No -> No. Proof. simple refine (No_rec No (fun x y => y <= x) (fun x y => y < x) _ _ _ _ _); intros. - exact {{ fxR | fxL // fun r l => fxcut l r }}. - apply path_No; assumption. - cbn in *. apply le_lr; intros; [ apply dq | apply dp ]. - cbn in *. apply lt_r with l; intros; assumption. - cbn in *. apply lt_l with r; intros; assumption. Defined. (** More useful is the following rewriting lemma. *) Definition negate_cut {L R : Type@{i} } {Sx : InSort S L R} (xL : L -> No) (xR : R -> No) (xcut : forall (l : L) (r : R), xL l < xR r) : { nxcut : forall r l, negate (xR r) < negate (xL l) & negate {{ xL | xR // xcut }} = {{ (fun r => negate (xR r)) | (fun l => negate (xL l)) // nxcut }} }. Proof. eexists. unfold negate at 1; rewrite No_rec_cut. reflexivity. Defined. (** The following proof verifies that [No_rec] applied to a cut reduces definitionally to a cut with the expected options (although it does produce quite a large term). *) Context `{InSort S Empty Empty} `{InSort S Unit Empty}. Goal negate one = minusone. Proof. unfold one; rewrite (negate_cut _ _ _).2. apply path_No; apply le_lr; intros. (** Since [le_lr] only proves inequality of cuts, this would not work if [negate] didn't compute to a cut when applied to a cut. *) - elim l. - apply lt_r with r. unfold zero; rewrite (negate_cut _ _ _).2. apply le_lr; apply Empty_ind. - elim l. - unfold zero; rewrite (negate_cut _ _ _).2. apply lt_r with r. apply le_lr; apply Empty_ind. Qed. End HasNegation. Coq-HoTT-9.0/theories/Spaces/Pos.v000066400000000000000000000001111474641544500167170ustar00rootroot00000000000000Require Export HoTT.Spaces.Pos.Core. Require Export HoTT.Spaces.Pos.Spec.Coq-HoTT-9.0/theories/Spaces/Pos/000077500000000000000000000000001474641544500165375ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/Pos/Core.v000066400000000000000000000261041474641544500176210ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.Decidable Spaces.Nat.Core. Local Set Universe Minimization ToSet. (** * Binary Positive Integers *) (** Most of this file has been adapted from the coq standard library for positive binary integers. *) (** Here we define the inductive type of positive binary numbers. *) Inductive Pos : Type0 := | xH : Pos | x0 : Pos -> Pos | x1 : Pos -> Pos. Declare Scope positive_scope. Delimit Scope positive_scope with pos. (** Here are some notations that let us write binary positive integers more easily. *) Notation "1" := xH : positive_scope. Notation "p ~ 1" := (x1 p) : positive_scope. Notation "p ~ 0" := (x0 p) : positive_scope. Local Open Scope positive_scope. (** ** Successor *) Fixpoint pos_succ x := match x with | p~1 => (pos_succ p)~0 | p~0 => p~1 | 1 => 1~0 end. (** Peano induction (due to Daniel Schepler) *) Fixpoint pos_peano_ind (P : Pos -> Type) (a : P 1) (f : forall p, P p -> P (pos_succ p)) (p : Pos) : P p := let f2 := pos_peano_ind (fun p => P (p~0)) (f _ a) (fun p (x : P p~0) => f _ (f _ x)) in match p with | q~1 => f _ (f2 q) | q~0 => f2 q | 1 => a end. (** Computation rules for Peano induction *) Definition pos_peano_ind_beta_1 (P : Pos -> Type) (a : P 1) (f : forall p, P p -> P (pos_succ p)) : pos_peano_ind P a f 1 = a := idpath. Definition pos_peano_ind_beta_pos_succ (P : Pos -> Type) (a : P 1) (f : forall p, P p -> P (pos_succ p)) (p : Pos) : pos_peano_ind P a f (pos_succ p) = f _ (pos_peano_ind P a f p). Proof. revert P a f. induction p; trivial. intros P a f. srapply IHp. Qed. Definition pos_peano_rec (P : Type) : P -> (Pos -> P -> P) -> Pos -> P := pos_peano_ind (fun _ => P). Definition pos_peano_rec_beta_pos_succ (P : Type) (a : P) (f : Pos -> P -> P) (p : Pos) : pos_peano_rec P a f (pos_succ p) = f p (pos_peano_rec P a f p) := pos_peano_ind_beta_pos_succ (fun _ => P) a f p. (** ** Properties of constructors *) Definition x0_inj {z w : Pos} (p : x0 z = x0 w) : z = w := transport (fun s => z = ( match s with xH => w | x0 a => a | x1 a => w end)) p idpath. Definition x1_inj {z w : Pos} (p : x1 z = x1 w) : z = w := transport (fun s => z = ( match s with xH => w | x0 a => w | x1 a => a end)) p idpath. Definition x0_neq_xH {z : Pos} : x0 z <> xH := fun p => transport (fun s => match s with xH => Empty | x0 a => z = a | x1 a => Empty end) p idpath. Definition x1_neq_xH {z : Pos} : x1 z <> xH := fun p => transport (fun s => match s with xH => Empty | x0 a => Empty | x1 a => z = a end) p idpath. Definition x0_neq_x1 {z w : Pos} : x0 z <> x1 w := fun p => transport (fun s => match s with xH => Empty | x0 a => z = a | x1 _ => Empty end) p idpath. Definition xH_neq_x0 {z : Pos} : xH <> x0 z := x0_neq_xH o symmetry _ _. Definition xH_neq_x1 {z : Pos} : xH <> x1 z := x1_neq_xH o symmetry _ _. Definition x1_neq_x0 {z w : Pos} : x1 z <> x0 w := x0_neq_x1 o symmetry _ _. (** * Positive binary integers have decidable paths *) Global Instance decpaths_pos : DecidablePaths Pos. Proof. intros n; induction n as [|zn|on]; intros m; induction m as [|zm|om]. + exact (inl idpath). + exact (inr xH_neq_x0). + exact (inr xH_neq_x1). + exact (inr x0_neq_xH). + destruct (IHzn zm) as [p|q]. - apply inl, ap, p. - apply inr; intro p. by apply q, x0_inj. + exact (inr x0_neq_x1). + exact (inr x1_neq_xH). + exact (inr x1_neq_x0). + destruct (IHon om) as [p|q]. - apply inl, ap, p. - apply inr; intro p. by apply q, x1_inj. Defined. (** Decidable paths imply Pos is a hSet *) Global Instance ishset_pos : IsHSet Pos := _. (** * Operations over positive numbers *) (** ** Addition *) Fixpoint pos_add x y := match x, y with | p~1, q~1 => (pos_add_carry p q)~0 | p~1, q~0 => (pos_add p q)~1 | p~1, 1 => (pos_succ p)~0 | p~0, q~1 => (pos_add p q)~1 | p~0, q~0 => (pos_add p q)~0 | p~0, 1 => p~1 | 1, q~1 => (pos_succ q)~0 | 1, q~0 => q~1 | 1, 1 => 1~0 end with pos_add_carry x y := match x, y with | p~1, q~1 => (pos_add_carry p q)~1 | p~1, q~0 => (pos_add_carry p q)~0 | p~1, 1 => (pos_succ p)~1 | p~0, q~1 => (pos_add_carry p q)~0 | p~0, q~0 => (pos_add p q)~1 | p~0, 1 => (pos_succ p)~0 | 1, q~1 => (pos_succ q)~1 | 1, q~0 => (pos_succ q)~0 | 1, 1 => 1~1 end. Infix "+" := pos_add : positive_scope. (** ** Operation [x -> 2*x-1] *) Fixpoint pos_pred_double x := match x with | p~1 => p~0~1 | p~0 => (pos_pred_double p)~1 | 1 => 1 end. (** ** Predecessor *) Definition pos_pred x := match x with | p~1 => p~0 | p~0 => pos_pred_double p | 1 => 1 end. (** ** An auxiliary type for subtraction *) Inductive Pos_mask : Set := | IsNul : Pos_mask | IsPos : Pos -> Pos_mask | IsNeg : Pos_mask. (** ** Operation [x -> 2*x+1] *) Definition pos_mask_succ_double (x : Pos_mask) : Pos_mask := match x with | IsNul => IsPos 1 | IsNeg => IsNeg | IsPos p => IsPos p~1 end. (** ** Operation [x -> 2*x] *) Definition pos_mask_double (x : Pos_mask) : Pos_mask := match x with | IsNul => IsNul | IsNeg => IsNeg | IsPos p => IsPos p~0 end. (** ** Operation [x -> 2*x-2] *) Definition pos_mask_double_pred x : Pos_mask := match x with | p~1 => IsPos p~0~0 | p~0 => IsPos (pos_pred_double p)~0 | 1 => IsNul end. (** ** Predecessor with mask *) Definition pos_mask_pred (p : Pos_mask) : Pos_mask := match p with | IsPos 1 => IsNul | IsPos q => IsPos (pos_pred q) | IsNul => IsNeg | IsNeg => IsNeg end. (** ** Subtraction, result as a mask *) Fixpoint pos_mask_sub (x y : Pos) {struct y} : Pos_mask := match x, y with | p~1, q~1 => pos_mask_double (pos_mask_sub p q) | p~1, q~0 => pos_mask_succ_double (pos_mask_sub p q) | p~1, 1 => IsPos p~0 | p~0, q~1 => pos_mask_succ_double (pos_mask_sub_carry p q) | p~0, q~0 => pos_mask_double (pos_mask_sub p q) | p~0, 1 => IsPos (pos_pred_double p) | 1, 1 => IsNul | 1, _ => IsNeg end with pos_mask_sub_carry (x y : Pos) {struct y} : Pos_mask := match x, y with | p~1, q~1 => pos_mask_succ_double (pos_mask_sub_carry p q) | p~1, q~0 => pos_mask_double (pos_mask_sub p q) | p~1, 1 => IsPos (pos_pred_double p) | p~0, q~1 => pos_mask_double (pos_mask_sub_carry p q) | p~0, q~0 => pos_mask_succ_double (pos_mask_sub_carry p q) | p~0, 1 => pos_mask_double_pred p | 1, _ => IsNeg end. (** ** Subtraction, result as a positive, returning 1 if [x<=y] *) Definition pos_sub x y := match pos_mask_sub x y with | IsPos z => z | _ => 1 end. Infix "-" := pos_sub : positive_scope. (** ** Multiplication *) Fixpoint pos_mul x y := match x with | p~1 => y + (pos_mul p y)~0 | p~0 => (pos_mul p y)~0 | 1 => y end. Infix "*" := pos_mul : positive_scope. (** ** Iteration over a positive number *) Definition pos_iter {A : Type} (f : A -> A) : Pos -> A -> A. Proof. apply (pos_peano_rec (A -> A) f). intros n g. exact (f o g). Defined. (** ** Iteration of a two-variable function, with nesting reflecting the bits *) Definition pos_iter_op {A} (op : A -> A -> A) := fix p_iter (p : Pos) (a : A) : A := match p with | 1 => a | p~0 => p_iter p (op a a) | p~1 => op a (p_iter p (op a a)) end. (** ** Power *) Definition pos_pow (x : Pos) := pos_iter (pos_mul x) 1. (** ** Square *) Fixpoint pos_square p := match p with | p~1 => (pos_square p + p)~0~1 | p~0 => (pos_square p)~0~0 | 1 => 1 end. (** ** Division by 2 rounded below but for 1 *) Definition pos_div2 p := match p with | 1 => 1 | p~0 => p | p~1 => p end. (** Division by 2 rounded up *) Definition pos_div2_up p := match p with | 1 => 1 | p~0 => p | p~1 => pos_succ p end. (** ** Number of digits in a positive number *) Fixpoint nat_pos_size p : nat := match p with | 1 => S O | p~1 => S (nat_pos_size p) | p~0 => S (nat_pos_size p) end. (** Same, with positive output *) Fixpoint pos_size p := match p with | 1 => 1 | p~1 => pos_succ (pos_size p) | p~0 => pos_succ (pos_size p) end. (** ** From binary positive numbers to Peano natural numbers *) (** Sends [n] to [n], missing [0]. *) Definition nat_of_pos (p : Pos) : nat := pos_iter S p 0%nat. (** ** From Peano natural numbers to binary positive numbers *) (** A version preserving positive numbers, and sending 0 to 1. *) Fixpoint pos_of_nat (n : nat) : Pos := match n with | O => 1 | S O => 1 | S x => pos_succ (pos_of_nat x) end. (* Another version that converts [n] into [n+1] *) Fixpoint pos_of_succ_nat (n : nat) : Pos := match n with | O => 1 | S x => pos_succ (pos_of_succ_nat x) end. (** ** Conversion with a decimal representation for printing/parsing *) Local Notation ten := 1~0~1~0. Fixpoint pos_of_uint_acc (d : Decimal.uint) (acc : Pos) := match d with | Decimal.Nil => acc | Decimal.D0 l => pos_of_uint_acc l (pos_mul ten acc) | Decimal.D1 l => pos_of_uint_acc l (pos_add 1 (pos_mul ten acc)) | Decimal.D2 l => pos_of_uint_acc l (pos_add 1~0 (pos_mul ten acc)) | Decimal.D3 l => pos_of_uint_acc l (pos_add 1~1 (pos_mul ten acc)) | Decimal.D4 l => pos_of_uint_acc l (pos_add 1~0~0 (pos_mul ten acc)) | Decimal.D5 l => pos_of_uint_acc l (pos_add 1~0~1 (pos_mul ten acc)) | Decimal.D6 l => pos_of_uint_acc l (pos_add 1~1~0 (pos_mul ten acc)) | Decimal.D7 l => pos_of_uint_acc l (pos_add 1~1~1 (pos_mul ten acc)) | Decimal.D8 l => pos_of_uint_acc l (pos_add 1~0~0~0 (pos_mul ten acc)) | Decimal.D9 l => pos_of_uint_acc l (pos_add 1~0~0~1 (pos_mul ten acc)) end. Fixpoint pos_of_uint (d : Decimal.uint) : option Pos := match d with | Decimal.Nil => None | Decimal.D0 l => pos_of_uint l | Decimal.D1 l => Some (pos_of_uint_acc l 1) | Decimal.D2 l => Some (pos_of_uint_acc l 1~0) | Decimal.D3 l => Some (pos_of_uint_acc l 1~1) | Decimal.D4 l => Some (pos_of_uint_acc l 1~0~0) | Decimal.D5 l => Some (pos_of_uint_acc l 1~0~1) | Decimal.D6 l => Some (pos_of_uint_acc l 1~1~0) | Decimal.D7 l => Some (pos_of_uint_acc l 1~1~1) | Decimal.D8 l => Some (pos_of_uint_acc l 1~0~0~0) | Decimal.D9 l => Some (pos_of_uint_acc l 1~0~0~1) end. Definition pos_of_decimal_int (d:Decimal.int) : option Pos := match d with | Decimal.Pos d => pos_of_uint d | Decimal.Neg _ => None end. Definition pos_of_number_uint (d:Numeral.int) : option Pos := match d with | Numeral.IntDec d => pos_of_decimal_int d | Numeral.IntHex _ => None end. Fixpoint pos_to_little_uint p := match p with | 1 => Decimal.D1 Decimal.Nil | p~1 => Decimal.Little.succ_double (pos_to_little_uint p) | p~0 => Decimal.Little.double (pos_to_little_uint p) end. Definition pos_to_uint p := Decimal.rev (pos_to_little_uint p). Definition pos_to_decimal_int n := Decimal.Pos (pos_to_uint n). Definition pos_to_number_uint p := Numeral.UIntDec (pos_to_uint p). Definition pos_to_nat : Pos -> nat. Proof. intro p. induction p. + exact (S O). + exact (nat_add IHp IHp). + exact (S (nat_add IHp IHp)). Defined. Number Notation Pos pos_of_number_uint pos_to_number_uint : positive_scope. Coq-HoTT-9.0/theories/Spaces/Pos/Spec.v000066400000000000000000000141131474641544500176200ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import Pos.Core. Local Set Universe Minimization ToSet. Local Open Scope positive_scope. (** ** Specification of [succ] in term of [add] *) Lemma pos_add_1_r p : p + 1 = pos_succ p. Proof. by destruct p. Qed. Lemma pos_add_1_l p : 1 + p = pos_succ p. Proof. by destruct p. Qed. (** ** Specification of [add_carry] *) Theorem pos_add_carry_spec p q : pos_add_carry p q = pos_succ (p + q). Proof. revert q. induction p; destruct q; simpl; by apply ap. Qed. (** ** Commutativity of [add] *) Theorem pos_add_comm p q : p + q = q + p. Proof. revert q. induction p; destruct q; simpl; apply ap; trivial. rewrite 2 pos_add_carry_spec; by apply ap. Qed. (** ** Permutation of [add] and [succ] *) Theorem pos_add_succ_r p q : p + pos_succ q = pos_succ (p + q). Proof. revert q. induction p; destruct q; simpl; apply ap; auto using pos_add_1_r; rewrite pos_add_carry_spec; auto. Qed. Theorem pos_add_succ_l p q : pos_succ p + q = pos_succ (p + q). Proof. rewrite pos_add_comm, (pos_add_comm p). apply pos_add_succ_r. Qed. Definition pos_add_succ p q : p + pos_succ q = pos_succ p + q. Proof. by rewrite pos_add_succ_r, pos_add_succ_l. Defined. Definition pos_add_carry_spec_l q r : pos_add_carry q r = pos_succ q + r. Proof. by rewrite pos_add_carry_spec, pos_add_succ_l. Qed. Definition pos_add_carry_spec_r q r : pos_add_carry q r = q + pos_succ r. Proof. by rewrite pos_add_carry_spec, pos_add_succ_r. Defined. (** ** No neutral elements for addition *) Lemma pos_add_no_neutral p q : q + p <> p. Proof. revert q. induction p as [ |p IHp|p IHp]; intros [ |q|q]. 1,3: apply x0_neq_xH. 1: apply x1_neq_xH. 1,3: apply x1_neq_x0. 2,4: apply x0_neq_x1. 1,2: intro H; apply (IHp q). 1: apply x0_inj, H. apply x1_inj, H. Qed. (** * Injectivity of pos_succ *) Lemma pos_succ_inj n m : pos_succ n = pos_succ m -> n = m. Proof. revert m. induction n as [ | n x | n x]; induction m as [ | m y | m y]. + reflexivity. + intro p. destruct (x0_neq_x1 p). + intro p. simpl in p. apply x0_inj in p. destruct m. 1,3: destruct (xH_neq_x0 p). destruct (xH_neq_x1 p). + intro p. destruct (x1_neq_x0 p). + simpl. intro p. by apply ap, x1_inj. + intro p. destruct (x1_neq_x0 p). + intro p. cbn in p. apply x0_inj in p. destruct n. 1,3: destruct (x0_neq_xH p). destruct (x1_neq_xH p). + intro p. cbn in p. destruct (x0_neq_x1 p). + intro p. apply ap, x, x0_inj, p. Defined. (** ** Addition is associative *) Theorem pos_add_assoc p q r : p + (q + r) = p + q + r. Proof. revert q r. induction p. + intros [|q|q] [|r|r]. all: try reflexivity. all: simpl. 1,2: by destruct r. 1,2: apply ap; symmetry. 1: apply pos_add_carry_spec. 1: apply pos_add_succ_l. apply ap. rewrite pos_add_succ_l. apply pos_add_carry_spec. + intros [|q|q] [|r|r]. all: try reflexivity. all: cbn; apply ap. 3,4,6: apply IHp. 1: apply pos_add_1_r. 1: symmetry; apply pos_add_carry_spec_r. 1: apply pos_add_succ_r. rewrite 2 pos_add_carry_spec_l. rewrite <- pos_add_succ_r. apply IHp. + intros [|q|q] [|r|r]. all: cbn; apply ap. 1: apply pos_add_1_r. 1: apply pos_add_carry_spec_l. 1: apply pos_add_succ. 1: apply pos_add_carry_spec. 1: apply IHp. 2: symmetry; apply pos_add_carry_spec_r. 1,2: rewrite 2 pos_add_carry_spec, ?pos_add_succ_l. 1,2: apply ap, IHp. rewrite ?pos_add_carry_spec_r. rewrite pos_add_succ. apply IHp. Qed. (** ** One is neutral for multiplication *) Lemma pos_mul_1_l p : 1 * p = p. Proof. reflexivity. Qed. Lemma pos_mul_1_r p : p * 1 = p. Proof. induction p; cbn; trivial; by apply ap. Qed. (** pos_succ and doubling functions *) Lemma pos_pred_double_succ n : pos_pred_double (pos_succ n) = n~1. Proof. induction n as [|n|n nH]. all: trivial. cbn; apply ap, nH. Qed. Lemma pos_succ_pred_double n : pos_succ (pos_pred_double n) = n~0. Proof. induction n as [|n nH|n]. all: trivial. cbn; apply ap, nH. Qed. (** ** Iteration and pos_succ *) Lemma pos_iter_succ_l {A} (f : A -> A) p a : pos_iter f (pos_succ p) a = f (pos_iter f p a). Proof. unfold pos_iter. by rewrite pos_peano_rec_beta_pos_succ. Qed. Lemma pos_iter_succ_r {A} (f : A -> A) p a : pos_iter f (pos_succ p) a = pos_iter f p (f a). Proof. revert p f a. srapply pos_peano_ind. 1: hnf; intros; trivial. hnf; intros p q f a. refine (_ @ _ @ _^). 1,3: unfold pos_iter; by rewrite pos_peano_rec_beta_pos_succ. apply ap. apply q. Qed. (** ** Right reduction properties for multiplication *) Lemma mul_xO_r p q : p * q~0 = (p * q)~0. Proof. induction p; simpl; f_ap; f_ap; trivial. Qed. Lemma mul_xI_r p q : p * q~1 = p + (p * q)~0. Proof. induction p; simpl; trivial; f_ap. rewrite IHp. rewrite pos_add_assoc. rewrite (pos_add_comm q p). symmetry. apply pos_add_assoc. Qed. (** ** Commutativity of multiplication *) Lemma pos_mul_comm p q : p * q = q * p. Proof. induction q; simpl. 1: apply pos_mul_1_r. + rewrite mul_xO_r. f_ap. + rewrite mul_xI_r. f_ap; f_ap. Qed. (** ** Distributivity of addition over multiplication *) Theorem pos_mul_add_distr_l p q r : p * (q + r) = p * q + p * r. Proof. induction p; cbn; [reflexivity | f_ap | ]. rewrite IHp. set (m:=(p*q)~0). set (n:=(p*r)~0). change ((p*q+p*r)~0) with (m+n). rewrite 2 pos_add_assoc; f_ap. rewrite <- 2 pos_add_assoc; f_ap. apply pos_add_comm. Qed. Theorem pos_mul_add_distr_r p q r : (p + q) * r = p * r + q * r. Proof. rewrite 3 (pos_mul_comm _ r); apply pos_mul_add_distr_l. Qed. (** ** Associativity of multiplication *) Theorem pos_mul_assoc p q r : p * (q * r) = p * q * r. Proof. induction p; simpl; rewrite ?IHp; trivial. by rewrite pos_mul_add_distr_r. Qed. (** ** pos_succ and pos_mul *) Lemma pos_mul_succ_l p q : (pos_succ p) * q = p * q + q. Proof. by rewrite <- pos_add_1_r, pos_mul_add_distr_r, pos_mul_1_l. Qed. Lemma pos_mul_succ_r p q : p * (pos_succ q) = p + p * q. Proof. by rewrite <- pos_add_1_l, pos_mul_add_distr_l, pos_mul_1_r. Qed. Coq-HoTT-9.0/theories/Spaces/Spheres.v000066400000000000000000000270671474641544500176120ustar00rootroot00000000000000Require Import Basics Types. Require Import WildCat.Equiv. Require Import Homotopy.NullHomotopy. Require Import Homotopy.Suspension. Require Import Pointed. Require Import Truncations. Require Import Spaces.Circle Spaces.TwoSphere. (** * The spheres, in all dimensions. *) Local Open Scope pointed_scope. Local Open Scope trunc_scope. Local Open Scope path_scope. Generalizable Variables X A B f g n. (** ** Definition, by iterated suspension. *) (** To match the usual indexing for spheres, we have to pad the sequence with a dummy term [Sphere -2]. *) Fixpoint Sphere (n : trunc_index) := match n return Type with | -2 => Empty | -1 => Empty | n'.+1 => Susp (Sphere n') end. (** ** Pointed sphere for non-negative dimensions. *) Definition psphere (n : nat) : pType := [Sphere n, _]. Arguments Sphere : simpl never. Arguments psphere : simpl never. (** ** Explicit equivalences in low dimensions *) (** *** [Sphere 0] *) Definition S0_to_Bool : (Sphere 0) -> Bool. Proof. simpl. apply (Susp_rec true false). intros []. Defined. Definition Bool_to_S0 : Bool -> (Sphere 0). Proof. exact (fun b => if b then North else South). Defined. Global Instance isequiv_S0_to_Bool : IsEquiv (S0_to_Bool) | 0. Proof. apply isequiv_adjointify with Bool_to_S0. - intros [ | ]; exact 1. - refine (Susp_ind _ 1 1 _). intros []. Defined. Definition equiv_S0_Bool : Sphere 0 <~> Bool := Build_Equiv _ _ _ isequiv_S0_to_Bool. Definition ispointed_bool : IsPointed Bool := true. Definition pBool := [Bool, true]. Definition pequiv_S0_Bool : psphere 0 <~>* pBool := @Build_pEquiv' (psphere 0) pBool equiv_S0_Bool 1. (** In [pmap_from_psphere_iterated_loops] below, we'll use this universal property of [pBool]. *) Definition pmap_from_bool `{Funext} (X : pType) : (pBool ->** X) <~>* X. Proof. snrapply Build_pEquiv'. - refine (_ oE (issig_pmap _ _)^-1%equiv). refine (_ oE (equiv_functor_sigma_pb (equiv_bool_rec_uncurried X))^-1%equiv); cbn. make_equiv_contr_basedpaths. - reflexivity. Defined. (** *** [Sphere 1] *) Definition S1_to_Circle : (Sphere 1) -> Circle. Proof. apply (Susp_rec Circle.base Circle.base). exact (fun x => if (S0_to_Bool x) then loop else 1). Defined. Definition Circle_to_S1 : Circle -> (Sphere 1). Proof. apply (Circle_rec _ North). exact (merid North @ (merid South)^). Defined. Global Instance isequiv_S1_to_Circle : IsEquiv (S1_to_Circle) | 0. Proof. apply isequiv_adjointify with Circle_to_S1. - refine (Circle_ind _ 1 _). nrapply transport_paths_FFlr'; apply equiv_p1_1q. refine (ap _ (Circle_rec_beta_loop _ _ _) @ _). refine (ap_pp _ _ (merid South)^ @ _). refine ((1 @@ ap_V _ _) @ _). refine ((_ @@ (ap inverse _)) @ _). 1, 2: nrapply Susp_rec_beta_merid. simpl. apply concat_p1. - refine (Susp_ind (fun x => Circle_to_S1 (S1_to_Circle x) = x) 1 (merid South) _); intros x. nrapply transport_paths_FFlr'; symmetry. unfold S1_to_Circle; rewrite (Susp_rec_beta_merid x). revert x. change (Susp Empty) with (Sphere 0). apply (equiv_ind (S0_to_Bool ^-1)); intros x. case x; simpl. 2: reflexivity. lhs nrapply concat_1p. unfold Circle_to_S1; rewrite Circle_rec_beta_loop. symmetry; apply concat_pV_p. Defined. Definition equiv_S1_Circle : Sphere 1 <~> Circle := Build_Equiv _ _ _ isequiv_S1_to_Circle. Definition pequiv_S1_Circle : psphere 1 <~>* [Circle, _]. Proof. srapply Build_pEquiv'. 1: apply equiv_S1_Circle. reflexivity. Defined. (** *** [Sphere 2] *) Definition S2_to_TwoSphere : (Sphere 2) -> TwoSphere. Proof. apply (Susp_rec base base). apply (Susp_rec (idpath base) (idpath base)). apply (Susp_rec surf (idpath (idpath base))). apply Empty_rec. Defined. Definition TwoSphere_to_S2 : TwoSphere -> (Sphere 2). Proof. apply (TwoSphere_rec (Sphere 2) North). refine (transport (fun x => x = x) (concat_pV (merid North)) _). refine (((ap (fun u => merid u @ (merid North)^) (merid North @ (merid South)^)))). Defined. Definition issect_TwoSphere_to_S2 : S2_to_TwoSphere o TwoSphere_to_S2 == idmap. Proof. refine (TwoSphere_ind _ 1 _). rhs_V rapply concat_p1. rhs refine (@concat_Ap (base = base) _ _ (fun p => (p^ @ ap S2_to_TwoSphere (ap TwoSphere_to_S2 p))^) (fun x => (transport_paths_FFlr x 1) @ ap (fun u => u @ x) (concat_p1 _) @ ap (fun w => _ @ w) (inv_V x)^ @ (inv_pp _ _)^) 1 1 surf). rhs rapply concat_1p. rhs refine (ap_compose (fun p => p^ @ ap S2_to_TwoSphere (ap TwoSphere_to_S2 p)) inverse surf). refine (@ap _ _ (ap inverse) 1 _ _). rhs_V rapply concat2_ap_ap. rhs refine (ap (fun w => inverse2 surf @@ w) (ap_compose (ap TwoSphere_to_S2) (ap S2_to_TwoSphere) surf)). lhs_V refine (concat_Vp_inverse2 _ _ surf). lhs rapply concat_p1. refine (ap (fun p : 1 = 1 => inverse2 surf @@ p) _). symmetry. lhs refine ((ap (ap (ap S2_to_TwoSphere)) (TwoSphere_rec_beta_surf (Sphere 2) North _))). lhs refine (ap_transport (concat_pV (merid North)) (fun z => @ap _ _ _ z z) (ap (fun u => merid u @ (merid North)^) (merid North @ (merid South)^))). lhs_V refine (ap (transport (fun z => ap S2_to_TwoSphere z = ap S2_to_TwoSphere z) (concat_pV (merid North))) (ap_compose (fun u => merid u @ (merid North)^) (ap S2_to_TwoSphere) (merid North @ (merid South)^))). apply transport_paths_FlFr'; symmetry. lhs_V refine (1 @@ ap_pp_concat_pV S2_to_TwoSphere (merid North)). lhs_V refine (1 @@ (1 @@ (1 @@ (concat_pV_inverse2 (ap S2_to_TwoSphere (merid North)) _ (Susp_rec_beta_merid North))))). lhs refine (@concat_Ap (Sphere 1) _ (fun x => ap S2_to_TwoSphere (merid x @ (merid North)^)) (fun x => Susp_rec 1 1 (Susp_rec surf 1 Empty_rec) x @ 1) (fun x => ap_pp S2_to_TwoSphere (merid x) (merid North)^ @ ((1 @@ ap_V S2_to_TwoSphere (merid North)) @ ((Susp_rec_beta_merid x @@ inverse2 (Susp_rec_beta_merid North)) @ 1))) North North (merid North @ (merid South)^)). f_ap. { rhs_V refine (ap_pp_concat_pV _ _). exact (1 @@ (1 @@ (concat_pV_inverse2 _ _ _))). } lhs_V refine (concat2_ap_ap (Susp_rec 1 1 (Susp_rec surf 1 Empty_rec)) (fun _ => 1) (merid North @ (merid South)^)). lhs refine (ap (fun w => _ @@ w) (ap_const _ _)). lhs rapply whiskerR_p1_1. lhs refine (ap_pp _ (merid North) (merid South)^). rhs_V rapply concat_p1. f_ap. - exact (Susp_rec_beta_merid North). - lhs rapply ap_V. refine (@inverse2 _ _ _ _ 1 _). exact (Susp_rec_beta_merid South). Defined. Definition issect_S2_to_TwoSphere : TwoSphere_to_S2 o S2_to_TwoSphere == idmap. Proof. intro x. refine ((Susp_rec_eta_homotopic (TwoSphere_to_S2 o S2_to_TwoSphere) x) @ _). symmetry. generalize dependent x. refine (Susp_ind _ 1 (merid North)^ _). intro x. refine ((transport_paths_FlFr (f := fun y => y) _ _) @ _). rewrite_moveR_Vp_p. refine ((concat_1p _) @ _). refine (_ @ (ap (fun w => w @ _) (ap_idmap _)^)). refine ((Susp_rec_beta_merid _) @ _). path_via (ap TwoSphere_to_S2 (ap S2_to_TwoSphere (merid x))). { apply (ap_compose S2_to_TwoSphere TwoSphere_to_S2 (merid x)). } path_via (ap TwoSphere_to_S2 (Susp_rec 1 1 (Susp_rec surf 1 Empty_rec) x)). { repeat f_ap. apply Susp_rec_beta_merid. } symmetry. generalize dependent x. simple refine (Susp_ind _ (concat_pV (merid North)) _ _). - refine (_ @ (concat_pV (merid North))). apply (ap (fun w => merid w @ (merid North)^) (merid South)^). - intro x. refine ((transport_paths_FlFr (merid x) (concat_pV (merid North))) @ _). rewrite_moveR_Vp_p. symmetry. refine ((dpath_path_lr _ _ _)^-1 _). refine ((ap (transport _ _) (ap_pp _ (merid x) (merid South)^)^) @ _). refine (_ @ (ap_compose (Susp_rec 1 1 (Susp_rec surf 1 Empty_rec)) (ap TwoSphere_to_S2) (merid x))^). refine (_ @ (ap (ap02 TwoSphere_to_S2) (Susp_rec_beta_merid _)^)). symmetry. generalize dependent x. simple refine (Susp_ind _ _ _ _). + refine (TwoSphere_rec_beta_surf _ _ _). + refine (_ @ (ap (fun w => transport _ _ (ap _ w)) (concat_pV (merid South))^)). refine (_ @ (transport_paths_lr _ _)^). refine (_ @ (ap (fun w => w @ _) (concat_p1 _)^)). refine (concat_Vp _)^. + apply Empty_ind. Defined. Global Instance isequiv_S2_to_TwoSphere : IsEquiv (S2_to_TwoSphere) | 0. Proof. apply isequiv_adjointify with TwoSphere_to_S2. - apply issect_TwoSphere_to_S2. - apply issect_S2_to_TwoSphere. Defined. Definition equiv_S2_TwoSphere : Sphere 2 <~> TwoSphere := Build_Equiv _ _ _ isequiv_S2_to_TwoSphere. (** ** Truncation and connectedness of spheres. *) (** S0 is 0-truncated. *) Global Instance istrunc_s0 : IsHSet (Sphere 0). Proof. srapply (istrunc_isequiv_istrunc _ S0_to_Bool^-1). Defined. (** S1 is 1-truncated. *) Global Instance istrunc_s1 `{Univalence} : IsTrunc 1 (Sphere 1). Proof. srapply (istrunc_isequiv_istrunc _ S1_to_Circle^-1). Defined. Global Instance isconnected_sn n : IsConnected n.+1 (Sphere n.+2). Proof. induction n. { srapply contr_inhabited_hprop. apply tr, North. } apply isconnected_susp. Defined. (** ** Truncatedness via spheres *) (** We show here that a type is n-truncated if and only if every map from the (n+1)-sphere into it is null-homotopic. (One direction of this is of course the assertion that the (n+1)-sphere is n-connected.) *) (** TODO: re-type these lemmas in terms of truncation. *) Fixpoint allnullhomot_trunc {n : trunc_index} {X : Type} `{IsTrunc n X} (f : Sphere n.+1 -> X) {struct n} : NullHomotopy f. Proof. destruct n as [ | n']. - exists (center X). intros []. - apply nullhomot_susp_from_paths. rapply allnullhomot_trunc. Defined. Fixpoint istrunc_allnullhomot {n : trunc_index} {X : Type} (HX : forall (f : Sphere n.+2 -> X), NullHomotopy f) {struct n} : IsTrunc n.+1 X. Proof. destruct n as [ | n']. - (* n = -2 *) apply hprop_allpath. intros x0 x1. set (f := (fun b => if (S0_to_Bool b) then x0 else x1)). set (n := HX f). exact (n.2 North @ (n.2 South)^). - (* n ≥ -1 *) apply istrunc_S; intros x0 x1. apply (istrunc_allnullhomot n'). intro f. apply nullhomot_paths_from_susp, HX. Defined. (** Iterated loop spaces can be described using pointed maps from spheres. The [n = 0] case of this is stated using Bool in [pmap_from_bool] above, and the [n = 1] case of this is stated using [Circle] in [pmap_from_circle_loops] in Circle.v. *) Definition pmap_from_psphere_iterated_loops `{Funext} (n : nat) (X : pType) : (psphere n ->** X) <~>* iterated_loops n X. Proof. induction n as [|n IHn]; simpl. - exact (pmap_from_bool X o*E pequiv_pequiv_precompose pequiv_S0_Bool^-1* ). - refine (emap loops IHn o*E _). refine (_ o*E loop_susp_adjoint (psphere n) _). symmetry; apply equiv_loops_ppforall. Defined. Coq-HoTT-9.0/theories/Spaces/Torus/000077500000000000000000000000001474641544500171125ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spaces/Torus/Torus.v000066400000000000000000000106371474641544500204240ustar00rootroot00000000000000Require Import Basics.Overture Basics.Equivalences Cubical.DPath Cubical.PathSquare Cubical.DPathSquare Cubical.PathCube Cubical.DPathCube. (** In this file we define the Torus as a HIT generated by two loops and a square between them. *) Notation hr := (sq_refl_h _). Notation vr := (sq_refl_v _). Module Export Torus. Private Inductive Torus := | tbase. Axiom loop_a : tbase = tbase. Axiom loop_b : tbase = tbase. Axiom surf : PathSquare loop_a loop_a loop_b loop_b. (** We define the induction principle for Torus *) Definition Torus_ind (P : Torus -> Type) (pb : P tbase) (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb) (ps : DPathSquare P surf pla pla plb plb) (x : Torus) : P x := (match x with tbase => fun _ _ _ => pb end) pla plb ps. (** We declare propositional computational rules for loop_a and loop_b *) Axiom Torus_ind_beta_loop_a : forall (P : Torus -> Type) (pb : P tbase) (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb) (ps : DPathSquare P surf pla pla plb plb), DPathSquare P hr (apD (Torus_ind P pb pla plb ps) (loop_a)) pla 1%dpath 1%dpath. Axiom Torus_ind_beta_loop_b : forall (P : Torus -> Type) (pb : P tbase) (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb) (ps : DPathSquare P surf pla pla plb plb), DPathSquare P hr (apD (Torus_ind P pb pla plb ps) (loop_b)) plb 1%dpath 1%dpath. (** We write out the computation rule for surf even though we will not use it. Instead we currently have an unfinished recursion computation principle, but we don't currently know how to derive it from this *) Axiom Torus_ind_beta_surf : forall (P : Torus -> Type) (pb : P tbase) (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb) (ps : DPathSquare P surf pla pla plb plb), DPathCube P (cu_refl_lr _) (ds_apD (Torus_ind P pb pla plb ps) surf) ps (Torus_ind_beta_loop_a _ _ _ _ _) (Torus_ind_beta_loop_a _ _ _ _ _) (Torus_ind_beta_loop_b _ _ _ _ _) (Torus_ind_beta_loop_b _ _ _ _ _). End Torus. (** We can now define Torus recursion as a special case of Torus induction *) Definition Torus_rec (P : Type) (pb : P) (pla plb : pb = pb) (ps : PathSquare pla pla plb plb) : Torus -> P := Torus_ind _ pb (dp_const pla) (dp_const plb) (ds_const ps). (** We can derive the recursion computation rules for Torus_rec *) Lemma Torus_rec_beta_loop_a (P : Type) (pb : P) (pla plb : pb = pb) (ps : PathSquare pla pla plb plb) : PathSquare (ap (Torus_rec P pb pla plb ps) loop_a) pla 1 1. Proof. refine (sq_GGcc _ (eissect _ _) (ds_const'^-1 (Torus_ind_beta_loop_a _ _ _ _ _))). apply moveR_equiv_V, dp_apD_const. Defined. Lemma Torus_rec_beta_loop_b (P : Type) (pb : P) (pla plb : pb = pb) (ps : PathSquare pla pla plb plb) : PathSquare (ap (Torus_rec P pb pla plb ps) loop_b) plb 1 1. Proof. refine (sq_GGcc _ (eissect _ _) (ds_const'^-1 (Torus_ind_beta_loop_b _ _ _ _ _))). apply moveR_equiv_V, dp_apD_const. Defined. (** We ought to be able to prove this from Torus_ind_beta_surf but it is currently too difficult. Therefore we will leave it as admitted where it will simply look like an axiom. *) Definition Torus_rec_beta_surf (P : Type) (pb : P) (pla plb : pb = pb) (ps : PathSquare pla pla plb plb) : PathCube (sq_ap (Torus_rec P pb pla plb ps) surf) ps (Torus_rec_beta_loop_a P pb pla plb ps) (Torus_rec_beta_loop_a P pb pla plb ps) (Torus_rec_beta_loop_b P pb pla plb ps) (Torus_rec_beta_loop_b P pb pla plb ps). Proof. Admitted. (** The torus is pointed. *) Global Instance ispointed_torus : IsPointed Torus := tbase. (** The loops commute. *) Definition loops_commute_torus : loop_a @ loop_b = loop_b @ loop_a := equiv_sq_path^-1 surf. (* TODO: (* We ought to be able to prove the computation rules all at the same time *) (* This gives me the idea of writing all our computation rules as a "dependent filler" *) Definition Torus_rec_beta_cube (P : Type) (pb : P) (pla plb : pb = pb) (ps : PathSquare pla pla plb plb) : { ba : PathSquare (ap (Torus_rec P pb pla plb ps) loop_a) pla 1 1 & { bb : PathSquare (ap (Torus_rec P pb pla plb ps) loop_b) plb 1 1 & PathCube (sq_ap (Torus_rec P pb pla plb ps) surf) ps ba ba bb bb}}. Proof. refine (_;_;_). set (cu_cGcccc (eissect ds_const' _) (dc_const'^-1 (Torus_ind_beta_surf (fun _ => P) pb (dp_const pla) (dp_const plb) (ds_const' (sq_GGGG (eissect _ _)^ (eissect _ _)^ (eissect _ _)^ (eissect _ _)^ ps))))). Admitted. *) Coq-HoTT-9.0/theories/Spaces/Torus/TorusEquivCircles.v000066400000000000000000000167421474641544500227460ustar00rootroot00000000000000Require Import Basics Types. Require Import Cubical.DPath Cubical.PathSquare Cubical.DPathSquare Cubical.PathCube Cubical.DPathCube. Require Import Spaces.Circle Spaces.Torus.Torus. (** In this file we prove that the torus is equivalent to the product of two circles. *) (** Here is a cube filler for help with circle recursion into the torus *) Definition c2t_square_and_cube : {s : PathSquare loop_a loop_a (ap (Circle_rec _ tbase loop_b) loop) (ap (Circle_rec _ tbase loop_b) loop) & PathCube s surf hr hr (sq_G1 (Circle_rec_beta_loop _ _ _)) (sq_G1 (Circle_rec_beta_loop _ _ _))}. Proof. apply cu_fill_left. Defined. (** We define the map from the Torus to the Circles *) Definition t2c : Torus -> Circle * Circle. Proof. snrapply Torus_rec. + exact (base, base). (* The point of the torus is taken to (base, base *) + exact (path_prod' loop 1). (* loop_a is taken to loop in the first *) + exact (path_prod' 1 loop). (* loop_b is taken to loop in the second *) + exact (sq_prod (hr, vr)). (* The square is the obvious product of squares *) Defined. (** We now define the curried function from the circles to the torus. *) (** TODO: It's easy to remove [Funext] from this definition by using [intro] and [revert] appropriately, but then the cube algebra in the proof of [c2t'_beta] would need to be updated. See https://github.com/HoTT/Coq-HoTT/pull/1824. *) Definition c2t' `{Funext} : Circle -> Circle -> Torus. Proof. snrapply Circle_rec. + snrapply Circle_rec. (* Double circle recursion *) - exact tbase. (* The basepoint is sent to the point of the torus *) - exact loop_b. (* The second loop is sent to loop_b *) + apply path_forall. (* We use function extensionality here to induct *) snrapply Circle_ind. (* Circle induction as a DPath *) - exact loop_a. (* The first loop is sent to loop_a *) - srapply sq_dp^-1. (* This DPath is actually a square *) apply (pr1 c2t_square_and_cube). (* We apply the cap we found above *) Defined. (** Here is the uncurried version *) Definition c2t `{Funext} : Circle * Circle -> Torus. Proof. apply uncurry, c2t'. Defined. (** Computation rules for c2t' as a cube filler *) Definition c2t'_beta `{Funext} : {bl1 : PathSquare (ap (fun y => c2t' base y) loop) loop_b 1 1 & {bl2 : PathSquare (ap (fun x => c2t' x base) loop) loop_a 1 1 & PathCube (sq_ap011 c2t' loop loop) surf bl2 bl2 bl1 bl1}}. Proof. nrefine (_;_;_). unfold sq_ap011. (* 1. Unfusing ap *) nrefine (cu_concat_lr (cu_ds (dp_apD_nat (fun y => ap_compose _ (fun f => f y) _) _)) _ (sji0:=?[X1]) (sji1:=?X1) (sj0i:=?[Y1]) (sj1i:=?Y1) (pj11:=1)). (* 2. Reducing c2t' on loop *) nrefine (cu_concat_lr (cu_ds (dp_apD_nat (fun x => ap_apply_l _ _ @ apD10 (ap _(Circle_rec_beta_loop _ _ _)) x) _)) _ (sji0:=?[X2]) (sji1:=?X2) (sj0i:=?[Y2]) (sj1i:=?Y2) (pj11:=1)). (* 3. Reducing ap10 on function extensionality *) nrefine (cu_concat_lr (cu_ds (dp_apD_nat (ap10_path_forall _ _ _) _)) _ (sji0:=?[X3]) (sji1:=?X3) (sj0i:=?[Y3]) (sj1i:=?Y3) (pj11:=1)). (* 4. Reducing Circle_ind on loop *) nrefine (cu_concat_lr (cu_G11 (ap _ (Circle_ind_beta_loop _ _ _))) _ (sji0:=?[X4]) (sji1:=?X4) (sj0i:=?[Y4]) (sj1i:=?Y4) (pj11:=1)). (* 5. collapsing equivalence *) nrefine (cu_concat_lr (cu_G11 (eisretr _ _)) _ (sji0:=?[X5]) (sji1:=?X5) (sj0i:=?[Y5]) (sj1i:=?Y5) (pj11:=1)). (* 6. filling the cube *) apply c2t_square_and_cube.2. Defined. Local Open Scope path_scope. Local Open Scope cube_scope. (** We now prove that t2c is a section of c2t *) Definition t2c2t `{Funext} : c2t o t2c == idmap. Proof. (* We start with Torus induction *) nrefine (Torus_ind _ 1 _ _ _). (* Our DPathSquare is really just a cube *) apply cu_ds^-1. (* We pretend that our sides have sq_dpath o sq_dpath^-1 and get rid of them *) refine (cu_GGGGcc (eisretr _ _)^ (eisretr _ _)^ (eisretr _ _)^ (eisretr _ _)^ _). (* Apply a symmetry to get the faces on the right side *) apply cu_rot_tb_fb. (* Clean up other faces *) refine (cu_ccGGGG (eisretr _ _)^ (eisretr _ _)^ (eisretr _ _)^ (eisretr _ _)^ _). (* Now we finish the proof with the following composition of cubes *) nrefine ((sq_ap_compose t2c c2t surf) @lr (cu_ap c2t (Torus_rec_beta_surf _ _ _ _ _ )) @lr (sq_ap_uncurry _ _ _) @lr (pr2 (pr2 c2t'_beta)) @lr (cu_flip_lr (sq_ap_idmap _))). Defined. (* NOTE: The last step in the previous proof can be done as a sequence of refines however coq really struggles to unify this. Below is the original way we proved the last statement before making it short and sweet. As can be seen, we need to give refine hints using existential variables which is tedious to write out, and perhaps motivates why we wrote it as one big concatenation. Ideally the way below should be as smooth as the way above, since above is difficult to write directly without having tried below. (* Now we decompose the cube with middle sq_ap_compose *) (* Note: coq sucks at unifying this so we have to explicitly give paths *) refine (cu_concat_lr (sq_ap_compose t2c c2t surf) _ (sji0:=?[X1]) (sji1:=?X1) (sj0i:=?[Y1]) (sj1i:=?Y1) (pj11:=1)). (* Now we reduce (sq_ap t2c surf) *) refine (cu_concat_lr (cu_ap c2t (Torus_rec_beta_surf _ _ _ _ _ )) _ (sji0:=?[X2]) (sji1:=?X2) (sj0i:=?[Y2]) (sj1i:=?Y2) (pj11:=1)). (* We now uncurry c2t inside sq_ap *) refine (cu_concat_lr (sq_ap_uncurry _ _ _) _ (sji0:=?[X3]) (sji1:=?X3) (sj0i:=?[Y3]) (sj1i:=?Y3) (pj11:=1)). (* Reduce sq_ap2 c2t' loop loop *) refine (cu_concat_lr (pr2 (pr2 c2t'_beta)) _ (sji0:=?[X4]) (sji1:=?X4) (sj0i:=?[Y4]) (sj1i:=?Y4) (pj11:=1)). (* Finally flip and sq_ap idmap *) refine (cu_flip_lr (sq_ap_idmap _)). *) Local Notation apcs := (ap_compose_sq _ _ _). Definition sq_ap011_compose {A B C D : Type} (f : A -> B -> C) (g : C -> D) {a a' : A} (p : a = a') {b b' : B} (q : b = b') : PathCube (sq_ap011 (fun x y => g (f x y)) p q) (sq_ap g (sq_ap011 f p q)) apcs apcs apcs apcs. Proof. by destruct p, q. Defined. (** We now prove t2c is a retraction of c2t *) Definition c2t2c `{Funext} : t2c o c2t == idmap. Proof. nrapply prod_ind. (* Start with double circle induction *) snrefine (Circle_ind _ (Circle_ind _ 1 _) _). (* Change the second loop case into a square and shelve *) 1: apply sq_dp^-1, sq_tr^-1; shelve. (* Take the forall out of the DPath *) apply dp_forall_domain. intro x; apply sq_dp^-1; revert x. snrefine (Circle_ind _ _ _). 1: apply sq_tr^-1; shelve. apply dp_cu. nrefine (cu_ccGGcc _ _ _). 1,2: nrefine (ap sq_dp (Circle_ind_beta_loop _ _ _) @ eisretr _ _)^. apply cu_rot_tb_fb. nrefine (cu_ccGGGG _ _ _ _ _). 1,2,3,4: exact (eisretr _ _)^. nrefine ((sq_ap011_compose c2t' t2c loop loop) @lr (cu_ap t2c (c2t'_beta.2.2)) @lr (Torus_rec_beta_surf _ _ _ _ _) @lr (cu_flip_lr (sq_ap_idmap _)) @lr (sq_ap_uncurry _ _ _)). Defined. (* refine (cu_concat_lr (sq_ap2_compose c2t' t2c loop loop) _ (sji0:=?[X1]) (sji1:=?X1) (sj0i:=?[Y1]) (sj1i:=?Y1) (pj11:=1)). refine (cu_concat_lr (cu_ap t2c (c2t'_beta.2.2)) _ (sji0:=?[X2]) (sji1:=?X2) (sj0i:=?[Y2]) (sj1i:=?Y2) (pj11:=1)). refine (cu_concat_lr (Torus_rec_beta_surf _ _ _ _ _) _ (sji0:=?[X3]) (sji1:=?X3) (sj0i:=?[Y3]) (sj1i:=?Y3) (pj11:=1)). refine (cu_concat_lr (cu_flip_lr (sq_ap_idmap _)) _ (sji0:=?[X4]) (sji1:=?X4) (sj0i:=?[Y4]) (sj1i:=?Y4) (pj11:=1)). apply sq_ap_uncurry. *) Definition equiv_torus_prod_Circle `{Funext} : Torus <~> Circle * Circle := equiv_adjointify t2c c2t c2t2c t2c2t. Coq-HoTT-9.0/theories/Spaces/Torus/TorusHomotopy.v000066400000000000000000000035251474641544500221610ustar00rootroot00000000000000Require Import Basics Types. Require Import Pointed WildCat. Require Import Modalities.ReflectiveSubuniverse Truncations.Core. Require Import Algebra.AbGroups. Require Import Homotopy.HomotopyGroup. Require Import Homotopy.PinSn. Require Import Spaces.Int Spaces.Circle. Require Import Spaces.Torus.Torus. Require Import Spaces.Torus.TorusEquivCircles. Local Open Scope trunc_scope. Local Open Scope pointed_scope. (** ** Fundamental group of the torus .*) (** The torus is 1-truncated *) Global Instance is1type_torus `{Univalence} : IsTrunc 1 Torus. Proof. refine (istrunc_equiv_istrunc _ equiv_torus_prod_Circle^-1). Qed. (** The torus is 0-connected *) Global Instance isconnected_torus `{Univalence} : IsConnected 0 Torus. Proof. srapply (isconnected_equiv' _ _ equiv_torus_prod_Circle^-1). srapply (isconnected_equiv' _ _ (equiv_sigma_prod0 _ _)). Qed. (** We give these notations for the pointed versions. *) Local Notation T := ([Torus, _]). Local Notation S1 := ([Circle, _]). (** A pointed version of the equivalence from TorusEquivCircles.v. *) (** TODO: If [Funext] is removed from there, remove it from here as well. *) Lemma pequiv_torus_prod_circles `{Funext} : T <~>* S1 * S1. Proof. srapply Build_pEquiv'. 1: apply equiv_torus_prod_Circle. reflexivity. Defined. (** Fundamental group of torus *) Theorem pi1_torus `{Univalence} : GroupIsomorphism (Pi 1 T) (grp_prod abgroup_Z abgroup_Z). Proof. etransitivity. 1: exact (emap (Pi 1) pequiv_torus_prod_circles). etransitivity. 1: apply grp_iso_pi_prod. apply grp_iso_prod. 1,2: apply pi1_circle. Defined. (** Loop space of torus *) Theorem loops_torus `{Univalence} : loops T <~>* Int * Int. Proof. (* Since [T] is 1-truncated, [loops T] is 0-truncated, and is therefore equivalent to its 0-truncation. *) refine (_ o*E pequiv_ptr (n:=0)). nrapply pi1_torus. Defined. Coq-HoTT-9.0/theories/Spaces/TwoSphere.v000066400000000000000000000050531474641544500201100ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids. Local Open Scope path_scope. (** * Theorems about the 2-sphere [S^2]. *) (* ** Definition of the 2-sphere. *) Module Export TwoSphere. Private Inductive TwoSphere : Type0 := | base : TwoSphere. Axiom surf : idpath base = idpath base. Definition TwoSphere_ind (P : TwoSphere -> Type) (b : P base) (s : idpath b = transport2 P surf b) : forall (x : TwoSphere), P x := fun x => match x with base => fun _ => b end s. Axiom TwoSphere_ind_beta_surf : forall (P : TwoSphere -> Type) (b : P base) (s : idpath b = transport2 P surf b), apD02 (TwoSphere_ind P b s) surf = s @ (concat_p1 _)^. End TwoSphere. (* ** The non-dependent eliminator *) Definition TwoSphere_rec (P : Type) (b : P) (s : idpath b = idpath b) : TwoSphere -> P := TwoSphere_ind (fun _ => P) b (s @ (transport2_const surf b) @ (concat_p1 _)). Definition TwoSphere_rec_beta_surf (P : Type) (b : P) (s : idpath b = idpath b) : ap02 (TwoSphere_rec P b s) surf = s. Proof. apply (cancel2L (transport2_const surf b)). apply (cancelL (apD_const (TwoSphere_rec P b s) (idpath base))). apply (cancelR _ _ (concat_p_pp _ (transport_const _ b) _)^). apply (cancelR _ _ (whiskerL (transport2 _ surf b) (apD_const _ _)^)). refine ((apD02_const (TwoSphere_rec P b s) surf)^ @ _). refine ((TwoSphere_ind_beta_surf _ _ _) @ _). refine (_ @ (ap (fun w => _ @ w) (triangulator (transport2 (fun _ : TwoSphere => P) surf b) _))). cbn. refine (_ @ (ap (fun w => (w @ _) @ _) (concat_1p _)^)). refine (_ @ (concat_p_pp _ _ _)). refine (_ @ (ap (fun w => _ @ w) (concat_pp_p _ _ _))). refine (_ @ (ap (fun w => _ @ (w @ _)) (concat_Vp _)^)). refine (_ @ (ap (fun w => _ @ (w @ _)) (concat_pV (concat_p1 (transport2 (fun _ : TwoSphere => P) surf b @ 1))))). refine (_ @ (ap (fun w => _ @ w) (concat_p_pp _ _ _))). refine (_ @ (concat_pp_p _ _ _)). apply moveR_pV. refine (_ @ (concat_p_pp _ _ _)). refine (_ @ (ap (fun w => _ @ w) (whiskerR_p1 _)^)). f_ap. refine ((ap (fun w => w @ _) (whiskerL_1p_1 _)^) @ _). refine ((ap (fun w => _ @ w) (whiskerR_p1 _)^) @ _). cbn. refine ((concat_p_pp _ _ _) @ _). f_ap. refine ((ap (fun w => _ @ w) (concat_1p _)) @ _). refine ((concat_whisker 1 _ _ 1 (transport2_const surf b) s)^ @ _). symmetry. refine ((ap (fun w => w @@ _) (concat_p1 _)^) @ _). refine ((ap (fun w => _ @@ w) (concat_1p _)^) @ _). refine ((concat_concat2 _ _ _ _)^ @ _). f_ap. Defined. Coq-HoTT-9.0/theories/Spectra/000077500000000000000000000000001474641544500161615ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Spectra/Spectrum.v000066400000000000000000000021721474641544500201540ustar00rootroot00000000000000(** * Spectra *) Require Import HoTT.Basics HoTT.Types. Require Import Pointed. Local Open Scope nat_scope. Local Open Scope path_scope. Local Open Scope equiv_scope. Local Open Scope pointed_scope. (** ** Basic Definitions of Spectra *) Record Prespectrum := { deloop :> nat -> pType ; glue : forall n, deloop n ->* loops (deloop (n .+1)) }. Class IsSpectrum (E : Prespectrum) := is_equiv_glue : forall n, IsEquiv (glue E n). Global Existing Instance is_equiv_glue. Definition equiv_glue (E : Prespectrum) `{IsSpectrum E} : forall n, E n <~>* loops (E n.+1) := fun n => Build_pEquiv _ _ (glue E n) _. Record Spectrum := { to_prespectrum :> Prespectrum ; to_is_spectrum : IsSpectrum to_prespectrum }. Global Existing Instance to_is_spectrum. (** ** Truncations of spectra *) Definition strunc `{Univalence} (k : trunc_index) (E : Spectrum) : Spectrum. Proof. simple refine (Build_Spectrum (Build_Prespectrum (fun n => pTr (trunc_index_inc k n) (E n)) _) _). - intros n. exact ((ptr_loops _ (E n.+1)) o*E (pequiv_ptr_functor _ (equiv_glue E n))). - intros n. unfold glue. srapply isequiv_compose. Defined. Coq-HoTT-9.0/theories/Tactics.v000066400000000000000000000530601474641544500163450ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Contractible Basics.Equivalences. Require Import Types.Prod Types.Forall. Require Export Tactics.BinderApply. (** * Extra tactics for homotopy type theory. *) (** ** Tactics for dealing with [Funext] *) (** *** Tactics about [transport]ing with [path_forall] *) (** Given using the variable names from [transport : forall {A : Type} (P : A -> Type) {x y : A}, x = y -> P x -> P y] and [path_forall : {Funext} -> forall {A B} (f g : forall x : A, B x), (forall x : A, f x = g x) -> f = g]: The high-level idea is that we don't really need functional extensionality if we end up just applying the functions to arguments anyway. That is, if we have that [forall x, f x = g x], and we only talk about [f y] and [f z], then we don't actually need to transport across [f = g], just [f y = g y] and [f z = g z]. In a bit more detail, if we are transporting across [path_forall f g H], and in the function [P], all instances of [f] are applied to some expressions, say we only see [f x], [f y], ..., [f z], then we can eliminate the [path_forall] by explicitly transporting across [H x], [H y], ..., [H z]. The lemma [path_forall_1_beta] expresses this fact in the case that we see [f] applied to only a single argument in [P], and the tactic [transport_path_forall_hammer] is some fancy Ltac to auto-infer what [P] is and what the argument to [f] is. The way the tactic does this is by creating an evar for [P] and an evar for the argument to [f], and then using a combination of [assert], [pattern], etc to figure out what each should be. If you want to see how it works, you can step through each step of [transport_path_forall_hammer] when trying to prove [path_forall_2_beta]. *) (** First, we prove some helpful lemmas about [path_forall] and [transport] *) Local Ltac path_forall_beta_t := lazymatch goal with | [ |- context[@path_forall ?H ?A ?B ?f ?g ?e] ] => let X := fresh in pose proof (eissect (@path_forall H A B f g) e) as X; case X; generalize (@path_forall H A B f g e); clear X; clear e; intro X; destruct X; cbn; unfold apD10; rewrite !(path_forall_1 f) end; reflexivity. (** The basic idea is expressed in the type of this lemma. *) Lemma path_forall_1_beta `{Funext} A B x P f g e Px : @transport (forall a : A, B a) (fun f => P (f x)) f g (@path_forall _ _ _ _ _ e) Px = @transport (B x) P (f x) (g x) (e x) Px. Proof. path_forall_beta_t. Defined. (** The powerful recursive case *) Lemma path_forall_recr_beta' `{Funext} A B x0 P f g e Px : @transport (forall a : A, B a) (fun f => P f (f x0)) f g (@path_forall _ _ _ _ _ e) Px = @transport ((forall a, B a) * B x0) (fun x => P (fst x) (snd x)) (f, f x0) (g, g x0) (path_prod' (@path_forall _ _ _ _ _ e) (e x0)) Px. Proof. path_forall_beta_t. Defined. (** Rewrite the recursive case after clean-up *) Lemma path_forall_recr_beta `{Funext} A B x0 P f g e Px : @transport (forall a : A, B a) (fun f => P f (f x0)) f g (@path_forall _ _ _ _ _ e) Px = @transport (forall x : A, B x) (fun x => P x (g x0)) f g (@path_forall H A B f g e) (@transport (B x0) (fun y => P f y) (f x0) (g x0) (e x0) Px). Proof. etransitivity. - apply path_forall_recr_beta'. - refine (transport_path_prod' _ _ _ _). Defined. (** The sledge-hammer for computing with [transport]ing across a [path_forall]. Note that it uses [rewrite], and so should only be used in opaque proofs. *) (** This helper tactic takes a [term] and a function [f], finds [f x] in [term] and patterns that, returning a pair [(x, term')] such that [term' (f x) ≡ term]. *) Ltac pull_app term f := let term' := (eval cbv beta in term) in match term' with | context[f ?x] => match eval pattern (f x) in term' with | ?term' (f x) => constr:((x, term')) end end. Ltac infer_path_forall_recr_beta term := let path_forall_recr_beta' := match term with | @transport _ (fun x => @?P0 x) _ _ (@path_forall ?H ?A ?B ?f ?g ?e) _ => constr:(fun x0 P Px => @path_forall_recr_beta H A B x0 P f g e Px) end in let Px := match term with @transport _ _ _ _ _ ?Px => constr:(Px) end in let P0 := match term with @transport _ (fun f => @?P0 f) _ _ _ _ => constr:(P0) end in (** pattern some [f x0] in [P0] *) (** Hopefully, no goal will have a variable called [WORKAROUND_FOR_BUG_3458] in the context. At least not until bug #3458 is fixed. *) let P0f := constr:(fun WORKAROUND_FOR_BUG_3458 => ltac:( let ret := pull_app (P0 WORKAROUND_FOR_BUG_3458) WORKAROUND_FOR_BUG_3458 in exact ret)) in let x0 := match P0f with fun f => (?x0, @?P f) => constr:(x0) end in let P := match P0f with fun f => (?x0, @?P f) => constr:(P) end in let ret := constr:(path_forall_recr_beta' x0 P Px) in let retT := type of ret in let ret' := (eval cbv beta in ret) in let retT' := (eval cbv beta in retT) in constr:(ret' : retT'). Ltac transport_path_forall_hammer_helper := let term := match goal with | |- context[@transport ?At (fun x => @?Bt x) ?ft ?gt (@path_forall ?H ?A ?B ?f ?g ?e) ?Px] => constr:(@transport At Bt ft gt (@path_forall H A B f g e) Px) end in let lem := infer_path_forall_recr_beta term in pattern term; refine (transport _ lem^ _); cbv beta. Ltac transport_path_forall_hammer := transport_path_forall_hammer_helper; rewrite ?transport_const; repeat ( transport_path_forall_hammer_helper; rewrite ?transport_const ). (** An example showing that it works *) Lemma path_forall_2_beta' `{Funext} A B x0 x1 P f g e Px : @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px = @transport (B x0 * B x1) (fun x => P (fst x) (snd x)) (f x0, f x1) (g x0, g x1) (path_prod' (e x0) (e x1)) Px. Proof. transport_path_forall_hammer. repeat match goal with | [ |- context[e ?x] ] => induction (e x) end; cbn. reflexivity. Qed. Lemma path_forall_2_beta `{Funext} A B x0 x1 P f g e Px : @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px = transport (fun y : B x1 => P (g x0) y) (e x1) (transport (fun y : B x0 => P y (f x1)) (e x0) Px). Proof. transport_path_forall_hammer. reflexivity. Qed. (** ** A more powerful variant of [path_induction] *) (** We first define some helper tactics, and then define [path_induction_hammer], which has poor computational behavior, but is vastly more powerful than [path_induction], and removes paths which are discoverably contractible, and paths which only appear in the goal, etc. *) (** A variant of [induction] which also tries [destruct] and [case], and may be extended to using other [destruct]-like tactics. *) Ltac induction_hammer H := destruct H || induction H || (case H; clear H). (** Takes a term of type [_ = _], and tries to replace it by [idpath] by trying to prove that it's an hProp. The ordering of attempts is tuned for speed. *) Ltac clear_contr_path p := let H := fresh in let T := type of p in progress ( first [ assert (H : idpath = p) by exact (center _) | assert (H : idpath = p) by ( let a := match goal with |- @paths (?x = ?y) ?a ?b => constr:(a) end in let b := match goal with |- @paths (?x = ?y) ?a ?b => constr:(b) end in let x := match goal with |- @paths (?x = ?y) ?a ?b => constr:(x) end in let y := match goal with |- @paths (?x = ?y) ?a ?b => constr:(y) end in apply (@equiv_inv _ _ _ (@equiv_ap _ _ _ (@isequiv_apD10 _ _ _ x y) a b)); exact (center _) ) | pose proof (@path_contr T _ idpath p) as H ]; destruct H; (* now reduce any matches on [idpath] (and on other things too) *) cbv iota in * ). (** Use both [induction_hammer] and [clear_contr_path] on a path, to try to get rid of it *) Ltac clear_path_no_check p := induction_hammer p || clear_contr_path p. Ltac clear_path p := let t := type of p in lazymatch eval hnf in t with | @paths _ _ _ => clear_path_no_check p || fail 1 "cannot clear path" p | _ => fail 0 "clear_path only works on paths;" p "is not a path" end. (** Run [clear_path] on hypotheses *) (** We don't match only on things of type [_ = _], because maybe that's the head normal form, but it's hiding behind something else; [clear_path] will make sure it's of the right type. We include some redundant cases at the top, for speed; it is faster to try to destruct everything first, and then do the full battery of tactics, than to just run the hammer. *) Ltac step_clear_paths := idtac; match goal with | [ p : _ = _ |- _ ] => destruct p | [ p : _ = _ |- _ ] => clear_path_no_check p | [ p : _ |- _ ] => clear_path p end. Ltac clear_paths := progress repeat step_clear_paths. (** Run [clear_path] on anything inside a [match] *) Ltac step_clear_paths_in_match := idtac; match goal with | [ |- context[match ?p with idpath => _ end] ] => progress destruct p | [ |- context[match ?p with idpath => _ end] ] => clear_path_no_check p end. Ltac clear_paths_in_match := progress repeat step_clear_paths_in_match. (** Now some lemmas about trivial [match]es *) Definition match_eta {T} {x y : T} (H0 : x = y) : (H0 = match H0 in (_ = y) return (x = y) with | idpath => idpath end) := match H0 with idpath => idpath end. Definition match_eta1 {T} {x : T} (E : x = x) : (match E in (_ = y) return (x = y) with | idpath => idpath end = idpath) -> idpath = E := fun H => ((H # match_eta E) ^)%path. Definition match_eta2 {T} {x : T} (E : x = x) : (idpath = match E in (_ = y) return (x = y) with | idpath => idpath end) -> idpath = E := fun H => match_eta1 E (H ^)%path. (** And now the actual tactic. Note that the order of the cases in the [match goal with ... end] is somewhat finely tuned for speed. *) Ltac step_path_induction_hammer := idtac; match goal with | _ => reflexivity | _ => intro | _ => progress cbn in * | _ => exact (contr _) | [ p : _ = _ |- _ ] => progress destruct p (* placed up here for speed *) | [ H : _ |- _ ] => let H' := fresh in assert (H' := match_eta1 _ H); destruct H' | [ H : _ |- _ ] => let H' := fresh in assert (H' := match_eta2 _ H); destruct H' | _ => step_clear_paths | _ => expand; step_clear_paths_in_match | _ => progress auto with path_hints | _ => done | _ => exact (center _) end. Ltac path_induction_hammer := progress repeat step_path_induction_hammer. (** * Miscellaneous tactics *) (** Substitute all hypotheses with bodies, i.e., of the form [H := _]. *) Ltac subst_body := repeat match goal with | [ H := _ |- _ ] => subst H end. (** Some tactics to do things with some arbitrary hypothesis in the context. These tactics are similar to, e.g., [assumption]. *) Ltac do_with_hyp tac := idtac; match goal with | [ H : _ |- _ ] => tac H end. Ltac rewrite_hyp' := do_with_hyp ltac:(fun H => rewrite H). Ltac rewrite_hyp := repeat rewrite_hyp'. Ltac rewrite_rev_hyp' := do_with_hyp ltac:(fun H => rewrite <- H). Ltac rewrite_rev_hyp := repeat rewrite_rev_hyp'. Ltac apply_hyp' := do_with_hyp ltac:(fun H => apply H). Ltac apply_hyp := repeat apply_hyp'. Ltac eapply_hyp' := do_with_hyp ltac:(fun H => eapply H). Ltac eapply_hyp := repeat eapply_hyp'. (** Run [simpl] on a hypothesis before rewriting with it. *) Ltac simpl_do_clear tac term := let H := fresh in assert (H := term); cbn in H |- *; tac H; clear H. (** The behavior of [simpl rewrite] with respect to implicit arguments is slightly different from that of [rewrite]. In some ways, it is a little more like [erewrite], but in fact both [rewrite] and [erewrite] use magic that we are unable to exactly duplicate with a user-defined tactic. The point is that for a user-defined tactic, Coq has to resolve the meaning of the term passed to it in some way before the tactic begins executing. In particular, if that term involves maximally inserted implicit arguments, then it will have to fill them in; but often there will be no way to do that. If we declared the argument of [simpl rewrite] as a [constr], then this would cause it to fail. Instead, we declare it as an [open_constr], which allows Coq to fill in those implicit arguments with existential variables, which can then be instantiated later during the rewriting. *) Tactic Notation "simpl" "rewrite" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite H) term. Tactic Notation "simpl" "rewrite" "->" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> H) term. Tactic Notation "simpl" "rewrite" "<-" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- H) term. Tactic Notation "simpl" "rewrite" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite H in hyp) term. Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> H in hyp) term. Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- H in hyp) term. Tactic Notation "simpl" "rewrite" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite H in * ) term. Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> H in * ) term. Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- H in * ) term. Tactic Notation "simpl" "rewrite" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite H in * |- ) term. Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> H in * |- ) term. Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- H in * |- ) term. Tactic Notation "simpl" "rewrite" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite !H) term. Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> !H) term. Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- !H) term. Tactic Notation "simpl" "rewrite" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite !H in hyp) term. Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> !H in hyp) term. Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- !H in hyp) term. Tactic Notation "simpl" "rewrite" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite !H in * ) term. Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> !H in * ) term. Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- !H in * ) term. Tactic Notation "simpl" "rewrite" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite !H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> !H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- !H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite !H in * |- ) term. Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> !H in * |- ) term. Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- !H in * |- ) term. Tactic Notation "simpl" "rewrite" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite ?H) term. Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> ?H) term. Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- ?H) term. Tactic Notation "simpl" "rewrite" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite ?H in hyp) term. Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> ?H in hyp) term. Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- ?H in hyp) term. Tactic Notation "simpl" "rewrite" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite ?H in * ) term. Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> ?H in * ) term. Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- ?H in * ) term. Tactic Notation "simpl" "rewrite" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite ?H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> ?H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- ?H in hyp |- * ) term. Tactic Notation "simpl" "rewrite" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite ?H in * |- ) term. Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> ?H in * |- ) term. Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- ?H in * |- ) term. Ltac head_hnf expr := let expr' := eval hnf in expr in head expr'. (* given a [matcher] that succeeds on some hypotheses and fails on others, destruct any matching hypotheses, and then execute [tac] after each [destruct]. The [tac] part exists so that you can, e.g., [simpl in *], to speed things up. *) Ltac destruct_all_matches_then matcher tac := repeat match goal with | [ H : ?T |- _ ] => matcher T; destruct H; tac end. Ltac destruct_all_matches matcher := destruct_all_matches_then matcher ltac:(simpl in *). Ltac destruct_all_matches' matcher := destruct_all_matches_then matcher idtac. (** matches anything whose type has a [T] in it *) Ltac destruct_type_matcher T HT := match HT with | context[T] => idtac end. Ltac destruct_type T := destruct_all_matches ltac:(destruct_type_matcher T). Ltac destruct_type' T := destruct_all_matches' ltac:(destruct_type_matcher T). Ltac destruct_head_matcher T HT := match head HT with | T => idtac end. Ltac destruct_head T := destruct_all_matches ltac:(destruct_head_matcher T). Ltac destruct_head' T := destruct_all_matches' ltac:(destruct_head_matcher T). Ltac destruct_head_hnf_matcher T HT := match head_hnf HT with | T => idtac end. Ltac destruct_head_hnf T := destruct_all_matches ltac:(destruct_head_hnf_matcher T). Ltac destruct_head_hnf' T := destruct_all_matches' ltac:(destruct_head_hnf_matcher T). (** Turns a context object, obtained via, e.g., [match goal with |- context G[...] => ... end], into a lambda / gallina function. *) Ltac context_to_lambda G := let ret := constr:(fun x => let k := x in ltac:( let ret := context G[k] in exact ret)) in (eval cbv zeta in ret). (** The [rewrite <-] tactic uses [internal_paths_rew], which is definitionally equal to [transport], except for the order of the arguments. The following replaces the former with the latter. *) Ltac internal_paths_rew_to_transport := repeat match goal with |- context [ internal_paths_rew ?P ?u ?p ] => change (internal_paths_rew P u p) with (transport P p u) end. (** Unfortunately, the more common [rewrite ->] uses [internal_paths_rew_r], which is not definitionally equal to something involving [transport]. However, we do have a propositional equality. The arguments here match the arguments that [internal_paths_rew_r] takes. *) Definition internal_paths_rew_r_to_transport {A : Type} {x y : A} (P : A -> Type) (u : P y) (p : x = y) : internal_paths_rew_r P u p = transport P p^ u. Proof. destruct p; reflexivity. Defined. (** This tactic replaces both [internal_paths_rew] and [internal_paths_rew_r] with [transport], using [rewrite] for the latter. *) Ltac rewrite_to_transport := internal_paths_rew_to_transport; rewrite ! internal_paths_rew_r_to_transport. Coq-HoTT-9.0/theories/Tactics/000077500000000000000000000000001474641544500161525ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Tactics/BinderApply.v000066400000000000000000000211771474641544500205620ustar00rootroot00000000000000(** * Apply a lemma under binders *) Require Import Basics.Overture Tactics.EvalIn. (** There are some cases where [apply lem] will fail, but [intros; apply lem] will succeed. The tactic [binder apply] is like [intros; apply lem], but it cleans up after itself by [revert]ing the things it introduced. The tactic [binder apply lem in H] is to [binder apply lem], as [apply lem in H] is to [apply lem]. Note, however, that the implementation of [binder apply lem in H] is completely different and significantly more complicated. *) Ltac can_binder_apply apply_tac fail1_tac := first [ assert_succeeds apply_tac | assert_succeeds (intro; can_binder_apply apply_tac fail1_tac) | fail1_tac ]. Ltac binder_apply apply_tac fail1_tac := can_binder_apply apply_tac fail1_tac; first [ apply_tac | let H := fresh in intro H; binder_apply apply_tac fail1_tac; revert H | fail 1 "Cannot re-revert some introduced hypothesis" ]. (** The tactic [eval_under_binders tac H] is equivalent to [tac H] if [H] is not a product (lambda-abstraction), and roughly equivalent to the constr [fun x => eval_under_binders tac (H x)] if [H] is a product. *) Ltac eval_under_binders tac H := (** Bind a convenient name for the recursive call *) let rec_tac := eval_under_binders tac in (** If the hypothesis is a product ([forall]), we want to recurse under binders; if not, we're in the base case, and we simply compute the new term. We use [match] rather than [lazymatch] so that if the tactic fails to apply under all of the binders, we try again under fewer binders. We want to try first under as many binders as possible, in case the tactic, e.g., instantiates extra binders with evars. *) match type of H with (** Standard pattern for recursing under binders. We zeta-expand to work around https://coq.inria.fr/bugs/show_bug.cgi?id=3248 and https://coq.inria.fr/bugs/show_bug.cgi?id=3458; we'd otherwise need globally unique name for [x]. We zeta-reduce afterwards so the user doesn't see our zeta-expansion. We use [x] in both the pattern and the returned constructor so that we preserve the given name for the binder. *) | forall x : ?T, @?P x => let ret := constr:(fun x : T => let Hx := H x in ltac:( let ret' := rec_tac Hx in exact ret')) in let ret' := (eval cbv zeta in ret) in constr:(ret') (** Base case - simply return [tac H] *) | _ => tac H end. (** The tactic [make_tac_under_binders_using_in tac using_tac H] uses [tac] to transform a term [H], solving side-conditions (e.g., if [tac] uses [apply]) with [using_tac]. It returns the updated version of [H] as a constr; if [H] is a hypothesis in the context, it does not modify it. Conceptually, [make_tac_under_binders_using_in tac idtac H] is the composition of two tactics: a [transform_under_binders : (constr -> constr) -> (constr -> constr)] that runs a tactic under the binders of the constr it's given, and what would be an [eval tac in H], except for the fact that, e.g., [eval rewrite in H] doesn't actually work because it predates tactics in terms (we use [eval_in_using tac using_tac H] instead). The arguments are: - [tac] - should take the name of a hypothesis, and modify that hypothesis in place. It could, for example, be [fun H => rewrite lem in H] to do the [rewrite H] under binders. - [using_tac] - used to solve any side-conditions that [tac] generates. Not strictly necessary, since [tac] can always solve its own side-conditions, but it's sometimes convenient to instantiate [tac] with [fun H => eapply lem in H] or something, and solve the side-conditions with [eassumption]. - [H] - the name of the hypothesis to start from. N.B. We do not require [Funext] to use this tactic; [Funext] would only required to relate the term returned by this tactic and the original term. Note also that we only rewrite under top-level binders (e.g., under the [x] in a hypothesis of type [forall x, P x], but not under the [x] in a hypothesis of type [(fun x y => x + y) = (fun x y => y + x)]). *) Ltac make_tac_under_binders_using_in tac using_tac H := eval_under_binders ltac:(fun H' => eval_in_using tac using_tac H') H. Ltac do_tac_under_binders_using_in tac using_tac H := let H' := make_tac_under_binders_using_in tac using_tac H in let H'' := fresh in pose proof H' as H''; clear H; rename H'' into H. Tactic Notation "constrbinder" "apply" constr(lem) "in" constr(H) "using" tactic3(tac) := make_tac_under_binders_using_in ltac:(fun H' => apply lem in H') tac H. Tactic Notation "constrbinder" "eapply" open_constr(lem) "in" constr(H) "using" tactic3(tac) := constrbinder apply lem in H using tac. Tactic Notation "binder" "apply" constr(lem) "in" constr(H) "using" tactic3(tac) := do_tac_under_binders_using_in ltac:(fun H' => apply lem in H') tac H. Tactic Notation "binder" "eapply" open_constr(lem) "in" constr(H) "using" tactic3(tac) := binder apply lem in H using tac. Tactic Notation "constrbinder" "apply" constr(lem) "in" constr(H) := constrbinder apply lem in H using idtac. Tactic Notation "constrbinder" "eapply" open_constr(lem) "in" constr(H) := constrbinder eapply lem in H using idtac. Tactic Notation "binder" "apply" constr(lem) := binder_apply ltac:(apply lem) ltac:(fail 1 "Cannot apply" lem). Tactic Notation "binder" "eapply" open_constr(lem) := binder_apply ltac:(eapply lem) ltac:(fail 1 "Cannot eapply" lem). Tactic Notation "binder" "apply" constr(lem) "in" constr(H) := binder apply lem in H using idtac. Tactic Notation "binder" "eapply" open_constr(lem) "in" constr(H) := binder eapply lem in H using idtac. Example basic_goal {A B C} (HA : forall x : A, B x) (HB : forall x : A, B x -> C x) : forall x : A, C x. Proof. (** If we try to [apply HB], wanting to replace [C] with [B], we get an error about being unable to unify [B ?] with [A]. *) Fail apply HB. (** The tactic [binder apply] fixes this shortcoming. *) binder apply HB. exact HA. (** We [Abort], so that we don't get an extra constant floating around. *) Abort. Example basic {A B C} (HA : forall x : A, B x) (HB : forall x : A, B x -> C x) : forall x : A, C x. Proof. (** If we try to [apply HB in HA], wanting to replace [B] with [C], we get an error about being unable to instantiate the argument of type [A]: "Error: Unable to find an instance for the variable x." *) Fail apply HB in HA. (** The tactic [binder apply] fixes this shortcoming. *) binder apply HB in HA. exact HA. (** We [Abort], so that we don't get an extra constant floating around. *) Abort. Example ex_funext `{Funext} {A} f g (H' : forall x y z w : A, f x y z w = g x y z w :> A) : f = g. Proof. (** We need to apply [path_forall] under binders five times in [H']. We use a different variant each time to demonstrate the various ways of using this tactic. In a normal proof, you'd probably just do [do 4 binder apply (@path_forall _) in H'] or just [repeat binder apply (@path_forall _) in H']. *) (** If we do [binder apply path_forall in H'], we are told that Coq can't infer the argument [A] to [path_forall]. Instead, we can [binder eapply] it, to tell Coq to defer inference and use an evar for now. *) Fail binder apply path_forall in H'. binder eapply path_forall in H'. (** Alternatively, we can make [A] explicit. But then we get an error about not being able to resolve the instance of [Funext]. We can either tell Coq to solve the side condition using the [assumption] tactic (or [typeclasses eauto], for that matter), or we can have typeclass inference run when we construct the lemma to apply. *) (** Some versions of Proof General are bad about noticing [Fail] within a tactic; see http://proofgeneral.inf.ed.ac.uk/trac/ticket/494. So we comment this one out. *) (** << Fail binder apply @path_forall in H'. >> Error: Tactic failure: Cannot use to solve side-condition goal Funext . Extended goal with context: (Funext -> forall (A : Type) (f g : A -> A -> A -> A -> A) (H' : forall x' x'0 x'1 : A, f x' x'0 x'1 = g x' x'0 x'1), let H0 := H' in Funext). *) binder apply @path_forall in H' using assumption. binder apply @path_forall in H' using typeclasses eauto. binder apply (@path_forall _) in H'. (** Now we have removed all arguments to [f] and [g] in [H']. *) exact H'. (** We [Abort], so that we don't get an extra constant floating around. *) Abort. (** N.B. [constrbinder apply] is like [binder apply], except that it constructs a new term and returns it, rather than applying a lemma in-place to a hypothesis. It's primarily useful as plumbing for higher-level tactics. *) Coq-HoTT-9.0/theories/Tactics/EquivalenceInduction.v000066400000000000000000000374021474641544500224650ustar00rootroot00000000000000(** * Equivalence induction *) Require Import Basics.Overture Basics.Equivalences Basics.Tactics. Require Import Types.Equiv Types.Prod Types.Forall Types.Sigma Types.Universe. (** We define typeclasses and tactics for doing equivalence induction. *) Local Open Scope equiv_scope. Class RespectsEquivalenceL@{i j k s0 s1} (A : Type@{i}) (P : forall (B : Type@{j}), (A <~> B) -> Type@{k}) := respects_equivalenceL : sig@{s0 s1} (fun e' : forall B (e : A <~> B), P A (equiv_idmap A) <~> P B e => Funext -> equiv_idmap _ = e' A (equiv_idmap _) ). Class RespectsEquivalenceR@{i j k s0 s1} (A : Type@{i}) (P : forall (B : Type@{j}), (B <~> A) -> Type@{k}) := respects_equivalenceR : sig@{s0 s1} (fun e' : forall B (e : B <~> A), P A (equiv_idmap A) <~> P B e => Funext -> equiv_idmap _ = e' A (equiv_idmap _) ). (** We use a sigma type rather than a record for two reasons: 1. In the dependent cases, where one equivalence-respectfulness proof will show up in the body of another goal, it might be the case that using sigma types allows us to reuse the respectfulness lemmas of sigma types, rather than writing new ones for this type. 2. We expect it to be significantly useful to see the type of the fields than the type of the record, because we expect this type to show up as a goal infrequently. Sigma types have more informative notations than record type names; the user can run hnf to see what is left to do in the side conditions. *) Global Arguments RespectsEquivalenceL : clear implicits. Global Arguments RespectsEquivalenceR : clear implicits. (** When doing equivalence induction, typeclass inference will either fully solve the respectfulness side-conditions, or not make any progress. We would like to progress as far as we can on the side-conditions, so that we leave the user with as little to prove as possible. To do this, we create a "database", implemented using typeclasses, to look up the refinement lemma, keyed on the head of the term we want to respect equivalence. *) Class respects_equivalence_db {KT VT} (Key : KT) {lem : VT} : Type0 := make_respects_equivalence_db : Unit. Definition get_lem' {KT VT} Key {lem} `{@respects_equivalence_db KT VT Key lem} : VT := lem. Notation get_lem key := ltac:(let res := constr:(get_lem' key) in let res' := (eval unfold get_lem' in res) in exact res') (only parsing). Section const. Context {A : Type} {T : Type}. Global Instance const_respects_equivalenceL : RespectsEquivalenceL A (fun _ _ => T). Proof. refine (fun _ _ => equiv_idmap T; fun _ => _). exact idpath. Defined. Global Instance const_respects_equivalenceR : RespectsEquivalenceR A (fun _ _ => T). Proof. refine (fun _ _ => equiv_idmap _; fun _ => _). exact idpath. Defined. End const. Global Instance: forall {T}, @respects_equivalence_db _ _ T (fun A => @const_respects_equivalenceL A T) := fun _ => tt. Section id. Context {A : Type}. Global Instance idmap_respects_equivalenceL : RespectsEquivalenceL A (fun B _ => B). Proof. refine (fun B e => e; fun _ => _). exact idpath. Defined. Global Instance idmap_respects_equivalenceR : RespectsEquivalenceR A (fun B _ => B). Proof. refine (fun B e => equiv_inverse e; fun _ => path_equiv _). apply path_forall; intro; reflexivity. Defined. End id. Section unit. Context {A : Type}. Definition unit_respects_equivalenceL : RespectsEquivalenceL A (fun _ _ => Unit) := @const_respects_equivalenceL A Unit. Definition unit_respects_equivalenceR : RespectsEquivalenceR A (fun _ _ => Unit) := @const_respects_equivalenceR A Unit. End unit. Section prod. Global Instance prod_respects_equivalenceL {A} {P Q : forall B, (A <~> B) -> Type} `{RespectsEquivalenceL A P, RespectsEquivalenceL A Q} : RespectsEquivalenceL A (fun B e => P B e * Q B e). Proof. refine ((fun B e => equiv_functor_prod' (respects_equivalenceL.1 B e) (respects_equivalenceL.1 B e)); _). exact (fun fs => transport (fun e' => _ = equiv_functor_prod' e' _) (respects_equivalenceL.2 _) (transport (fun e' => _ = equiv_functor_prod' _ e') (respects_equivalenceL.2 _) idpath)). Defined. Global Instance prod_respects_equivalenceR {A} {P Q : forall B, (B <~> A) -> Type} `{RespectsEquivalenceR A P, RespectsEquivalenceR A Q} : RespectsEquivalenceR A (fun B e => P B e * Q B e). Proof. refine ((fun B e => equiv_functor_prod' (respects_equivalenceR.1 B e) (respects_equivalenceR.1 B e)); _). exact (fun fs => transport (fun e' => _ = equiv_functor_prod' e' _) (respects_equivalenceR.2 _) (transport (fun e' => _ = equiv_functor_prod' _ e') (respects_equivalenceR.2 _) idpath)). Defined. Global Instance: @respects_equivalence_db _ _ (@prod) (@prod_respects_equivalenceL) := tt. End prod. (** A tactic to solve the identity-preservation part of equivalence-respectfulness. *) Local Ltac t_step := idtac; match goal with | [ |- _ = _ :> (_ <~> _) ] => apply path_equiv | _ => reflexivity | _ => assumption | _ => intro | [ |- _ = _ :> (forall _, _) ] => apply path_forall | _ => progress unfold functor_forall, functor_sigma | _ => progress cbn in * | [ |- context[?x.1] ] => let H := fresh in destruct x as [? H]; try destruct H | [ H : _ = _ |- _ ] => destruct H | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H') | [ H : ?A -> ?B, H' : ?A |- _ ] => generalize dependent (H H'); clear H | _ => progress rewrite ?eisretr, ?eissect end. Local Ltac t := repeat t_step. Section pi. Global Instance forall_respects_equivalenceL `{Funext} {A} {P : forall B, (A <~> B) -> Type} {Q : forall B e, P B e -> Type} `{HP : RespectsEquivalenceL A P} `{HQ : forall a : P A (equiv_idmap A), RespectsEquivalenceL A (fun B e => Q B e (respects_equivalenceL.1 B e a))} : RespectsEquivalenceL A (fun B e => forall x : P B e, Q B e x). Proof. simple refine (fun B e => _; _). { refine (equiv_functor_forall' (equiv_inverse ((@respects_equivalenceL _ _ HP).1 B e)) (fun b => _)). refine (equiv_compose' (equiv_path _ _ (ap (Q B e) (eisretr _ _))) (equiv_compose' ((HQ (equiv_inverse ((@respects_equivalenceL _ _ HP).1 B e) b)).1 B e) (equiv_path _ _ (ap (Q A (equiv_idmap _)) _)))). refine (ap10 (ap equiv_fun (respects_equivalenceL.2 _)) _). } { t. } Defined. Global Instance forall_respects_equivalenceR `{Funext} {A} {P : forall B, (B <~> A) -> Type} {Q : forall B e, P B e -> Type} `{HP : RespectsEquivalenceR A P} `{HQ : forall a : P A (equiv_idmap A), RespectsEquivalenceR A (fun B e => Q B e (respects_equivalenceR.1 B e a))} : RespectsEquivalenceR A (fun B e => forall x : P B e, Q B e x). Proof. simple refine (fun B e => _; _). { refine (equiv_functor_forall' (equiv_inverse ((@respects_equivalenceR _ _ HP).1 B e)) (fun b => _)). refine (equiv_compose' (equiv_path _ _ (ap (Q B e) (eisretr _ _))) (equiv_compose' ((HQ (equiv_inverse ((@respects_equivalenceR _ _ HP).1 B e) b)).1 B e) (equiv_path _ _ (ap (Q A (equiv_idmap _)) _)))). refine (ap10 (ap equiv_fun (respects_equivalenceR.2 _)) _). } { t. } Defined. End pi. Section sigma. Global Instance sigma_respects_equivalenceL `{Funext} {A} {P : forall B, (A <~> B) -> Type} {Q : forall B e, P B e -> Type} `{HP : RespectsEquivalenceL A P} `{HQ : forall a : P A (equiv_idmap A), RespectsEquivalenceL A (fun B e => Q B e (respects_equivalenceL.1 B e a))} : RespectsEquivalenceL A (fun B e => sig (Q B e)). Proof. simple refine ((fun B e => equiv_functor_sigma' (respects_equivalenceL.1 B e) (fun b => _)); _). { refine (equiv_compose' ((HQ b).1 B e) (equiv_path _ _ (ap (Q A (equiv_idmap _)) _))). refine (ap10 (ap equiv_fun (respects_equivalenceL.2 _)) _). } { t. } Defined. Global Instance sigma_respects_equivalenceR `{Funext} {A} {P : forall B, (B <~> A) -> Type} {Q : forall B e, P B e -> Type} `{HP : RespectsEquivalenceR A P} `{HQ : forall a : P A (equiv_idmap A), RespectsEquivalenceR A (fun B e => Q B e (respects_equivalenceR.1 B e a))} : RespectsEquivalenceR A (fun B e => sig (Q B e)). Proof. simple refine ((fun B e => equiv_functor_sigma' (respects_equivalenceR.1 B e) (fun b => _)); _). { refine (equiv_compose' ((HQ b).1 B e) (equiv_path _ _ (ap (Q A (equiv_idmap _)) _))). refine (ap10 (ap equiv_fun (respects_equivalenceR.2 _)) _). } { t. } Defined. Global Instance: @respects_equivalence_db _ _ (@sig) (@sigma_respects_equivalenceL) := tt. End sigma. Section equiv_transfer. Definition respects_equivalenceL_equiv {A A'} {P : forall B, (A <~> B) -> Type} {P' : forall B, A' <~> B -> Type} (eA : A <~> A') (eP : forall B e, P B (equiv_compose' e eA) <~> P' B e) `{HP : RespectsEquivalenceL A P} : RespectsEquivalenceL A' P'. Proof. simple refine ((fun B e => _); _). { refine (equiv_compose' (eP _ _) (equiv_compose' (equiv_compose' (HP.1 _ _) (equiv_inverse (HP.1 _ _))) (equiv_inverse (eP _ _)))). } { t. } Defined. Definition respects_equivalenceR_equiv {A A'} {P : forall B, (B <~> A) -> Type} {P' : forall B, B <~> A' -> Type} (eA : A' <~> A) (eP : forall B e, P B (equiv_compose' eA e) <~> P' B e) `{HP : RespectsEquivalenceR A P} : RespectsEquivalenceR A' P'. Proof. simple refine ((fun B e => _); _). { refine (equiv_compose' (eP _ _) (equiv_compose' (equiv_compose' (HP.1 _ _) (equiv_inverse (HP.1 _ _))) (equiv_inverse (eP _ _)))). } { t. } Defined. Definition respects_equivalenceL_equiv' {A} {P P' : forall B, (A <~> B) -> Type} (eP : forall B e, P B e <~> P' B e) `{HP : RespectsEquivalenceL A P} : RespectsEquivalenceL A P'. Proof. simple refine ((fun B e => _); _). { refine (equiv_compose' (eP _ _) (equiv_compose' (equiv_compose' (HP.1 _ _) (equiv_inverse (HP.1 _ _))) (equiv_inverse (eP _ _)))). } { t. } Defined. Definition respects_equivalenceR_equiv' {A} {P P' : forall B, (B <~> A) -> Type} (eP : forall B e, P B e <~> P' B e) `{HP : RespectsEquivalenceR A P} : RespectsEquivalenceR A P'. Proof. simple refine ((fun B e => _); _). { refine (equiv_compose' (eP _ _) (equiv_compose' (equiv_compose' (HP.1 _ _) (equiv_inverse (HP.1 _ _))) (equiv_inverse (eP _ _)))). } { t. } Defined. End equiv_transfer. Section equiv. Global Instance equiv_respects_equivalenceL `{Funext} {A} {P Q : forall B, (A <~> B) -> Type} `{HP : RespectsEquivalenceL A P} `{HQ : RespectsEquivalenceL A Q} : RespectsEquivalenceL A (fun B e => P B e <~> Q B e). Proof. simple refine (fun B e => _; fun _ => _). { refine (equiv_functor_equiv _ _); apply respects_equivalenceL.1. } { t. } Defined. Global Instance equiv_respects_equivalenceR `{Funext} {A} {P Q : forall B, (B <~> A) -> Type} `{HP : RespectsEquivalenceR A P} `{HQ : RespectsEquivalenceR A Q} : RespectsEquivalenceR A (fun B e => P B e <~> Q B e). Proof. simple refine (fun B e => _; fun _ => _). { refine (equiv_functor_equiv _ _); apply respects_equivalenceR.1. } { t. } Defined. Global Instance: @respects_equivalence_db _ _ (@Equiv) (@equiv_respects_equivalenceL) := tt. End equiv. Section ap. Global Instance equiv_ap_respects_equivalenceL {A} {P Q : forall B, (A <~> B) -> A} `{HP : RespectsEquivalenceL A (fun B (e : A <~> B) => P B e = Q B e)} : RespectsEquivalenceL A (fun (B : Type) (e : A <~> B) => e (P B e) = e (Q B e)). Proof. simple refine (fun B e => _; fun _ => _). { refine (equiv_ap' _ _ _ oE _); simpl. refine (respects_equivalenceL.1 B e). } { t. } Defined. Global Instance equiv_ap_inv_respects_equivalenceL {A} {P Q : forall B, (A <~> B) -> B} `{HP : RespectsEquivalenceL A (fun B (e : A <~> B) => P B e = Q B e)} : RespectsEquivalenceL A (fun (B : Type) (e : A <~> B) => e^-1 (P B e) = e^-1 (Q B e)). Proof. simple refine (fun B e => _; fun _ => _). { refine (equiv_ap' _ _ _ oE _); simpl. refine (respects_equivalenceL.1 B e). } { t. } Defined. Global Instance equiv_ap_respects_equivalenceR {A} {P Q : forall B, (B <~> A) -> B} `{HP : RespectsEquivalenceR A (fun B (e : B <~> A) => P B e = Q B e)} : RespectsEquivalenceR A (fun (B : Type) (e : B <~> A) => e (P B e) = e (Q B e)). Proof. simple refine (fun B e => _; fun _ => _). { refine (equiv_ap' _ _ _ oE _); simpl. refine (respects_equivalenceR.1 B e). } { t. } Defined. Global Instance equiv_ap_inv_respects_equivalenceR {A} {P Q : forall B, (B <~> A) -> A} `{HP : RespectsEquivalenceR A (fun B (e : B <~> A) => P B e = Q B e)} : RespectsEquivalenceR A (fun (B : Type) (e : B <~> A) => e^-1 (P B e) = e^-1 (Q B e)). Proof. simple refine (fun B e => _; fun _ => _). { refine (equiv_ap' _ _ _ oE _); simpl. refine (respects_equivalenceR.1 B e). } { t. } Defined. End ap. (** We now write the tactic that partially solves the respectfulness side-condition. We include cases for generic typeclass resolution, keys (heads) with zero, one, two, and three arguments, and a few cases that cannot be easily keyed (where the head is one of the arguments, or [forall]), or the head is [paths], for which we have only ad-hoc solutions at the moment. *) Ltac step_respects_equiv := idtac; match goal with | _ => progress intros | _ => assumption | _ => progress unfold respects_equivalenceL | _ => progress cbn | _ => exact _ (* case for fully solving the side-condition, when possible *) | [ |- RespectsEquivalenceL _ (fun _ _ => ?T) ] => rapply (get_lem T) | [ |- RespectsEquivalenceL _ (fun _ _ => ?T _) ] => rapply (get_lem T) | [ |- RespectsEquivalenceL _ (fun _ _ => ?T _ _) ] => rapply (get_lem T) | [ |- RespectsEquivalenceL _ (fun _ _ => ?T _ _ _) ] => rapply (get_lem T) | [ |- RespectsEquivalenceL _ (fun B e => equiv_fun e _ = equiv_fun e _) ] => refine equiv_ap_respects_equivalenceL | [ |- RespectsEquivalenceL _ (fun B e => equiv_inv e _ = equiv_inv e _) ] => refine equiv_ap_inv_respects_equivalenceL | [ |- RespectsEquivalenceL _ (fun B _ => B) ] => refine idmap_respects_equivalenceL | [ |- RespectsEquivalenceL _ (fun _ _ => forall _, _) ] => refine forall_respects_equivalenceL end. Ltac equiv_induction p := generalize dependent p; let p' := fresh in intro p'; let y := match type of p' with ?x <~> ?y => constr:(y) end in move p' at top; generalize dependent y; let P := match goal with |- forall y p, @?P y p => constr:(P) end in (* We use [(fun x => x) _] to block automatic typeclass resolution in the hole for the equivalence respectful proof. *) refine ((fun g H B e => (@respects_equivalenceL _ P H).1 B e g) _ (_ : (fun x => x) _)); [ intros | repeat step_respects_equiv ]. Goal forall `{Funext} A B (e : A <~> B), A -> { y : B & forall Q, Contr Q -> ((e^-1 y = e^-1 y) <~> (y = y)) * Q }. intros ? ? ? ? a. equiv_induction e. - simpl. exists a. intros Q q. exact (1, center _). Abort. Coq-HoTT-9.0/theories/Tactics/EvalIn.v000066400000000000000000000127641474641544500175310ustar00rootroot00000000000000(** * Evaluating tactics on terms *) Require Import Basics.Overture Basics.PathGroupoids. (** It sometimes happens, in the course of writing a tactic, that we have some term in an Ltac variable (more precisely, we have what Ltac calls a "constr") and we would like to act on it with some tactic such as [cbv] or [rewrite]. Ordinarily, such tactics only act on the current *goal*, and generally they have a version such as [rewrite ... in ...] which acts on something in the current *context*, but neither of these is the same as acting on a term held in an Ltac variable. For some tactics, such as [cbv] and [pattern], we can write [eval TAC in H], where [H] is the term in question; this form *returns* the modified term so we can place it in another Ltac variable. However, other tactics such as [rewrite] do not support this syntax. (There is a feature request for it at https://coq.inria.fr/bugs/show_bug.cgi?id=3677.) The following tactic [eval_in TAC H] fills this gap, allowing us to act by [rewrite] on terms in Ltac variables. The argument [TAC] must be a tactic that takes one argument, which is an Ltac function that gets passed the name of a hypothesis to act on, such as [ltac:(fun H' => rewrite H in H')]. (Unfortunately, however, [eval_in] cannot be used to exactly generalize [eval pattern in H]; see below.) There is also a variant called [eval_in_using], which also accepts a second user-specified tactic and uses it to solve side-conditions generated by the first one. We actually define [eval_in] in terms of [eval_in_using] by passing [idtac] as the second tactic. *) Ltac eval_in_using tac_in using_tac H := (** The syntax [$(...)$] allows execution of an arbitrary tactic to supply a needed term. By prefixing it with [constr:] which tells Ltac to expect a term, we obtain a pattern [constr:($(...)$)] which allows us to execute an arbitrary tactic in the situation of a fresh goal. This way we avoid modifying the existing context, and we can also get our hands on a proof term corresponding to the stateful modification. We pose [H] in the fresh context so we can play with it nicely, regardless of if it's a hypothesis or a term. Then we run [tac_in] on the hypothesis to modify it, use [exact] to "return" the modified hypothesis, and give a nice error message if [using_tac] fails to solve some side-condition. *) let ret := constr:(ltac:( let H' := fresh in pose H as H'; tac_in H'; [ exact H' | solve [ using_tac | let G := match goal with |- ?G => constr:(G) end in repeat match goal with H : _ |- _ => revert H end; let G' := match goal with |- ?G => constr:(G) end in fail 1 "Cannot use" using_tac "to solve side-condition goal" G "." "Extended goal with context:" G' ].. ])) in (** Finally, we play some games to format the return value nicely. We want to zeta-reduce the let-in generated by [pose], but not any other [let-in]s; we do this by matching for it and doing the substitution manually. Additionally, [pose]/[exact] also results in an extra [idmap]; we remove this with [cbv beta], which unfortunately also beta-reduces everything else. (This is why [eval_in pattern H] doesn't strictly generalize [eval pattern in H], since the latter doesn't beta-reduce.) Perhaps we want to zeta-reduce everything, and not beta-reduce anything instead? *) let T := type of ret in let ret' := (lazymatch ret with | let x := ?x' in @?P x => constr:(P x') end) in let ret'' := (eval cbv beta in ret') in constr:(ret'' : T). Ltac eval_in tac_in H := eval_in_using tac_in idtac H. Example eval_in_example : forall A B : Set, A = B -> A -> B. Proof. intros A B H a. let x := (eval_in ltac:(fun H' => rewrite H in H') a) in pose x as b. (** we get a [b : B] *) (** We [Abort], so that we don't get an extra constant floating around. *) Abort. (** ** Rewriting with reflexivity *) (** As an example application, we define a tactic that takes a lemma whose definition is [idpath] and behaves like [rewrite], except that it doesn't insert any transport lemmas like [Overture.internal_paths_rew_r]. In other words, it does a [change], but leverages the pattern-matching and substitution engine of [rewrite] to decide what to [change] into. *) (** We use a dummy inductive type since [rewrite] acts on the *type* of a hypothesis rather than its body (if any). *) Inductive dummy (A:Type) := adummy : dummy A. Ltac rewrite_refl H := match goal with | [ |- ?X ] => let dX' := eval_in ltac:(fun H' => rewrite H in H') (adummy X) in match type of dX' with | dummy ?X' => change X' end end. (** Here's what it would look like with ordinary [rewrite]: *) Example rewrite_refl_example {A B : Type} (x : A) (f : A -> B) : ap f idpath = idpath :> (f x = f x). Proof. rewrite ap_1. reflexivity. (** Show Proof. *) (** ==> (fun (A B : Type) (x : A) (f : A -> B) => Overture.internal_paths_rew_r (f x = f x) (ap f 1) 1 (fun p : f x = f x => p = 1) 1 (ap_1 x f)) *) Abort. (** And here's what we get with [rewrite_refl]: *) Example rewrite_refl_example {A B : Type} (x : A) (f : A -> B) : ap f idpath = idpath :> (f x = f x). Proof. rewrite_refl @ap_1. reflexivity. (** Show Proof. *) (** ==> (fun (A B : Type) (x : A) (f : A -> B) => 1) *) Abort. Coq-HoTT-9.0/theories/Tactics/Nameless.v000066400000000000000000000020201474641544500201020ustar00rootroot00000000000000Require Import Basics.Overture. (** * Building blocks for a globally nameless style of tactic reasoning *) (** ** [hyp] returns any hypothesis, with subsequent failures backtracking through all hypotheses *) Ltac hyp := multimatch goal with H : _ |- _ => constr:(H) end. (** ** [enforce foo] ensures that [foo] is well-typed *) Tactic Notation "enforce" open_constr(term) := idtac. (** ** [syntax_enforce [ H := body ]] ensures that [H] has a body which is syntactically equal to [body] *) Tactic Notation "syntax_enforce" "[" constr(H) ":=" open_constr(body) "]" := let H' := (eval unfold H in H) in constr_eq H' body. (** ** [enforce [ x = y ]] ensures that two terms, possibly containing holes, are judgmentally equal *) Tactic Notation "enforce" "[" open_constr(x) "=" open_constr(y) "]" := unify x y. (** An example *) Goal Empty -> let X0 := tt in Empty -> Unit. Proof. intros. let H := hyp in enforce (H : Unit); syntax_enforce [ H := tt ]; enforce [ H = _ ]; enforce [ _ = H ]; enforce [ H = tt ]. Abort. Coq-HoTT-9.0/theories/Tactics/RewriteModuloAssociativity.v000066400000000000000000000455431474641544500237310ustar00rootroot00000000000000(** * Tactics for rewriting modulo assciativity *) Require Import Overture PathGroupoids. Require Import Tactics.BinderApply. Local Open Scope path_scope. (** Throughout this file, we prefix with [idtac; ] all imperative tactics (those not returning constrs) which would otherwise start with [let] or [match]. This prevents them from being evaluated at the call site. See https://coq.inria.fr/bugs/show_bug.cgi?id=3498 for more details on this difference between tactics and tactic expressions. *) (** rewrite [lem] modulo associativity using: - [assoc_tac : unit] to associate the goal (in place) - [assoc_in_tac : hyp -> unit] to associate the hypothesis (in place) - [prepostcompose_any_tac : constr -> constr] to pre/post compose an arbitrary morphism onto the lemma - [rew_tac : hyp -> unit] to do the actual rewriting (in place). This tactic is called first with the non-associated version of the lemma, then with the associated version. *) Ltac rewriteA_using_helper rew_tac lem prepostcompose_any_tac assoc_tac assoc_in_tac := idtac; let lem' := prepostcompose_any_tac lem in let H := fresh in pose proof lem' as H; assoc_tac; match goal with | _ => rew_tac H | _ => assoc_in_tac H; rew_tac H end; clear H. (** This tactic is similar to the above, except that it passes both the unassociated lemma and the associated lemma to [repeat_rew_tac], which may then contain optimizations over a manual [repeat] such as being [rewrite ?lem, ?lem']. *) Ltac repeat_rewriteA_using_helper repeat_rew_tac lem prepostcompose_any_tac assoc_tac assoc_in_tac := idtac; let lem' := prepostcompose_any_tac lem in let H := fresh in pose proof lem' as H; assoc_in_tac H; assoc_tac; repeat_rew_tac lem' H; clear H. Module Export Compose. (** ** Rewriting modulo associativity of composition ([o]) *) (** Since [f o g] is just a notation, we need to define a constant that isn't reduced by [cbv beta]. *) Local Definition compose {A B C} (g : B -> C) (f : A -> B) (x : A) : C := g (f x). Ltac to_compose T := match T with | context G[?g o ?f] => let T' := context G[compose g f] in to_compose T' | ?T' => constr:(T') end. (** Turns a lemma of type [f = g] into [forall h, h o f = h o g] *) Ltac precompose_any H := let ret := make_tac_under_binders_using_in ltac:(fun H => (let H' := fresh in rename H into H'; let T := type of H' in let T' := to_compose T in pose proof (fun src (g : _ -> src) => @ap _ _ (fun f => compose g f) _ _ (H' : T')) as H)) ltac:(idtac) H in let T := type of ret in let T' := (eval cbv beta in T) in constr:(ret : T'). (** Associates a type fully to the left *) Ltac left_associate_compose_type T := let rec_tac := left_associate_compose_type in match to_compose T with | forall a : ?A, @?P a => let ret := constr:(forall a : A, let T' := P a in ltac:( let T'' := (eval unfold T' in T') in let ret := rec_tac T'' in exact ret)) in eval cbv beta zeta in ret | context T'[compose ?a (compose ?b ?c)] => let T'' := context T'[compose (compose a b) c] in rec_tac T'' | ?T' => constr:(T') end. Ltac left_associate_compose_in_type_of H := let T := type of H in let T' := left_associate_compose_type T in constr:(H : T'). Ltac left_associate_compose := idtac; (lazymatch goal with | [ |- ?G ] => let G' := left_associate_compose_type G in change G' end). Ltac left_associate_compose_in H := idtac; (lazymatch type of H with | ?T => let T' := left_associate_compose_type T in change T' in H end). Ltac after_rewrite := repeat match goal with | [ |- context G[compose ?g ?f] ] => let G' := context G[g o f] in change G' | _ => match goal with | [ |- context G[@compose ?A ?B ?C ?g] ] => let G' := context G[fun f : A -> B => g o f] in change G' | [ |- context G[@compose ?A ?B ?C] ] => let G' := context G[fun (g : B -> C) (f : A -> B) => g o f] in change G' | _ => progress cbv delta [compose] end; idtac "Warning: could not fully restore pre-rewrite state." "Try introducing more things or removing binders." end. Tactic Notation "rewriteoA" constr(lem) := rewriteA_using_helper ltac:(fun lem' => rewrite lem') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewriteoA" "->" constr(lem) := rewriteA_using_helper ltac:(fun lem' => rewrite -> lem') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewriteoA" "<-" constr(lem) := rewriteA_using_helper ltac:(fun lem' => rewrite <- lem') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewriteoA" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress rewrite ?lem', ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewriteoA" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => rewrite ?lem', ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewriteoA" "->" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress rewrite -> ?lem', -> ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewriteoA" "<-" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress rewrite <- ?lem', <- ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewriteoA" "->" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => rewrite -> ?lem', -> ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewriteoA" "<-" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => rewrite <- ?lem', <- ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" constr(lem) := rewriteA_using_helper ltac:(fun lem' => erewrite lem') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" "->" constr(lem) := rewriteA_using_helper ltac:(fun lem' => erewrite -> lem') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" "<-" constr(lem) := rewriteA_using_helper ltac:(fun lem' => erewrite <- lem') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress erewrite ?lem', ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => erewrite ?lem', ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" "->" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress erewrite -> ?lem', -> ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" "<-" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress erewrite <- ?lem', <- ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" "->" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => erewrite -> ?lem', -> ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "erewriteoA" "<-" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => erewrite <- ?lem', <- ?lem'') lem ltac:(precompose_any) ltac:(left_associate_compose) ltac:(left_associate_compose_in); after_rewrite. Tactic Notation "rewrite∘A" constr(lem) := rewriteoA lem. Tactic Notation "rewrite∘A" "->" constr(lem) := rewriteoA -> lem. Tactic Notation "rewrite∘A" "<-" constr(lem) := rewriteoA <- lem. Tactic Notation "rewrite∘A" "!" constr(lem) := rewriteoA !lem. Tactic Notation "rewrite∘A" "?" constr(lem) := rewriteoA ? lem. Tactic Notation "rewrite∘A" "->" "!" constr(lem) := rewriteoA -> !lem. Tactic Notation "rewrite∘A" "<-" "!" constr(lem) := rewriteoA <- !lem. Tactic Notation "rewrite∘A" "->" "?" constr(lem) := rewriteoA -> ? lem. Tactic Notation "rewrite∘A" "<-" "?" constr(lem) := rewriteoA <- ? lem. Tactic Notation "erewrite∘A" open_constr(lem) := erewriteoA lem. Tactic Notation "erewrite∘A" "->" open_constr(lem) := erewriteoA -> lem. Tactic Notation "erewrite∘A" "<-" open_constr(lem) := erewriteoA <- lem. Tactic Notation "erewrite∘A" "!" open_constr(lem) := erewriteoA !lem. Tactic Notation "erewrite∘A" "?" open_constr(lem) := erewriteoA ? lem. Tactic Notation "erewrite∘A" "->" "!" open_constr(lem) := erewriteoA -> !lem. Tactic Notation "erewrite∘A" "<-" "!" open_constr(lem) := erewriteoA <- !lem. Tactic Notation "erewrite∘A" "->" "?" open_constr(lem) := erewriteoA -> ? lem. Tactic Notation "erewrite∘A" "<-" "?" open_constr(lem) := erewriteoA <- ? lem. End Compose. Module Export Concat. (** ** Rewriting modulo associativity of concatenation ([@]) *) (** Turns a lemma of type [f = g] into [forall h, h @ f = h @ g] *) Ltac preconcat_any H := let ret := make_tac_under_binders_using_in ltac:(fun H => (let H' := fresh in rename H into H'; pose proof (fun dst (g : dst = _) => @ap _ _ (fun f => g @ f) _ _ H') as H)) ltac:(idtac) H in let T := type of ret in let T' := (eval cbv beta in T) in constr:(ret : T'). (** Associates a path fully to the left *) Ltac left_associate_concat_in H := let rec_tac := left_associate_concat_in in let T := type of H in let T' := (eval cbv beta in T) in match T' with | forall a : ?A, @?P a => let ret := constr:(fun a : A => let H' := H a in ltac:( let H'' := (eval unfold H' in H') in let ret := rec_tac H'' in exact ret)) in let T := type of ret in let T' := (eval cbv beta zeta in T) in let ret' := (eval cbv beta zeta in ret) in constr:(ret' : T') | context[@concat ?A1 ?x1 ?y1 ?z1 ?a (@concat ?A2 ?x2 ?y2 ?z2 ?b ?c)] => (lazymatch eval pattern (@concat A1 x1 y1 z1 a (@concat A2 x2 y2 z2 b c)) in T' with | ?P _ => let H' := constr:(transport P (concat_p_pp a b c) H) in rec_tac H' end) | ?T' => constr:(H : T') end. (** We really should just use [setoid_rewrite -> !concat_p_pp] here, to take care of binders, but we threw away Setoids. *) Ltac left_associate_concat := repeat match goal with | _ => rewrite -> !concat_p_pp | [ |- forall a : ?A, _ ] => let H := fresh in intro H; left_associate_concat; revert H end. Ltac left_associate_concat_in_hyp H := let H' := fresh in rename H into H'; let H_rep := left_associate_concat_in H' in pose proof H_rep as H; clear H'. Tactic Notation "rewrite@A" constr(lem) := rewriteA_using_helper ltac:(fun lem' => rewrite lem') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite@A" "->" constr(lem) := rewriteA_using_helper ltac:(fun lem' => rewrite -> lem') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite@A" "<-" constr(lem) := rewriteA_using_helper ltac:(fun lem' => rewrite <- lem') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite@A" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress rewrite ?lem', ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite@A" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => rewrite ?lem', ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite@A" "->" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress rewrite -> ?lem', -> ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite@A" "<-" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress rewrite <- ?lem', <- ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite@A" "->" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => rewrite -> ?lem', -> ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite@A" "<-" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => rewrite <- ?lem', <- ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" constr(lem) := rewriteA_using_helper ltac:(fun lem' => erewrite lem') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" "->" constr(lem) := rewriteA_using_helper ltac:(fun lem' => erewrite -> lem') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" "<-" constr(lem) := rewriteA_using_helper ltac:(fun lem' => erewrite <- lem') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress erewrite ?lem', ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => erewrite ?lem', ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" "->" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress erewrite -> ?lem', -> ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" "<-" "!" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => progress erewrite <- ?lem', <- ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" "->" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => erewrite -> ?lem', -> ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "erewrite@A" "<-" "?" constr(lem) := repeat_rewriteA_using_helper ltac:(fun lem' lem'' => erewrite <- ?lem', <- ?lem'') lem ltac:(preconcat_any) ltac:(left_associate_concat) ltac:(left_associate_concat_in_hyp). Tactic Notation "rewrite•A" constr(lem) := rewrite@A lem. Tactic Notation "rewrite•A" "->" constr(lem) := rewrite@A -> lem. Tactic Notation "rewrite•A" "<-" constr(lem) := rewrite@A <- lem. Tactic Notation "rewrite•A" "!" constr(lem) := rewrite@A !lem. Tactic Notation "rewrite•A" "?" constr(lem) := rewrite@A ? lem. Tactic Notation "rewrite•A" "->" "!" constr(lem) := rewrite@A -> !lem. Tactic Notation "rewrite•A" "<-" "!" constr(lem) := rewrite@A <- !lem. Tactic Notation "rewrite•A" "->" "?" constr(lem) := rewrite@A -> ? lem. Tactic Notation "rewrite•A" "<-" "?" constr(lem) := rewrite@A <- ? lem. Tactic Notation "erewrite•A" open_constr(lem) := erewrite@A lem. Tactic Notation "erewrite•A" "->" open_constr(lem) := erewrite@A -> lem. Tactic Notation "erewrite•A" "<-" open_constr(lem) := erewrite@A <- lem. Tactic Notation "erewrite•A" "!" open_constr(lem) := erewrite@A !lem. Tactic Notation "erewrite•A" "?" open_constr(lem) := erewrite@A ? lem. Tactic Notation "erewrite•A" "->" "!" open_constr(lem) := erewrite@A -> !lem. Tactic Notation "erewrite•A" "<-" "!" open_constr(lem) := erewrite@A <- !lem. Tactic Notation "erewrite•A" "->" "?" open_constr(lem) := erewrite@A -> ? lem. Tactic Notation "erewrite•A" "<-" "?" open_constr(lem) := erewrite@A <- ? lem. End Concat. Section examples. Section compose. Example simple_01 {A} (f g h i j : A -> A) : f o g = h -> (i o f) o (g o j) = i o h o j. Proof. intro H. rewrite∘A H. reflexivity. Abort. Example simple_02 {A} (f g h i j : A -> A) : f o g = h -> (i o f) o (g o f o g o j) = i o h o h o j. Proof. intro H. rewrite∘A !H. reflexivity. Abort. End compose. Section concat. Example simple_01 {A} {a : A} (f g h i j : a = a) : f @ g = h -> (i @ f) @ (g @ j) = i @ h @ j. Proof. intro H. rewrite@A H. reflexivity. Abort. Example simple_02 {A} {a : A} (f g h i j : A = A) : f @ g = h -> (i @ f) @ (g @ f @ g @ j) = i @ h @ h @ j. Proof. intro H. rewrite@A !H. reflexivity. Abort. End concat. End examples. Coq-HoTT-9.0/theories/Truncations.v000066400000000000000000000002051474641544500172550ustar00rootroot00000000000000Require Export HoTT.Truncations.Core. Require Export HoTT.Truncations.SeparatedTrunc. Require Export HoTT.Truncations.Connectedness. Coq-HoTT-9.0/theories/Truncations/000077500000000000000000000000001474641544500170715ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Truncations/Connectedness.v000066400000000000000000000307141474641544500220600ustar00rootroot00000000000000(** * Connectedness *) Require Import Basics. Require Import Types. Require Import Extensions. Require Import Factorization. Require Export Modalities.Modality. (* [Export] since the actual definitions of connectedness appear there, in the generality of a modality. *) Require Import Modalities.Descent. Require Import Truncations.Core Truncations.SeparatedTrunc. (** This reduces universe variables in [conn_pointed_type] and [conn_point_elim], which refer to [Unit]. *) Local Set Universe Minimization ToSet. Local Open Scope path_scope. Local Open Scope trunc_scope. (** There is a slight controversy of indexing for connectedness — in particular, how the indexing for maps shoud relate to the indexing for types. One may reasonably take the connectedness of a map to correspond either to that of its *fibers*, or of its *cofiber*; these differ by 1. The traditional topological indexing uses the cofiber. We use the fiber, as does Lurie in [HTT]; but we choose to agree with the traditional indexing on types, while Lurie agrees with it on maps. Currently, the translation is therefore as follows: HoTT Traditional Lurie Map (n-1)-connected n-connected n-connective Type n-connected n-connected (n+1)-connective A handy benchmark: under our indexing, the map [S1 -> 1] is 0-connected but not 1-connected, while the map [1 -> S1] is (–1)–connected but not 0-connected. One reason for our choice is that this way, the n-truncated and n-connected maps are the modal and modally-connected maps for the n-truncation modality. Many of the basic lemmas about connected maps are in fact true for any modality, and can be found in [Modality.v]. Thus, here we consider mainly properties that involve the interaction of connectedness at different truncation levels. *) (** ** Truncatedness of the type of extensions *) (** A key lemma on the interaction between connectedness and truncatedness: suppose one is trying to extend along an n-connected map, into a k-truncated family of types (k ≥ n). Then the space of possible extensions is (k–n–2)-truncated. (Mnemonic for the indexing: think of the base case, where k=n; then we know we can eliminate, so the space of extensions is contractible.) This lemma is most useful via corollaries like the wedge-inclusion, the wiggly wedge, and their n-ary generalizations. *) Lemma istrunc_extension_along_conn `{Funext} {m n : trunc_index} {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} (P : B -> Type) {HP : forall b:B, IsTrunc (m +2+ n) (P b)} (d : forall a:A, P (f a)) : IsTrunc m (ExtensionAlong f P d). Proof. revert P HP d. simple_induction m m' IH; intros P HP d; simpl in *. (* m = –2 *) - apply (Build_Contr _ (extension_conn_map_elim n f P d)). intros y. apply (allpath_extension_conn_map n); assumption. (* m = S m' *) - apply istrunc_S. intros e e'. refine (istrunc_isequiv_istrunc _ (path_extension e e')). (* magically infers: paths in extensions = extensions into paths, which by induction is m'-truncated. *) Defined. (** ** Connectedness of path spaces *) Global Instance isconnected_paths `{Univalence} {n A} `{IsConnected n.+1 A} (x y : A) : IsConnected n (x = y). Proof. refine (contr_equiv' _ (equiv_path_Tr x y)^-1). Defined. (** ** Connectivity of pointed types *) (** The connectivity of a pointed type and (the inclusion of) its point are intimately connected. *) (** We can't make both of these [Instance]s, as that would result in infinite loops. *) Global Instance conn_pointed_type@{u} {n : trunc_index} {A : Type@{u}} (a0:A) `{IsConnMap n _ _ (unit_name a0)} : IsConnected n.+1 A | 1000. Proof. apply isconnected_conn_map_to_unit. apply (OO_cancelR_conn_map (Tr n.+1) (Tr n) (unit_name a0) (const_tt A)). Defined. Definition conn_point_incl `{Univalence} {n : trunc_index} {A : Type} (a0:A) `{IsConnected n.+1 A} : IsConnMap n (unit_name a0). Proof. rapply (OO_cancelL_conn_map (Tr n.+1) (Tr n) (unit_name a0) (const_tt A)). apply O_lex_leq_Tr. Defined. #[export] Hint Immediate conn_point_incl : typeclass_instances. (** Note that [OO_cancelR_conn_map] and [OO_cancelL_conn_map] (Proposition 2.31 of CORS) generalize the above statements to 2/3 of a 2-out-of-3 property for connected maps, for any reflective subuniverse and its subuniverse of separated types. If useful, we could specialize that more general form explicitly to truncations. *) (** To prove an [n]-truncated predicate on an (n+1)-connected, pointed type, it's enough to prove it for the basepoint. *) Definition conn_point_elim `{Univalence} (n : trunc_index) {A : pType@{u}} `{IsConnected n.+1 A} (P : A -> Type@{u}) `{forall a, IsTrunc n (P a)} (p0 : P (point A)) : forall a, P a. Proof. (** This follows from [conn_point_incl] and [conn_map_elim], but we give a direct proof. *) intro a. (** Since [A] is [n+1]-connected, [a0 = a] is [n]-connected, which means that [Tr n (a0 = a)] has an element. *) pose proof (p := center (Tr n ((point A) = a))). strip_truncations. exact (p # p0). Defined. (** ** Decreasing connectedness *) (** An [n.+1]-connected type is also [n]-connected. This obviously can't be an [Instance]! *) Definition isconnected_pred n A `{IsConnected n.+1 A} : IsConnected n A. Proof. apply isconnected_from_elim; intros C ? f. refine (isconnected_elim n.+1 C f). Defined. (** A [k]-connected type is [n]-connected, when [k >= n]. We constrain [k] by making it of the form [n +2+ m], which makes the induction go through smoothly. *) Definition isconnected_pred_add n m A `{H : IsConnected (n +2+ m) A} : IsConnected m A. Proof. induction n. 1: assumption. apply IHn. apply isconnected_pred. assumption. Defined. (** A version with the order of summands swapped, which is sometimes handy, e.g. in the next two results. *) Definition isconnected_pred_add' n m A `{H : IsConnected (m +2+ n) A} : IsConnected m A. Proof. apply (isconnected_pred_add n m). destruct (trunc_index_add_comm m n); assumption. Defined. (** It follows that an [n.+1]-connected type is also [-1]-connected. *) Definition merely_isconnected n A `{IsConnected n.+1 A} : merely A := @center _ (isconnected_pred_add' n (-1) A). (** And that an [n.+2]-connected type is [0]-connected. *) Definition is0connected_isconnected (n : trunc_index) A `{IsConnected n.+2 A} : IsConnected 0 A := isconnected_pred_add' n 0 A. Definition isconnmap_pred_add n m A B (f : A -> B) `{IsConnMap (n +2+ m) _ _ f} : IsConnMap m f. Proof. intro b. exact (isconnected_pred_add n m _). Defined. (** ** 0-connectedness *) (** To be 0-connected is the same as to be (-1)-connected and that any two points are merely equal. TODO: This should also be generalized to separated subuniverses (CORS Remark 2.35). *) Definition merely_path_is0connected `{Univalence} (A : Type) `{IsConnected 0 A} (x y : A) : merely (x = y). Proof. (** This follows immediately from [isconnected_paths] above. *) rapply center. Defined. Definition is0connected_merely_allpath `{Univalence} (A : Type) `{merely A} (p : forall (x y:A), merely (x = y)) : IsConnected 0 A. Proof. strip_truncations. apply contr_inhabited_hprop. - apply hprop_allpath; intros z w. strip_truncations. exact (equiv_path_Tr z w (p z w)). - apply tr; assumption. Defined. (** The path component of a point [x : X] is connected. *) Global Instance is0connected_component {X : Type} (x : X) : IsConnected 0 { z : X & merely (z = x) }. Proof. apply (Build_Contr _ (tr (x; tr idpath))). rapply Trunc_ind; intros [Z p]. strip_truncations. apply (ap tr). rapply path_sigma_hprop. exact p^. Defined. (** Any two points in a path component are merely equal. This follows from [merely_path_is0connected], but this proof doesn't need univalence. *) Definition merely_path_component {X : Type} {x : X} (z1 z2 : { z : X & merely (z = x) }) : merely (z1 = z2). Proof. destruct z1 as [z1 p1], z2 as [z2 p2]. strip_truncations. apply tr. apply path_sigma_hprop; cbn. exact (p1 @ p2^). Defined. (** The path component of a point [x : X] is equivalent to the image of the constant map [Unit -> X] at [x]. *) Definition equiv_component_image_unit {X : Type} (x : X) : { z : X & merely (z = x) } <~> image (Tr (-1)) (unit_name x). Proof. unfold image; simpl. apply equiv_functor_sigma_id; intros z; simpl. apply Trunc_functor_equiv; unfold hfiber. refine ((equiv_contr_sigma _)^-1 oE _). apply equiv_path_inverse. Defined. (** 0-connected types are indecomposable *) Global Instance indecomposable_0connected `{Univalence} (X : Type) `{IsConnected 0 X} : Indecomposable X. Proof. assert (IsConnected (-1) X) by refine (isconnected_pred (-1) X). constructor. - intros A B f. assert (z := center (merely X) : merely X); generalize z. refine (Trunc_rec _). + apply ishprop_sum; try exact _. intros l r. strip_truncations. exact (not_is_inl_and_inr' (f z) (l z) (r z)). + intros x. remember (f x) as y eqn:p. destruct y as [a|b]; [ left | right ]; intros x'. all:assert (q := merely_path_is0connected X x x'); strip_truncations. all:refine (transport _ (ap f q) _). all:exact (transport _ p^ tt). - intros nx. apply (Trunc_rec (n := -1) nx). exact (center (merely X)). Defined. (* Truncation preserves connectedness. Note that this is for different levels. *) Global Instance isconnected_trunc {X : Type} (n m : trunc_index) `{IsConnected n X} : IsConnected n (Tr m X). Proof. unfold IsConnected. srapply (contr_equiv' _ (Trunc_swap n m X)^-1). Defined. Section Wedge_Incl_Conn. (** ** Connectivity of the wedge into the product. A very useful form of the key lemma [istrunc_extension_along_conn] is the connectivity of the wedge into the product, for a pair of pointed spaces. In fact this can be formulated without mentioning the wedge per se (so, without requiring HIT’s), since the statement only needs to talk about maps out of the wedge. Once again, we believe that the type of the conclusion is an hprop (though we do not prove it) — essentially because it is wrapping up an elimination principle and its corresponding computation rule — and so we make the proof of this result opaque. *) Context `{Univalence} {m n : trunc_index} {A : Type} (a0 : A) `{IsConnected m.+1 A} {B : Type} (b0 : B) `{IsConnected n.+1 B} (P : A -> B -> Type) {HP : forall a b, IsTrunc (m +2+ n) (P a b)} (f_a0 : forall b:B, P a0 b) (f_b0 : forall a:A, P a b0) (f_a0b0 : f_a0 b0 = f_b0 a0). Corollary isconn_wedge_incl : { f : forall a b, P a b & { e_a0 : forall b, f a0 b = f_a0 b & { e_b0 : forall a, f a b0 = f_b0 a & e_b0 a0 = (e_a0 b0) @ f_a0b0 }}}. Proof. assert (goal_as_extension : ExtensionAlong (unit_name a0) (fun a => ExtensionAlong (unit_name b0) (P a) (unit_name (f_b0 a))) (unit_name (f_a0 ; (unit_name f_a0b0)))). - apply (extension_conn_map_elim m). + apply (conn_point_incl a0). + intros a. apply (istrunc_extension_along_conn (n := n)). * apply (conn_point_incl b0). * apply HP. - destruct goal_as_extension as [f_eb name_ea_eab]. assert (ea_eab := name_ea_eab tt); clear name_ea_eab. exists (fun a => pr1 (f_eb a)). exists (fun b => apD10 (ea_eab ..1) b). exists (fun a => pr2 (f_eb a) tt). (* The last component is essentially (g' ..2), wrapped in a bit of path-algebra. *) apply moveL_Mp. apply (concatR (apD10 (ea_eab ..2) tt)). set (ea := ea_eab ..1). generalize ea; simpl. clear ea_eab ea. intros. rewrite transport_arrow. rewrite transport_const. rewrite transport_paths_Fl. exact 1%path. Qed. (** It is easier to apply the above result with its components separated. *) Definition wedge_incl_elim : forall a b, P a b := isconn_wedge_incl.1. Definition wedge_incl_comp1 : forall b, wedge_incl_elim a0 b = f_a0 b := isconn_wedge_incl.2.1. Definition wedge_incl_comp2 : forall a, wedge_incl_elim a b0 = f_b0 a := isconn_wedge_incl.2.2.1. Definition wedge_incl_comp3 : wedge_incl_comp2 a0 = (wedge_incl_comp1 b0) @ f_a0b0 := isconn_wedge_incl.2.2.2. End Wedge_Incl_Conn. Definition wedge_incl_elim_uncurried `{Univalence} {m n : trunc_index} {A : Type} (a0 : A) `{IsConnected m.+1 A} {B : Type} (b0 : B) `{IsConnected n.+1 B} (P : A -> B -> Type) {HP : forall a b, IsTrunc (m +2+ n) (P a b)} (fs : {f_a0 : forall b:B, P a0 b & { f_b0 : forall a:A, P a b0 & f_a0 b0 = f_b0 a0 }}) : forall (a : A) (b : B), P a b. Proof. destruct fs as [f_a0 [f_b0 f_a0b0]]. refine (wedge_incl_elim _ _ _ _ _ f_a0b0). Defined. Coq-HoTT-9.0/theories/Truncations/Core.v000066400000000000000000000367161474641544500201650ustar00rootroot00000000000000Require Import Basics Types WildCat.Core WildCat.Universe HFiber. Require Import Modalities.Modality. (** Users of this file almost always want to be able to write [Tr n] for both a [Modality] and a [ReflectiveSubuniverse], so they want the coercion [modality_to_reflective_subuniverse]: *) Require Export (coercions) Modalities.Modality. (** * Truncations of types *) Local Open Scope path_scope. Generalizable Variables A X n. (** ** The definition *) (** The definition of [Trunc n], the n-truncation of a type. If Coq supported higher inductive types natively, we would construct this as something like: Inductive Trunc n (A : Type) : Type := | tr : A -> Trunc n A | istrunc_truncation : forall (f : Sphere n.+1 -> Trunc n A) (x : Sphere n.+1), f x = f North. However, while we are faking our higher-inductives anyway, we can take some shortcuts, rather than translating the definition above. Firstly, we directly posit a “constructor” giving truncatedness, rather than rephrasing it in terms of maps of spheres. Secondly, we omit the “computation rule” for this constructor, since it is implied by truncatedness of the result type (and, for essentially that reason, is never wanted in practice anyway). *) Module Export Trunc. Cumulative Private Inductive Trunc (n : trunc_index) (A :Type) : Type := tr : A -> Trunc n A. Arguments tr {n A} a. (** Without explicit universe parameters, this instance is insufficiently polymorphic. *) Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i}) : IsTrunc@{j} n (Trunc@{i} n A). Admitted. Definition Trunc_ind {n A} (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)} : (forall a, P (tr a)) -> (forall aa, P aa) := fun f aa => match aa with tr a => fun _ => f a end Pt. End Trunc. (** The non-dependent version of the eliminator. *) Definition Trunc_rec {n A X} `{IsTrunc n X} : (A -> X) -> (Trunc n A -> X) := Trunc_ind (fun _ => X). Definition Trunc_rec_tr n {A : Type} : Trunc_rec (A:=A) (tr (n:=n)) == idmap := Trunc_ind _ (fun a => idpath). (** ** [Trunc] is a modality *) Definition Tr (n : trunc_index) : Modality. Proof. srapply (Build_Modality (fun A => IsTrunc n A)); cbn. - intros A B ? f ?; rapply (istrunc_isequiv_istrunc A f). - exact (Trunc n). - intros; apply istrunc_truncation. - intros A; apply tr. - intros A B ? f oa; cbn in *. exact (Trunc_ind B f oa). - intros; reflexivity. - exact (@istrunc_paths' n). Defined. (** We don't usually declare modalities as coercions, but this particular one is convenient so that lemmas about (for instance) connected maps can be applied to truncation modalities without the user/reader needing to be (particularly) aware of the general notion of modality. *) Coercion Tr : trunc_index >-> Modality. (** However, if the coercion is not printed, then we get things like [Tr (-1) X] being printed as [(-1) X], which is terribly confusing. So we tell Coq to always print this coercion. This does mean that although the user can type things like [IsConnected n X], it will always be displayed back as [IsConnected (Tr n) X]. *) Add Printing Coercion Tr. Section TruncationModality. Context (n : trunc_index). Definition trunc_iff_isequiv_truncation (A : Type) : IsTrunc n A <-> IsEquiv (@tr n A) := inO_iff_isequiv_to_O (Tr n) A. Global Instance isequiv_tr A `{IsTrunc n A} : IsEquiv (@tr n A) := fst (trunc_iff_isequiv_truncation A) _. Definition equiv_tr (A : Type) `{IsTrunc n A} : A <~> Tr n A := Build_Equiv _ _ (@tr n A) _. Definition untrunc_istrunc {A : Type} `{IsTrunc n A} : Tr n A -> A := (@tr n A)^-1. (** ** Functoriality *) (** Since a modality lives on a single universe, by default if we simply define [Trunc_functor] to be [O_functor] then it would force [X] and [Y] to live in the same universe. But since we defined [Trunc] as a cumulative inductive, if we add universe annotations we can make [Trunc_functor] more universe-polymorphic than [O_functor] is. This is sometimes useful. *) Definition Trunc_functor@{i j k | i <= k, j <= k} {X : Type@{i}} {Y : Type@{j}} (f : X -> Y) : Tr@{i} n X -> Tr@{j} n Y := O_functor@{k k k} (Tr n) f. Global Instance is0functor_Tr : Is0Functor (Tr n) := Build_Is0Functor _ _ _ _ (Tr n) (@Trunc_functor). Global Instance Trunc_functor_isequiv {X Y : Type} (f : X -> Y) `{IsEquiv _ _ f} : IsEquiv (Trunc_functor f) := isequiv_O_functor (Tr n) f. Definition Trunc_functor_equiv {X Y : Type} (f : X <~> Y) : Tr n X <~> Tr n Y := equiv_O_functor (Tr n) f. Definition Trunc_functor_compose {X Y Z} (f : X -> Y) (g : Y -> Z) : Trunc_functor (g o f) == Trunc_functor g o Trunc_functor f := O_functor_compose (Tr n) f g. Definition Trunc_functor_idmap (X : Type) : @Trunc_functor X X idmap == idmap := O_functor_idmap (Tr n) X. Definition equiv_Trunc_prod_cmp {X Y} : Tr n (X * Y) <~> Tr n X * Tr n Y := equiv_O_prod_cmp (Tr n) X Y. Global Instance is1functor_Tr : Is1Functor (Tr n). Proof. apply Build_Is1Functor. - apply @O_functor_homotopy. - apply @Trunc_functor_idmap. - apply @Trunc_functor_compose. Defined. End TruncationModality. (** We have to teach Coq to translate back and forth between [IsTrunc n] and [In (Tr n)]. *) Global Instance inO_tr_istrunc {n : trunc_index} (A : Type) `{IsTrunc n A} : In (Tr n) A. Proof. assumption. Defined. (** Having both of these as [Instance]s would cause infinite loops. *) Definition istrunc_inO_tr {n : trunc_index} (A : Type) `{In (Tr n) A} : IsTrunc n A. Proof. assumption. Defined. (** Instead, we make the latter an immediate instance, but with high cost (i.e. low priority) so that it doesn't override the ordinary lemmas about truncation. Unfortunately, [Hint Immediate] doesn't allow specifying a cost, so we use [Hint Extern] instead. *) (** Hint Immediate istrunc_inO_tr : typeclass_instances. *) (** See https://github.com/coq/coq/issues/11697 *) #[export] Hint Extern 1000 (IsTrunc _ _) => simple apply istrunc_inO_tr; solve [ trivial ] : typeclass_instances. (** This doesn't seem to be quite the same as [Hint Immediate] with a different cost either, though. *) (** Unfortunately, this isn't perfect; Coq still can't always find [In n] hypotheses in the context when it wants [IsTrunc]. You can always apply [istrunc_inO_tr] explicitly, but sometimes it also works to just [pose] it into the context. *) (** We do the same for [IsTruncMap n] and [MapIn (Tr n)]. *) Global Instance mapinO_tr_istruncmap {n : trunc_index} {A B : Type} (f : A -> B) `{IsTruncMap n A B f} : MapIn (Tr n) f. Proof. assumption. Defined. Definition istruncmap_mapinO_tr {n : trunc_index} {A B : Type} (f : A -> B) `{MapIn (Tr n) _ _ f} : IsTruncMap n f. Proof. assumption. Defined. #[export] Hint Immediate istruncmap_mapinO_tr : typeclass_instances. (** ** A few special things about the (-2)-truncation *) (** The type of contractible types is contractible. *) Definition contr_tr_minus_two@{u su | u < su} `{Univalence} : Contr (Type_@{u su} (Tr (-2))). Proof. apply (Build_Contr _ (exist@{su su} _ (Unit : Type@{u}) (inO_tr_istrunc _))). intros [C ContrC]. apply equiv_path_sigma_hprop. apply path_universe_uncurried. symmetry; apply equiv_contr_unit. Defined. (** ** A few special things about the (-1)-truncation *) Local Open Scope trunc_scope. (** We define [merely A] to be an inhabitant of the universe [hProp] of hprops, rather than a type. We can always treat it as a type because there is a coercion, but this means that if we need an element of [hProp] then we don't need a separate name for it. *) Definition merely (A : Type@{i}) : HProp@{i} := Build_HProp (Tr (-1) A). Definition hexists {X} (P : X -> Type) : HProp := merely (sig P). Definition hor (P Q : Type) : HProp := merely (P + Q). Declare Scope hprop_scope. Notation "A \/ B" := (hor A B) : hprop_scope. Definition himage {X Y} (f : X -> Y) := image (Tr (-1)) f. Definition contr_inhab_prop {A} `{IsHProp A} (ma : merely A) : Contr A. Proof. refine (@contr_trunc_conn (Tr (-1)) A _ _); try assumption. refine (contr_inhabited_hprop _ ma). Defined. (** A stable type is logically equivalent to its (-1)-truncation. (It follows that this is true for decidable types as well.) *) Definition merely_inhabited_iff_inhabited_stable {A} {A_stable : Stable A} : Tr (-1) A <-> A. Proof. refine (_, tr). intro ma. apply stable; intro na. revert ma; rapply Trunc_ind; exact na. Defined. (** ** Surjections *) (** Surjections are the (-1)-connected maps, but they can be characterized more simply since an inhabited hprop is automatically contractible. *) Notation IsSurjection := (IsConnMap (Tr (-1))). Definition BuildIsSurjection {A B} (f : A -> B) : (forall b, merely (hfiber f b)) -> IsSurjection f. Proof. intros H b; refine (contr_inhabited_hprop _ _). apply H. Defined. (** A family of types is pointwise merely inhabited if and only if the corresponding fibration is surjective. *) Lemma iff_merely_issurjection {X : Type} (P : X -> Type) : (forall x, merely (P x)) <-> IsSurjection (pr1 : {x : X & P x} -> X). Proof. refine (iff_compose _ (iff_forall_inO_mapinO_pr1 (Conn _) P)). apply iff_functor_forall; intro a. symmetry; apply (iff_contr_hprop (Tr (-1) (P a))). Defined. Lemma equiv_merely_issurjection `{Funext} {X : Type} (P : X -> Type) : (forall x, merely (P x)) <~> IsSurjection (pr1 : {x : X & P x} -> X). Proof. (* Can also be proved from equiv_forall_inO_mapinO_pr1. *) exact (equiv_iff_hprop_uncurried (iff_merely_issurjection P)). Defined. (** Surjections cancel on the right *) Lemma cancelR_issurjection {A B C : Type} (f : A -> B) (g : B -> C) (isconn : IsSurjection (g o f)) : IsSurjection g. Proof. intro c. rapply contr_inhabited_hprop. rapply (Trunc_functor _ (X:= (hfiber (g o f) c))). - intros [a p]. exact (f a; p). - apply center, isconn. Defined. (** Retractions are surjective. *) Definition issurj_retr {X Y : Type} {r : X -> Y} (s : Y -> X) (h : forall y:Y, r (s y) = y) : IsSurjection r. Proof. intro y. rapply contr_inhabited_hprop. exact (tr (s y; h y)). Defined. (** ** Embeddings *) (** For any point in the image of an embedding, the fibers are contractable. *) Global Instance contr_hfiber_emb {A B} (a : A) (f : A -> B) `{IsEmbedding f} : Contr (hfiber f (f a)). Proof. srapply contr_inhabited_hprop. exact (a; idpath (f a)). Defined. (** Since embeddings are the (-1)-truncated maps, a map that is both a surjection and an embedding is an equivalence. *) Definition isequiv_surj_emb {A B} (f : A -> B) `{IsSurjection f} `{IsEmbedding f} : IsEquiv f. Proof. apply (@isequiv_conn_ino_map (Tr (-1))); assumption. Defined. (** As a corollary, it follows that if [i o f] is an equivalence and [i] is an embedding, then [f] is an equivalence. *) Definition isequiv_isequiv_compose_embedding {X Y Z : Type} {f : X -> Y} (i : Y -> Z) `{IsEmbedding i} `{!IsEquiv (i o f)} : IsEquiv f. Proof. rapply (cancelL_isequiv i). refine (isequiv_surj_emb i). rapply (cancelR_issurjection f). Defined. (** If [X] is a set and [f : Y -> Z] is a surjection, then [- o f] is an embedding. *) Definition isembedding_precompose_surjection_hset `{Funext} {X Y Z : Type} `{IsHSet X} (f : Y -> Z) `{IsSurjection f} : IsEmbedding (fun phi : Z -> X => phi o f). Proof. intros phi; apply istrunc_S. intros g0 g1; cbn. rapply contr_inhabited_hprop. apply path_sigma_hprop, equiv_path_arrow. rapply conn_map_elim; intro y. exact (ap10 (g0.2 @ g1.2^) y). Defined. (** We next prove that [paths : X -> (X -> Type)] is an embedding. This was proved by Escardo as Lemma 15 in "Injective types in univalent mathematics", but we give an argument similar to the proof of Thm 2.25 of CORS. *) (** This will be an inverse to [ap paths]. We'll want to show that it is an embedding, so we'll construct it out of pieces that are clearly equivalences, except for one step, [equiv_fun]. *) Definition ap_paths_inverse `{Univalence} {X : Type} (x1 x2 : X) : paths x1 = paths x2 -> x1 = x2. Proof. refine (_ o @equiv_ap10 _ X Type (paths x1) (paths x2)). refine (_ o equiv_functor_forall_id (fun y => equiv_equiv_path (x1 = y) (x2 = y))). refine (_ o functor_forall_id (fun y => @equiv_fun (x1 = y) (x2 = y))). refine (_ o (equiv_paths_ind x1 (fun y p => x2 = y))^-1%equiv). exact (equiv_path_inverse x2 x1). Defined. (** A Yoneda-like embedding for path types: [paths : X -> (X -> Type)] is an embedding. *) Definition isembedding_paths `{Univalence} {X : Type@{u}} : IsEmbedding (@paths X). Proof. (* To show that [paths] is an embedding, it suffices to show that [ap paths : x1 = x2 -> (paths x1) = (paths x2)] is an equivalence. *) snrapply isembedding_isequiv_ap. intros x1 x2. (* And for that, it suffices to show that [i o (ap paths)] is an equivalence for a well-chosen embedding [i]. *) snrapply (isequiv_isequiv_compose_embedding (ap_paths_inverse x1 x2)). - (* [ap_paths_inverse x1 x2] is an embedding since it is a composite of four equivalences and one embedding. We can group these into three parts. *) unfold ap_paths_inverse. nrefine (mapinO_compose (O:=Tr (-1)) _ (equiv_path_inverse x2 x1 oE _)). 2: exact _. (* The second part is an equivalence, so it's an embedding. *) nrefine (mapinO_compose _ (functor_forall_id _)). 1: exact _. (* The first part is an equivalence, so it's an embedding. *) rapply mapinO_functor_forall_id. intro y. apply isembedding_equiv_fun. - (* The composite is an equivalence because it is homotopic to the identity. *) simpl. srapply (isequiv_homotopic idmap). intros []. reflexivity. Defined. (** ** Tactic to remove truncations in hypotheses if possible *) Ltac strip_truncations := (** search for truncated hypotheses *) progress repeat match goal with | [ T : _ |- _ ] => revert_opaque T; refine (@Trunc_ind _ _ _ _ _); (** ensure that we didn't generate more than one subgoal, i.e. that the goal was appropriately truncated *) []; intro T end. (** See [strip_reflections] and [strip_modalities] for generalizations to other reflective subuniverses and modalities. We provide this version because it sometimes needs fewer universes (due to the cumulativity of [Trunc]). However, that same cumulativity sometimes causes free universe variables. For a hypothesis of type [Trunc@{i} X], we can use [Trunc_ind@{i j}], but sometimes Coq uses [Trunc_ind@{k j}] with [i <= k] and [k] otherwise free. In these cases, [strip_reflections] and/or [strip_modalities] may generate fewer universe variables. *) (** ** Iterated truncations *) (** Compare to [O_leq_Tr] and [O_strong_leq_Tr] in SeparatedTrunc.v. *) Definition O_leq_Tr_leq {n m : trunc_index} (Hmn : m <= n) : O_leq (Tr m) (Tr n). Proof. intros A; rapply istrunc_leq. Defined. Definition Trunc_min n m X : Tr (trunc_index_min n m) X <~> Tr n (Tr m X). Proof. destruct (trunc_index_min_path n m) as [p|q]. + assert (l := trunc_index_min_leq_right n m). destruct p^; clear p. snrapply (Build_Equiv _ _ (Trunc_functor _ tr)). nrapply O_inverts_conn_map. rapply (conn_map_O_leq _ (Tr m)). rapply O_leq_Tr_leq. + assert (l := trunc_index_min_leq_left n m). destruct q^; clear q. srapply equiv_tr. srapply istrunc_leq. Defined. Definition Trunc_swap n m X : Tr n (Tr m X) <~> Tr m (Tr n X). Proof. refine (Trunc_min m n _ oE equiv_transport (fun k => Tr k _) _ oE (Trunc_min n m _)^-1). apply trunc_index_min_swap. Defined. (** If you are looking for a theorem about truncation, you may want to read the note "Finding Theorems" in "STYLE.md". *) Coq-HoTT-9.0/theories/Truncations/SeparatedTrunc.v000066400000000000000000000027301474641544500222060ustar00rootroot00000000000000Require Import Basics Types. Require Import TruncType. Require Import Truncations.Core Modalities.Modality Modalities.Descent. (** ** Separatedness and path-spaces of truncations *) Section SeparatedTrunc. Local Open Scope subuniverse_scope. (** The [n.+1]-truncation modality consists of the separated types for the [n]-truncation modality. *) Global Instance O_eq_Tr (n : trunc_index) : Tr n.+1 <=> Sep (Tr n). Proof. split; intros A A_inO. - intros x y; exact _. - rapply istrunc_S. Defined. (** It follows that [Tr n <<< Tr n.+1]. However, it is easier to prove this directly than to go through separatedness. *) Global Instance O_leq_Tr (n : trunc_index) : Tr n <= Tr n.+1. Proof. intros A ?; exact _. Defined. Global Instance O_strong_leq_Tr (n : trunc_index) : Tr n << Tr n.+1. Proof. srapply O_strong_leq_trans_l. Defined. (** For some reason, this causes typeclass search to spin. *) Local Instance O_lex_leq_Tr `{Univalence} (n : trunc_index) : Tr n <<< Tr n.+1. Proof. intros A; unshelve econstructor; intros P' P_inO; pose (P := fun x => Build_TruncType n (P' x)). - refine (Trunc_rec P). - intros; simpl; exact _. - intros; cbn. reflexivity. Defined. Definition path_Tr {n A} {x y : A} : Tr n (x = y) -> (tr x = tr y :> Tr n.+1 A) := path_OO (Tr n.+1) (Tr n) x y. Definition equiv_path_Tr `{Univalence} {n} {A : Type} (x y : A) : Tr n (x = y) <~> (tr x = tr y :> Tr n.+1 A) := equiv_path_OO (Tr n.+1) (Tr n) x y. End SeparatedTrunc. Coq-HoTT-9.0/theories/Types.v000066400000000000000000000005541474641544500160570ustar00rootroot00000000000000Require Export Types.Unit. Require Export Types.Empty. Require Export Types.Paths. Require Export Types.Prod. Require Export Types.Forall. Require Export Types.Arrow. Require Export Types.Sigma. Require Export Types.Equiv. Require Export Types.Universe. Require Export Types.Bool. Require Export Types.Sum. Require Export Types.WType. Require Export Types.IWType. Coq-HoTT-9.0/theories/Types/000077500000000000000000000000001474641544500156645ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Types/Arrow.v000066400000000000000000000240271474641544500171520ustar00rootroot00000000000000(** * Theorems about Non-dependent function types *) Require Import Basics.Overture Basics.PathGroupoids Basics.Decidable Basics.Equivalences Basics.Trunc Basics.Tactics Basics.Iff. Require Import Types.Forall. Local Open Scope path_scope. Local Set Universe Minimization ToSet. Generalizable Variables A B C D f g n. Definition arrow@{u u0} (A : Type@{u}) (B : Type@{u0}) := A -> B. #[export] Instance IsReflexive_arrow : Reflexive arrow := fun _ => idmap. #[export] Instance IsTransitive_arrow : Transitive arrow := fun _ _ _ f g => compose g f. Section AssumeFunext. Context `{Funext}. (** ** Paths *) (** As for dependent functions, paths [p : f = g] in a function type [A -> B] are equivalent to functions taking values in path types, [H : forall x:A, f x = g x], or concisely [H : f == g]. These are all given in the [Overture], but we can give them separate names for clarity in the non-dependent case. *) Definition path_arrow {A B : Type} (f g : A -> B) : (f == g) -> (f = g) := path_forall f g. (** There are a number of combinations of dependent and non-dependent for [apD10_path_forall]; we list all of the combinations as helpful lemmas for rewriting. *) Definition ap10_path_arrow {A B : Type} (f g : A -> B) (h : f == g) : ap10 (path_arrow f g h) == h := apD10_path_forall f g h. Definition apD10_path_arrow {A B : Type} (f g : A -> B) (h : f == g) : apD10 (path_arrow f g h) == h := apD10_path_forall f g h. Definition ap10_path_forall {A B : Type} (f g : A -> B) (h : f == g) : ap10 (path_forall f g h) == h := apD10_path_forall f g h. Definition eta_path_arrow {A B : Type} (f g : A -> B) (p : f = g) : path_arrow f g (ap10 p) = p := eta_path_forall f g p. Definition path_arrow_1 {A B : Type} (f : A -> B) : (path_arrow f f (fun x => 1)) = 1 := eta_path_arrow f f 1. Definition equiv_ap10 {A B : Type} f g : (f = g) <~> (f == g) := Build_Equiv _ _ (@ap10 A B f g) _. Global Instance isequiv_path_arrow {A B : Type} (f g : A -> B) : IsEquiv (path_arrow f g) | 0 := isequiv_path_forall f g. Definition equiv_path_arrow {A B : Type} (f g : A -> B) : (f == g) <~> (f = g) := equiv_path_forall f g. (** Function extensionality for two-variable functions *) Definition equiv_path_arrow2 {X Y Z: Type} (f g : X -> Y -> Z) : (forall x y, f x y = g x y) <~> f = g. Proof. refine (equiv_path_arrow _ _ oE _). apply equiv_functor_forall_id; intro x. apply equiv_path_arrow. Defined. Definition ap100_path_arrow2 {X Y Z : Type} {f g : X -> Y -> Z} (h : forall x y, f x y = g x y) (x : X) (y : Y) : ap100 (equiv_path_arrow2 f g h) x y = h x y. Proof. unfold ap100. refine (ap (fun p => ap10 p y) _ @ _). 1: apply apD10_path_arrow. cbn. apply apD10_path_arrow. Defined. (** ** Path algebra *) Definition path_arrow_pp {A B : Type} (f g h : A -> B) (p : f == g) (q : g == h) : path_arrow f h (fun x => p x @ q x) = path_arrow f g p @ path_arrow g h q := path_forall_pp f g h p q. (** ** Transport *) (** Transporting in non-dependent function types is somewhat simpler than in dependent ones. *) Definition transport_arrow {A : Type} {B C : A -> Type} {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C x1) (y : B x2) : (transport (fun x => B x -> C x) p f) y = p # (f (p^ # y)). Proof. destruct p; simpl; auto. Defined. (** This is an improvement to [transport_arrow]. That result only shows that the functions are homotopic, but even without funext, we can prove that these functions are equal. *) Definition transport_arrow' {A : Type} {B C : A -> Type} {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C x1) : transport (fun x => B x -> C x) p f = transport _ p o f o transport _ p^. Proof. destruct p; auto. Defined. Definition transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) (y : B x2) : (transport (fun x => B x -> C) p f) y = f (p^ # y). Proof. destruct p; simpl; auto. Defined. (** This is an improvement to [transport_arrow_toconst]. That result shows that the functions are homotopic, but even without funext, we can prove that these functions are equal. *) Definition transport_arrow_toconst' {A : Type} {B : A -> Type} {C : Type} {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) : transport (fun x => B x -> C) p f = f o transport B p^. Proof. destruct p; auto. Defined. Definition transport_arrow_fromconst {A B : Type} {C : A -> Type} {x1 x2 : A} (p : x1 = x2) (f : B -> C x1) (y : B) : (transport (fun x => B -> C x) p f) y = p # (f y). Proof. destruct p; simpl; auto. Defined. (** And some naturality and coherence for these laws. *) Definition ap_transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) {y1 y2 : B x2} (q : y1 = y2) : ap (transport (fun x => B x -> C) p f) q @ transport_arrow_toconst p f y2 = transport_arrow_toconst p f y1 @ ap (fun y => f (p^ # y)) q. Proof. destruct p, q; reflexivity. Defined. (** ** Dependent paths *) (** Usually, a dependent path over [p:x1=x2] in [P:A->Type] between [y1:P x1] and [y2:P x2] is a path [transport P p y1 = y2] in [P x2]. However, when [P] is a function space, these dependent paths have a more convenient description: rather than transporting the argument of [y1] forwards and backwards, we transport only forwards but on both sides of the equation, yielding a "naturality square". *) Definition dpath_arrow {A:Type} (B C : A -> Type) {x1 x2:A} (p:x1=x2) (f : B x1 -> C x1) (g : B x2 -> C x2) : (forall (y1:B x1), transport C p (f y1) = g (transport B p y1)) <~> (transport (fun x => B x -> C x) p f = g). Proof. destruct p. apply equiv_path_arrow. Defined. Definition ap10_dpath_arrow {A : Type} (B C : A -> Type) {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C x1) (g : B x2 -> C x2) (h : forall (y1 : B x1), transport C p (f y1) = g (transport B p y1)) (u : B x1) : ap10 (dpath_arrow B C p f g h) (p # u) = transport_arrow p f (p # u) @ ap (fun x => p # (f x)) (transport_Vp B p u) @ h u. Proof. destruct p; simpl; unfold ap10. exact (apD10_path_forall f g h u @ (concat_1p _)^). Defined. (** ** Maps on paths *) (** The action of maps given by application. *) Definition ap_apply_l {A B : Type} {x y : A -> B} (p : x = y) (z : A) : ap (fun f => f z) p = ap10 p z := 1. Definition ap_apply_Fl {A B C : Type} {x y : A} (p : x = y) (M : A -> B -> C) (z : B) : ap (fun a => (M a) z) p = ap10 (ap M p) z := match p with 1 => 1 end. Definition ap_apply_Fr {A B C : Type} {x y : A} (p : x = y) (z : B -> C) (N : A -> B) : ap (fun a => z (N a)) p = ap01 z (ap N p) := (ap_compose N _ _). Definition ap_apply_FlFr {A B C : Type} {x y : A} (p : x = y) (M : A -> B -> C) (N : A -> B) : ap (fun a => (M a) (N a)) p = ap11 (ap M p) (ap N p) := match p with 1 => 1 end. (** The action of maps given by lambda. *) Definition ap_lambda {A B C : Type} {x y : A} (p : x = y) (M : A -> B -> C) : ap (fun a b => M a b) p = path_arrow _ _ (fun b => ap (fun a => M a b) p). Proof. destruct p; symmetry; simpl; apply path_arrow_1. Defined. (** The action of pre/post-composition on a path between functions. See also [ap10_ap_precompose] and [ap10_ap_postcompose] in PathGroupoids.v and [ap_precomposeD] in Forall.v. *) Definition ap_precompose {B P Q : Type} {f g : Q -> P} (h : f = g) (i : B -> Q) : ap (fun (k : Q -> P) => k o i) h = path_arrow (f o i) (g o i) (ap10 h o i) := ap_lambdaD _ _. Definition ap_postcompose {B P Q : Type} {f g : Q -> P} (h : f = g) (j : P -> B) : ap (fun (k : Q -> P) => j o k) h = path_arrow (j o f) (j o g ) (fun q => ap j (ap10 h q)). Proof. destruct h; cbn. symmetry; apply path_forall_1. Defined. (** ** Functorial action *) Definition functor_arrow `(f : B -> A) `(g : C -> D) : (A -> C) -> (B -> D) := @functor_forall A (fun _ => C) B (fun _ => D) f (fun _ => g). Definition not_contrapositive `(f : B -> A) : not A -> not B := functor_arrow f idmap. Definition iff_not@{u v k | u <= k, v <= k} (A : Type@{u}) (B : Type@{v}) : A <-> B -> iff@{u v k} (~A) (~B). Proof. intros e; split; apply not_contrapositive@{_ k}, e. Defined. Definition ap_functor_arrow `(f : B -> A) `(g : C -> D) (h h' : A -> C) (p : h == h') : ap (functor_arrow f g) (path_arrow _ _ p) = path_arrow _ _ (fun b => ap g (p (f b))) := @ap_functor_forall _ A (fun _ => C) B (fun _ => D) f (fun _ => g) h h' p. (** ** Truncatedness: functions into an n-type is an n-type *) Global Instance contr_arrow {A B : Type} `{Contr B} : Contr (A -> B) | 100 := contr_forall. Global Instance istrunc_arrow {A B : Type} `{IsTrunc n B} : IsTrunc n (A -> B) | 100 := istrunc_forall. (** ** Functions from a contractible type *) (** This also follows from [equiv_contr_forall], but this proof has a better inverse map. *) Definition equiv_arrow_from_contr (A B : Type) `{Contr A} : (A -> B) <~> B. Proof. srapply (equiv_adjointify (fun f => f (center A)) const). - reflexivity. - intro f; funext a; unfold const; simpl. apply (ap f), contr. Defined. (** ** Equivalences *) Global Instance isequiv_functor_arrow `{IsEquiv B A f} `{IsEquiv C D g} : IsEquiv (functor_arrow f g) | 1000 := @isequiv_functor_forall _ A (fun _ => C) B (fun _ => D) _ _ _ _. Definition equiv_functor_arrow `{IsEquiv B A f} `{IsEquiv C D g} : (A -> C) <~> (B -> D) := @equiv_functor_forall _ A (fun _ => C) B (fun _ => D) f _ (fun _ => g) _. Definition equiv_functor_arrow' `(f : B <~> A) `(g : C <~> D) : (A -> C) <~> (B -> D) := @equiv_functor_forall' _ A (fun _ => C) B (fun _ => D) f (fun _ => g). (* We could do something like this notation, but it's not clear that it would be that useful, and might be confusing. *) (* Notation "f -> g" := (equiv_functor_arrow' f g) : equiv_scope. *) End AssumeFunext. (** ** Decidability *) (** This doesn't require funext *) Global Instance decidable_arrow {A B : Type} `{Decidable A} `{Decidable B} : Decidable (A -> B). Proof. destruct (dec B) as [x2|y2]. - exact (inl (fun _ => x2)). - destruct (dec A) as [x1|y1]. + apply inr; intros f. exact (y2 (f x1)). + apply inl; intros x1. elim (y1 x1). Defined. Coq-HoTT-9.0/theories/Types/Bool.v000066400000000000000000000146631474641544500167600ustar00rootroot00000000000000(** * Theorems about the booleans *) Require Import HoTT.Basics. Require Import Types.Equiv. Local Open Scope path_scope. (* coq calls it "bool", we call it "Bool" *) Local Unset Elimination Schemes. Inductive Bool : Type0 := | true : Bool | false : Bool. Scheme Bool_ind := Induction for Bool Sort Type. Scheme Bool_rec := Minimality for Bool Sort Type. (* For compatibility with Coq's [induction] *) Definition Bool_rect := Bool_ind. Add Printing If Bool. Declare Scope bool_scope. Delimit Scope bool_scope with Bool. Bind Scope bool_scope with Bool. Definition andb (b1 b2 : Bool) : Bool := if b1 then b2 else false. Definition orb (b1 b2 : Bool) : Bool := if b1 then true else b2. Definition negb (b : Bool) := if b then false else true. Definition implb (b1 b2 : Bool) : Bool := if b1 then b2 else true. Infix "||" := orb : bool_scope. Infix "&&" := andb : bool_scope. Infix "->" := implb : bool_scope. Definition implb_true {b} : implb b true = true := if b as b return implb b true = true then idpath else idpath. Definition implb_impl {a b} : (a -> b)%Bool = true <-> (a = true -> b = true). Proof. destruct a; simpl; split; trivial using idpath with nocore; destruct b; simpl; auto using idpath with nocore. Defined. Global Instance trunc_if n A B `{IsTrunc n A, IsTrunc n B} (b : Bool) : IsTrunc n (if b then A else B) | 100 := if b as b return (IsTrunc n (if b then A else B)) then _ else _. (** ** Decidability *) Section BoolDecidable. Definition false_ne_true : ~ (false = true) := fun H => match H in (_ = y) return (if y return Set then Empty else Bool) with | 1%path => true end. Definition true_ne_false : ~ (true = false) := fun H => false_ne_true (symmetry _ _ H). Global Instance decidable_paths_bool : DecidablePaths Bool := fun x y => match x as x, y as y return ((x = y) + ~(x = y)) with | true, true => inl idpath | false, false => inl idpath | true, false => inr true_ne_false | false, true => inr false_ne_true end. Definition hset_bool : IsHSet Bool := _. End BoolDecidable. (** In particular, [negb] has no fixed points *) Definition not_fixed_negb (b : Bool) : negb b <> b := match b return negb b <> b with | true => false_ne_true | false => true_ne_false end. (** And conversely, if two elements of [Bool] are unequal, they must be related by [negb]. *) Definition negb_ne {b1 b2 : Bool} : (b1 <> b2) -> (b1 = negb b2). Proof. destruct b1, b2. - intros oops; case (oops idpath). - reflexivity. - reflexivity. - intros oops; case (oops idpath). Defined. (** This version of [negb_ne] is more convenient to [destruct] against. *) Definition negb_ne' {b1 b2 : Bool} : (b1 <> b2) -> (negb b1 = b2). Proof. intros oops. symmetry. apply negb_ne. exact (symmetric_neq oops). Defined. (** ** Products as [forall] over [Bool] *) Section BoolForall. Variable P : Bool -> Type. Let f (s : forall b, P b) := (s false, s true). Let g (u : P false * P true) (b : Bool) : P b := match b with | false => fst u | true => snd u end. Definition equiv_bool_forall_prod `{Funext} : (forall b, P b) <~> P false * P true. Proof. apply (equiv_adjointify f g); repeat (reflexivity || intros [] || intro || apply path_forall). Defined. End BoolForall. Definition equiv_bool_rec_uncurried `{Funext} (P : Type) : P * P <~> (Bool -> P) := (equiv_bool_forall_prod (fun _ => P))^-1%equiv. (** ** The type [Bool <~> Bool] is equivalent to [Bool]. *) (** The nonidentity equivalence is negation (the flip). *) Global Instance isequiv_negb : IsEquiv negb. Proof. refine (@Build_IsEquiv _ _ negb negb (fun b => if b as b return negb (negb b) = b then idpath else idpath) (fun b => if b as b return negb (negb b) = b then idpath else idpath) _). intros []; simpl; exact idpath. Defined. Definition equiv_negb : Bool <~> Bool := Build_Equiv Bool Bool negb _. (** Any equivalence [Bool <~> Bool] sends [true] and [false] to different things. *) Lemma eval_bool_isequiv (f : Bool -> Bool) `{IsEquiv Bool Bool f} : f false = negb (f true). Proof. pose proof (eissect f true). pose proof (eissect f false). simpl in *. destruct (f true), (f false). - etransitivity; try (eassumption || (symmetry; eassumption)). - simpl. reflexivity. - simpl. reflexivity. - etransitivity; try (eassumption || (symmetry; eassumption)). Defined. Section EquivBoolEquiv. (** We will identify the constant equivalence with [true] and the flip equivalence with [false], and do this by evaluating the equivalence function on [true]. *) Let f : (Bool <~> Bool) -> Bool := fun e => e true. Let g : Bool -> (Bool <~> Bool) := fun b => if b then (equiv_idmap Bool) else equiv_negb. Definition aut_bool_canonical (e : Bool <~> Bool) : e == g (f e). Proof. unfold f, g; clear f g; intros []; simpl. - destruct (e true); reflexivity. - refine (eval_bool_isequiv e @ _). destruct (e true); reflexivity. Defined. Lemma equiv_bool_aut_bool `{Funext} : Bool <~> (Bool <~> Bool). Proof. refine (equiv_adjointify g f _ _). - intro e. apply path_equiv, path_forall. intros b; symmetry; apply aut_bool_canonical. - intros []; reflexivity. Defined. (** It follows that every automorphism of [Bool] is either [idmap] or [negb]. *) Definition aut_bool_idmap_or_negb `{Funext} (e : Bool <~> Bool) : (e = equiv_idmap Bool) + (e = equiv_negb). Proof. revert e. equiv_intro equiv_bool_aut_bool e. destruct e; simpl. - exact (inl idpath). - exact (inr idpath). Defined. (** But, obviously, not both. *) Definition idmap_bool_ne_negb : equiv_idmap Bool <> equiv_negb. Proof. intros oops. exact (true_ne_false (ap10_equiv oops true)). Defined. (** In particular, every pair of automorphisms of [Bool] commute with each other. *) Definition abelian_aut_bool (e1 e2 : Bool <~> Bool) : e1 o e2 == e2 o e1. Proof. intro b. refine (ap e1 (aut_bool_canonical e2 b) @ _). refine (aut_bool_canonical e1 _ @ _). refine (_ @ ap e2 (aut_bool_canonical e1 b)^). refine (_ @ (aut_bool_canonical e2 _)^). unfold f, g. destruct (e1 true), (e2 true), b; reflexivity. Defined. End EquivBoolEquiv. Coq-HoTT-9.0/theories/Types/Empty.v000066400000000000000000000040571474641544500171570ustar00rootroot00000000000000(** * Theorems about the empty type *) Require Import Basics.Overture Basics.Equivalences Basics.Trunc. Local Set Universe Minimization ToSet. Local Open Scope path_scope. (** ** Unpacking *) (** ** Eta conversion *) (** ** Paths *) (** ** Transport *) (** ** Functorial action *) (** ** Equivalences *) (** ** Universal mapping properties *) Global Instance contr_from_Empty@{u} {_ : Funext} (A : Empty -> Type@{u}) : Contr@{u} (forall x:Empty, A x). Proof. refine (Build_Contr@{u} _ (Empty_ind A) _). intros f; apply path_forall@{Set u u}; intros x; elim x. Defined. Lemma Empty_rec {T : Type} (falso: Empty) : T. Proof. case falso. Defined. Global Instance isequiv_empty_rec@{u} `{Funext} (A : Type@{u}) : IsEquiv@{Set u} (fun (_ : Unit) => @Empty_rec A) | 0 := isequiv_adjointify@{Set u} _ (fun _ => tt) (fun f => path_forall@{Set u u} _ _ (fun x => Empty_rec x)) (fun x => match x with tt => idpath end). Definition equiv_empty_rec@{u} `{Funext} (A : Type@{u}) : Unit <~> ((Empty -> A) : Type@{u}) := (Build_Equiv@{Set u} _ _ (fun (_ : Unit) => @Empty_rec A) _). (** ** Behavior with respect to truncation *) Global Instance istrunc_Empty@{} (n : trunc_index) : IsTrunc n.+1 Empty. Proof. refine (@istrunc_leq (-1) n.+1 tt _ _). apply istrunc_S. intros []. Defined. Global Instance isequiv_all_to_empty (T : Type) (f : T -> Empty) : IsEquiv f. Proof. refine (Build_IsEquiv _ _ _ (Empty_ind (fun _ => T)) (* := equiv_inv *) (fun fals:Empty => match fals with end) (* : f o equiv_inv == idmap *) (fun t:T => match (f t) with end) (* : equiv_inv o f == idmap *) (_) (* adjointify part *) ). intro t. exact (Empty_rec (f t)). Defined. Definition equiv_to_empty {T : Type} (f : T -> Empty) : T <~> Empty := Build_Equiv T Empty f _. (** ** Paths *) (** We could probably prove some theorems about non-existing paths in [Empty], but this is really quite useless. As soon as an element of [Empty] is hypothesized, we can prove whatever we like with a simple elimination. *) Coq-HoTT-9.0/theories/Types/Equiv.v000066400000000000000000000222431474641544500171470ustar00rootroot00000000000000Require Import HoTT.Basics. Require Import Types.Sigma Types.Forall Types.Arrow Types.Paths. Local Open Scope path_scope. (** * Equivalences *) (** ** [IsEquiv f] is logically equivalent to [IsTruncMap (-2) f] *) Global Instance contr_map_isequiv {A B} (f : A -> B) `{IsEquiv _ _ f} : IsTruncMap (-2) f. Proof. intros b; refine (contr_equiv' {a : A & a = f^-1 b} _). apply equiv_functor_sigma_id; intros a. apply equiv_moveR_equiv_M. Defined. Definition isequiv_contr_map {A B} (f : A -> B) `{IsTruncMap (-2) A B f} : IsEquiv f. Proof. srapply Build_IsEquiv. - intros b; exact (center {a : A & f a = b}).1. - intros b. exact (center {a : A & f a = b}).2. - intros a. exact (@contr {x : A & f x = f a} _ (a;1))..1. - intros a; cbn. apply moveL_M1. lhs_V nrapply transport_paths_l. lhs_V nrapply transport_compose. exact ((@contr {x : A & f x = f a} _ (a;1))..2). Defined. (** As usual, we can't make both of these [Instances]. *) #[export] Hint Immediate isequiv_contr_map : typeclass_instances. (** It follows that when proving a map is an equivalence, we may assume its codomain is inhabited. *) Definition isequiv_inhab_codomain {A B} (f : A -> B) (feq : B -> IsEquiv f) : IsEquiv f. Proof. apply isequiv_contr_map. intros b. pose (feq b); exact _. Defined. (** If [functor_sigma idmap g] is an equivalence then so is g. *) Definition isequiv_from_functor_sigma {A} (P Q : A -> Type) (g : forall a, P a -> Q a) `{!IsEquiv (functor_sigma idmap g)} : forall (a : A), IsEquiv (g a). Proof. intros a; apply isequiv_contr_map. apply istruncmap_from_functor_sigma. exact _. Defined. (** Theorem 4.7.7: [functor_sigma idmap g] is an equivalence if and only if g is. *) Definition equiv_total_iff_equiv_fiberwise {A} (P Q : A -> Type) (g : forall a, P a -> Q a) : IsEquiv (functor_sigma idmap g) <-> forall a, IsEquiv (g a). Proof. split. - apply isequiv_from_functor_sigma. - intro K. apply isequiv_functor_sigma. Defined. (** ** Assuming [Funext], [IsEquiv f] is an hprop, which has further consequences *) Section AssumeFunext. Context `{Funext}. Global Instance contr_sect_equiv {A B} (f : A -> B) `{IsEquiv A B f} : Contr {g : B -> A & f o g == idmap}. Proof. refine (contr_change_center (f^-1 ; eisretr f)). refine (contr_equiv' { g : B -> A & f o g = idmap } _). (* Typeclass inference finds this contractible instance: it's the fiber over [idmap] of postcomposition with [f], and the latter is an equivalence since [f] is. *) apply equiv_functor_sigma_id; intros g. apply equiv_ap10. Defined. Global Instance contr_retr_equiv {A B} (f : A -> B) `{IsEquiv A B f} : Contr {g : B -> A & g o f == idmap}. Proof. refine (contr_change_center (f^-1 ; eissect f)). refine (contr_equiv' { g : B -> A & g o f = idmap } _). apply equiv_functor_sigma_id; intros g. apply equiv_ap10. Defined. Global Instance hprop_isequiv {A B} (f : A -> B) : IsHProp (IsEquiv f). Proof. (* We will show that assuming [f] is an equivalence, [IsEquiv f] decomposes into a sigma of two contractible types. *) apply hprop_inhabited_contr; intros feq. nrefine (contr_equiv' _ (issig_isequiv f oE (equiv_sigma_assoc' _ _)^-1)). srefine (contr_equiv' _ (equiv_contr_sigma _)^-1). (* Each of these types is equivalent to a based homotopy space. The first is exactly [contr_sect_equiv]. *) 1: rapply contr_sect_equiv. (* The second requires a bit more work. *) cbn. refine (contr_equiv' { s : f^-1 o f == idmap & eissect f == s } _). apply equiv_functor_sigma_id; intros s; cbn. apply equiv_functor_forall_id; intros a. refine (equiv_concat_l (eisadj f a) _ oE _). rapply equiv_ap. Qed. (** Now since [IsEquiv f] and the assertion that its fibers are contractible are both HProps, logical equivalence implies equivalence. *) Definition equiv_contr_map_isequiv {A B} (f : A -> B) : IsTruncMap (-2) f <~> IsEquiv f. Proof. rapply equiv_iff_hprop. (** Both directions are found by typeclass inference! *) Defined. (** It also follows that paths of equivalences are equivalent to paths of functions. *) Lemma equiv_path_equiv {A B : Type} (e1 e2 : A <~> B) : (e1 = e2 :> (A -> B)) <~> (e1 = e2 :> (A <~> B)). Proof. equiv_via ((issig_equiv A B) ^-1 e1 = (issig_equiv A B) ^-1 e2). 2: symmetry; apply equiv_ap; refine _. exact (equiv_path_sigma_hprop ((issig_equiv A B)^-1 e1) ((issig_equiv A B)^-1 e2)). Defined. Definition path_equiv {A B : Type} {e1 e2 : A <~> B} : (e1 = e2 :> (A -> B)) -> (e1 = e2 :> (A <~> B)) := equiv_path_equiv e1 e2. Global Instance isequiv_path_equiv {A B : Type} {e1 e2 : A <~> B} : IsEquiv (@path_equiv _ _ e1 e2) (* Coq can find this instance by itself, but it's slow. *) := equiv_isequiv (equiv_path_equiv e1 e2). (** The inverse equivalence is homotopic to [ap equiv_fun], so that is also an equivalence. *) Global Instance isequiv_ap_equiv_fun {A B : Type} (e1 e2 : A <~> B) : IsEquiv (ap (x:=e1) (y:=e2) (@equiv_fun A B)). Proof. snrapply isequiv_homotopic. - exact (equiv_path_equiv e1 e2)^-1%equiv. - exact _. - intro p. exact (ap_compose (fun v => (equiv_fun v; equiv_isequiv v)) pr1 p)^. Defined. (** This implies that types of equivalences inherit truncation. Note that we only state the theorem for [n.+1]-truncatedness, since it is not true for contractibility: if [B] is contractible but [A] is not, then [A <~> B] is not contractible because it is not inhabited. Don't confuse this lemma with [trunc_equiv], which says that if [A] is truncated and [A] is equivalent to [B], then [B] is truncated. It would be nice to find a better pair of names for them. *) Global Instance istrunc_equiv {n : trunc_index} {A B : Type} `{IsTrunc n.+1 B} : IsTrunc n.+1 (A <~> B). Proof. apply istrunc_S. intros e1 e2. apply (istrunc_equiv_istrunc _ (equiv_path_equiv e1 e2)). Defined. (** In the contractible case, we have to assume that *both* types are contractible to get a contractible type of equivalences. *) Global Instance contr_equiv_contr_contr {A B : Type} `{Contr A} `{Contr B} : Contr (A <~> B). Proof. apply (Build_Contr _ equiv_contr_contr). intros e. apply path_equiv, path_forall. intros ?; apply contr. Defined. (** The type of *automorphisms* of an hprop is always contractible *) Global Instance contr_aut_hprop A `{IsHProp A} : Contr (A <~> A). Proof. apply (Build_Contr _ 1%equiv). intros e; apply path_equiv, path_forall. intros ?; apply path_ishprop. Defined. (** Equivalences are functorial under equivalences. *) Definition functor_equiv {A B C D} (h : A <~> C) (k : B <~> D) : (A <~> B) -> (C <~> D) := fun f => ((k oE f) oE h^-1). Global Instance isequiv_functor_equiv {A B C D} (h : A <~> C) (k : B <~> D) : IsEquiv (functor_equiv h k). Proof. refine (isequiv_adjointify _ (functor_equiv (equiv_inverse h) (equiv_inverse k)) _ _). - intros f; apply path_equiv, path_arrow; intros x; simpl. exact (eisretr k _ @ ap f (eisretr h x)). - intros g; apply path_equiv, path_arrow; intros x; simpl. exact (eissect k _ @ ap g (eissect h x)). Defined. Definition equiv_functor_equiv {A B C D} (h : A <~> C) (k : B <~> D) : (A <~> B) <~> (C <~> D) := Build_Equiv _ _ (functor_equiv h k) _. Definition equiv_functor_precompose_equiv@{i j k u v | i <= u, j <= v, k <= u, k <= v} {X : Type@{i}} {Y : Type@{j}} (Z : Type@{k}) (e : X <~> Y) : Equiv@{v u} (Y <~> Z) (X <~> Z) := equiv_functor_equiv e^-1%equiv 1%equiv. Definition equiv_functor_postcompose_equiv@{i j k u v | i <= u, j <= v, k <= u, k <= v} {X : Type@{i}} {Y : Type@{j}} (Z : Type@{k}) (e : X <~> Y) : Equiv@{u v} (Z <~> X) (Z <~> Y) := equiv_functor_equiv 1%equiv e. (** Reversing equivalences is an equivalence *) Global Instance isequiv_equiv_inverse {A B} : IsEquiv (@equiv_inverse A B). Proof. refine (isequiv_adjointify _ equiv_inverse _ _); intros e; apply path_equiv; reflexivity. Defined. Definition equiv_equiv_inverse A B : (A <~> B) <~> (B <~> A) := Build_Equiv _ _ (@equiv_inverse A B) _. End AssumeFunext. (** ** Other facts about equivalences *) (** This is like [transport_arrow], but for a family of equivalence types. It just shows that the functions are homotopic. *) Definition transport_equiv {A : Type} {B C : A -> Type} {x1 x2 : A} (p : x1 = x2) (f : B x1 <~> C x1) (y : B x2) : (transport (fun x => B x <~> C x) p f) y = p # (f (p^ # y)). Proof. destruct p; auto. Defined. (** A version that shows that the underlying functions are equal. *) Definition transport_equiv' {A : Type} {B C : A -> Type} {x1 x2 : A} (p : x1 = x2) (f : B x1 <~> C x1) : transport (fun x => B x <~> C x) p f = (equiv_transport _ p) oE f oE (equiv_transport _ p^) :> (B x2 -> C x2). Proof. destruct p; auto. Defined. (** A version that shows that the equivalences are equal. Here we do need [Funext], for [path_equiv]. *) Definition transport_equiv'' `{Funext} {A : Type} {B C : A -> Type} {x1 x2 : A} (p : x1 = x2) (f : B x1 <~> C x1) : transport (fun x => B x <~> C x) p f = (equiv_transport _ p) oE f oE (equiv_transport _ p^). Proof. apply path_equiv. destruct p; auto. Defined. Coq-HoTT-9.0/theories/Types/Forall.v000066400000000000000000000353641474641544500173050ustar00rootroot00000000000000(** * Theorems about dependent products *) Require Import Basics.Overture Basics.Equivalences Basics.PathGroupoids Basics.Tactics Basics.Contractible Basics.Iff. Require Export Basics.Trunc (istrunc_forall). Local Open Scope path_scope. Generalizable Variables A B C f g e n. Section AssumeFunext. Context `{Funext}. (** ** Paths *) (** Paths [p : f = g] in a function type [forall x:X, P x] are equivalent to functions taking values in path types, [H : forall x:X, f x = g x], or concisely, [H : f == g]. This equivalence, however, is just the combination of [apD10] and function extensionality [funext], and as such, [path_forall], et seq. are given in the [Overture]: *) (** Now we show how these things compute. *) Definition apD10_path_forall `{P : A -> Type} (f g : forall x, P x) (h : f == g) : apD10 (path_forall _ _ h) == h := apD10 (eisretr apD10 h). Definition eta_path_forall `{P : A -> Type} (f g : forall x, P x) (p : f = g) : path_forall _ _ (apD10 p) = p := eissect apD10 p. Definition path_forall_1 `{P : A -> Type} (f : forall x, P x) : (path_forall f f (fun x => 1)) = 1 := eta_path_forall f f 1. (** The identification of the path space of a dependent function space, up to equivalence, is of course just funext. *) Definition equiv_apD10 {A : Type} (P : A -> Type) f g : (f = g) <~> (f == g) := Build_Equiv _ _ (@apD10 A P f g) _. Global Instance isequiv_path_forall `{P : A -> Type} (f g : forall x, P x) : IsEquiv (path_forall f g) | 0 := @isequiv_inverse _ _ (@apD10 A P f g) _. Definition equiv_path_forall `{P : A -> Type} (f g : forall x, P x) : (f == g) <~> (f = g) := Build_Equiv _ _ (path_forall f g) _. Global Arguments equiv_path_forall {A%_type_scope P} (f g)%_function_scope. (** ** Path algebra *) Definition path_forall_pp `{P : A -> Type} (f g h : forall x, P x) (p : f == g) (q : g == h) : path_forall f h (fun x => p x @ q x) = path_forall f g p @ path_forall g h q. Proof. revert p q. equiv_intro (@apD10 A P f g) p. equiv_intro (@apD10 A P g h) q. transitivity (path_forall f h (apD10 (p @ q))). - apply ap, path_forall; intros x. symmetry; apply apD10_pp. - refine (eta_path_forall _ _ _ @ _). apply concat2; symmetry; apply eta_path_forall. Defined. Definition path_forall_V `{P : A -> Type} (f g : forall x, P x) (p : f == g) : path_forall _ _ (fun x => (p x)^) = (path_forall _ _ p)^. Proof. transitivity (path_forall _ _ (fun x => (apD10 (path_forall _ _ p) x)^)). - f_ap. symmetry. apply (@ap _ _ (fun h x => (h x)^)). apply eisretr. - transitivity (path_forall _ _ (apD10 (path_forall _ _ p)^)). + apply ap, inverse. apply path_forall; intros x. apply apD10_V. + apply eissect. Defined. (** ** Transport *) (** The concrete description of transport in sigmas and pis is rather trickier than in the other types. In particular, these cannot be described just in terms of transport in simpler types; they require the full Id-elim rule by way of "dependent transport" [transportD]. In particular this indicates why "transport" alone cannot be fully defined by induction on the structure of types, although Id-elim/transportD can be (cf. Observational Type Theory). A more thorough set of lemmas, along the lines of the present ones but dealing with Id-elim rather than just transport, might be nice to have eventually? *) Definition transport_forall {A : Type} {P : A -> Type} {C : forall x, P x -> Type} {x1 x2 : A} (p : x1 = x2) (f : forall y : P x1, C x1 y) : (transport (fun x => forall y : P x, C x y) p f) == (fun y => transport (C x2) (transport_pV _ _ _) (transportD _ _ p _ (f (p^ # y)))) := match p with idpath => fun _ => 1 end. (** A special case of [transport_forall] where the type [P] does not depend on [A], and so it is just a fixed type [B]. *) Definition transport_forall_constant {A B : Type} {C : A -> B -> Type} {x1 x2 : A} (p : x1 = x2) (f : forall y : B, C x1 y) : (transport (fun x => forall y : B, C x y) p f) == (fun y => transport (fun x => C x y) p (f y)) := match p with idpath => fun _ => 1 end. Definition apD_transport_forall_constant {A B : Type} (C : A -> B -> Type) {x1 x2 : A} (p : x1 = x2) (f : forall y : B, C x1 y) {y1 y2 : B} (q : y1 = y2) : apD (transport (fun x => forall y : B, C x y) p f) q = ap (transport (C x2) q) (transport_forall_constant p f y1) @ transport_transport C p q (f y1) @ ap (transport (fun x : A => C x y2) p) (apD f q) @ (transport_forall_constant p f y2)^. Proof. destruct p, q; reflexivity. Defined. (** ** Maps on paths *) (** The action of maps given by application. *) Definition ap_apply_lD {A} {B : A -> Type} {f g : forall x, B x} (p : f = g) (z : A) : ap (fun f => f z) p = apD10 p z := 1. Definition ap_apply_lD2 {A} {B : A -> Type} { C : forall x, B x -> Type} {f g : forall x y, C x y} (p : f = g) (z1 : A) (z2 : B z1) : ap (fun f => f z1 z2) p = apD10 (apD10 p z1) z2. Proof. by path_induction. Defined. (** The action of maps given by lambda. *) Definition ap_lambdaD {A B : Type} {C : B -> Type} {x y : A} (p : x = y) (M : forall a b, C b) : ap (fun a b => M a b) p = path_forall _ _ (fun b => ap (fun a => M a b) p). Proof. destruct p; symmetry; simpl; apply path_forall_1. Defined. (** The action of pre-composition on a path between dependent functions. See also [ap10_ap_precompose] in PathGroupoids.v and [ap_precompose] in Arrow.v. *) Definition ap_precomposeD {B Q : Type} {P : Q -> Type} {f g : forall q, P q} (h : f = g) (i : B -> Q) : ap (fun (k : forall q, P q) => k oD i) h = path_forall (f oD i) (g oD i) (apD10 h oD i) := ap_lambdaD _ _. (** ** Dependent paths *) (** Usually, a dependent path over [p:x1=x2] in [P:A->Type] between [y1:P x1] and [y2:P x2] is a path [transport P p y1 = y2] in [P x2]. However, when [P] is a function space, these dependent paths have a more convenient description: rather than transporting the argument of [y1] forwards and backwards, we transport only forwards but on both sides of the equation, yielding a "naturality square". *) Definition dpath_forall {A:Type} (B:A -> Type) (C:forall a, B a -> Type) (x1 x2:A) (p:x1=x2) (f:forall y1:B x1, C x1 y1) (g:forall (y2:B x2), C x2 y2) : (forall (y1:B x1), transportD B C p y1 (f y1) = g (transport B p y1)) <~> (transport (fun x => forall y:B x, C x y) p f = g). Proof. destruct p. apply equiv_path_forall. Defined. Definition dpath_forall_constant {A B:Type} (C : A -> B -> Type) (x1 x2:A) (p:x1=x2) (f:forall (y1:B), C x1 y1) (g:forall (y2:B), C x2 y2) : (forall (y1:B), transport (fun x => C x y1) p (f y1) = g y1) <~> (transport (fun x => forall y:B, C x y) p f = g). Proof. destruct p. apply equiv_path_forall. Defined. (** ** Functorial action *) (** The functoriality of [forall] is slightly subtle: it is contravariant in the domain type and covariant in the codomain, but the codomain is dependent on the domain. *) Definition functor_forall `{P : A -> Type} `{Q : B -> Type} (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) : (forall a:A, P a) -> (forall b:B, Q b) := (fun g b => f1 _ (g (f0 b))). Definition ap_functor_forall `{P : A -> Type} `{Q : B -> Type} (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) (g g' : forall a:A, P a) (h : g == g') : ap (functor_forall f0 f1) (path_forall _ _ h) = path_forall _ _ (fun b:B => (ap (f1 b) (h (f0 b)))). Proof. revert h. equiv_intro (@apD10 A P g g') h. destruct h. simpl. transitivity (idpath (functor_forall f0 f1 g)). - exact (ap (ap (functor_forall f0 f1)) (path_forall_1 g)). - symmetry. apply path_forall_1. Defined. Definition functor_forall_compose `{P : A -> Type} `{Q : B -> Type} `{R : C -> Type} (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) (g0 : C -> B) (g1 : forall c:C, Q (g0 c) -> R c) (k : forall a, P a) : functor_forall g0 g1 (functor_forall f0 f1 k) == functor_forall (f0 o g0) (fun c => g1 c o f1 (g0 c)) k := fun a => 1. (** Some special cases appear when one or the other of the maps are equivalences. *) Definition functor_forall_id `{P : A -> Type} `{Q : A -> Type} (f1 : forall a:A, P a -> Q a) : (forall a:A, P a) -> (forall a:A, Q a) := functor_forall idmap f1. Definition functor_forall_pb {A B : Type} `{P : A -> Type} (f0 : B -> A) : (forall a:A, P a) -> (forall b:B, P (f0 b)) := functor_forall f0 (fun _ => idmap). (** If [f0] is an equivalence, then we can simply apply [functor_forall] to its inverse. However, in this case it is sometimes more convenient to place the substitution on the other side of [f1]. *) Definition functor_forall_equiv `{P : A -> Type} `{Q : B -> Type} (f0 : A -> B) `{!IsEquiv f0} (f1 : forall a:A, P a -> Q (f0 a)) : (forall a:A, P a) -> (forall b:B, Q b). Proof. nrapply (functor_forall f0^-1). intros b u. refine ((eisretr f0 b) # _). exact (f1 _ u). Defined. Definition functor_forall_equiv_pb {A B : Type} `{Q : B -> Type} (f0 : A -> B) `{!IsEquiv f0} : (forall a:A, Q (f0 a)) -> (forall b:B, Q b) := functor_forall_equiv f0 (fun _ => idmap). (** Since there's a nontrivial transport here, it's useful to have a computation lemma. *) Definition functor_forall_equiv_pb_beta {A B : Type} {P : B -> Type} (f : A -> B) `{!IsEquiv f} (h : forall a, P (f a)) : forall a, functor_forall_equiv_pb f h (f a) = h a. Proof. intro a; srapply (_ @ apD h (eissect f a)); srapply (_ @ (transport_compose _ _ _ _)^). srapply ap10; apply ap; apply eisadj. Defined. (** ** Equivalences *) (** If *both* maps in [functor_forall] are equivalences, then so is the output. *) Global Instance isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} : IsEquiv (functor_forall f g) | 1000. Proof. simple refine (isequiv_adjointify (functor_forall f g) (functor_forall (f^-1) (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y )) _ _); intros h. - abstract ( apply path_forall; intros b; unfold functor_forall; rewrite eisadj; rewrite <- transport_compose; rewrite ap_transport; rewrite eisretr; apply apD ). - abstract ( apply path_forall; intros a; unfold functor_forall; rewrite eissect; apply apD ). Defined. Definition equiv_functor_forall `{P : A -> Type} `{Q : B -> Type} (f : B -> A) `{IsEquiv B A f} (g : forall b, P (f b) -> Q b) `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} : (forall a, P a) <~> (forall b, Q b) := Build_Equiv _ _ (functor_forall f g) _. Definition equiv_functor_forall' `{P : A -> Type} `{Q : B -> Type} (f : B <~> A) (g : forall b, P (f b) <~> Q b) : (forall a, P a) <~> (forall b, Q b) := equiv_functor_forall f g. Definition equiv_functor_forall_id `{P : A -> Type} `{Q : A -> Type} (g : forall a, P a <~> Q a) : (forall a, P a) <~> (forall a, Q a) := equiv_functor_forall (equiv_idmap A) g. Definition equiv_functor_forall_pb {A B : Type} {P : A -> Type} (f : B <~> A) : (forall a, P a) <~> (forall b, P (f b)) := equiv_functor_forall' (Q := P o f) f (fun b => equiv_idmap). (** Similarly, we have a version of [functor_forall_equiv] that acts on on equivalences both upstairs and downstairs. *) Definition equiv_functor_forall_covariant `{P : A -> Type} `{Q : B -> Type} (f : A <~> B) (g : forall a, P a <~> Q (f a)) : (forall a, P a) <~> (forall b, Q b) := (equiv_functor_forall' f (fun a => (g a)^-1%equiv))^-1. Definition equiv_functor_forall_covariant_compose `{P : A -> Type} `{Q : B -> Type} `{R : C -> Type} (f0 : A <~> B) (f1 : forall a, P a <~> Q (f0 a)) (g0 : B <~> C) (g1 : forall b, Q b <~> R (g0 b)) (h : forall a, P a) : equiv_functor_forall_covariant g0 g1 (equiv_functor_forall_covariant f0 f1 h) == equiv_functor_forall_covariant (g0 oE f0) (fun a => g1 (f0 a) oE f1 a) h. Proof. apply apD10. refine ((equiv_inverse_compose (equiv_functor_forall' g0 (fun a : B => (g1 a)^-1%equiv)) (equiv_functor_forall' f0 (fun a : A => (f1 a)^-1%equiv)) h)^ @ _). revert h; apply equiv_inverse_homotopy; intros h. apply path_forall; intros c. symmetry; rapply functor_forall_compose. Defined. (** ** Functoriality on logical equivalences *) (** At least over a fixed base *) Definition iff_functor_forall {A : Type} {P Q : A -> Type} (f : forall a, P a <-> Q a) : (forall a, P a) <-> (forall a, Q a) := (functor_forall idmap (fun a => fst (f a)), functor_forall idmap (fun a => snd (f a))). (** ** Two variable versions for function extensionality. *) Definition equiv_path_forall11 {A : Type} {B : A -> Type} {P : forall a : A, B a -> Type} (f g : forall a b, P a b) : (forall (a : A) (b : B a), f a b = g a b) <~> f = g := (equiv_path_forall f g) oE (equiv_functor_forall_id (fun a => equiv_path_forall (f a) (g a))). Definition path_forall11 {A : Type} {B : A -> Type} {P : forall a : A, B a -> Type} (f g : forall a b, P a b) : (forall x y, f x y = g x y) -> f = g := equiv_path_forall11 f g. Global Instance isequiv_path_forall11 {A : Type} {B : A -> Type} `{P : forall a : A, B a -> Type} (f g : forall a b, P a b) : IsEquiv (path_forall11 f g) | 0 := _. Global Arguments equiv_path_forall11 {A B}%_type_scope {P} (f g)%_function_scope. Global Arguments path_forall11 {A B}%_type_scope {P} (f g)%_function_scope _. (** ** Truncatedness: any dependent product of n-types is an n-type: see [contr_forall] and [istrunc_forall] in Basics.Trunc. *) (** ** Contractibility: A product over a contractible type is equivalent to the fiber over the center. *) Definition equiv_contr_forall `{Contr A} `(P : A -> Type) : (forall a, P a) <~> P (center A). Proof. simple refine (equiv_adjointify (fun (f:forall a, P a) => f (center A)) _ _ _). - intros p a; exact (transport P (path_contr _ _) p). - intros p. refine (transport2 P (q := 1) _ p). apply path_contr. - intros f; apply path_forall; intros a. apply apD. Defined. End AssumeFunext. (** ** Symmetry of curried arguments *) (** Using the standard Haskell name for this, as it’s a handy utility function. Note: not sure if [P] will usually be deducible, or whether it would be better explicit. *) Definition flip `{P : A -> B -> Type} : (forall a b, P a b) -> (forall b a, P a b) := fun f b a => f a b. Arguments flip {A B P} f b a /. Global Instance isequiv_flip `{P : A -> B -> Type} : IsEquiv (@flip _ _ P) | 0. Proof. set (flip_P := @flip _ _ P). set (flip_P_inv := @flip _ _ (flip P)). set (flip_P_is_sect := (fun f => 1) : flip_P_inv o flip_P == idmap). set (flip_P_is_retr := (fun g => 1) : flip_P o flip_P_inv == idmap). exists flip_P_inv flip_P_is_retr flip_P_is_sect. intro g. exact 1. Defined. Definition equiv_flip `(P : A -> B -> Type) : (forall a b, P a b) <~> (forall b a, P a b) := Build_Equiv _ _ (@flip _ _ P) _. Coq-HoTT-9.0/theories/Types/IWType.v000066400000000000000000000442161474641544500172430ustar00rootroot00000000000000Require Import Basics. Require Import Types.Forall Types.Sigma Types.Prod Types.WType. (** In this file we define indexed W-types. We show that indexed W-types can be reduced to W-types whilst still having definitional computation rules. We also characterize the path space of indexed W-types. This allows us to derive sufficient conditions for an indexed W-type to be truncated. *) (** This is mostly adapted from Jasper Hugunin's formalization in coq: https://github.com/jashug/IWTypes *) (** On a more meta-theoretic note, this partly justifies the use of indexed inductive types in Coq with respect to homotopy type theory. *) Inductive IW (I : Type) (** The indexing type *) (A : Type) (** The type of labels / constructors / data *) (B : A -> Type) (** The the type of arities / arguments / children *) (i : A -> I) (** The index map (for labels) *) (j : forall x, B x -> I) (** The index map for arguments *) : I -> Type := | iw_sup (x : A) : (forall (y : B x), IW I A B i j (j x y)) -> IW I A B i j (i x). Definition iw_label {A B I i j} {l : I} (w : IW I A B i j l) : A := match w with | iw_sup x y => x end. Definition iw_arity {A B I i j} (l : I) (w : IW I A B i j l) : forall (y : B (iw_label w)), IW I A B i j (j (iw_label w) y) := match w with | iw_sup x y => y end. Definition path_index_iw_label {A B I i j} (l : I) (w : IW I A B i j l) : i (iw_label w) = l. Proof. by destruct w. Defined. Definition iw_eta {A B I i j} (l : I) (w : IW I A B i j l) : path_index_iw_label l w # iw_sup I A B i j (iw_label w) (iw_arity l w) = w. Proof. by destruct w. Defined. (** We have a canonical map from the IW-type to the fiber of the index map *) Definition iw_to_hfiber_index {A B I i j} (l : I) : IW I A B i j l -> hfiber i l. Proof. intros w. exists (iw_label w). apply path_index_iw_label. Defined. Definition pointwise_paths_ind `{Funext} {A : Type} {B : A -> Type} (a : forall x, B x) (P : forall b, a == b -> Type) (f : P a (fun _ => 1%path)) {b : forall x, B x} (p : a == b) : P b p. Proof. refine (equiv_ind apD10 (P b) _ p). intros []. exact f. Defined. (** * Reduction of indexed W-types to W-types *) (** Jasper Hugunin found this construction (typecheck unindexed trees) in "Indexed Containers by Thorsten Altenkirch and Peter Morris". http://www.cs.nott.ac.uk/~psztxa/publ/ICont.pdf This references the following: * M. Abbott, T. Altenkirch, and N. Ghani. Containers - constructing strictly positive types. Theoretical Computer Science, 342:327, September 2005. Applied Semantics: Selected Topics. * N. Gambino and M. Hyland. Wellfounded trees and dependent polynomial functors. In S. Berardi, M. Coppo, and F. Damiani, editors, types for Proofs and Programs (TYPES 2003), Lecture Notes in Computer Science, 2004 as previous examples of the technique. *) Section Reduction. Context (I : Type) (A : Type) (B : A -> Type) (i : A -> I) (j : forall x, B x -> I). Fixpoint IsIndexedBy (x : I) (w : W A B) : Type := match w with | w_sup a b => (i a = x) * (forall c, IsIndexedBy (j a c) (b c)) end. Definition IW' (x : I) := sig (IsIndexedBy x). Definition iw_sup' (x : A) (y : forall z : B x, IW' (j x z)) : IW' (i x) := (w_sup A B x (fun a => pr1 (y a)); (idpath, (fun a => pr2 (y a)))). (** We can derive the induction principle for IW-types *) Definition IW'_ind (P : forall i, IW' i -> Type) (S : forall x y, (forall c, P _ (y c)) -> P _ (iw_sup' x y)) : forall x w, P x w. Proof. intros x [w r]. revert w x r. induction w as [a b k]. intros x [p IH]. destruct p. refine (S a (fun c => (b c; IH c)) _). intros c. apply k. Defined. (** We have definitional computation rules for this eliminator. *) Definition IW'_ind_beta_iw_sup' (P : forall i, IW' i -> Type) (S : forall x y, (forall c, P _ (y c)) -> P _ (iw_sup' x y)) x y : IW'_ind P S _ (iw_sup' x y) = S x y (fun c => IW'_ind P S _ (y c)) := idpath. (** Showing that IW-types are equivalent to W-types requries funext. *) Definition equiv_wtype_iwtype `{Funext} (x : I) : IW' x <~> IW I A B i j x. Proof. snrapply equiv_adjointify. { rapply (IW'_ind (fun l _ => IW I A B i j l)). intros a b c. apply iw_sup. intros y. apply c. } { rapply (IW_rect I A B i j (fun l _ => IW' l)). intros a b c. apply iw_sup'. intros y. apply c. } { rapply (IW_rect I A B i j (fun x y => IW'_ind _ _ x _ = y)). cbn; intros a b c. apply ap. funext y. apply c. } simpl. intro y. rapply (IW'_ind (fun x y => IW_rect I A B i j _ _ x _ = y)). cbn; intros a b c. apply ap. funext d. apply c. Defined. End Reduction. (** * Characterization of path types of IW-types. Argument due to Jasper Hugunin. *) Section Paths. Context `{Funext} (I : Type) (A : Type) (B : A -> Type) (i : A -> I) (j : forall x, B x -> I). (** We wish to show that path types of IW-types are IW-types themselves. We do this by showing the path type satisfies the same induction principle as the IW-type hence they are equivalent. *) Let I' : Type := {k : I & IW I A B i j k * IW I A B i j k}. Let A' : Type := {e : A & (forall c, IW I A B i j (j e c)) * (forall c, IW I A B i j (j e c))}. Let B' : A' -> Type := fun X => B X.1. Let i' : A' -> I' := functor_sigma i (fun a : A => functor_prod (iw_sup I A B i j a) (iw_sup I A B i j a)). Let j' : forall k, B' k -> I' := fun k c => (j k.1 c; (fst k.2 c, snd k.2 c)). Let IWPath : I' -> Type := fun x => fst (pr2 x) = snd (pr2 x). Definition iwpath_sup (x : A') : (forall y : B' x, IWPath (j' x y)) -> IWPath (i' x). Proof. destruct x as [x [c1 c2]]. intros y. unfold IWPath. cbn; apply ap. funext l. apply y. Defined. Definition iwpath_sup_refl (x : A) (a : forall c : B x, IW I A B i j (j x c)) : iwpath_sup (x; (a, a)) (apD10 1) = idpath. Proof. unfold iwpath_sup. rewrite path_forall_1. reflexivity. Defined. Section Ind. Context (P : forall xab, IWPath xab -> Type) (S : forall a b, (forall c, P _ (b c)) -> P (i' a) (iwpath_sup a b)). Definition IWPath_ind_refl : forall l a, P (l ; (a, a)) idpath. Proof. rapply (IW_rect I A B i j (fun l a => P (l; (a, a)) idpath)). intros x a q. pose (S (x; (a, a)) _ q) as p. unfold iwpath_sup in p. refine (transport (P (i x; (iw_sup I A B i j x a, iw_sup I A B i j x a))) _ p). change (ap (iw_sup I A B i j x) (path_forall a a (apD10 idpath)) = ap (iw_sup I A B i j x) 1%path). refine (ap _ _). apply eissect. Defined. Definition IWPath_ind : forall x p, P x p. Proof. intros [x [a b]]. unfold IWPath; cbn. destruct p. apply IWPath_ind_refl. Defined. (** The computation rule for the induction principle. *) Definition IWPath_ind_beta_iwpath_sup (x : A') (h : forall y : B' x, IWPath (j' x y)) : IWPath_ind _ (iwpath_sup x h) = S x h (fun c => IWPath_ind _ (h c)). Proof. destruct x as [x [a b]]. cbv in h. refine (_ @ _). { refine (_ @ ap _ (eisadj (path_forall _ _) h)). refine (paths_ind _ (fun b p' => paths_ind _ (fun r p'' => P (i x ; (iw_sup I A B i j x a , r)) p'') (IWPath_ind_refl (i x) (iw_sup I A B i j x a)) _ (ap (iw_sup I A B i j x) p') = paths_rec (path_forall _ _ (apD10 p')) (fun p'' => P (_ ; (_, _)) (ap (iw_sup I A B i j x) p'')) (S (x ; (a, b)) (apD10 p') (fun c => IWPath_ind (_ ; (_, _)) (apD10 p' c))) p' (eissect apD10 p')) _ _ _). exact (transport_compose _ _ _ _)^. } by cbn; destruct (eisretr apD10 h). Defined. End Ind. (** The path type of an IW-type is again an IW-type. *) Definition equiv_path_iwtype (x : I) (a b : IW I A B i j x) : IW I' A' B' i' j' (x; (a, b)) <~> a = b. Proof. change (IW I' A' B' i' j' (x; (a, b)) <~> IWPath (x; (a,b))). snrapply equiv_adjointify. { intros y. induction y as [e f g]. apply iwpath_sup. intros y. apply g. } { intros y. induction y as [e f g] using IWPath_ind. apply iw_sup. intros y. apply g. } { intros y; cbn. induction y as [a' b' IH] using IWPath_ind. rewrite IWPath_ind_beta_iwpath_sup. simpl; f_ap. funext c. apply IH. } intros y; cbn. induction y as [e f IH]. rewrite IWPath_ind_beta_iwpath_sup. f_ap; funext c. apply IH. Defined. (** ** Characterization of fiber *) (** We begin with two auxillary lemmas that will be explained shortly. *) Local Definition adjust_hfiber {X Y} {f : X -> Y} {y z} : hfiber f y -> y = z -> hfiber f z := fun '(x ; p) => match p with idpath => fun q => (x ; q) end. Local Definition adjust_hfiber_idpath {X Y} {f : X -> Y} {y xp} : adjust_hfiber (f:=f) xp (idpath : y = y) = xp. Proof. by destruct xp as [x []]. Defined. (** We wish to show an induction principle coming from the path type of the fiber. However to do this we need to be a bit more general by allowing the elements of the IW-type to differ in label upto equality. This allows us to do prove this induction principle easily, and later we will derive the induction principle where the labels are the same. *) Local Definition path_iw_to_hfiber_ind' (P : forall (la lb : I) (le : lb = la) (a : IW I A B i j la) (b : IW I A B i j lb), iw_to_hfiber_index la a = adjust_hfiber (iw_to_hfiber_index lb b) le -> Type) (h : forall x a b, P (i x) (i x) idpath (iw_sup I A B i j x a) (iw_sup I A B i j x b) idpath) : forall la lb le a b p, P la lb le a b p. Proof. intros la lb le a b. destruct a as [xa cha], b as [xb chb]. intros p. refine (paths_ind _ (fun _ q => forall chb, P _ _ _ _ (iw_sup _ _ _ _ _ _ chb) q) _ _ p chb). intros x. apply h. Defined. (** Induction principle for paths in the fiber. *) Local Definition path_iw_to_hfiber_ind (P : forall (l : I) (a b : IW I A B i j l), iw_to_hfiber_index l a = iw_to_hfiber_index l b -> Type) (h : forall x a b, P (i x) (iw_sup I A B i j x a) (iw_sup I A B i j x b) idpath) : forall l a b p, P l a b p. Proof. intros l a b p. transparent assert (Q : (forall (la lb : I) (le : lb = la) (a : IW I A B i j la) (b : IW I A B i j lb), iw_to_hfiber_index la a = adjust_hfiber (iw_to_hfiber_index lb b) le -> Type)). { intros la lb le. destruct le. intros a' b' p'. refine (P lb _ _ _). exact (p' @ adjust_hfiber_idpath). } transparent assert (h' : ((forall (x : A) (a b : forall y : B x, IW I A B i j (j x y)), Q (i x) (i x) idpath (iw_sup I A B i j x a) (iw_sup I A B i j x b) idpath))). { intros x a' b'. apply h. } pose (path_iw_to_hfiber_ind' Q h' l l idpath a b (p @ adjust_hfiber_idpath^)) as q. refine (transport (P l a b) _ q). apply concat_pV_p. Defined. (** Induction principle for families over hfiber of i' *) Local Definition hfiber_ind (P : forall l a b, hfiber i' (l; (a, b)) -> Type) (h : forall x a b, P (i x) (iw_sup I A B i j x a) (iw_sup I A B i j x b) ((x; (a, b)); idpath)) : forall l a b p, P l a b p. Proof. intros l a b [[x [y z]] p]. unfold i', functor_sigma, functor_prod in p; simpl in p. revert p. refine (equiv_ind (equiv_path_sigma _ _ _) _ _). intros [p q]; simpl in p, q. destruct p. revert q; cbn. refine (equiv_ind (equiv_path_prod _ _) _ _). cbn; intros [p q]. destruct p, q. apply h. Defined. Local Definition path_iw_to_hfiber l a b : iw_to_hfiber_index l a = iw_to_hfiber_index l b -> hfiber i' (l; (a, b)) := path_iw_to_hfiber_ind (fun l a b _ => hfiber i' (l ; (a, b))) (fun x a b => ((x ; (a, b)); idpath)) l a b. Local Definition hfiber_to_path_iw l a b : hfiber i' (l; (a, b)) -> iw_to_hfiber_index l a = iw_to_hfiber_index l b := hfiber_ind (fun l a b _ => iw_to_hfiber_index l a = iw_to_hfiber_index l b) (fun x a b => idpath) l a b. Local Definition path_iw_to_hfiber_to_path_iw : forall l a b p, path_iw_to_hfiber l a b (hfiber_to_path_iw l a b p) = p. Proof. refine (hfiber_ind (fun l a b p => path_iw_to_hfiber l a b (hfiber_to_path_iw l a b p) = p) _). intros x a b. reflexivity. Defined. Local Definition hfiber_to_path_iw_to_hfiber : forall l a b p, hfiber_to_path_iw l a b (path_iw_to_hfiber l a b p) = p. Proof. rapply path_iw_to_hfiber_ind. intros x a b. reflexivity. Defined. (** The path type of the fibers of [i] is equivalent to the fibers of [i']. *) Definition equiv_path_hfiber_index (l : I) (a b : IW I A B i j l) : iw_to_hfiber_index l a = iw_to_hfiber_index l b <~> hfiber i' (l; (a, b)). Proof. srapply equiv_adjointify. + apply path_iw_to_hfiber. + apply hfiber_to_path_iw. + rapply path_iw_to_hfiber_to_path_iw. + rapply hfiber_to_path_iw_to_hfiber. Defined. End Paths. (** Some properties of the (fibers of the) index map [i] hold for the IW-type as well. For example, if [i] is an embedding then the corresponding IW-type is a hprop. *) (** ** IW-types preserve truncation *) (** We can show that if the index map is an embedding then the IW-type is a hprop. *) Global Instance ishprop_iwtype `{Funext} (I : Type) (A : Type) (B : A -> Type) (i : A -> I) (j : forall x, B x -> I) {h : IsEmbedding i} : forall x, IsHProp (IW I A B i j x). Proof. intros l. apply hprop_allpath. intros x. induction x as [x x' IHx]. intros y. (** We need to induct on y and at the same time generalize the goal to become a dependent equality. This can be difficult to do with tactics so we just refine the corresponding match statement. All we have done is turn the RHS into a transport over an equality allowing the induction on y to go through. *) refine ( match y in (IW _ _ _ _ _ l) return (forall q : l = i x, iw_sup I A B i j x x' = q # y) with iw_sup y y' => _ end idpath). intros q. pose (r := @path_ishprop _ (h (i x)) (x; idpath) (y; q)). set (r2 := r..2); cbn in r2. set (r1 := r..1) in r2; cbn in r1. clearbody r1 r2. destruct r1. simpl in r2. destruct r2. cbn; f_ap. funext a. apply IHx. Defined. (** Now by induction on truncation indices we show that IW-types are n.+1 truncated if the index maps are also n.+1 truncated. *) Global Instance istrunc_iwtype `{Funext} (I : Type) (A : Type) (B : A -> Type) (i : A -> I) (j : forall x, B x -> I) (n : trunc_index) {h : IsTruncMap n.+1 i} (l : I) : IsTrunc n.+1 (IW I A B i j l). Proof. (** We need a general induction hypothesis *) revert n I A B i j h l. induction n as [|n IHn]. 1: apply ishprop_iwtype. intros I A B i j h l. apply istrunc_S. intros x y. refine (istrunc_equiv_istrunc _ (equiv_path_iwtype I A B i j l x y) (n := n.+1)). apply IHn. intros [k [a b]]. (** The crucial step is to characterize the fiber of [i'] which was done previously. *) apply (istrunc_equiv_istrunc _ (equiv_path_hfiber_index I A B i j k a b)). Defined. (** ** Decidable equality for IW-types *) (** If A has decidable paths then it is a hset and therefore equality of sigma types over it are determined by the second component. *) Local Definition inj_right_pair_on {A : Type} {A_dec : DecidablePaths A} (P : A -> Type) (x : A) (y y' : P x) (H : (x; y) = (x; y')) : y = y'. Proof. apply (equiv_path_sigma _ _ _)^-1%equiv in H. destruct H as [p q]; cbn in p, q. assert (r : idpath = p) by apply path_ishprop. destruct r. exact q. Defined. (** IW-types have decidable equality if liftP holds and the fibers of the indexing map have decidable paths. Notably, if B x is finitely enumerable, then liftP holds. *) Section DecidablePaths. Context `{Funext} (I : Type) (A : Type) (B : A -> Type) (i : A -> I) (j : forall x, B x -> I) (liftP : forall (x : A) (P : B x -> Type), (forall c, Decidable (P c)) -> Decidable (forall c, P c)) (fibers_dec : forall x, DecidablePaths (hfiber i x)). Let children_for (x : A) : Type := forall c, IW I A B i j (j x c). Let getfib {x} (a : IW I A B i j x) : hfiber i x := match a with iw_sup x _ => (x ; idpath) end. Let getfib_computes x y children p : getfib (paths_rec (i y) _ (iw_sup _ _ _ _ _ y children) (i x) p) = exist _ y p := match p return getfib (paths_rec _ _ (iw_sup _ _ _ _ _ y children) _ p) = exist _ y p with idpath => idpath end. Let getfib_plus {x} (a : IW I A B i j x) : {f : hfiber i x & children_for (pr1 f)} := match a with iw_sup x c => ((x; idpath); c) end. Let children_eq (x : A) (c1 c2 : forall c, IW I A B i j (j x c)) : iw_sup I A B i j x c1 = iw_sup I A B i j x c2 -> c1 = c2 := fun r => inj_right_pair_on (fun f => children_for (pr1 f)) (x; idpath) _ _ (ap getfib_plus r). Fixpoint decide_eq l (a : IW I A B i j l) : forall b, Decidable (a = b). Proof. destruct a as [x c1]. intro b. transparent assert (decide_children : (forall c2, Decidable (c1 = c2))). { intros c2. destruct (liftP x (fun c => c1 c = c2 c) (fun c => decide_eq _ (c1 c) (c2 c))) as [p|p]. + left; by apply path_forall. + right; intro h; by apply p, apD10. } snrefine ( match b in (IW _ _ _ _ _ l) return forall iy : l = i x, Decidable (iw_sup I A B i j x c1 = paths_rec l (IW I A B i j) b (i x) iy) with iw_sup y c2 => fun iy : i y = i x => _ end idpath). destruct (fibers_dec (i x) (x ; idpath) (y ; iy)) as [feq|fneq]. + refine ( match feq in (_ = (y ; iy)) return forall c2, Decidable (iw_sup _ _ _ _ _ x c1 = paths_rec (i y) (IW I A B i j) (iw_sup _ _ _ _ _ y c2) (i x) iy) with idpath => _ end c2). cbn; intros c3. destruct (decide_children c3) as [ceq | cneq]. - left; exact (ap _ ceq). - right; intros r; apply cneq. exact (children_eq x c1 c3 r). + right; intros r; apply fneq. exact (ap getfib r @ getfib_computes x y c2 iy). Defined. Definition decidablepaths_iwtype : forall x, DecidablePaths (IW I A B i j x). Proof. intros x a b. apply decide_eq. Defined. End DecidablePaths. Coq-HoTT-9.0/theories/Types/Option.v000066400000000000000000000010361474641544500173230ustar00rootroot00000000000000Require Import Basics.Overture. (** * Option types *) (** Option types are a simple way to represent a value that may or may not be present. They are also known as the Maybe monad in functional programming. *) (** [option] is functorial. *) Definition functor_option {A B} (f : A -> B) (x : option A) : option B := match x with | None => None | Some a => Some (f a) end. (** The [Some] constructor is injective. *) Definition isinj_some {A} {x y : A} (p : Some x = Some y) : x = y. Proof. injection p. exact idmap. Defined. Coq-HoTT-9.0/theories/Types/Paths.v000066400000000000000000000617551474641544500171500ustar00rootroot00000000000000(** * Theorems about path spaces *) Require Import Basics.Overture Basics.Equivalences Basics.PathGroupoids Basics.Tactics. Local Open Scope path_scope. Generalizable Variables A B f x y z. (** ** Path spaces *) (** The path spaces of a path space are not, of course, determined; they are just the higher-dimensional structure of the original space. *) (** ** Transporting in path spaces. There are potentially a lot of these lemmas, so we adopt a uniform naming scheme: - `l` means the left endpoint varies - `r` means the right endpoint varies - `F` means application of a function to that (varying) endpoint. *) Definition transport_paths_l {A : Type} {x1 x2 y : A} (p : x1 = x2) (q : x1 = y) : transport (fun x => x = y) p q = p^ @ q. Proof. destruct p, q; reflexivity. Defined. Definition transport_paths_r {A : Type} {x y1 y2 : A} (p : y1 = y2) (q : x = y1) : transport (fun y => x = y) p q = q @ p. Proof. destruct p, q; reflexivity. Defined. Definition transport_paths_lr {A : Type} {x1 x2 : A} (p : x1 = x2) (q : x1 = x1) : transport (fun x => x = x) p q = p^ @ q @ p. Proof. destruct p; simpl. exact ((concat_1p q)^ @ (concat_p1 (1 @ q))^). Defined. Definition transport_paths_Fl {A B : Type} {f : A -> B} {x1 x2 : A} {y : B} (p : x1 = x2) (q : f x1 = y) : transport (fun x => f x = y) p q = (ap f p)^ @ q. Proof. destruct p, q; reflexivity. Defined. Definition transport_paths_Fr {A B : Type} {g : A -> B} {y1 y2 : A} {x : B} (p : y1 = y2) (q : x = g y1) : transport (fun y => x = g y) p q = q @ (ap g p). Proof. destruct p. symmetry; apply concat_p1. Defined. Definition transport_paths_FFl {A B C : Type} {f : A -> B} {g : B -> C} {x1 x2 : A} {y : C} (p : x1 = x2) (q : g (f x1) = y) : transport (fun x => g (f x) = y) p q = (ap g (ap f p))^ @ q. Proof. destruct p, q; reflexivity. Defined. Definition transport_paths_FlFr {A B : Type} {f g : A -> B} {x1 x2 : A} (p : x1 = x2) (q : f x1 = g x1) : transport (fun x => f x = g x) p q = (ap f p)^ @ q @ (ap g p). Proof. destruct p; simpl. exact ((concat_1p q)^ @ (concat_p1 (1 @ q))^). Defined. Definition transport_paths_FlFr_D {A : Type} {B : A -> Type} {f g : forall a, B a} {x1 x2 : A} (p : x1 = x2) (q : f x1 = g x1) : transport (fun x => f x = g x) p q = (apD f p)^ @ ap (transport B p) q @ (apD g p). Proof. destruct p; simpl. exact ((ap_idmap _)^ @ (concat_1p _)^ @ (concat_p1 _)^). Defined. Definition transport_paths_Flr {A : Type} {f : A -> A} {x1 x2 : A} (p : x1 = x2) (q : f x1 = x1) : transport (fun x => f x = x) p q = (ap f p)^ @ q @ p. Proof. destruct p; simpl. exact ((concat_1p q)^ @ (concat_p1 (1 @ q))^). Defined. Definition transport_paths_FFlr {A B : Type} {f : A -> B} {g : B -> A} {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = x1) : transport (fun x => g (f x) = x) p q = (ap g (ap f p))^ @ q @ p. Proof. destruct p; simpl. exact ((concat_1p q)^ @ (concat_p1 (1 @ q))^). Defined. Definition transport_paths_lFFr {A B : Type} {f : A -> B} {g : B -> A} {x1 x2 : A} (p : x1 = x2) (q : x1 = g (f x1)) : transport (fun x => x = g (f x)) p q = p^ @ q @ (ap g (ap f p)). Proof. destruct p; simpl. exact ((concat_1p q)^ @ (concat_p1 (1 @ q))^). Defined. Definition transport_paths_FFlFr {A B C : Type} {f : A -> B} {g : B -> C} {h : A -> C} {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = h x1) : transport (fun x => g (f x) = h x) p q = (ap g (ap f p))^ @ q @ (ap h p). Proof. destruct p; simpl. exact ((concat_1p q)^ @ (concat_p1 (1 @ q))^). Defined. Definition transport_paths_FlFFr {A B C : Type} {f : A -> C} {g : B -> C} {h : A -> B} {x1 x2 : A} (p : x1 = x2) (q : f x1 = g (h x1)) : transport (fun x => f x = g (h x)) p q = (ap f p)^ @ q @ (ap g (ap h p)). Proof. destruct p; simpl. exact ((concat_1p q)^ @ (concat_p1 (1 @ q))^). Defined. Definition transport_paths_FFlFFr {A B B' C : Type} {f : A -> B} {f' : A -> B'} {g : B -> C} {g' : B' -> C} {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = g' (f' x1)) : transport (fun x => g (f x) = g' (f' x)) p q = (ap g (ap f p))^ @ q @ (ap g' (ap f' p)). Proof. destruct p; simpl. exact ((concat_1p q)^ @ (concat_p1 (1 @ q))^). Defined. (** Variants of the above that do the most common rearranging. We could add similar variants for the others as needed. *) Definition transport_paths_Flr' {A : Type} {f : A -> A} {x1 x2 : A} (p : x1 = x2) (q : f x1 = x1) (r : f x2 = x2) (h : (ap f p) @ r = q @ p) : transport (fun x => f x = x) p q = r. Proof. refine (transport_paths_Flr _ _ @ _). refine (concat_pp_p _ _ _ @ _). apply moveR_Vp. exact h^. Defined. Definition transport_paths_FlFr' {A B : Type} {f g : A -> B} {x1 x2 : A} (p : x1 = x2) (q : f x1 = g x1) (r : (f x2) = (g x2)) (h : (ap f p) @ r = q @ (ap g p)) : transport (fun x => f x = g x) p q = r. Proof. refine (transport_paths_FlFr _ _ @ _). refine (concat_pp_p _ _ _ @ _). apply moveR_Vp. exact h^. Defined. Definition transport_paths_FFlr' {A B : Type} {f : A -> B} {g : B -> A} {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = x1) (r : g (f x2) = x2) (h : (ap g (ap f p)) @ r = q @ p) : transport (fun x => g (f x) = x) p q = r. Proof. refine (transport_paths_FFlr _ _ @ _). refine (concat_pp_p _ _ _ @ _). apply moveR_Vp. exact h^. Defined. Definition transport_paths_FFlFr' {A B C : Type} {f : A -> B} {g : B -> C} {h : A -> C} {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = h x1) (r : g (f x2) = h x2) (h' : (ap g (ap f p)) @ r = q @ (ap h p)) : transport (fun x => g (f x) = h x) p q = r. Proof. lhs nrapply (transport_paths_FFlFr p q). lhs nrapply concat_pp_p. apply moveR_Vp. exact h'^. Defined. Definition transport_paths_FlFFr' {A B C : Type} {f : A -> C} {g : B -> C} {h : A -> B} {x1 x2 : A} (p : x1 = x2) (q : f x1 = g (h x1)) (r : f x2 = g (h x2)) (h' : (ap f p) @ r = q @ (ap g (ap h p))) : transport (fun x => f x = g (h x)) p q = r. Proof. lhs nrapply (transport_paths_FlFFr p q). lhs nrapply concat_pp_p. apply moveR_Vp. exact h'^. Defined. Definition transport_paths_FFlFFr' {A B B' C : Type} {f : A -> B} {f' : A -> B'} {g : B -> C} {g' : B' -> C} {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = g' (f' x1)) (r : g (f x2) = g' (f' x2)) (h : ap g (ap f p) @ r = q @ ap g' (ap f' p)) : transport (fun x => g (f x) = g' (f' x)) p q = r. Proof. lhs nrapply (transport_paths_FFlFFr p q). lhs nrapply concat_pp_p. apply moveR_Vp. exact h^. Defined. Definition transport011_paths {A B X} (f : A -> X) (g : B -> X) {a1 a2 : A} {b1 b2 : B} (p : a1 = a2) (q : b1 = b2) (r : f a1 = g b1) : transport011 (fun a b => f a = g b) p q r = (ap f p)^ @ r @ ap g q. Proof. destruct p, q; cbn. symmetry. lhs nrapply concat_p1. apply concat_1p. Defined. (** ** Transporting in 2-path types *) Definition transport_paths2 {A : Type} {x y : A} (p : x = y) (q : idpath x = idpath x) : transport (fun a => idpath a = idpath a) p q = (concat_Vp p)^ @ whiskerL p^ ((concat_1p p)^ @ whiskerR q p @ concat_1p p) @ concat_Vp p. Proof. destruct p. simpl. refine (_ @ (concat_p1 _)^). refine (_ @ (concat_1p _)^). (** The tricky thing here is getting a sufficiently general statement that we can prove it by path induction. *) assert (H : forall (p : x = x) (q : 1 = p), (q @ (concat_p1 p)^) @ (concat_1p (p @ 1))^ = whiskerL (idpath x) (idpath 1 @ whiskerR q 1 @ idpath (p @ 1))). { intros p' q'. destruct q'. reflexivity. } transitivity (q @ (concat_p1 1)^ @ (concat_1p 1)^). { simpl; exact ((concat_p1 _)^ @ (concat_p1 _)^). } refine (H 1 q). Defined. (** ** Functorial action *) (** 'functor_path' is called [ap]. *) (** ** Equivalences between path spaces *) (** [isequiv_ap] and [equiv_ap] are in Equivalences.v *) (** ** Path operations are equivalences *) Global Instance isequiv_path_inverse {A : Type} (x y : A) : IsEquiv (@inverse A x y) | 0. Proof. refine (Build_IsEquiv _ _ _ (@inverse A y x) (@inv_V A y x) (@inv_V A x y) _). intros p; destruct p; reflexivity. Defined. Definition equiv_path_inverse {A : Type} (x y : A) : (x = y) <~> (y = x) := Build_Equiv _ _ (@inverse A x y) _. Global Instance isequiv_concat_l {A : Type} `(p : x = y:>A) (z : A) : IsEquiv (@transitivity A _ _ x y z p) | 0. Proof. refine (Build_IsEquiv _ _ _ (concat p^) (concat_p_Vp p) (concat_V_pp p) _). intros q; destruct p; destruct q; reflexivity. Defined. Definition equiv_concat_l {A : Type} `(p : x = y) (z : A) : (y = z) <~> (x = z) := Build_Equiv _ _ (concat p) _. Global Instance isequiv_concat_r {A : Type} `(p : y = z) (x : A) : IsEquiv (fun q:x=y => q @ p) | 0. Proof. refine (Build_IsEquiv _ _ (fun q => q @ p) (fun q => q @ p^) (fun q => concat_pV_p q p) (fun q => concat_pp_V q p) _). intros q; destruct p; destruct q; reflexivity. Defined. Definition equiv_concat_r {A : Type} `(p : y = z) (x : A) : (x = y) <~> (x = z) := Build_Equiv _ _ (fun q => q @ p) _. Global Instance isequiv_concat_lr {A : Type} {x x' y y' : A} (p : x' = x) (q : y = y') : IsEquiv (fun r:x=y => p @ r @ q) | 0 := @isequiv_compose _ _ (fun r => p @ r) _ _ (fun r => r @ q) _. Definition equiv_concat_lr {A : Type} {x x' y y' : A} (p : x' = x) (q : y = y') : (x = y) <~> (x' = y') := Build_Equiv _ _ (fun r:x=y => p @ r @ q) _. Definition equiv_p1_1q {A : Type} {x y : A} {p q : x = y} : p = q <~> p @ 1 = 1 @ q := equiv_concat_lr (concat_p1 p) (concat_1p q)^. Definition equiv_1p_q1 {A : Type} {x y : A} {p q : x = y} : p = q <~> 1 @ p = q @ 1 := equiv_concat_lr (concat_1p p) (concat_p1 q)^. Global Instance isequiv_whiskerL {A} {x y z : A} (p : x = y) {q r : y = z} : IsEquiv (@whiskerL A x y z p q r). Proof. simple refine (isequiv_adjointify _ _ _ _). - apply cancelL. - intros k. unfold cancelL. rewrite !whiskerL_pp. refine ((_ @@ 1 @@ _) @ whiskerL_pVL p k). + destruct p, q; reflexivity. + destruct p, r; reflexivity. - intros k. unfold cancelL. refine ((_ @@ 1 @@ _) @ whiskerL_VpL p k). + destruct p, q; reflexivity. + destruct p, r; reflexivity. Defined. Definition equiv_whiskerL {A} {x y z : A} (p : x = y) (q r : y = z) : (q = r) <~> (p @ q = p @ r) := Build_Equiv _ _ (whiskerL p) _. Definition equiv_cancelL {A} {x y z : A} (p : x = y) (q r : y = z) : (p @ q = p @ r) <~> (q = r) := equiv_inverse (equiv_whiskerL p q r). Definition isequiv_cancelL {A} {x y z : A} (p : x = y) (q r : y = z) : IsEquiv (cancelL p q r). Proof. change (IsEquiv (equiv_cancelL p q r)); exact _. Defined. Global Instance isequiv_whiskerR {A} {x y z : A} {p q : x = y} (r : y = z) : IsEquiv (fun h => @whiskerR A x y z p q h r). Proof. simple refine (isequiv_adjointify _ _ _ _). - apply cancelR. - intros k. unfold cancelR. rewrite !whiskerR_pp. refine ((_ @@ 1 @@ _) @ whiskerR_VpR k r). + destruct p, r; reflexivity. + destruct q, r; reflexivity. - intros k. unfold cancelR. refine ((_ @@ 1 @@ _) @ whiskerR_pVR k r). + destruct p, r; reflexivity. + destruct q, r; reflexivity. Defined. Definition equiv_whiskerR {A} {x y z : A} (p q : x = y) (r : y = z) : (p = q) <~> (p @ r = q @ r) := Build_Equiv _ _ (fun h => whiskerR h r) _. Definition equiv_cancelR {A} {x y z : A} (p q : x = y) (r : y = z) : (p @ r = q @ r) <~> (p = q) := equiv_inverse (equiv_whiskerR p q r). Definition isequiv_cancelR {A} {x y z : A} (p q : x = y) (r : y = z) : IsEquiv (cancelR p q r). Proof. change (IsEquiv (equiv_cancelR p q r)); exact _. Defined. (** We can use these to build up more complicated equivalences. In particular, all of the [move] family are equivalences. (Note: currently, some but not all of these [isequiv_] lemmas have corresponding [equiv_] lemmas. Also, they do *not* currently contain the computational content that e.g. the inverse of [moveR_Mp] is [moveL_Vp]; perhaps it would be useful if they did? *) Global Instance isequiv_moveR_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : IsEquiv (moveR_Mp p q r). Proof. destruct r. apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). Defined. Definition equiv_moveR_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : (p = r^ @ q) <~> (r @ p = q) := Build_Equiv _ _ (moveR_Mp p q r) _. Global Instance isequiv_moveR_pM {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : IsEquiv (moveR_pM p q r). Proof. destruct p. apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). Defined. Definition equiv_moveR_pM {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : (r = q @ p^) <~> (r @ p = q) := Build_Equiv _ _ (moveR_pM p q r) _. Global Instance isequiv_moveR_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : IsEquiv (moveR_Vp p q r). Proof. destruct r. apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). Defined. Definition equiv_moveR_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : (p = r @ q) <~> (r^ @ p = q) := Build_Equiv _ _ (moveR_Vp p q r) _. Global Instance isequiv_moveR_pV {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) : IsEquiv (moveR_pV p q r). Proof. destruct p. apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). Defined. Definition equiv_moveR_pV {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) : (r = q @ p) <~> (r @ p^ = q) := Build_Equiv _ _ (moveR_pV p q r) _. Global Instance isequiv_moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : IsEquiv (moveL_Mp p q r). Proof. destruct r. apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). Defined. Definition equiv_moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : (r^ @ q = p) <~> (q = r @ p) := Build_Equiv _ _ (moveL_Mp p q r) _. Definition isequiv_moveL_pM {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : IsEquiv (moveL_pM p q r). Proof. destruct p. apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). Defined. Definition equiv_moveL_pM {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : q @ p^ = r <~> q = r @ p := Build_Equiv _ _ _ (isequiv_moveL_pM p q r). Global Instance isequiv_moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : IsEquiv (moveL_Vp p q r). Proof. destruct r. apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). Defined. Definition equiv_moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : r @ q = p <~> q = r^ @ p := Build_Equiv _ _ (moveL_Vp p q r) _. Global Instance isequiv_moveL_pV {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) : IsEquiv (moveL_pV p q r). Proof. destruct p. apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). Defined. Definition equiv_moveL_pV {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) : q @ p = r <~> q = r @ p^ := Build_Equiv _ _ (moveL_pV p q r) _. Definition isequiv_moveL_1M {A : Type} {x y : A} (p q : x = y) : IsEquiv (moveL_1M p q). Proof. destruct q. apply isequiv_concat_l. Defined. Definition isequiv_moveL_M1 {A : Type} {x y : A} (p q : x = y) : IsEquiv (moveL_M1 p q). Proof. destruct q. apply isequiv_concat_l. Defined. Definition isequiv_moveL_1V {A : Type} {x y : A} (p : x = y) (q : y = x) : IsEquiv (moveL_1V p q). Proof. destruct q. apply isequiv_concat_l. Defined. Definition isequiv_moveL_V1 {A : Type} {x y : A} (p : x = y) (q : y = x) : IsEquiv (moveL_V1 p q). Proof. destruct q. apply isequiv_concat_l. Defined. Definition isequiv_moveR_M1 {A : Type} {x y : A} (p q : x = y) : IsEquiv (moveR_M1 p q). Proof. destruct p. apply isequiv_concat_r. Defined. Global Instance isequiv_moveR_1M {A : Type} {x y : A} (p q : x = y) : IsEquiv (moveR_1M p q). Proof. destruct p. apply isequiv_concat_r. Defined. Definition equiv_moveR_1M {A : Type} {x y : A} (p q : x = y) : (1 = q @ p^) <~> (p = q) := Build_Equiv _ _ (moveR_1M p q) _. Definition isequiv_moveR_1V {A : Type} {x y : A} (p : x = y) (q : y = x) : IsEquiv (moveR_1V p q). Proof. destruct p. apply isequiv_concat_r. Defined. Definition isequiv_moveR_V1 {A : Type} {x y : A} (p : x = y) (q : y = x) : IsEquiv (moveR_V1 p q). Proof. destruct p. apply isequiv_concat_r. Defined. Definition moveR_moveL_transport_V {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) (q : transport P p u = v) : moveR_transport_p P p u v (moveL_transport_V P p u v q) = q. Proof. destruct p; reflexivity. Defined. Definition moveL_moveR_transport_p {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) (q : u = transport P p^ v) : moveL_transport_V P p u v (moveR_transport_p P p u v q) = q. Proof. destruct p; reflexivity. Defined. Global Instance isequiv_moveR_transport_p {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) : IsEquiv (moveR_transport_p P p u v). Proof. srapply isequiv_adjointify. - apply moveL_transport_V. - intro q; apply moveR_moveL_transport_V. - intro q; apply moveL_moveR_transport_p. Defined. Definition equiv_moveR_transport_p {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) : u = transport P p^ v <~> transport P p u = v := Build_Equiv _ _ (moveR_transport_p P p u v) _. Definition moveR_moveL_transport_p {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) (q : transport P p^ u = v) : moveR_transport_V P p u v (moveL_transport_p P p u v q) = q. Proof. destruct p; reflexivity. Defined. Definition moveL_moveR_transport_V {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) (q : u = transport P p v) : moveL_transport_p P p u v (moveR_transport_V P p u v q) = q. Proof. destruct p; reflexivity. Defined. Global Instance isequiv_moveR_transport_V {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) : IsEquiv (moveR_transport_V P p u v). Proof. srapply isequiv_adjointify. - apply moveL_transport_p. - intro q; apply moveR_moveL_transport_p. - intro q; apply moveL_moveR_transport_V. Defined. Definition equiv_moveR_transport_V {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) : u = transport P p v <~> transport P p^ u = v := Build_Equiv _ _ (moveR_transport_V P p u v) _. Global Instance isequiv_moveL_transport_V {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) : IsEquiv (moveL_transport_V P p u v). Proof. srapply isequiv_adjointify. - apply moveR_transport_p. - intro q; apply moveL_moveR_transport_p. - intro q; apply moveR_moveL_transport_V. Defined. Definition equiv_moveL_transport_V {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) (v : P y) : transport P p u = v <~> u = transport P p^ v := Build_Equiv _ _ (moveL_transport_V P p u v) _. Global Instance isequiv_moveL_transport_p {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) : IsEquiv (moveL_transport_p P p u v). Proof. srapply isequiv_adjointify. - apply moveR_transport_V. - intro q; apply moveL_moveR_transport_V. - intro q; apply moveR_moveL_transport_p. Defined. Definition equiv_moveL_transport_p {A : Type} (P : A -> Type) {x y : A} (p : y = x) (u : P x) (v : P y) : transport P p^ u = v <~> u = transport P p v := Build_Equiv _ _ (moveL_transport_p P p u v) _. Global Instance isequiv_moveR_equiv_M `{IsEquiv A B f} (x : A) (y : B) : IsEquiv (@moveR_equiv_M A B f _ x y). Proof. unfold moveR_equiv_M. refine (@isequiv_compose _ _ (ap f) _ _ (fun q => q @ eisretr f y) _). Defined. Definition equiv_moveR_equiv_M `{IsEquiv A B f} (x : A) (y : B) : (x = f^-1 y) <~> (f x = y) := Build_Equiv _ _ (@moveR_equiv_M A B f _ x y) _. Global Instance isequiv_moveR_equiv_V `{IsEquiv A B f} (x : B) (y : A) : IsEquiv (@moveR_equiv_V A B f _ x y). Proof. unfold moveR_equiv_V. refine (@isequiv_compose _ _ (ap f^-1) _ _ (fun q => q @ eissect f y) _). Defined. Definition equiv_moveR_equiv_V `{IsEquiv A B f} (x : B) (y : A) : (x = f y) <~> (f^-1 x = y) := Build_Equiv _ _ (@moveR_equiv_V A B f _ x y) _. Global Instance isequiv_moveL_equiv_M `{IsEquiv A B f} (x : A) (y : B) : IsEquiv (@moveL_equiv_M A B f _ x y). Proof. unfold moveL_equiv_M. refine (@isequiv_compose _ _ (ap f) _ _ (fun q => (eisretr f y)^ @ q) _). Defined. Definition equiv_moveL_equiv_M `{IsEquiv A B f} (x : A) (y : B) : (f^-1 y = x) <~> (y = f x) := Build_Equiv _ _ (@moveL_equiv_M A B f _ x y) _. Global Instance isequiv_moveL_equiv_V `{IsEquiv A B f} (x : B) (y : A) : IsEquiv (@moveL_equiv_V A B f _ x y). Proof. unfold moveL_equiv_V. refine (@isequiv_compose _ _ (ap f^-1) _ _ (fun q => (eissect f y)^ @ q) _). Defined. Definition equiv_moveL_equiv_V `{IsEquiv A B f} (x : B) (y : A) : (f y = x) <~> (y = f^-1 x) := Build_Equiv _ _ (@moveL_equiv_V A B f _ x y) _. (** *** Dependent paths *) (** Usually, a dependent path over [p:x1=x2] in [P:A->Type] between [y1:P x1] and [y2:P x2] is a path [transport P p y1 = y2] in [P x2]. However, when [P] is a path space, these dependent paths have a more convenient description: rather than transporting the left side both forwards and backwards, we transport both sides of the equation forwards, forming a sort of "naturality square". We use the same naming scheme as for the transport lemmas. *) Definition dpath_path_l {A : Type} {x1 x2 y : A} (p : x1 = x2) (q : x1 = y) (r : x2 = y) : q = p @ r <~> transport (fun x => x = y) p q = r. Proof. destruct p; simpl. exact (equiv_concat_r (concat_1p r) q). Defined. Definition dpath_path_r {A : Type} {x y1 y2 : A} (p : y1 = y2) (q : x = y1) (r : x = y2) : q @ p = r <~> transport (fun y => x = y) p q = r. Proof. destruct p; simpl. exact (equiv_concat_l (concat_p1 q)^ r). Defined. Definition dpath_path_lr {A : Type} {x1 x2 : A} (p : x1 = x2) (q : x1 = x1) (r : x2 = x2) : q @ p = p @ r <~> transport (fun x => x = x) p q = r. Proof. destruct p; simpl. transitivity (q @ 1 = r). - exact (equiv_concat_r (concat_1p r) (q @ 1)). - exact (equiv_concat_l (concat_p1 q)^ r). Defined. Definition dpath_path_Fl {A B : Type} {f : A -> B} {x1 x2 : A} {y : B} (p : x1 = x2) (q : f x1 = y) (r : f x2 = y) : q = ap f p @ r <~> transport (fun x => f x = y) p q = r. Proof. destruct p; simpl. exact (equiv_concat_r (concat_1p r) q). Defined. Definition dpath_path_Fr {A B : Type} {g : A -> B} {x : B} {y1 y2 : A} (p : y1 = y2) (q : x = g y1) (r : x = g y2) : q @ ap g p = r <~> transport (fun y => x = g y) p q = r. Proof. destruct p; simpl. exact (equiv_concat_l (concat_p1 q)^ r). Defined. Definition dpath_path_FlFr {A B : Type} {f g : A -> B} {x1 x2 : A} (p : x1 = x2) (q : f x1 = g x1) (r : f x2 = g x2) : q @ ap g p = ap f p @ r <~> transport (fun x => f x = g x) p q = r. Proof. destruct p; simpl. transitivity (q @ 1 = r). - exact (equiv_concat_r (concat_1p r) (q @ 1)). - exact (equiv_concat_l (concat_p1 q)^ r). Defined. Definition dpath_path_FFlr {A B : Type} {f : A -> B} {g : B -> A} {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = x1) (r : g (f x2) = x2) : q @ p = ap g (ap f p) @ r <~> transport (fun x => g (f x) = x) p q = r. Proof. destruct p; simpl. transitivity (q @ 1 = r). - exact (equiv_concat_r (concat_1p r) (q @ 1)). - exact (equiv_concat_l (concat_p1 q)^ r). Defined. Definition dpath_path_lFFr {A B : Type} {f : A -> B} {g : B -> A} {x1 x2 : A} (p : x1 = x2) (q : x1 = g (f x1)) (r : x2 = g (f x2)) : q @ ap g (ap f p) = p @ r <~> transport (fun x => x = g (f x)) p q = r. Proof. destruct p; simpl. transitivity (q @ 1 = r). - exact (equiv_concat_r (concat_1p r) (q @ 1)). - exact (equiv_concat_l (concat_p1 q)^ r). Defined. Definition dpath_paths2 {A : Type} {x y : A} (p : x = y) (q : idpath x = idpath x) (r : idpath y = idpath y) : (concat_1p p)^ @ whiskerR q p @ concat_1p p = (concat_p1 p)^ @ whiskerL p r @ concat_p1 p <~> transport (fun a => idpath a = idpath a) p q = r. Proof. destruct p. simpl. refine (_ oE (equiv_whiskerR _ _ 1)^-1). refine (_ oE (equiv_whiskerL 1 _ _)^-1). refine (equiv_concat_lr _ _). - symmetry; apply whiskerR_p1_1. - apply whiskerL_1p_1. Defined. (** ** Universal mapping property *) Global Instance isequiv_paths_ind `{Funext} {A : Type} (a : A) (P : forall x, (a = x) -> Type) : IsEquiv (paths_ind a P) | 0. Proof. refine (isequiv_adjointify (paths_ind a P) (fun f => f a 1) _ _). - intros f. apply path_forall; intros x. apply path_forall; intros p. destruct p; reflexivity. - intros u. reflexivity. Defined. Definition equiv_paths_ind `{Funext} {A : Type} (a : A) (P : forall x, (a = x) -> Type) : P a 1 <~> forall x p, P x p := Build_Equiv _ _ (paths_ind a P) _. Global Instance isequiv_paths_ind_r `{Funext} {A : Type} (a : A) (P : forall x, (x = a) -> Type) : IsEquiv (paths_ind_r a P) | 0. Proof. refine (isequiv_adjointify (paths_ind_r a P) (fun f => f a 1) _ _). - intros f. apply path_forall; intros x. apply path_forall; intros p. destruct p; reflexivity. - intros u. reflexivity. Defined. Definition equiv_paths_ind_r `{Funext} {A : Type} (a : A) (P : forall x, (x = a) -> Type) : P a 1 <~> forall x p, P x p := Build_Equiv _ _ (paths_ind_r a P) _. (** ** Truncation *) (** Paths reduce truncation level by one. This is essentially the definition of [IsTrunc_internal]. *) Coq-HoTT-9.0/theories/Types/Prod.v000066400000000000000000000336361474641544500167720ustar00rootroot00000000000000(** * Theorems about cartesian products *) Require Import Basics.Overture Basics.Equivalences Basics.PathGroupoids Basics.Tactics Basics.Trunc Basics.Decidable Basics.Iff. Require Import Types.Empty. Local Open Scope path_scope. Local Set Universe Minimization ToSet. Generalizable Variables X A B f g n. Scheme prod_ind := Induction for prod Sort Type. Arguments prod_ind {A B} P f p. (** ** Unpacking *) (** Sometimes we would like to prove [Q u] where [u : A * B] by writing [u] as a pair [(fst u ; snd u)]. This is accomplished by [unpack_prod]. We want tight control over the proof, so we just write it down even though is looks a bit scary. *) Definition unpack_prod `{P : A * B -> Type} (u : A * B) : P (fst u, snd u) -> P u := idmap. Arguments unpack_prod / . (** Now we write down the reverse. *) Definition pack_prod `{P : A * B -> Type} (u : A * B) : P u -> P (fst u, snd u) := idmap. Arguments pack_prod / . (** ** Eta conversion *) Definition eta_prod `(z : A * B) : (fst z, snd z) = z := 1. Arguments eta_prod / . (** ** Paths *) (** With this version of the function, we often have to give [z] and [z'] explicitly, so we make them explicit arguments. *) Definition path_prod_uncurried {A B : Type} (z z' : A * B) (pq : (fst z = fst z') * (snd z = snd z')) : (z = z'). Proof. change ((fst z, snd z) = (fst z', snd z')). case (fst pq). case (snd pq). reflexivity. Defined. (** This is the curried one you usually want to use in practice. We define it in terms of the uncurried one, since it's the uncurried one that is proven below to be an equivalence. *) Definition path_prod {A B : Type} (z z' : A * B) : (fst z = fst z') -> (snd z = snd z') -> (z = z') := fun p q => path_prod_uncurried z z' (p,q). (** This version produces only paths between pairs, as opposed to paths between arbitrary inhabitants of product types. But it has the advantage that the components of those pairs can more often be inferred. *) Definition path_prod' {A B : Type} {x x' : A} {y y' : B} : (x = x') -> (y = y') -> ((x,y) = (x',y')) := fun p q => path_prod (x,y) (x',y') p q. (** Now we show how these things compute. *) Definition ap_fst_path_prod {A B : Type} {z z' : A * B} (p : fst z = fst z') (q : snd z = snd z') : ap fst (path_prod _ _ p q) = p. Proof. change z with (fst z, snd z). change z' with (fst z', snd z'). destruct p, q. reflexivity. Defined. Definition ap_fst_path_prod' {A B : Type} {x x' : A} {y y' : B} (p : x = x') (q : y = y') : ap fst (path_prod' p q) = p. Proof. apply ap_fst_path_prod. Defined. Definition ap_snd_path_prod {A B : Type} {z z' : A * B} (p : fst z = fst z') (q : snd z = snd z') : ap snd (path_prod _ _ p q) = q. Proof. change z with (fst z, snd z). change z' with (fst z', snd z'). destruct p, q. reflexivity. Defined. Definition ap_snd_path_prod' {A B : Type} {x x' : A} {y y' : B} (p : x = x') (q : y = y') : ap snd (path_prod' p q) = q. Proof. apply ap_snd_path_prod. Defined. Definition eta_path_prod {A B : Type} {z z' : A * B} (p : z = z') : path_prod _ _(ap fst p) (ap snd p) = p. Proof. destruct p. reflexivity. Defined. Definition ap_path_prod {A B C : Type} (f : A -> B -> C) {z z' : A * B} (p : fst z = fst z') (q : snd z = snd z') : ap (fun z => f (fst z) (snd z)) (path_prod _ _ p q) = ap011 f p q. Proof. destruct z, z'; simpl in *; destruct p, q; reflexivity. Defined. (** Now we show how these compute with transport. *) Lemma transport_path_prod_uncurried {A B} (P : A * B -> Type) {x y : A * B} (H : (fst x = fst y) * (snd x = snd y)) (Px : P x) : transport P (path_prod_uncurried _ _ H) Px = transport (fun x => P (x, snd y)) (fst H) (transport (fun y => P (fst x, y)) (snd H) Px). Proof. destruct x, y, H; simpl in *. path_induction. reflexivity. Defined. Definition transport_path_prod {A B} (P : A * B -> Type) {x y : A * B} (HA : fst x = fst y) (HB : snd x = snd y) (Px : P x) : transport P (path_prod _ _ HA HB) Px = transport (fun x => P (x, snd y)) HA (transport (fun y => P (fst x, y)) HB Px) := transport_path_prod_uncurried P (HA, HB) Px. Definition transport_path_prod' {A B} (P : A * B -> Type) {x y : A} {x' y' : B} (HA : x = y) (HB : x' = y') (Px : P (x,x')) : transport P (path_prod' HA HB) Px = transport (fun x => P (x, y')) HA (transport (fun y => P (x, y)) HB Px) := @transport_path_prod _ _ P (x, x') (y, y') HA HB Px. (** This lets us identify the path space of a product type, up to equivalence. *) Global Instance isequiv_path_prod {A B : Type} {z z' : A * B} : IsEquiv (path_prod_uncurried z z') | 0. Proof. refine (Build_IsEquiv _ _ _ (fun r => (ap fst r, ap snd r)) eta_path_prod (fun pq => path_prod' (ap_fst_path_prod (fst pq) (snd pq)) (ap_snd_path_prod (fst pq) (snd pq))) _). destruct z as [x y], z' as [x' y']. intros [p q]; simpl in p, q. destruct p, q; reflexivity. Defined. Definition equiv_path_prod {A B : Type} (z z' : A * B) : (fst z = fst z') * (snd z = snd z') <~> (z = z') := Build_Equiv _ _ (path_prod_uncurried z z') _. (** Path algebra *) (** Composition. The next three lemma are displayed equations in section 2.6 of the book, but they have no numbers so we can't put them into [HoTTBook.v]. *) Definition path_prod_pp {A B : Type} (z z' z'' : A * B) (p : fst z = fst z') (p' : fst z' = fst z'') (q : snd z = snd z') (q' : snd z' = snd z'') : path_prod z z'' (p @ p') (q @ q') = path_prod z z' p q @ path_prod z' z'' p' q'. Proof. destruct z, z', z''; simpl in *; destruct p, p', q, q'. reflexivity. Defined. (** Associativity *) Definition path_prod_pp_p {A B : Type} (u v z w : A * B) (p : fst u = fst v) (q : fst v = fst z) (r : fst z = fst w) (p' : snd u = snd v) (q' : snd v = snd z) (r' : snd z = snd w) : path_prod_pp u z w (p @ q) r (p' @ q') r' @ whiskerR (path_prod_pp u v z p q p' q') (path_prod z w r r') @ concat_pp_p (path_prod u v p p') (path_prod v z q q') (path_prod z w r r') = ap011 (path_prod u w) (concat_pp_p p q r) (concat_pp_p p' q' r') @ path_prod_pp u v w p (q @ r) p' (q' @ r') @ whiskerL (path_prod u v p p') (path_prod_pp v z w q r q' r'). Proof. destruct u, v, z, w; simpl in *; destruct p, p', q, q', r, r'. reflexivity. Defined. (** Inversion *) Definition path_prod_V {A B : Type} (u v: A * B) (p : fst u = fst v) (q : snd u = snd v) : path_prod v u p^ q^ = (path_prod u v p q)^. Proof. destruct u, v; simpl in *; destruct p, q. reflexivity. Defined. (** ** Transport *) Definition transport_prod {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a') (z : P a * Q a) : transport (fun a => P a * Q a) p z = (p # (fst z), p # (snd z)) := match p with idpath => 1 end. (** ** Functorial action *) Definition functor_prod {A A' B B' : Type} (f:A->A') (g:B->B') : A * B -> A' * B' := fun z => (f (fst z), g (snd z)). Definition ap_functor_prod {A A' B B' : Type} (f:A->A') (g:B->B') (z z' : A * B) (p : fst z = fst z') (q : snd z = snd z') : ap (functor_prod f g) (path_prod _ _ p q) = path_prod (functor_prod f g z) (functor_prod f g z') (ap f p) (ap g q). Proof. destruct z as [a b]; destruct z' as [a' b']. simpl in p, q. destruct p, q. reflexivity. Defined. (** ** Equivalences *) Global Instance isequiv_functor_prod `{IsEquiv A A' f} `{IsEquiv B B' g} : IsEquiv (functor_prod f g) | 1000. Proof. refine (Build_IsEquiv _ _ (functor_prod f g) (functor_prod f^-1 g^-1) (fun z => path_prod' (eisretr f (fst z)) (eisretr g (snd z)) @ eta_prod z) (fun w => path_prod' (eissect f (fst w)) (eissect g (snd w)) @ eta_prod w) _). intros [a b]; simpl. unfold path_prod'. rewrite !concat_p1. rewrite ap_functor_prod. rewrite !eisadj. reflexivity. Defined. Definition equiv_functor_prod `{IsEquiv A A' f} `{IsEquiv B B' g} : A * B <~> A' * B'. Proof. exists (functor_prod f g). exact _. (* i.e., search the context for instances *) Defined. Definition equiv_functor_prod' {A A' B B' : Type} (f : A <~> A') (g : B <~> B') : A * B <~> A' * B'. Proof. exists (functor_prod f g). exact _. Defined. Notation "f *E g" := (equiv_functor_prod' f g) : equiv_scope. Definition equiv_functor_prod_l {A B B' : Type} (g : B <~> B') : A * B <~> A * B' := 1 *E g. Definition equiv_functor_prod_r {A A' B : Type} (f : A <~> A') : A * B <~> A' * B := f *E 1. (** ** Logical equivalences *) Definition iff_functor_prod {A A' B B' : Type} (f : A <-> A') (g : B <-> B') : A * B <-> A' * B' := (functor_prod (fst f) (fst g) , functor_prod (snd f) (snd g)). (** ** Symmetry *) (** This is a special property of [prod], of course, not an instance of a general family of facts about types. *) Definition equiv_prod_symm (A B : Type) : A * B <~> B * A. Proof. make_equiv. Defined. (** ** Associativity *) (** This, too, is a special property of [prod], of course, not an instance of a general family of facts about types. *) Definition equiv_prod_assoc (A B C : Type) : A * (B * C) <~> (A * B) * C. Proof. make_equiv. Defined. (** ** Unit and annihilation *) Definition prod_empty_r@{u} (X : Type@{u}) : X * Empty <~> Empty := (Build_Equiv@{u u} _ _ snd _). Definition prod_empty_l@{u} (X : Type@{u}) : Empty * X <~> Empty := (Build_Equiv@{u u} _ _ fst _). Definition prod_unit_r X : X * Unit <~> X. Proof. refine (Build_Equiv _ _ fst _). simple refine (Build_IsEquiv _ _ _ (fun x => (x,tt)) _ _ _). - intros x; reflexivity. - intros [x []]; reflexivity. - intros [x []]; reflexivity. Defined. Definition prod_unit_l X : Unit * X <~> X. Proof. refine (Build_Equiv _ _ snd _). simple refine (Build_IsEquiv _ _ _ (fun x => (tt,x)) _ _ _). - intros x; reflexivity. - intros [[] x]; reflexivity. - intros [[] x]; reflexivity. Defined. (** ** Universal mapping properties *) (** Ordinary universal mapping properties are expressed as equivalences of sets or spaces of functions. In type theory, we can go beyond this and express an equivalence of types of *dependent* functions. Moreover, because the product type can expressed both positively and negatively, it has both a left universal property and a right one. *) (* First the positive universal property. *) Global Instance isequiv_prod_ind `(P : A * B -> Type) : IsEquiv (prod_ind P) | 0 := Build_IsEquiv _ _ (prod_ind P) (fun f x y => f (x, y)) (fun _ => 1) (fun _ => 1) (fun _ => 1). Definition equiv_prod_ind `(P : A * B -> Type) : (forall (a : A) (b : B), P (a, b)) <~> (forall p : A * B, P p) := Build_Equiv _ _ (prod_ind P) _. (* The non-dependent version, which is a special case, is the currying equivalence. *) Definition equiv_uncurry (A B C : Type) : (A -> B -> C) <~> (A * B -> C) := equiv_prod_ind (fun _ => C). (* Now the negative universal property. *) Definition prod_coind_uncurried `{A : X -> Type} `{B : X -> Type} : (forall x, A x) * (forall x, B x) -> (forall x, A x * B x) := fun fg x => (fst fg x, snd fg x). Definition prod_coind `(f : forall x:X, A x) `(g : forall x:X, B x) : forall x, A x * B x := prod_coind_uncurried (f, g). Global Instance isequiv_prod_coind `(A : X -> Type) (B : X -> Type) : IsEquiv (@prod_coind_uncurried X A B) | 0 := Build_IsEquiv _ _ (@prod_coind_uncurried X A B) (fun h => (fun x => fst (h x), fun x => snd (h x))) (fun _ => 1) (fun _ => 1) (fun _ => 1). Definition equiv_prod_coind `(A : X -> Type) (B : X -> Type) : ((forall x, A x) * (forall x, B x)) <~> (forall x, A x * B x) := Build_Equiv _ _ (@prod_coind_uncurried X A B) _. (** ** Products preserve truncation *) Global Instance istrunc_prod `{IsTrunc n A} `{IsTrunc n B} : IsTrunc n (A * B) | 100. Proof. generalize dependent B; generalize dependent A. simple_induction n n IH; simpl; (intros A ? B ?). { apply (Build_Contr _ (center A, center B)). intros z; apply path_prod; apply contr. } apply istrunc_S. intros x y. exact (istrunc_equiv_istrunc _ (equiv_path_prod x y)). Defined. Global Instance contr_prod `{CA : Contr A} `{CB : Contr B} : Contr (A * B) | 100 := istrunc_prod. (** ** Decidability *) Global Instance decidable_prod {A B : Type} `{Decidable A} `{Decidable B} : Decidable@{k} (A * B). Proof. destruct (dec A) as [x1|y1]; destruct (dec B) as [x2|y2]. - exact (inl@{k k} (x1,x2)). - apply inr@{k k}; intros [_ x2]; exact (y2 x2). - apply inr@{k k}; intros [x1 _]; exact (y1 x1). - apply inr@{k k}; intros [x1 _]; exact (y1 x1). Defined. (** Interaction of ap and uncurry *) (* The function in ap011 can be uncurried *) Definition ap_uncurry {A B C} (f : A -> B -> C) {a a' : A} (p : a = a') {b b' : B} (q : b = b') : ap (uncurry f) (path_prod' p q) = ap011 f p q. Proof. by destruct q, p. Defined. (** Fibers *) (** ** Fibers of [functor_prod] *) Definition hfiber_functor_prod {A B C D : Type} (f : A -> B) (g : C -> D) y : hfiber (functor_prod f g) y <~> (hfiber f (fst y) * hfiber g (snd y)). Proof. unfold functor_prod. snrefine (equiv_adjointify _ _ _ _). - exact (fun x => ((fst x.1; ap fst x.2), (snd x.1; ap snd x.2))). - refine (fun xs => (((fst xs).1, (snd xs).1); _)). apply Prod.path_prod;simpl. + exact (fst xs).2. + exact (snd xs).2. - destruct y as [y1 y2]; intros [[x1 p1] [x2 p2]]. simpl in *. destruct p1,p2. reflexivity. - intros [[x1 x2] p]. destruct p;cbn. reflexivity. Defined. Global Instance istruncmap_functor_prod (n : trunc_index) {A B C D : Type} (f : A -> B) (g : C -> D) `{!IsTruncMap n f} `{!IsTruncMap n g} : IsTruncMap n (Prod.functor_prod f g) := fun y => istrunc_equiv_istrunc _ (hfiber_functor_prod _ _ _)^-1. Coq-HoTT-9.0/theories/Types/Sigma.v000066400000000000000000000646061474641544500171270ustar00rootroot00000000000000(** * Theorems about Sigma-types (dependent sums) *) Require Import HoTT.Basics. Require Import Types.Arrow Types.Paths. Local Open Scope path_scope. Generalizable Variables X A B C f g n. (** In homotopy type theory, we think of elements of [Type] as spaces, homotopy types, or weak omega-groupoids. A type family [P : A -> Type] corresponds to a fibration whose base is [A] and whose fiber over [x] is [P x]. From such a [P] we can build a total space over the base space [A] so that the fiber over [x : A] is [P x]. This is just Coq's dependent sum construction, written as [sig P] or [{x : A & P x}]. The elements of [{x : A & P x}] are pairs, written [exist P x y] in Coq, where [x : A] and [y : P x]. In [Overture.v], we defined the notation [(x; y)] to mean [exist _ x y]. The base and fiber components of a point in the total space are extracted with the two projections [pr1] and [pr2]. *) (** ** Eta conversion *) Definition eta_sigma `{P : A -> Type} (u : sig P) : (u.1; u.2) = u := 1. Arguments eta_sigma / . Definition eta2_sigma `{P : forall (a : A) (b : B a), Type} (u : sig (fun a => sig (P a))) : (u.1; u.2.1; u.2.2) = u := 1. Arguments eta2_sigma / . Definition eta3_sigma `{P : forall (a : A) (b : B a) (c : C a b), Type} (u : sig (fun a => sig (fun b => sig (P a b)))) : (u.1; u.2.1; u.2.2.1; u.2.2.2) = u := 1. Arguments eta3_sigma / . (** ** Paths *) (** A path in a total space is commonly shown component wise. Because we use this over and over, we write down the proofs by hand to make sure they are what we think they should be. *) (** With this version of the function, we often have to give [u] and [v] explicitly, so we make them explicit arguments. *) Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sig P) (pq : {p : u.1 = v.1 & p # u.2 = v.2}) : u = v := match pq.2 in (_ = v2) return u = (v.1; v2) with | 1 => match pq.1 as p in (_ = v1) return u = (v1; p # u.2) with | 1 => 1 end end. (** This is the curried one you usually want to use in practice. We define it in terms of the uncurried one, since it's the uncurried one that is proven below to be an equivalence. *) Definition path_sigma {A : Type} (P : A -> Type) (u v : sig P) (p : u.1 = v.1) (q : p # u.2 = v.2) : u = v := path_sigma_uncurried P u v (p;q). (** A contravariant instance of [path_sigma_uncurried] *) Definition path_sigma_uncurried_contra {A : Type} (P : A -> Type) (u v : sig P) (pq : {p : u.1 = v.1 & u.2 = p^ # v.2}) : u = v := (path_sigma_uncurried P v u (pq.1^;pq.2^))^. (** A variant of [Forall.dpath_forall] from which uses dependent sums to package things. It cannot go into [Forall] because [Sigma] depends on [Forall]. *) Definition dpath_forall' {A : Type } (P : A -> Type) (Q: sig P -> Type) {x y : A} (h : x = y) (f : forall p, Q (x ; p)) (g : forall p, Q (y ; p)) : (forall p, transport Q (path_sigma P (x ; p) (y; _) h 1) (f p) = g (h # p)) <~> (forall p, transportD P (fun x => fun p => Q ( x ; p)) h p (f p) = g (transport P h p)). Proof. destruct h. apply 1%equiv. Defined. (** This version produces only paths between pairs, as opposed to paths between arbitrary inhabitants of dependent sum types. But it has the advantage that the components of those pairs can more often be inferred, so we make them implicit arguments. *) Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'} (p : x = x') (q : p # y = y') : (x;y) = (x';y') := path_sigma P (x;y) (x';y') p q. (** Projections of paths from a total space. *) Definition pr1_path `{P : A -> Type} {u v : sig P} (p : u = v) : u.1 = v.1 := ap pr1 p. (* match p with idpath => 1 end. *) Notation "p ..1" := (pr1_path p) : fibration_scope. Definition pr2_path `{P : A -> Type} {u v : sig P} (p : u = v) : p..1 # u.2 = v.2 := (transport_compose P pr1 p u.2)^ @ (@apD {x:A & P x} _ pr2 _ _ p). Notation "p ..2" := (pr2_path p) : fibration_scope. (** Now we show how these things compute. *) Definition pr1_path_sigma_uncurried `{P : A -> Type} {u v : sig P} (pq : { p : u.1 = v.1 & p # u.2 = v.2 }) : (path_sigma_uncurried _ _ _ pq)..1 = pq.1. Proof. destruct u as [u1 u2]; destruct v as [v1 v2]; simpl in *. destruct pq as [p q]. destruct p; simpl in q; destruct q; reflexivity. Defined. Definition pr2_path_sigma_uncurried `{P : A -> Type} {u v : sig P} (pq : { p : u.1 = v.1 & p # u.2 = v.2 }) : (path_sigma_uncurried _ _ _ pq)..2 = ap (fun s => transport P s u.2) (pr1_path_sigma_uncurried pq) @ pq.2. Proof. destruct u as [u1 u2]; destruct v as [v1 v2]; simpl in *. destruct pq as [p q]. destruct p; simpl in q; destruct q; reflexivity. Defined. Definition eta_path_sigma_uncurried `{P : A -> Type} {u v : sig P} (p : u = v) : path_sigma_uncurried _ _ _ (p..1; p..2) = p. Proof. destruct p. reflexivity. Defined. Lemma transport_pr1_path_sigma_uncurried `{P : A -> Type} {u v : sig P} (pq : { p : u.1 = v.1 & transport P p u.2 = v.2 }) Q : transport (fun x => Q x.1) (@path_sigma_uncurried A P u v pq) = transport _ pq.1. Proof. destruct pq as [p q], u, v; simpl in *. destruct p, q; simpl in *. reflexivity. Defined. Definition pr1_path_sigma `{P : A -> Type} {u v : sig P} (p : u.1 = v.1) (q : p # u.2 = v.2) : (path_sigma _ _ _ p q)..1 = p := pr1_path_sigma_uncurried (p; q). (* Writing it the other way can help [rewrite]. *) Definition ap_pr1_path_sigma {A:Type} {P : A -> Type} {u v : sig P} (p : u.1 = v.1) (q : p # u.2 = v.2) : ap pr1 (path_sigma _ _ _ p q) = p := pr1_path_sigma p q. Definition pr2_path_sigma `{P : A -> Type} {u v : sig P} (p : u.1 = v.1) (q : p # u.2 = v.2) : (path_sigma _ _ _ p q)..2 = ap (fun s => transport P s u.2) (pr1_path_sigma p q) @ q := pr2_path_sigma_uncurried (p; q). Definition eta_path_sigma `{P : A -> Type} {u v : sig P} (p : u = v) : path_sigma _ _ _ (p..1) (p..2) = p := eta_path_sigma_uncurried p. Definition transport_pr1_path_sigma `{P : A -> Type} {u v : sig P} (p : u.1 = v.1) (q : p # u.2 = v.2) Q : transport (fun x => Q x.1) (@path_sigma A P u v p q) = transport _ p := transport_pr1_path_sigma_uncurried (p; q) Q. (** This lets us identify the path space of a sigma-type, up to equivalence. *) Global Instance isequiv_path_sigma `{P : A -> Type} {u v : sig P} : IsEquiv (path_sigma_uncurried P u v) | 0. Proof. simple refine (Build_IsEquiv _ _ _ (fun r => (r..1; r..2)) eta_path_sigma _ _). all: destruct u, v; intros [p q]. all: simpl in *. all: destruct q, p; simpl in *. all: reflexivity. Defined. Definition equiv_path_sigma `(P : A -> Type) (u v : sig P) : {p : u.1 = v.1 & p # u.2 = v.2} <~> (u = v) := Build_Equiv _ _ (path_sigma_uncurried P u v) _. (* A contravariant version of [isequiv_path_sigma'] *) Global Instance isequiv_path_sigma_contra `{P : A -> Type} {u v : sig P} : IsEquiv (path_sigma_uncurried_contra P u v) | 0. Proof. apply (isequiv_adjointify (path_sigma_uncurried_contra P u v) (fun r => match r with idpath => (1; 1) end)). - by intro r; induction r; destruct u as [u1 u2]; reflexivity. - destruct u, v; intros [p q]. simpl in *. destruct p; simpl in q. destruct q; reflexivity. Defined. (* A contravariant version of [equiv_path_sigma] *) Definition equiv_path_sigma_contra {A : Type} `(P : A -> Type) (u v : sig P) : {p : u.1 = v.1 & u.2 = p^ # v.2} <~> (u = v) := Build_Equiv _ _ (path_sigma_uncurried_contra P u v) _. (** This identification respects path concatenation. *) Definition path_sigma_pp_pp {A : Type} (P : A -> Type) {u v w : sig P} (p1 : u.1 = v.1) (q1 : p1 # u.2 = v.2) (p2 : v.1 = w.1) (q2 : p2 # v.2 = w.2) : path_sigma P u w (p1 @ p2) (transport_pp P p1 p2 u.2 @ ap (transport P p2) q1 @ q2) = path_sigma P u v p1 q1 @ path_sigma P v w p2 q2. Proof. destruct u, v, w. simpl in *. destruct p1, p2, q1, q2. reflexivity. Defined. Definition path_sigma_pp_pp' {A : Type} (P : A -> Type) {u1 v1 w1 : A} {u2 : P u1} {v2 : P v1} {w2 : P w1} (p1 : u1 = v1) (q1 : p1 # u2 = v2) (p2 : v1 = w1) (q2 : p2 # v2 = w2) : path_sigma' P (p1 @ p2) (transport_pp P p1 p2 u2 @ ap (transport P p2) q1 @ q2) = path_sigma' P p1 q1 @ path_sigma' P p2 q2 := @path_sigma_pp_pp A P (u1;u2) (v1;v2) (w1;w2) p1 q1 p2 q2. Definition path_sigma_p1_1p' {A : Type} (P : A -> Type) {u1 v1 : A} {u2 : P u1} {v2 : P v1} (p : u1 = v1) (q : p # u2 = v2) : path_sigma' P p q = path_sigma' P p 1 @ path_sigma' P 1 q. Proof. destruct p, q. reflexivity. Defined. (** [pr1_path] also commutes with the groupoid structure. *) Definition pr1_path_1 {A : Type} {P : A -> Type} (u : sig P) : (idpath u) ..1 = idpath (u .1) := 1. Definition pr1_path_pp {A : Type} {P : A -> Type} {u v w : sig P} (p : u = v) (q : v = w) : (p @ q) ..1 = (p ..1) @ (q ..1) := ap_pp _ _ _. Definition pr1_path_V {A : Type} {P : A -> Type} {u v : sig P} (p : u = v) : p^ ..1 = (p ..1)^ := ap_V _ _. (** Applying [exist] to one argument is the same as [path_sigma] with reflexivity in the first place. *) Definition ap_exist {A : Type} (P : A -> Type) (x : A) (y1 y2 : P x) (q : y1 = y2) : ap (exist P x) q = path_sigma' P 1 q. Proof. destruct q; reflexivity. Defined. (** Dependent transport is the same as transport along a [path_sigma]. *) Definition transportD_is_transport {A:Type} (B:A->Type) (C:sig B -> Type) (x1 x2:A) (p:x1=x2) (y:B x1) (z:C (x1;y)) : transportD B (fun a b => C (a;b)) p y z = transport C (path_sigma' B p 1) z. Proof. destruct p. reflexivity. Defined. (** Doubly dependent transport is the same as transport along a [path_sigma]. *) Definition transportDD_is_transport {A : Type} (B : A -> Type) (C : forall a : A, B a -> Type) {a1 a2 : A} (pA : a1 = a2) {b1 : B a1} {b2 : B a2} (pB : transport B pA b1 = b2) (c1 : C a1 b1) : transportDD B C pA pB c1 = transport (fun (ab : sig B) => C ab.1 ab.2) (path_sigma' B pA pB) c1. Proof. by destruct pB, pA. Defined. (** Applying a two variable function to a [path_sigma]. *) Definition ap_path_sigma {A B} (P : A -> Type) (F : forall a : A, P a -> B) {x x' : A} {y : P x} {y' : P x'} (p : x = x') (q : p # y = y') : ap (sig_rec F) (path_sigma' P p q) = ap _ (moveL_transport_V _ p _ _ q) @ (transport_arrow_toconst _ _ _)^ @ ap10 (apD F p) y'. Proof. destruct p, q; reflexivity. Defined. (* Remark: this is also equal to: *) (* = ap10 (apD F p^)^ y @ transport_arrow_toconst _ _ _ *) (* @ ap (F x') (transport2 _ (inv_V p) y @ q). *) (** And we can simplify when the first equality is [1]. *) Lemma ap_path_sigma_1p {A B : Type} {P : A -> Type} (F : forall a, P a -> B) (a : A) {x y : P a} (p : x = y) : ap (fun w => F w.1 w.2) (path_sigma' P 1 p) = ap (fun z => F a z) p. Proof. destruct p; reflexivity. Defined. (** Applying a function constructed with [sig_rec] to a [path_sigma] can be computed. Technically this computation should probably go by way of a 2-variable [ap], and should be done in the dependently typed case. *) Definition ap_sig_rec_path_sigma {A : Type} (P : A -> Type) {Q : Type} (x1 x2 : A) (p : x1 = x2) (y1 : P x1) (y2 : P x2) (q : p # y1 = y2) (d : forall a, P a -> Q) : ap (sig_rec d) (path_sigma' P p q) = (transport_const p _)^ @ (ap ((transport (fun _ => Q) p) o (d x1)) (transport_Vp _ p y1))^ @ (transport_arrow p _ _)^ @ ap10 (apD d p) (p # y1) @ ap (d x2) q. Proof. destruct p. destruct q. reflexivity. Defined. (** A path between paths in a total space is commonly shown component wise. *) (** With this version of the function, we often have to give [u] and [v] explicitly, so we make them explicit arguments. *) Definition path_path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sig P) (p q : u = v) (rs : {r : p..1 = q..1 & transport (fun x => transport P x u.2 = v.2) r p..2 = q..2}) : p = q. Proof. destruct rs, p, u. etransitivity; [ | apply eta_path_sigma ]. path_induction. reflexivity. Defined. (** This is the curried one you usually want to use in practice. We define it in terms of the uncurried one, since it's the uncurried one that is proven below to be an equivalence. *) Definition path_path_sigma {A : Type} (P : A -> Type) (u v : sig P) (p q : u = v) (r : p..1 = q..1) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2) : p = q := path_path_sigma_uncurried P u v p q (r; s). (** ** Transport *) (** The concrete description of transport in sigmas (and also pis) is rather trickier than in the other types. In particular, these cannot be described just in terms of transport in simpler types; they require also the dependent transport [transportD]. In particular, this indicates why "transport" alone cannot be fully defined by induction on the structure of types, although Id-elim/transportD can be (cf. Observational Type Theory). A more thorough set of lemmas, along the lines of the present ones but dealing with Id-elim rather than just transport, might be nice to have eventually? *) Definition transport_sigma {A : Type} {B : A -> Type} {C : forall a:A, B a -> Type} {x1 x2 : A} (p : x1 = x2) (yz : { y : B x1 & C x1 y }) : transport (fun x => { y : B x & C x y }) p yz = (p # yz.1 ; transportD _ _ p yz.1 yz.2). Proof. destruct p. destruct yz as [y z]. reflexivity. Defined. (** The special case when the second variable doesn't depend on the first is simpler. *) Definition transport_sigma' {A B : Type} {C : A -> B -> Type} {x1 x2 : A} (p : x1 = x2) (yz : { y : B & C x1 y }) : transport (fun x => { y : B & C x y }) p yz = (yz.1 ; transport (fun x => C x yz.1) p yz.2). Proof. destruct p. destruct yz. reflexivity. Defined. (** Or if the second variable contains a first component that doesn't depend on the first. Need to think about the naming of these. *) Definition transport_sigma_' {A : Type} {B C : A -> Type} {D : forall a:A, B a -> C a -> Type} {x1 x2 : A} (p : x1 = x2) (yzw : { y : B x1 & { z : C x1 & D x1 y z } }) : transport (fun x => { y : B x & { z : C x & D x y z } }) p yzw = (p # yzw.1 ; p # yzw.2.1 ; transportD2 _ _ _ p yzw.1 yzw.2.1 yzw.2.2). Proof. destruct p. reflexivity. Defined. (** ** Functorial action *) Definition functor_sigma `{P : A -> Type} `{Q : B -> Type} (f : A -> B) (g : forall a, P a -> Q (f a)) : sig P -> sig Q := fun u => (f u.1 ; g u.1 u.2). Definition ap_functor_sigma `{P : A -> Type} `{Q : B -> Type} (f : A -> B) (g : forall a, P a -> Q (f a)) (u v : sig P) (p : u.1 = v.1) (q : p # u.2 = v.2) : ap (functor_sigma f g) (path_sigma P u v p q) = path_sigma Q (functor_sigma f g u) (functor_sigma f g v) (ap f p) ((transport_compose Q f p (g u.1 u.2))^ @ (@ap_transport _ P (fun x => Q (f x)) _ _ p g u.2)^ @ ap (g v.1) q). Proof. destruct u as [u1 u2]; destruct v as [v1 v2]; simpl in p, q. destruct p; simpl in q. destruct q. reflexivity. Defined. (** ** Equivalences *) (** The converse to [isequiv_functor_sigma] when [f] is [idmap] is [isequiv_from_functor_sigma] in Types/Equiv.v, which also contains Theorem 4.7.7 *) Global Instance isequiv_functor_sigma `{P : A -> Type} `{Q : B -> Type} `{IsEquiv A B f} `{forall a, @IsEquiv (P a) (Q (f a)) (g a)} : IsEquiv (functor_sigma f g) | 1000. Proof. refine (isequiv_adjointify (functor_sigma f g) (functor_sigma (f^-1) (fun x y => ((g (f^-1 x))^-1 ((eisretr f x)^ # y)))) _ _); intros [x y]. - refine (path_sigma' _ (eisretr f x) _); simpl. abstract ( rewrite (eisretr (g (f^-1 x))); apply transport_pV ). - refine (path_sigma' _ (eissect f x) _); simpl. refine ((ap_transport (eissect f x) (fun x' => (g x') ^-1) (transport Q (eisretr f (f x)) ^ (g x y)))^ @ _). abstract ( rewrite transport_compose, eisadj, transport_pV; apply eissect ). Defined. Definition equiv_functor_sigma `{P : A -> Type} `{Q : B -> Type} (f : A -> B) `{IsEquiv A B f} (g : forall a, P a -> Q (f a)) `{forall a, @IsEquiv (P a) (Q (f a)) (g a)} : sig P <~> sig Q := Build_Equiv _ _ (functor_sigma f g) _. Definition equiv_functor_sigma' `{P : A -> Type} `{Q : B -> Type} (f : A <~> B) (g : forall a, P a <~> Q (f a)) : sig P <~> sig Q := equiv_functor_sigma f g. Definition equiv_functor_sigma_id `{P : A -> Type} `{Q : A -> Type} (g : forall a, P a <~> Q a) : sig P <~> sig Q := equiv_functor_sigma' 1 g. Definition equiv_functor_sigma_pb {A B : Type} {Q : B -> Type} (f : A <~> B) : sig (Q o f) <~> sig Q := equiv_functor_sigma f (fun a => 1%equiv). (** Lemma 3.11.9(i): Summing up a contractible family of types does nothing. *) Global Instance isequiv_pr1_contr {A} {P : A -> Type} `{forall a, Contr (P a)} : IsEquiv (@pr1 A P) | 100. Proof. refine (isequiv_adjointify (@pr1 A P) (fun a => (a ; center (P a))) _ _). - intros a; reflexivity. - intros [a p]. refine (path_sigma' P 1 (contr _)). Defined. Definition equiv_sigma_contr {A : Type} (P : A -> Type) `{forall a, Contr (P a)} : sig P <~> A := Build_Equiv _ _ pr1 _. (** Lemma 3.11.9(ii): Dually, summing up over a contractible type does nothing. *) Definition equiv_contr_sigma {A : Type} (P : A -> Type) `{Contr A} : { x : A & P x } <~> P (center A). Proof. refine (equiv_adjointify (fun xp => (contr xp.1)^ # xp.2) (fun p => (center A ; p)) _ _). - intros p; simpl. exact (ap (fun q => q # p) (path_contr _ 1)). - intros [a p]. refine (path_sigma' _ (contr a) _). apply transport_pV. Defined. (** ** Associativity *) (** All of the following lemmas are proven easily with the [make_equiv] tactic. If you have a more complicated rearrangement of sigma-types to do, it is usually possible to do it by putting together these equivalences, but it is often simpler and faster to just use [make_equiv] directly. *) Definition equiv_sigma_assoc `(P : A -> Type) (Q : {a : A & P a} -> Type) : {a : A & {p : P a & Q (a;p)}} <~> sig Q. Proof. make_equiv. Defined. Definition equiv_sigma_assoc' `(P : A -> Type) (Q : forall a : A, P a -> Type) : {a : A & {p : P a & Q a p}} <~> {ap : sig P & Q ap.1 ap.2}. Proof. make_equiv. Defined. Definition equiv_sigma_prod `(Q : (A * B) -> Type) : {a : A & {b : B & Q (a,b)}} <~> sig Q. Proof. make_equiv. Defined. Definition equiv_sigma_prod' `(Q : A -> B -> Type) : {a : A & {b : B & Q a b}} <~> sig (fun ab => Q (fst ab) (snd ab)). Proof. make_equiv. Defined. Definition equiv_sigma_prod0 (A B : Type) : {a : A & B} <~> A * B. Proof. make_equiv. Defined. Definition equiv_sigma_prod1 (A B C : Type) : {a : A & {b : B & C}} <~> A * B * C := ltac:(make_equiv). Definition equiv_sigma_prod_prod {X Y : Type} (P : X -> Type) (Q : Y -> Type) : {z : X * Y & (P (fst z)) * (Q (snd z))} <~> (sig P) * (sig Q) := ltac:(make_equiv). (** ** Symmetry *) Definition equiv_sigma_symm `(P : A -> B -> Type) : {a : A & {b : B & P a b}} <~> {b : B & {a : A & P a b}}. Proof. make_equiv. Defined. Definition equiv_sigma_symm' {A : Type} `(P : A -> Type) `(Q : A -> Type) : { ap : { a : A & P a } & Q ap.1 } <~> { aq : { a : A & Q a } & P aq.1 }. Proof. make_equiv. Defined. Definition equiv_sigma_symm0 (A B : Type) : {a : A & B} <~> {b : B & A}. Proof. make_equiv. Defined. (** ** Universal mapping properties *) (** *** The positive universal property. *) Global Instance isequiv_sig_ind `{P : A -> Type} (Q : sig P -> Type) : IsEquiv (sig_ind Q) | 0 := Build_IsEquiv _ _ (sig_ind Q) (fun f x y => f (x;y)) (fun _ => 1) (fun _ => 1) (fun _ => 1). Definition equiv_sig_ind `{P : A -> Type} (Q : sig P -> Type) : (forall (x:A) (y:P x), Q (x;y)) <~> (forall xy, Q xy) := Build_Equiv _ _ (sig_ind Q) _. (** And a curried version *) Definition equiv_sig_ind' `{P : A -> Type} (Q : forall a, P a -> Type) : (forall (x:A) (y:P x), Q x y) <~> (forall xy, Q xy.1 xy.2) := equiv_sig_ind (fun xy => Q xy.1 xy.2). (** *** The negative universal property. *) Definition sig_coind_uncurried `{A : X -> Type} (P : forall x, A x -> Type) : { f : forall x, A x & forall x, P x (f x) } -> (forall x, sig (P x)) := fun fg => fun x => (fg.1 x ; fg.2 x). Definition sig_coind `{A : X -> Type} (P : forall x, A x -> Type) (f : forall x, A x) (g : forall x, P x (f x)) : (forall x, sig (P x)) := sig_coind_uncurried P (f;g). Global Instance isequiv_sig_coind `{A : X -> Type} {P : forall x, A x -> Type} : IsEquiv (sig_coind_uncurried P) | 0 := Build_IsEquiv _ _ (sig_coind_uncurried P) (fun h => exist (fun f => forall x, P x (f x)) (fun x => (h x).1) (fun x => (h x).2)) (fun _ => 1) (fun _ => 1) (fun _ => 1). Definition equiv_sig_coind `(A : X -> Type) (P : forall x, A x -> Type) : { f : forall x, A x & forall x, P x (f x) } <~> (forall x, sig (P x)) := Build_Equiv _ _ (sig_coind_uncurried P) _. (** ** Sigmas preserve truncation *) Global Instance istrunc_sigma `{P : A -> Type} `{IsTrunc n A} `{forall a, IsTrunc n (P a)} : IsTrunc n (sig P) | 100. Proof. generalize dependent A. simple_induction' n; simpl; intros A P ac Pc. { apply (Build_Contr _ (center A; center (P (center A)))). intros [a ?]. refine (path_sigma' P (contr a) (path_contr _ _)). } apply istrunc_S. intros u v. refine (istrunc_isequiv_istrunc _ (path_sigma_uncurried P u v)). Defined. (** The sigma of an arbitrary family of *disjoint* hprops is an hprop. *) Definition ishprop_sigma_disjoint `{P : A -> Type} `{forall a, IsHProp (P a)} : (forall x y, P x -> P y -> x = y) -> IsHProp { x : A & P x }. Proof. intros dj; apply hprop_allpath; intros [x px] [y py]. refine (path_sigma' P (dj x y px py) _). apply path_ishprop. Defined. (** ** Subtypes (sigma types whose second components are hprops) *) (** To prove equality in a subtype, we only need equality of the first component. *) Definition path_sigma_hprop {A : Type} {P : A -> Type} `{forall x, IsHProp (P x)} (u v : sig P) : u.1 = v.1 -> u = v := path_sigma_uncurried P u v o pr1^-1. Global Instance isequiv_path_sigma_hprop {A P} `{forall x : A, IsHProp (P x)} {u v : sig P} : IsEquiv (@path_sigma_hprop A P _ u v) | 100 := isequiv_compose. #[export] Hint Immediate isequiv_path_sigma_hprop : typeclass_instances. Definition equiv_path_sigma_hprop {A : Type} {P : A -> Type} {HP : forall a, IsHProp (P a)} (u v : sig P) : (u.1 = v.1) <~> (u = v) := Build_Equiv _ _ (path_sigma_hprop _ _) _. Definition isequiv_pr1_path_hprop {A} {P : A -> Type} `{forall a, IsHProp (P a)} (x y : sig P) : IsEquiv (@pr1_path A P x y) := _ : IsEquiv (path_sigma_hprop x y)^-1. #[export] Hint Immediate isequiv_pr1_path_hprop : typeclass_instances. (** We define this for ease of [SearchAbout IsEquiv ap pr1] *) Definition isequiv_ap_pr1_hprop {A} {P : A -> Type} `{forall a, IsHProp (P a)} (x y : sig P) : IsEquiv (@ap _ _ (@pr1 A P) x y) := _. (** [path_sigma_hprop] is functorial *) Definition path_sigma_hprop_1 {A : Type} {P : A -> Type} `{forall x, IsHProp (P x)} (u : sig P) : path_sigma_hprop u u 1 = 1. Proof. unfold path_sigma_hprop. unfold isequiv_pr1_contr; simpl. (** Ugh *) refine (ap (fun p => match p in (_ = v2) return (u = (u.1; v2)) with 1 => 1 end) (contr (idpath u.2))). Defined. Definition path_sigma_hprop_V {A : Type} {P : A -> Type} `{forall x, IsHProp (P x)} {a b : A} (p : a = b) (x : P a) (y : P b) : path_sigma_hprop (b;y) (a;x) p^ = (path_sigma_hprop (a;x) (b;y) p)^. Proof. destruct p; simpl. rewrite (path_ishprop x y). refine (path_sigma_hprop_1 _ @ (ap inverse (path_sigma_hprop_1 _))^). Qed. Definition path_sigma_hprop_pp {A : Type} {P : A -> Type} `{forall x, IsHProp (P x)} {a b c : A} (p : a = b) (q : b = c) (x : P a) (y : P b) (z : P c) : path_sigma_hprop (a;x) (c;z) (p @ q) = path_sigma_hprop (a;x) (b;y) p @ path_sigma_hprop (b;y) (c;z) q. Proof. destruct p, q. rewrite (path_ishprop y x). rewrite (path_ishprop z x). refine (_ @ (ap (fun z => z @ _) (path_sigma_hprop_1 _))^). apply (concat_1p _)^. Qed. (** The inverse of [path_sigma_hprop] has its own name, so we give special names to the section and retraction homotopies to help [rewrite] out. *) Definition path_sigma_hprop_ap_pr1 {A : Type} {P : A -> Type} `{forall x, IsHProp (P x)} (u v : sig P) (p : u = v) : path_sigma_hprop u v (ap pr1 p) = p := eisretr (path_sigma_hprop u v) p. Definition path_sigma_hprop_pr1_path {A : Type} {P : A -> Type} `{forall x, IsHProp (P x)} (u v : sig P) (p : u = v) : path_sigma_hprop u v p..1 = p := eisretr (path_sigma_hprop u v) p. Definition ap_pr1_path_sigma_hprop {A : Type} {P : A -> Type} `{forall x, IsHProp (P x)} (u v : sig P) (p : u.1 = v.1) : ap pr1 (path_sigma_hprop u v p) = p := eissect (path_sigma_hprop u v) p. Definition pr1_path_path_sigma_hprop {A : Type} {P : A -> Type} `{forall x, IsHProp (P x)} (u v : sig P) (p : u.1 = v.1) : (path_sigma_hprop u v p)..1 = p := eissect (path_sigma_hprop u v) p. (** ** Fibers of [functor_sigma] *) Definition hfiber_functor_sigma {A B} (P : A -> Type) (Q : B -> Type) (f : A -> B) (g : forall a, P a -> Q (f a)) (b : B) (v : Q b) : (hfiber (functor_sigma f g) (b; v)) <~> {w : hfiber f b & hfiber (g w.1) ((w.2)^ # v)}. Proof. unfold hfiber, functor_sigma. refine (_ oE equiv_functor_sigma_id _). 2:intros; symmetry; apply equiv_path_sigma. transitivity {w : {x : A & f x = b} & {x : P w.1 & (w.2) # (g w.1 x) = v}}. 1:make_equiv. apply equiv_functor_sigma_id; intros [a p]; simpl. apply equiv_functor_sigma_id; intros u; simpl. apply equiv_moveL_transport_V. Defined. Global Instance istruncmap_functor_sigma n {A B P Q} (f : A -> B) (g : forall a, P a -> Q (f a)) {Hf : IsTruncMap n f} {Hg : forall a, IsTruncMap n (g a)} : IsTruncMap n (functor_sigma f g). Proof. intros [a b]. exact (istrunc_equiv_istrunc _ (hfiber_functor_sigma _ _ _ _ _ _)^-1). Defined. (** Theorem 4.7.6 *) Definition hfiber_functor_sigma_idmap {A} (P Q : A -> Type) (g : forall a, P a -> Q a) (b : A) (v : Q b) : (hfiber (functor_sigma idmap g) (b; v)) <~> hfiber (g b) v. Proof. refine (_ oE hfiber_functor_sigma P Q idmap g b v). exact (equiv_contr_sigma (fun (w:hfiber idmap b) => hfiber (g w.1) (transport Q (w.2)^ v))). Defined. Definition istruncmap_from_functor_sigma n {A P Q} (g : forall a : A, P a -> Q a) `{!IsTruncMap n (functor_sigma idmap g)} : forall a, IsTruncMap n (g a). Proof. intros a v. exact (istrunc_equiv_istrunc _ (hfiber_functor_sigma_idmap _ _ _ _ _)). Defined. Coq-HoTT-9.0/theories/Types/Sum.v000066400000000000000000001014071474641544500166220ustar00rootroot00000000000000(** * Theorems about disjoint unions *) Require Import HoTT.Basics. Require Import Types.Empty Types.Unit Types.Prod Types.Sigma. (** The following are only required for the equivalence between [sum] and a sigma type *) Require Import Types.Bool. Local Open Scope trunc_scope. Local Open Scope path_scope. Local Set Universe Minimization ToSet. Generalizable Variables X A B f g n. Scheme sum_ind := Induction for sum Sort Type. Arguments sum_ind {A B} P f g s : rename. Scheme sum_rec := Minimality for sum Sort Type. Arguments sum_rec {A B} P f g s : rename. (** ** CoUnpacking *) (** Sums are coproducts, so there should be a dual to [unpack_prod]. I'm not sure what it is, though. *) (** ** Eta conversion *) Definition eta_sum `(z : A + B) : match z with | inl z' => inl z' | inr z' => inr z' end = z := match z with inl _ => 1 | inr _ => 1 end. (** ** Paths *) Definition code_sum {A B} (z z' : A + B) : Type := match z, z' with | inl a, inl a' => a = a' | inr b, inr b' => b = b' | _, _ => Empty end. Definition path_sum {A B : Type} {z z' : A + B} (c : code_sum z z') : z = z'. Proof. destruct z, z'. - apply ap, c. - elim c. - elim c. - apply ap, c. Defined. Definition path_sum_inv {A B : Type} {z z' : A + B} (pq : z = z') : match z, z' with | inl z0, inl z'0 => z0 = z'0 | inr z0, inr z'0 => z0 = z'0 | _, _ => Empty end := match pq with | 1 => match z with | inl _ => 1 | inr _ => 1 end end. Definition inl_ne_inr {A B : Type} (a : A) (b : B) : inl a <> inr b := path_sum_inv. Definition inr_ne_inl {A B : Type} (b : B) (a : A) : inr b <> inl a := path_sum_inv. (** This version produces only paths between closed terms, as opposed to paths between arbitrary inhabitants of sum types. *) Definition path_sum_inl {A : Type} (B : Type) {x x' : A} : inl x = inl x' -> x = x' := fun p => @path_sum_inv A B _ _ p. Definition path_sum_inr (A : Type) {B : Type} {x x' : B} : inr x = inr x' -> x = x' := fun p => @path_sum_inv A B _ _ p. (** This lets us identify the path space of a sum type, up to equivalence. *) Definition eisretr_path_sum {A B} {z z' : A + B} : path_sum o (@path_sum_inv _ _ z z') == idmap := fun p => match p as p in (_ = z') return path_sum (path_sum_inv p) = p with | 1 => match z as z return (@path_sum _ _ z z) (path_sum_inv 1) = 1 with | inl _ => 1 | inr _ => 1 end end. Definition eissect_path_sum {A B} {z z' : A + B} : path_sum_inv o (@path_sum _ _ z z') == idmap. Proof. intro p. destruct z, z', p; exact idpath. Defined. Global Instance isequiv_path_sum {A B : Type} {z z' : A + B} : IsEquiv (@path_sum _ _ z z') | 0. Proof. refine (Build_IsEquiv _ _ path_sum path_sum_inv eisretr_path_sum eissect_path_sum _). destruct z, z'; intros []; exact idpath. Defined. Definition equiv_path_sum {A B : Type} (z z' : A + B) := Build_Equiv _ _ _ (@isequiv_path_sum A B z z'). (** ** Fibers of [inl] and [inr] *) (** It follows that the fibers of [inl] and [inr] are decidable hprops. *) Global Instance ishprop_hfiber_inl {A B : Type} (z : A + B) : IsHProp (hfiber inl z). Proof. destruct z as [a|b]; unfold hfiber. - refine (istrunc_equiv_istrunc _ (equiv_functor_sigma_id (fun x => equiv_path_sum (inl x) (inl a)))). - refine (istrunc_isequiv_istrunc _ (fun xp => inl_ne_inr (xp.1) b xp.2)^-1). Defined. Global Instance decidable_hfiber_inl {A B : Type} (z : A + B) : Decidable (hfiber inl z). Proof. destruct z as [a|b]; unfold hfiber. - refine (decidable_equiv' _ (equiv_functor_sigma_id (fun x => equiv_path_sum (inl x) (inl a))) _). - refine (decidable_equiv _ (fun xp => inl_ne_inr (xp.1) b xp.2)^-1 _). Defined. Global Instance ishprop_hfiber_inr {A B : Type} (z : A + B) : IsHProp (hfiber inr z). Proof. destruct z as [a|b]; unfold hfiber. - refine (istrunc_isequiv_istrunc _ (fun xp => inr_ne_inl (xp.1) a xp.2)^-1). - refine (istrunc_equiv_istrunc _ (equiv_functor_sigma_id (fun x => equiv_path_sum (inr x) (inr b)))). Defined. Global Instance decidable_hfiber_inr {A B : Type} (z : A + B) : Decidable (hfiber inr z). Proof. destruct z as [a|b]; unfold hfiber. - refine (decidable_equiv _ (fun xp => inr_ne_inl (xp.1) a xp.2)^-1 _). - refine (decidable_equiv' _ (equiv_functor_sigma_id (fun x => equiv_path_sum (inr x) (inr b))) _). Defined. (** ** Decomposition *) (** Conversely, a decidable predicate decomposes a type as a sum. *) Section DecidableSum. Context `{Funext} {A : Type} (P : A -> Type) `{forall a, IsHProp (P a)} `{forall a, Decidable (P a)}. Definition equiv_decidable_sum : A <~> {x:A & P x} + {x:A & ~(P x)}. Proof. transparent assert (f : (A -> {x:A & P x} + {x:A & ~(P x)})). { intros x. destruct (dec (P x)) as [p|np]. - exact (inl (x;p)). - exact (inr (x;np)). } refine (Build_Equiv _ _ f _). refine (isequiv_adjointify _ (fun z => match z with | inl (x;p) => x | inr (x;np) => x end) _ _). - intros [[x p]|[x np]]; unfold f; destruct (dec (P x)) as [p'|np']. + apply ap, ap, path_ishprop. + elim (np' p). + elim (np p'). + apply ap, ap, path_ishprop. - intros x; unfold f. destruct (dec (P x)); cbn; reflexivity. Defined. Definition equiv_decidable_sum_l (a : A) (p : P a) : equiv_decidable_sum a = inl (a;p). Proof. unfold equiv_decidable_sum; cbn. destruct (dec (P a)) as [p'|np']. - apply ap, path_sigma_hprop; reflexivity. - elim (np' p). Defined. Definition equiv_decidable_sum_r (a : A) (np : ~ (P a)) : equiv_decidable_sum a = inr (a;np). Proof. unfold equiv_decidable_sum; cbn. destruct (dec (P a)) as [p'|np']. - elim (np p'). - apply ap, path_sigma_hprop; reflexivity. Defined. End DecidableSum. (** ** Transport *) Definition transport_sum {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a') (z : P a + Q a) : transport (fun a => P a + Q a) p z = match z with | inl z' => inl (p # z') | inr z' => inr (p # z') end := match p with idpath => match z with inl _ => 1 | inr _ => 1 end end. (** ** Detecting the summands *) Definition is_inl_and {A B} (P : A -> Type@{p}) : A + B -> Type@{p} := fun x => match x with inl a => P a | inr _ => Empty end. Definition is_inr_and {A B} (P : B -> Type@{p}) : A + B -> Type@{p} := fun x => match x with inl _ => Empty | inr b => P b end. Definition is_inl {A B} : A + B -> Type0 := is_inl_and (fun _ => Unit). Definition is_inr {A B} : A + B -> Type0 := is_inr_and (fun _ => Unit). Global Instance ishprop_is_inl {A B} (x : A + B) : IsHProp (is_inl x). Proof. destruct x; exact _. Defined. Global Instance ishprop_is_inr {A B} (x : A + B) : IsHProp (is_inr x). Proof. destruct x; exact _. Defined. Global Instance decidable_is_inl {A B} (x : A + B) : Decidable (is_inl x). Proof. destruct x; exact _. Defined. Global Instance decidable_is_inr {A B} (x : A + B) : Decidable (is_inr x). Proof. destruct x; exact _. Defined. Definition un_inl {A B} (z : A + B) : is_inl z -> A. Proof. destruct z as [a|b]. - intros; exact a. - intros e; elim e. Defined. Definition un_inr {A B} (z : A + B) : is_inr z -> B. Proof. destruct z as [a|b]. - intros e; elim e. - intros; exact b. Defined. Definition is_inl_not_inr {A B} (x : A + B) (na : ~ A) : is_inr x := match x with | inl a => na a | inr b => tt end. Definition is_inr_not_inl {A B} (x : A + B) (nb : ~ B) : is_inl x := match x with | inl a => tt | inr b => nb b end. Definition un_inl_inl {A B : Type} (a : A) (w : is_inl (inl a)) : un_inl (@inl A B a) w = a := 1. Definition un_inr_inr {A B : Type} (b : B) (w : is_inr (inr b)) : un_inr (@inr A B b) w = b := 1. Definition inl_un_inl {A B : Type} (z : A + B) (w : is_inl z) : inl (un_inl z w) = z. Proof. destruct z as [a|b]; simpl. - reflexivity. - elim w. Defined. Definition inr_un_inr {A B : Type} (z : A + B) (w : is_inr z) : inr (un_inr z w) = z. Proof. destruct z as [a|b]; simpl. - elim w. - reflexivity. Defined. Definition not_is_inl_and_inr {A B} (P : A -> Type) (Q : B -> Type) (x : A + B) : is_inl_and P x -> is_inr_and Q x -> Empty. Proof. destruct x as [a|b]; simpl. - exact (fun _ e => e). - exact (fun e _ => e). Defined. Definition not_is_inl_and_inr' {A B} (x : A + B) : is_inl x -> is_inr x -> Empty := not_is_inl_and_inr (fun _ => Unit) (fun _ => Unit) x. Definition is_inl_or_is_inr {A B} (x : A + B) : (is_inl x) + (is_inr x) := match x return (is_inl x) + (is_inr x) with | inl _ => inl tt | inr _ => inr tt end. Definition is_inl_ind {A B : Type} (P : A + B -> Type) (f : forall a:A, P (inl a)) : forall (x:A+B), is_inl x -> P x. Proof. intros [a|b] H; [ exact (f a) | elim H ]. Defined. Definition is_inr_ind {A B : Type} (P : A + B -> Type) (f : forall b:B, P (inr b)) : forall (x:A+B), is_inr x -> P x. Proof. intros [a|b] H; [ elim H | exact (f b) ]. Defined. (** ** Functorial action *) Section FunctorSum. Context {A A' B B' : Type} (f : A -> A') (g : B -> B'). Definition functor_sum : A + B -> A' + B' := fun z => match z with inl z' => inl (f z') | inr z' => inr (g z') end. Definition functor_code_sum {z z' : A + B} (c : code_sum z z') : code_sum (functor_sum z) (functor_sum z'). Proof. destruct z, z'. - destruct c. reflexivity. - elim c. - elim c. - destruct c. reflexivity. Defined. Definition ap_functor_sum {z z' : A + B} (c : code_sum z z') : ap functor_sum (path_sum c) = path_sum (functor_code_sum c). Proof. destruct z, z'. - destruct c. reflexivity. - elim c. - elim c. - destruct c. reflexivity. Defined. (** The fibers of [functor_sum] are those of [f] and [g]. *) Definition hfiber_functor_sum_l (a' : A') : hfiber functor_sum (inl a') <~> hfiber f a'. Proof. simple refine (equiv_adjointify _ _ _ _). - intros [[a|b] p]. + exists a. exact (path_sum_inl _ p). + elim (inr_ne_inl _ _ p). - intros [a p]. exists (inl a). exact (ap inl p). - intros [a p]. apply ap. (** Why doesn't Coq find this? *) pose (@isequiv_path_sum A' B' (inl (f a)) (inl a')). exact (eissect (@path_sum A' B' (inl (f a)) (inl a')) p). - intros [[a|b] p]; simpl. + apply ap. pose (@isequiv_path_sum A' B' (inl (f a)) (inl a')). exact (eisretr (@path_sum A' B' (inl (f a)) (inl a')) p). + elim (inr_ne_inl _ _ p). Defined. Definition hfiber_functor_sum_r (b' : B') : hfiber functor_sum (inr b') <~> hfiber g b'. Proof. simple refine (equiv_adjointify _ _ _ _). - intros [[a|b] p]. + elim (inl_ne_inr _ _ p). + exists b. exact (path_sum_inr _ p). - intros [b p]. exists (inr b). exact (ap inr p). - intros [b p]. apply ap. (** Why doesn't Coq find this? *) pose (@isequiv_path_sum A' B' (inr (g b)) (inr b')). exact (eissect (@path_sum A' B' (inr (g b)) (inr b')) p). - intros [[a|b] p]; simpl. + elim (inl_ne_inr _ _ p). + apply ap. pose (@isequiv_path_sum A' B' (inr (g b)) (inr b')). exact (eisretr (@path_sum A' B' (inr (g b)) (inr b')) p). Defined. End FunctorSum. Definition functor_sum_homotopic {A A' B B' : Type} {f f' : A -> A'} {g g' : B -> B'} (p : f == f') (q : g == g') : functor_sum f g == functor_sum f' g'. Proof. intros [a|b]. - exact (ap inl (p a)). - exact (ap inr (q b)). Defined. Definition functor_sum_compose {A A' A'' B B' B'' : Type} {f : A -> A'} {f' : A' -> A''} {g : B -> B'} {g' : B' -> B''} : functor_sum (f' o f) (g' o g) == functor_sum f' g' o functor_sum f g. Proof. intros [a|b]; reflexivity. Defined. Definition functor_sum_idmap {A B : Type} : functor_sum (A:=A) (B:=B) idmap idmap == idmap. Proof. intros [a|b]; reflexivity. Defined. (** ** "Unfunctorial action" *) (** Not every function [A + B -> A' + B'] is of the form [functor_sum f g]. However, this is the case if it preserves the summands, i.e. if it maps [A] into [A'] and [B] into [B']. More generally, if a function [A + B -> A' + B'] maps [A] into [A'] only, then we can extract from it a function [A -> A']. Since these operations are a sort of inverse to [functor_sum], we call them [unfunctor_sum_*]. *) Definition unfunctor_sum_l {A A' B B' : Type} (h : A + B -> A' + B') (Ha : forall a:A, is_inl (h (inl a))) : A -> A' := fun a => un_inl (h (inl a)) (Ha a). Definition unfunctor_sum_r {A A' B B' : Type} (h : A + B -> A' + B') (Hb : forall b:B, is_inr (h (inr b))) : B -> B' := fun b => un_inr (h (inr b)) (Hb b). Definition unfunctor_sum_eta {A A' B B' : Type} (h : A + B -> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) : functor_sum (unfunctor_sum_l h Ha) (unfunctor_sum_r h Hb) == h. Proof. intros [a|b]; simpl. - unfold unfunctor_sum_l; apply inl_un_inl. - unfold unfunctor_sum_r; apply inr_un_inr. Defined. Definition unfunctor_sum_l_beta {A A' B B' : Type} (h : A + B -> A' + B') (Ha : forall a:A, is_inl (h (inl a))) : inl o unfunctor_sum_l h Ha == h o inl. Proof. intros a; unfold unfunctor_sum_l; apply inl_un_inl. Defined. Definition unfunctor_sum_r_beta {A A' B B' : Type} (h : A + B -> A' + B') (Hb : forall b:B, is_inr (h (inr b))) : inr o unfunctor_sum_r h Hb == h o inr. Proof. intros b; unfold unfunctor_sum_r; apply inr_un_inr. Defined. Definition unfunctor_sum_l_compose {A A' A'' B B' B'' : Type} (h : A + B -> A' + B') (k : A' + B' -> A'' + B'') (Ha : forall a:A, is_inl (h (inl a))) (Ha' : forall a':A', is_inl (k (inl a'))) : unfunctor_sum_l k Ha' o unfunctor_sum_l h Ha == unfunctor_sum_l (k o h) (fun a => is_inl_ind (fun x' => is_inl (k x')) Ha' (h (inl a)) (Ha a)). Proof. intros a. refine (path_sum_inl B'' _). refine (unfunctor_sum_l_beta _ _ _ @ _). refine (ap k (unfunctor_sum_l_beta _ _ _) @ _). refine ((unfunctor_sum_l_beta _ _ _)^). Defined. Definition unfunctor_sum_r_compose {A A' A'' B B' B'' : Type} (h : A + B -> A' + B') (k : A' + B' -> A'' + B'') (Hb : forall b:B, is_inr (h (inr b))) (Hb' : forall b':B', is_inr (k (inr b'))) : unfunctor_sum_r k Hb' o unfunctor_sum_r h Hb == unfunctor_sum_r (k o h) (fun b => is_inr_ind (fun x' => is_inr (k x')) Hb' (h (inr b)) (Hb b)). Proof. intros b. refine (path_sum_inr A'' _). refine (unfunctor_sum_r_beta _ _ _ @ _). refine (ap k (unfunctor_sum_r_beta _ _ _) @ _). refine ((unfunctor_sum_r_beta _ _ _)^). Defined. (** [unfunctor_sum] also preserves fibers, if both summands are preserved. *) Definition hfiber_unfunctor_sum_l {A A' B B' : Type} (h : A + B -> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) (a' : A') : hfiber (unfunctor_sum_l h Ha) a' <~> hfiber h (inl a'). Proof. simple refine (equiv_adjointify _ _ _ _). - intros [a p]. exists (inl a). refine (_ @ ap inl p). symmetry; apply inl_un_inl. - intros [[a|b] p]. + exists a. apply path_sum_inl with B'. refine (_ @ p). apply inl_un_inl. + specialize (Hb b). abstract (rewrite p in Hb; elim Hb). - intros [[a|b] p]; simpl. + apply ap. apply moveR_Vp. exact (eisretr (@path_sum A' B' _ _) (inl_un_inl (h (inl a)) (Ha a) @ p)). + apply Empty_rec. specialize (Hb b). abstract (rewrite p in Hb; elim Hb). - intros [a p]. apply ap. rewrite concat_p_Vp. pose (@isequiv_path_sum A' B' (inl (unfunctor_sum_l h Ha a)) (inl a')). exact (eissect (@path_sum A' B' (inl (unfunctor_sum_l h Ha a)) (inl a')) p). Defined. Definition hfiber_unfunctor_sum_r {A A' B B' : Type} (h : A + B -> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) (b' : B') : hfiber (unfunctor_sum_r h Hb) b' <~> hfiber h (inr b'). Proof. simple refine (equiv_adjointify _ _ _ _). - intros [b p]. exists (inr b). refine (_ @ ap inr p). symmetry; apply inr_un_inr. - intros [[a|b] p]. + specialize (Ha a). abstract (rewrite p in Ha; elim Ha). + exists b. apply path_sum_inr with A'. refine (_ @ p). apply inr_un_inr. - intros [[a|b] p]; simpl. + apply Empty_rec. specialize (Ha a). abstract (rewrite p in Ha; elim Ha). + apply ap. apply moveR_Vp. exact (eisretr (@path_sum A' B' _ _) (inr_un_inr (h (inr b)) (Hb b) @ p)). - intros [b p]. apply ap. rewrite concat_p_Vp. pose (@isequiv_path_sum A' B' (inr (unfunctor_sum_r h Hb b)) (inr b')). exact (eissect (@path_sum A' B' (inr (unfunctor_sum_r h Hb b)) (inr b')) p). Defined. (** ** Functoriality on equivalences *) Global Instance isequiv_functor_sum `{IsEquiv A A' f} `{IsEquiv B B' g} : IsEquiv (functor_sum f g) | 1000. Proof. apply (isequiv_adjointify (functor_sum f g) (functor_sum f^-1 g^-1)); [ intros [?|?]; simpl; apply ap; apply eisretr | intros [?|?]; simpl; apply ap; apply eissect ]. Defined. Definition equiv_functor_sum `{IsEquiv A A' f} `{IsEquiv B B' g} : A + B <~> A' + B' := Build_Equiv _ _ (functor_sum f g) _. Definition equiv_functor_sum' {A A' B B' : Type} (f : A <~> A') (g : B <~> B') : A + B <~> A' + B' := equiv_functor_sum (f := f) (g := g). Notation "f +E g" := (equiv_functor_sum' f g) : equiv_scope. Definition equiv_functor_sum_l {A B B' : Type} (g : B <~> B') : A + B <~> A + B' := 1 +E g. Definition equiv_functor_sum_r {A A' B : Type} (f : A <~> A') : A + B <~> A' + B := f +E 1. Definition iff_functor_sum {A A' B B' : Type} (f : A <-> A') (g : B <-> B') : A + B <-> A' + B' := (functor_sum (fst f) (fst g), functor_sum (snd f) (snd g)). (** ** Unfunctoriality on equivalences *) Global Instance isequiv_unfunctor_sum_l {A A' B B' : Type} (h : A + B <~> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) : IsEquiv (unfunctor_sum_l h Ha). Proof. simple refine (isequiv_adjointify _ _ _ _). - refine (unfunctor_sum_l h^-1 _); intros a'. remember (h^-1 (inl a')) as x eqn:p. destruct x as [a|b]. + exact tt. + apply moveL_equiv_M in p. elim (p^ # (Hb b)). - intros a'. refine (unfunctor_sum_l_compose _ _ _ _ _ @ _). refine (path_sum_inl B' _). refine (unfunctor_sum_l_beta _ _ _ @ _). apply eisretr. - intros a. refine (unfunctor_sum_l_compose _ _ _ _ _ @ _). refine (path_sum_inl B _). refine (unfunctor_sum_l_beta (h^-1 o h) _ a @ _). apply eissect. Defined. Definition equiv_unfunctor_sum_l {A A' B B' : Type} (h : A + B <~> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) : A <~> A' := Build_Equiv _ _ (unfunctor_sum_l h Ha) (isequiv_unfunctor_sum_l h Ha Hb). Global Instance isequiv_unfunctor_sum_r {A A' B B' : Type} (h : A + B <~> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) : IsEquiv (unfunctor_sum_r h Hb). Proof. simple refine (isequiv_adjointify _ _ _ _). - refine (unfunctor_sum_r h^-1 _); intros b'. remember (h^-1 (inr b')) as x eqn:p. destruct x as [a|b]. + apply moveL_equiv_M in p. elim (p^ # (Ha a)). + exact tt. - intros b'. refine (unfunctor_sum_r_compose _ _ _ _ _ @ _). refine (path_sum_inr A' _). refine (unfunctor_sum_r_beta _ _ _ @ _). apply eisretr. - intros b. refine (unfunctor_sum_r_compose _ _ _ _ _ @ _). refine (path_sum_inr A _). refine (unfunctor_sum_r_beta (h^-1 o h) _ b @ _). apply eissect. Defined. Definition equiv_unfunctor_sum_r {A A' B B' : Type} (h : A + B <~> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) : B <~> B' := Build_Equiv _ _ (unfunctor_sum_r h Hb) (isequiv_unfunctor_sum_r h Ha Hb). Definition equiv_unfunctor_sum {A A' B B' : Type} (h : A + B <~> A' + B') (Ha : forall a:A, is_inl (h (inl a))) (Hb : forall b:B, is_inr (h (inr b))) : (A <~> A') * (B <~> B') := (equiv_unfunctor_sum_l h Ha Hb , equiv_unfunctor_sum_r h Ha Hb). (** ** Symmetry *) (* This is a special property of [sum], of course, not an instance of a general family of facts about types. *) Definition equiv_sum_symm@{u v k | u <= k, v <= k} (A : Type@{u}) (B : Type@{v}) : Equiv@{k k} (A + B) (B + A). Proof. apply (equiv_adjointify (fun ab => match ab with inl a => inr a | inr b => inl b end) (fun ab => match ab with inl a => inr a | inr b => inl b end)); intros [?|?]; exact idpath. Defined. (** ** Associativity *) Definition equiv_sum_assoc (A B C : Type) : (A + B) + C <~> A + (B + C). Proof. simple refine (equiv_adjointify _ _ _ _). - intros [[a|b]|c]; [ exact (inl a) | exact (inr (inl b)) | exact (inr (inr c)) ]. - intros [a|[b|c]]; [ exact (inl (inl a)) | exact (inl (inr b)) | exact (inr c) ]. - intros [a|[b|c]]; reflexivity. - intros [[a|b]|c]; reflexivity. Defined. (** ** Identity *) Definition sum_empty_l@{u|} (A : Type@{u}) : Equiv@{u u} (Empty + A) A. Proof. snrapply equiv_adjointify@{u u}. - intros [e|a]; [ exact (Empty_rec@{u} e) | exact a ]. - intros a; exact (inr@{Set u} a). - intro x; exact idpath@{u}. - intros [e|z]; [ elim e | exact idpath@{u}]. Defined. Definition sum_empty_r@{u} (A : Type@{u}) : Equiv@{u u} (A + Empty) A := equiv_compose'@{u u u} (sum_empty_l A) (equiv_sum_symm@{u Set u} _ _). (** ** Distributivity *) Definition sum_distrib_l A B C : A * (B + C) <~> (A * B) + (A * C). Proof. snrapply Build_Equiv. 2: snrapply Build_IsEquiv. - intros [a [b|c]]. + exact (inl@{u u} (a, b)). + exact (inr@{u u} (a, c)). - intros [[a b]|[a c]]. + exact (a, inl@{u u} b). + exact (a, inr@{u u} c). - intros [[a b]|[a c]]; reflexivity. - intros [a [b|c]]; reflexivity. - intros [a [b|c]]; reflexivity. Defined. Definition sum_distrib_r A B C : (B + C) * A <~> (B * A) + (C * A). Proof. refine (Build_Equiv ((B + C) * A) ((B * A) + (C * A)) (fun abc => let (bc,a) := abc in match bc with | inl b => inl (b,a) | inr c => inr (c,a) end) _). simple refine (Build_IsEquiv ((B + C) * A) ((B * A) + (C * A)) _ (fun ax => match ax with | inl (b,a) => (inl b,a) | inr (c,a) => (inr c,a) end) _ _ _). - intros [[b a]|[c a]]; reflexivity. - intros [[b|c] a]; reflexivity. - intros [[b|c] a]; reflexivity. Defined. (** ** Extensivity *) (** We can phrase extensivity in two ways, using either dependent types or functions. *) (** The first is a statement about types dependent on a sum type. *) Definition equiv_sigma_sum A B (C : A + B -> Type) : { x : A+B & C x } <~> { a : A & C (inl a) } + { b : B & C (inr b) }. Proof. refine (Build_Equiv { x : A+B & C x } ({ a : A & C (inl a) } + { b : B & C (inr b) }) (fun xc => let (x,c) := xc in match x return C x -> ({ a : A & C (inl a) } + { b : B & C (inr b) }) with | inl a => fun c => inl (a;c) | inr b => fun c => inr (b;c) end c) _). simple refine (Build_IsEquiv { x : A+B & C x } ({ a : A & C (inl a) } + { b : B & C (inr b) }) _ (fun abc => match abc with | inl (a;c) => (inl a ; c) | inr (b;c) => (inr b ; c) end) _ _ _). - intros [[a c]|[b c]]; reflexivity. - intros [[a|b] c]; reflexivity. - intros [[a|b] c]; reflexivity. Defined. (** The second is a statement about functions into a sum type. *) Definition decompose_l {A B C} (f : C -> A + B) : Type := { c:C & is_inl (f c) }. Definition decompose_r {A B C} (f : C -> A + B) : Type := { c:C & is_inr (f c) }. Definition equiv_decompose {A B C} (f : C -> A + B) : decompose_l f + decompose_r f <~> C. Proof. simple refine (equiv_adjointify (sum_ind (fun _ => C) pr1 pr1) _ _ _). - intros c; destruct (is_inl_or_is_inr (f c)); [ left | right ]; exists c; assumption. - intros c; destruct (is_inl_or_is_inr (f c)); reflexivity. - intros [[c l]|[c r]]; simpl; destruct (is_inl_or_is_inr (f c)). + apply ap, ap, path_ishprop. + elim (not_is_inl_and_inr' _ l i). + elim (not_is_inl_and_inr' _ i r). + apply ap, ap, path_ishprop. Defined. Definition is_inl_decompose_l {A B C} (f : C -> A + B) (z : decompose_l f) : is_inl (f (equiv_decompose f (inl z))) := z.2. Definition is_inr_decompose_r {A B C} (f : C -> A + B) (z : decompose_r f) : is_inr (f (equiv_decompose f (inr z))) := z.2. (** ** Indecomposability *) (** A type is indecomposable if whenever it maps into a finite sum, it lands entirely in one of the summands. It suffices to assert this for binary and nullary sums; in the latter case it reduces to nonemptiness. *) Class Indecomposable (X : Type) := { indecompose : forall A B (f : X -> A + B), (forall x, is_inl (f x)) + (forall x, is_inr (f x)) ; indecompose0 : ~~X }. (** For instance, contractible types are indecomposable. *) Global Instance indecomposable_contr `{Contr X} : Indecomposable X. Proof. constructor. - intros A B f. destruct (is_inl_or_is_inr (f (center X))); [ left | right ]; intros x. all:refine (transport _ (ap f (contr x)) _); assumption. - intros nx; exact (nx (center X)). Defined. (** In particular, if an indecomposable type is equivalent to a sum type, then one summand is empty and it is equivalent to the other. *) Definition equiv_indecomposable_sum {X A B} `{Indecomposable X} (f : X <~> A + B) : ((X <~> A) * (Empty <~> B)) + ((X <~> B) * (Empty <~> A)). Proof. destruct (indecompose A B f) as [i|i]; [ left | right ]. 1:pose (g := (f oE sum_empty_r X)). 2:pose (g := (f oE sum_empty_l X)). 2:apply (equiv_prod_symm _ _). all:refine (equiv_unfunctor_sum g _ _); try assumption; try intros []. Defined. (** Summing with an indecomposable type is injective on equivalence classes of types. *) Definition equiv_unfunctor_sum_indecomposable_ll {A B B' : Type} `{Indecomposable A} (h : A + B <~> A + B') : B <~> B'. Proof. pose (f := equiv_decompose (h o inl)). pose (g := equiv_decompose (h o inr)). pose (k := (h oE (f +E g))). (** This looks messy, but it just amounts to swapping the middle two summands in [k]. *) pose (k' := k oE (equiv_sum_assoc _ _ _) oE ((equiv_sum_assoc _ _ _)^-1 +E 1) oE (1 +E (equiv_sum_symm _ _) +E 1) oE ((equiv_sum_assoc _ _ _) +E 1) oE (equiv_sum_assoc _ _ _)^-1). destruct (equiv_unfunctor_sum k' (fun x : decompose_l (h o inl) + decompose_l (h o inr) => match x as x0 return (is_inl (k' (inl x0))) with | inl x0 => x0.2 | inr x0 => x0.2 end) (fun x : decompose_r (h o inl) + decompose_r (h o inr) => match x as x0 return (is_inr (k' (inr x0))) with | inl x0 => x0.2 | inr x0 => x0.2 end)) as [s t]; clear k k'. refine (t oE (_ +E 1) oE g^-1). destruct (equiv_indecomposable_sum s^-1) as [[p q]|[p q]]; destruct (equiv_indecomposable_sum f^-1) as [[u v]|[u v]]. - refine (v oE q^-1). - elim (indecompose0 (v^-1 o p)). - refine (Empty_rec (indecompose0 _)); intros a. destruct (is_inl_or_is_inr (h (inl a))) as [l|r]. * exact (q^-1 (a;l)). * exact (v^-1 (a;r)). - refine (u oE p^-1). Defined. Definition equiv_unfunctor_sum_contr_ll {A A' B B' : Type} `{Contr A} `{Contr A'} (h : A + B <~> A' + B') : B <~> B' := equiv_unfunctor_sum_indecomposable_ll ((equiv_contr_contr +E 1) oE h). (** ** Universal mapping properties *) (** Ordinary universal mapping properties are expressed as equivalences of sets or spaces of functions. In type theory, we can go beyond this and express an equivalence of types of *dependent* functions. *) Definition sum_ind_uncurried {A B} (P : A + B -> Type) (fg : (forall a, P (inl a)) * (forall b, P (inr b))) : forall s, P s := @sum_ind A B P (fst fg) (snd fg). (* First the positive universal property. Doing this sort of thing without adjointifying will require very careful use of funext. *) Global Instance isequiv_sum_ind `{Funext} `(P : A + B -> Type) : IsEquiv (sum_ind_uncurried P) | 0. Proof. apply (isequiv_adjointify (sum_ind_uncurried P) (fun f => (fun a => f (inl a), fun b => f (inr b)))); repeat ((exact idpath) || intros [] || intro || apply path_forall). Defined. Definition equiv_sum_ind `{Funext} `(P : A + B -> Type) := Build_Equiv _ _ _ (isequiv_sum_ind P). (* The non-dependent version, which is a special case, is the sum-distributive equivalence. *) Definition equiv_sum_distributive `{Funext} (A B C : Type) : (A -> C) * (B -> C) <~> (A + B -> C) := equiv_sum_ind (fun _ => C). (** ** Sums preserve most truncation *) Global Instance istrunc_sum n' (n := n'.+2) `{IsTrunc n A, IsTrunc n B} : IsTrunc n (A + B) | 100. Proof. apply istrunc_S. intros a b. eapply istrunc_equiv_istrunc; [ exact (equiv_path_sum _ _) | ]. destruct a, b; exact _. Defined. Global Instance ishset_sum `{HA : IsHSet A, HB : IsHSet B} : IsHSet (A + B) | 100 := @istrunc_sum (-2) A HA B HB. (** Sums don't preserve hprops in general, but they do for disjoint sums. *) Global Instance ishprop_sum A B `{IsHProp A} `{IsHProp B} : (A -> B -> Empty) -> IsHProp (A + B). Proof. intros H. apply hprop_allpath; intros [a1|b1] [a2|b2]. - apply ap, path_ishprop. - case (H a1 b2). - case (H a2 b1). - apply ap, path_ishprop. Defined. (** ** Decidability *) (** Sums preserve decidability *) Global Instance decidable_sum@{u v k | u <= k, v <= k} {A : Type@{u}} {B : Type@{v}} `{Decidable A} `{Decidable B} : Decidable@{k} (A + B). Proof. destruct (dec A) as [x1|y1]. - exact (inl@{k k} (inl x1)). - destruct (dec@{v} B) as [x2|y2]. + exact (inl@{k k} (inr x2)). + apply inr@{k k}; intros z. destruct z as [x1|x2]. * exact (y1 x1). * exact (y2 x2). Defined. (** Sums preserve decidable paths *) Global Instance decidablepaths_sum {A B} `{DecidablePaths A} `{DecidablePaths B} : DecidablePaths (A + B). Proof. intros [a1|b1] [a2|b2]. - destruct (dec_paths a1 a2) as [p|np]. + exact (inl (ap inl p)). + apply inr; intros p. exact (np (path_sum^-1 p)). - exact (inr path_sum^-1). - exact (inr path_sum^-1). - destruct (dec_paths b1 b2) as [p|np]. + exact (inl (ap inr p)). + apply inr; intros p. exact (np (path_sum^-1 p)). Defined. (** Because of [ishprop_sum], decidability of an hprop is again an hprop. *) Global Instance ishprop_decidable_hprop `{Funext} A `{IsHProp A} : IsHProp (Decidable A). Proof. unfold Decidable; refine (ishprop_sum _ _ _). intros a na; exact (na a). Defined. (** ** Binary coproducts are equivalent to dependent sigmas where the first component is a bool. *) Definition sig_of_sum A B (x : A + B) : { b : Bool & if b then A else B } := (_; match x as s return (if match s with | inl _ => true | inr _ => false end then A else B) with | inl a => a | inr b => b end). Definition sum_of_sig A B (x : { b : Bool & if b then A else B }) : A + B := match x with | (true; a) => inl a | (false; b) => inr b end. Global Instance isequiv_sig_of_sum A B : IsEquiv (@sig_of_sum A B) | 0. Proof. apply (isequiv_adjointify (@sig_of_sum A B) (@sum_of_sig A B)). - intros [[] ?]; exact idpath. - intros []; exact idpath. Defined. Global Instance isequiv_sum_of_sig A B : IsEquiv (sum_of_sig A B) := isequiv_inverse (@sig_of_sum A B). (** An alternative way of proving the truncation property of [sum]. *) Definition trunc_sum' n A B `{IsTrunc n Bool, IsTrunc n A, IsTrunc n B} : (IsTrunc n (A + B)). Proof. eapply istrunc_equiv_istrunc; [ esplit; exact (@isequiv_sum_of_sig _ _) | ]. typeclasses eauto. Defined. Coq-HoTT-9.0/theories/Types/Unit.v000066400000000000000000000101141474641544500167670ustar00rootroot00000000000000(** * Theorems about the unit type *) Require Import Basics.Overture Basics.Equivalences. Local Open Scope path_scope. Local Set Universe Minimization ToSet. Generalizable Variables A. (** ** Eta conversion *) Definition eta_unit (z : Unit) : tt = z := match z with tt => 1 end. (** ** Paths *) (* This is all kind of ridiculous, but it fits the pattern. *) Definition path_unit_uncurried (z z' : Unit) : Unit -> z = z' := fun _ => match z, z' with tt, tt => 1 end. Definition path_unit (z z' : Unit) : z = z' := path_unit_uncurried z z' tt. Definition eta_path_unit {z z' : Unit} (p : z = z') : path_unit z z' = p. Proof. destruct p. destruct z. reflexivity. Defined. Global Instance isequiv_path_unit (z z' : Unit) : IsEquiv (path_unit_uncurried z z') | 0. Proof. refine (Build_IsEquiv _ _ (path_unit_uncurried z z') (fun _ => tt) (fun p:z=z' => match p in (_ = z') return (path_unit_uncurried z z' tt = p) with | idpath => match z as z return (path_unit_uncurried z z tt = 1) with | tt => 1 end end) (fun x => match x with tt => 1 end) _). intros []; destruct z, z'; reflexivity. Defined. Definition equiv_path_unit (z z' : Unit) : Unit <~> (z = z') := Build_Equiv _ _ (path_unit_uncurried z z') _. (** ** Transport *) (** Is a special case of transporting in a constant fibration. *) (** ** Universal mapping properties *) (* The positive universal property *) Arguments Unit_ind [A] a u : rename. Global Instance isequiv_unit_ind `{Funext} (A : Unit -> Type) : IsEquiv (@Unit_ind A) | 0 := isequiv_adjointify _ (fun f : forall u:Unit, A u => f tt) (fun f : forall u:Unit, A u => path_forall (@Unit_ind A (f tt)) f (fun x => match x with tt => 1 end)) (fun _ => 1). Global Instance isequiv_unit_rec `{Funext} (A : Type) : IsEquiv (@Unit_ind (fun _ => A)) | 0 := isequiv_unit_ind (fun _ => A). #[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances. Definition equiv_unit_rec `{Funext} (A : Type) : A <~> (Unit -> A) := (Build_Equiv _ _ (@Unit_ind (fun _ => A)) _). (* For various reasons, it is typically more convenient to define functions out of the unit as constant maps, rather than [Unit_ind]. *) Notation unit_name x := (fun (_ : Unit) => x). Global Instance isequiv_unit_name@{i j} `{Funext} (A : Type@{i}) : @IsEquiv@{i j} _ (Unit -> _) (fun (a:A) => unit_name a). Proof. refine (isequiv_adjointify _ (fun f : Unit -> _ => f tt) _ _). - intros f; apply path_forall@{i i j}; intros x. apply ap@{i i}, path_unit. - intros a; reflexivity. Defined. (* The negative universal property *) Definition unit_coind {A : Type} : Unit -> (A -> Unit) := fun _ _ => tt. Global Instance isequiv_unit_coind `{Funext} (A : Type) : IsEquiv (@unit_coind A) | 0. Proof. refine (isequiv_adjointify _ (fun f => tt) _ _). - intro f. apply path_forall; intros x; apply path_unit. - intro x; destruct x; reflexivity. Defined. Definition equiv_unit_coind `{Funext} (A : Type) : Unit <~> (A -> Unit) := Build_Equiv _ _ (@unit_coind A) _. (** ** Truncation *) (* The Unit type is contractible *) Global Instance contr_unit : Contr Unit | 0 := Build_Contr _ tt (fun t : Unit => match t with tt => 1 end). (** ** Equivalences *) (** A contractible type is equivalent to [Unit]. *) Definition equiv_contr_unit `{Contr A} : A <~> Unit := equiv_contr_contr. (* Conversely, a type equivalent to [Unit] is contractible. We don't make this an instance because Coq would have to guess the equivalence. And when it has a map in mind, it would try to use [isequiv_contr_contr], which would cause a cycle. *) Definition contr_equiv_unit (A : Type) (f : A <~> Unit) : Contr A := contr_equiv' Unit f^-1%equiv. (** The constant map to [Unit]. We define this so we can get rid of an unneeded universe variable that Coq generates when [const tt] is used in a context that doesn't have [Universe Minimization ToSet] as this file does. If we ever set that globally, then we could get rid of this and remove some imports of this file. *) Definition const_tt (A : Type) := @const A Unit tt. Coq-HoTT-9.0/theories/Types/Universe.v000066400000000000000000000517341474641544500176650ustar00rootroot00000000000000(** * Theorems about the universe, including the Univalence Axiom. *) Require Import HoTT.Basics. Require Import Types.Sigma Types.Forall Types.Arrow Types.Paths Types.Equiv Types.Bool Types.Prod. Local Open Scope path_scope. Generalizable Variables A B f. (** ** Paths *) Definition equiv_path (A B : Type@{u}) (p : A = B) : A <~> B := equiv_transport (fun X => X) p. Definition equiv_path_V `{Funext} (A B : Type) (p : A = B) : equiv_path B A (p^) = (equiv_path A B p)^-1%equiv. Proof. apply path_equiv. reflexivity. Defined. (** See the note by [Funext] in Overture.v *) Monomorphic Axiom Univalence : Type0. Existing Class Univalence. (** Mark this axiom as a "global axiom", which some of our tactics will automatically handle. *) Global Instance is_global_axiom_univalence : IsGlobalAxiom Univalence := {}. Axiom isequiv_equiv_path : forall `{Univalence} (A B : Type@{u}), IsEquiv (equiv_path A B). Global Existing Instance isequiv_equiv_path. (** A proof that univalence implies function extensionality can be found in the metatheory file [UnivalenceImpliesFunext], but that actual proof can't be used on our dummy typeclasses. So we assert the following axiomatic instance. *) Global Instance Univalence_implies_Funext `{Univalence} : Funext. Admitted. Section Univalence. Context `{Univalence}. Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B := (equiv_path A B)^-1 f. Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B) := path_universe_uncurried (Build_Equiv _ _ f feq). Global Arguments path_universe {A B}%_type_scope f%_function_scope {feq}. Definition eta_path_universe {A B : Type} (p : A = B) : path_universe (equiv_path A B p) = p := eissect (equiv_path A B) p. Definition eta_path_universe_uncurried {A B : Type} (p : A = B) : path_universe_uncurried (equiv_path A B p) = p := eissect (equiv_path A B) p. Definition isequiv_path_universe {A B : Type} : IsEquiv (@path_universe_uncurried A B) := _. Definition equiv_path_universe (A B : Type) : (A <~> B) <~> (A = B) := Build_Equiv _ _ (@path_universe_uncurried A B) isequiv_path_universe. Definition equiv_equiv_path (A B : Type) : (A = B) <~> (A <~> B) := (equiv_path_universe A B)^-1%equiv. (** These operations have too many names, making [rewrite] a pain. So we give lots of names to the computation laws. *) Definition path_universe_equiv_path {A B : Type} (p : A = B) : path_universe (equiv_path A B p) = p := eissect (equiv_path A B) p. Definition path_universe_uncurried_equiv_path {A B : Type} (p : A = B) : path_universe_uncurried (equiv_path A B p) = p := eissect (equiv_path A B) p. Definition path_universe_transport_idmap {A B : Type} (p : A = B) : path_universe (transport idmap p) = p := eissect (equiv_path A B) p. Definition path_universe_uncurried_transport_idmap {A B : Type} (p : A = B) : path_universe_uncurried (equiv_transport idmap p) = p := eissect (equiv_path A B) p. Definition equiv_path_path_universe {A B : Type} (f : A <~> B) : equiv_path A B (path_universe f) = f := eisretr (equiv_path A B) f. Definition equiv_path_path_universe_uncurried {A B : Type} (f : A <~> B) : equiv_path A B (path_universe_uncurried f) = f := eisretr (equiv_path A B) f. Definition transport_idmap_path_universe {A B : Type} (f : A <~> B) : transport idmap (path_universe f) = f := ap equiv_fun (eisretr (equiv_path A B) f). Definition transport_idmap_path_universe_uncurried {A B : Type} (f : A <~> B) : transport idmap (path_universe_uncurried f) = f := ap equiv_fun (eisretr (equiv_path A B) f). (** ** Behavior on path operations *) (* We explicitly assume [Funext] here, since this result doesn't use [Univalence]. *) Definition equiv_path_pp `{Funext} {A B C : Type} (p : A = B) (q : B = C) : equiv_path A C (p @ q) = equiv_path B C q oE equiv_path A B p. Proof. apply path_equiv, path_arrow. nrapply transport_pp. Defined. Definition path_universe_compose_uncurried {A B C : Type} (f : A <~> B) (g : B <~> C) : path_universe_uncurried (equiv_compose g f) = path_universe_uncurried f @ path_universe_uncurried g. Proof. revert f. equiv_intro (equiv_path A B) f. revert g. equiv_intro (equiv_path B C) g. refine ((ap path_universe_uncurried (equiv_path_pp f g))^ @ _). refine (eta_path_universe (f @ g) @ _). apply concat2; symmetry; apply eta_path_universe. Defined. Definition path_universe_compose {A B C : Type} (f : A <~> B) (g : B <~> C) : path_universe (g o f) = path_universe f @ path_universe g := path_universe_compose_uncurried f g. Definition path_universe_1 {A : Type} : path_universe (equiv_idmap A) = 1 := eta_path_universe 1. Definition path_universe_V_uncurried {A B : Type} (f : A <~> B) : path_universe_uncurried f^-1 = (path_universe_uncurried f)^. Proof. revert f. equiv_intro ((equiv_path_universe A B)^-1) p. simpl. transitivity (p^). 2: exact (inverse2 (eisretr (equiv_path_universe A B) p)^). transitivity (path_universe_uncurried (equiv_path B A p^)). - by refine (ap _ (equiv_path_V A B p)^). - by refine (eissect (equiv_path B A) p^). Defined. Definition path_universe_V `(f : A -> B) `{IsEquiv A B f} : path_universe (f^-1) = (path_universe f)^ := path_universe_V_uncurried (Build_Equiv A B f _). (** ** Path operations vs Type operations *) (** [ap (Equiv A)] behaves like postcomposition. *) Definition ap_equiv_path_universe A {B C} (f : B <~> C) : equiv_path (A <~> B) (A <~> C) (ap (Equiv A) (path_universe f)) = equiv_functor_equiv (equiv_idmap A) f. Proof. revert f. equiv_intro (equiv_path B C) f. rewrite (eissect (equiv_path B C) f : path_universe (equiv_path B C f) = f). destruct f; simpl. apply path_equiv, path_forall; intros g. apply path_equiv, path_forall; intros a. reflexivity. Defined. (** [ap (prod A)] behaves like [equiv_functor_prod_l]. *) Definition ap_prod_l_path_universe A {B C} (f : B <~> C) : equiv_path (A * B) (A * C) (ap (prod A) (path_universe f)) = equiv_functor_prod_l f. Proof. revert f. equiv_intro (equiv_path B C) f. rewrite (eissect (equiv_path B C) f : path_universe (equiv_path B C f) = f). destruct f. apply path_equiv, path_arrow; intros x; reflexivity. Defined. (** [ap (fun Z => Z * A)] behaves like [equiv_functor_prod_r]. *) Definition ap_prod_r_path_universe A {B C} (f : B <~> C) : equiv_path (B * A) (C * A) (ap (fun Z => Z * A) (path_universe f)) = equiv_functor_prod_r f. Proof. revert f. equiv_intro (equiv_path B C) f. rewrite (eissect (equiv_path B C) f : path_universe (equiv_path B C f) = f). destruct f. apply path_equiv, path_arrow; intros x; reflexivity. Defined. (** ** Transport *) (** There are two ways we could define [transport_path_universe]: we could give an explicit definition, or we could reduce it to paths by [equiv_ind] and give an explicit definition there. The two should be equivalent, but we choose the second for now as it makes the currently needed coherence lemmas easier to prove. *) Definition transport_path_universe_uncurried {A B : Type} (f : A <~> B) (z : A) : transport (fun X:Type => X) (path_universe_uncurried f) z = f z. Proof. revert f. equiv_intro (equiv_path A B) p. exact (ap (fun s => transport idmap s z) (eissect _ p)). Defined. (* Alternatively, [apply ap10, transport_idmap_path_universe_uncurried.], but then some later proofs would have to change. *) Definition transport_path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) : transport (fun X:Type => X) (path_universe f) z = f z := transport_path_universe_uncurried (Build_Equiv A B f feq) z. (* Alternatively, [ap10_equiv (eisretr (equiv_path A B) (Build_Equiv _ _ f feq)) z]. *) Definition transport_path_universe_equiv_path {A B : Type} (p : A = B) (z : A) : transport_path_universe (equiv_path A B p) z = (ap (fun s => transport idmap s z) (eissect _ p)) := equiv_ind_comp _ _ _. (* This somewhat fancier version is useful when working with HITs. *) Definition transport_path_universe' {A : Type} (P : A -> Type) {x y : A} (p : x = y) (f : P x <~> P y) (q : ap P p = path_universe f) (u : P x) : transport P p u = f u := transport_compose idmap P p u @ ap10 (ap (transport idmap) q) u @ transport_path_universe f u. (** And a version for transporting backwards. *) Definition transport_path_universe_V_uncurried {A B : Type} (f : A <~> B) (z : B) : transport (fun X:Type => X) (path_universe_uncurried f)^ z = f^-1 z. Proof. revert f. equiv_intro (equiv_path A B) p. exact (ap (fun s => transport idmap s z) (inverse2 (eissect _ p))). Defined. Definition transport_path_universe_V {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B) : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z := transport_path_universe_V_uncurried (Build_Equiv _ _ f feq) z. (* Alternatively, [(transport2 idmap (path_universe_V f) z)^ @ (transport_path_universe (f^-1) z)]. *) Definition transport_path_universe_V_equiv_path {A B : Type} (p : A = B) (z : B) : transport_path_universe_V (equiv_path A B p) z = ap (fun s => transport idmap s z) (inverse2 (eissect _ p)) := equiv_ind_comp _ _ _. (** And some coherence for it. *) Definition transport_path_universe_Vp_uncurried {A B : Type} (f : A <~> B) (z : A) : ap (transport idmap (path_universe f)^) (transport_path_universe f z) @ transport_path_universe_V f (f z) @ eissect f z = transport_Vp idmap (path_universe f) z. Proof. pattern f. refine (equiv_ind (equiv_path A B) _ _ _); intros p. (* Something slightly sneaky happens here: by definition of [equiv_path], [eissect (equiv_path A B p)] is judgmentally equal to [transport_Vp idmap p]. Thus, we can apply [ap_transport_Vp_idmap]. *) refine (_ @ ap_transport_Vp_idmap p (path_universe (equiv_path A B p)) (eissect (equiv_path A B) p) z). apply whiskerR. apply concat2. - apply ap. apply transport_path_universe_equiv_path. - apply transport_path_universe_V_equiv_path. Defined. Definition transport_path_universe_Vp {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) : ap (transport idmap (path_universe f)^) (transport_path_universe f z) @ transport_path_universe_V f (f z) @ eissect f z = transport_Vp idmap (path_universe f) z := transport_path_universe_Vp_uncurried (Build_Equiv A B f feq) z. (** *** Transporting in particular type families *) Theorem transport_arrow_toconst_path_universe {A U V : Type} (w : U <~> V) : forall f : U -> A, transport (fun E : Type => E -> A) (path_universe w) f = (f o w^-1). Proof. intros f. funext y. refine (transport_arrow_toconst _ _ _ @ _). apply ap. apply transport_path_universe_V. Defined. (** Transporting along an equivalence with univalence. *) Definition univalent_transport (S : Type -> Type) {X Y} (e : X <~> Y) (s : S X) : S Y := (path_universe e) # s. (** Transporting along the identity equivalence is the identity. *) Definition univalent_transport_idequiv (S : Type -> Type) {X} : @univalent_transport S X X equiv_idmap == idmap. Proof. intros s. apply (transport2 S path_universe_1). Defined. (** ** 2-paths *) Definition equiv_path2_universe {A B : Type} (f g : A <~> B) : (f == g) <~> (path_universe f = path_universe g). Proof. refine (_ oE equiv_path_arrow f g). refine (_ oE equiv_path_equiv f g). exact (equiv_ap (equiv_path A B)^-1 _ _). Defined. Definition path2_universe {A B : Type} {f g : A <~> B} : (f == g) -> (path_universe f = path_universe g) := equiv_path2_universe f g. Definition equiv_path2_universe_1 {A B : Type} (f : A <~> B) : equiv_path2_universe f f (fun x => 1) = 1. Proof. simpl. rewrite concat_1p, concat_p1, path_forall_1, path_sigma_hprop_1. reflexivity. Qed. Definition path2_universe_1 {A B : Type} (f : A <~> B) : @path2_universe _ _ f f (fun x => 1) = 1 := equiv_path2_universe_1 f. (** There ought to be a lemma which says something like this: << Definition path2_universe_postcompose {A B C : Type} {f1 f2 : A <~> B} (p : f1 == f2) (g : B <~> C) : equiv_path2_universe (g o f1) (g o f2) (fun a => ap g (p a)) = path_universe_compose f1 g @ whiskerR (path2_universe p) (path_universe g) @ (path_universe_compose f2 g)^. >> and similarly << Definition path2_universe_precompose {A B C : Type} {f1 f2 : B <~> C} (p : f1 == f2) (g : A <~> B) : equiv_path2_universe (f1 o g) (f2 o g) (fun a => (p (g a))) = path_universe_compose g f1 @ whiskerL (path_universe g) (path2_universe p) @ (path_universe_compose g f2)^. >> but I haven't managed to prove them yet. Fortunately, for existing applications what we actually need is the following rather different-looking version that applies only when [f1] and [f2] are identities. *) (** Coq is too eager about unfolding [equiv_path_equiv] in the following proofs, so we tell it not to. We go into a section in order to limit the scope of the [simpl never] command. *) Section PathEquivSimplNever. Local Arguments equiv_path_equiv : simpl never. Definition path2_universe_postcompose_idmap {A C : Type} (p : forall a:A, a = a) (g : A <~> C) : equiv_path2_universe g g (fun a => ap g (p a)) = (concat_1p _)^ @ whiskerR (path_universe_1)^ (path_universe g) @ whiskerR (equiv_path2_universe (equiv_idmap A) (equiv_idmap A) p) (path_universe g) @ whiskerR path_universe_1 (path_universe g) @ concat_1p _. Proof. transitivity ((eta_path_universe (path_universe g))^ @ equiv_path2_universe (equiv_path A C (path_universe g)) (equiv_path A C (path_universe g)) (fun a => ap (equiv_path A C (path_universe g)) (p a)) @ eta_path_universe (path_universe g)). - refine ((apD (fun g' => equiv_path2_universe g' g' (fun a => ap g' (p a))) (eisretr (equiv_path A C) g))^ @ _). refine (transport_paths_FlFr (eisretr (equiv_path A C) g) _ @ _). apply concat2. + apply whiskerR. apply inverse2, symmetry. refine (eisadj (equiv_path A C)^-1 g). + symmetry; refine (eisadj (equiv_path A C)^-1 g). - generalize (path_universe g). intros h. destruct h. cbn. rewrite !concat_1p, !concat_p1. refine (_ @ whiskerR (whiskerR_pp 1 path_universe_1^ _) _). refine (_ @ whiskerR_pp 1 _ path_universe_1). refine (_ @ (whiskerR_p1_1 _)^). apply whiskerR, whiskerL, ap, ap, ap. apply path_forall; intros x; apply ap_idmap. Defined. Definition path2_universe_precompose_idmap {A B : Type} (p : forall b:B, b = b) (g : A <~> B) : equiv_path2_universe g g (fun a => (p (g a))) = (concat_p1 _)^ @ whiskerL (path_universe g) (path_universe_1)^ @ whiskerL (path_universe g) (equiv_path2_universe (equiv_idmap B) (equiv_idmap B) p) @ whiskerL (path_universe g) (path_universe_1) @ concat_p1 _. Proof. transitivity ((eta_path_universe (path_universe g))^ @ equiv_path2_universe (equiv_path A B (path_universe g)) (equiv_path A B (path_universe g)) (fun a => p (equiv_path A B (path_universe g) a)) @ eta_path_universe (path_universe g)). - refine ((apD (fun g' => equiv_path2_universe g' g' (fun a => p (g' a))) (eisretr (equiv_path A B) g))^ @ _). refine (transport_paths_FlFr (eisretr (equiv_path A B) g) _ @ _). apply concat2. + apply whiskerR. apply inverse2, symmetry. refine (eisadj (equiv_path A B)^-1 g). + symmetry; refine (eisadj (equiv_path A B)^-1 g). - generalize (path_universe g). intros h. destruct h. cbn. rewrite !concat_p1. refine (_ @ (((concat_1p (whiskerL 1 path_universe_1^))^ @@ 1) @@ 1)). refine (_ @ whiskerR (whiskerL_pp 1 path_universe_1^ _) _). refine (_ @ whiskerL_pp 1 _ path_universe_1). exact ((whiskerL_1p_1 _)^). Defined. End PathEquivSimplNever. (** ** 3-paths *) Definition equiv_path3_universe {A B : Type} {f g : A <~> B} (p q : f == g) : (p == q) <~> (path2_universe p = path2_universe q). Proof. refine (_ oE equiv_path_forall p q). refine (_ oE equiv_ap (equiv_path_arrow f g) p q). refine (_ oE equiv_ap (equiv_path_equiv f g) _ _). unfold path2_universe, equiv_path2_universe. simpl. refine (equiv_ap (ap (equiv_path A B)^-1) _ _). Defined. Definition path3_universe {A B : Type} {f g : A <~> B} {p q : f == g} : (p == q) -> (path2_universe p = path2_universe q) := equiv_path3_universe p q. Definition transport_path_universe_pV_uncurried {A B : Type} (f : A <~> B) (z : B) : transport_path_universe f (transport idmap (path_universe f)^ z) @ ap f (transport_path_universe_V f z) @ eisretr f z = transport_pV idmap (path_universe f) z. Proof. pattern f. refine (equiv_ind (equiv_path A B) _ _ _); intros p. refine (_ @ ap_transport_pV_idmap p (path_universe (equiv_path A B p)) (eissect (equiv_path A B) p) z). apply whiskerR. refine ((concat_Ap _ _)^ @ _). apply concat2. - apply ap. refine (transport_path_universe_V_equiv_path _ _ @ _). unfold inverse2. symmetry; apply (ap_compose inverse (fun s => transport idmap s z)). - apply transport_path_universe_equiv_path. Defined. Definition transport_path_universe_pV {A B : Type} (f : A -> B) {feq : IsEquiv f } (z : B) : transport_path_universe f (transport idmap (path_universe f)^ z) @ ap f (transport_path_universe_V f z) @ eisretr f z = transport_pV idmap (path_universe f) z := transport_path_universe_pV_uncurried (Build_Equiv A B f feq) z. (** ** Equivalence induction *) (** Paulin-Mohring style *) Theorem equiv_induction {U : Type} (P : forall V, U <~> V -> Type) : (P U (equiv_idmap U)) -> (forall V (w : U <~> V), P V w). Proof. intros H0 V. apply (equiv_ind (equiv_path U V)). intro p; induction p; exact H0. Defined. Definition equiv_induction_comp {U : Type} (P : forall V, U <~> V -> Type) (didmap : P U (equiv_idmap U)) : equiv_induction P didmap U (equiv_idmap U) = didmap := (equiv_ind_comp (P U) _ 1). (** Martin-Lof style *) Theorem equiv_induction' (P : forall U V, U <~> V -> Type) : (forall T, P T T (equiv_idmap T)) -> (forall U V (w : U <~> V), P U V w). Proof. intros H0 U V w. apply (equiv_ind (equiv_path U V)). intro p; induction p; apply H0. Defined. Definition equiv_induction'_comp (P : forall U V, U <~> V -> Type) (didmap : forall T, P T T (equiv_idmap T)) (U : Type) : equiv_induction' P didmap U U (equiv_idmap U) = didmap U := (equiv_ind_comp (P U U) _ 1). Theorem equiv_induction_inv {U : Type} (P : forall V, V <~> U -> Type) : (P U (equiv_idmap U)) -> (forall V (w : V <~> U), P V w). Proof. intros H0 V. apply (equiv_ind (equiv_path V U)). (* We manually apply [paths_ind_r] to reduce universe levels. *) revert V; rapply paths_ind_r; apply H0. Defined. Definition equiv_induction_inv_comp {U : Type} (P : forall V, V <~> U -> Type) (didmap : P U (equiv_idmap U)) : equiv_induction_inv P didmap U (equiv_idmap U) = didmap := (equiv_ind_comp (P U) _ 1). (** ** Based equivalence types *) Global Instance contr_basedequiv@{u +} {X : Type@{u}} : Contr {Y : Type@{u} & X <~> Y}. Proof. apply (Build_Contr _ (X; equiv_idmap)). intros [Y f]; revert Y f. exact (equiv_induction _ idpath). Defined. Global Instance contr_basedequiv'@{u +} {X : Type@{u}} : Contr {Y : Type@{u} & Y <~> X}. Proof. (* The next line is used so that Coq can figure out the type of (X; equiv_idmap). *) srapply Build_Contr. - exact (X; equiv_idmap). - intros [Y f]; revert Y f. refine (equiv_induction_inv _ idpath). Defined. (** Any two functions that act like transport along an equivalence, i.e. maps of the type [T : forall X Y, X <~> Y -> S X -> S Y] with a computation rule of type [Trefl : forall X, (T (equiv_idmap X) == idmap)], are homotopic. This can be useful when we want to transport along an equivalence, but [univalent_transport] does not have the computational properties that we want. *) Definition homotopic_trequiv (S : Type -> Type) {X Y} (T T' : forall {X Y}, X <~> Y -> S X -> S Y) (Trefl : forall {X}, (T (equiv_idmap X) == idmap)) (T'refl : forall {X}, (T' (equiv_idmap X) == idmap)) (e : X <~> Y) : T e == T' e. Proof. revert Y e. apply equiv_induction. apply (pointwise_paths_concat (Trefl _)). symmetry; apply T'refl. Defined. (** ** Truncations *) (** Truncatedness of the universe is a subtle question, but with univalence we can conclude things about truncations of certain of its path-spaces. *) Global Instance istrunc_paths_Type {n : trunc_index} {A B : Type} `{IsTrunc n.+1 B} : IsTrunc n.+1 (A = B). Proof. refine (istrunc_isequiv_istrunc _ path_universe_uncurried). Defined. (** We can also say easily that the universe is not a set. *) Definition not_hset_Type : ~ (IsHSet Type). Proof. intro HT. apply true_ne_false. pose (r := path_ishprop (path_universe equiv_negb) 1). refine (_ @ (ap (fun q => transport idmap q false) r)). symmetry; apply transport_path_universe. Defined. End Univalence. Coq-HoTT-9.0/theories/Types/WType.v000066400000000000000000000026661474641544500171350ustar00rootroot00000000000000Require Import HoTT.Basics. Require Import Types.Forall Types.Sigma. (** * Theorems about W-types (well-founded trees) *) Inductive W (A : Type) (B : A -> Type) : Type := w_sup (x : A) : (B x -> W A B) -> W A B. Definition w_label {A B} (w : W A B) : A := match w with | w_sup x y => x end. Definition w_arg {A B} (w : W A B) : B (w_label w) -> W A B := match w with | w_sup x y => y end. Definition issig_W (A : Type) (B : A -> Type) : _ <~> W A B := ltac:(issig). (** ** Paths *) Definition equiv_path_wtype {A B} (z z' : W A B) : (w_label z;w_arg z) = (w_label z';w_arg z') :> {a : _ & B a -> W A B} <~> z = z' := (equiv_ap' (issig_W A B)^-1%equiv z z')^-1%equiv. Definition equiv_path_wtype' {A B} (z z' : W A B) : {p : w_label z = w_label z' & w_arg z = w_arg z' o transport B p} <~> z = z'. Proof. refine (equiv_path_wtype _ _ oE equiv_path_sigma _ _ _ oE _). apply equiv_functor_sigma_id. destruct z as [z1 z2], z' as [z1' z2']. cbn; intros p. destruct p. reflexivity. Defined. (** ** W-types preserve truncation *) Global Instance istrunc_wtype `{Funext} {A B} {n : trunc_index} `{IsTrunc n.+1 A} : IsTrunc n.+1 (W A B) | 100. Proof. apply istrunc_S. intros z; induction z as [a w]. intro y; destruct y as [a0 w0]. nrefine (istrunc_equiv_istrunc _ (equiv_path_wtype' _ _)). rapply istrunc_sigma. cbn; intro p. destruct p. apply (istrunc_equiv_istrunc _ (equiv_path_forall _ _)). Defined. Coq-HoTT-9.0/theories/Universes/000077500000000000000000000000001474641544500165435ustar00rootroot00000000000000Coq-HoTT-9.0/theories/Universes/Automorphisms.v000066400000000000000000000157171474641544500216170ustar00rootroot00000000000000Require Import Basics Types. Require Import HoTT.Truncations. Require Import Universes.BAut Universes.Rigid. Require Import ExcludedMiddle. Local Open Scope trunc_scope. Local Open Scope path_scope. (** * The universe *) (** ** Automorphisms of the universe *) (** See "Parametricity, automorphisms of the universe, and excluded middle" by Booij, Escardo, Lumsdaine, Shulman. *) (** If two inequivalent types have equivalent automorphism oo-groups, then assuming LEM we can swap them and leave the rest of the universe untouched. *) Section SwapTypes. (** Amusingly, this does not actually require univalence! But of course, to verify [BAut A <~> BAut B] in any particular example does require univalence. *) Context `{Funext} `{ExcludedMiddle}. Context (A B : Type) (ne : ~(A <~> B)) (e : BAut A <~> BAut B). Definition equiv_swap_types : Type <~> Type. Proof. refine (((equiv_decidable_sum (fun X:Type => merely (X=A)))^-1) oE _ oE (equiv_decidable_sum (fun X:Type => merely (X=A)))). refine ((equiv_functor_sum_l (equiv_decidable_sum (fun X => merely (X.1=B)))^-1) oE _ oE (equiv_functor_sum_l (equiv_decidable_sum (fun X => merely (X.1=B))))). refine ((equiv_sum_assoc _ _ _) oE _ oE (equiv_sum_assoc _ _ _)^-1). apply equiv_functor_sum_r. assert (q : BAut B <~> {x : {x : Type & ~ merely (x = A)} & merely (x.1 = B)}). { refine (equiv_sigma_assoc _ _ oE _). apply equiv_functor_sigma_id; intros X. apply equiv_iff_hprop. - intros p. refine (fun q => _ ; p). strip_truncations. destruct q. exact (ne (equiv_path X B p)). - exact pr2. } refine (_ oE equiv_sum_symm _ _). apply equiv_functor_sum'. - exact (e^-1 oE q^-1). - exact (q oE e). Defined. Definition equiv_swap_types_swaps : merely (equiv_swap_types A = B). Proof. assert (ea := (e (point _)).2). cbn in ea. strip_truncations; apply tr. unfold equiv_swap_types. apply moveR_equiv_V. rewrite (equiv_decidable_sum_l (fun X => merely (X=A)) A (tr 1)). assert (ne' : ~ merely (B=A)) by (intros p; strip_truncations; exact (ne (equiv_path A B p^))). rewrite (equiv_decidable_sum_r (fun X => merely (X=A)) B ne'). cbn. apply ap, path_sigma_hprop; cbn. exact ea. Defined. Definition equiv_swap_types_not_id : equiv_swap_types <> equiv_idmap. Proof. intros p. assert (q := equiv_swap_types_swaps). strip_truncations. apply ne. apply equiv_path. rewrite p in q; exact q. Qed. End SwapTypes. (** In particular, we can swap any two distinct rigid types. *) Definition equiv_swap_rigid `{Univalence} `{ExcludedMiddle} (A B : Type) `{IsRigid A} `{IsRigid B} (ne : ~(A <~> B)) : Type <~> Type. Proof. refine (equiv_swap_types A B ne _). apply equiv_contr_contr. Defined. (** Such as [Empty] and [Unit]. *) Definition equiv_swap_empty_unit `{Univalence} `{ExcludedMiddle} : Type <~> Type := equiv_swap_rigid Empty Unit (fun e => e^-1 tt). (** In this case we get an untruncated witness of the swapping. *) Definition equiv_swap_rigid_swaps `{Univalence} `{ExcludedMiddle} (A B : Type) `{IsRigid A} `{IsRigid B} (ne : ~(A <~> B)) : equiv_swap_rigid A B ne A = B. Proof. unfold equiv_swap_rigid, equiv_swap_types. apply moveR_equiv_V. rewrite (equiv_decidable_sum_l (fun X => merely (X=A)) A (tr 1)). assert (ne' : ~ merely (B=A)) by (intros p; strip_truncations; exact (ne (equiv_path A B p^))). rewrite (equiv_decidable_sum_r (fun X => merely (X=A)) B ne'). cbn. apply ap, path_sigma_hprop; cbn. exact ((path_contr (center (BAut B)) (point (BAut B)))..1). Defined. (** We can also swap the products of two rigid types with another type [X], under a connectedness/truncatedness assumption. *) Definition equiv_swap_prod_rigid `{Univalence} `{ExcludedMiddle} (X A B : Type) (n : trunc_index) (ne : ~(X*A <~> X*B)) `{IsRigid A} `{IsConnected n.+1 A} `{IsRigid B} `{IsConnected n.+1 B} `{IsTrunc n.+1 X} : Type <~> Type. Proof. refine (equiv_swap_types (X*A) (X*B) ne _). transitivity (BAut X). - symmetry; exact (baut_prod_rigid_equiv X A n). - exact (baut_prod_rigid_equiv X B n). Defined. (** Conversely, from some nontrivial automorphisms of the universe we can deduce nonconstructive consequences. *) Definition lem_from_aut_type_unit_empty `{Univalence} (f : Type <~> Type) (eu : f Unit = Empty) : ExcludedMiddle_type. Proof. apply DNE_to_LEM, DNE_from_allneg; intros P ?. exists (f P); split. - intros p. assert (Contr P) by (apply contr_inhabited_hprop; assumption). assert (q : Unit = P) by (apply path_universe_uncurried, equiv_contr_contr). destruct q. rewrite eu. auto. - intros nfp. assert (q : f P = Empty) by (apply path_universe_uncurried, equiv_to_empty, nfp). rewrite <- eu in q. apply ((ap f)^-1) in q. rewrite q; exact tt. Defined. Lemma equiv_hprop_idprod `{Univalence} (A : Type) (P : Type) (a : merely A) `{IsHProp P} : P <-> (P * A = A). Proof. split. - intros p; apply path_universe with snd. apply isequiv_adjointify with (fun a => (p,a)). + intros x; reflexivity. + intros [p' x]. apply path_prod; [ apply path_ishprop | reflexivity ]. - intros q. strip_truncations. apply equiv_path in q. exact (fst (q^-1 a)). Defined. Definition lem_from_aut_type_inhabited_empty `{Univalence} (f : Type <~> Type) (A : Type) (a : merely A) (eu : f A = Empty) : ExcludedMiddle_type. Proof. apply DNE_to_LEM, DNE_from_allneg; intros P ?. exists (f (P * A)); split. - intros p. assert (q := fst (equiv_hprop_idprod A P a) p). apply (ap f) in q. rewrite eu in q. rewrite q; auto. - intros q. apply equiv_to_empty in q. apply path_universe_uncurried in q. rewrite <- eu in q. apply ((ap f)^-1) in q. exact (snd (equiv_hprop_idprod A P a) q). Defined. (** If you can derive a constructive taboo from an automorphism of the universe such that [g X <> X], then you get [X]-many beers; see . *) Definition zero_beers `{Univalence} (g : Type <~> Type) (ge : g Empty <> Empty) : ~~ExcludedMiddle_type. Proof. pose (f := equiv_inverse g). intros nlem. apply ge. apply path_universe_uncurried, equiv_to_empty; intros gz. apply nlem. apply (lem_from_aut_type_inhabited_empty f (g Empty) (tr gz)). unfold f; apply eissect. Defined. Definition lem_beers `{Univalence} (g : Type <~> Type) (ge : g ExcludedMiddle_type <> ExcludedMiddle_type) : ~~ExcludedMiddle_type. Proof. intros nlem. pose (nlem' := equiv_to_empty nlem). apply path_universe_uncurried in nlem'. rewrite nlem' in ge. apply (zero_beers g) in ge. exact (ge nlem). Defined. Coq-HoTT-9.0/theories/Universes/BAut.v000066400000000000000000000274561474641544500176030ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import Constant. Require Import HoTT.Truncations. Require Import ObjectClassifier Homotopy.ExactSequence Pointed. Local Open Scope type_scope. Local Open Scope path_scope. (** * BAut(X) *) (** ** Basics *) (** [BAut X] is the type of types that are merely equal to [X]. It is connected, by [is0connected_component] and any two points are merely equal by [merely_path_component]. *) Definition BAut (X : Type@{u}) := { Z : Type@{u} & merely (Z = X) }. Coercion BAut_pr1 X : BAut X -> Type := pr1. Global Instance ispointed_baut {X : Type} : IsPointed (BAut X) := (X; tr 1). (** We also define a pointed version [pBAut X], since the coercion [BAut_pr1] doesn't work if [BAut X] is a [pType]. *) Definition pBAut (X : Type) : pType := [BAut X, _]. Definition path_baut `{Univalence} {X} (Z Z' : BAut X) : (Z <~> Z') <~> (Z = Z' :> BAut X) := equiv_path_sigma_hprop _ _ oE equiv_path_universe _ _. Definition ap_pr1_path_baut `{Univalence} {X} {Z Z' : BAut X} (f : Z <~> Z') : ap (BAut_pr1 X) (path_baut Z Z' f) = path_universe f. Proof. unfold path_baut, BAut_pr1; simpl. apply ap_pr1_path_sigma_hprop. Defined. Definition transport_path_baut `{Univalence} {X} {Z Z' : BAut X} (f : Z <~> Z') (z : Z) : transport (fun (W:BAut X) => W) (path_baut Z Z' f) z = f z. Proof. refine (transport_compose idmap (BAut_pr1 X) _ _ @ _). refine (_ @ transport_path_universe f z). apply ap10, ap, ap_pr1_path_baut. Defined. (** The following tactic, which applies when trying to prove an hprop, replaces all assumed elements of [BAut X] by [X] itself. With [Univalence], this would work for any 0-connected type, but using [merely_path_component] we can avoid univalence. *) Ltac baut_reduce := progress repeat match goal with | [ Z : BAut ?X |- _ ] => let Zispoint := fresh "Zispoint" in assert (Zispoint := merely_path_component (point (BAut X)) Z); revert Zispoint; refine (@Trunc_ind _ _ _ _ _); intro Zispoint; destruct Zispoint end. (** ** Truncation *) (** If [X] is an [n.+1]-type, then [BAut X] is an [n.+2]-type. *) Global Instance trunc_baut `{Univalence} {n X} `{IsTrunc n.+1 X} : IsTrunc n.+2 (BAut X). Proof. apply istrunc_S. intros Z W. baut_reduce. exact (@istrunc_equiv_istrunc _ _ (path_baut _ _) n.+1 _). Defined. (** If [X] is truncated, then so is every element of [BAut X]. *) Global Instance trunc_el_baut {n X} `{Funext} `{IsTrunc n X} (Z : BAut X) : IsTrunc n Z := ltac:(by baut_reduce). (** ** Operations on [BAut] *) (** Multiplying by a fixed type *) Definition baut_prod_r (X A : Type) : BAut X -> BAut (X * A) := fun Z:BAut X => (Z * A ; Trunc_functor (-1) (ap (fun W => W * A)) (pr2 Z)) : BAut (X * A). Definition ap_baut_prod_r `{Univalence} (X A : Type) {Z W : BAut X} (e : Z <~> W) : ap (baut_prod_r X A) (path_baut Z W e) = path_baut (baut_prod_r X A Z) (baut_prod_r X A W) (equiv_functor_prod_r e). Proof. cbn. apply moveL_equiv_M; cbn; unfold pr1_path. rewrite <- (ap_compose (baut_prod_r X A) pr1 (path_sigma_hprop Z W _)). rewrite <- ((ap_compose pr1 (fun Z => Z * A) (path_sigma_hprop Z W _))^). rewrite ap_pr1_path_sigma_hprop. apply moveL_equiv_M; cbn. apply ap_prod_r_path_universe. Qed. (** ** Centers *) (** The following lemma says that to define a section of a family [P] of hsets over [BAut X], it is equivalent to define an element of [P X] which is fixed by all automorphisms of [X]. *) Lemma baut_ind_hset `{Univalence} X (** It ought to be possible to allow more generally [P : BAut X -> Type], but the proof would get more complicated, and this version suffices for present applications. *) (P : Type -> Type) `{forall (Z : BAut X), IsHSet (P Z)} : { e : P (point (BAut X)) & forall g : X <~> X, transport P (path_universe g) e = e } <~> (forall (Z:BAut X), P Z). Proof. refine (equiv_sig_ind _ oE _). (** We use the fact that maps out of a propositional truncation into an hset are equivalent to weakly constant functions. *) refine ((equiv_functor_forall' (P := fun Z => { f : (Z=X) -> P Z & WeaklyConstant f }) 1 (fun Z => equiv_merely_rec_hset_if_domain _ _)) oE _); simpl. { intros p. change (IsHSet (P (BAut_pr1 X (Z ; tr p)))). exact _. } unfold WeaklyConstant. (** Now we peel away a bunch of contractible types. *) refine (equiv_sig_coind _ _ oE _). srapply equiv_functor_sigma'. 1:apply (equiv_paths_ind_r X (fun x _ => P x)). intros p; cbn. refine (equiv_paths_ind_r X _ oE _). srapply equiv_functor_forall'. 1:apply equiv_equiv_path. intros e; cbn. refine (_ oE equiv_moveL_transport_V _ _ _ _). apply equiv_concat_r. rewrite path_universe_transport_idmap, paths_ind_r_transport. reflexivity. Defined. (** This implies that if [X] is a set, then the center of [BAut X] is the set of automorphisms of [X] that commute with every other automorphism (i.e. the center, in the usual sense, of the group of automorphisms of [X]). *) Definition center_baut `{Univalence} X `{IsHSet X} : { f : X <~> X & forall g:X<~>X, g o f == f o g } <~> (forall Z:BAut X, Z = Z). Proof. refine (equiv_functor_forall_id (fun Z => equiv_path_sigma_hprop Z Z) oE _). refine (baut_ind_hset X (fun Z => Z = Z) oE _). simpl. refine (equiv_functor_sigma' (equiv_path_universe X X) _); intros f. apply equiv_functor_forall_id; intros g; simpl. refine (_ oE equiv_path_arrow _ _). refine (_ oE equiv_path_equiv (g oE f) (f oE g)). revert g. equiv_intro (equiv_path X X) g. revert f. equiv_intro (equiv_path X X) f. refine (_ oE equiv_concat_l (equiv_path_pp _ _) _). refine (_ oE equiv_concat_r (equiv_path_pp _ _)^ _). refine (_ oE (equiv_ap (equiv_path X X) _ _)^-1). refine (equiv_concat_l (transport_paths_lr _ _) _ oE _). refine (equiv_concat_l (concat_pp_p _ _ _) _ oE _). refine (equiv_moveR_Vp _ _ _ oE _). refine (equiv_concat_l _ _ oE equiv_concat_r _ _). - apply concat2; apply eissect. - symmetry; apply concat2; apply eissect. Defined. (** We show that this equivalence takes the identity equivalence to the identity in the center. We have to be careful in this proof never to [simpl] or [unfold] too many things, or Coq will produce gigantic terms that take it forever to compute with. *) Definition id_center_baut `{Univalence} X `{IsHSet X} : center_baut X (exist (fun (f:X<~>X) => forall (g:X<~>X), g o f == f o g) (equiv_idmap X) (fun (g:X<~>X) (x:X) => idpath (g x))) = fun Z => idpath Z. Proof. apply path_forall; intros Z. assert (IsHSet (Z.1 = Z.1)) by exact _. baut_reduce. exact (ap (path_sigma_hprop _ _) path_universe_1 @ path_sigma_hprop_1 _). Defined. (** Similarly, if [X] is a 1-type, we can characterize the 2-center of [BAut X]. *) (** Coq is too eager about unfolding some things appearing in this proof. *) Section Center2BAut. Local Arguments equiv_path_equiv : simpl never. Local Arguments equiv_path2_universe : simpl never. Definition center2_baut `{Univalence} X `{IsTrunc 1 X} : { f : forall x:X, x=x & forall (g:X<~>X) (x:X), ap g (f x) = f (g x) } <~> (forall Z:BAut X, (idpath Z) = (idpath Z)). Proof. refine ((equiv_functor_forall_id (fun Z => (equiv_concat_lr _ _) oE (equiv_ap (equiv_path_sigma_hprop Z Z) 1%path 1%path))) oE _). { symmetry; apply path_sigma_hprop_1. } { apply path_sigma_hprop_1. } assert (forall Z:BAut X, IsHSet (idpath Z.1 = idpath Z.1)) by exact _. refine (baut_ind_hset X (fun Z => idpath Z = idpath Z) oE _). simple refine (equiv_functor_sigma' _ _). { refine (_ oE equiv_path2_universe 1 1). apply equiv_concat_lr. - symmetry; apply path_universe_1. - apply path_universe_1. } intros f. apply equiv_functor_forall_id; intros g. refine (_ oE equiv_path3_universe _ _). refine (dpath_paths2 (path_universe g) _ _ oE _). cbn. change (equiv_idmap X == equiv_idmap X) in f. refine (equiv_concat_lr _ _). - refine (_ @ (path2_universe_postcompose_idmap f g)^). abstract (rewrite !whiskerR_pp, !concat_pp_p; reflexivity). - refine (path2_universe_precompose_idmap f g @ _). abstract (rewrite !whiskerL_pp, !concat_pp_p; reflexivity). Defined. (** Once again we compute it on the identity. In this case it seems to be unavoidable to do some [simpl]ing (or at least [cbn]ing), making this proof somewhat slower. *) Definition id_center2_baut `{Univalence} X `{IsTrunc 1 X} : center2_baut X (exist (fun (f:forall x:X, x=x) => forall (g:X<~>X) (x:X), ap g (f x) = f (g x)) (fun x => idpath x) (fun (g:X<~>X) (x:X) => idpath (idpath (g x)))) = fun Z => idpath (idpath Z). Proof. apply path_forall; intros Z. assert (IsHSet (idpath Z.1 = idpath Z.1)) by exact _. baut_reduce. cbn. unfold functor_forall, sig_rect, merely_rec_hset. cbn. rewrite equiv_path2_universe_1. rewrite !concat_p1, !concat_Vp. simpl. rewrite !concat_p1, !concat_Vp. reflexivity. Defined. End Center2BAut. Section ClassifyingMaps. (** ** Maps into [BAut F] classify bundles with fiber [F] *) (** The property of being merely equivalent to a given type [F] defines a subuniverse. *) Definition subuniverse_merely_equiv (F : Type) : Subuniverse. Proof. rapply (Build_Subuniverse (fun E => merely (E <~> F))). intros T U mere_eq f iseq_f. strip_truncations. pose (feq:=Build_Equiv _ _ f iseq_f). exact (tr (mere_eq oE feq^-1)). Defined. (** The universe of O-local types for [subuniverse_merely_equiv F] is equivalent to [BAut F]. *) Proposition equiv_baut_typeO `{Univalence} {F : Type} : BAut F <~> Type_ (subuniverse_merely_equiv F). Proof. srapply equiv_functor_sigma_id; intro X; cbn. rapply Trunc_functor_equiv. exact (equiv_path_universe _ _)^-1%equiv. Defined. (** Consequently, maps into [BAut F] correspond to bundles with fibers merely equivalent to [F]. *) Corollary equiv_map_baut_fibration `{Univalence} {Y : pType} {F : Type} : (Y -> BAut F) <~> { p : Slice Y & forall y:Y, merely (hfiber p.2 y <~> F) }. Proof. refine (_ oE equiv_postcompose' equiv_baut_typeO). refine (_ oE equiv_sigma_fibration_O). snrapply equiv_functor_sigma_id; intro p. rapply equiv_functor_forall_id; intro y. by apply Trunc_functor_equiv. Defined. (** The pointed version of [equiv_baut_typeO] above. *) Proposition pequiv_pbaut_typeOp@{u v +} `{Univalence} {F : Type@{u}} : pBAut@{u v} F <~>* [Type_ (subuniverse_merely_equiv F), (F; tr equiv_idmap)]. Proof. snrapply Build_pEquiv'; cbn. 1: exact equiv_baut_typeO. by apply path_sigma_hprop. Defined. Definition equiv_pmap_pbaut_pfibration `{Univalence} {Y F : pType@{u}} : (Y ->* pBAut@{u v} F) <~> { p : { q : pSlice Y & forall y:Y, merely (hfiber q.2 y <~> F) } & pfiber p.1.2 <~>* F } := (equiv_sigma_pfibration_O (subuniverse_merely_equiv F)) oE pequiv_pequiv_postcompose pequiv_pbaut_typeOp. (** When [Y] is connected, pointed maps into [pBAut F] correspond to maps into the universe sending the base point to [F]. *) Proposition equiv_pmap_pbaut_type_p `{Univalence} {Y : pType@{u}} {F : Type@{u}} `{IsConnected 0 Y} : (Y ->* pBAut F) <~> (Y ->* [Type@{u}, F]). Proof. refine (_ oE pequiv_pequiv_postcompose pequiv_pbaut_typeOp). rapply equiv_pmap_typeO_type_connected. Defined. (** When [Y] is connected, [pBAut F] classifies fiber sequences over [Y] with fiber [F]. *) Definition equiv_pmap_pbaut_pfibration_connected `{Univalence} {Y F : pType} `{IsConnected 0 Y} : (Y ->* pBAut F) <~> { X : pType & FiberSeq F X Y } := classify_fiberseq oE equiv_pmap_pbaut_type_p. End ClassifyingMaps. Coq-HoTT-9.0/theories/Universes/DProp.v000066400000000000000000000232471474641544500177660ustar00rootroot00000000000000(** * Decidable propositions *) Require Import HoTT.Basics HoTT.Types. Require Import TruncType HProp. Require Import Truncations.Core Modalities.ReflectiveSubuniverse. Local Open Scope path_scope. (** ** Definitions *) (** A decidable proposition is, morally speaking, an HProp that is decidable. However, we only require that it be an HProp under the additional assumption of [Funext]; this enables decidable propositions to usually be used without [Funext] hypotheses. *) Record DProp := { dprop_type : Type ; ishprop_dprop : Funext -> IsHProp dprop_type ; dec_dprop : Decidable dprop_type }. (** A fancier definition, which would have the property that negation is judgmentally involutive, would be << Record DProp := { dprop_holds : Type ; ishprop_holds : Funext -> IsHProp dprop_holds ; dprop_denies : Type ; ishprop_denies : Funext -> IsHProp dprop_denies ; holds_or_denies : dprop_holds + dprop_denies ; denies_or_holds : dprop_denies + dprop_holds ; not_holds_and_denies : dprop_holds -> dprop_denies -> Empty }. >> At some point we may want to go that route, but it would be more work. In particualar, [Instance]s of [Decidable] wouldn't be automatically computed for us, and the characterization of the homotopy type of [DProp] itself would be a lot harder. *) Coercion dprop_type : DProp >-> Sortclass. Global Existing Instance ishprop_dprop. Global Existing Instance dec_dprop. (** Sometimes, however, we have decidable props that are hprops without funext, and we want to remember that. *) Record DHProp := { dhprop_hprop : HProp ; dec_dhprop : Decidable dhprop_hprop }. Coercion dhprop_hprop : DHProp >-> HProp. Global Existing Instance dec_dhprop. Definition dhprop_to_dprop : DHProp -> DProp := fun P => Build_DProp P (fun _ => _) _. Coercion dhprop_to_dprop : DHProp >-> DProp. (** In particular, [True] and [False] are always hprops. *) Definition True : DHProp := Build_DHProp Unit_hp (inl tt). Definition False : DHProp := Build_DHProp False_hp (inr idmap). (** Decidable props can be coerced to [Bool]. *) Definition dprop_to_bool (P : DProp) : Bool := if dec P then true else false. Coercion dprop_to_bool : DProp >-> Bool. (** And back again, but we don't declare that as a coercion. *) Definition bool_to_dhprop (b : Bool) : DHProp := if b then True else False. (** ** The type of decidable props *) Definition issig_dprop : { X : Type & { _ : Funext -> IsHProp X & Decidable X } } <~> DProp. Proof. issig. Defined. Definition equiv_path_dprop `{Funext} (P Q : DProp) : (P = Q :> Type) <~> (P = Q :> DProp). Proof. destruct P as [P hP dP]. destruct Q as [Q hQ dQ]. refine (((equiv_ap' issig_dprop^-1 _ _)^-1) oE _); cbn. refine ((equiv_ap' (equiv_sigma_assoc' _ _)^-1 ((P;hP);dP) ((Q;hQ);dQ)) oE _). refine (equiv_path_sigma_hprop _ _ oE _); cbn. { intros [X hX]; exact _. } refine (equiv_path_sigma_hprop (P;hP) (Q;hQ)). Defined. Definition path_dprop `{Funext} {P Q : DProp} : (P = Q :> Type) -> (P = Q :> DProp) := equiv_path_dprop P Q. Definition issig_dhprop : { X : HProp & Decidable X } <~> DHProp. Proof. issig. Defined. Definition equiv_path_dhprop' `{Funext} (P Q : DHProp) : (P = Q :> HProp) <~> (P = Q :> DHProp). Proof. destruct P as [P dP]. destruct Q as [Q dQ]. refine (((equiv_ap' issig_dhprop^-1 _ _)^-1) oE _); cbn. refine ((equiv_path_sigma_hprop (P; dP) (Q; dQ))). Defined. Definition equiv_path_dhprop `{Univalence} (P Q : DHProp) : (P = Q :> Type) <~> (P = Q :> DHProp). Proof. assert (eq_type_hprop : (P = Q :> Type) <~> (P = Q :> HProp)) by apply equiv_path_trunctype'. assert (eq_hprop_dhprop : (P = Q :> HProp) <~> (P = Q :> DHProp)) by apply equiv_path_dhprop'. refine (eq_hprop_dhprop oE eq_type_hprop). Defined. Definition path_dhprop `{Univalence} {P Q : DHProp} : (P = Q :> Type) -> (P = Q :> DHProp) := equiv_path_dhprop P Q. Global Instance ishset_dprop `{Univalence} : IsHSet DProp. Proof. apply istrunc_S; intros P Q. refine (istrunc_equiv_istrunc _ (n := -1) (equiv_path_dprop P Q)). Defined. Global Instance isequiv_dprop_to_bool `{Univalence} : IsEquiv dprop_to_bool. Proof. refine (isequiv_adjointify dprop_to_bool bool_to_dhprop _ _). - intros []; reflexivity. - intros P; unfold dprop_to_bool. destruct (dec P); symmetry; apply path_dprop, path_universe_uncurried. + apply if_hprop_then_equiv_Unit; [ exact _ | assumption ]. + apply if_not_hprop_then_equiv_Empty; [ exact _ | assumption ]. Defined. Definition equiv_dprop_to_bool `{Univalence} : DProp <~> Bool := Build_Equiv _ _ dprop_to_bool _. (** ** Operations *) (** We define the logical operations on decidable hprops to be the operations on ordinary hprops, with decidability carrying over. For the operations which preserve hprops without funext, we define separate versions that act on [DHProp]. *) Definition dand (b1 b2 : DProp) : DProp := Build_DProp (b1 * b2) _ _. Definition dhand (b1 b2 : DHProp) : DHProp := Build_DHProp (Build_HProp (b1 * b2)) _. Definition dor (b1 b2 : DProp) : DProp := Build_DProp (hor b1 b2) _ _. Definition dhor (b1 b2 : DHProp) : DHProp := Build_DHProp (Build_HProp (hor b1 b2)) _. Definition dneg (b : DProp) : DProp := Build_DProp (~b) _ _. Definition dimpl (b1 b2 : DProp) : DProp := Build_DProp (b1 -> b2) _ _. Declare Scope dprop_scope. Delimit Scope dprop_scope with dprop. Bind Scope dprop_scope with DProp. Declare Scope dhprop_scope. Delimit Scope dhprop_scope with dhprop. Bind Scope dhprop_scope with DHProp. Infix "&&" := dand : dprop_scope. Infix "&&" := dhand : dhprop_scope. Infix "||" := dor : dprop_scope. Infix "||" := dhor : dhprop_scope. Infix "->" := dimpl : dprop_scope. Notation "!! P" := (dneg P) : dprop_scope. Local Open Scope dprop_scope. (** ** Computation *) (** In order to be able to "compute" with [DProp]s like booleans, we define a couple of typeclasses. *) Class IsTrue (P : DProp) := dprop_istrue : P. Class IsFalse (P : DProp) := dprop_isfalse : ~ P. (** Note that we are not using [Typeclasses Strict Resolution] for [IsTrue] and [IsFalse]; this enables us to write simply [dprop_istrue] as a proof of some true dprop, and Coq will infer from context what the dprop is that we're proving. *) Global Instance true_istrue : IsTrue True := tt. Global Instance false_isfalse : IsFalse False := idmap. Global Instance dand_true_true {P Q} `{IsTrue P} `{IsTrue Q} : IsTrue (P && Q). Proof. exact (dprop_istrue, dprop_istrue). Defined. Global Instance dand_false_l {P Q} `{IsFalse P} : IsFalse (P && Q). Proof. intros [p q]. exact (dprop_isfalse p). Defined. Global Instance dand_false_r {P Q} `{IsFalse Q} : IsFalse (P && Q). Proof. intros [p q]. exact (dprop_isfalse q). Defined. Global Instance dhand_true_true {P Q : DHProp} `{IsTrue P} `{IsTrue Q} : IsTrue (P && Q)%dhprop. Proof. (** We have to give [P] as an explicit argument here. This is apparently because with two [IsTrue] instances in the context, when we write simply [dprop_istrue], Coq guesses one of them during typeclass resolution, and isn't willing to backtrack once it realizes that that choice fails to be what's needed to solve the goal. Coq currently seems to consistently guess [Q] rather than [P], so that we don't have to give the argument [Q] to the second call to [dprop_istrue]; but rather than depend on such behavior, we give both arguments explicitly. (The problem doesn't arise with [dand_true_true] because in that case, unification, which fires before typeclass search, is able to guess that the argument must be [P].) *) exact (@dprop_istrue P _, @dprop_istrue Q _). Defined. Global Instance dhand_false_l {P Q : DHProp} `{IsFalse P} : IsFalse (P && Q)%dhprop. Proof. intros [p q]. exact (dprop_isfalse p). Defined. Global Instance dhand_false_r {P Q : DHProp} `{IsFalse Q} : IsFalse (P && Q)%dhprop. Proof. intros [p q]. exact (dprop_isfalse q). Defined. Global Instance dor_true_l {P Q} `{IsTrue P} : IsTrue (P || Q). Proof. exact (tr (inl Q dprop_istrue)). Defined. Global Instance dor_true_r {P Q} `{IsTrue Q} : IsTrue (P || Q). Proof. exact (tr (inr P dprop_istrue)). Defined. Global Instance dor_false_false {P Q} `{IsFalse P} `{IsFalse Q} : IsFalse (P || Q). Proof. intros pq. strip_truncations. destruct pq as [p|q]. - exact (dprop_isfalse p). - exact (dprop_isfalse q). Defined. Global Instance dhor_true_l {P Q : DHProp} `{IsTrue P} : IsTrue (P || Q)%dhprop. Proof. exact (tr (inl Q dprop_istrue)). Defined. Global Instance dhor_true_r {P Q : DHProp} `{IsTrue Q} : IsTrue (P || Q)%dhprop. Proof. exact (tr (inr P dprop_istrue)). Defined. Global Instance dhor_false_false {P Q : DHProp} `{IsFalse P} `{IsFalse Q} : IsFalse (P || Q)%dhprop. Proof. intros pq. strip_truncations. destruct pq as [p|q]. (** See comment in the proof of [dhand_true_true]. *) - exact (@dprop_isfalse P _ p). - exact (@dprop_isfalse Q _ q). Defined. Global Instance dneg_true {P} `{IsTrue P} : IsFalse (!! P). Proof. intros np; exact (np dprop_istrue). Defined. Global Instance dneg_false {P} `{IsFalse P} : IsTrue (!! P). Proof. exact dprop_isfalse. Defined. Global Instance dimpl_true_r {P Q} `{IsTrue Q} : IsTrue (P -> Q). Proof. intros p. exact dprop_istrue. Defined. Global Instance dimpl_false_l {P Q} `{IsFalse P} : IsTrue (P -> Q). Proof. intros p. elim (dprop_isfalse p). Defined. Global Instance dimpl_true_false {P Q} `{IsTrue P} `{IsFalse Q} : IsFalse (P -> Q). Proof. intros f. exact (dprop_isfalse (f dprop_istrue)). Defined. Lemma path_dec (A :Type) `{IsHProp A} `{Decidable A} `{Univalence} : A = is_inl (dec A). Proof. refine (path_universe_uncurried _). apply equiv_iff_hprop_uncurried. split. - intros b. destruct (dec A); simpl; auto. - destruct (dec A); simpl; auto. intros []. Defined. Coq-HoTT-9.0/theories/Universes/HProp.v000066400000000000000000000206151474641544500177660ustar00rootroot00000000000000(** * HPropositions *) Require Import Basics. Require Import Types.Empty Types.Unit Types.Prod Types.Paths Types.Sigma Types.Equiv. Local Open Scope path_scope. Generalizable Variables A B. (** ** Alternate characterization of hprops. *) Theorem equiv_hprop_allpath `{Funext} (A : Type) : IsHProp A <~> (forall (x y : A), x = y). Proof. rapply (equiv_iff_hprop (@path_ishprop A) (@hprop_allpath A)). apply hprop_allpath; intros f g. funext x y. pose (C := Build_Contr A x (f x)). apply path_contr. Defined. Theorem equiv_hprop_inhabited_contr `{Funext} {A} : IsHProp A <~> (A -> Contr A). Proof. apply (equiv_adjointify (@contr_inhabited_hprop A) (@hprop_inhabited_contr A)). - intro ic. by_extensionality x. apply @path_contr. apply contr_istrunc. exact (ic x). - intro hp. apply path_ishprop. Defined. (** Being an hprop is also equivalent to the diagonal being an equivalence. *) Definition ishprop_isequiv_diag {A} `{IsEquiv _ _ (fun (a:A) => (a,a))} : IsHProp A. Proof. apply hprop_allpath; intros x y. set (d := fun (a:A) => (a,a)) in *. transitivity (fst (d (d^-1 (x,y)))). - exact (ap fst (eisretr d (x,y))^). - transitivity (snd (d (d^-1 (x,y)))). + unfold d; reflexivity. + exact (ap snd (eisretr d (x,y))). Defined. Global Instance isequiv_diag_ishprop {A} `{IsHProp A} : IsEquiv (fun (a:A) => (a,a)). Proof. refine (isequiv_adjointify _ fst _ _). - intros [x y]. apply path_prod; simpl. + reflexivity. + apply path_ishprop. - intros a; simpl. reflexivity. Defined. (** ** A map is an embedding as soon as its ap's have sections. *) Definition isembedding_sect_ap {X Y} (f : X -> Y) (s : forall x1 x2, (f x1 = f x2) -> (x1 = x2)) (H : forall x1 x2, (@ap X Y f x1 x2) o (s x1 x2) == idmap) : IsEmbedding f. Proof. intros y. apply hprop_allpath. intros [x1 p1] [x2 p2]. apply path_sigma with (s x1 x2 (p1 @ p2^)). abstract (rewrite transport_paths_Fl; cbn; rewrite (H x1 x2 (p1 @ p2^)); rewrite inv_pp, inv_V; apply concat_pV_p). Defined. (** ** Alternate characterizations of contractibility. *) Theorem equiv_contr_inhabited_hprop `{Funext} {A} : Contr A <~> A * IsHProp A. Proof. assert (f : Contr A -> A * IsHProp A). - intro P. split. + exact (@center _ P). + apply @istrunc_succ. exact P. - assert (g : A * IsHProp A -> Contr A). + intros [a P]. apply (@contr_inhabited_hprop _ P a). + refine (@equiv_iff_hprop _ _ _ _ f g). apply hprop_inhabited_contr; intro p. apply @contr_prod. * exact (g p). * apply (@contr_inhabited_hprop _ _ (snd p)). Defined. Theorem equiv_contr_inhabited_allpath `{Funext} {A} : Contr A <~> A * forall (x y : A), x = y. Proof. transitivity (A * IsHProp A). - apply equiv_contr_inhabited_hprop. - exact (1 *E equiv_hprop_allpath _). Defined. (** ** Logical equivalence of hprops *) (** Logical equivalence of hprops is not just logically equivalent to equivalence, it is equivalent to it. *) Global Instance isequiv_equiv_iff_hprop_uncurried `{Funext} {A B} `{IsHProp A} `{IsHProp B} : IsEquiv (@equiv_iff_hprop_uncurried A _ B _) | 0. Proof. pose (@istrunc_equiv). refine (isequiv_adjointify equiv_iff_hprop_uncurried (fun e => (@equiv_fun _ _ e, @equiv_inv _ _ e _)) _ _); intro; by apply path_ishprop. Defined. Definition equiv_equiv_iff_hprop `{Funext} (A B : Type) `{IsHProp A} `{IsHProp B} : (A <-> B) <~> (A <~> B) := Build_Equiv _ _ (@equiv_iff_hprop_uncurried A _ B _) _. (** ** Inhabited and uninhabited hprops *) (** If an hprop is inhabited, then it is equivalent to [Unit]. *) Lemma if_hprop_then_equiv_Unit (hprop : Type) `{IsHProp hprop} : hprop -> hprop <~> Unit. Proof. intro p. apply equiv_iff_hprop. - exact (fun _ => tt). - exact (fun _ => p). Defined. (** If an hprop is not inhabited, then it is equivalent to [Empty]. *) Lemma if_not_hprop_then_equiv_Empty (hprop : Type) `{IsHProp hprop} : ~hprop -> hprop <~> Empty. Proof. intro np. exact (Build_Equiv _ _ np _). Defined. (** Thus, a decidable hprop is either equivalent to [Unit] or [Empty]. *) Definition equiv_decidable_hprop (hprop : Type) `{IsHProp hprop} `{Decidable hprop} : (hprop <~> Unit) + (hprop <~> Empty). Proof. destruct (dec hprop) as [x|nx]. - exact (inl (if_hprop_then_equiv_Unit hprop x)). - exact (inr (if_not_hprop_then_equiv_Empty hprop nx)). Defined. (** ** Stable types and stable hprops *) (** Recall that a type [A] is "stable" if [~~A -> A]. *) (** When [A] is an hprop, so is [Stable A] (by [ishprop_stable_hprop]), so [Stable A * IsHProp A] is an hprop for any [A]. *) Global Instance ishprop_stable_ishprop `{Funext} (A : Type) : IsHProp (Stable A * IsHProp A). Proof. apply istrunc_inhabited_istrunc; intros [stable ishprop]. exact _. Defined. (** Under function extensionality, if [A] is a stable type, then [~~A] is the propositional truncation of [A]. Here, for dependency reasons, we don't give the equivalence to [Tr (-1) A], but just show that the recursion principle holds. See Metatheory/ImpredicativeTruncation.v for a generalization to all types, and Modalities/Notnot.v for a description of the universal property of [~~A] when [A] is not assumed to be stable. *) (** Any negation is an hprop, by [istrunc_Empty] and [istrunc_arrow]. In particular, double-negation is an hprop. *) Definition ishprop_not_not `{Funext} {A : Type} : IsHProp (~~A) := _. (** The recursion principle for [~~A] when [A] is stable. *) Definition not_not_rec {A : Type} `{stable : Stable A} (P : HProp) (f : A -> P) : ~~A -> P. Proof. intro nna. exact (f (stable nna)). Defined. (** The unit is [not_not_unit : A -> ~~A], and the computation rule only holds propositionally. *) Definition not_not_rec_beta {A : Type} `{Stable A} (P : HProp) (f : A -> P) (a : A) : not_not_rec P f (not_not_unit a) = f a := path_ishprop _ _. (** The map [A -> ~~A] is an equivalence if and only if [A] is a stable hprop. This characterizes the local types for the double-negation modality. See Modality/Notnot.v. *) Definition isequiv_not_not_unit_iff_stable_hprop `{Funext} A : IsEquiv (@not_not_unit A) <-> (Stable A * IsHProp A). Proof. split. - intros iseq. pose proof (eq := (Build_Equiv _ _ _ iseq)^-1%equiv); clear iseq. exact (stable_equiv eq _, istrunc_equiv_istrunc _ eq). - intros [stable ishprop]. rapply isequiv_iff_hprop. apply stable. Defined. (** We can upgrade the previous "iff" result to an equivalence. *) Definition equiv_isequiv_not_not_unit_stable_hprop `{Funext} (P : Type) : IsEquiv (@not_not_unit P) <~> (Stable P * IsHProp P) := equiv_iff_hprop_uncurried (isequiv_not_not_unit_iff_stable_hprop P). (** ** A generalization of [ishprop_decpaths] *) (** Under [Funext], [ishprop_decpaths] shows that [DecidablePaths A] is an hprop. More generally, it's also an hprop with the first argument fixed. *) Global Instance ishprop_decpaths' `{Funext} {A : Type} (x : A) : IsHProp (forall (y : A), Decidable (x = y)). Proof. apply hprop_allpath; intros d d'. (* Define [C] to be the component of [A] containing [x]. Since [x = y] is decidable, it is stable, so we can use [~~(x = y)] as an elementary form of propositional truncation. It also works to use [merely] here, but that brings in further dependencies and requires HITs. *) pose (C := {y : A & ~~(x = y)}). assert (cC : Contr C). { snrapply (Build_Contr C (x; not_not_unit idpath)). intros [y p]. srapply path_sigma_hprop; cbn. (* [d y] either solves the goal or contradicts [p]. *) by destruct (d y). } funext y. generalize (d y); clear d; intros d. generalize (d' y); clear d'; intros d'. destruct d as [d | nd]; destruct d' as [d' | nd']. - apply ap. (* [x] and [y] are "in" the component [C]: *) pose (xC := (x; not_not_unit idpath) : C). pose (yC := (y; not_not_unit d) : C). (* [d] and [d'] can be lifted to equalities of type [xC = yC] using [path_sigma_hprop], and so up to the computation rule for [pr1_path] (denoted "..1"), our goal is in the image of "..1". *) refine ((pr1_path_path_sigma_hprop xC yC d)^ @ _ @ pr1_path_path_sigma_hprop xC yC d'). (* But since [C] is an hset, the paths in [C] are equal. *) apply ap, path_ishprop. (* The remaining cases are the same as in [ishprop_decpaths], but the last bullet is shorter since typeclass search tells us that [x <> y] is an hprop. *) - elim (nd' d). - elim (nd d'). - apply ap, path_ishprop. Defined. Coq-HoTT-9.0/theories/Universes/HSet.v000066400000000000000000000114261474641544500176010ustar00rootroot00000000000000Require Import Basics. Require Import Types.Sigma Types.Paths Types.Unit Types.Arrow. (** * H-Sets *) Local Open Scope path_scope. (** A type is a set if and only if it satisfies Axiom K. *) Definition axiomK A := forall (x : A) (p : x = x), p = idpath x. Definition axiomK_hset {A} : IsHSet A -> axiomK A. Proof. intros H x p. nrapply path_ishprop. exact (H x x). Defined. Definition hset_axiomK {A} `{axiomK A} : IsHSet A. Proof. apply istrunc_S; intros x y. apply @hprop_allpath. intros p q. by induction p. Defined. Section AssumeFunext. Context `{Funext}. Theorem equiv_hset_axiomK {A} : IsHSet A <~> axiomK A. Proof. apply (equiv_adjointify (@axiomK_hset A) (@hset_axiomK A)). - intros K. by_extensionality x. by_extensionality x'. cut (Contr (x=x)). + intro. eapply path_contr. + apply (Build_Contr _ 1). intros. symmetry; apply K. - intro K. eapply path_ishprop. Defined. Global Instance axiomK_isprop A : IsHProp (axiomK A) | 0. Proof. apply (istrunc_equiv_istrunc _ equiv_hset_axiomK). Defined. Theorem hset_path2 {A} `{IsHSet A} {x y : A} (p q : x = y): p = q. Proof. induction q. apply axiomK_hset; assumption. Defined. (** Recall that axiom K says that any self-path is homotopic to the identity path. In particular, the identity path is homotopic to itself. The following lemma says that the endo-homotopy of the identity path thus specified is in fact (homotopic to) its identity homotopy (whew!). *) (* TODO: What was the purpose of this lemma? Do we need it at all? It's actually fairly trivial. *) Lemma axiomK_idpath {A} (x : A) (K : axiomK A) : K x (idpath x) = idpath (idpath x). Proof. pose (T1A := @istrunc_succ _ A (@hset_axiomK A K)). exact (@hset_path2 (x=x) (T1A x x) _ _ _ _). Defined. End AssumeFunext. (** We prove that if [R] is a reflexive mere relation on [X] implying identity, then [X] is an hSet, and hence [R x y] is equivalent to [x = y]. *) Lemma ishset_hrel_subpaths {X R} `{Reflexive X R} `{forall x y, IsHProp (R x y)} (f : forall x y, R x y -> x = y) : IsHSet X. Proof. apply @hset_axiomK. intros x p. refine (_ @ concat_Vp (f x x (transport (R x) p^ (reflexivity _)))). apply moveL_Vp. refine ((transport_paths_r _ _)^ @ _). refine ((transport_arrow _ _ _)^ @ _). refine ((ap10 (apD (f x) p) (@reflexivity X R _ x)) @ _). apply ap. apply path_ishprop. Defined. Global Instance isequiv_hrel_subpaths X R `{Reflexive X R} `{forall x y, IsHProp (R x y)} (f : forall x y, R x y -> x = y) x y : IsEquiv (f x y) | 10000. Proof. pose proof (ishset_hrel_subpaths f). refine (isequiv_adjointify (f x y) (fun p => transport (R x) p (reflexivity x)) _ _); intro; apply path_ishprop. Defined. (** We will now prove that for sets, monos and injections are equivalent.*) Definition ismono {X Y} (f : X -> Y) := forall (Z : HSet), forall g h : Z -> X, f o g = f o h -> g = h. Global Instance isinj_embedding {A B : Type} (m : A -> B) : IsEmbedding m -> IsInjective m. Proof. intros ise x y p. pose (ise (m y)). assert (q : (x;p) = (y;1) :> hfiber m (m y)) by apply path_ishprop. exact (ap pr1 q). Defined. (** Computation rule for isinj_embedding. *) Lemma isinj_embedding_beta {X Y : Type} (f : X -> Y) {I : IsEmbedding f} {x : X} : (isinj_embedding f I x x idpath) = idpath. Proof. exact (ap (ap pr1) (contr (idpath : (x;idpath) = (x;idpath)))). Defined. Definition isinj_section {A B : Type} {s : A -> B} {r : B -> A} (H : r o s == idmap) : IsInjective s. Proof. intros a a' alpha. exact ((H a)^ @ ap r alpha @ H a'). Defined. Lemma isembedding_isinj_hset {A B : Type} `{IsHSet B} (m : A -> B) : IsInjective m -> IsEmbedding m. Proof. intros isi b. apply hprop_allpath; intros [x p] [y q]. apply path_sigma_hprop; simpl. exact (isi x y (p @ q^)). Defined. Lemma ismono_isinj `{Funext} {X Y} (f : X -> Y) : IsInjective f -> ismono f. Proof. intros ? ? ? ? H'. apply path_forall. apply ap10 in H'. hnf in *. eauto. Qed. Definition isinj_ismono {X Y} (f : X -> Y) (H : ismono f) : IsInjective f := fun x0 x1 H' => ap10 (H (Build_HSet Unit) (fun _ => x0) (fun _ => x1) (ap (fun x => unit_name x) H')) tt. Lemma ismono_isequiv `{Funext} X Y (f : X -> Y) `{IsEquiv _ _ f} : ismono f. Proof. intros ? g h H'. apply ap10 in H'. apply path_forall. intro x. transitivity (f^-1 (f (g x))). - by rewrite eissect. - transitivity (f^-1 (f (h x))). * apply ap. apply H'. * by rewrite eissect. Qed. Lemma cancelL_isembedding {A B C : Type} `{IsHSet B} {f : A -> B} {g : B -> C} `{IsEmbedding (g o f)} : IsEmbedding f. Proof. rapply isembedding_isinj_hset. rapply (isinj_cancelL _ g). Defined. Coq-HoTT-9.0/theories/Universes/ObjectClassifier.v000066400000000000000000000167521474641544500221600ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types HFiber Limits.Pullback Pointed Truncations. Local Open Scope pointed_scope. (** * The object classifier *) (** We prove that type families correspond to fibrations [equiv_sigma_fibration] (Theorem 4.8.3) and the projection [pointed_type : pType -> Type] is an object classifier [ispullback_square_objectclassifier] (Theorem 4.8.4). *) (** We denote the type of all maps into a type [Y] as follows, and refer to them "bundles over Y". *) Definition Slice (Y : Type@{u}) := { X : Type@{u} & X -> Y }. Definition pSlice (Y : pType@{u}) := { X : pType@{u} & X ->* Y }. Definition sigma_fibration@{u v} {Y : Type@{u}} (P : Y -> Type@{u}) : Slice@{u v} Y := (sig@{u u} P; pr1). Definition sigma_fibration_inverse {Y : Type@{u}} (p : Slice Y) : Y -> Type@{u} := hfiber p.2. Theorem isequiv_sigma_fibration `{Univalence} {Y : Type} : IsEquiv (@sigma_fibration Y). Proof. srapply isequiv_adjointify. - exact sigma_fibration_inverse. - intros [X p]. srapply path_sigma; cbn. + exact (path_universe (equiv_fibration_replacement _)^-1%equiv). + apply transport_arrow_toconst_path_universe. - intro P. funext y; cbn. exact ((path_universe (@hfiber_fibration _ y P))^). Defined. (** Theorem 4.8.3. *) Definition equiv_sigma_fibration `{Univalence} {Y : Type@{u}} : (Y -> Type@{u}) <~> { X : Type@{u} & X -> Y } := Build_Equiv _ _ _ isequiv_sigma_fibration. (** The universal map is the forgetful map [pointed_type : pType -> Type]. *) (** We construct the universal square for the object classifier. *) Local Definition topmap {A : Type} (P : A -> Type) (e : sig P) : pType := [P e.1, e.2]. (** The square commutes definitionally. *) Definition objectclassifier_square {A : Type} (P : A -> Type) : P o pr1 == pointed_type o (topmap P) := fun e : sig P => idpath (P e.1). (** Theorem 4.8.4. *) Theorem ispullback_objectclassifier_square {A : Type} (P : A -> Type) : IsPullback (objectclassifier_square P). Proof. srapply isequiv_adjointify. - intros [a [F p]]. exact (a; transport idmap p^ (point F)). - intros [a [[T t] p]]; cbn in p. refine (path_sigma' _ (idpath a) _). by induction p. - reflexivity. Defined. (** ** Classifying bundles with specified fiber *) (** Bundles over [B] with fiber [F] correspond to pointed maps into the universe pointed at [F]. *) Proposition equiv_sigma_fibration_p@{u v +} `{Univalence} {Y : pType@{u}} {F : Type@{u}} : (Y ->* [Type@{u}, F]) <~> { p : Slice@{u v} Y & hfiber p.2 (point Y) <~> F }. Proof. refine (_ oE (issig_pmap _ _)^-1). srapply (equiv_functor_sigma' equiv_sigma_fibration); intro P; cbn. refine (_ oE (equiv_path_universe@{u u v} _ _)^-1%equiv). refine (equiv_functor_equiv _ equiv_idmap). apply hfiber_fibration. Defined. (** If the fiber [F] is pointed we may upgrade the right-hand side to pointed fiber sequences. *) Lemma equiv_pfiber_fibration_pfibration@{u v} {Y F : pType@{u}} : { p : Slice@{u v} Y & hfiber p.2 (point Y) <~> F} <~> { p : pSlice@{u v} Y & pfiber p.2 <~>* F }. Proof. equiv_via (sig@{v u} (fun X : Type@{u} => { x : X & { p : X -> Y & { eq : p x = point Y & { e : hfiber p (point Y) <~> F & e^-1 (point F) = (x; eq) } } } })). - refine (_ oE _). + do 5 (rapply equiv_functor_sigma_id; intro). apply equiv_path_sigma. + cbn; make_equiv_contr_basedpaths. - refine (_ oE _). 2: { do 5 (rapply equiv_functor_sigma_id; intro). exact (equiv_path_inverse _ _ oE equiv_moveL_equiv_M _ _). } make_equiv. Defined. Definition equiv_sigma_pfibration@{u v +} `{Univalence} {Y F : pType@{u}} : (Y ->* [Type@{u}, F]) <~> { p : pSlice@{u v} Y & pfiber p.2 <~>* F} := equiv_pfiber_fibration_pfibration oE equiv_sigma_fibration_p. (** * The classifier for O-local types *) (** Families of O-local types correspond to bundles with O-local fibers. *) Theorem equiv_sigma_fibration_O@{u v} `{Univalence} {O : Subuniverse} {Y : Type@{u}} : (Y -> Type_@{u v} O) <~> { p : { X : Type@{u} & X -> Y } & MapIn O p.2 }. Proof. refine (_ oE (equiv_sig_coind@{u v u v v v u} _ _)^-1). apply (equiv_functor_sigma'@{v u v v v v} equiv_sigma_fibration@{u v}); intro P; cbn. rapply equiv_forall_inO_mapinO_pr1. Defined. (** ** Classifying O-local bundles with specified fiber *) (** We consider a pointed base [Y], and the universe of O-local types [Type_ O] pointed at some O-local type [F]. *) (** Pointed maps into [Type_ O] correspond to O-local bundles with fiber [F] over the base point of [Y]. *) Proposition equiv_sigma_fibration_Op@{u v +} `{Univalence} {O : Subuniverse} {Y : pType@{u}} {F : Type@{u}} `{inO : In O F} : (Y ->* [Type_ O, (F; inO)]) <~> { p : { q : Slice@{u v} Y & MapIn O q.2 } & hfiber p.1.2 (point Y) <~> F }. Proof. refine (_ oE (issig_pmap _ _)^-1); cbn. srapply (equiv_functor_sigma' equiv_sigma_fibration_O); intro P; cbn. refine (_ oE (equiv_path_sigma_hprop _ _)^-1%equiv); cbn. refine (_ oE (equiv_path_universe _ _)^-1%equiv). refine (equiv_functor_equiv _ equiv_idmap). exact (hfiber_fibration (point Y) _). Defined. (** When the base [Y] is connected, the fibers being O-local follow from the fact that the fiber [F] over the base point is. *) Proposition equiv_sigma_fibration_Op_connected@{u v +} `{Univalence} {O : Subuniverse} {Y : pType@{u}} `{IsConnected 0 Y} {F : Type@{u}} `{inO : In O F} : (Y ->* [Type_ O, (F; inO)]) <~> { p : Slice@{u v} Y & hfiber p.2 (point Y) <~> F }. Proof. refine (_ oE equiv_sigma_fibration_Op). refine (_ oE (equiv_sigma_assoc' _ (fun p _ => hfiber p.2 (point Y) <~> F))^-1%equiv). srapply equiv_functor_sigma_id; intro; cbn. refine (_ oE equiv_sigma_symm0 _ _). apply equiv_sigma_contr; intro e. rapply contr_inhabited_hprop. rapply conn_point_elim. apply (inO_equiv_inO F e^-1). Defined. (** *** Classifying O-local bundles with specified pointed fiber *) (** When the fiber [F] is pointed, the right-hand side can be upgraded to pointed fiber sequences with O-local fibers. *) Proposition equiv_sigma_pfibration_O `{Univalence} (O : Subuniverse) {Y F : pType} `{inO : In O F} : (Y ->* [Type_ O, (pointed_type F; inO)]) <~> { p : { q : pSlice Y & MapIn O q.2 } & pfiber p.1.2 <~>* F }. Proof. refine (_ oE equiv_sigma_fibration_Op). refine (_ oE equiv_sigma_symm' _ (fun q => hfiber q.2 (point Y) <~> F)). refine (equiv_sigma_symm' (fun q => pfiber q.2 <~>* F) _ oE _). by rapply (equiv_functor_sigma' equiv_pfiber_fibration_pfibration). Defined. (** When moreover the base [Y] is connected, the right-hand side is exactly the type of pointed fiber sequences, since the fibers being O-local follow from [F] being O-local and [Y] connected. *) Definition equiv_sigma_pfibration_O_connected@{u v +} `{Univalence} (O : Subuniverse) {Y F : pType@{u}} `{IsConnected 0 Y} `{inO : In O F} : (Y ->* [Type_ O, (pointed_type F; inO)]) <~> { p : pSlice@{u v} Y & pfiber p.2 <~>* F } := equiv_pfiber_fibration_pfibration oE equiv_sigma_fibration_Op_connected. (** As a corollary, pointed maps into the unverse of O-local types are just pointed maps into the universe, when the base [Y] is connected. *) Definition equiv_pmap_typeO_type_connected `{Univalence} {O : Subuniverse} {Y : pType@{u}} `{IsConnected 0 Y} {F : Type@{u}} `{inO : In O F} : (Y ->* [Type_ O, (F; inO)]) <~> (Y ->* [Type@{u}, F]) := equiv_sigma_fibration_p^-1 oE equiv_sigma_fibration_Op_connected. Coq-HoTT-9.0/theories/Universes/Rigid.v000066400000000000000000000114671474641544500200010ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HFiber. Require Import Truncations. Require Import Universes.BAut. Local Open Scope trunc_scope. Local Open Scope path_scope. (** * Rigid types *) Class IsRigid (A : Type) := path_aut_rigid : forall f g : A <~> A, f == g. (** Assuming funext, rigidity is equivalent to contractibility of [A <~> A]. *) Global Instance contr_aut_rigid `{Funext} (A : Type) `{IsRigid A} : Contr (A <~> A). Proof. apply (Build_Contr _ equiv_idmap). intros f; apply path_equiv, path_arrow, path_aut_rigid. Defined. (** Assuming univalence, rigidity is equivalent to contractibility of [BAut A]. *) Global Instance contr_baut_rigid `{Univalence} {A : Type} `{IsRigid A} : Contr (BAut A). Proof. refine (contr_change_center (point (BAut A))). refine (contr_trunc_conn (Tr 0)). apply istrunc_S. intros Z W; baut_reduce. refine (istrunc_equiv_istrunc (n := -1) (A <~> A) (path_baut (point (BAut A)) (point (BAut A)))). Defined. Definition rigid_contr_Baut `{Univalence} {A : Type} `{Contr (BAut A)} : IsRigid A. Proof. unfold IsRigid. equiv_intro ((path_baut (point (BAut A)) (point (BAut A)))^-1) f. equiv_intro ((path_baut (point (BAut A)) (point (BAut A)))^-1) g. apply ap10, ap, ap, path_contr. Defined. (** ** HProps are rigid *) Global Instance rigid_ishprop (A : Type) `{IsHProp A} : IsRigid A. Proof. intros f g x; apply path_ishprop. Defined. (** ** Equivalences of BAut *) (** Under a truncatedness/connectedness assumption, multiplying by a rigid type doesn't change the automorphism oo-group. *) (** A lemma: a "monoid homomorphism up to homotopy" between endomorphism monoids restricts to automorphism groups. *) Definition aut_homomorphism_end `{Funext} {X Y : Type} (M : (X -> X) -> (Y -> Y)) (Mid : M idmap == idmap) (MC : forall f g, M (g o f) == M g o M f) : (X <~> X) -> (Y <~> Y). Proof. assert (MS : forall f g, g o f == idmap -> (M g) o (M f) == idmap). { intros g f s x. transitivity (M (f o g) x). + symmetry. refine (MC g f x). + transitivity (M idmap x). * apply ap10, ap, path_arrow. intros y; apply s. * apply Mid. } assert (ME : (forall f, IsEquiv f -> IsEquiv (M f))). { intros f ?. refine (isequiv_adjointify (M f) (M f^-1) _ _); apply MS; [ apply eisretr | apply eissect ]. } exact (fun f => (Build_Equiv _ _ (M f) (ME f _))). Defined. Definition baut_prod_rigid_equiv `{Univalence} (X A : Type) (n : trunc_index) `{IsTrunc n.+1 X} `{IsRigid A} `{IsConnected n.+1 A} : BAut X <~> BAut (X * A). Proof. refine (Build_Equiv _ _ (baut_prod_r X A) _). apply isequiv_surj_emb. { apply BuildIsSurjection; intros Z. baut_reduce. refine (tr (point _ ; _)). apply path_sigma_hprop; reflexivity. } { apply isembedding_isequiv_ap. intros Z W. pose (L := fun e : Z <~> W => equiv_functor_prod_r (B := A) e). refine (isequiv_commsq L (ap (baut_prod_r X A)) (path_baut Z W) (path_baut (baut_prod_r X A Z) (baut_prod_r X A W)) (fun e => (ap_baut_prod_r X A e)^)). refine ((isconnected_elim (Tr (-1)) (A := A) _ _).1). { apply contr_inhabited_hprop; [ exact _ | refine (merely_isconnected n A) ]. } intros a0. baut_reduce. pose (M := fun f:X*A -> X*A => fun x => fst (f (x,a0))). assert (MH : forall (a:A) (f:X*A -> X*A) (x:X), fst (f (x,a)) = fst (f (x,a0))). { refine (conn_map_elim (Tr n) (unit_name a0) _ _). intros; reflexivity. } assert (MC : forall (f g :X*A -> X*A), M (g o f) == M g o M f). { intros f g x; unfold M. transitivity (fst (g (fst (f (x,a0)), snd (f (x,a0))))). - reflexivity. - apply MH. } pose (M' := aut_homomorphism_end M (fun x => 1) MC). assert (Mker : forall f, M' f == 1%equiv -> f == 1%equiv). { unfold M', M; cbn. intros f p. pose (fh := fun x a => (MH a f x) @ p x). pose (g := fun x a => snd (f (x,a))). assert (ge : forall x, IsEquiv (g x)). { apply isequiv_from_functor_sigma. refine (isequiv_commsq' _ f (equiv_sigma_prod0 X A) (equiv_sigma_prod0 X A) _). intros [x a]; cbn. apply path_prod; [ apply fh | reflexivity ]. } intros [x a]. pose (gisid := path_aut_rigid (Build_Equiv _ _ (g x) (ge x)) 1). apply path_prod. - apply fh. - apply gisid. } assert (Minj : forall f g, M' f == M' g -> f == g). { intros f g p z. apply moveL_equiv_M. revert z. refine (Mker (g^-1 oE f) _). intros x. refine (MC f g^-1 x @ _). change ((M' g)^-1 (M f x) = x). apply moveR_equiv_V, p. } refine (isequiv_adjointify L M' _ _); intros e; apply path_equiv, path_arrow; try apply Minj; intros x; reflexivity. } Defined. Coq-HoTT-9.0/theories/Universes/Smallness.v000066400000000000000000000202561474641544500207000ustar00rootroot00000000000000Require Import Basics.Overture Basics.Equivalences Basics.Trunc Basics.Tactics Basics.Nat Types.Unit Types.Sigma Types.Universe Types.Equiv HFiber. Set Universe Minimization ToSet. (** * Facts about "small" types *) (** This closely follows Section 2 of the paper "Non-accessible localizations", by Dan Christensen, https://arxiv.org/abs/2109.06670 *) (** Universe variables: we most often use a subset of [i j k u]. We think of [Type@{i}] as containing the "small" types and [Type@{j}] the "large" types. In some early results, there are no constraints between [i] and [j], and in others we require that [i <= j], as expected. While the case [i = j] isn't particularly interesting, we put some effort into ensuring that it is permitted as well, as there is no semantic reason to exclude it. The universe variable [k] should be thought of as max(i+1,j), and it is generally required to satisfy [i < k] and [j <= k]. If we assume that [i < j], then we can take [k = j], but we include [k] so that we also allow the case [i = j]. The universe variable [u] is only present because we occasionally use Univalence in [Type@{k}], so the equality types need a larger universe to live in. Because of this, most results require [k < u]. Summary of the most common situation: [i < k < u, j <= k], where [i] is for the small types, [j] is for the large types, [k = max(i+1,j)] and [u] is an ambient universe for Univalence. We include universe annotations when they clarify the meaning (e.g. in [IsSmall] and when using [PropResizing]), and also when it is required in order to keep control of the universe variables. Note that [IsSmall] is defined in Overture.v. *) Global Instance ishprop_issmall@{i j k | i < k, j <= k} `{Univalence} (X : Type@{j}) : IsHProp (IsSmall@{i j} X). Proof. apply hprop_inhabited_contr. intros [Z e]. (* [IsSmall X] is equivalent to [IsSmall Z], which is contractible since it is a based path space. *) rapply (istrunc_equiv_istrunc { Y : Type@{i} & Y <~> Z } _). equiv_via (sig@{k k} (fun Y : Type@{i} => Y <~> X)). 2: issig. apply equiv_functor_sigma_id. intro Y. exact (equiv_functor_postcompose_equiv Y e). Defined. (** A type in [Type@{i}] is clearly small. *) Global Instance issmall_in@{i j | i <= j} (X : Type@{i}) : IsSmall@{i j} X | 10 := Build_IsSmall X X equiv_idmap. (** The small types are closed under equivalence. *) Definition issmall_equiv_issmall@{i1 j1 i2 j2 | i1 <= i2} {A : Type@{j1}} {B : Type@{j2}} (e : A <~> B) (sA : IsSmall@{i1 j1} A) : IsSmall@{i2 j2} B. Proof. exists (smalltype A). exact (e oE (equiv_smalltype A)). Defined. (** The small types are closed under dependent sums. *) Definition sigma_closed_issmall@{i j | } {A : Type@{j}} (B : A -> Type@{j}) (sA : IsSmall@{i j} A) (sB : forall a, IsSmall@{i j} (B a)) : IsSmall@{i j} { a : A & B a }. Proof. exists { a : (smalltype A) & (smalltype (B (equiv_smalltype A a))) }. snrapply equiv_functor_sigma'; intros; apply equiv_smalltype. Defined. (** If a map has small codomain and fibers, then the domain is small. *) Definition issmall_issmall_codomain_fibers@{i j | } {X Y : Type@{j}} (f : X -> Y) (sY : IsSmall@{i j} Y) (sF : forall y : Y, IsSmall@{i j} (hfiber f y)) : IsSmall@{i j} X. Proof. nrapply issmall_equiv_issmall. - exact (equiv_fibration_replacement f)^-1%equiv. - apply sigma_closed_issmall; assumption. Defined. (** Every contractible type is small. *) Definition issmall_contr@{i j| } (X : Type@{j}) (T : Contr X) : IsSmall@{i j} X := issmall_equiv_issmall (equiv_contr_unit)^-1 _. (** If we can show that [X] is small when it is inhabited, then it is in fact small. This is Remark 2.9 in the paper. It lets us simplify the statement of Proposition 2.8. Note that this implies propositional resizing, so the [PropResizing] assumption is necessary. *) Definition issmall_inhabited_issmall@{i j k | i < k, j <= k} `{PropResizing} `{Univalence} (X : Type@{j}) (isX : X -> IsSmall@{i j} X) : IsSmall@{i j} X. Proof. (* Since [IsSmall] is cumulative in the universe [j], it suffices to prove [IsSmall@{i k} X] for [k] the universe that [IsSmall@{i j}] lives in. We think of [k] as max(i+1,j). *) rapply (issmall_issmall_codomain_fibers@{i k} isX). intro sX. rapply sigma_closed_issmall. Defined. (** If a type [X] is truncated, then so is [smalltype X]. *) Global Instance istrunc_smalltype@{i j | } (X : Type@{j}) (n : trunc_index) `{IsSmall@{i j} X, IsTrunc n X} : IsTrunc n (smalltype X) := istrunc_equiv_istrunc X (equiv_smalltype@{i j} X)^-1%equiv. (** * Locally small types *) (** We say that a type [X] is 0-locally small if it is small, and (n+1)-locally small if its identity types are n-locally small. *) (* TODO: Can we make this an inductive type and avoid the extra universe variable [k]? *) Fixpoint IsLocallySmall@{i j k | i < k, j <= k} (n : nat) (X : Type@{j}) : Type@{k} := match n with | 0%nat => IsSmall@{i j} X | S m => forall x y : X, IsLocallySmall m (x = y) end. Existing Class IsLocallySmall. Hint Unfold IsLocallySmall : typeclass_instances. Global Instance ishprop_islocallysmall@{i j k | i < k, j <= k} `{Univalence} (n : nat) (X : Type@{j}) : IsHProp@{k} (IsLocallySmall@{i j k} n X). Proof. (* Here and later we use [simple_induction] to control the universe variable. *) revert X; simple_induction n n IHn; exact _. Defined. (** A small type is n-locally small for all [n]. *) Global Instance islocallysmall_in@{i j k | i <= j, j <= k, i < k} (n : nat) (X : Type@{i}) : IsLocallySmall@{i j k} n X. Proof. revert X. induction n; intro X. - apply issmall_in. - intros x y. exact (IHn (x = y)). Defined. (** The n-locally small types are closed under equivalence. *) Definition islocallysmall_equiv_islocallysmall @{i j1 j2 k | i < k, j1 <= k, j2 <= k} (n : nat) {A : Type@{j1}} {B : Type@{j2}} (e : A <~> B) (lsA : IsLocallySmall@{i j1 k} n A) : IsLocallySmall@{i j2 k} n B. Proof. revert A B e lsA. simple_induction n n IHn. - exact @issmall_equiv_issmall. - intros A B e lsA b b'. nrapply IHn. * exact (equiv_ap' (e^-1%equiv) b b')^-1%equiv. * apply lsA. Defined. (** A small type is n-locally small for all n. *) Global Instance islocallysmall_issmall@{i j k | i < k, j <= k} (n : nat) (X : Type@{j}) (sX : IsSmall@{i j} X) : IsLocallySmall@{i j k} n X := islocallysmall_equiv_islocallysmall n (equiv_smalltype X) _. (** If a type is n-locally small, then it is (n+1)-locally small. *) Global Instance islocallysmall_succ@{i j k | i < k, j <= k} (n : nat) (X : Type@{j}) (lsX : IsLocallySmall@{i j k} n X) : IsLocallySmall@{i j k} n.+1 X. Proof. revert X lsX; simple_induction n n IHn; intros X. - apply islocallysmall_issmall. - intro lsX. intros x y. apply IHn, lsX. Defined. (** The n-locally small types are closed under dependent sums. *) Global Instance sigma_closed_islocallysmall@{i j k | i < k, j <= k} (n : nat) {A : Type@{j}} (B : A -> Type@{j}) (lsA : IsLocallySmall@{i j k} n A) (lsB : forall a, IsLocallySmall@{i j k} n (B a)) : IsLocallySmall@{i j k} n { a : A & B a }. Proof. revert A B lsA lsB. simple_induction n n IHn. - exact @sigma_closed_issmall. - intros A B lsA lsB x y. apply (islocallysmall_equiv_islocallysmall n (equiv_path_sigma _ x y)). apply IHn. * apply lsA. * intro p. apply lsB. Defined. (** If a map has n-locally small codomain and fibers, then the domain is n-locally small. *) Definition islocallysmall_islocallysmall_codomain_fibers@{i j k | i < k, j <= k} (n : nat) {X Y : Type@{j}} (f : X -> Y) (sY : IsLocallySmall@{i j k} n Y) (sF : forall y : Y, IsLocallySmall@{i j k} n (hfiber f y)) : IsLocallySmall@{i j k} n X. Proof. nrapply islocallysmall_equiv_islocallysmall. - exact (equiv_fibration_replacement f)^-1%equiv. - apply sigma_closed_islocallysmall; assumption. Defined. (** Under propositional resizing, every (n+1)-truncated type is (n+2)-locally small. This is Lemma 2.3 in the paper. *) Global Instance islocallysmall_trunc@{i j k | i < k, j <= k} `{PropResizing} (n : trunc_index) (X : Type@{j}) (T : IsTrunc n.+1 X) : IsLocallySmall@{i j k} (trunc_index_to_nat n) X. Proof. revert n X T. simple_induction n n IHn; cbn. - nrapply issmall_hprop@{i j}. - intros X T x y. rapply IHn. Defined. Coq-HoTT-9.0/theories/Universes/TruncType.v000066400000000000000000000131671474641544500206770ustar00rootroot00000000000000Require Import HoTT.Basics HoTT.Types. Require Import HProp. Generalizable Variables A B n f. (** * Universes of truncated types Now that we have the univalence axiom (from [Types/Universe]), we study further the universes [TruncType] of truncated types (including [hProp] and [hSet]) that were defined in [Basics/Trunc]. *) (** ** Paths in [TruncType] *) Section TruncType. Context `{Univalence}. Definition issig_trunctype {n : trunc_index} : { X : Type & IsTrunc n X } <~> TruncType n. Proof. issig. Defined. Definition equiv_path_trunctype' {n : trunc_index} (A B : TruncType n) : (A = B :> Type) <~> (A = B :> TruncType n). Proof. refine ((equiv_ap' issig_trunctype^-1 _ _)^-1 oE _). exact (equiv_path_sigma_hprop (_;_) (_;_)). Defined. Global Instance isequiv_ap_trunctype {n : trunc_index} (A B : n-Type) : IsEquiv (@ap _ _ (@trunctype_type n) A B). Proof. srefine (isequiv_homotopic _^-1%equiv _). 1: apply equiv_path_trunctype'. intros []; reflexivity. Defined. Definition equiv_path_trunctype {n : trunc_index} (A B : TruncType n) : (A <~> B) <~> (A = B :> TruncType n) := equiv_path_trunctype' _ _ oE equiv_path_universe _ _. Definition path_trunctype@{a b} {n : trunc_index} {A B : TruncType n} : A <~> B -> (A = B :> TruncType n) := equiv_path_trunctype@{a b} A B. Global Instance isequiv_path_trunctype {n : trunc_index} {A B : TruncType n} : IsEquiv (@path_trunctype n A B) := _. (** [path_trunctype] is functorial *) Definition path_trunctype_1 {n : trunc_index} {A : TruncType n} : path_trunctype (equiv_idmap A) = idpath. Proof. unfold path_trunctype; simpl. rewrite (eta_path_universe_uncurried 1). rewrite path_sigma_hprop_1. reflexivity. Qed. Definition path_trunctype_V {n : trunc_index} {A B : TruncType n} (f : A <~> B) : path_trunctype f^-1 = (path_trunctype f)^. Proof. unfold path_trunctype; simpl. rewrite path_universe_V_uncurried. rewrite (path_sigma_hprop_V (path_universe_uncurried f)). refine (concat_p1 _ @ concat_1p _ @ _). refine (_ @ (ap inverse (concat_1p _))^ @ (ap inverse (concat_p1 _))^). refine (ap_V _ _). Qed. Definition path_trunctype_pp {n : trunc_index} {A B C : TruncType n} (f : A <~> B) (g : B <~> C) : path_trunctype (g oE f) = path_trunctype f @ path_trunctype g. Proof. unfold path_trunctype; simpl. rewrite path_universe_compose_uncurried. rewrite (path_sigma_hprop_pp (path_universe_uncurried f) _ _ (trunctype_istrunc B)). refine (concat_p1 _ @ concat_1p _ @ _). refine (_ @ (ap _ (concat_1p _))^ @ (ap _ (concat_p1 _))^). refine (_ @ (ap (fun z => z @ _) (concat_1p _))^ @ (ap (fun z => z @ _) (concat_p1 _))^). refine (ap_pp _ _ _). Qed. Definition ap_trunctype {n : trunc_index} {A B : TruncType n} {f : A <~> B} : ap trunctype_type (path_trunctype f) = path_universe_uncurried f. Proof. destruct A, B. cbn in *. cbn; destruct (path_universe_uncurried f). rewrite concat_1p, concat_p1. rewrite <- 2 ap_compose. apply ap_const. Qed. Definition path_hset {A B} := @path_trunctype 0 A B. Definition path_hprop {A B} := @path_trunctype (-1) A B. Global Instance istrunc_trunctype {n : trunc_index} : IsTrunc n.+1 (TruncType n) | 0. Proof. apply istrunc_S. intros A B. refine (istrunc_equiv_istrunc _ (equiv_path_trunctype@{i j} A B)). case n as [ | n']. - apply contr_equiv_contr_contr. (* The reason is different in this case. *) - apply istrunc_equiv. Defined. Global Instance isset_HProp : IsHSet HProp := _. Global Instance istrunc_sig_istrunc : forall n, IsTrunc n.+1 { A : Type & IsTrunc n A } | 0. Proof. intro n. apply (istrunc_equiv_istrunc _ issig_trunctype^-1). Defined. (** ** Some standard inhabitants *) Definition Unit_hp : HProp := (Build_HProp Unit). Definition False_hp : HProp := (Build_HProp Empty). Definition Negation_hp `{Funext} (hprop : HProp) : HProp := Build_HProp (~hprop). (** We could continue with products etc *) (** ** The canonical map from Bool to hProp *) Definition is_true (b : Bool) : HProp := if b then Unit_hp else False_hp. (** ** Facts about HProps using univalence *) Global Instance trunc_path_IsHProp X Y `{IsHProp Y} : IsHProp (X = Y). Proof. apply hprop_allpath. intros pf1 pf2. apply (equiv_inj (equiv_path X Y)). apply path_equiv, path_arrow. intros x; by apply path_ishprop. Qed. Definition path_iff_ishprop_uncurried `{IsHProp A, IsHProp B} : (A <-> B) -> A = B :> Type := @path_universe_uncurried _ A B o equiv_iff_hprop_uncurried. Definition path_iff_hprop_uncurried {A B : HProp} : (A <-> B) -> A = B :> HProp := (@path_hprop A B) o (@equiv_iff_hprop_uncurried A _ B _). Global Instance isequiv_path_iff_ishprop_uncurried `{IsHProp A, IsHProp B} : IsEquiv (@path_iff_ishprop_uncurried A _ B _) := _. Global Instance isequiv_path_iff_hprop_uncurried {A B : HProp} : IsEquiv (@path_iff_hprop_uncurried A B) := _. Definition path_iff_ishprop `{IsHProp A, IsHProp B} : (A -> B) -> (B -> A) -> A = B :> Type := fun f g => path_iff_ishprop_uncurried (f,g). Definition path_iff_hprop {A B : HProp} : (A -> B) -> (B -> A) -> A = B :> HProp := fun f g => path_iff_hprop_uncurried (f,g). Lemma equiv_path_iff_ishprop {A B : Type} `{IsHProp A, IsHProp B} : (A <-> B) <~> (A = B). Proof. exact (Build_Equiv _ _ path_iff_ishprop_uncurried _). Defined. Lemma equiv_path_iff_hprop {A B : HProp} : (A <-> B) <~> (A = B). Proof. refine (equiv_path_trunctype' _ _ oE equiv_path_iff_ishprop). Defined. End TruncType. Coq-HoTT-9.0/theories/Universes/UniverseLevel.v000066400000000000000000000115741474641544500215320ustar00rootroot00000000000000From HoTT Require Import Basics.Overture Basics.PathGroupoids. (** * Universe Levels *) (** We provide casting definitions for raising universe levels. *) (** Because we have cumulativity (that [T : U@{i}] gives us [T : U@{j}] when [i < j]), we may define [Lift : U@{i} → U@{j}] to be the identity function. *) Definition Lift@{i j | i < j} (A : Type@{i}) : Type@{j} := A. Definition lift {A} : A -> Lift A := fun x => x. Definition lower {A} : Lift A -> A := fun x => x. Definition lift2 {A B} (f : forall x : A, B x) : forall x : Lift A, Lift (B (lower x)) := f. Definition lower2 {A B} (f : forall x : Lift A, Lift (B (lower x))) : forall x : A, B x := f. (** We make [lift] and [lower] opaque so that typeclass resolution doesn't pick up [isequiv_lift] as an instance of [IsEquiv idmap] and wreck havok. *) #[global] Typeclasses Opaque lift lower lift2 lower2. Global Instance isequiv_lift T : IsEquiv (@lift T) := @Build_IsEquiv _ _ (@lift T) (@lower T) (fun _ => idpath) (fun _ => idpath) (fun _ => idpath). Global Instance isequiv_lift2 A B : IsEquiv (@lift2 A B) := @Build_IsEquiv _ _ (@lift2 A B) (@lower2 A B) (fun _ => idpath) (fun _ => idpath) (fun _ => idpath). Global Instance lift_isequiv {A B} (f : A -> B) {H : IsEquiv f} : @IsEquiv (Lift A) (Lift B) (lift2 f) := @Build_IsEquiv (Lift A) (Lift B) (lift2 f) (lift2 (f^-1)) (fun x => ap lift (eisretr f (lower x))) (fun x => ap lift (eissect f (lower x))) (fun x => ((ap (ap lift) (eisadj f (lower x))) @ (ap_compose f lift _)^) @ (@ap_compose A (Lift A) (Lift B) lift (lift2 f) _ _ _)). Global Instance lower_isequiv {A B} (f : Lift A -> Lift B) {H : IsEquiv f} : @IsEquiv A B (lower2 f) := @Build_IsEquiv _ _ (lower2 f) (lower2 (f^-1)) (fun x => ap lower (eisretr f (lift x))) (fun x => ap lower (eissect f (lift x))) (fun x => ((ap (ap lower) (eisadj f (lift x))) @ (ap_compose f lower _)^) @ (@ap_compose (Lift A) A B lower (lower2 f) _ _ _)). Definition lower_equiv {A B} (e : Equiv (Lift A) (Lift B)) : Equiv A B := @Build_Equiv A B (lower2 e) _. (** This version doesn't force strict containment, i.e. it allows the two universes to possibly be the same. *) Definition Lift'@{i j | i <= j} (A : Type@{i}) : Type@{j} := A. (** However, if we don't give the universes as explicit arguments here, then Coq collapses them. *) Definition lift'@{i j} {A : Type@{i}} : A -> Lift'@{i j} A := fun x => x. Definition lower'@{i j} {A : Type@{i}} : Lift'@{i j} A -> A := fun x => x. Definition lift'2@{i i' j j'} {A : Type@{i}} {B : A -> Type@{i'}} (f : forall x : A, B x) : forall x : Lift'@{i j} A, Lift'@{i' j'} (B (lower' x)) := f. Definition lower'2@{i i' j j'} {A : Type@{i}} {B : A -> Type@{i'}} (f : forall x : Lift'@{i j} A, Lift'@{i' j'} (B (lower' x))) : forall x : A, B x := f. (** We make [lift] and [lower] opaque so that typeclass resolution doesn't pick up [isequiv_lift] as an instance of [IsEquiv idmap] and wreck havok. *) #[global] Typeclasses Opaque lift' lower' lift'2 lower'2. Global Instance isequiv_lift'@{i j} (T : Type@{i}) : IsEquiv (@lift'@{i j} T) := @Build_IsEquiv _ _ (@lift' T) (@lower' T) (fun _ => idpath) (fun _ => idpath) (fun _ => idpath). Global Instance isequiv_lift'2@{e0 e1 i i' j j'} (A : Type@{i}) (B : A -> Type@{j}) : IsEquiv@{e0 e1} (@lift'2@{i i' j j'} A B) := @Build_IsEquiv _ _ (@lift'2 A B) (@lower'2 A B) (fun _ => idpath) (fun _ => idpath) (fun _ => idpath). Global Instance lift'_isequiv@{a b i j i' j'} {A : Type@{a}} {B : Type@{b}} (f : A -> B) {H : IsEquiv f} : @IsEquiv (Lift'@{i j} A) (Lift'@{i' j'} B) (lift'2 f) := @Build_IsEquiv (Lift' A) (Lift' B) (lift'2 f) (lift'2 (f^-1)) (fun x => ap lift' (eisretr f (lower' x))) (fun x => ap lift' (eissect f (lower' x))) (fun x => ((ap (ap lift') (eisadj f (lower' x))) @ (ap_compose f lift' _)^) @ (@ap_compose A (Lift' A) (Lift' B) lift' (lift'2 f) _ _ _)). Global Instance lower'_isequiv@{i j i' j'} {A : Type@{i}} {B : Type@{j}} (f : Lift'@{i j} A -> Lift'@{i' j'} B) {H : IsEquiv f} : @IsEquiv A B (lower'2 f) := @Build_IsEquiv _ _ (lower'2 f) (lower'2 (f^-1)) (fun x => ap lower' (eisretr f (lift' x))) (fun x => ap lower' (eissect f (lift' x))) (fun x => ((ap (ap lower') (eisadj f (lift' x))) @ (ap_compose f lower' _)^) @ (@ap_compose (Lift' A) A B lower' (lower'2 f) _ _ _)). Definition lower'_equiv@{i j i' j'} {A : Type@{i}} {B : Type@{j}} (e : Equiv (Lift'@{i j} A) (Lift'@{i' j'} B)) : Equiv A B := @Build_Equiv A B (lower'2 e) _. Coq-HoTT-9.0/theories/Utf8.v000066400000000000000000000054561474641544500156070ustar00rootroot00000000000000Require Export HoTT.Basics.Utf8. Require Export HoTT.Utf8Minimal. Require Import HoTT.Basics HoTT.Types. Require Import Modalities.Identity. Require Import Spaces.Circle Spaces.TwoSphere HoTT.Truncations Homotopy.Suspension. (** Some unicode symbols that we don't use within the library. See also Utf8Minimal.v for a small number of symbols uses in the Classes library. *) Notation Type₀ := Type0. Notation pr₁ := pr1. Notation pr₂ := pr2. Local Open Scope fibration_scope. (*Notation "f → g" := (f -> g)%equiv : equiv_scope.*) Notation "x ₁" := (x.1) : fibration_scope. Notation "x ₂" := (x.2) : fibration_scope. Notation "g ∘ f" := (g o f)%function : function_scope. (* Notation "g ∘ᴱ f" := (g oE f)%equiv : equiv_scope. *) (* Notation "f *ᴱ g" := (f *E g)%equiv : equiv_scope. *) (* Notation "f ×ᴱ g" := (f *E g)%equiv : equiv_scope. *) Notation "A × B" := (A * B)%type : type_scope. Notation "f +ᴱ g" := (f +E g)%equiv : equiv_scope. (** We copy the HoTT-Agda library with regard to path concatenation. *) Notation "p • q" := (p @ q)%path : path_scope. Notation "p '⁻¹'" := (p^)%path : path_scope. Notation "p •' q" := (p @ q)%path : long_path_scope. (** Add error messages so people aren't intensely confused by using an almost identical character. *) Infix "∙" := ltac:(fail "You used '∙' (BULLET OPERATOR, #x2219) when you probably meant to use '•' (BULLET, #x2022)") (only parsing) : path_scope. (*Notation "p # x" := (transport _ p x) : path_scope.*) (*Notation "f == g" := (pointwise_paths f g) : type_scope.*) Notation "A ≃ B" := (A <~> B) : type_scope. Notation "f '⁻¹'" := (f^-1)%function : function_scope. Notation "f '⁻¹'" := (f^-1)%equiv : equiv_scope. Notation "¬ x" := (~x) : type_scope. Notation "x ≠ y" := (x <> y) : type_scope. (*Notation "p @@ q" := (concat2 p q)%path : path_scope.*) Notation "m ≤ n" := (m <= n)%trunc : trunc_scope. (*Infix "||" := orb : bool_scope.*) (*Infix "&&" := andb : bool_scope.*) (*Notation "p ..1" := (pr1_path p) : fibration_scope.*) (*Notation "p ..2" := (pr2_path p) : fibration_scope.*) Notation "'S¹'" := Circle. Notation "'S²'" := TwoSphere. Notation "∥ A ∥₋₂" := (Trunc (-2) A). Notation "❘ a ❘₋₂" := (@tr (-2) _ a) : trunc_scope. Notation "∥ A ∥" := (Trunc (-1) A) (only parsing). Notation "∥ A ∥₋₁" := (Trunc (-1) A). Notation "❘ a ❘₋₁" := (@tr (-1) _ a) : trunc_scope. Notation "x ∨ y" := (hor x y) : type_scope. (* Notation "x ⊔ y" := (sum x y) : type_scope. *) Notation "∥ A ∥₀" := (Trunc 0 A). Notation "❘ a ❘₀" := (@tr 0 _ a) : trunc_scope. Notation "∥ A ∥₁" := (Trunc 1 A). Notation "❘ a ❘₁" := (@tr 1 _ a) : trunc_scope. Notation "∥ A ∥₂" := (Trunc 2 A). Notation "❘ a ❘₂" := (@tr 2 _ a) : trunc_scope. Notation "∞" := purely. Notation Σ := Susp. Coq-HoTT-9.0/theories/Utf8Minimal.v000066400000000000000000000012251474641544500171040ustar00rootroot00000000000000Require Export Basics.Utf8 Basics.Overture Basics.Iff. (** * Just enough Utf8/unicode for the Classes library to build, without depending on everything that HoTT.Utf8 depends on. *) (* Logic *) Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) : type_scope. Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..) : type_scope. Notation "x ∧ y" := (x /\ y) : type_scope. Notation "x → y" := (x -> y) : type_scope. Notation "x ↔ y" := (x <-> y) : type_scope. (*Notation "¬ x" := (not x) : type_scope.*) (*Notation "x ≠ y" := (x <> y) : type_scope.*) (* Abstraction *) Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..). Coq-HoTT-9.0/theories/WildCat.v000066400000000000000000000020741474641544500163010ustar00rootroot00000000000000(* Theory *) Require Export WildCat.Adjoint. Require Export WildCat.Core. Require Export WildCat.Equiv. Require Export WildCat.Opposite. Require Export WildCat.Induced. Require Export WildCat.EquivGpd. Require Export WildCat.FunctorCat. Require Export WildCat.NatTrans. Require Export WildCat.Yoneda. Require Export WildCat.Square. Require Export WildCat.PointedCat. Require Export WildCat.Bifunctor. Require Export WildCat.Monoidal. Require Export WildCat.MonoidalTwistConstruction. Require Export WildCat.Products. Require Export WildCat.Coproducts. Require Export WildCat.Displayed. Require Export WildCat.DisplayedEquiv. (* See also contrib/SetoidRewrite.v for tools that can be used for rewriting in wild categories. *) (* Examples *) Require Export WildCat.Universe. Require Export WildCat.Paths. Require Export WildCat.UnitCat. Require Export WildCat.EmptyCat. Require Export WildCat.Prod. Require Export WildCat.Sum. Require Export WildCat.Forall. Require Export WildCat.Sigma. Require Export WildCat.ZeroGroupoid. (* Higher categories *) Require Export WildCat.TwoOneCat. Coq-HoTT-9.0/theories/WildCat/000077500000000000000000000000001474641544500161075ustar00rootroot00000000000000Coq-HoTT-9.0/theories/WildCat/Adjoint.v000066400000000000000000000351331474641544500176730ustar00rootroot00000000000000Require Import Basics.Utf8 Basics.Overture Basics.Tactics Basics.Equivalences. Require Import WildCat.Core. Require Import WildCat.NatTrans. Require Import WildCat.Equiv. Require Import WildCat.Prod. Require Import WildCat.Opposite. Require Import WildCat.Yoneda. Require Import WildCat.FunctorCat. Require Import WildCat.Universe. Require Import Types.Prod. Generalizable Variables C D F G. (** ** Notions of adjunctions in wild categories. *) (** We try to capture a wild notion of (oo,1)-adjunctions since these are the ones that commonly appear in practice. Special cases include the standard 1-categorical adjunction. There are notions of 2-adjunction/biadjunction/higher adjunction but it is not clear if this generality is useful. We will define an adjunction to be an equivalence (in Type) between corresponding hom-types. This is a more immediately useful definition than others we can consider. We should also be able to define "F having a left adjoint" as the initial object of a slice category C / F. However this seems like too much work for now, and it is not immediately obvious how it ties back to the adjunction isomorphism. In the future, it ought to be possible to generalize this definition to live inside a given bicategory, however due to current structural issues in the WildCat library, writing down a usable definition of bicategory requires a lot of effort. *) (** * Definition of adjunction *) (** ** Definition of adjunction *) Record Adjunction {C D : Type} (F : C -> D) (G : D -> C) `{Is1Cat C, Is1Cat D, !Is0Functor F, !Is0Functor G} := { equiv_adjunction (x : C) (y : D) : (F x $-> y) <~> (x $-> G y) ; (** Naturality condition in both varibles seperately *) (** The left variable is a bit trickier to state since we have opposite categories involved. *) is1natural_equiv_adjunction_l (y : D) : Is1Natural (A := C^op) (yon y o F) (** We have to explicitly give a witness to the functoriality of [yon y o F]. *) (is0functor_F := is0functor_compose (A:=C^op) (B:=D^op) (C:=Type) _ _) (yon (G y)) (fun x => equiv_adjunction _ y) ; (** Naturality in the right variable *) is1natural_equiv_adjunction_r (x : C) : Is1Natural (opyon (F x)) (opyon x o G) (equiv_adjunction x) ; }. Arguments equiv_adjunction {C D F G isgraph_C is2graph_C is01cat_C is1cat_C isgraph_D is2graph_D is01cat_D is1cat_D is0functor_F is0functor_G} adj x y : rename. Arguments is1natural_equiv_adjunction_l {C D F G isgraph_C is2graph_C is01cat_C is1cat_C isgraph_D is2graph_D is01cat_D is1cat_D is0functor_F is0functor_G} adj y : rename. Arguments is1natural_equiv_adjunction_r {C D F G isgraph_C is2graph_C is01cat_C is1cat_C isgraph_D is2graph_D is01cat_D is1cat_D is0functor_F is0functor_G} adj x : rename. Global Existing Instances is1natural_equiv_adjunction_l is1natural_equiv_adjunction_r. Notation "F ⊣ G" := (Adjunction F G). (** TODO: move but where? *) Lemma fun01_profunctor {A B C D : Type} (F : A -> B) (G : C -> D) `{Is0Functor A B F, Is0Functor C D G} : Fun01 (A^op * C) (B^op * D). Proof. snrapply Build_Fun01. 1: exact (functor_prod F G). rapply is0functor_prod_functor. Defined. Definition fun01_hom {C : Type} `{Is01Cat C} : Fun01 (C^op * C) Type := @Build_Fun01 _ _ _ _ _ is0functor_hom. (** ** Natural equivalences coming from adjunctions. *) (** There are various bits of data we would like to extract from adjunctions. *) Section AdjunctionData. Context {C D : Type} {F : C -> D} {G : D -> C} `{Is1Cat C, Is1Cat D, !HasMorExt C, !HasMorExt D, !Is0Functor F, !Is0Functor G, !Is1Functor F, !Is1Functor G} (adj : Adjunction F G). Definition natequiv_adjunction_l (y : D) : NatEquiv (A := C^op) (yon y o F) (** We have to explicitly give a witness to the functoriality of [yon y o F]. *) (is0functor_F := is0functor_compose (A:=C^op) (B:=D^op) (C:=Type) _ _) (yon (G y)). Proof. nrapply Build_NatEquiv. apply (is1natural_equiv_adjunction_l adj). Defined. Definition natequiv_adjunction_r (x : C) : NatEquiv (opyon (F x)) (opyon x o G). Proof. nrapply Build_NatEquiv. apply (is1natural_equiv_adjunction_r adj). Defined. (** We also have the natural equivalence in both arguments at the same time. *) (** In order to manage the typeclass instances, we have to bundle them up into Fun01. *) Definition natequiv_adjunction : NatEquiv (A := C^op * D) (fun01_compose fun01_hom (fun01_profunctor F idmap)) (fun01_compose fun01_hom (fun01_profunctor idmap G)). Proof. snrapply Build_NatEquiv. 1: intros [x y]; exact (equiv_adjunction adj x y). snrapply Build_Is1Natural. intros [a b] [a' b'] [f g] K. refine (_ @ ap (fun x : a $-> G b' => x $o f) (is1natural_equiv_adjunction_r adj a b b' g K)). exact (is1natural_equiv_adjunction_l adj _ _ _ f (g $o K)). Defined. (** The counit of an adjunction *) Definition adjunction_counit : NatTrans idmap (G o F). Proof. snrapply Build_NatTrans. { hnf. intros x. exact (equiv_adjunction adj x (F x) (Id _)). } snrapply Build_Is1Natural. intros x x' f. apply GpdHom_path. refine (_^ @ _ @ _). 1: exact (is1natural_equiv_adjunction_l adj _ _ _ f (Id _)). 2: exact (is1natural_equiv_adjunction_r adj _ _ _ (fmap F f) (Id _)). simpl. apply equiv_ap'. apply path_hom. apply Square.vrefl. Defined. (** The unit of an adjunction *) Definition adjunction_unit : NatTrans (F o G) idmap. Proof. snrapply Build_NatTrans. { hnf. intros y. exact ((equiv_adjunction adj (G y) y)^-1 (Id _)). } snrapply Build_Is1Natural. intros y y' f. apply GpdHom_path. refine (_^ @ _ @ _). 1: exact (is1natural_natequiv (natequiv_inverse (natequiv_adjunction_l _)) (G y') _ (fmap G f) _). 2: exact (is1natural_natequiv (natequiv_inverse (natequiv_adjunction_r _)) _ _ _ (Id _)). simpl. apply equiv_ap_inv'. apply path_hom. apply Square.vrefl. Defined. Lemma triangle_helper1 x y f : equiv_adjunction adj x y f = fmap G f $o adjunction_counit x. Proof. refine (_ @ is1natural_equiv_adjunction_r adj _ _ _ _ _). by cbv; rewrite (cat_idr_strong f). Qed. Lemma triangle_helper2 x y g : (equiv_adjunction adj x y)^-1 g = adjunction_unit y $o fmap F g. Proof. epose (n1 := is1natural_natequiv (natequiv_inverse (natequiv_adjunction_l _)) _ _ _ _). clearbody n1; cbv in n1. refine (_ @ n1). by rewrite cat_idl_strong. Qed. Definition adjunction_triangle1 : Transformation (nattrans_comp (nattrans_prewhisker adjunction_unit F) (nattrans_postwhisker F adjunction_counit)) (nattrans_id _). Proof. intros c. change (?x $-> _) with (x $-> Id (F c)). rewrite <- (eissect (equiv_adjunction adj _ _) (Id (F c))). cbv;rewrite <- (triangle_helper2 _ (F c) (adjunction_counit _)). exact (Id _). Qed. Definition adjunction_triangle2 : Transformation (nattrans_comp (nattrans_postwhisker G adjunction_unit) (nattrans_prewhisker adjunction_counit G)) (nattrans_id _). Proof. intros d. change (?x $-> _) with (x $-> Id (G d)). rewrite <- (eisretr (equiv_adjunction adj _ _) (Id (G d))). cbv;rewrite <- (triangle_helper1 (G d) _ (adjunction_unit _)). exact (Id _). Qed. End AdjunctionData. (** ** Building adjunctions *) (** There are various ways to build an adjunction. *) (** A natural equivalence between functors [D -> Type] which is also natural in the left. *) Definition Build_Adjunction_natequiv_nat_left {C D : Type} (F : C -> D) (G : D -> C) `{Is1Cat C, Is1Cat D, !Is0Functor F, !Is0Functor G} (e : forall x, NatEquiv (opyon (F x)) (opyon x o G)) (is1nat_e : forall y, Is1Natural (A := C^op) (yon y o F) (** We have to explicitly give a witness to the functoriality of [yon y o F]. *) (is0functor_F := is0functor_compose (A:=C^op) (B:=D^op) (C:=Type) _ _) (yon (G y)) (fun x => e _ y)) : Adjunction F G. Proof. snrapply Build_Adjunction. 1: exact (fun x => e x). 1: exact is1nat_e. intros x; apply (is1natural_natequiv (e x)). Defined. (** A natural equivalence between functors [C^op -> Type] which is also natural in the left. *) Definition Build_Adjunction_natequiv_nat_right {C D : Type} (F : C -> D) (G : D -> C) `{Is1Cat C, Is1Cat D, !Is0Functor F, !Is0Functor G} (e : forall y, NatEquiv (A := C^op) (yon y o F) (yon (G y)) (is0functor_F := is0functor_compose (A:=C^op) (B:=D^op) (C:=Type) _ _)) (is1nat_e : forall x, Is1Natural (opyon (F x)) (opyon x o G) (fun y => e y x)) : Adjunction F G. Proof. snrapply Build_Adjunction. 1: exact (fun x y => e y x). 1: intros y; apply (is1natural_natequiv (e y)). exact is1nat_e. Defined. (** TODO: A natural equivalence between functors [C^op * D -> Type] *) Section UnitCounitAdjunction. (** From the data of an adjunction: unit, counit, left triangle, right triangle *) Context {C D : Type} (F : C -> D) (G : D -> C) `{Is1Cat C, Is1Cat D, !Is0Functor F, !Is0Functor G, !Is1Functor F, !Is1Functor G} `{!HasMorExt C, !HasMorExt D} (ε : NatTrans (F o G) idmap) (η : NatTrans idmap (G o F)) (t1 : Transformation (nattrans_comp (nattrans_prewhisker ε F) (nattrans_postwhisker F η)) (nattrans_id _)) (t2 : Transformation (nattrans_comp (nattrans_postwhisker G ε) (nattrans_prewhisker η G)) (nattrans_id _)). (** We can construct an equivalence between homs *) Local Definition γ a b : (F a $-> b) $<~> (a $-> G b). Proof. srapply equiv_adjointify. 1: exact (fun x => fmap G x $o (η : _ $=> _) a). 1: exact (fun x => (ε : _ $=> _) b $o fmap F x). + intros f. apply path_hom; simpl. refine ((fmap_comp G _ _ $@R _) $@ _). refine (cat_assoc _ _ _ $@ _). refine ((_ $@L (isnat η f)^$) $@ _). refine (cat_assoc_opp _ _ _ $@ _). refine (_ $@R _ $@ cat_idl _). exact (t2 b). + intros g. apply path_hom; simpl. refine ((_ $@L fmap_comp F _ _) $@ _). refine (cat_assoc_opp _ _ _ $@ _). refine (((isnat ε g) $@R _) $@ _). refine (cat_assoc _ _ _ $@ _). refine (_ $@L _ $@ cat_idr _). exact (t1 a). Defined. (** Which is natural in the left *) Lemma is1natural_γ_l (y : D) : Is1Natural (yon y o F) (yon (G y)) (is0functor_F := is0functor_compose (A:=C^op) (B:=D^op) (C:=Type) _ _) (is0functor_G := is0functor_yon (G y)) (fun x : C^op => γ x y). Proof. nrapply (is1natural_natequiv (natequiv_inverse (Build_NatEquiv (yon (G y)) (yon y o F) (fun x => (γ x y)^-1$) _))). nrapply is1natural_yoneda. nrapply is1functor_compose. 1: nrapply is1functor_op; exact _. nrapply is1functor_opyon. nrapply hasmorext_op; exact _. Defined. (** And natural in the right. *) Lemma is1natural_γ_r x : Is1Natural (opyon (F x)) (fun x0 : D => opyon x (G x0)) (γ x). Proof. nrapply is1natural_opyoneda. exact _. Defined. (** Together this constructs an adjunction. *) Definition Build_Adjunction_unit_counit : Adjunction F G. Proof. snrapply Build_Adjunction. - exact γ. - apply is1natural_γ_l. - apply is1natural_γ_r. Defined. End UnitCounitAdjunction. (** * Properties of adjunctions *) (** ** Postcomposition adjunction *) (** There are at least two easy proofs of the following on paper: 1. Using ends: Hom(F*x,y) ≃ ∫_c Hom(Fxc,yc) ≃ ∫_c Hom(xc,Gyc) ≃ Hom(x,G*y) 2. 2-cat theory: postcomp (-)* is a 2-functor so preserves adjunctions. *) Lemma adjunction_postcomp (C D J : Type) `{HasEquivs C, HasEquivs D, Is01Cat J} (F : Fun11 C D) (G : Fun11 D C) `{!HasMorExt C, !HasMorExt D, !HasMorExt (Fun01 J C), !HasMorExt (Fun01 J D)} : F ⊣ G -> fun11_fun01_postcomp (A:=J) F ⊣ fun11_fun01_postcomp (A:=J) G. Proof. intros adj. srapply Build_Adjunction_unit_counit. - snrapply Build_NatTrans. + intros K. exact (nattrans_prewhisker (adjunction_unit adj) K). + snrapply Build_Is1Natural. intros K K' θ j. apply GpdHom_path. refine (_ @ is1natural_natequiv (natequiv_inverse (natequiv_adjunction_r adj _)) _ _ _ _). refine ((is1natural_natequiv (natequiv_inverse (natequiv_adjunction_l adj _)) _ _ _ _)^ @ _). cbn; rapply ap. refine(cat_idl_strong _ @ _^). apply cat_idr_strong. - snrapply Build_NatTrans. + intros K. exact (nattrans_prewhisker (adjunction_counit adj) K). + snrapply Build_Is1Natural. intros K K' θ j. apply GpdHom_path. refine (_ @ is1natural_natequiv (natequiv_adjunction_r adj _) _ _ _ _). refine ((is1natural_natequiv (natequiv_adjunction_l adj _) _ _ _ _)^ @ _). cbn; rapply ap. refine(cat_idl_strong _ @ _^). apply cat_idr_strong. - exact (trans_prewhisker (adjunction_triangle1 adj)). - exact (trans_prewhisker (adjunction_triangle2 adj)). Defined. (** We can compose adjunctions. Notice how the middle category must have equivalences. *) Lemma adjunction_compose (A B C : Type) (F : A -> B) (G : B -> A) (F' : B -> C) (G' : C -> B) `{Is1Cat A, HasEquivs B, Is1Cat C} `{!Is0Functor F, !Is0Functor G, !Is0Functor F', !Is0Functor G'} : F ⊣ G -> F' ⊣ G' -> F' o F ⊣ G o G'. Proof. intros adj1 adj2. snrapply Build_Adjunction_natequiv_nat_right. { intros y. nrefine (natequiv_compose (natequiv_adjunction_l adj1 _) _). exact (natequiv_prewhisker (A:=A^op) (B:=B^op) (natequiv_adjunction_l adj2 y) F). } intros x. rapply is1natural_comp. + rapply (is1natural_prewhisker G' (natequiv_adjunction_r adj1 x)). + rapply is1natural_equiv_adjunction_r. Defined. (** Replace the left functor in an adjunction by a naturally equivalent one. *) Lemma adjunction_natequiv_left {C D : Type} (F F' : C -> D) (G : D -> C) `{Is1Cat C, HasEquivs D, !HasMorExt D, !Is0Functor F, !Is0Functor F', !Is0Functor G} : NatEquiv F F' -> F ⊣ G -> F' ⊣ G. Proof. intros e adj. snrapply Build_Adjunction_natequiv_nat_right. { intros y. refine (natequiv_compose (natequiv_adjunction_l adj _) _). rapply (natequiv_postwhisker _ (natequiv_op e)). } intros x. rapply is1natural_comp. Defined. (** Replace the right functor in an adjunction by a naturally equivalent one. *) Lemma adjunction_natequiv_right {C D : Type} (F : C -> D) (G G' : D -> C) `{HasEquivs C, Is1Cat D, !HasMorExt C, !Is0Functor F, !Is0Functor G, !Is0Functor G'} : NatEquiv G G' -> F ⊣ G -> F ⊣ G'. Proof. intros e adj. snrapply Build_Adjunction_natequiv_nat_left. { intros x. refine (natequiv_compose _ (natequiv_adjunction_r adj _)). rapply (natequiv_postwhisker _ e). } intros y. rapply is1natural_comp. 2: exact _. rapply is1natural_yoneda. Defined. Coq-HoTT-9.0/theories/WildCat/Bifunctor.v000066400000000000000000000446671474641544500202520ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import Types.Forall Types.Prod. Require Import WildCat.Core WildCat.Prod WildCat.Equiv WildCat.NatTrans WildCat.Square WildCat.Opposite. (** * Bifunctors between WildCats *) (** ** Definition *) (** We choose to store redundant information in the class, so that depending on how an instance is constructed, we will get the expected implementations of [fmap10], [fmap01] and [fmap11]. *) Class Is0Bifunctor {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C} (F : A -> B -> C) := { is0functor_bifunctor_uncurried :: Is0Functor (uncurry F); is0functor01_bifunctor :: forall a, Is0Functor (F a); is0functor10_bifunctor :: forall b, Is0Functor (flip F b); }. Arguments Is0Bifunctor {A B C _ _ _} F. Arguments is0functor_bifunctor_uncurried {A B C _ _ _} F {_}. Arguments is0functor01_bifunctor {A B C _ _ _} F {_} a : rename. Arguments is0functor10_bifunctor {A B C _ _ _} F {_} b : rename. (** We provide two alternate constructors, allowing the user to provide just the first field or the last two fields. *) Definition Build_Is0Bifunctor' {A B C : Type} `{Is01Cat A, Is01Cat B, IsGraph C} (F : A -> B -> C) `{!Is0Functor (uncurry F)} : Is0Bifunctor F. Proof. snrapply Build_Is0Bifunctor. - exact _. - exact (is0functor_functor_uncurried01 (uncurry F)). - exact (is0functor_functor_uncurried10 (uncurry F)). Defined. Definition Build_Is0Bifunctor'' {A B C : Type} `{IsGraph A, IsGraph B, Is01Cat C} (F : A -> B -> C) `{!forall a, Is0Functor (F a), !forall b, Is0Functor (flip F b)} : Is0Bifunctor F. Proof. (* The first condition follows from [is0functor_prod_is0functor]. *) nrapply Build_Is0Bifunctor; exact _. Defined. (** *** 1-functorial action *) (** [fmap] in the first argument. *) Definition fmap10 {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C} (F : A -> B -> C) `{!Is0Bifunctor F} {a0 a1 : A} (f : a0 $-> a1) (b : B) : (F a0 b) $-> (F a1 b) := fmap (flip F b) f. (** [fmap] in the second argument. *) Definition fmap01 {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C} (F : A -> B -> C) `{!Is0Bifunctor F} (a : A) {b0 b1 : B} (g : b0 $-> b1) : F a b0 $-> F a b1 := fmap (F a) g. (** [fmap] in both arguments. *) Definition fmap11 {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C} (F : A -> B -> C) `{!Is0Bifunctor F} {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} (g : b0 $-> b1) : F a0 b0 $-> F a1 b1 := fmap_pair (uncurry F) f g. (** As with [Is0Bifunctor], we store redundant information. In addition, we store the proofs that they are consistent with each other. *) Class Is1Bifunctor {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F} := { is1functor_bifunctor_uncurried :: Is1Functor (uncurry F); is1functor01_bifunctor :: forall a, Is1Functor (F a); is1functor10_bifunctor :: forall b, Is1Functor (flip F b); fmap11_is_fmap01_fmap10 {a0 a1} (f : a0 $-> a1) {b0 b1} (g : b0 $-> b1) : fmap11 F f g $== fmap01 F a1 g $o fmap10 F f b0; fmap11_is_fmap10_fmap01 {a0 a1} (f : a0 $-> a1) {b0 b1} (g : b0 $-> b1) : fmap11 F f g $== fmap10 F f b1 $o fmap01 F a0 g; }. Arguments Is1Bifunctor {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {Is0Bifunctor} : rename. Arguments Build_Is1Bifunctor {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {_} _ _ _ _ _. Arguments is1functor_bifunctor_uncurried {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {_ _}. Arguments is1functor01_bifunctor {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {_ _} a : rename. Arguments is1functor10_bifunctor {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {_ _} b : rename. Arguments fmap11_is_fmap01_fmap10 {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {Is0Bifunctor Is1Bifunctor} {a0 a1} f {b0 b1} g : rename. Arguments fmap11_is_fmap10_fmap01 {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {Is0Bifunctor Is1Bifunctor} {a0 a1} f {b0 b1} g : rename. (** We again provide two alternate constructors. *) Definition Build_Is1Bifunctor' {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Functor (uncurry F), !Is1Functor (uncurry F)} : Is1Bifunctor (Is0Bifunctor := Build_Is0Bifunctor' F) F. Proof. snrapply Build_Is1Bifunctor. - exact _. - exact (is1functor_functor_uncurried01 (uncurry F)). - exact (is1functor_functor_uncurried10 (uncurry F)). - intros a0 a1 f b0 b1 g. refine (_^$ $@ fmap_pair_comp (uncurry F) f (Id b0) (Id a1) g). exact (fmap2_pair (uncurry F) (cat_idl _) (cat_idr _)). - intros a0 a1 f b0 b1 g. refine (_^$ $@ fmap_pair_comp (uncurry F) (Id a0) g f (Id b1)). exact (fmap2_pair (uncurry F) (cat_idr _) (cat_idl _)). Defined. Definition Build_Is1Bifunctor'' {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!forall a, Is0Functor (F a), !forall b, Is0Functor (flip F b)} (Is0Bifunctor_F := Build_Is0Bifunctor'' F) `{!forall a, Is1Functor (F a), !forall b, Is1Functor (flip F b)} (bifunctor_coh : forall a0 a1 (f : a0 $-> a1) b0 b1 (g : b0 $-> b1), fmap01 F a1 g $o fmap10 F f b0 $== fmap10 F f b1 $o fmap01 F a0 g) : Is1Bifunctor F. Proof. snrapply Build_Is1Bifunctor. - exact _. (* [is1functor_prod_is1functor]. *) - exact _. - exact _. - intros a0 a1 f b0 b1 g. exact (bifunctor_coh a0 a1 f b0 b1 g)^$. - reflexivity. Defined. (** ** Bifunctor lemmas *) (** *** Coherence *) Definition bifunctor_coh {A B C : Type} (F : A -> B -> C) `{Is1Bifunctor A B C F} {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} (g : b0 $-> b1) : fmap01 F a1 g $o fmap10 F f b0 $== fmap10 F f b1 $o fmap01 F a0 g := (fmap11_is_fmap01_fmap10 _ _ _)^$ $@ fmap11_is_fmap10_fmap01 _ _ _. (** 2-functorial action *) Definition fmap02 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) {b0 b1 : B} {g g' : b0 $-> b1} (q : g $== g') : fmap01 F a g $== fmap01 F a g' := fmap2 (F a) q. Definition fmap12 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} {g g' : b0 $-> b1} (q : g $== g') : fmap11 F f g $== fmap11 F f g' := fmap2_pair (uncurry F) (Id _) q. Definition fmap20 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} {f f' : a0 $-> a1} (p : f $== f') (b : B) : fmap10 F f b $== fmap10 F f' b := fmap2 (flip F b) p. Definition fmap21 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} {f f' : a0 $-> a1} (p : f $== f') {b0 b1 : B} (g : b0 $-> b1) : fmap11 F f g $== fmap11 F f' g := fmap2_pair (uncurry F) p (Id _). Definition fmap22 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} {f f' : a0 $-> a1} (p : f $== f') {b0 b1 : B} {g g' : b0 $-> b1} (q : g $== g') : fmap11 F f g $== fmap11 F f' g' := fmap2_pair (uncurry F) p q. (** *** Identity preservation *) Definition fmap01_id {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) (b : B) : fmap01 F a (Id b) $== Id (F a b) := fmap_id (F a) b. Definition fmap10_id {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) (b : B) : fmap10 F (Id a) b $== Id (F a b) := fmap_id (flip F b) a. Definition fmap11_id {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) (b : B) : fmap11 F (Id a) (Id b) $== Id (F a b) := fmap_id (uncurry F) (a, b). (** [fmap11] with left map the identity gives [fmap01]. *) Definition fmap01_is_fmap11 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) {b0 b1 : B} (g : b0 $-> b1) : fmap11 F (Id a) g $== fmap01 F a g := fmap11_is_fmap01_fmap10 _ _ _ $@ (_ $@L fmap10_id _ _ _) $@ cat_idr _. (** [fmap11] with right map the identity gives [fmap10]. *) Definition fmap10_is_fmap11 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} (f : a0 $-> a1) (b : B) : fmap11 F f (Id b) $== fmap10 F f b := fmap11_is_fmap01_fmap10 _ _ _ $@ (fmap01_id _ _ _ $@R _) $@ cat_idl _. (** *** Composition preservation *) Definition fmap01_comp {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) {b0 b1 b2 : B} (g : b1 $-> b2) (f : b0 $-> b1) : fmap01 F a (g $o f) $== fmap01 F a g $o fmap01 F a f := fmap_comp (F a) f g. Definition fmap10_comp {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 a2 : A} (g : a1 $-> a2) (f : a0 $-> a1) (b : B) : fmap10 F (g $o f) b $== fmap10 F g b $o fmap10 F f b := fmap_comp (flip F b) f g. Definition fmap11_comp {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 a2 : A} (g : a1 $-> a2) (f : a0 $-> a1) {b0 b1 b2 : B} (k : b1 $-> b2) (h : b0 $-> b1) : fmap11 F (g $o f) (k $o h) $== fmap11 F g k $o fmap11 F f h := fmap_pair_comp (uncurry F) _ _ _ _. (** *** Equivalence preservation *) Global Instance iemap10 {A B C : Type} `{HasEquivs A, Is1Cat B, HasEquivs C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} (f : a0 $<~> a1) (b : B) : CatIsEquiv (fmap10 F f b) := iemap (flip F b) f. Global Instance iemap01 {A B C : Type} `{Is1Cat A, HasEquivs B, HasEquivs C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) {b0 b1 : B} (g : b0 $<~> b1) : CatIsEquiv (fmap01 F a g) := iemap (F a) g. Global Instance iemap11 {A B C : Type} `{HasEquivs A, HasEquivs B, HasEquivs C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} (f : a0 $<~> a1) {b0 b1 : B} (g : b0 $<~> b1) : CatIsEquiv (fmap11 F f g) := iemap (uncurry F) (a := (a0, b0)) (b := (_, _)) (f, g). Definition emap10 {A B C : Type} `{HasEquivs A, Is1Cat B, HasEquivs C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} (f : a0 $<~> a1) (b : B) : F a0 b $<~> F a1 b := Build_CatEquiv (fmap10 F f b). Definition emap01 {A B C : Type} `{Is1Cat A, HasEquivs B, HasEquivs C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) {b0 b1 : B} (g : b0 $<~> b1) : F a b0 $<~> F a b1 := Build_CatEquiv (fmap01 F a g). Definition emap11 {A B C : Type} `{HasEquivs A, HasEquivs B, HasEquivs C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a0 a1 : A} (f : a0 $<~> a1) {b0 b1 : B} (g : b0 $<~> b1) : F a0 b0 $<~> F a1 b1 := Build_CatEquiv (fmap11 F f g). (** ** Flipping bifunctors *) Definition is0bifunctor_flip {A B C : Type} (F : A -> B -> C) `{Is01Cat A, Is01Cat B, Is01Cat C, !Is0Bifunctor F} : Is0Bifunctor (flip F). Proof. snrapply Build_Is0Bifunctor. - change (Is0Functor (uncurry F o equiv_prod_symm _ _)). exact _. - exact _. - exact _. Defined. Hint Immediate is0bifunctor_flip : typeclass_instances. Definition is1bifunctor_flip {A B C : Type} (F : A -> B -> C) `{H : Is1Bifunctor A B C F} : Is1Bifunctor (flip F). Proof. snrapply Build_Is1Bifunctor. - change (Is1Functor (uncurry F o equiv_prod_symm _ _)). exact _. - exact _. - exact _. - intros b0 b1 g a0 a1 f. exact (fmap11_is_fmap10_fmap01 F f g). - intros b0 b1 g a0 a1 f. exact (fmap11_is_fmap01_fmap10 F f g). Defined. Hint Immediate is1bifunctor_flip : typeclass_instances. (** ** Composition of bifunctors *) (** There are 4 different ways to compose a functor with a bifunctor. *) (** Restricting a functor along a bifunctor yields a bifunctor. *) Global Instance is0bifunctor_postcompose {A B C D : Type} `{IsGraph A, IsGraph B, IsGraph C, IsGraph D} (F : A -> B -> C) {bf : Is0Bifunctor F} (G : C -> D) `{!Is0Functor G} : Is0Bifunctor (fun a b => G (F a b)) | 10 := {}. Global Instance is1bifunctor_postcompose {A B C D : Type} `{Is1Cat A, Is1Cat B, Is1Cat C, Is1Cat D} (F : A -> B -> C) (G : C -> D) `{!Is0Functor G, !Is1Functor G} `{!Is0Bifunctor F} {bf : Is1Bifunctor F} : Is1Bifunctor (fun a b => G (F a b)) | 10. Proof. snrapply Build_Is1Bifunctor. 1-3: exact _. - intros a0 a1 f b0 b1 g. exact (fmap2 G (fmap11_is_fmap01_fmap10 F f g) $@ fmap_comp G _ _). - intros a0 a1 f b0 b1 g. exact (fmap2 G (fmap11_is_fmap10_fmap01 F f g) $@ fmap_comp G _ _). Defined. Global Instance is0bifunctor_precompose {A B C D E : Type} `{IsGraph A, IsGraph B, IsGraph C, IsGraph D, IsGraph E} (G : A -> B) (K : E -> C) (F : B -> C -> D) `{!Is0Functor G, !Is0Bifunctor F, !Is0Functor K} : Is0Bifunctor (fun a b => F (G a) (K b)) | 10. Proof. snrapply Build_Is0Bifunctor. - change (Is0Functor (uncurry F o functor_prod G K)). exact _. - exact _. - intros e. change (Is0Functor (flip F (K e) o G)). exact _. Defined. Global Instance is1bifunctor_precompose {A B C D E : Type} `{Is1Cat A, Is1Cat B, Is1Cat C, Is1Cat D, Is1Cat E} (G : A -> B) (K : E -> C) (F : B -> C -> D) `{!Is0Functor G, !Is1Functor G, !Is0Bifunctor F, !Is1Bifunctor F, !Is0Functor K, !Is1Functor K} : Is1Bifunctor (fun a b => F (G a) (K b)) | 10. Proof. snrapply Build_Is1Bifunctor. - change (Is1Functor (uncurry F o functor_prod G K)). exact _. - exact _. - intros e. change (Is1Functor (flip F (K e) o G)). exact _. - intros a0 a1 f b0 b1 g. exact (fmap11_is_fmap01_fmap10 F (fmap G f) (fmap K g)). - intros a0 a1 f b0 b1 g. exact (fmap11_is_fmap10_fmap01 F (fmap G f) (fmap K g)). Defined. Global Instance is0functor_uncurry_uncurry_left {A B C D E} (F : A -> B -> C) (G : C -> D -> E) `{IsGraph A, IsGraph B, IsGraph C, IsGraph D, IsGraph E, !Is0Bifunctor F, !Is0Bifunctor G} : Is0Functor (uncurry (uncurry (fun x y z => G (F x y) z))). Proof. exact _. Defined. Global Instance is1functor_uncurry_uncurry_left {A B C D E} (F : A -> B -> C) (G : C -> D -> E) `{Is1Cat A, Is1Cat B, Is1Cat C, Is1Cat D, Is1Cat E, !Is0Bifunctor F, !Is1Bifunctor F, !Is0Bifunctor G, !Is1Bifunctor G} : Is1Functor (uncurry (uncurry (fun x y z => G (F x y) z))). Proof. exact _. Defined. Global Instance is0functor_uncurry_uncurry_right {A B C D E} (F : A -> B -> D) (G : C -> D -> E) `{IsGraph A, IsGraph B, IsGraph C, IsGraph D, IsGraph E, !Is0Bifunctor F, !Is0Bifunctor G} : Is0Functor (uncurry (uncurry (fun x y z => G x (F y z)))). Proof. snrapply Build_Is0Functor. intros cab cab' [[h f] g]. exact (fmap11 G h (fmap11 F f g)). Defined. Global Instance is1functor_uncurry_uncurry_right {A B C D E} (F : A -> B -> D) (G : C -> D -> E) `{Is1Cat A, Is1Cat B, Is1Cat C, Is1Cat D, Is1Cat E, !Is0Bifunctor F, !Is1Bifunctor F, !Is0Bifunctor G, !Is1Bifunctor G} : Is1Functor (uncurry (uncurry (fun x y z => G x (F y z)))). Proof. snrapply Build_Is1Functor. - intros cab cab' [[h f] g] [[h' f'] g'] [[q p] r]. exact (fmap22 G q (fmap22 F p r)). - intros cab. exact (fmap12 G _ (fmap11_id F _ _) $@ fmap11_id G _ _). - intros cab cab' cab'' [[h f] g] [[h' f'] g']. exact (fmap12 G _ (fmap11_comp F _ _ _ _) $@ fmap11_comp G _ _ _ _). Defined. Definition fmap11_square {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} {a00 a20 a02 a22 : A} {f10 : a00 $-> a20} {f12 : a02 $-> a22} {f01 : a00 $-> a02} {f21 : a20 $-> a22} {b00 b20 b02 b22 : B} {g10 : b00 $-> b20} {g12 : b02 $-> b22} {g01 : b00 $-> b02} {g21 : b20 $-> b22} (p : Square f01 f21 f10 f12) (q : Square g01 g21 g10 g12) : Square (fmap11 F f01 g01) (fmap11 F f21 g21) (fmap11 F f10 g10) (fmap11 F f12 g12) := (fmap11_comp F _ _ _ _)^$ $@ fmap22 F p q $@ fmap11_comp F _ _ _ _. (** ** Natural transformations between bifunctors *) (** We can show that an uncurried natural transformation between uncurried bifunctors by composing the naturality square in each variable. *) Global Instance is1natural_uncurry {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (G : A -> B -> C) `{!Is0Bifunctor G, !Is1Bifunctor G} (alpha : uncurry F $=> uncurry G) (nat_l : forall b, Is1Natural (flip F b) (flip G b) (fun x : A => alpha (x, b))) (nat_r : forall a, Is1Natural (F a) (G a) (fun y : B => alpha (a, y))) : Is1Natural (uncurry F) (uncurry G) alpha. Proof. snrapply Build_Is1Natural. intros [a b] [a' b'] [f f']; cbn in *. change (?w $o ?x $== ?y $o ?z) with (Square z w x y). nrapply vconcatL. 1: rapply (fmap11_is_fmap01_fmap10 F). nrapply vconcatR. 2: rapply (fmap11_is_fmap01_fmap10 G). exact (hconcat (nat_l _ _ _ f) (nat_r _ _ _ f')). Defined. (** Flipping a natural transformation between bifunctors. *) Definition nattrans_flip {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} {F : A -> B -> C} `{!Is0Bifunctor F, !Is1Bifunctor F} {G : A -> B -> C} `{!Is0Bifunctor G, !Is1Bifunctor G} : NatTrans (uncurry F) (uncurry G) -> NatTrans (uncurry (flip F)) (uncurry (flip G)). Proof. intros alpha. snrapply Build_NatTrans. - exact (alpha o equiv_prod_symm _ _). - snrapply Build_Is1Natural'. + intros [b a] [b' a'] [g f]. exact (isnat (a:=(a, b)) (a':=(a', b')) alpha (f, g)). + intros [b a] [b' a'] [g f]. exact (isnat_tr (a:=(a, b)) (a':=(a', b')) alpha (f, g)). Defined. (** ** Opposite Bifunctors *) (** There are a few more combinations we can do for this, such as profunctors, but we will leave those for later. *) Global Instance is0bifunctor_op A B C (F : A -> B -> C) `{Is0Bifunctor A B C F} : Is0Bifunctor (F : A^op -> B^op -> C^op). Proof. snrapply Build_Is0Bifunctor. - exact (is0functor_op _ _ (uncurry F)). - intros a. nrapply is0functor_op. exact (is0functor01_bifunctor F a). - intros b. nrapply is0functor_op. exact (is0functor10_bifunctor F b). Defined. Global Instance is1bifunctor_op A B C (F : A -> B -> C) `{Is1Bifunctor A B C F} : Is1Bifunctor (F : A^op -> B^op -> C^op). Proof. snrapply Build_Is1Bifunctor. - exact (is1functor_op _ _ (uncurry F)). - intros a. nrapply is1functor_op. exact (is1functor01_bifunctor F a). - intros b. nrapply is1functor_op. exact (is1functor10_bifunctor F b). - intros a0 a1 f b0 b1 g; cbn in f, g. exact (fmap11_is_fmap10_fmap01 F f g). - intros a0 a1 f b0 b1 g; cbn in f, g. exact (fmap11_is_fmap01_fmap10 F f g). Defined. Global Instance is0bifunctor_op' A B C (F : A^op -> B^op -> C^op) `{IsGraph A, IsGraph B, IsGraph C, Fop : !Is0Bifunctor (F : A^op -> B^op -> C^op)} : Is0Bifunctor (F : A -> B -> C) := is0bifunctor_op A^op B^op C^op F. Global Instance is1bifunctor_op' A B C (F : A^op -> B^op -> C^op) `{Is1Cat A, Is1Cat B, Is1Cat C, !Is0Bifunctor (F : A^op -> B^op -> C^op), !Is1Bifunctor (F : A^op -> B^op -> C^op)} : Is1Bifunctor (F : A -> B -> C) := is1bifunctor_op A^op B^op C^op F. Coq-HoTT-9.0/theories/WildCat/Coproducts.v000066400000000000000000000371701474641544500204330ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.Decidable. Require Import Types.Bool. Require Import WildCat.Core WildCat.Equiv WildCat.Forall WildCat.NatTrans WildCat.Opposite WildCat.Products WildCat.Universe WildCat.Yoneda WildCat.ZeroGroupoid WildCat.PointedCat WildCat.Monoidal WildCat.Bifunctor. (** * Categories with coproducts *) Definition cat_coprod_rec_inv {I A : Type} `{Is1Cat A} (coprod : A) (x : I -> A) (z : A) (inj : forall i, x i $-> coprod) : yon_0gpd z coprod $-> prod_0gpd I (fun i => yon_0gpd z (x i)) := cat_prod_corec_inv (coprod : A^op) x z inj. Class Coproduct (I : Type) {A : Type} `{Is1Cat A} (x : I -> A) := prod_co_coprod :: Product (A:=A^op) I x. Definition cat_coprod (I : Type) {A : Type} (x : I -> A) `{Coproduct I _ x} : A := cat_prod (A:=A^op) I x. Definition cat_in {I : Type} {A : Type} {x : I -> A} `{Coproduct I _ x} : forall (i : I), x i $-> cat_coprod I x := cat_pr (A:=A^op) (x:=x). Global Instance cat_isequiv_cat_coprod_rec_inv {I : Type} {A : Type} {x : I -> A} `{Coproduct I _ x} : forall (z : A), CatIsEquiv (cat_coprod_rec_inv (cat_coprod I x) x z cat_in) := cat_isequiv_cat_prod_corec_inv (A:=A^op) (x:=x). (** A convenience wrapper for building coproducts *) Definition Build_Coproduct (I : Type) {A : Type} `{Is1Cat A} {x : I -> A} (cat_coprod : A) (cat_in : forall i : I, x i $-> cat_coprod) (cat_coprod_rec : forall z : A, (forall i : I, x i $-> z) -> (cat_coprod $-> z)) (cat_coprod_beta_in : forall (z : A) (f : forall i, x i $-> z) (i : I), cat_coprod_rec z f $o cat_in i $== f i) (cat_prod_eta_in : forall (z : A) (f g : cat_coprod $-> z), (forall i : I, f $o cat_in i $== g $o cat_in i) -> f $== g) : Coproduct I x := Build_Product I (cat_coprod : A^op) cat_in cat_coprod_rec cat_coprod_beta_in cat_prod_eta_in. Section Lemmata. Context (I : Type) {A : Type} {x : I -> A} `{Coproduct I _ x}. Definition cate_cat_coprod_rec_inv {z : A} : yon_0gpd z (cat_coprod I x) $<~> prod_0gpd I (fun i => yon_0gpd z (x i)) := cate_cat_prod_corec_inv I (A:=A^op) (x:=x). Definition cate_cat_coprod_rec {z : A} : prod_0gpd I (fun i => yon_0gpd z (x i)) $<~> yon_0gpd z (cat_coprod I x) := cate_cat_prod_corec I (A:=A^op) (x:=x). Definition cat_coprod_rec {z : A} : (forall i, x i $-> z) -> cat_coprod I x $-> z := cat_prod_corec I (A:=A^op) (x:=x). Definition cat_coprod_beta {z : A} (f : forall i, x i $-> z) : forall i, cat_coprod_rec f $o cat_in i $== f i := cat_prod_beta I (A:=A^op) (x:=x) f. Definition cat_coprod_eta {z : A} (f : cat_coprod I x $-> z) : cat_coprod_rec (fun i => f $o cat_in i) $== f := cat_prod_eta I (A:=A^op) (x:=x) f. Definition natequiv_cat_coprod_rec_inv : NatEquiv (fun z => yon_0gpd z (cat_coprod I x)) (fun z : A => prod_0gpd I (fun i => yon_0gpd z (x i))) := natequiv_cat_prod_corec_inv I (A:=A^op) (x:=x). Definition cat_coprod_rec_eta {z : A} {f g : forall i, x i $-> z} : (forall i, f i $== g i) -> cat_coprod_rec f $== cat_coprod_rec g := cat_prod_corec_eta I (A:=A^op) (x:=x). Definition cat_coprod_in_eta {z : A} {f g : cat_coprod I x $-> z} : (forall i, f $o cat_in i $== g $o cat_in i) -> f $== g := cat_prod_pr_eta I (A:=A^op) (x:=x). End Lemmata. (** *** Codiagonal / fold map *) Definition cat_coprod_codiag {I : Type} {A : Type} (x : A) `{Coproduct I _ (fun _ => x)} : cat_coprod I (fun _ => x) $-> x := cat_prod_diag (A:=A^op) x. (** *** Uniqueness of coproducts *) (** [I]-indexed coproducts are unique no matter how they are constructed. *) Definition cate_cat_coprod {I J : Type} (ie : I <~> J) {A : Type} `{HasEquivs A} (x : I -> A) `{!Coproduct I x} (y : J -> A) `{!Coproduct J y} (e : forall (i : I), y (ie i) $<~> x i) : cat_coprod J y $<~> cat_coprod I x := cate_cat_prod (A:=A^op) ie x y e. (** *** Existence of coproducts *) Class HasCoproducts (I A : Type) `{Is1Cat A} := has_coproducts :: forall x : I -> A, Coproduct I x. Class HasAllCoproducts (A : Type) `{Is1Cat A} := has_all_coproducts :: forall I : Type, HasCoproducts I A. (** *** Coproduct functor *) Local Instance hasproductsop_hascoproducts {I A : Type} `{HasCoproducts I A} : HasProducts I A^op := fun x : I -> A^op => @has_coproducts I A _ _ _ _ _ x. Global Instance is0functor_cat_coprod (I : Type) `{IsGraph I} (A : Type) `{HasCoproducts I A} : @Is0Functor (I -> A) A (isgraph_forall I (fun _ => A)) _ (fun x : I -> A => cat_coprod I x). Proof. apply is0functor_op'. exact (is0functor_cat_prod I A^op). Defined. Global Instance is1functor_cat_coprod (I : Type) `{IsGraph I} (A : Type) `{HasCoproducts I A} : @Is1Functor (I -> A) A _ _ _ (is1cat_forall I (fun _ => A)) _ _ _ _ (fun x : I -> A => cat_coprod I x) _. Proof. apply is1functor_op'. exact (is1functor_cat_prod I A^op). Defined. (** *** Categories with specific kinds of coproducts *) Definition isinitial_coprodempty {A : Type} {z : A} `{Coproduct Empty A (fun _ => z)} : IsInitial (cat_coprod Empty (fun _ => z)). Proof. intros a. snrefine (cat_coprod_rec _ _; fun f => cat_coprod_in_eta _ _); intros []. Defined. (** *** Binary coproducts *) Class BinaryCoproduct {A : Type} `{Is1Cat A} (x y : A) := prod_co_bincoprod :: BinaryProduct (A:=A^op) x y. Definition cat_bincoprod {A : Type} `{Is1Cat A} (x y : A) `{!BinaryCoproduct x y} : A := cat_binprod (x : A^op) y. Definition cat_inl {A : Type} `{Is1Cat A} {x y : A} `{!BinaryCoproduct x y} : x $-> cat_bincoprod x y := cat_pr1 (A:=A^op) (x:=x) (y:=y). Definition cat_inr {A : Type} `{Is1Cat A} {x y : A} `{!BinaryCoproduct x y} : y $-> cat_bincoprod x y := cat_pr2 (A:=A^op) (x:=x) (y:=y). (** A category with binary coproducts is a category with a binary coproduct for each pair of objects. *) Class HasBinaryCoproducts (A : Type) `{Is1Cat A} := binary_coproducts :: forall x y, BinaryCoproduct x y. Global Instance hasbinarycoproducts_hascoproductsbool {A : Type} `{HasCoproducts Bool A} : HasBinaryCoproducts A := fun x y => has_coproducts (fun b : Bool => if b then x else y). (** A convenience wrapper for building binary coproducts *) Definition Build_BinaryCoproduct {A : Type} `{Is1Cat A} {x y : A} (cat_coprod : A) (cat_inl : x $-> cat_coprod) (cat_inr : y $-> cat_coprod) (cat_coprod_rec : forall z : A, (x $-> z) -> (y $-> z) -> cat_coprod $-> z) (cat_coprod_beta_inl : forall (z : A) (f : x $-> z) (g : y $-> z), cat_coprod_rec z f g $o cat_inl $== f) (cat_coprod_beta_inr : forall (z : A) (f : x $-> z) (g : y $-> z), cat_coprod_rec z f g $o cat_inr $== g) (cat_coprod_in_eta : forall (z : A) (f g : cat_coprod $-> z), f $o cat_inl $== g $o cat_inl -> f $o cat_inr $== g $o cat_inr -> f $== g) : BinaryCoproduct x y := Build_BinaryProduct (cat_coprod : A^op) cat_inl cat_inr cat_coprod_rec cat_coprod_beta_inl cat_coprod_beta_inr cat_coprod_in_eta. Section Lemmata. Context {A : Type} {x y z : A} `{BinaryCoproduct _ x y}. Definition cat_bincoprod_rec (f : x $-> z) (g : y $-> z) : cat_bincoprod x y $-> z := @cat_binprod_corec A^op _ _ _ _ x y _ _ f g. Definition cat_bincoprod_beta_inl (f : x $-> z) (g : y $-> z) : cat_bincoprod_rec f g $o cat_inl $== f := @cat_binprod_beta_pr1 A^op _ _ _ _ x y _ _ f g. Definition cat_bincoprod_beta_inr (f : x $-> z) (g : y $-> z) : cat_bincoprod_rec f g $o cat_inr $== g := @cat_binprod_beta_pr2 A^op _ _ _ _ x y _ _ f g. Definition cat_bincoprod_eta (f : cat_bincoprod x y $-> z) : cat_bincoprod_rec (f $o cat_inl) (f $o cat_inr) $== f := @cat_binprod_eta A^op _ _ _ _ x y _ _ f. Definition cat_bincoprod_eta_in {f g : cat_bincoprod x y $-> z} : f $o cat_inl $== g $o cat_inl -> f $o cat_inr $== g $o cat_inr -> f $== g := @cat_binprod_eta_pr A^op _ _ _ _ x y _ _ f g. Definition cat_bincoprod_rec_eta {f f' : x $-> z} {g g' : y $-> z} : f $== f' -> g $== g' -> cat_bincoprod_rec f g $== cat_bincoprod_rec f' g' := @cat_binprod_corec_eta A^op _ _ _ _ x y _ _ f f' g g'. End Lemmata. (** *** Binary coproduct functor *) (** Hint: Use [Set Printing Implicit] to see the implicit arguments in the following proofs. *) Global Instance is0functor_cat_bincoprod_l {A : Type} `{hbc : HasBinaryCoproducts A} y : Is0Functor (A:=A) (fun x => cat_bincoprod x y). Proof. rapply is0functor_op'. exact (is0functor_cat_binprod_l (A:=A^op) (H0:=hbc) y). Defined. Global Instance is1functor_cat_bincoprod_l {A : Type} `{hbc : HasBinaryCoproducts A} y : Is1Functor (fun x => cat_bincoprod x y). Proof. rapply is1functor_op'. exact (is1functor_cat_binprod_l (A:=A^op) (H0:=hbc) y). Defined. Global Instance is0functor_cat_bincoprod_r {A : Type} `{hbc : HasBinaryCoproducts A} x : Is0Functor (fun y => cat_bincoprod x y). Proof. rapply is0functor_op'. exact (is0functor_cat_binprod_r (A:=A^op) (H0:=hbc) x). Defined. Global Instance is1functor_cat_bincoprod_r {A : Type} `{hbc : HasBinaryCoproducts A} x : Is1Functor (fun y => cat_bincoprod x y). Proof. rapply is1functor_op'. exact (is1functor_cat_binprod_r (A:=A^op) (H0:=hbc) x). Defined. Global Instance is0bifunctor_cat_bincoprod {A : Type} `{hbc : HasBinaryCoproducts A} : Is0Bifunctor (fun x y => cat_bincoprod x y). Proof. nrapply is0bifunctor_op'. exact (is0bifunctor_cat_binprod (A:=A^op) (H0:=hbc)). Defined. Global Instance is1bifunctor_cat_bincoprod {A : Type} `{hbc : HasBinaryCoproducts A} : Is1Bifunctor (fun x y => cat_bincoprod x y). Proof. nrapply is1bifunctor_op'. exact (is1bifunctor_cat_binprod (A:=A^op) (H0:=hbc)). Defined. (** *** Products and coproducts in the opposite category *) Definition hasbinarycoproducts_op_hasbinaryproducts {A : Type} `{hbp : HasBinaryProducts A} : HasBinaryCoproducts A^op := hbp. Hint Immediate hasbinarycoproducts_op_hasbinaryproducts : typeclass_instances. Definition hasbinarycoproducts_hasbinaryproducts_op {A : Type} `{Is1Cat A, hbp : !HasBinaryProducts A^op} : HasBinaryCoproducts A := hbp. Hint Immediate hasbinarycoproducts_hasbinaryproducts_op : typeclass_instances. Definition hasbinaryproducts_op_hasbinarycoproducts {A : Type} `{hbc : HasBinaryCoproducts A} : HasBinaryProducts A^op := hbc. Hint Immediate hasbinarycoproducts_op_hasbinaryproducts : typeclass_instances. Definition hasbinaryproducts_hasbinarycoproducts_op {A : Type} `{Is1Cat A, hbc : !HasBinaryCoproducts A^op} : HasBinaryProducts A := hbc. Hint Immediate hasbinaryproducts_hasbinarycoproducts_op : typeclass_instances. (** *** Symmetry of coproducts *) Definition cat_bincoprod_swap {A : Type} `{Is1Cat A} {hbc : HasBinaryCoproducts A} (x y : A) : cat_bincoprod x y $-> cat_bincoprod y x. Proof. exact (@cat_binprod_swap A^op _ _ _ _ hbc _ _). Defined. Definition cate_bincoprod_swap {A : Type} `{HasEquivs A} {hbc : HasBinaryCoproducts A} (x y : A) : cat_bincoprod x y $<~> cat_bincoprod y x. Proof. exact (@cate_binprod_swap A^op _ _ _ _ _ hbc _ _). Defined. (** *** Associativity of coproducts *) Lemma cate_coprod_assoc {A : Type} `{HasEquivs A} {hbc : HasBinaryCoproducts A} (x y z : A) : cat_bincoprod x (cat_bincoprod y z) $<~> cat_bincoprod (cat_bincoprod x y) z. Proof. exact (@associator_cat_binprod A^op _ _ _ _ _ hbc x y z)^-1$. Defined. Definition associator_cat_bincoprod {A : Type} `{HasEquivs A} `{!HasBinaryCoproducts A} : Associator (fun x y => cat_bincoprod x y). Proof. unfold Associator. snrapply associator_op'. 1: exact _. nrapply associator_cat_binprod. Defined. (** *** Codiagonal *) Definition cat_bincoprod_codiag {A : Type} `{Is1Cat A} (x : A) `{!BinaryCoproduct x x} : cat_bincoprod x x $-> x := cat_binprod_diag (A:=A^op) x. (** *** Lemmas about [cat_bincoprod_rec] *) Definition cat_bincoprod_fmap01_rec {A : Type} `{Is1Cat A, !HasBinaryCoproducts A} {w x y z : A} (f : z $-> w) (g : y $-> x) (h : x $-> w) : cat_bincoprod_rec f h $o fmap01 (fun x y => cat_bincoprod x y) z g $== cat_bincoprod_rec f (h $o g) := @cat_binprod_fmap01_corec A^op _ _ _ _ hasbinaryproducts_op_hasbinarycoproducts _ _ _ _ f g h. Definition cat_bincoprod_fmap10_rec {A : Type} `{Is1Cat A, !HasBinaryCoproducts A} {w x y z : A} (f : y $-> x) (g : x $-> w) (h : z $-> w) : cat_bincoprod_rec g h $o fmap10 (fun x y => cat_bincoprod x y) f z $== cat_bincoprod_rec (g $o f) h := @cat_binprod_fmap10_corec A^op _ _ _ _ hasbinaryproducts_op_hasbinarycoproducts _ _ _ _ f g h. Definition cat_bincoprod_fmap11_rec {A : Type} `{Is1Cat A, !HasBinaryCoproducts A} {v w x y z : A} (f : y $-> w) (g : z $-> x) (h : w $-> v) (i : x $-> v) : cat_bincoprod_rec h i $o fmap11 (fun x y => cat_binprod x y) f g $== cat_bincoprod_rec (h $o f) (i $o g) := @cat_binprod_fmap11_corec A^op _ _ _ _ hasbinaryproducts_op_hasbinarycoproducts _ _ _ _ _ f g h i. Definition cat_bincoprod_rec_associator {A : Type} `{HasEquivs A} {hbc : HasBinaryCoproducts A} {w x y z : A} (f : w $-> z) (g : x $-> z) (h : y $-> z) : cat_bincoprod_rec (cat_bincoprod_rec f g) h $o associator_cat_bincoprod w x y $== cat_bincoprod_rec f (cat_bincoprod_rec g h). Proof. nrapply cate_moveR_eV. symmetry. exact (cat_binprod_associator_corec (HasBinaryProducts0:=hasbinaryproducts_op_hasbinarycoproducts (hbc:=hbc)) f g h). Defined. Definition cat_bincoprod_swap_rec {A : Type} `{Is1Cat A} `{!HasBinaryCoproducts A} {a b c : A} (f : a $-> c) (g : b $-> c) : cat_bincoprod_rec f g $o cat_bincoprod_swap b a $== cat_bincoprod_rec g f := @cat_binprod_swap_corec A^op _ _ _ _ hasbinaryproducts_op_hasbinarycoproducts _ _ _ _ _. (** *** Cocartesian Monoidal Structure *) Global Instance ismonoidal_cat_bincoprod {A : Type} `{HasEquivs A} `{!HasBinaryCoproducts A} (zero : A) `{!IsInitial zero} : IsMonoidal A (fun x y => cat_bincoprod x y) zero | 10. Proof. nrapply ismonoidal_op'. nrapply (ismonoidal_cat_binprod (A:=A^op) zero). by nrapply isterminal_op_isinitial. Defined. Global Instance issymmetricmonoidal_cat_bincoprod {A : Type} `{HasEquivs A} `{!HasBinaryCoproducts A} (zero : A) `{!IsInitial zero} : IsSymmetricMonoidal A (fun x y => cat_bincoprod x y) zero | 10. Proof. nrapply issymmetricmonoidal_op'. nrapply (issymmetricmonoidal_cat_binprod (A:=A^op) zero). by nrapply isterminal_op_isinitial. Defined. (** *** Coproducts in Type *) (** [Type] has all coproducts. *) Global Instance hasallcoproducts_type : HasAllCoproducts Type. Proof. intros I x. snrapply Build_Coproduct. - exact (sig (fun i : I => x i)). - exact (exist x). - intros A f [i xi]. exact (f i xi). - intros A f i xi; reflexivity. - intros A f g p [i xi]. exact (p i xi). Defined. (** In particular, [Type] has all binary coproducts. *) Global Instance hasbinarycoproducts_type : HasBinaryCoproducts Type := {}. (** ** Canonical coproduct-product map *) (** There is a canonical map from a coproduct to a product when the indexing set has decidable equality and the category is pointed. *) Definition cat_coprod_prod {I : Type} `{DecidablePaths I} {A : Type} `{Is1Cat A, !IsPointedCat A} (x : I -> A) `{!Coproduct I x, !Product I x} : cat_coprod I x $-> cat_prod I x. Proof. apply cat_coprod_rec. intros i. apply cat_prod_corec. intros a. destruct (dec_paths i a) as [p|]. - destruct p. exact (Id _). - apply zero_morphism. Defined. Definition cat_bincoprod_binprod {A : Type} `{Is1Cat A, !IsPointedCat A} (x y : A) `{!BinaryCoproduct x y, !BinaryProduct x y} : cat_bincoprod x y $-> cat_binprod x y. Proof. nrapply cat_coprod_prod; exact _. Defined. (** *** Coproducts in the opposite category *) Definition coproduct_op {I A : Type} (x : I -> A) `{Is1Cat A} {H' : Product I x} : Coproduct I (A:=A^op) x := H'. Hint Immediate coproduct_op : typeclass_instances. Coq-HoTT-9.0/theories/WildCat/Core.v000066400000000000000000000507151474641544500171760ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. (** * Wild categories, functors, and transformations *) (** ** Directed graphs *) Class IsGraph (A : Type) := { Hom : A -> A -> Type }. Notation "a $-> b" := (Hom a b). Definition graph_hfiber {B C : Type} `{IsGraph C} (F : B -> C) (c : C) := {b : B & F b $-> c}. (** ** 0-categorical structures *) (** A wild (0,1)-category has 1-morphisms and operations on them, but no coherence. *) Class Is01Cat (A : Type) `{IsGraph A} := { Id : forall (a : A), a $-> a; cat_comp : forall (a b c : A), (b $-> c) -> (a $-> b) -> (a $-> c); }. Arguments cat_comp {A _ _ a b c} _ _. Notation "g $o f" := (cat_comp g f). Definition cat_postcomp {A} `{Is01Cat A} (a : A) {b c : A} (g : b $-> c) : (a $-> b) -> (a $-> c) := cat_comp g. Definition cat_precomp {A} `{Is01Cat A} {a b : A} (c : A) (f : a $-> b) : (b $-> c) -> (a $-> c) := fun g => g $o f. (** A wild 0-groupoid is a wild (0,1)-category whose morphisms can be reversed. This is also known as a setoid. *) Class Is0Gpd (A : Type) `{Is01Cat A} := { gpd_rev : forall {a b : A}, (a $-> b) -> (b $-> a) }. Definition GpdHom {A} `{Is0Gpd A} (a b : A) := a $-> b. Notation "a $== b" := (GpdHom a b). Global Instance reflexive_GpdHom {A} `{Is0Gpd A} : Reflexive GpdHom := fun a => Id a. Global Instance reflexive_Hom {A} `{Is01Cat A} : Reflexive Hom := fun a => Id a. Definition gpd_comp {A} `{Is0Gpd A} {a b c : A} : (a $== b) -> (b $== c) -> (a $== c) := fun p q => q $o p. Infix "$@" := gpd_comp. Global Instance transitive_GpdHom {A} `{Is0Gpd A} : Transitive GpdHom := fun a b c f g => f $@ g. Global Instance transitive_Hom {A} `{Is01Cat A} : Transitive Hom := fun a b c f g => g $o f. Notation "p ^$" := (gpd_rev p). Global Instance symmetric_GpdHom {A} `{Is0Gpd A} : Symmetric GpdHom := fun a b f => f^$. Global Instance symmetric_GpdHom' {A} `{Is0Gpd A} : Symmetric Hom := fun a b f => f^$. Definition Hom_path {A : Type} `{Is01Cat A} {a b : A} (p : a = b) : (a $-> b). Proof. destruct p; apply Id. Defined. Definition GpdHom_path {A} `{Is0Gpd A} {a b : A} (p : a = b) : a $== b := Hom_path p. (** A 0-functor acts on morphisms, but satisfies no axioms. *) Class Is0Functor {A B : Type} `{IsGraph A} `{IsGraph B} (F : A -> B) := { fmap : forall (a b : A) (f : a $-> b), F a $-> F b }. Arguments fmap {A B isgraph_A isgraph_B} F {is0functor_F a b} f : rename. Class Is2Graph (A : Type) `{IsGraph A} := isgraph_hom : forall (a b : A), IsGraph (a $-> b). Global Existing Instance isgraph_hom | 20. #[global] Typeclasses Transparent Is2Graph. (** ** Wild 1-categorical structures *) Class Is1Cat (A : Type) `{!IsGraph A, !Is2Graph A, !Is01Cat A} := { is01cat_hom : forall (a b : A), Is01Cat (a $-> b) ; is0gpd_hom : forall (a b : A), Is0Gpd (a $-> b) ; is0functor_postcomp : forall (a b c : A) (g : b $-> c), Is0Functor (cat_postcomp a g) ; is0functor_precomp : forall (a b c : A) (f : a $-> b), Is0Functor (cat_precomp c f) ; cat_assoc : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d), (h $o g) $o f $== h $o (g $o f); cat_assoc_opp : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d), h $o (g $o f) $== (h $o g) $o f; cat_idl : forall (a b : A) (f : a $-> b), Id b $o f $== f; cat_idr : forall (a b : A) (f : a $-> b), f $o Id a $== f; }. Global Existing Instance is01cat_hom. Global Existing Instance is0gpd_hom. Global Existing Instance is0functor_postcomp. Global Existing Instance is0functor_precomp. Arguments cat_assoc {_ _ _ _ _ _ _ _ _} f g h. Arguments cat_assoc_opp {_ _ _ _ _ _ _ _ _} f g h. Arguments cat_idl {_ _ _ _ _ _ _} f. Arguments cat_idr {_ _ _ _ _ _ _} f. (** An alternate constructor that doesn't require the proof of [cat_assoc_opp]. This can be used for defining examples of wild categories, but shouldn't be used for the general theory of wild categories. *) Definition Build_Is1Cat' (A : Type) `{!IsGraph A, !Is2Graph A, !Is01Cat A} (is01cat_hom : forall a b : A, Is01Cat (a $-> b)) (is0gpd_hom : forall a b : A, Is0Gpd (a $-> b)) (is0functor_postcomp : forall (a b c : A) (g : b $-> c), Is0Functor (cat_postcomp a g)) (is0functor_precomp : forall (a b c : A) (f : a $-> b), Is0Functor (cat_precomp c f)) (cat_assoc : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d), h $o g $o f $== h $o (g $o f)) (cat_idl : forall (a b : A) (f : a $-> b), Id b $o f $== f) (cat_idr : forall (a b : A) (f : a $-> b), f $o Id a $== f) : Is1Cat A := Build_Is1Cat A _ _ _ is01cat_hom is0gpd_hom is0functor_postcomp is0functor_precomp cat_assoc (fun a b c d f g h => (cat_assoc a b c d f g h)^$) cat_idl cat_idr. (** Whiskering and horizontal composition of 2-cells. *) Definition cat_postwhisker {A} `{Is1Cat A} {a b c : A} {f g : a $-> b} (h : b $-> c) (p : f $== g) : h $o f $== h $o g := fmap (cat_postcomp a h) p. Notation "h $@L p" := (cat_postwhisker h p). Definition cat_prewhisker {A} `{Is1Cat A} {a b c : A} {f g : b $-> c} (p : f $== g) (h : a $-> b) : f $o h $== g $o h := fmap (cat_precomp c h) p. Notation "p $@R h" := (cat_prewhisker p h). Definition cat_comp2 {A} `{Is1Cat A} {a b c : A} {f g : a $-> b} {h k : b $-> c} (p : f $== g) (q : h $== k ) : h $o f $== k $o g := (q $@R _) $@ (_ $@L p). Notation "q $@@ p" := (cat_comp2 q p). (** Monomorphisms and epimorphisms. *) Definition Monic {A} `{Is1Cat A} {b c: A} (f : b $-> c) := forall a (g h : a $-> b), f $o g $== f $o h -> g $== h. Definition Epic {A} `{Is1Cat A} {a b : A} (f : a $-> b) := forall c (g h : b $-> c), g $o f $== h $o f -> g $== h. (** Section might be a clearer name but it's better to avoid confusion with Coq keywords. *) Record SectionOf {A} `{Is1Cat A} {a b : A} (f : a $-> b) := { comp_right_inverse : b $-> a; is_section : f $o comp_right_inverse $== Id b }. Record RetractionOf {A} `{Is1Cat A} {a b : A} (f : a $-> b) := { comp_left_inverse : b $-> a; is_retraction : comp_left_inverse $o f $== Id a }. (** Often, the coherences are actually equalities rather than homotopies. *) Class Is1Cat_Strong (A : Type)`{!IsGraph A, !Is2Graph A, !Is01Cat A} := { is01cat_hom_strong : forall (a b : A), Is01Cat (a $-> b) ; is0gpd_hom_strong : forall (a b : A), Is0Gpd (a $-> b) ; is0functor_postcomp_strong : forall (a b c : A) (g : b $-> c), Is0Functor (cat_postcomp a g) ; is0functor_precomp_strong : forall (a b c : A) (f : a $-> b), Is0Functor (cat_precomp c f) ; cat_assoc_strong : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d), (h $o g) $o f = h $o (g $o f) ; cat_assoc_opp_strong : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d), h $o (g $o f) = (h $o g) $o f ; cat_idl_strong : forall (a b : A) (f : a $-> b), Id b $o f = f ; cat_idr_strong : forall (a b : A) (f : a $-> b), f $o Id a = f ; }. Arguments cat_assoc_strong {_ _ _ _ _ _ _ _ _} f g h. Arguments cat_assoc_opp_strong {_ _ _ _ _ _ _ _ _} f g h. Arguments cat_idl_strong {_ _ _ _ _ _ _} f. Arguments cat_idr_strong {_ _ _ _ _ _ _} f. Global Instance is1cat_is1cat_strong (A : Type) `{Is1Cat_Strong A} : Is1Cat A | 1000. Proof. srapply Build_Is1Cat. all: intros a b. - apply is01cat_hom_strong. - apply is0gpd_hom_strong. - apply is0functor_postcomp_strong. - apply is0functor_precomp_strong. - intros; apply GpdHom_path, cat_assoc_strong. - intros; apply GpdHom_path, cat_assoc_opp_strong. - intros; apply GpdHom_path, cat_idl_strong. - intros; apply GpdHom_path, cat_idr_strong. Defined. (** Initial objects *) Definition IsInitial {A : Type} `{Is1Cat A} (x : A) := forall (y : A), {f : x $-> y & forall g, f $== g}. Existing Class IsInitial. Definition mor_initial {A : Type} `{Is1Cat A} (x y : A) {h : IsInitial x} : x $-> y := (h y).1. Definition mor_initial_unique {A : Type} `{Is1Cat A} (x y : A) {h : IsInitial x} (f : x $-> y) : mor_initial x y $== f := (h y).2 f. (** Terminal objects *) Definition IsTerminal {A : Type} `{Is1Cat A} (y : A) := forall (x : A), {f : x $-> y & forall g, f $== g}. Existing Class IsTerminal. Definition mor_terminal {A : Type} `{Is1Cat A} (x y : A) {h : IsTerminal y} : x $-> y := (h x).1. Definition mor_terminal_unique {A : Type} `{Is1Cat A} (x y : A) {h : IsTerminal y} (f : x $-> y) : mor_terminal x y $== f := (h x).2 f. (** Generalizing function extensionality, "Morphism extensionality" states that homwise [GpdHom_path] is an equivalence. *) Class HasMorExt (A : Type) `{Is1Cat A} := { isequiv_Htpy_path : forall a b f g, IsEquiv (@GpdHom_path (a $-> b) _ _ _ f g) }. Global Existing Instance isequiv_Htpy_path. Definition path_hom {A} `{HasMorExt A} {a b : A} {f g : a $-> b} (p : f $== g) : f = g := GpdHom_path^-1 p. (** A 1-category with morphism extensionality induces a strong 1-category *) Global Instance is1cat_strong_hasmorext {A : Type} `{HasMorExt A} : Is1Cat_Strong A. Proof. rapply Build_Is1Cat_Strong; hnf; intros; apply path_hom. + apply cat_assoc. + apply cat_assoc_opp. + apply cat_idl. + apply cat_idr. Defined. (** A 1-functor acts on 2-cells (satisfying no axioms) and also preserves composition and identities up to a 2-cell. *) (* The [!] tells Coq to use typeclass search to find the [IsGraph] parameters of [Is0Functor] instead of assuming additional copies of them. *) Class Is1Functor {A B : Type} `{Is1Cat A} `{Is1Cat B} (F : A -> B) `{!Is0Functor F} := { fmap2 : forall a b (f g : a $-> b), (f $== g) -> (fmap F f $== fmap F g) ; fmap_id : forall a, fmap F (Id a) $== Id (F a); fmap_comp : forall a b c (f : a $-> b) (g : b $-> c), fmap F (g $o f) $== fmap F g $o fmap F f; }. Arguments fmap2 {A B isgraph_A is2graph_A is01cat_A is1cat_A isgraph_B is2graph_B is01cat_B is1cat_B} F {is0functor_F is1functor_F a b f g} p : rename. Arguments fmap_id {A B isgraph_A is2graph_A is01cat_A is1cat_A isgraph_B is2graph_B is01cat_B is1cat_B} F {is0functor_F is1functor_F} a : rename. Arguments fmap_comp {A B isgraph_A is2graph_A is01cat_A is1cat_A isgraph_B is2graph_B is01cat_B is1cat_B} F {is0functor_F is1functor_F a b c} f g : rename. Class Faithful {A B : Type} (F : A -> B) `{Is1Functor A B F} := faithful : forall (x y : A) (f g : x $-> y), fmap F f $== fmap F g -> f $== g. (** Identity functor *) Section IdentityFunctor. Global Instance is0functor_idmap {A : Type} `{IsGraph A} : Is0Functor idmap. Proof. by apply Build_Is0Functor. Defined. Global Instance is1functor_idmap {A : Type} `{Is1Cat A} : Is1Functor idmap. Proof. by apply Build_Is1Functor. Defined. #[export] Instance isFaithful_idmap {A : Type} `{Is1Cat A}: Faithful idmap. Proof. by unfold Faithful. Defined. End IdentityFunctor. (** Constant functor *) Section ConstantFunctor. Context {A B : Type}. Global Instance is01functor_const `{IsGraph A} `{Is01Cat B} (x : B) : Is0Functor (fun _ : A => x). Proof. srapply Build_Is0Functor. intros a b f; apply Id. Defined. Global Instance is1functor_const `{Is1Cat A} `{Is1Cat B} (x : B) : Is1Functor (fun _ : A => x). Proof. srapply Build_Is1Functor. - intros a b f g p; apply Id. - intro; apply Id. - intros a b c f g. cbn. symmetry. apply cat_idl. Defined. End ConstantFunctor. (** Composite functors *) Global Instance is0functor_compose {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C} (F : A -> B) `{!Is0Functor F} (G : B -> C) `{!Is0Functor G} : Is0Functor (G o F). Proof. srapply Build_Is0Functor. intros a b f; exact (fmap G (fmap F f)). Defined. Global Instance is1functor_compose {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (G : B -> C) `{!Is0Functor G, !Is1Functor G} : Is1Functor (G o F). Proof. srapply Build_Is1Functor. - intros a b f g p; exact (fmap2 G (fmap2 F p)). - intros a; exact (fmap2 G (fmap_id F a) $@ fmap_id G (F a)). - intros a b c f g. refine (fmap2 G (fmap_comp F f g) $@ _). exact (fmap_comp G (fmap F f) (fmap F g)). Defined. (** We give all arguments names in order to refer to them later. This allows us to write things like [is0functor (isgraph_A := _)] without having to make all the variables explicit. *) Arguments is0functor_compose {A B C} {isgraph_A isgraph_B isgraph_C} F {is0functor_F} G {is0functor_G} : rename. Arguments is1functor_compose {A B C} {isgraph_A is2graph_A is01cat_A is1cat_A isgraph_B is2graph_B is01cat_B is1cat_B isgraph_C is2graph_C is01cat_C is1cat_C} F {is0functor_F} {is1functor_F} G {is0functor_G} {is1functor_G} : rename. (** ** Wild 1-groupoids *) Class Is1Gpd (A : Type) `{Is1Cat A, !Is0Gpd A} := { gpd_issect : forall {a b : A} (f : a $-> b), f^$ $o f $== Id a ; gpd_isretr : forall {a b : A} (f : a $-> b), f $o f^$ $== Id b ; }. (** Some more convenient equalities for morphisms in a 1-groupoid. The naming scheme is similar to [PathGroupoids.v].*) Definition gpd_V_hh {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b) : f^$ $o (f $o g) $== g := (cat_assoc _ _ _)^$ $@ (gpd_issect f $@R g) $@ cat_idl g. Definition gpd_h_Vh {A} `{Is1Gpd A} {a b c : A} (f : c $-> b) (g : a $-> b) : f $o (f^$ $o g) $== g := (cat_assoc _ _ _)^$ $@ (gpd_isretr f $@R g) $@ cat_idl g. Definition gpd_hh_V {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b) : (f $o g) $o g^$ $== f := cat_assoc _ _ _ $@ (f $@L gpd_isretr g) $@ cat_idr f. Definition gpd_hV_h {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : b $-> a) : (f $o g^$) $o g $== f := cat_assoc _ _ _ $@ (f $@L gpd_issect g) $@ cat_idr f. Definition gpd_moveL_1M {A} `{Is1Gpd A} {x y : A} {p q : x $-> y} (r : p $o q^$ $== Id _) : p $== q. Proof. refine ((cat_idr p)^$ $@ (p $@L (gpd_issect q)^$) $@ (cat_assoc _ _ _)^$ $@ _). refine ((r $@R q) $@ cat_idl q). Defined. Definition gpd_moveR_V1 {A} `{Is1Gpd A} {x y : A} {p : x $-> y} {q : y $-> x} (r : Id _ $== p $o q) : p^$ $== q. Proof. refine ((cat_idr p^$)^$ $@ (p^$ $@L r) $@ _). apply gpd_V_hh. Defined. Definition gpd_moveR_M1 {A : Type} `{Is1Gpd A} {x y : A} {p q : x $-> y} (r : Id _ $== p^$ $o q) : p $== q. Proof. refine (_ $@ (cat_assoc _ _ _)^$ $@ ((gpd_isretr p) $@R q) $@ (cat_idl q)). exact ((cat_idr p)^$ $@ (p $@L r)). Defined. Definition gpd_moveR_1M {A : Type} `{Is1Gpd A} {x y : A} {p q : x $-> y} (r : Id _ $== q $o p^$) : p $== q. Proof. refine ((cat_idl p)^$ $@ _ $@ cat_idr q). refine (_ $@ cat_assoc _ _ _ $@ (q $@L (gpd_issect p)^$)^$). exact (r $@R p). Defined. Definition gpd_moveL_1V {A : Type} `{Is1Gpd A} {x y : A} {p : x $-> y} {q : y $-> x} (r : p $o q $== Id _) : p $== q^$. Proof. refine (_ $@ (cat_idl q^$)). refine (_ $@ (r $@R q^$)). exact (gpd_hh_V _ _)^$. Defined. Definition gpd_moveR_hV {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z} {q : x $-> y} {r : x $-> z} (s : r $== p $o q) : r $o q^$ $== p := (s $@R q^$) $@ gpd_hh_V _ _. Definition gpd_moveR_Vh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z} {q : x $-> y} {r : x $-> z} (s : r $== p $o q) : p^$ $o r $== q := (p^$ $@L s) $@ gpd_V_hh _ _. Definition gpd_moveL_hM {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z} {q : x $-> y} {r : x $-> z} (s : r $o q^$ $== p) : r $== p $o q := ((gpd_hV_h _ _)^$ $@ (s $@R _)). Definition gpd_moveL_hV {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z} {q : x $-> y} {r : x $-> z} (s : p $o q $== r) : p $== r $o q^$ := (gpd_moveR_hV s^$)^$. Definition gpd_moveL_Mh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z} {q : x $-> y} {r : x $-> z} (s : p^$ $o r $== q) : r $== p $o q := ((gpd_h_Vh _ _)^$ $@ (p $@L s)). Definition gpd_moveL_Vh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z} {q : x $-> y} {r : x $-> z} (s : p $o q $== r) : q $== p^$ $o r := (gpd_moveR_Vh s^$)^$. Definition gpd_rev2 {A : Type} `{Is1Gpd A} {x y : A} {p q : x $-> y} (r : p $== q) : p^$ $== q^$. Proof. apply gpd_moveR_V1. apply gpd_moveL_hV. exact (cat_idl q $@ r^$). Defined. Definition gpd_rev_pp {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b) : (f $o g)^$ $== g^$ $o f^$. Proof. apply gpd_moveR_V1. refine (_ $@ cat_assoc _ _ _). apply gpd_moveL_hV. refine (cat_idl _ $@ _). exact (gpd_hh_V _ _)^$. Defined. Definition gpd_rev_1 {A} `{Is1Gpd A} {a : A} : (Id a)^$ $== Id a. Proof. refine ((gpd_rev2 (gpd_issect (Id a)))^$ $@ _). refine (gpd_rev_pp _ _ $@ _). apply gpd_isretr. Defined. Definition gpd_rev_rev {A} `{Is1Gpd A} {a0 a1 : A} (g : a0 $== a1) : (g^$)^$ $== g. Proof. apply gpd_moveR_V1. exact (gpd_issect _)^$. Defined. (** 1-functors between 1-groupoids preserve identities *) Definition gpd_1functor_V {A B} `{Is1Gpd A, Is1Gpd B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a0 a1 : A} (f : a0 $== a1) : fmap F f^$ $== (fmap F f)^$. Proof. apply gpd_moveL_1V. refine ((fmap_comp _ _ _)^$ $@ _ $@ fmap_id _ _). rapply fmap2. apply gpd_issect. Defined. (** Movement lemmas with extensionality *) (** For more complex movements you probably want to apply [path_hom] and use the lemmas above. *) Definition gpd_strong_V_hh {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : b $-> c) (g : a $-> b) : f^$ $o (f $o g) = g := path_hom (gpd_V_hh f g). Definition gpd_strong_h_Vh {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : c $-> b) (g : a $-> b) : f $o (f^$ $o g) = g := path_hom (gpd_h_Vh f g). Definition gpd_strong_hh_V {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : b $-> c) (g : a $-> b) : (f $o g) $o g^$ = f := path_hom (gpd_hh_V f g). Definition gpd_strong_hV_h {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : b $-> c) (g : b $-> a) : (f $o g^$) $o g = f := path_hom (gpd_hV_h f g). Definition gpd_strong_rev_pp {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : b $-> c) (g : a $-> b) : (f $o g)^$ = g^$ $o f^$ := path_hom (gpd_rev_pp f g). Definition gpd_strong_rev_1 {A} `{Is1Gpd A, !HasMorExt A} {a : A} : (Id a)^$ = Id a := path_hom gpd_rev_1. Definition gpd_strong_rev_rev {A} `{Is1Gpd A, !HasMorExt A} {a0 a1 : A} (g : a0 $== a1) : (g^$)^$ = g := path_hom (gpd_rev_rev g). Definition fmap_id_strong {A B} `{Is1Cat A, Is1Cat B, !HasMorExt B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (a : A) : fmap F (Id a) = Id (F a) := path_hom (fmap_id F a). Definition gpd_strong_1functor_V {A B} `{Is1Gpd A, Is1Gpd B, !HasMorExt B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a0 a1 : A} (f : a0 $== a1) : fmap F f^$ = (fmap F f)^$ := path_hom (gpd_1functor_V F f). Class Is3Graph (A : Type) `{Is2Graph A} := isgraph_hom_hom : forall (a b : A), Is2Graph (a $-> b). Global Existing Instance isgraph_hom_hom | 30. #[global] Typeclasses Transparent Is3Graph. (** *** Preservation of initial and terminal objects *) Class PreservesInitial {A B : Type} (F : A -> B) `{Is1Functor A B F} : Type := isinitial_preservesinitial : forall (x : A), IsInitial x -> IsInitial (F x). Global Existing Instance isinitial_preservesinitial. (** The initial morphism is preserved by such a functor. *) Lemma fmap_initial {A B : Type} (F : A -> B) `{PreservesInitial A B F} (x y : A) (h : IsInitial x) : fmap F (mor_initial x y) $== mor_initial (F x) (F y). Proof. exact (mor_initial_unique _ _ _)^$. Defined. Class PreservesTerminal {A B : Type} (F : A -> B) `{Is1Functor A B F} : Type := isterminal_preservesterminal : forall (x : A), IsTerminal x -> IsTerminal (F x). Global Existing Instance isterminal_preservesterminal. (** The terminal morphism is preserved by such a functor. *) Lemma fmap_terminal {A B : Type} (F : A -> B) `{PreservesTerminal A B F} (x y : A) (h : IsTerminal y) : fmap F (mor_terminal x y) $== mor_terminal (F x) (F y). Proof. exact (mor_terminal_unique _ _ _)^$. Defined. (** *** Functors preserving distinguished objects *) Record BasepointPreservingFunctor (B C : Type) `{Is01Cat B, Is01Cat C} `{IsPointed B, IsPointed C} := { bp_map : B -> C; bp_is0functor : Is0Functor bp_map; bp_pointed : bp_map (point B) $-> point C }. Arguments bp_pointed {B C}%_type_scope {H H0 H1 H2 H3 H4} b. Arguments Build_BasepointPreservingFunctor {B C}%_type_scope {H H0 H1 H2 H3 H4} bp_map%_function_scope {bp_is0functor} bp_pointed. Coercion bp_map : BasepointPreservingFunctor >-> Funclass. Global Existing Instance bp_is0functor. Notation "B -->* C" := (BasepointPreservingFunctor B C) (at level 70). Definition basepointpreservingfunctor_compose {B C D : Type} `{Is01Cat B, Is01Cat C, Is01Cat D} `{IsPointed B, IsPointed C, IsPointed D} (F : B -->* C) (G : C -->* D) : B -->* D. Proof. snrapply Build_BasepointPreservingFunctor. - exact (G o F). - exact _. - exact (bp_pointed G $o fmap G (bp_pointed F)). Defined. Notation "G $o* F" := (basepointpreservingfunctor_compose F G) (at level 40). Coq-HoTT-9.0/theories/WildCat/Displayed.v000066400000000000000000000503201474641544500202140ustar00rootroot00000000000000Require Import Basics.Overture. Require Import Basics.PathGroupoids. Require Import Basics.Tactics. Require Import Types.Sigma. Require Import WildCat.Core. Require Import WildCat.Prod. Class IsDGraph {A : Type} `{IsGraph A} (D : A -> Type) := DHom : forall {a b : A}, (a $-> b) -> D a -> D b -> Type. Class IsD01Cat {A : Type} `{Is01Cat A} (D : A -> Type) `{!IsDGraph D} := { DId : forall {a : A} (a' : D a), DHom (Id a) a' a'; dcat_comp : forall {a b c : A} {g : b $-> c} {f : a $-> b} {a' : D a} {b' : D b} {c' : D c}, DHom g b' c' -> DHom f a' b' -> DHom (g $o f) a' c'; }. Notation "g '$o'' f" := (dcat_comp g f). Definition dcat_postcomp {A : Type} {D : A -> Type} `{IsD01Cat A D} {a b c : A} {g : b $-> c} {a' : D a} {b' : D b} {c' : D c} (g' : DHom g b' c') : forall (f : a $-> b), DHom f a' b' -> DHom (g $o f) a' c' := fun _ f' => g' $o' f'. Definition dcat_precomp {A : Type} {D : A -> Type} `{IsD01Cat A D} {a b c : A} {f : a $-> b} {a' : D a} {b' : D b} {c' : D c} (f' : DHom f a' b') : forall (g : b $-> c), DHom g b' c' -> DHom (g $o f) a' c' := fun _ g' => g' $o' f'. Class IsD0Gpd {A : Type} `{Is0Gpd A} (D : A -> Type) `{!IsDGraph D, !IsD01Cat D} := dgpd_rev : forall {a b : A} {f : a $== b} {a' : D a} {b' : D b}, DHom f a' b' -> DHom (f^$) b' a'. Notation "p ^$'" := (dgpd_rev p). Definition DGpdHom {A : Type} {D : A -> Type} `{IsD0Gpd A D} {a b : A} (f : a $== b) (a' : D a) (b' : D b) := DHom f a' b'. (** Diagrammatic order to match gpd_comp *) Definition dgpd_comp {A : Type} {D : A -> Type} `{IsD0Gpd A D} {a b c : A} {f : a $== b} {g : b $== c} {a' : D a} {b' : D b} {c' : D c} : DGpdHom f a' b' -> DGpdHom g b' c' -> DGpdHom (g $o f) a' c' := fun f' g' => g' $o' f'. Notation "p '$@'' q" := (dgpd_comp p q). Definition DHom_path {A : Type} {D : A -> Type} `{IsD01Cat A D} {a b : A} (p : a = b) {a' : D a} {b': D b} (p' : transport D p a' = b') : DHom (Hom_path p) a' b'. Proof. destruct p, p'; apply DId. Defined. Definition DGpdHom_path {A : Type} {D : A -> Type} `{IsD0Gpd A D} {a b : A} (p : a = b) {a' : D a} {b': D b} (p' : transport D p a' = b') : DGpdHom (GpdHom_path p) a' b' := DHom_path p p'. Global Instance reflexive_DHom {A} {D : A -> Type} `{IsD01Cat A D} {a : A} : Reflexive (DHom (Id a)) := fun a' => DId a'. Global Instance reflexive_DGpdHom {A} {D : A -> Type} `{IsD0Gpd A D} {a : A} : Reflexive (DGpdHom (Id a)) := fun a' => DId a'. (** A displayed 0-functor [F'] over a 0-functor [F] acts on displayed objects and 1-cells and satisfies no axioms. *) Class IsD0Functor {A : Type} {B : Type} {DA : A -> Type} `{IsDGraph A DA} {DB : B -> Type} `{IsDGraph B DB} (F : A -> B) `{!Is0Functor F} (F' : forall (a : A), DA a -> DB (F a)) := dfmap : forall {a b : A} {f : a $-> b} {a' : DA a} {b' : DA b}, DHom f a' b' -> DHom (fmap F f) (F' a a') (F' b b'). Arguments dfmap {A B DA _ _ DB _ _} F {_} F' {_ _ _ _ _ _} f'. Class IsD2Graph {A : Type} `{Is2Graph A} (D : A -> Type) `{!IsDGraph D} := isdgraph_hom : forall {a b} {a'} {b'}, IsDGraph (fun (f:a $-> b) => DHom f a' b'). Global Existing Instance isdgraph_hom. #[global] Typeclasses Transparent IsD2Graph. Class IsD1Cat {A : Type} `{Is1Cat A} (D : A -> Type) `{!IsDGraph D, !IsD2Graph D, !IsD01Cat D} := { isd01cat_hom : forall {a b : A} {a' : D a} {b' : D b}, IsD01Cat (fun f => DHom f a' b'); isd0gpd_hom : forall {a b : A} {a' : D a} {b' : D b}, IsD0Gpd (fun f => DHom f a' b'); isd0functor_postcomp : forall {a b c : A} {g : b $-> c} {a' : D a} {b' : D b} {c' : D c} (g' : DHom g b' c'), @IsD0Functor _ _ (fun f => DHom f a' b') _ _ (fun gf => DHom gf a' c') _ _ (cat_postcomp a g) _ (dcat_postcomp g'); isd0functor_precomp : forall {a b c : A} {f : a $-> b} {a' : D a} {b' : D b} {c' : D c} (f' : DHom f a' b'), @IsD0Functor _ _ (fun g => DHom g b' c') _ _ (fun gf => DHom gf a' c') _ _ (cat_precomp c f) _ (dcat_precomp f'); dcat_assoc : forall {a b c d : A} {f : a $-> b} {g : b $-> c} {h : c $-> d} {a' : D a} {b' : D b} {c' : D c} {d' : D d} (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d'), DHom (cat_assoc f g h) ((h' $o' g') $o' f') (h' $o' (g' $o' f')); dcat_assoc_opp : forall {a b c d : A} {f : a $-> b} {g : b $-> c} {h : c $-> d} {a' : D a} {b' : D b} {c' : D c} {d' : D d} (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d'), DHom (cat_assoc_opp f g h) (h' $o' (g' $o' f')) ((h' $o' g') $o' f'); dcat_idl : forall {a b : A} {f : a $-> b} {a' : D a} {b' : D b} (f' : DHom f a' b'), DHom (cat_idl f) (DId b' $o' f') f'; dcat_idr : forall {a b : A} {f : a $-> b} {a' : D a} {b' : D b} (f' : DHom f a' b'), DHom (cat_idr f) (f' $o' DId a') f'; }. Global Existing Instance isd01cat_hom. Global Existing Instance isd0gpd_hom. Global Existing Instance isd0functor_postcomp. Global Existing Instance isd0functor_precomp. Definition dcat_postwhisker {A : Type} {D : A -> Type} `{IsD1Cat A D} {a b c : A} {f g : a $-> b} {h : b $-> c} {p : f $== g} {a' : D a} {b' : D b} {c' : D c} {f' : DHom f a' b'} {g' : DHom g a' b'} (h' : DHom h b' c') (p' : DHom p f' g') : DHom (h $@L p) (h' $o' f') (h' $o' g') := dfmap (cat_postcomp a h) (dcat_postcomp h') p'. Notation "h $@L' p" := (dcat_postwhisker h p). Definition dcat_prewhisker {A : Type} {D : A -> Type} `{IsD1Cat A D} {a b c : A} {f : a $-> b} {g h : b $-> c} {p : g $== h} {a' : D a} {b' : D b} {c' : D c} {g' : DHom g b' c'} {h' : DHom h b' c'} (p' : DHom p g' h') (f' : DHom f a' b') : DHom (p $@R f) (g' $o' f') (h' $o' f') := dfmap (cat_precomp c f) (dcat_precomp f') p'. Notation "p $@R' f" := (dcat_prewhisker p f). Definition dcat_comp2 {A : Type} {D : A -> Type} `{IsD1Cat A D} {a b c : A} {f g : a $-> b} {h k : b $-> c} {p : f $== g} {q : h $== k} {a' : D a} {b' : D b} {c' : D c} {f' : DHom f a' b'} {g' : DHom g a' b'} {h' : DHom h b' c'} {k' : DHom k b' c'} (p' : DHom p f' g') (q' : DHom q h' k') : DHom (p $@@ q) (h' $o' f') (k' $o' g') := (k' $@L' p') $o' (q' $@R' f'). Notation "q $@@' p" := (dcat_comp2 q p). (** Monomorphisms and epimorphisms. *) Definition DMonic {A} {D : A -> Type} `{IsD1Cat A D} {b c : A} {f : b $-> c} {mon : Monic f} {b' : D b} {c' : D c} (f' : DHom f b' c') := forall (a : A) (g h : a $-> b) (p : f $o g $== f $o h) (a' : D a) (g' : DHom g a' b') (h' : DHom h a' b'), DGpdHom p (f' $o' g') (f' $o' h') -> DGpdHom (mon a g h p) g' h'. Definition DEpic {A} {D : A -> Type} `{IsD1Cat A D} {a b : A} {f : a $-> b} {epi : Epic f} {a' : D a} {b' : D b} (f' : DHom f a' b') := forall (c : A) (g h : b $-> c) (p : g $o f $== h $o f) (c' : D c) (g' : DHom g b' c') (h' : DHom h b' c'), DGpdHom p (g' $o' f') (h' $o' f') -> DGpdHom (epi c g h p) g' h'. Global Instance isgraph_total {A : Type} (D : A -> Type) `{IsDGraph A D} : IsGraph (sig D). Proof. srapply Build_IsGraph. intros [a a'] [b b']. exact {f : a $-> b & DHom f a' b'}. Defined. Global Instance is01cat_total {A : Type} (D : A -> Type) `{IsD01Cat A D} : Is01Cat (sig D). Proof. srapply Build_Is01Cat. - intros [a a']. exact (Id a; DId a'). - intros [a a'] [b b'] [c c'] [g g'] [f f']. exact (g $o f; g' $o' f'). Defined. Global Instance is0gpd_total {A : Type} (D : A -> Type) `{IsD0Gpd A D} : Is0Gpd (sig D). Proof. srapply Build_Is0Gpd. intros [a a'] [b b'] [f f']. exact (f^$; dgpd_rev f'). Defined. Global Instance is0functor_total_pr1 {A : Type} (D : A -> Type) `{IsDGraph A D} : Is0Functor (pr1 : sig D -> A). Proof. srapply Build_Is0Functor. intros [a a'] [b b'] [f f']. exact f. Defined. Global Instance is2graph_total {A : Type} (D : A -> Type) `{IsD2Graph A D} : Is2Graph (sig D). Proof. intros [a a'] [b b']. srapply Build_IsGraph. intros [f f'] [g g']. exact ({p : f $-> g & DHom p f' g'}). Defined. Global Instance is0functor_total {A : Type} (DA : A -> Type) `{IsD01Cat A DA} {B : Type} (DB : B -> Type) `{IsD01Cat B DB} (F : A -> B) `{!Is0Functor F} (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F'} : Is0Functor (functor_sigma F F'). Proof. srapply Build_Is0Functor. intros [a a'] [b b']. intros [f f']. exact (fmap F f; dfmap F F' f'). Defined. Global Instance is1cat_total {A : Type} (D : A -> Type) `{IsD1Cat A D} : Is1Cat (sig D). Proof. srapply Build_Is1Cat. - intros [a a'] [b b'] [c c'] [f f']. apply Build_Is0Functor. intros [g g'] [h h'] [p p']. exact (f $@L p; f' $@L' p'). - intros [a a'] [b b'] [c c'] [f f']. apply Build_Is0Functor. intros [g g'] [h h'] [p p']. exact (p $@R f; p' $@R' f'). - intros [a a'] [b b'] [c c'] [d d'] [f f'] [g g'] [h h']. exact (cat_assoc f g h; dcat_assoc f' g' h'). - intros [a a'] [b b'] [c c'] [d d'] [f f'] [g g'] [h h']. exact (cat_assoc_opp f g h; dcat_assoc_opp f' g' h'). - intros [a a'] [b b'] [f f']. exact (cat_idl f; dcat_idl f'). - intros [a a'] [b b'] [f f']. exact (cat_idr f; dcat_idr f'). Defined. Global Instance is1functor_pr1 {A : Type} {D : A -> Type} `{IsD1Cat A D} : Is1Functor (pr1 : sig D -> A). Proof. srapply Build_Is1Functor. - intros [a a'] [b b'] [f f'] [g g'] [p p']. exact p. - intros [a a']. apply Id. - intros [a a'] [b b'] [c c'] [f f'] [g g']. apply Id. Defined. Class IsD1Cat_Strong {A : Type} `{Is1Cat_Strong A} (D : A -> Type) `{!IsDGraph D, !IsD2Graph D, !IsD01Cat D} := { isd01cat_hom_strong : forall {a b : A} {a' : D a} {b' : D b}, IsD01Cat (fun f => DHom f a' b'); isd0gpd_hom_strong : forall {a b : A} {a' : D a} {b' : D b}, IsD0Gpd (fun f => DHom f a' b'); isd0functor_postcomp_strong : forall {a b c : A} {g : b $-> c} {a' : D a} {b' : D b} {c' : D c} (g' : DHom g b' c'), @IsD0Functor _ _ (fun f => DHom f a' b') _ _ (fun gf => DHom gf a' c') _ _ (cat_postcomp a g) _ (dcat_postcomp g'); isd0functor_precomp_strong : forall {a b c : A} {f : a $-> b} {a' : D a} {b' : D b} {c' : D c} (f' : DHom f a' b'), @IsD0Functor _ _ (fun g => DHom g b' c') _ _ (fun gf => DHom gf a' c') _ _ (cat_precomp c f) _ (dcat_precomp f'); dcat_assoc_strong : forall {a b c d : A} {f : a $-> b} {g : b $-> c} {h : c $-> d} {a' : D a} {b' : D b} {c' : D c} {d' : D d} (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d'), (transport (fun k => DHom k a' d') (cat_assoc_strong f g h) ((h' $o' g') $o' f')) = h' $o' (g' $o' f'); dcat_assoc_opp_strong : forall {a b c d : A} {f : a $-> b} {g : b $-> c} {h : c $-> d} {a' : D a} {b' : D b} {c' : D c} {d' : D d} (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d'), (transport (fun k => DHom k a' d') (cat_assoc_opp_strong f g h) (h' $o' (g' $o' f'))) = (h' $o' g') $o' f'; dcat_idl_strong : forall {a b : A} {f : a $-> b} {a' : D a} {b' : D b} (f' : DHom f a' b'), (transport (fun k => DHom k a' b') (cat_idl_strong f) (DId b' $o' f')) = f'; dcat_idr_strong : forall {a b : A} {f : a $-> b} {a' : D a} {b' : D b} (f' : DHom f a' b'), (transport (fun k => DHom k a' b') (cat_idr_strong f) (f' $o' DId a')) = f'; }. Global Existing Instance isd01cat_hom_strong. Global Existing Instance isd0gpd_hom_strong. Global Existing Instance isd0functor_postcomp_strong. Global Existing Instance isd0functor_precomp_strong. (* If in the future we make a [Build_Is1Cat_Strong'] that lets the user omit the second proof of associativity, this shows how it can be recovered from the original proof: Definition dcat_assoc_opp_strong {A : Type} {D : A -> Type} `{IsD1Cat_Strong A D} {a b c d : A} {f : a $-> b} {g : b $-> c} {h : c $-> d} {a' : D a} {b' : D b} {c' : D c} {d' : D d} (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d') : (transport (fun k => DHom k a' d') (cat_assoc_opp_strong f g h) (h' $o' (g' $o' f'))) = (h' $o' g') $o' f'. Proof. apply (moveR_transport_V (fun k => DHom k a' d') (cat_assoc_strong f g h) _ _). exact ((dcat_assoc_strong f' g' h')^). Defined. *) Global Instance isd1cat_isd1catstrong {A : Type} (D : A -> Type) `{IsD1Cat_Strong A D} : IsD1Cat D. Proof. srapply Build_IsD1Cat. - intros a b c d f g h a' b' c' d' f' g' h'. exact (DHom_path (cat_assoc_strong f g h) (dcat_assoc_strong f' g' h')). - intros a b c d f g h a' b' c' d' f' g' h'. exact (DHom_path (cat_assoc_opp_strong f g h) (dcat_assoc_opp_strong f' g' h')). - intros a b f a' b' f'. exact (DHom_path (cat_idl_strong f) (dcat_idl_strong f')). - intros a b f a' b' f'. exact (DHom_path (cat_idr_strong f) (dcat_idr_strong f')). Defined. Global Instance is1catstrong_total {A : Type} (D : A -> Type) `{IsD1Cat_Strong A D} : Is1Cat_Strong (sig D). Proof. srapply Build_Is1Cat_Strong. - intros aa' bb' cc' dd' [f f'] [g g'] [h h']. exact (path_sigma' _ (cat_assoc_strong f g h) (dcat_assoc_strong f' g' h')). - intros aa' bb' cc' dd' [f f'] [g g'] [h h']. exact (path_sigma' _ (cat_assoc_opp_strong f g h) (dcat_assoc_opp_strong f' g' h')). - intros aa' bb' [f f']. exact (path_sigma' _ (cat_idl_strong f) (dcat_idl_strong f')). - intros aa' bb' [f f']. exact (path_sigma' _ (cat_idr_strong f) (dcat_idr_strong f')). Defined. Class IsD1Functor {A B : Type} {DA : A -> Type} `{IsD1Cat A DA} {DB : B -> Type} `{IsD1Cat B DB} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F'} := { dfmap2 : forall {a b : A} {f g : a $-> b} {p : f $== g} {a' : DA a} {b' : DA b} (f' : DHom f a' b') (g' : DHom g a' b'), DHom p f' g' -> DHom (fmap2 F p) (dfmap F F' f') (dfmap F F' g'); dfmap_id : forall {a : A} (a' : DA a), DHom (fmap_id F a) (dfmap F F' (DId a')) (DId (F' a a')); dfmap_comp : forall {a b c : A} {f : a $-> b} {g : b $-> c} {a' : DA a} {b' : DA b} {c' : DA c} (f' : DHom f a' b') (g' : DHom g b' c'), DHom (fmap_comp F f g) (dfmap F F' (g' $o' f')) (dfmap F F' g' $o' dfmap F F' f'); }. Arguments dfmap2 {A B DA _ _ _ _ _ _ _ _ DB _ _ _ _ _ _ _ _} F {_ _} F' {_ _ a b f g p a' b' f' g'} p'. Arguments dfmap_id {A B DA _ _ _ _ _ _ _ _ DB _ _ _ _ _ _ _ _} F {_ _} F' {_ _ a} a'. Arguments dfmap_comp {A B DA _ _ _ _ _ _ _ _ DB _ _ _ _ _ _ _ _} F {_ _} F' {_ _ a b c f g a' b' c'} f' g'. Global Instance is1functor_total {A B : Type} (DA : A -> Type) (DB : B -> Type) (F : A -> B) (F' : forall (a : A), DA a -> DB (F a)) `{IsD1Functor A B DA DB F F'} : Is1Functor (functor_sigma F F'). Proof. srapply Build_Is1Functor. - intros [a a'] [b b'] [f f'] [g g'] [p p']. exists (fmap2 F p). exact (dfmap2 F F' p'). - intros [a a']. exact (fmap_id F a; dfmap_id F F' a'). - intros [a a'] [b b'] [c c'] [f f'] [g g']. exact (fmap_comp F f g; dfmap_comp F F' f' g'). Defined. Section IdentityFunctor. Global Instance isd0functor_idmap {A : Type} `{Is01Cat A} (DA : A -> Type) `{!IsDGraph DA, !IsD01Cat DA} : IsD0Functor (idmap) (fun a a' => a'). Proof. intros a b f a' b' f'. assumption. Defined. Global Instance isd1functor_idmap {A : Type} (DA : A -> Type) `{IsD1Cat A DA} : IsD1Functor (idmap) (fun a a' => a'). Proof. apply Build_IsD1Functor. - intros a b f g p a' b' f' g' p'. assumption. - intros a a'. apply DId. - intros a b c f g a' b' c' f' g'. apply DId. Defined. End IdentityFunctor. Section ConstantFunctor. Global Instance isd0functor_const {A : Type} `{IsGraph A} {B : Type} `{Is01Cat B} (DA : A -> Type) `{!IsDGraph DA} (DB : B -> Type) `{!IsDGraph DB, !IsD01Cat DB} (x : B) (x' : DB x) : IsD0Functor (fun _ : A => x) (fun _ _ => x'). Proof. intros a b f a' b' f'. apply DId. Defined. Global Instance isd1functor_const {A : Type} {B : Type} (DA : A -> Type) `{IsD1Cat A DA} (DB : B -> Type) `{IsD1Cat B DB} (x : B) (x' : DB x) : IsD1Functor (fun _ => x) (fun _ _ => x'). Proof. snrapply Build_IsD1Functor. - intros a b f g p a' b' f' g' p'. apply DId. - intros a a'. apply DId. - intros a b c f g a' b' c' f' g'. apply dgpd_rev. apply dcat_idl. Defined. End ConstantFunctor. Section CompositeFunctor. Context {A B C : Type} {DA : A -> Type} {DB : B -> Type} {DC : C -> Type} (F : A -> B) (G : B -> C) (F' : forall (a : A), DA a -> DB (F a)) (G' : forall (b : B), DB b -> DC (G b)). Global Instance isd0functor_compose `{IsDGraph A DA} `{IsDGraph B DB} `{IsDGraph C DC} `{!Is0Functor F} `{!Is0Functor G} `{!IsD0Functor F F'} `{!IsD0Functor G G'} : IsD0Functor (G o F) (fun a a' => (G' (F a) o (F' a)) a'). Proof. intros a b f a' b' f'. exact (dfmap G G' (dfmap F F' f')). Defined. Global Instance isd1functor_compose `{IsD1Cat A DA} `{IsD1Cat B DB} `{IsD1Cat C DC} `{!Is0Functor F, !Is1Functor F} `{!Is0Functor G, !Is1Functor G} `{!IsD0Functor F F', !IsD1Functor F F'} `{!IsD0Functor G G', !IsD1Functor G G'} : IsD1Functor (G o F) (fun a a' => (G' (F a) o (F' a)) a'). Proof. snrapply Build_IsD1Functor. - intros a b f g p a' b' f' g' p'. apply (dfmap2 _ _ (dfmap2 F F' p')). - intros a a'. apply (dfmap2 _ _ (dfmap_id F F' a') $@' dfmap_id G G' _). - intros a b c f g a' b' c' f' g'. apply (dfmap2 _ _ (dfmap_comp F F' f' g') $@' dfmap_comp G G' _ _). Defined. End CompositeFunctor. Local Definition pointwise_prod {A B : Type} (DA : A -> Type) (DB : B -> Type) (x : A * B) := DA (fst x) * DB (snd x). Global Instance isdgraph_prod {A B : Type} (DA : A -> Type) `{IsDGraph A DA} (DB : B -> Type) `{IsDGraph B DB} : IsDGraph (pointwise_prod DA DB). Proof. intros [a1 b1] [a2 b2] [f g] [a1' b1'] [a2' b2']. exact (DHom f a1' a2' * DHom g b1' b2'). Defined. Global Instance isd01cat_prod {A B : Type} (DA : A -> Type) `{IsD01Cat A DA} (DB : B -> Type) `{IsD01Cat B DB} : IsD01Cat (pointwise_prod DA DB). Proof. srapply Build_IsD01Cat. - intros [a b] [a' b']. exact (DId a', DId b'). - intros [a1 b1] [a2 b2] [a3 b3] [f2 g2] [f1 g1] [a1' b1'] [a2' b2'] [a3' b3']. intros [f2' g2'] [f1' g1']. exact (f2' $o' f1', g2' $o' g1'). Defined. Global Instance isd0gpd_prod {A B : Type} (DA : A -> Type) `{IsD0Gpd A DA} (DB : B -> Type) `{IsD0Gpd B DB} : IsD0Gpd (pointwise_prod DA DB). Proof. intros [a1 b1] [a2 b2] [f g] [a1' b1'] [a2' b2'] [f' g']. exact (f'^$', g'^$'). Defined. Global Instance isd2graph_prod {A B : Type} (DA : A -> Type) `{IsD2Graph A DA} (DB : B -> Type) `{IsD2Graph B DB} : IsD2Graph (pointwise_prod DA DB). Proof. intros [a1 b1] [a2 b2] [a1' b1'] [a2' b2']. srapply isdgraph_prod. Defined. Global Instance isd1cat_prod {A B : Type} (DA : A -> Type) `{IsD1Cat A DA} (DB : B -> Type) `{IsD1Cat B DB} : IsD1Cat (pointwise_prod DA DB). Proof. snrapply Build_IsD1Cat. - intros ab1 ab2 ab1' ab2'. srapply isd01cat_prod. - intros ab1 ab2 ab1' ab2'. srapply (isd0gpd_prod _ _). - intros ab1 ab2 ab3 fg ab1' ab2' ab3' [f' g']. intros hk1 hk2 pq hk1' hk2' [p' q']. exact (f' $@L' p', g' $@L' q'). - intros ab1 ab2 ab3 fg ab1' ab2' ab3' [f' g']. intros hk1 hk2 pq hk1' hk2' [p' q']. exact (p' $@R' f', q' $@R' g'). - intros ab1 ab2 ab3 ab4 fg1 fg2 fg3. intros ab1' ab2' ab3' ab4' [f1' g1'] [f2' g2'] [f3' g3']. exact (dcat_assoc f1' f2' f3', dcat_assoc g1' g2' g3'). - intros ab1 ab2 ab3 ab4 fg1 fg2 fg3. intros ab1' ab2' ab3' ab4' [f1' g1'] [f2' g2'] [f3' g3']. exact (dcat_assoc_opp f1' f2' f3', dcat_assoc_opp g1' g2' g3'). - intros ab1 ab2 fg ab1' ab2' [f' g']. exact (dcat_idl f', dcat_idl g'). - intros ab1 ab2 fg ab1' ab2' [f' g']. exact (dcat_idr f', dcat_idr g'). Defined. Coq-HoTT-9.0/theories/WildCat/DisplayedEquiv.v000066400000000000000000000552661474641544500212440ustar00rootroot00000000000000Require Import Basics.Overture. Require Import Basics.Tactics. Require Import Basics.Equivalences. Require Import Types.Sigma. Require Import WildCat.Core. Require Import WildCat.Displayed. Require Import WildCat.Equiv. (** Equivalences in displayed wild categories *) Class DHasEquivs {A : Type} `{HasEquivs A} (D : A -> Type) `{!IsDGraph D, !IsD2Graph D, !IsD01Cat D, !IsD1Cat D} := { DCatEquiv : forall {a b}, (a $<~> b) -> D a -> D b -> Type; DCatIsEquiv : forall {a b} {f : a $-> b} {fe : CatIsEquiv f} {a'} {b'}, DHom f a' b' -> Type; dcate_fun : forall {a b} {f : a $<~> b} {a'} {b'}, DCatEquiv f a' b' -> DHom f a' b'; dcate_isequiv : forall {a b} {f : a $<~> b} {a'} {b'} (f' : DCatEquiv f a' b'), DCatIsEquiv (dcate_fun f'); dcate_buildequiv : forall {a b} {f : a $-> b} `{!CatIsEquiv f} {a'} {b'} (f' : DHom f a' b') {fe' : DCatIsEquiv f'}, DCatEquiv (Build_CatEquiv f) a' b'; dcate_buildequiv_fun : forall {a b} {f : a $-> b} `{!CatIsEquiv f} {a'} {b'} (f' : DHom f a' b') {fe' : DCatIsEquiv f'}, DGpdHom (cate_buildequiv_fun f) (dcate_fun (dcate_buildequiv f' (fe':=fe'))) f'; dcate_inv' : forall {a b} {f : a $<~> b} {a'} {b'} (f' : DCatEquiv f a' b'), DHom (cate_inv' _ _ f) b' a'; dcate_issect' : forall {a b} {f : a $<~> b} {a'} {b'} (f' : DCatEquiv f a' b'), DGpdHom (cate_issect' _ _ f) (dcate_inv' f' $o' dcate_fun f') (DId a'); dcate_isretr' : forall {a b} {f : a $<~> b} {a'} {b'} (f' : DCatEquiv f a' b'), DGpdHom (cate_isretr' _ _ f) (dcate_fun f' $o' dcate_inv' f') (DId b'); dcatie_adjointify : forall {a b} {f : a $-> b} {g : b $-> a} {r : f $o g $== Id b} {s : g $o f $== Id a} {a'} {b'} (f' : DHom f a' b') (g' : DHom g b' a') (r' : DGpdHom r (f' $o' g') (DId b')) (s' : DGpdHom s (g' $o' f') (DId a')), @DCatIsEquiv _ _ _ (catie_adjointify f g r s) _ _ f'; }. (** Being an equivalence is a typeclass. *) Existing Class DCatIsEquiv. Global Existing Instance dcate_isequiv. Coercion dcate_fun : DCatEquiv >-> DHom. Definition Build_DCatEquiv {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $-> b} `{!CatIsEquiv f} {a' : D a} {b' : D b} (f' : DHom f a' b') {fe' : DCatIsEquiv f'} : DCatEquiv (Build_CatEquiv f) a' b' := dcate_buildequiv f' (fe':=fe'). (** Construct [DCatEquiv] via adjointify. *) Definition dcate_adjointify {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $-> b} {g : b $-> a} {r : f $o g $== Id b} {s : g $o f $== Id a} {a'} {b'} (f' : DHom f a' b') (g' : DHom g b' a') (r' : DHom r (f' $o' g') (DId b')) (s' : DHom s (g' $o' f') (DId a')) : DCatEquiv (cate_adjointify f g r s) a' b' := Build_DCatEquiv f' (fe':=dcatie_adjointify f' g' r' s'). (** Construct the entire inverse equivalence *) Definition dcate_inv {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $<~> b} {a' : D a} {b' : D b} (f' : DCatEquiv f a' b') : DCatEquiv (f^-1$) b' a'. Proof. snrapply dcate_adjointify. - exact (dcate_inv' f'). - exact f'. - exact (dcate_issect' f'). - exact (dcate_isretr' f'). Defined. Notation "f ^-1$'" := (dcate_inv f). (** Witness that [f'] is a section of [dcate_inv f'] in addition to [dcate_inv' f']. *) Definition dcate_issect {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $<~> b} {a' : D a} {b' : D b} (f' : DCatEquiv f a' b') : DGpdHom (cate_issect f) (dcate_fun f'^-1$' $o' f') (DId a'). Proof. refine (_ $@' dcate_issect' f'). refine (_ $@R' (dcate_fun f')). apply dcate_buildequiv_fun. Defined. (** Witness that [f'] is a retraction of [dcate_inv f'] in addition to [dcate_inv' f']. *) Definition dcate_isretr {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $<~> b} {a' : D a} {b' : D b} (f' : DCatEquiv f a' b') : DGpdHom (cate_isretr f) (dcate_fun f' $o' f'^-1$') (DId b'). Proof. refine (_ $@' dcate_isretr' f'). refine (dcate_fun f' $@L' _). apply dcate_buildequiv_fun. Defined. (** If [g'] is a section of an equivalence, then it is the inverse. *) Definition dcate_inverse_sect {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $<~> b} {g : b $-> a} {p : f $o g $== Id b} {a' : D a} {b' : D b} (f' : DCatEquiv f a' b') (g' : DHom g b' a') (p' : DGpdHom p (dcate_fun f' $o' g') (DId b')) : DGpdHom (cate_inverse_sect f g p) (dcate_fun f'^-1$') g'. Proof. refine ((dcat_idr _)^$' $@' _). refine ((_ $@L' p'^$') $@' _). 1: exact isd0gpd_hom. refine (dcat_assoc_opp _ _ _ $@' _). refine (dcate_issect f' $@R' _ $@' _). apply dcat_idl. Defined. (** If [g'] is a retraction of an equivalence, then it is the inverse. *) Definition dcate_inverse_retr {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $<~> b} {g : b $-> a} {p : g $o f $== Id a} {a' : D a} {b' : D b} (f' : DCatEquiv f a' b') (g' : DHom g b' a') (p' : DGpdHom p (g' $o' f') (DId a')) : DGpdHom (cate_inverse_retr f g p) (dcate_fun f'^-1$') g'. Proof. refine ((dcat_idl _)^$' $@' _). refine ((p'^$' $@R' _) $@' _). 1: exact isd0gpd_hom. refine (dcat_assoc _ _ _ $@' _). refine (_ $@L' dcate_isretr f' $@' _). apply dcat_idr. Defined. (** It follows that the inverse of the equivalence you get by adjointification is homotopic to the inverse [g'] provided. *) Definition dcate_inv_adjointify {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $-> b} {g : b $-> a} {r : f $o g $== Id b} {s : g $o f $== Id a} {a' : D a} {b' : D b} (f' : DHom f a' b') (g' : DHom g b' a') (r' : DGpdHom r (f' $o' g') (DId b')) (s' : DGpdHom s (g' $o' f') (DId a')) : DGpdHom (cate_inv_adjointify f g r s) (dcate_fun (dcate_adjointify f' g' r' s')^-1$') g'. Proof. apply dcate_inverse_sect. exact ((dcate_buildequiv_fun f' $@R' _) $@' r'). Defined. (** If the base category has equivalences and the displayed category has displayed equivalences, then the total category has equivalences. *) Global Instance hasequivs_total {A} (D : A -> Type) `{DHasEquivs A D} : HasEquivs (sig D). Proof. snrapply Build_HasEquivs. 1:{ intros [a a'] [b b']. exact {f : a $<~> b & DCatEquiv f a' b'}. } all: intros aa' bb' [f f']. - exact {fe : CatIsEquiv f & DCatIsEquiv f'}. - exists f. exact f'. - exact (cate_isequiv f; dcate_isequiv f'). - intros [fe fe']. exact (Build_CatEquiv f (fe:=fe); Build_DCatEquiv f' (fe':=fe')). - intros ?; exists (cate_buildequiv_fun f). exact (dcate_buildequiv_fun f'). - exists (f^-1$). exact (f'^-1$'). - exact (cate_issect f; dcate_issect f'). - exact (cate_isretr f; dcate_isretr f'). - intros [g g'] [r r'] [s s']. exact (catie_adjointify f g r s; dcatie_adjointify f' g' r' s'). Defined. (** The identity morphism is an equivalence *) Global Instance dcatie_id {A} {D : A -> Type} `{DHasEquivs A D} {a : A} (a' : D a) : DCatIsEquiv (DId a') := dcatie_adjointify (DId a') (DId a') (dcat_idl (DId a')) (dcat_idr (DId a')). Definition did_cate {A} {D : A -> Type} `{DHasEquivs A D} {a : A} (a' : D a) : DCatEquiv (id_cate a) a' a' := Build_DCatEquiv (DId a'). Global Instance reflexive_dcate {A} {D : A -> Type} `{DHasEquivs A D} {a : A} : Reflexive (DCatEquiv (id_cate a)) := did_cate. (** Anything homotopic to an equivalence is an equivalence. This should not be an instance. *) Definition dcatie_homotopic {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $-> b} `{!CatIsEquiv f} {g : a $-> b} {p : f $== g} {a' : D a} {b' : D b} (f' : DHom f a' b') `{fe' : !DCatIsEquiv f'} {g' : DHom g a' b'} (p' : DGpdHom p f' g') : DCatIsEquiv (fe:=catie_homotopic f p) g'. Proof. snrapply dcatie_adjointify. - exact (Build_DCatEquiv (fe':=fe') f')^-1$'. - refine (p'^$' $@R' _ $@' _). 1: exact isd0gpd_hom. refine ((dcate_buildequiv_fun f')^$' $@R' _ $@' _). 1: exact isd0gpd_hom. apply dcate_isretr. - refine (_ $@L' p'^$' $@' _). 1: exact isd0gpd_hom. refine (_ $@L' (dcate_buildequiv_fun f')^$' $@' _). 1: exact isd0gpd_hom. apply dcate_issect. Defined. (** Equivalences can be composed. *) Global Instance dcompose_catie {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {g : b $<~> c} {f : a $<~> b} {a' : D a} {b' : D b} {c' : D c} (g' : DCatEquiv g b' c') (f' : DCatEquiv f a' b') : DCatIsEquiv (dcate_fun g' $o' f'). Proof. snrapply dcatie_adjointify. - exact (dcate_fun f'^-1$' $o' g'^-1$'). - refine (dcat_assoc _ _ _ $@' _). refine (_ $@L' dcat_assoc_opp _ _ _ $@' _). refine (_ $@L' (dcate_isretr _ $@R' _) $@' _). refine (_ $@L' dcat_idl _ $@' _). apply dcate_isretr. - refine (dcat_assoc_opp _ _ _ $@' _). refine (dcat_assoc _ _ _ $@R' _ $@' _). refine (((_ $@L' dcate_issect _) $@R' _) $@' _). refine ((dcat_idr _ $@R' _) $@' _). apply dcate_issect. Defined. Global Instance dcompose_catie' {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {g : b $-> c} `{!CatIsEquiv g} {f : a $-> b} `{!CatIsEquiv f} {a' : D a} {b' : D b} {c' : D c} (g' : DHom g b' c') `{ge' : !DCatIsEquiv g'} (f' : DHom f a' b') `{fe' : !DCatIsEquiv f'} : DCatIsEquiv (fe:=compose_catie' g f) (g' $o' f'). Proof. pose (ff:=Build_DCatEquiv (fe':=fe') f'). pose (gg:=Build_DCatEquiv (fe':=ge') g'). nrefine (dcatie_homotopic (fe':=dcompose_catie gg ff) _ _). exact (dcate_buildequiv_fun _ $@@' dcate_buildequiv_fun _). Defined. Definition dcompose_cate {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {g : b $<~> c} {f : a $<~> b} {a' : D a} {b' : D b} {c' : D c} (g' : DCatEquiv g b' c') (f' : DCatEquiv f a' b') : DCatEquiv (compose_cate g f) a' c' := Build_DCatEquiv (dcate_fun g' $o' f'). Notation "g $oE' f" := (dcompose_cate g f). (** Composing equivalences commutes with composing the underlying maps. *) Definition dcompose_cate_fun {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {g : b $<~> c} {f : a $<~> b} {a' : D a} {b' : D b} {c' : D c} (g' : DCatEquiv g b' c') (f' : DCatEquiv f a' b') : DGpdHom (compose_cate_fun g f) (dcate_fun (g' $oE' f')) (dcate_fun g' $o' f') := dcate_buildequiv_fun _. Definition dcompose_cate_funinv {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {g : b $<~> c} {f : a $<~> b} {a' : D a} {b' : D b} {c' : D c} (g' : DCatEquiv g b' c') (f' : DCatEquiv f a' b') : DGpdHom (compose_cate_funinv g f) (dcate_fun g' $o' f') (dcate_fun (g' $oE' f')). Proof. apply dgpd_rev. apply dcate_buildequiv_fun. Defined. (** The underlying map of the identity equivalence is homotopic to the identity. *) Definition did_cate_fun {A} {D : A -> Type} `{DHasEquivs A D} {a : A} (a' : D a) : DGpdHom (id_cate_fun a) (dcate_fun (did_cate a')) (DId a') := dcate_buildequiv_fun _. (** Composition of equivalences is associative. *) Definition dcompose_cate_assoc {A} {D : A -> Type} `{DHasEquivs A D} {a b c d : A} {f : a $<~> b} {g : b $<~> c} {h : c $<~> d} {a'} {b'} {c'} {d'} (f' : DCatEquiv f a' b') (g' : DCatEquiv g b' c') (h' : DCatEquiv h c' d') : DGpdHom (compose_cate_assoc f g h) (dcate_fun ((h' $oE' g') $oE' f')) (dcate_fun (h' $oE' (g' $oE' f'))). Proof. refine (dcompose_cate_fun _ f' $@' _ $@' dcat_assoc (dcate_fun f') g' h' $@' _ $@' dcompose_cate_funinv h' _). - apply (dcompose_cate_fun h' g' $@R' _). - apply (_ $@L' dcompose_cate_funinv g' f'). Defined. Definition dcompose_cate_idl {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $<~> b} {a' : D a} {b' : D b} (f' : DCatEquiv f a' b') : DGpdHom (compose_cate_idl f) (dcate_fun (did_cate b' $oE' f')) (dcate_fun f'). Proof. refine (dcompose_cate_fun _ f' $@' _ $@' dcat_idl (dcate_fun f')). apply (dcate_buildequiv_fun _ $@R' _). Defined. Definition dcompose_cate_idr {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {f : a $<~> b} {a' : D a} {b' : D b} (f' : DCatEquiv f a' b') : DGpdHom (compose_cate_idr f) (dcate_fun (f' $oE' did_cate a')) (dcate_fun f'). Proof. refine (dcompose_cate_fun f' _ $@' _ $@' dcat_idr (dcate_fun f')). rapply (_ $@L' dcate_buildequiv_fun _). Defined. (** Some more convenient equalities for equivalences. The naming scheme is similar to [PathGroupoids.v].*) Definition dcompose_V_hh {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {f : b $<~> c} {g : a $-> b} {a' : D a} {b' : D b} {c' : D c} (f' : DCatEquiv f b' c') (g' : DHom g a' b') : DGpdHom (compose_V_hh f g) (dcate_fun f'^-1$' $o' (dcate_fun f' $o' g')) g' := (dcat_assoc_opp _ _ _) $@' (dcate_issect f' $@R' g') $@' dcat_idl g'. Definition dcompose_h_Vh {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {f : c $<~> b} {g : a $-> b} {a' : D a} {b' : D b} {c' : D c} (f' : DCatEquiv f c' b') (g' : DHom g a' b') : DGpdHom (compose_h_Vh f g) (dcate_fun f' $o' (dcate_fun f'^-1$' $o' g')) g' := (dcat_assoc_opp _ _ _) $@' (dcate_isretr f' $@R' g') $@' dcat_idl g'. Definition dcompose_hh_V {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {f : b $-> c} {g : a $<~> b} {a' : D a} {b' : D b} {c' : D c} (f' : DHom f b' c') (g' : DCatEquiv g a' b') : DGpdHom (compose_hh_V f g) ((f' $o' g') $o' g'^-1$') f' := dcat_assoc _ _ _ $@' (f' $@L' dcate_isretr g') $@' dcat_idr f'. Definition dcompose_hV_h {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {f : b $-> c} {g : b $<~> a} {a' : D a} {b' : D b} {c' : D c} (f' : DHom f b' c') (g' : DCatEquiv g b' a') : DGpdHom (compose_hV_h f g) ((f' $o' g'^-1$') $o' g') f' := dcat_assoc _ _ _ $@' (f' $@L' dcate_issect g') $@' dcat_idr f'. (** Equivalences are both monomorphisms and epimorphisms (but not the converse). *) Definition dcate_monic_equiv {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {e : a $<~> b} {a' : D a} {b' : D b} (e' : DCatEquiv e a' b') : DMonic (mon:=cate_monic_equiv e) (dcate_fun e'). Proof. intros c f g p c' f' g' p'. refine ((dcompose_V_hh e' _)^$' $@' _ $@' dcompose_V_hh e' _). 1: exact isd0gpd_hom. exact (_ $@L' p'). Defined. Definition dcate_epic_equiv {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {e : a $<~> b} {a' : D a} {b' : D b} (e' : DCatEquiv e a' b') : DEpic (epi:=cate_epic_equiv e) (dcate_fun e'). Proof. intros c f g p c' f' g' p'. refine ((dcompose_hh_V _ e')^$' $@' _ $@' dcompose_hh_V _ e'). 1: exact isd0gpd_hom. exact (p' $@R' _). Defined. (** Some lemmas for moving equivalences around. Naming based on EquivGroupoids.v. *) Definition dcate_moveR_eM {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {e : b $<~> a} {f : a $-> c} {g : b $-> c} {p : f $== g $o e^-1$} {a' : D a} {b' : D b} {c' : D c} (e' : DCatEquiv e b' a') (f' : DHom f a' c') (g' : DHom g b' c') (p' : DGpdHom p f' (g' $o' e'^-1$')) : DGpdHom (cate_moveR_eM e f g p) (f' $o' e') g'. Proof. apply (dcate_epic_equiv e'^-1$'). exact (dcompose_hh_V _ _ $@' p'). Defined. Definition dcate_moveR_Ve {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {e : b $<~> c} {f : a $-> c} {g : a $-> b} {p : f $== e $o g} {a' : D a} {b' : D b} {c' : D c} (e' : DCatEquiv e b' c') (f' : DHom f a' c') (g' : DHom g a' b') (p' : DGpdHom p f' (dcate_fun e' $o' g')) : DGpdHom (cate_moveR_Ve e f g p) (dcate_fun e'^-1$' $o' f') g'. Proof. apply (dcate_monic_equiv e'). exact (dcompose_h_Vh _ _ $@' p'). Defined. Definition dcate_moveL_V1 {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {e : a $<~> b} {f : b $-> a} {p : e $o f $== Id b} {a' : D a} {b' : D b} {e' : DCatEquiv e a' b'} (f' : DHom f b' a') (p' : DGpdHom p (dcate_fun e' $o' f') (DId b')) : DGpdHom (cate_moveL_V1 f p) f' (dcate_fun e'^-1$'). Proof. apply (dcate_monic_equiv e'). nrapply (p' $@' (dcate_isretr e')^$'). exact isd0gpd_hom. Defined. Definition dcate_moveL_1V {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {e : a $<~> b} {f : b $-> a} {p : f $o e $== Id a} {a' : D a} {b' : D b} {e' : DCatEquiv e a' b'} (f' : DHom f b' a') (p' : DGpdHom p (f' $o' e') (DId a')) : DGpdHom (cate_moveL_1V f p) f' (dcate_fun e'^-1$'). Proof. apply (dcate_epic_equiv e'). nrapply (p' $@' (dcate_issect e')^$'). exact isd0gpd_hom. Defined. Definition dcate_moveR_V1 {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {e : a $<~> b} {f : b $-> a} {p : Id b $== e $o f} {a' : D a} {b' : D b} {e' : DCatEquiv e a' b'} (f' : DHom f b' a') (p' : DGpdHom p (DId b') (dcate_fun e' $o' f')) : DGpdHom (cate_moveR_V1 f p) (dcate_fun e'^-1$') f'. Proof. apply (dcate_monic_equiv e'). exact (dcate_isretr e' $@' p'). Defined. Definition dcate_moveR_1V {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {e : a $<~> b} {f : b $-> a} {p : Id a $== f $o e} {a' : D a} {b' : D b} {e' : DCatEquiv e a' b'} (f' : DHom f b' a') (p' : DGpdHom p (DId a') (f' $o' e')) : DGpdHom (cate_moveR_1V f p) (dcate_fun e'^-1$') f'. Proof. apply (dcate_epic_equiv e'). exact (dcate_issect e' $@' p'). Defined. (** Lemmas about the underlying map of an equivalence. *) Definition dcate_inv2 {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {e f : a $<~> b} {p : cate_fun e $== cate_fun f} {a' : D a} {b' : D b} {e' : DCatEquiv e a' b'} {f' : DCatEquiv f a' b'} (p' : DGpdHom p (dcate_fun e') (dcate_fun f')) : DGpdHom (cate_inv2 p) (dcate_fun e'^-1$') (dcate_fun f'^-1$'). Proof. apply dcate_moveL_V1. rapply ((p'^$' $@R' _) $@' dcate_isretr _). exact isd0gpd_hom. Defined. Definition dcate_inv_compose {A} {D : A -> Type} `{DHasEquivs A D} {a b c : A} {e : a $<~> b} {f : b $<~> c} {a' : D a} {b' : D b} {c' : D c} (e' : DCatEquiv e a' b') (f' : DCatEquiv f b' c') : DGpdHom (cate_inv_compose e f) (dcate_fun (f' $oE' e')^-1$') (dcate_fun (e'^-1$' $oE' f'^-1$')). Proof. refine (_ $@' (dcompose_cate_fun e'^-1$' f'^-1$')^$'). - snrapply dcate_inv_adjointify. - exact isd0gpd_hom. Defined. Definition dcate_inv_V {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} {e : a $<~> b} {a' : D a} {b' : D b} (e' : DCatEquiv e a' b') : DGpdHom (cate_inv_V e) (dcate_fun (e'^-1$')^-1$') (dcate_fun e'). Proof. apply dcate_moveR_V1. apply dgpd_rev. apply dcate_issect. Defined. (** Any sufficiently coherent displayed functor preserves displayed equivalences. *) Global Instance diemap {A B : Type} {DA : A -> Type} `{DHasEquivs A DA} {DB : B -> Type} `{DHasEquivs B DB} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F', !IsD1Functor F F'} {a b : A} {f : a $<~> b} {a' : DA a} {b' : DA b} (f' : DCatEquiv f a' b') : DCatIsEquiv (fe:=iemap F f) (dfmap F F' (dcate_fun f')). Proof. refine (dcatie_adjointify (dfmap F F' (dcate_fun f')) (dfmap F F' (dcate_fun f'^-1$')) _ _). - refine ((dfmap_comp F F' (dcate_fun f'^-1$') f')^$' $@' _ $@' _). + exact (dfmap2 F F' (dcate_isretr _)). + exact (dfmap_id F F' _). - refine ((dfmap_comp F F' (dcate_fun f') f'^-1$')^$' $@' _ $@' _). + exact (dfmap2 F F' (dcate_issect _)). + exact (dfmap_id F F' _). Defined. Definition demap {A B : Type} {DA : A -> Type} `{DHasEquivs A DA} {DB : B -> Type} `{DHasEquivs B DB} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F', !IsD1Functor F F'} {a b : A} {f : a $<~> b} {a' : DA a} {b' : DA b} (f' : DCatEquiv f a' b') : DCatEquiv (emap F f) (F' a a') (F' b b') := Build_DCatEquiv (dfmap F F' (dcate_fun f')). Definition demap_id {A B : Type} {DA : A -> Type} `{DHasEquivs A DA} {DB : B -> Type} `{DHasEquivs B DB} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F', !IsD1Functor F F'} {a : A} {a' : DA a} : DGpdHom (emap_id F) (dcate_fun (demap F F' (did_cate a'))) (dcate_fun (did_cate (F' a a'))). Proof. refine (dcate_buildequiv_fun _ $@' _). refine (dfmap2 F F' (did_cate_fun a') $@' _ $@' _). - rapply dfmap_id. - apply dgpd_rev. exact (did_cate_fun (F' a a')). Defined. Definition demap_compose {A B : Type} {DA : A -> Type} `{DHasEquivs A DA} {DB : B -> Type} `{DHasEquivs B DB} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F', isd1f : !IsD1Functor F F'} {a b c : A} {f : a $<~> b} {g : b $<~> c} {a' : DA a} {b' : DA b} {c' : DA c} (f' : DCatEquiv f a' b') (g' : DCatEquiv g b' c') : DGpdHom (emap_compose F f g) (dcate_fun (demap F F' (g' $oE' f'))) (dfmap F F' (dcate_fun g') $o' dfmap F F' (dcate_fun f')). Proof. refine (dcate_buildequiv_fun _ $@' _). refine (dfmap2 F F' (dcompose_cate_fun _ _) $@' _). nrapply dfmap_comp; exact isd1f. Defined. (** A variant. *) Definition demap_compose' {A B : Type} {DA : A -> Type} `{DHasEquivs A DA} {DB : B -> Type} `{DHasEquivs B DB} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F', !IsD1Functor F F'} {a b c : A} {f : a $<~> b} {g : b $<~> c} {a' : DA a} {b' : DA b} {c' : DA c} (f' : DCatEquiv f a' b') (g' : DCatEquiv g b' c') : DGpdHom (emap_compose' F f g) (dcate_fun (demap F F' (g' $oE' f'))) (dcate_fun ((demap F F' g') $oE' (demap F F' f'))). Proof. refine (demap_compose F F' f' g' $@' _). apply dgpd_rev. refine (dcompose_cate_fun _ _ $@' _). exact (dcate_buildequiv_fun _ $@@' dcate_buildequiv_fun _). Defined. Definition demap_inv {A B : Type} {DA : A -> Type} `{DHasEquivs A DA} {DB : B -> Type} `{DHasEquivs B DB} (F : A -> B) `{!Is0Functor F, !Is1Functor F} (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F', !IsD1Functor F F'} {a b : A} {e : a $<~> b} {a' : DA a} {b' : DA b} (e' : DCatEquiv e a' b') : DGpdHom (emap_inv F e) (dcate_fun (demap F F' e')^-1$') (dcate_fun (demap F F' e'^-1$')). Proof. refine (dcate_inv_adjointify _ _ _ _ $@' _). apply dgpd_rev. exact (dcate_buildequiv_fun _). Defined. (** When we have equivalences, we can define what it means for a displayed category to be univalent. *) Definition dcat_equiv_path {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} (p : a = b) (a' : D a) (b' : D b) : transport D p a' = b' -> DCatEquiv (cat_equiv_path a b p) a' b'. Proof. intro p'. destruct p, p'. reflexivity. Defined. Class IsDUnivalent1Cat {A} (D : A -> Type) `{DHasEquivs A D} := { isequiv_dcat_equiv_path : forall {a b : A} (p : a = b) a' b', IsEquiv (dcat_equiv_path p a' b') }. Global Existing Instance isequiv_dcat_equiv_path. Definition dcat_path_equiv {A} {D : A -> Type} `{IsDUnivalent1Cat A D} {a b : A} (p : a = b) (a' : D a) (b' : D b) : DCatEquiv (cat_equiv_path a b p) a' b' -> transport D p a' = b' := (dcat_equiv_path p a' b')^-1. (** If [IsUnivalent1Cat A] and [IsDUnivalent1Cat D], then this is an equivalence by [isequiv_functor_sigma]. *) Definition dcat_equiv_path_total {A} {D : A -> Type} `{DHasEquivs A D} {a b : A} (a' : D a) (b' : D b) : {p : a = b & p # a' = b'} -> {e : a $<~> b & DCatEquiv e a' b'} := functor_sigma (cat_equiv_path a b) (fun p => dcat_equiv_path p a' b'). (** If the base category and the displayed category are both univalent, then the total category is univalent. *) Global Instance isunivalent1cat_total {A} `{IsUnivalent1Cat A} (D : A -> Type) `{!IsDGraph D, !IsD2Graph D, !IsD01Cat D, !IsD1Cat D, !DHasEquivs D} `{!IsDUnivalent1Cat D} : IsUnivalent1Cat (sig D). Proof. snrapply Build_IsUnivalent1Cat. intros aa' bb'. apply (isequiv_homotopic (dcat_equiv_path_total _ _ o (path_sigma_uncurried D aa' bb')^-1)). intros []; reflexivity. Defined. Coq-HoTT-9.0/theories/WildCat/EmptyCat.v000066400000000000000000000011051474641544500200210ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. (** Empty category *) Global Instance isgraph_empty : IsGraph Empty. Proof. by apply Build_IsGraph. Defined. Global Instance is01cat_empty : Is01Cat Empty. Proof. srapply Build_Is01Cat; intros []. Defined. Global Instance is0gpd_empty : Is0Gpd Empty. Proof. constructor; intros []. Defined. Global Instance is2graph_empty : Is2Graph Empty. Proof. intros f g. by apply Build_IsGraph. Defined. Global Instance is1cat_empty : Is1Cat Empty. Proof. snrapply Build_Is1Cat; intros []. Defined. Coq-HoTT-9.0/theories/WildCat/Equiv.v000066400000000000000000000565051474641544500174020ustar00rootroot00000000000000Require Import Basics.Utf8 Basics.Overture Basics.Tactics Basics.Equivalences. Require Import WildCat.Core. Require Import WildCat.Opposite. (** We declare a scope for printing [CatEquiv] as [≅] *) Declare Scope wc_iso_scope. (** * Equivalences in wild categories *) (** We could define equivalences in any wild 1-category as bi-invertible maps, or in a wild 2-category as half-adjoint equivalences. However, in concrete cases there is often an equivalent definition of equivalences that we want to use instead, and the important property we need is that it's logically equivalent to (quasi-)isomorphism. In [cat_hasequivs] below, we show that bi-invertible maps do provide a [HasEquivs] structure for any wild 1-category. *) Class HasEquivs (A : Type) `{Is1Cat A} := { CatEquiv' : A -> A -> Type where "a $<~> b" := (CatEquiv' a b); CatIsEquiv' : forall a b, (a $-> b) -> Type; cate_fun' : forall a b, (a $<~> b) -> (a $-> b); cate_isequiv' : forall a b (f : a $<~> b), CatIsEquiv' a b (cate_fun' a b f); cate_buildequiv' : forall a b (f : a $-> b), CatIsEquiv' a b f -> CatEquiv' a b; cate_buildequiv_fun' : forall a b (f : a $-> b) (fe : CatIsEquiv' a b f), cate_fun' a b (cate_buildequiv' a b f fe) $== f; cate_inv' : forall a b (f : a $<~> b), b $-> a; cate_issect' : forall a b (f : a $<~> b), cate_inv' _ _ f $o cate_fun' _ _ f $== Id a; cate_isretr' : forall a b (f : a $<~> b), cate_fun' _ _ f $o cate_inv' _ _ f $== Id b; catie_adjointify' : forall a b (f : a $-> b) (g : b $-> a) (r : f $o g $== Id b) (s : g $o f $== Id a), CatIsEquiv' a b f; }. (** Since apparently a field of a record can't be the source of a coercion (Coq complains about the uniform inheritance condition, although as officially stated that condition appears to be satisfied), we redefine all the fields of [HasEquivs]. *) Definition CatEquiv {A} `{HasEquivs A} (a b : A) := @CatEquiv' A _ _ _ _ _ a b. Notation "a $<~> b" := (CatEquiv a b). Infix "≅" := CatEquiv : wc_iso_scope. Arguments CatEquiv : simpl never. Definition cate_fun {A} `{HasEquivs A} {a b : A} (f : a $<~> b) : a $-> b := @cate_fun' A _ _ _ _ _ a b f. Coercion cate_fun : CatEquiv >-> Hom. (* Being an equivalence should be a typeclass, but we have to redefine it to work around https://github.com/coq/coq/issues/8994 . *) Class CatIsEquiv {A} `{HasEquivs A} {a b : A} (f : a $-> b) := catisequiv : CatIsEquiv' a b f. Global Instance cate_isequiv {A} `{HasEquivs A} {a b : A} (f : a $<~> b) : CatIsEquiv f := cate_isequiv' a b f. Definition Build_CatEquiv {A} `{HasEquivs A} {a b : A} (f : a $-> b) {fe : CatIsEquiv f} : a $<~> b := cate_buildequiv' a b f fe. Definition cate_buildequiv_fun {A} `{HasEquivs A} {a b : A} (f : a $-> b) {fe : CatIsEquiv f} : cate_fun (Build_CatEquiv f) $== f := cate_buildequiv_fun' a b f fe. Definition catie_adjointify {A} `{HasEquivs A} {a b : A} (f : a $-> b) (g : b $-> a) (r : f $o g $== Id b) (s : g $o f $== Id a) : CatIsEquiv f := catie_adjointify' a b f g r s. Definition cate_adjointify {A} `{HasEquivs A} {a b : A} (f : a $-> b) (g : b $-> a) (r : f $o g $== Id b) (s : g $o f $== Id a) : a $<~> b := Build_CatEquiv f (fe:=catie_adjointify f g r s). (** This one we define to construct the whole inverse equivalence. *) Definition cate_inv {A} `{HasEquivs A} {a b : A} (f : a $<~> b) : b $<~> a. Proof. simple refine (cate_adjointify _ _ _ _). - exact (cate_inv' a b f). - exact f. - exact (cate_issect' a b f). - exact (cate_isretr' a b f). Defined. Notation "f ^-1$" := (cate_inv f). (** * Opposite categories preserve having equivalences. *) Global Instance hasequivs_op {A} `{HasEquivs A} : HasEquivs A^op. Proof. snrapply Build_HasEquivs; intros a b; unfold op in a, b; cbn. - exact (b $<~> a). - apply CatIsEquiv. - apply cate_fun'. - apply cate_isequiv'. - apply cate_buildequiv'. - rapply cate_buildequiv_fun'. - apply cate_inv'. - rapply cate_isretr'. - rapply cate_issect'. - intros f g s t. exact (catie_adjointify f g t s). Defined. Global Instance isequiv_op {A : Type} `{HasEquivs A} {a b : A} (f : a $-> b) {ief : CatIsEquiv f} : @CatIsEquiv A^op _ _ _ _ _ b a f := ief. Definition cate_issect {A} `{HasEquivs A} {a b} (f : a $<~> b) : f^-1$ $o f $== Id a. Proof. refine (_ $@ cate_issect' a b f). refine (_ $@R f). apply cate_buildequiv_fun'. Defined. Definition cate_isretr {A} `{HasEquivs A} {a b} (f : a $<~> b) : f $o f^-1$ $== Id b := cate_issect (A:=A^op) (b:=a) (a:=b) f. (** If [g] is a section of an equivalence, then it is the inverse. *) Definition cate_inverse_sect {A} `{HasEquivs A} {a b} (f : a $<~> b) (g : b $-> a) (p : f $o g $== Id b) : cate_fun f^-1$ $== g. Proof. refine ((cat_idr _)^$ $@ _). refine ((_ $@L p^$) $@ _). refine (cat_assoc_opp _ _ _ $@ _). refine (cate_issect f $@R _ $@ _). apply cat_idl. Defined. (** If [g] is a retraction of an equivalence, then it is the inverse. *) Definition cate_inverse_retr {A} `{HasEquivs A} {a b} (f : a $<~> b) (g : b $-> a) (p : g $o f $== Id a) : cate_fun f^-1$ $== g := cate_inverse_sect (A:=A^op) (a:=b) (b:=a) f g p. (** It follows that the inverse of the equivalence you get by adjointification is homotopic to the inverse [g] provided. *) Definition cate_inv_adjointify {A} `{HasEquivs A} {a b : A} (f : a $-> b) (g : b $-> a) (r : f $o g $== Id b) (s : g $o f $== Id a) : cate_fun (cate_adjointify f g r s)^-1$ $== g. Proof. apply cate_inverse_sect. exact ((cate_buildequiv_fun f $@R _) $@ r). Defined. (** The identity morphism is an equivalence *) Global Instance catie_id {A} `{HasEquivs A} (a : A) : CatIsEquiv (Id a) := catie_adjointify (Id a) (Id a) (cat_idl (Id a)) (cat_idr (Id a)). Definition id_cate {A} `{HasEquivs A} (a : A) : a $<~> a := Build_CatEquiv (Id a). Global Instance reflexive_cate {A} `{HasEquivs A} : Reflexive (@CatEquiv A _ _ _ _ _) := id_cate. Global Instance symmetric_cate {A} `{HasEquivs A} : Symmetric (@CatEquiv A _ _ _ _ _) := fun a b f => cate_inv f. (** Anything homotopic to an equivalence is an equivalence. This should not be an instance. *) Definition catie_homotopic {A} `{HasEquivs A} {a b : A} (f : a $-> b) `{!CatIsEquiv f} {g : a $-> b} (p : f $== g) : CatIsEquiv g. Proof. snrapply catie_adjointify. - exact (Build_CatEquiv f)^-1$. - refine (p^$ $@R _ $@ _). refine ((cate_buildequiv_fun f)^$ $@R _ $@ _). apply cate_isretr. - refine (_ $@L p^$ $@ _). refine (_ $@L (cate_buildequiv_fun f)^$ $@ _). apply cate_issect. Defined. (** Equivalences can be composed. In order to make use of duality, we factor out parts of the proof as two lemmas. *) Definition compose_catie_isretr {A} `{HasEquivs A} {a b c : A} (g : b $<~> c) (f : a $<~> b) : g $o f $o (f^-1$ $o g^-1$) $== Id c. Proof. refine (cat_assoc _ _ _ $@ _). refine ((_ $@L cat_assoc_opp _ _ _) $@ _). refine ((_ $@L (cate_isretr _ $@R _)) $@ _). refine ((_ $@L cat_idl _) $@ _). apply cate_isretr. Defined. Definition compose_catie_issect {A} `{HasEquivs A} {a b c : A} (g : b $<~> c) (f : a $<~> b) : (f^-1$ $o g^-1$ $o (g $o f) $== Id a) := compose_catie_isretr (A:=A^op) (a:=c) (b:=b) (c:=a) f g. Global Instance compose_catie {A} `{HasEquivs A} {a b c : A} (g : b $<~> c) (f : a $<~> b) : CatIsEquiv (g $o f). Proof. refine (catie_adjointify _ (f^-1$ $o g^-1$) _ _). - apply compose_catie_isretr. - apply compose_catie_issect. Defined. Global Instance compose_catie' {A} `{HasEquivs A} {a b c : A} (g : b $-> c) `{!CatIsEquiv g} (f : a $-> b) `{!CatIsEquiv f} : CatIsEquiv (g $o f) := catie_homotopic _ (cate_buildequiv_fun _ $@@ cate_buildequiv_fun _). Definition compose_cate {A} `{HasEquivs A} {a b c : A} (g : b $<~> c) (f : a $<~> b) : a $<~> c := Build_CatEquiv (g $o f). Notation "g $oE f" := (compose_cate g f). Definition compose_cate_fun {A} `{HasEquivs A} {a b c : A} (g : b $<~> c) (f : a $<~> b) : cate_fun (g $oE f) $== g $o f. Proof. apply cate_buildequiv_fun. Defined. Definition compose_cate_funinv {A} `{HasEquivs A} {a b c : A} (g : b $<~> c) (f : a $<~> b) : g $o f $== cate_fun (g $oE f). Proof. apply gpd_rev. apply cate_buildequiv_fun. Defined. Definition id_cate_fun {A} `{HasEquivs A} (a : A) : cate_fun (id_cate a) $== Id a. Proof. apply cate_buildequiv_fun. Defined. Definition compose_cate_assoc {A} `{HasEquivs A} {a b c d : A} (f : a $<~> b) (g : b $<~> c) (h : c $<~> d) : cate_fun ((h $oE g) $oE f) $== cate_fun (h $oE (g $oE f)). Proof. refine (compose_cate_fun _ f $@ _ $@ cat_assoc f g h $@ _ $@ compose_cate_funinv h _). - refine (compose_cate_fun h g $@R _). - refine (_ $@L compose_cate_funinv g f). Defined. Definition compose_cate_assoc_opp {A} `{HasEquivs A} {a b c d : A} (f : a $<~> b) (g : b $<~> c) (h : c $<~> d) : cate_fun (h $oE (g $oE f)) $== cate_fun ((h $oE g) $oE f). Proof. Opaque compose_catie_isretr. (* We use [exact_no_check] just to save a small amount of time. *) exact_no_check (compose_cate_assoc (A:=A^op) (a:=d) (b:=c) (c:=b) (d:=a) h g f). Defined. Transparent compose_catie_isretr. Definition compose_cate_idl {A} `{HasEquivs A} {a b : A} (f : a $<~> b) : cate_fun (id_cate b $oE f) $== cate_fun f. Proof. refine (compose_cate_fun _ f $@ _ $@ cat_idl f). refine (cate_buildequiv_fun _ $@R _). Defined. Definition compose_cate_idr {A} `{HasEquivs A} {a b : A} (f : a $<~> b) : cate_fun (f $oE id_cate a) $== cate_fun f := compose_cate_idl (A:=A^op) (a:=b) (b:=a) f. Global Instance transitive_cate {A} `{HasEquivs A} : Transitive (@CatEquiv A _ _ _ _ _) := fun a b c f g => g $oE f. (** Some more convenient equalities for equivalences. The naming scheme is similar to [PathGroupoids.v].*) Definition compose_V_hh {A} `{HasEquivs A} {a b c : A} (f : b $<~> c) (g : a $-> b) : f^-1$ $o (f $o g) $== g := (cat_assoc_opp _ _ _) $@ (cate_issect f $@R g) $@ cat_idl g. Definition compose_h_Vh {A} `{HasEquivs A} {a b c : A} (f : c $<~> b) (g : a $-> b) : f $o (f^-1$ $o g) $== g := (cat_assoc_opp _ _ _) $@ (cate_isretr f $@R g) $@ cat_idl g. Definition compose_hh_V {A} `{HasEquivs A} {a b c : A} (f : b $-> c) (g : a $<~> b) : (f $o g) $o g^-1$ $== f := cat_assoc _ _ _ $@ (f $@L cate_isretr g) $@ cat_idr f. Definition compose_hV_h {A} `{HasEquivs A} {a b c : A} (f : b $-> c) (g : b $<~> a) : (f $o g^-1$) $o g $== f := cat_assoc _ _ _ $@ (f $@L cate_issect g) $@ cat_idr f. (** Equivalences are both monomorphisms and epimorphisms (but not the converse). *) Definition cate_monic_equiv {A} `{HasEquivs A} {a b : A} (e : a $<~> b) : Monic e. Proof. intros c f g p. refine ((compose_V_hh e _)^$ $@ _ $@ compose_V_hh e _). exact (_ $@L p). Defined. Definition cate_epic_equiv {A} `{HasEquivs A} {a b : A} (e : a $<~> b) : Epic e := cate_monic_equiv (A:=A^op) (a:=b) (b:=a) e. (** ** Movement Lemmas *) (** These lemmas can be used to move equivalences around in an equation. *) Definition cate_moveL_eM {A} `{HasEquivs A} {a b c : A} (e : a $<~> b) (f : a $-> c) (g : b $-> c) (p : f $o e^-1$ $== g) : f $== g $o e. Proof. apply (cate_epic_equiv e^-1$). exact (p $@ (compose_hh_V _ _)^$). Defined. Definition cate_moveR_eM {A} `{HasEquivs A} {a b c : A} (e : b $<~> a) (f : a $-> c) (g : b $-> c) (p : f $== g $o e^-1$) : f $o e $== g. Proof. apply (cate_epic_equiv e^-1$). exact (compose_hh_V _ _ $@ p). Defined. Definition cate_moveL_Me {A} `{HasEquivs A} {a b c : A} (e : b $<~> c) (f : a $-> c) (g : a $-> b) (p : e^-1$ $o f $== g) : f $== e $o g := cate_moveL_eM (A:=A^op) (a:=c) (b:=b) (c:=a) e f g p. Definition cate_moveR_Me {A} `{HasEquivs A} {a b c : A} (e : c $<~> b) (f : a $-> c) (g : a $-> b) (p : f $== e^-1$ $o g) : e $o f $== g := cate_moveR_eM (A:=A^op) (a:=c) (b:=b) (c:=a) e f g p. Definition cate_moveL_eV {A} `{HasEquivs A} {a b c : A} (e : a $<~> b) (f : b $-> c) (g : a $-> c) (p : f $o e $== g) : f $== g $o e^-1$. Proof. apply (cate_epic_equiv e). exact (p $@ (compose_hV_h _ _)^$). Defined. Definition cate_moveR_eV {A} `{HasEquivs A} {a b c : A} (e : b $<~> a) (f : b $-> c) (g : a $-> c) (p : f $== g $o e) : f $o e^-1$ $== g. Proof. apply (cate_epic_equiv e). exact (compose_hV_h _ _ $@ p). Defined. Definition cate_moveL_Ve {A} `{HasEquivs A} {a b c : A} (e : b $<~> c) (f : a $-> b) (g : a $-> c) (p : e $o f $== g) : f $== e^-1$ $o g := cate_moveL_eV (A:=A^op) (a:=c) (b:=b) (c:=a) e f g p. Definition cate_moveR_Ve {A} `{HasEquivs A} {a b c : A} (e : b $<~> c) (f : a $-> c) (g : a $-> b) (p : f $== e $o g) : e^-1$ $o f $== g := cate_moveR_eV (A:=A^op) (a:=b) (b:=c) (c:=a) e f g p. Definition cate_moveL_V1 {A} `{HasEquivs A} {a b : A} {e : a $<~> b} (f : b $-> a) (p : e $o f $== Id _) : f $== cate_fun e^-1$. Proof. apply (cate_monic_equiv e). exact (p $@ (cate_isretr e)^$). Defined. Definition cate_moveL_1V {A} `{HasEquivs A} {a b : A} {e : a $<~> b} (f : b $-> a) (p : f $o e $== Id _) : f $== cate_fun e^-1$ := cate_moveL_V1 (A:=A^op) (a:=b) (b:=a) f p. Definition cate_moveR_V1 {A} `{HasEquivs A} {a b : A} {e : a $<~> b} (f : b $-> a) (p : Id _ $== e $o f) : cate_fun e^-1$ $== f. Proof. apply (cate_monic_equiv e). exact (cate_isretr e $@ p). Defined. Definition cate_moveR_1V {A} `{HasEquivs A} {a b : A} {e : a $<~> b} (f : b $-> a) (p : Id _ $== f $o e) : cate_fun e^-1$ $== f := cate_moveR_V1 (A:=A^op) (a:=b) (b:=a) f p. (** Lemmas about the underlying map of an equivalence. *) Definition cate_inv2 {A} `{HasEquivs A} {a b : A} {e f : a $<~> b} (p : cate_fun e $== cate_fun f) : cate_fun e^-1$ $== cate_fun f^-1$. Proof. apply cate_moveL_V1. exact ((p^$ $@R _) $@ cate_isretr _). Defined. Definition cate_inv_compose {A} `{HasEquivs A} {a b c : A} (e : a $<~> b) (f : b $<~> c) : cate_fun (f $oE e)^-1$ $== cate_fun (e^-1$ $oE f^-1$). Proof. refine (_ $@ (compose_cate_fun _ _)^$). apply cate_inv_adjointify. Defined. Definition cate_inv_compose' {A} `{HasEquivs A} {a b c : A} (e : a $<~> b) (f : b $<~> c) : cate_fun (f $oE e)^-1$ $== e^-1$ $o f^-1$. Proof. nrefine (_ $@ cate_buildequiv_fun _). nrapply cate_inv_compose. Defined. Definition cate_inv_V {A} `{HasEquivs A} {a b : A} (e : a $<~> b) : cate_fun (e^-1$)^-1$ $== cate_fun e. Proof. apply cate_moveR_V1. symmetry; apply cate_issect. Defined. (** Any sufficiently coherent functor preserves equivalences. *) Global Instance iemap {A B : Type} `{HasEquivs A} `{HasEquivs B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a b : A} (f : a $<~> b) : CatIsEquiv (fmap F f). Proof. refine (catie_adjointify (fmap F f) (fmap F f^-1$) _ _). - refine ((fmap_comp F f^-1$ f)^$ $@ fmap2 F (cate_isretr _) $@ fmap_id F _). - refine ((fmap_comp F f f^-1$)^$ $@ fmap2 F (cate_issect _) $@ fmap_id F _). Defined. Definition emap {A B : Type} `{HasEquivs A} `{HasEquivs B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a b : A} (f : a $<~> b) : F a $<~> F b := Build_CatEquiv (fmap F f). Definition emap_id {A B : Type} `{HasEquivs A} `{HasEquivs B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a : A} : cate_fun (emap F (id_cate a)) $== cate_fun (id_cate (F a)). Proof. refine (cate_buildequiv_fun _ $@ _). refine (fmap2 F (id_cate_fun a) $@ _ $@ (id_cate_fun (F a))^$). rapply fmap_id. Defined. Definition emap_compose {A B : Type} `{HasEquivs A} `{HasEquivs B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a b c : A} (f : a $<~> b) (g : b $<~> c) : cate_fun (emap F (g $oE f)) $== fmap F (cate_fun g) $o fmap F (cate_fun f). Proof. refine (cate_buildequiv_fun _ $@ _). refine (fmap2 F (compose_cate_fun _ _) $@ _). rapply fmap_comp. Defined. (** A variant. *) Definition emap_compose' {A B : Type} `{HasEquivs A} `{HasEquivs B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a b c : A} (f : a $<~> b) (g : b $<~> c) : cate_fun (emap F (g $oE f)) $== cate_fun ((emap F g) $oE (emap F f)). Proof. refine (emap_compose F f g $@ _). symmetry. refine (compose_cate_fun _ _ $@ _). exact (cate_buildequiv_fun _ $@@ cate_buildequiv_fun _). Defined. Definition emap_inv {A B : Type} `{HasEquivs A} `{HasEquivs B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a b : A} (e : a $<~> b) : cate_fun (emap F e)^-1$ $== cate_fun (emap F e^-1$). Proof. refine (cate_inv_adjointify _ _ _ _ $@ _). exact (cate_buildequiv_fun _)^$. Defined. Definition emap_inv' {A B : Type} `{HasEquivs A} `{HasEquivs B} (F : A -> B) `{!Is0Functor F, !Is1Functor F} {a b : A} (e : a $<~> b) : cate_fun (emap F e)^-1$ $== fmap F e^-1$ := emap_inv F e $@ cate_buildequiv_fun _. (** When we have equivalences, we can define what it means for a category to be univalent. *) Definition cat_equiv_path {A : Type} `{HasEquivs A} (a b : A) : (a = b) -> (a $<~> b). Proof. intros []; reflexivity. Defined. Class IsUnivalent1Cat (A : Type) `{HasEquivs A} := { isequiv_cat_equiv_path : forall a b, IsEquiv (@cat_equiv_path A _ _ _ _ _ a b) }. Global Existing Instance isequiv_cat_equiv_path. Definition cat_path_equiv {A : Type} `{IsUnivalent1Cat A} (a b : A) : (a $<~> b) -> (a = b) := (cat_equiv_path a b)^-1. (** ** Core of a 1-category *) Record core (A : Type) := { uncore : A }. Arguments uncore {A} c. Arguments Build_core {A} a : rename. Global Instance isgraph_core {A : Type} `{HasEquivs A} : IsGraph (core A). Proof. srapply Build_IsGraph. intros a b ; exact (uncore a $<~> uncore b). Defined. Global Instance is01cat_core {A : Type} `{HasEquivs A} : Is01Cat (core A). Proof. srapply Build_Is01Cat ; cbv. - intros; apply id_cate. - intros a b c ; apply compose_cate. Defined. Global Instance is2graph_core {A : Type} `{HasEquivs A} : Is2Graph (core A). Proof. intros a b. apply Build_IsGraph. intros f g ; exact (cate_fun f $== cate_fun g). Defined. Global Instance is01cat_core_hom {A : Type} `{HasEquivs A} (a b : core A) : Is01Cat (a $-> b). Proof. srapply Build_Is01Cat. - intro f; cbn; apply Id. - intros f g h; cbn; apply cat_comp. Defined. Global Instance is0gpd_core_hom {A : Type} `{HasEquivs A} (a b : core A) : Is0Gpd (a $-> b). Proof. apply Build_Is0Gpd. intros f g ; cbv. apply gpd_rev. Defined. Global Instance is0functor_core_postcomp {A : Type} `{HasEquivs A} (a b c : core A) (h : b $-> c) : Is0Functor (cat_postcomp a h). Proof. apply Build_Is0Functor. intros f g al; cbn in h. exact (compose_cate_fun h f $@ (h $@L al) $@ (compose_cate_fun h g)^$). Defined. Global Instance is0functor_core_precomp {A : Type} `{HasEquivs A} (a b c : core A) (h : a $-> b) : Is0Functor (cat_precomp c h). Proof. apply Build_Is0Functor. intros f g al; cbn in h. (** Why can't coq resolve this? *) refine (compose_cate_fun f h $@ (_ $@R h) $@ (compose_cate_fun g h)^$). exact al. Defined. Global Instance is1cat_core {A : Type} `{HasEquivs A} : Is1Cat (core A). Proof. rapply Build_Is1Cat. - intros; apply compose_cate_assoc. - intros; apply compose_cate_assoc_opp. - intros; apply compose_cate_idl. - intros; apply compose_cate_idr. Defined. Global Instance is0gpd_core {A : Type} `{HasEquivs A} : Is0Gpd (core A). Proof. apply Build_Is0Gpd. intros a b f; cbn in *; exact (f^-1$). Defined. Global Instance is1gpd_core {A : Type} `{HasEquivs A} : Is1Gpd (core A). Proof. apply Build_Is1Gpd; cbn ; intros a b f; refine (compose_cate_fun _ _ $@ _ $@ (id_cate_fun _)^$). - apply cate_issect. - apply cate_isretr. Defined. Global Instance hasequivs_core {A : Type} `{HasEquivs A} : HasEquivs (core A). Proof. srapply Build_HasEquivs. 1: exact (fun a b => a $-> b). (* In [core A], i.e. [CatEquiv' (uncore a) (uncore b)]. *) all: intros a b f; cbn; intros. - exact Unit. (* Or [CatIsEquiv' (uncore a) (uncore b) (cate_fun f)]? *) - exact f. - exact tt. (* Or [cate_isequiv' _ _ _]? *) - exact f. - reflexivity. - exact f^-1$. - refine (compose_cate_fun _ _ $@ _). refine (cate_issect _ $@ _). symmetry; apply id_cate_fun. - refine (compose_cate_fun _ _ $@ _). refine (cate_isretr _ $@ _). symmetry; apply id_cate_fun. - exact tt. Defined. Global Instance hasmorext_core {A : Type} `{HasEquivs A, !HasMorExt A} `{forall x y (f g : uncore x $<~> uncore y), IsEquiv (ap (x := f) (y := g) cate_fun)} : HasMorExt (core A). Proof. snrapply Build_HasMorExt. intros X Y f g; cbn in *. snrapply isequiv_homotopic. - exact (GpdHom_path o (ap (x:=f) (y:=g) cate_fun)). - rapply isequiv_compose. - intro p; by induction p. Defined. (** * Initial objects and terminal objects are all respectively equivalent. *) Lemma cate_isinitial A `{HasEquivs A} (x y : A) : IsInitial x -> IsInitial y -> x $<~> y. Proof. intros inx iny. srapply (cate_adjointify (inx y).1 (iny x).1). 1: exact (((iny _).2 _)^$ $@ (iny _).2 _). 1: exact (((inx _).2 _)^$ $@ (inx _).2 _). Defined. Definition cate_isterminal A `{HasEquivs A} (x y : A) : IsTerminal x -> IsTerminal y -> y $<~> x := cate_isinitial A^op x y. Lemma isinitial_cate A `{HasEquivs A} (x y : A) : x $<~> y -> IsInitial x -> IsInitial y. Proof. intros f inx z. exists ((inx z).1 $o f^-1$). intros g. refine (_ $@ compose_hh_V _ f). refine (_ $@R _). exact ((inx z).2 _). Defined. Definition isterminal_cate A `{HasEquivs A} (x y : A) : y $<~> x -> IsTerminal x -> IsTerminal y := isinitial_cate A^op x y. (** * There is a default notion of equivalence for a 1-category, namely bi-invertibility. *) (** We do not use the half-adjoint definition, since we can't prove adjointification for that definition. *) Class Cat_IsBiInv {A} `{Is1Cat A} {x y : A} (f : x $-> y) := { cat_equiv_inv : y $-> x; cat_eisretr : f $o cat_equiv_inv $== Id y; cat_equiv_inv' : y $-> x; cat_eissect' : cat_equiv_inv' $o f $== Id x; }. Arguments cat_equiv_inv {A}%_type_scope { _ _ _ _ x y} f {_}. Arguments cat_eisretr {A}%_type_scope { _ _ _ _ x y} f {_}. Arguments cat_equiv_inv' {A}%_type_scope { _ _ _ _ x y} f {_}. Arguments cat_eissect' {A}%_type_scope { _ _ _ _ x y} f {_}. Arguments Build_Cat_IsBiInv {A}%_type_scope {_ _ _ _ x y f} cat_equiv_inv cat_eisretr cat_equiv_inv' cat_eissect'. Record Cat_BiInv A `{Is1Cat A} (x y : A) := { cat_equiv_fun :> x $-> y; cat_equiv_isequiv : Cat_IsBiInv cat_equiv_fun; }. Global Existing Instance cat_equiv_isequiv. (** The two inverses are necessarily homotopic. *) Definition cat_inverses_homotopic {A} `{Is1Cat A} {x y : A} (f : x $-> y) {bif : Cat_IsBiInv f} : cat_equiv_inv f $== cat_equiv_inv' f. Proof. refine ((cat_idl _)^$ $@ _). refine (cat_prewhisker (cat_eissect' f)^$ _ $@ _). refine (cat_assoc _ _ _ $@ _). refine (cat_postwhisker _ (cat_eisretr f) $@ _). apply cat_idr. Defined. (** Therefore we can prove [eissect] for the first inverse as well. *) Definition cat_eissect {A} `{Is1Cat A} {x y : A} (f : x $-> y) {bif : Cat_IsBiInv f} : cat_equiv_inv f $o f $== Id x := (cat_inverses_homotopic f $@R f) $@ cat_eissect' f. (** This shows that any 1-category satisfies [HasEquivs]. We do not make it an instance, since we may want to use a different [HasEquivs] structure in particular cases. *) Definition cat_hasequivs A `{Is1Cat A} : HasEquivs A. Proof. srapply Build_HasEquivs; intros x y. 1: exact (Cat_BiInv _ x y). all:intros f; cbn beta in *. - exact (Cat_IsBiInv f). - exact f. - exact _. - apply Build_Cat_BiInv. - intros; reflexivity. - exact (cat_equiv_inv f). - apply cat_eissect. - apply cat_eisretr. - intros g r s. exact (Build_Cat_IsBiInv g r g s). Defined. Coq-HoTT-9.0/theories/WildCat/EquivGpd.v000066400000000000000000000177121474641544500200320ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.Iff. Require Import WildCat.Core. Require Import WildCat.NatTrans. Require Import WildCat.Sigma. (** * Equivalences of 0-groupoids, and split essentially surjective functors *) (** For a logically equivalent definition of equivalences of 0-groupoids, see ZeroGroupoid.v. *) (** We could define these similarly for more general categories too, but we'd need to use [HasEquivs] and [$<~>] instead of [$==]. *) Class SplEssSurj {A B : Type} `{Is0Gpd A, Is0Gpd B} (F : A -> B) `{!Is0Functor F} := esssurj : forall b:B, { a:A & F a $== b }. Arguments esssurj {A B _ _ _ _ _ _} F {_ _} b. (** A 0-functor between 0-groupoids is an "equivalence" if it is essentially surjective and reflects the existence of morphisms. This is "surjective and injective" in setoid-language, so we use the name [IsSurjInj]. (To define essential surjectivity for non-groupoids, we would need [HasEquivs] from [WildCat.Equiv]. *) Class IsSurjInj {A B : Type} `{Is0Gpd A, Is0Gpd B} (F : A -> B) `{!Is0Functor F} := { esssurj_issurjinj : SplEssSurj F ; essinj : forall (x y:A), (F x $== F y) -> (x $== y) ; }. Global Existing Instance esssurj_issurjinj. Arguments essinj {A B _ _ _ _ _ _} F {_ _ x y} f. Definition surjinj_inv {A B : Type} (F : A -> B) `{IsSurjInj A B F} : B -> A := fun b => (esssurj F b).1. (** Some of the results below also follow from the logical equivalence with [IsEquiv_0Gpd] and the fact that [ZeroGpd] satisfies [HasEquivs]. But it is sometimes awkward to deduce the results this way, mostly because [ZeroGpd] requires bundled objects rather than typeclass instances. *) (** Equivalences have inverses *) Global Instance is0functor_surjinj_inv {A B : Type} (F : A -> B) `{IsSurjInj A B F} : Is0Functor (surjinj_inv F). Proof. constructor; intros x y f. pose (p := (esssurj F x).2). pose (q := (esssurj F y).2). cbn in *. pose (f' := p $@ f $@ q^$). exact (essinj F f'). Defined. (** The inverse is an inverse, up to unnatural transformations *) Definition eisretr0gpd_inv {A B : Type} (F : A -> B) `{IsSurjInj A B F} : F o surjinj_inv F $=> idmap. Proof. intros b. exact ((esssurj F b).2). Defined. Definition eissect0gpd_inv {A B : Type} (F : A -> B) `{IsSurjInj A B F} : surjinj_inv F o F $=> idmap. Proof. intros a. apply (essinj F). apply eisretr0gpd_inv. Defined. (** Essentially surjective functors and equivalences are preserved by transformations. *) Definition isesssurj_transf {A B : Type} {F : A -> B} {G : A -> B} `{SplEssSurj A B F} `{!Is0Functor G} (alpha : G $=> F) : SplEssSurj G. Proof. intros b. exists ((esssurj F b).1). refine (_ $@ (esssurj F b).2). apply alpha. Defined. Definition issurjinj_transf {A B : Type} {F : A -> B} {G : A -> B} `{IsSurjInj A B F} `{!Is0Functor G} (alpha : G $=> F) : IsSurjInj G. Proof. constructor. - apply (isesssurj_transf alpha). - intros x y f. apply (essinj F). refine (_ $@ f $@ _). + symmetry; apply alpha. + apply alpha. Defined. (** Equivalences compose and cancel with each other and with essentially surjective functors. *) Section ComposeAndCancel. Context {A B C} `{Is0Gpd A, Is0Gpd B, Is0Gpd C} (G : B -> C) (F : A -> B) `{!Is0Functor G, !Is0Functor F}. Global Instance isesssurj_compose `{!SplEssSurj G, !SplEssSurj F} : SplEssSurj (G o F). Proof. intros c. exists ((esssurj F (esssurj G c).1).1). refine (_ $@ (esssurj G c).2). apply (fmap G). apply (esssurj F). Defined. Global Instance issurjinj_compose `{!IsSurjInj G, !IsSurjInj F} : IsSurjInj (G o F). Proof. constructor. - exact _. - intros x y f. apply (essinj F). exact (essinj G f). Defined. Definition cancelL_isesssurj `{!IsSurjInj G, !SplEssSurj (G o F)} : SplEssSurj F. Proof. intros b. exists ((esssurj (G o F) (G b)).1). apply (essinj G). exact ((esssurj (G o F) (G b)).2). Defined. Definition iffL_isesssurj `{!IsSurjInj G} : SplEssSurj (G o F) <-> SplEssSurj F. Proof. split; [ apply @cancelL_isesssurj | apply @isesssurj_compose ]; exact _. Defined. Definition cancelL_issurjinj `{!IsSurjInj G, !IsSurjInj (G o F)} : IsSurjInj F. Proof. constructor. - apply cancelL_isesssurj. - intros x y f. exact (essinj (G o F) (fmap G f)). Defined. Definition iffL_issurjinj `{!IsSurjInj G} : IsSurjInj (G o F) <-> IsSurjInj F. Proof. split; [ apply @cancelL_issurjinj | apply @issurjinj_compose ]; exact _. Defined. Definition cancelR_isesssurj `{!SplEssSurj (G o F)} : SplEssSurj G. Proof. intros c. exists (F (esssurj (G o F) c).1). exact ((esssurj (G o F) c).2). Defined. Definition iffR_isesssurj `{!SplEssSurj F} : SplEssSurj (G o F) <-> SplEssSurj G. Proof. split; [ apply @cancelR_isesssurj | intros; apply @isesssurj_compose ]; exact _. Defined. Definition cancelR_issurjinj `{!IsSurjInj F, !IsSurjInj (G o F)} : IsSurjInj G. Proof. constructor. - apply cancelR_isesssurj. - intros x y f. pose (p := (esssurj F x).2). pose (q := (esssurj F y).2). cbn in *. refine (p^$ $@ _ $@ q). apply (fmap F). apply (essinj (G o F)). refine (_ $@ f $@ _). + exact (fmap G p). + exact (fmap G q^$). Defined. Definition iffR_issurjinj `{!IsSurjInj F} : IsSurjInj (G o F) <-> IsSurjInj G. Proof. split; [ apply @cancelR_issurjinj | intros; apply @issurjinj_compose ]; exact _. Defined. End ComposeAndCancel. (** In particular, essential surjectivity and being an equivalence transfer across commutative squares of functors. *) Definition isesssurj_iff_commsq {A B C D : Type} {F : A -> B} {G : C -> D} {H : A -> C} {K : B -> D} `{IsSurjInj A C H} `{IsSurjInj B D K} `{!Is0Functor F} `{!Is0Functor G} (p : K o F $=> G o H) : SplEssSurj F <-> SplEssSurj G. Proof. split; intros ?. - srapply (cancelR_isesssurj G H); try exact _. apply (isesssurj_transf (fun a => (p a)^$)). - srapply (cancelL_isesssurj K F); try exact _. apply (isesssurj_transf p). Defined. Definition issurjinj_iff_commsq {A B C D : Type} {F : A -> B} {G : C -> D} {H : A -> C} {K : B -> D} `{IsSurjInj A C H} `{IsSurjInj B D K} `{!Is0Functor F} `{!Is0Functor G} (p : K o F $=> G o H) : IsSurjInj F <-> IsSurjInj G. Proof. split; intros ?. - srapply (cancelR_issurjinj G H); try exact _. apply (issurjinj_transf (fun a => (p a)^$)). - srapply (cancelL_issurjinj K F); try exact _. apply (issurjinj_transf p). Defined. (** Equivalences and essential surjectivity are preserved by sigmas (for now, just over constant bases), and essential surjectivity at least is also reflected. *) Definition isesssurj_iff_sigma {A : Type} (B C : A -> Type) `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)} `{forall a, Is0Gpd (B a)} `{forall a, IsGraph (C a)} `{forall a, Is01Cat (C a)} `{forall a, Is0Gpd (C a)} (F : forall a, B a -> C a) {ff : forall a, Is0Functor (F a)} : SplEssSurj (fun (x:sig B) => (x.1 ; F x.1 x.2)) <-> (forall a, SplEssSurj (F a)). Proof. split. - intros fs a c. pose (s := fs (a;c)). destruct s as [[a' b] [p q]]; cbn in *. destruct p; cbn in q. exists b. exact q. - intros fs [a c]. exists (a ; (esssurj (F a) c).1); cbn. exists idpath; cbn. exact ((esssurj (F a) c).2). Defined. Definition issurjinj_sigma {A : Type} (B C : A -> Type) `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)} `{forall a, Is0Gpd (B a)} `{forall a, IsGraph (C a)} `{forall a, Is01Cat (C a)} `{forall a, Is0Gpd (C a)} (F : forall a, B a -> C a) `{forall a, Is0Functor (F a)} `{forall a, IsSurjInj (F a)} : IsSurjInj (fun (x:sig B) => (x.1 ; F x.1 x.2)). Proof. constructor. - apply isesssurj_iff_sigma; exact _. - intros [a1 b1] [a2 b2] [p f]; cbn in *. destruct p; cbn in *. exists idpath; cbn. exact (essinj (F a1) f). Defined. Coq-HoTT-9.0/theories/WildCat/Forall.v000066400000000000000000000033651474641544500175240ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. (** ** Indexed product of categories *) Global Instance isgraph_forall (A : Type) (B : A -> Type) `{forall a, IsGraph (B a)} : IsGraph (forall a, B a). Proof. srapply Build_IsGraph. intros x y; exact (forall (a : A), x a $-> y a). Defined. Global Instance is01cat_forall (A : Type) (B : A -> Type) `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)} : Is01Cat (forall a, B a). Proof. srapply Build_Is01Cat. + intros x a; exact (Id (x a)). + intros x y z f g a; exact (f a $o g a). Defined. Global Instance is0gpd_forall (A : Type) (B : A -> Type) (* Apparently when there's a [forall] there, Coq can't automatically add the [Is01Cat] instance from the [Is0Gpd] instance. *) `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)} `{forall a, Is0Gpd (B a)} : Is0Gpd (forall a, B a). Proof. constructor. intros f g p a; exact ((p a)^$). Defined. Global Instance is2graph_forall (A : Type) (B : A -> Type) `{forall a, IsGraph (B a)} `{forall a, Is2Graph (B a)} : Is2Graph (forall a, B a). Proof. intros x y; srapply Build_IsGraph. intros f g; exact (forall a, f a $-> g a). Defined. Global Instance is1cat_forall (A : Type) (B : A -> Type) `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)} `{forall a, Is2Graph (B a)} `{forall a, Is1Cat (B a)} : Is1Cat (forall a, B a). Proof. srapply Build_Is1Cat. + intros x y z h; srapply Build_Is0Functor. intros f g p a. exact (h a $@L p a). + intros x y z h; srapply Build_Is0Functor. intros f g p a. exact (p a $@R h a). + intros w x y z f g h a; apply cat_assoc. + intros w x y z f g h a; apply cat_assoc_opp. + intros x y f a; apply cat_idl. + intros x y f a; apply cat_idr. Defined. Coq-HoTT-9.0/theories/WildCat/FunctorCat.v000066400000000000000000000147571474641544500203640ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. Require Import WildCat.Opposite. Require Import WildCat.Equiv. Require Import WildCat.Induced. Require Import WildCat.NatTrans. (** * Wild functor categories *) (** ** Categories of 0-coherent 1-functors *) Record Fun01 (A B : Type) `{IsGraph A} `{IsGraph B} := { fun01_F : A -> B; fun01_is0functor : Is0Functor fun01_F; }. Coercion fun01_F : Fun01 >-> Funclass. Global Existing Instance fun01_is0functor. Arguments Build_Fun01 A B {isgraph_A isgraph_B} F {fun01_is0functor} : rename. Definition issig_Fun01 (A B : Type) `{IsGraph A} `{IsGraph B} : _ <~> Fun01 A B := ltac:(issig). (* Note that even if [A] and [B] are fully coherent oo-categories, the objects of our "functor category" are not fully coherent. Thus we cannot in general expect this "functor category" to itself be fully coherent. However, it is at least a 0-coherent 1-category, as long as [B] is a 1-coherent 1-category. *) Global Instance isgraph_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : IsGraph (Fun01 A B). Proof. srapply Build_IsGraph. intros [F ?] [G ?]. exact (NatTrans F G). Defined. Global Instance is01cat_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : Is01Cat (Fun01 A B). Proof. srapply Build_Is01Cat. - intros [F ?]; cbn. exact (nattrans_id F). - intros F G K gamma alpha; cbn in *. exact (nattrans_comp gamma alpha). Defined. Global Instance is2graph_fun01 (A B : Type) `{IsGraph A, Is1Cat B} : Is2Graph (Fun01 A B). Proof. intros [F ?] [G ?]; apply Build_IsGraph. intros [alpha ?] [gamma ?]. exact (forall a, alpha a $== gamma a). Defined. (** In fact, in this case it is automatically also a 0-coherent 2-category and a 1-coherent 1-category, with a totally incoherent notion of 2-cell between 1-coherent natural transformations. *) Global Instance is1cat_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : Is1Cat (Fun01 A B). Proof. srapply Build_Is1Cat. - intros [F ?] [G ?]; srapply Build_Is01Cat. + intros [alpha ?] a; cbn. reflexivity. + intros [alpha ?] [gamma ?] [phi ?] nu mu a. exact (mu a $@ nu a). - intros [F ?] [G ?]; srapply Build_Is0Gpd. intros [alpha ?] [gamma ?] mu a. exact ((mu a)^$). - intros [F ?] [G ?] [K ?] [alpha ?]. srapply Build_Is0Functor. intros [phi ?] [mu ?] f a. exact (alpha a $@L f a). - intros [F ?] [G ?] [K ?] [alpha ?]. srapply Build_Is0Functor. intros [phi ?] [mu ?] f a. exact (f a $@R alpha a). - intros [F ?] [G ?] [K ?] [L ?] [alpha ?] [gamma ?] [phi ?] a; cbn. srapply cat_assoc. - intros [F ?] [G ?] [K ?] [L ?] [alpha ?] [gamma ?] [phi ?] a; cbn. srapply cat_assoc_opp. - intros [F ?] [G ?] [alpha ?] a; cbn. srapply cat_idl. - intros [F ?] [G ?] [alpha ?] a; cbn. srapply cat_idr. Defined. (** It also inherits a notion of equivalence, namely a natural transformation that is a pointwise equivalence. Note that this is not a "fully coherent" notion of equivalence, since the functors and transformations are not themselves fully coherent. *) Global Instance hasequivs_fun01 (A B : Type) `{Is01Cat A} `{HasEquivs B} : HasEquivs (Fun01 A B). Proof. srapply Build_HasEquivs. 1: intros F G; exact (NatEquiv F G). all: intros F G alpha; cbn in *. - exact (forall a, CatIsEquiv (alpha a)). - exact alpha. - intros a; exact _. - apply Build_NatEquiv'. - cbn; intros; apply cate_buildequiv_fun. - exact (natequiv_inverse alpha). - intros; apply cate_issect. - intros; apply cate_isretr. - intros [gamma ?] r s a; cbn in *. refine (catie_adjointify (alpha a) (gamma a) (r a) (s a)). Defined. (** Bundled opposite functors *) Definition fun01_op (A B : Type) `{IsGraph A} `{IsGraph B} : Fun01 A B -> Fun01 A^op B^op. Proof. intros F. rapply (Build_Fun01 A^op B^op F). Defined. (** ** Categories of 1-coherent 1-functors *) Record Fun11 (A B : Type) `{Is1Cat A} `{Is1Cat B} := { fun11_fun : A -> B ; is0functor_fun11 : Is0Functor fun11_fun ; is1functor_fun11 : Is1Functor fun11_fun }. Coercion fun11_fun : Fun11 >-> Funclass. Global Existing Instance is0functor_fun11. Global Existing Instance is1functor_fun11. Arguments Build_Fun11 A B {isgraph_A is2graph_A is01cat_A is1cat_A isgraph_B is2graph_B is01cat_B is1cat_B} F {is0functor_fun11 is1functor_fun11} : rename. Coercion fun01_fun11 {A B : Type} `{Is1Cat A} `{Is1Cat B} (F : Fun11 A B) : Fun01 A B. Proof. exists F; exact _. Defined. Global Instance isgraph_fun11 {A B : Type} `{Is1Cat A} `{Is1Cat B} : IsGraph (Fun11 A B) := isgraph_induced fun01_fun11. Global Instance is01cat_fun11 {A B : Type} `{Is1Cat A} `{Is1Cat B} : Is01Cat (Fun11 A B) := is01cat_induced fun01_fun11. Global Instance is2graph_fun11 {A B : Type} `{Is1Cat A, Is1Cat B} : Is2Graph (Fun11 A B) := is2graph_induced fun01_fun11. Global Instance is1cat_fun11 {A B :Type} `{Is1Cat A} `{Is1Cat B} : Is1Cat (Fun11 A B) := is1cat_induced fun01_fun11. Global Instance hasequivs_fun11 {A B : Type} `{Is1Cat A} `{HasEquivs B} : HasEquivs (Fun11 A B) := hasequivs_induced fun01_fun11. (** * Identity functors *) Definition fun01_id {A} `{IsGraph A} : Fun01 A A := Build_Fun01 A A idmap. Definition fun11_id {A} `{Is1Cat A} : Fun11 A A := Build_Fun11 _ _ idmap. (** * Composition of functors *) Definition fun01_compose {A B C} `{IsGraph A, IsGraph B, IsGraph C} : Fun01 B C -> Fun01 A B -> Fun01 A C := fun G F => Build_Fun01 _ _ (G o F). Definition fun01_postcomp {A B C} `{IsGraph A, Is1Cat B, Is1Cat C} (F : Fun11 B C) : Fun01 A B -> Fun01 A C := fun01_compose (A:=A) F. (** Warning: [F] needs to be a 1-functor for this to be a 0-functor. *) Global Instance is0functor_fun01_postcomp {A B C} `{IsGraph A, Is1Cat B, Is1Cat C} (F : Fun11 B C) : Is0Functor (fun01_postcomp (A:=A) F). Proof. apply Build_Is0Functor. intros a b f. rapply nattrans_postwhisker. exact f. Defined. Global Instance is1functor_fun01_postcomp {A B C} `{IsGraph A, Is1Cat B, Is1Cat C} (F : Fun11 B C) : Is1Functor (fun01_postcomp (A:=A) F). Proof. apply Build_Is1Functor. - intros a b f g p x. rapply fmap2. rapply p. - intros f x. rapply fmap_id. - intros a b c f g x. rapply fmap_comp. Defined. Definition fun11_fun01_postcomp {A B C} `{IsGraph A, Is1Cat B, Is1Cat C} (F : Fun11 B C) : Fun11 (Fun01 A B) (Fun01 A C) := Build_Fun11 _ _ (fun01_postcomp F). Definition fun11_compose {A B C} `{Is1Cat A, Is1Cat B, Is1Cat C} : Fun11 B C -> Fun11 A B -> Fun11 A C. Proof. intros F G. nrapply Build_Fun11. rapply (is1functor_compose G F). Defined. Coq-HoTT-9.0/theories/WildCat/Induced.v000066400000000000000000000054341474641544500176570ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. Require Import WildCat.Equiv. (** * Induced wild categories *) (** A map [A -> B] of types, where [B] is some type of wild category, induces the same level of structure on [A], via taking everything to be defined on the image. This needs to be separate from Core because of HasEquivs usage. We don't make these definitions Global Instances because we only want to apply them manually, but we make them Local Instances so that subsequent ones can pick up the previous ones automatically. *) (** In most of the proofs, we only want to use [intro] on variables of type [A], so this will be handy. *) Ltac intros_of_type A := repeat match goal with |- forall (a : A), _ => intro a end. Section Induced_category. Context {A B : Type} (f : A -> B). Local Instance isgraph_induced `{IsGraph B} : IsGraph A. Proof. nrapply Build_IsGraph. intros a1 a2. exact (f a1 $-> f a2). Defined. Local Instance is01cat_induced `{Is01Cat B} : Is01Cat A. Proof. nrapply Build_Is01Cat; intros_of_type A; cbn. + apply Id. + apply cat_comp. Defined. Local Instance is0gpd_induced `{Is0Gpd B} : Is0Gpd A. Proof. nrapply Build_Is0Gpd; intros_of_type A; cbn. apply gpd_rev. Defined. (** The structure map along which we induce the category structure becomes a functor with respect to the induced structure. *) Local Instance is0functor_induced `{IsGraph B} : Is0Functor f. Proof. nrapply Build_Is0Functor; intros_of_type A; cbn. exact idmap. Defined. Local Instance is2graph_induced `{Is2Graph B} : Is2Graph A. Proof. constructor; cbn. apply isgraph_hom. Defined. Local Instance is1cat_induced `{Is1Cat B} : Is1Cat A. Proof. snrapply Build_Is1Cat; intros_of_type A; cbn. + rapply is01cat_hom. + nrapply is0gpd_hom. + rapply is0functor_postcomp. + rapply is0functor_precomp. + rapply cat_assoc. + rapply cat_assoc_opp. + rapply cat_idl. + rapply cat_idr. Defined. Local Instance is1functor_induced `{Is1Cat B} : Is1Functor f. Proof. srapply Build_Is1Functor; intros_of_type A; cbn. + intros g h. exact idmap. + exact (Id _). + intros g h. exact (Id _). Defined. Instance hasmorext_induced `{HasMorExt B} : HasMorExt A. Proof. constructor. intros_of_type A; cbn. rapply isequiv_Htpy_path. Defined. Definition hasequivs_induced `{HasEquivs B} : HasEquivs A. Proof. srapply Build_HasEquivs; intros a b; cbn. + exact (f a $<~> f b). + apply CatIsEquiv'. + apply cate_fun. + apply cate_isequiv'. + apply cate_buildequiv'. + nrapply cate_buildequiv_fun'. + apply cate_inv'. + nrapply cate_issect'. + nrapply cate_isretr'. + nrapply catie_adjointify'. Defined. End Induced_category. Coq-HoTT-9.0/theories/WildCat/Monoidal.v000066400000000000000000000637221474641544500200520ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Types.Forall. Require Import WildCat.Core WildCat.Bifunctor WildCat.Prod WildCat.Equiv. Require Import WildCat.NatTrans WildCat.Opposite. (** * Monoidal Categories *) (** In this file we define monoidal categories and symmetric monoidal categories. *) (** ** Typeclasses for common diagrams *) (** TODO: These should eventually be moved to a separate file in WildCat and used in other places. They can be thought of as a wildcat generalization of the classes in canonical_names.v *) (** *** Associators *) Class Associator {A : Type} `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} := associator_uncurried : NatEquiv (fun '(a, b, c) => F a (F b c)) (fun '(a, b, c) => F (F a b) c). Arguments associator_uncurried {A _ _ _ _ _ F _ _ _}. Definition associator {A : Type} `{HasEquivs A} {F : A -> A -> A} `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F} : forall a b c, F a (F b c) $<~> F (F a b) c := fun a b c => associator_uncurried (a, b, c). Coercion associator : Associator >-> Funclass. Definition Build_Associator {A : Type} `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (associator : forall a b c, F a (F b c) $<~> F (F a b) c) (isnat_assoc : Is1Natural (fun '(a, b, c) => F a (F b c)) (fun '(a, b, c) => F (F a b) c) (fun '(a, b, c) => associator a b c)) : Associator F. Proof. snrapply Build_NatEquiv. - intros [[a b] c]. exact (associator a b c). - exact isnat_assoc. Defined. (** *** Unitors *) Class LeftUnitor {A : Type} `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (unit : A) (** A natural isomorphism [left_unitor] witnessing the left unit law of [F]. *) := left_unitor : NatEquiv (F unit) idmap. Coercion left_unitor : LeftUnitor >-> NatEquiv. Arguments left_unitor {A _ _ _ _ _ F _ _ unit _}. Class RightUnitor {A : Type} `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (unit : A) (** A natural isomorphism [right_unitor] witnessing the right unit law of [F]. *) := right_unitor : NatEquiv (flip F unit) idmap. Coercion right_unitor : RightUnitor >-> NatEquiv. Arguments right_unitor {A _ _ _ _ _ F _ _ unit _}. (** *** Triangle and Pentagon identities *) Class TriangleIdentity {A : Type} `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F} (unit : A) `{!LeftUnitor F unit, !RightUnitor F unit} (** The triangle identity for an associator and unitors. *) := triangle_identity a b : fmap01 F a (left_unitor b) $== fmap10 F (right_unitor a) b $o (associator (F := F) a unit b). Coercion triangle_identity : TriangleIdentity >-> Funclass. Arguments triangle_identity {A _ _ _ _ _} F {_ _ _} unit {_}. Class PentagonIdentity {A : Type} `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F} (** The pentagon identity for an associator. *) := pentagon_identity a b c d : associator (F a b) c d $o associator a b (F c d) $== fmap10 F (associator a b c) d $o associator a (F b c) d $o fmap01 F a (associator b c d). Coercion pentagon_identity : PentagonIdentity >-> Funclass. Arguments pentagon_identity {A _ _ _ _ _} F {_ _ _}. (** *** Braiding *) Class Braiding {A : Type} `{Is1Cat A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} := braid_uncurried : NatTrans (uncurry F) (uncurry (flip F)). Arguments braid_uncurried {A _ _ _ _ F _ _ _}. Definition braid {A : Type} `{Is1Cat A} {F : A -> A -> A} `{!Is0Bifunctor F, !Is1Bifunctor F, !Braiding F} : forall a b, F a b $-> F b a := fun a b => braid_uncurried (a, b). Coercion braid : Braiding >-> Funclass. Class SymmetricBraiding {A : Type} `{Is1Cat A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} := { braiding_symmetricbraiding :: Braiding F; braid_braid : forall a b, braid a b $o braid b a $== Id (F b a); }. (** We could have used [::>] in [braiding_symmetricbraiding] instead however due to bug https://github.com/coq/coq/issues/18971 the coercion isn't registered, so we have to register it manually instead. *) Coercion braiding_symmetricbraiding : SymmetricBraiding >-> Braiding. Arguments braid_braid {A _ _ _ _ F _ _ _} a b. (** *** Hexagon identity *) Class HexagonIdentity {A : Type} `{HasEquivs A} (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F, !Braiding F} (** The hexagon identity for an associator and a braiding. *) := hexagon_identity a b c : fmap10 F (braid b a) c $o associator b a c $o fmap01 F b (braid c a) $== associator a b c $o braid (F b c) a $o associator b c a. Coercion hexagon_identity : HexagonIdentity >-> Funclass. Arguments hexagon_identity {A _ _ _ _ _} F {_ _}. (** ** Monoidal Categories *) (** A monoidal 1-category is a 1-category with equivalences together with the following: *) Class IsMonoidal (A : Type) `{HasEquivs A} (** It has a binary operation [cat_tensor] called the tensor product. *) (cat_tensor : A -> A -> A) (** It has a unit object [cat_tensor_unit] called the tensor unit. *) (cat_tensor_unit : A) (** These all satisfy the following properties: *) := { (** A [cat_tensor] is a 1-bifunctor. *) is0bifunctor_cat_tensor : Is0Bifunctor cat_tensor; is1bifunctor_cat_tensor : Is1Bifunctor cat_tensor; (** A natural isomorphism [associator] witnessing the associativity of the tensor product. *) cat_tensor_associator :: Associator cat_tensor; (** A natural isomorphism [left_unitor] witnessing the left unit law. *) cat_tensor_left_unitor :: LeftUnitor cat_tensor cat_tensor_unit; (** A natural isomorphism [right_unitor] witnessing the right unit law. *) cat_tensor_right_unitor :: RightUnitor cat_tensor cat_tensor_unit; (** The triangle identity. *) cat_tensor_triangle_identity :: TriangleIdentity cat_tensor cat_tensor_unit; (** The pentagon identity. *) cat_tensor_pentagon_identity :: PentagonIdentity cat_tensor; }. Existing Instance is0bifunctor_cat_tensor | 10. Existing Instance is1bifunctor_cat_tensor | 10. (** TODO: Braided monoidal categories *) (** ** Symmetric Monoidal Categories *) (** A symmetric monoidal 1-category is a 1-category with equivalences together with the following: *) Class IsSymmetricMonoidal (A : Type) `{HasEquivs A} (** A binary operation [cat_tensor] called the tensor product. *) (cat_tensor : A -> A -> A) (** A unit object [cat_tensor_unit] called the tensor unit. *) (cat_tensor_unit : A) := { (** A monoidal structure with [cat_tensor] and [cat_tensor_unit]. *) issymmetricmonoidal_ismonoidal :: IsMonoidal A cat_tensor cat_tensor_unit; (** A natural transformation [braid] witnessing the symmetry of the tensor product such that [braid] is its own inverse. *) cat_symm_tensor_braiding :: SymmetricBraiding cat_tensor; (** The hexagon identity. *) cat_symm_tensor_hexagon :: HexagonIdentity cat_tensor; }. (** *** Theory about [Associator] *) Section Associator. Context {A : Type} `{HasEquivs A} {F : A -> A -> A} `{!Is0Bifunctor F, !Is1Bifunctor F, assoc : !Associator F}. Definition associator_nat {x x' y y' z z'} (f : x $-> x') (g : y $-> y') (h : z $-> z') : associator x' y' z' $o fmap11 F f (fmap11 F g h) $== fmap11 F (fmap11 F f g) h $o associator x y z. Proof. destruct assoc as [asso nat]. exact (nat (x, y, z) (x', y', z') (f, g, h)). Defined. Definition associator_nat_l {x x' : A} (f : x $-> x') (y z : A) : associator x' y z $o fmap10 F f (F y z) $== fmap10 F (fmap10 F f y) z $o associator x y z. Proof. refine ((_ $@L _^$) $@ _ $@ (_ $@R _)). 2: rapply (associator_nat f (Id _) (Id _)). - exact (fmap12 _ _ (fmap11_id _ _ _) $@ fmap10_is_fmap11 _ _ _). - exact (fmap21 _ (fmap10_is_fmap11 _ _ _) _ $@ fmap10_is_fmap11 _ _ _). Defined. Definition associator_nat_m (x : A) {y y' : A} (g : y $-> y') (z : A) : associator x y' z $o fmap01 F x (fmap10 F g z) $== fmap10 F (fmap01 F x g) z $o associator x y z. Proof. refine ((_ $@L _^$) $@ _ $@ (_ $@R _)). 2: nrapply (associator_nat (Id _) g (Id _)). - exact (fmap12 _ _ (fmap10_is_fmap11 _ _ _) $@ fmap01_is_fmap11 _ _ _). - exact (fmap21 _ (fmap01_is_fmap11 _ _ _) _ $@ fmap10_is_fmap11 _ _ _). Defined. Definition associator_nat_r (x y : A) {z z' : A} (h : z $-> z') : associator x y z' $o fmap01 F x (fmap01 F y h) $== fmap01 F (F x y) h $o associator x y z. Proof. refine ((_ $@L _^$) $@ _ $@ (_ $@R _)). 2: nrapply (associator_nat (Id _) (Id _) h). - exact (fmap12 _ _ (fmap01_is_fmap11 _ _ _) $@ fmap01_is_fmap11 _ _ _). - exact (fmap21 _ (fmap11_id _ _ _) _ $@ fmap01_is_fmap11 F _ _). Defined. Global Instance associator_op : Associator (A:=A^op) F := natequiv_inverse (natequiv_op assoc). End Associator. Definition associator_op' {A : Type} `{HasEquivs A} {F : A -> A -> A} `{!Is0Bifunctor F, !Is1Bifunctor F, assoc : !Associator (A:=A^op) F} : Associator F := associator_op (A:=A^op) (assoc := assoc). (** ** Theory about [LeftUnitor] and [RightUnitor] *) Section LeftUnitor. Context {A : Type} `{HasEquivs A} {F : A -> A -> A} (unit : A) `{!Is0Bifunctor F, !Is1Bifunctor F, !LeftUnitor F unit, !RightUnitor F unit}. Global Instance left_unitor_op : LeftUnitor (A:=A^op) F unit := natequiv_inverse (natequiv_op left_unitor). Global Instance right_unitor_op : RightUnitor (A:=A^op) F unit := natequiv_inverse (natequiv_op right_unitor). End LeftUnitor. (** ** Theory about [Braiding] *) Global Instance braiding_op {A : Type} `{HasEquivs A} {F : A -> A -> A} `{!Is0Bifunctor F, !Is1Bifunctor F, braid : !Braiding F} : Braiding (A:=A^op) F := nattrans_op (nattrans_flip braid). Definition braiding_op' {A : Type} `{HasEquivs A} {F : A -> A -> A} `{!Is0Bifunctor F, !Is1Bifunctor F, braid : !Braiding (A:=A^op) F} : Braiding F := braiding_op (A:=A^op) (braid := braid). (** ** Theory about [SymmetricBraid] *) Section SymmetricBraid. Context {A : Type} {F : A -> A -> A} `{SymmetricBraiding A F, !HasEquivs A}. (** [braid] is its own inverse and therefore an equivalence. *) Instance catie_braid a b : CatIsEquiv (braid a b) := catie_adjointify (braid a b) (braid b a) (braid_braid a b) (braid_braid b a). (** [braide] is the bundled equivalence whose underlying map is [braid]. *) Definition braide a b : F a b $<~> F b a := Build_CatEquiv (braid a b). Definition moveL_braidL a b c f (g : c $-> _) : braid a b $o f $== g -> f $== braid b a $o g. Proof. intros p. apply (cate_monic_equiv (braide a b)). refine ((cate_buildequiv_fun _ $@R _) $@ p $@ _ $@ cat_assoc _ _ _). refine ((cat_idl _)^$ $@ (_^$ $@R _)). refine ((cate_buildequiv_fun _ $@R _) $@ _). apply braid_braid. Defined. Definition moveL_braidR a b c f (g : _ $-> c) : f $o braid a b $== g -> f $== g $o braid b a. Proof. intros p. apply (cate_epic_equiv (braide a b)). refine (_ $@ (cat_assoc _ _ _)^$). refine (_ $@ (_ $@L ((_ $@L cate_buildequiv_fun _) $@ _)^$)). 2: apply braid_braid. refine ((_ $@L _) $@ _ $@ (cat_idr _)^$). 1: apply cate_buildequiv_fun. exact p. Defined. Definition moveR_braidL a b c f (g : c $-> _) : f $== braid b a $o g -> braid a b $o f $== g. Proof. intros p; symmetry; apply moveL_braidL; symmetry; exact p. Defined. Definition moveR_braidR a b c f (g : _ $-> c) : f $== g $o braid b a -> f $o braid a b $== g. Proof. intros p; symmetry; apply moveL_braidR; symmetry; exact p. Defined. Definition moveL_fmap01_braidL a b c d f (g : d $-> _) : fmap01 F a (braid b c) $o f $== g -> f $== fmap01 F a (braid c b) $o g. Proof. intros p. apply (cate_monic_equiv (emap01 F a (braide b c))). refine (_ $@ cat_assoc _ _ _). refine (_ $@ (_ $@R _)). 2: { refine (_ $@ (_^$ $@R _)). 2: apply cate_buildequiv_fun. refine ((fmap_id _ _)^$ $@ fmap2 _ _ $@ fmap_comp _ _ _). refine ((_ $@R _) $@ _)^$. 1: apply cate_buildequiv_fun. apply braid_braid. } refine ((_ $@R _) $@ p $@ (cat_idl _)^$). refine (_ $@ fmap2 _ _); apply cate_buildequiv_fun. Defined. Definition moveL_fmap01_braidR a b c d f (g : _ $-> d) : f $o fmap01 F a (braid b c) $== g -> f $== g $o fmap01 F a (braid c b). Proof. intros p. apply (cate_epic_equiv (emap01 F a (braide b c))). refine (_ $@ (cat_assoc _ _ _)^$). refine (_ $@ (_ $@L _)). 2: { refine (_^$ $@ (_ $@L _^$)). 2: apply cate_buildequiv_fun. refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _). refine ((_ $@L _) $@ _). 1: apply cate_buildequiv_fun. apply braid_braid. } refine ((_ $@L _) $@ p $@ (cat_idr _)^$). refine (_ $@ fmap2 _ _); apply cate_buildequiv_fun. Defined. Definition moveR_fmap01_braidL a b c d f (g : d $-> _) : f $== fmap01 F a (braid c b) $o g -> fmap01 F a (braid b c) $o f $== g. Proof. intros p; symmetry; apply moveL_fmap01_braidL; symmetry; exact p. Defined. Definition moveR_fmap01_braidR a b c d f (g : _ $-> d) : f $== g $o fmap01 F a (braid c b) -> f $o fmap01 F a (braid b c) $== g. Proof. intros p; symmetry; apply moveL_fmap01_braidR; symmetry; exact p. Defined. Definition moveL_fmap01_fmap01_braidL a b c d e f (g : e $-> _) : fmap01 F a (fmap01 F b (braid c d)) $o f $== g -> f $== fmap01 F a (fmap01 F b (braid d c)) $o g. Proof. intros p. apply (cate_monic_equiv (emap01 F a (emap01 F b (braide c d)))). refine (_ $@ cat_assoc _ _ _). refine (_ $@ (_ $@R _)). 2: { refine (_ $@ (_^$ $@R _)). 2: apply cate_buildequiv_fun. refine ((fmap_id _ _)^$ $@ fmap2 _ _ $@ fmap_comp _ _ _). refine (_ $@ (_^$ $@R _)). 2: apply cate_buildequiv_fun. refine ((fmap_id _ _)^$ $@ fmap2 _ _ $@ fmap_comp _ _ _). refine ((_ $@R _) $@ _)^$. 1: apply cate_buildequiv_fun. apply braid_braid. } refine ((_ $@R _) $@ p $@ (cat_idl _)^$). refine (cate_buildequiv_fun _ $@ fmap02 _ _ _). refine (cate_buildequiv_fun _ $@ fmap02 _ _ _). apply cate_buildequiv_fun. Defined. Definition moveL_fmap01_fmap01_braidR a b c d e f (g : _ $-> e) : f $o fmap01 F a (fmap01 F b (braid c d)) $== g -> f $== g $o fmap01 F a (fmap01 F b (braid d c)). Proof. intros p. apply (cate_epic_equiv (emap01 F a (emap01 F b (braide c d)))). refine (_ $@ (cat_assoc _ _ _)^$). refine (_ $@ (_ $@L _)). 2: { refine (_^$ $@ (_ $@L _^$)). 2: apply cate_buildequiv_fun. refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _). refine ((_ $@L _) $@ _). 1: apply cate_buildequiv_fun. refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _). refine ((_ $@L _) $@ _). 1: apply cate_buildequiv_fun. apply braid_braid. } refine ((_ $@L _) $@ p $@ (cat_idr _)^$). refine (cate_buildequiv_fun _ $@ fmap02 _ _ _). refine (cate_buildequiv_fun _ $@ fmap02 _ _ _). apply cate_buildequiv_fun. Defined. Definition moveR_fmap01_fmap01_braidL a b c d e f (g : e $-> _) : f $== fmap01 F a (fmap01 F b (braid d c)) $o g -> fmap01 F a (fmap01 F b (braid c d)) $o f $== g. Proof. intros p; symmetry; apply moveL_fmap01_fmap01_braidL; symmetry; exact p. Defined. Definition moveR_fmap01_fmap01_braidR a b c d e f (g : _ $-> e) : f $== g $o fmap01 F a (fmap01 F b (braid d c)) -> f $o fmap01 F a (fmap01 F b (braid c d)) $== g. Proof. intros p; symmetry; apply moveL_fmap01_fmap01_braidR; symmetry; exact p. Defined. Definition braid_nat {a b c d} (f : a $-> c) (g : b $-> d) : braid c d $o fmap11 F f g $== fmap11 F g f $o braid a b. Proof. exact (isnat braid_uncurried (a := (a, b)) (a' := (c, d)) (f, g)). Defined. Definition braid_nat_l {a b c} (f : a $-> b) : braid b c $o fmap10 F f c $== fmap01 F c f $o braid a c. Proof. refine ((_ $@L (fmap10_is_fmap11 _ _ _)^$) $@ _ $@ (fmap01_is_fmap11 _ _ _ $@R _)). exact (isnat braid_uncurried (a := (a, c)) (a' := (b, c)) (f, Id _)). Defined. (** This is just the inverse of above. *) Definition braid_nat_r {a b c} (g : b $-> c) : braid a c $o fmap01 F a g $== fmap10 F g a $o braid a b. Proof. refine ((_ $@L (fmap01_is_fmap11 _ _ _)^$) $@ _ $@ (fmap10_is_fmap11 _ _ _ $@R _)). exact (isnat braid_uncurried (a := (a, b)) (a' := (a, c)) (Id _ , g)). Defined. Global Instance symmetricbraiding_op : SymmetricBraiding (A:=A^op) F. Proof. snrapply Build_SymmetricBraiding. - exact _. - intros a b. rapply braid_braid. Defined. End SymmetricBraid. Definition symmetricbraiding_op' {A : Type} {F : A -> A -> A} `{HasEquivs A, !Is0Bifunctor F, !Is1Bifunctor F, H' : !SymmetricBraiding (A:=A^op) F} : SymmetricBraiding F := symmetricbraiding_op (A:=A^op) (F := F). (** ** Opposite Monoidal Categories *) Global Instance ismonoidal_op {A : Type} (tensor : A -> A -> A) (unit : A) `{IsMonoidal A tensor unit} : IsMonoidal A^op tensor unit. Proof. snrapply Build_IsMonoidal. 1-5: exact _. - intros a b; unfold op in a, b; simpl. refine (_^$ $@ _ $@ (_ $@L _)). 1,3: exact (emap_inv _ _ $@ cate_buildequiv_fun _). nrefine (cate_inv2 _ $@ cate_inv_compose' _ _). refine (cate_buildequiv_fun _ $@ _ $@ ((cate_buildequiv_fun _)^$ $@R _) $@ (cate_buildequiv_fun _)^$). rapply cat_tensor_triangle_identity. - intros a b c d; unfold op in a, b, c, d; simpl. refine (_ $@ ((_ $@L _) $@@ _)). 2,3: exact (emap_inv _ _ $@ cate_buildequiv_fun _). refine ((cate_inv_compose' _ _)^$ $@ cate_inv2 _ $@ cate_inv_compose' _ _ $@ (_ $@L cate_inv_compose' _ _)). refine (cate_buildequiv_fun _ $@ _ $@ ((cate_buildequiv_fun _)^$ $@R _) $@ (cate_buildequiv_fun _)^$). refine (_ $@ (cate_buildequiv_fun _ $@@ (cate_buildequiv_fun _ $@R _))^$). rapply cat_tensor_pentagon_identity. Defined. Definition ismonoidal_op' {A : Type} (tensor : A -> A -> A) (unit : A) `{HasEquivs A} `{!IsMonoidal A^op tensor unit} : IsMonoidal A tensor unit := ismonoidal_op (A:=A^op) tensor unit. Global Instance issymmetricmonoidal_op {A : Type} (tensor : A -> A -> A) (unit : A) `{IsSymmetricMonoidal A tensor unit} : IsSymmetricMonoidal A^op tensor unit. Proof. snrapply Build_IsSymmetricMonoidal. - rapply ismonoidal_op. - rapply symmetricbraiding_op. - intros a b c; unfold op in a, b, c; simpl. snrefine (_ $@ (_ $@L (_ $@R _))). 2: exact ((braide _ _)^-1$). 2: { nrapply cate_moveR_V1. symmetry. nrefine ((_ $@R _) $@ _). 1: nrapply cate_buildequiv_fun. rapply braid_braid. } snrefine ((_ $@R _) $@ _). { refine (emap _ _)^-1$. rapply braide. } { symmetry. refine (cate_inv_adjointify _ _ _ _ $@ fmap2 _ _). nrapply cate_inv_adjointify. } snrefine ((_ $@L (_ $@L _)) $@ _). { refine (emap (flip tensor c) _)^-1$. rapply braide. } { symmetry. refine (cate_inv_adjointify _ _ _ _ $@ fmap2 _ _). nrapply cate_inv_adjointify. } refine ((_ $@L _)^$ $@ _^$ $@ cate_inv2 _ $@ _ $@ (_ $@L _)). 1,2,4,5: rapply cate_inv_compose'. refine (_ $@ (_ $@@ _) $@ _ $@ (_ $@R _)^$ $@ _^$). 1-3,5-6: rapply cate_buildequiv_fun. refine ((fmap02 _ _ _ $@@ ((_ $@ fmap20 _ _ _) $@R _)) $@ cat_symm_tensor_hexagon a b c $@ ((_ $@L _^$) $@R _)). 1-4: nrapply cate_buildequiv_fun. Defined. Definition issymmetricmonoidal_op' {A : Type} (tensor : A -> A -> A) (unit : A) `{HasEquivs A} `{H' : !IsSymmetricMonoidal A^op tensor unit} : IsSymmetricMonoidal A tensor unit := issymmetricmonoidal_op (A:=A^op) tensor unit. (** ** Further Coherence Conditions *) (** In MacLane's original axiomatisation of a monoidal category, 3 extra coherence conditions were given in addition to the pentagon and triangle identities. It was later shown by Kelly that these axioms are redundant and follow from the rest. We reproduce these arguments here. *) (** The left unitor of a tensor can be decomposed as an associator and a functorial action of the tensor on a left unitor. *) Definition left_unitor_associator {A} (tensor : A -> A -> A) (unit : A) `{IsMonoidal A tensor unit} (x y : A) : (left_unitor (tensor x y) : _ $-> _) $== fmap10 tensor (left_unitor x) y $o associator unit x y. Proof. refine ((cate_moveR_eV _ _ _ (isnat_natequiv left_unitor _))^$ $@ ((_ $@L _) $@R _) $@ cate_moveR_eV _ _ _ (isnat_natequiv left_unitor _)). refine (_ $@ (fmap01_comp _ _ _ _)^$). refine (_ $@ (cate_moveR_Ve _ _ _ (associator_nat_m _ _ _)^$ $@R _)). nrefine (_ $@ cat_assoc_opp _ _ _). change (fmap (tensor ?x) ?f) with (fmap01 tensor x f). change (cate_fun' _ _ (cat_tensor_left_unitor ?x)) with (cate_fun (cat_tensor_left_unitor x)). apply cate_moveL_Ve. refine ((_ $@L triangle_identity _ _ _ _ _ _) $@ _). nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc_opp _ _ _). refine (_ $@ ((fmap20 _ (triangle_identity _ _ _ _ _ _) _ $@ fmap10_comp _ _ _ _)^$ $@R _)). refine (_ $@ cat_assoc_opp _ _ _). refine (_ $@ (_ $@L (pentagon_identity _ _ _ _ _ _ $@ cat_assoc _ _ _))). refine ((_ $@R _) $@ cat_assoc _ _ _). exact (associator_nat_l _ _ _). Defined. (** The right unitor of a tensor can be decomposed as an inverted associator and a functorial action of the tensor on a right unitor. *) Definition right_unitor_associator {A} (tensor : A -> A -> A) (unit : A) `{IsMonoidal A tensor unit} (x y : A) : (fmap01 tensor x (right_unitor y) : _ $-> _) $== right_unitor (tensor x y) $o associator x y unit. Proof. refine ((cate_moveR_eV _ _ _ (isnat_natequiv right_unitor _))^$ $@ ((_ $@L _) $@R _) $@ cate_moveR_eV _ _ _ (isnat_natequiv right_unitor _)). refine (_ $@ (fmap10_comp tensor _ _ _)^$). refine ((cate_moveR_eV _ _ _ (associator_nat_m _ _ _))^$ $@ _). refine (_ $@ (cate_moveR_eV _ _ _ (triangle_identity _ _ _ _ _ _) $@R _)). apply cate_moveR_eV. refine ((_ $@L (fmap02 _ _ (cate_moveR_eV _ _ _ (triangle_identity _ _ _ _ _ _))^$ $@ fmap01_comp _ _ _ _)) $@ _). refine (cat_assoc_opp _ _ _ $@ _). nrefine ((associator_nat_r _ _ _ $@R _) $@ cat_assoc _ _ _ $@ _). do 2 nrefine (_ $@ cat_assoc_opp _ _ _). refine (_ $@L _). refine ((_ $@L (emap_inv' _ _)^$) $@ _). apply cate_moveR_eV. refine (_ $@ (_ $@L cate_buildequiv_fun _)^$). nrefine (_ $@ cat_assoc_opp _ _ _). apply cate_moveL_Ve. rapply pentagon_identity. Defined. (** The left unitor at the unit is the right unitor at the unit. *) Definition left_unitor_unit_right_unitor_unit {A} (tensor : A -> A -> A) (unit : A) `{IsMonoidal A tensor unit} : (left_unitor unit : tensor unit unit $-> _) $== right_unitor unit. Proof. refine ((cate_moveR_eV _ _ _ (isnat_natequiv left_unitor (left_unitor unit)))^$ $@ _). apply cate_moveR_eV. refine (_ $@ (_ $@L left_unitor_associator _ _ _ _)^$). nrefine (_ $@ (_ $@R _) $@ cat_assoc _ _ _). 2: rapply (isnat_natequiv right_unitor _)^$. nrefine ((_ $@L _) $@ cat_assoc_opp _ _ _). refine (triangle_identity _ _ _ _ _ _ $@ _). nrefine (_ $@R _). nrapply cate_monic_equiv. exact (isnat_natequiv right_unitor (right_unitor unit)). Defined. (** TODO: Kelly also shows that there are redundant coherence conditions for symmetric monoidal categories also, but we leave these out for now. *) (** ** Monoidal functors *) (** A (lax) monoidal functor [F] between two monoidal categories [A] and [B] is a functor [F : A -> B] together with: *) Class IsMonoidalFunctor {A B : Type} {tensorA : A -> A -> A} {tensorB : B -> B -> B} {IA : A} {IB : B} `{IsMonoidal A tensorA IA, IsMonoidal B tensorB IB} (F : A -> B) `{!Is0Functor F, !Is1Functor F} := { (** A natural transformation [fmap_tensor] from [F a ⊗ F b] to [F (a ⊗ b)]. *) fmap_tensor : NatTrans (uncurry (fun a b => tensorB (F a) (F b))) (uncurry (fun a b => F (tensorA a b))); (** A morphism [fmap_unit] relating the two unit objects. *) fmap_unit : IB $-> F (IA); (** Such that the following coherence conditions hold: [F] preserves the [associator]s in a suitable way. *) fmap_tensor_assoc a b c : fmap F (associator a b c) $o fmap_tensor (a, tensorA b c) $o fmap01 tensorB (F a) (fmap_tensor (b, c)) $== fmap_tensor (tensorA a b, c) $o fmap10 tensorB (fmap_tensor (a, b)) (F c) $o associator (F a) (F b) (F c); (** [F] preserves the [left_unitor]s in a suitable way. *) fmap_tensor_left_unitor a : trans_nattrans left_unitor (F a) $== fmap F (left_unitor a) $o fmap_tensor (IA, a) $o fmap10 tensorB fmap_unit (F a); (** [F] preserves the [right_unitors]s in a suitable way. *) fmap_tensor_right_unitor a : trans_nattrans right_unitor (F a) $== fmap F (right_unitor a) $o fmap_tensor (a, IA) $o fmap01 tensorB (F a) fmap_unit; }. Arguments fmap_tensor {A B tensorA tensorB IA IB _ _ _ _ _ _ _ _ _ _ _ _} F {_ _ _}. Definition fmap_tensor_nat {A B : Type} {tensorA : A -> A -> A} {tensorB : B -> B -> B} {IA : A} {IB : B} (F : A -> B) `{IsMonoidalFunctor A B tensorA tensorB IA IB F} {x x' y y': A} (f : x $-> x') (g : y $-> y') : fmap_tensor F (x', y') $o fmap11 tensorB (fmap F f) (fmap F g) $== fmap F (fmap11 tensorA f g) $o fmap_tensor F (x, y). Proof. destruct (fmap_tensor F) as [fmap_tensor_F nat]. exact (nat (x, y) (x', y') (f, g)). Defined. Definition fmap_tensor_nat_l {A B : Type} {tensorA : A -> A -> A} {tensorB : B -> B -> B} {IA : A} {IB : B} (F : A -> B) `{IsMonoidalFunctor A B tensorA tensorB IA IB F} {x x' y : A} (f : x $-> x') : fmap_tensor F (x', y) $o fmap10 tensorB (fmap F f) (F y) $== fmap F (fmap10 tensorA f y) $o fmap_tensor F (x, y). Proof. refine ((_ $@L (fmap12 tensorB _ (fmap_id _ _) $@ fmap10_is_fmap11 _ _ _)^$) $@ _). refine (_ $@ (fmap2 F (fmap10_is_fmap11 _ _ _) $@R _)). snrapply fmap_tensor_nat. Defined. Definition fmap_tensor_nat_r {A B : Type} {tensorA : A -> A -> A} {tensorB : B -> B -> B} {IA : A} {IB : B} (F : A -> B) `{IsMonoidalFunctor A B tensorA tensorB IA IB F} {x y y' : A} (g : y $-> y') : fmap_tensor F (x, y') $o fmap01 tensorB (F x) (fmap F g) $== fmap F (fmap01 tensorA x g) $o fmap_tensor F (x, y). Proof. refine ((_ $@L (fmap21 tensorB (fmap_id _ _) _ $@ fmap01_is_fmap11 _ _ _)^$) $@ _). refine (_ $@ (fmap2 F (fmap01_is_fmap11 _ _ _) $@R _)). snrapply fmap_tensor_nat. Defined. Coq-HoTT-9.0/theories/WildCat/MonoidalTwistConstruction.v000066400000000000000000000462241474641544500235160ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Types.Forall WildCat.Monoidal. Require Import WildCat.Core WildCat.Bifunctor WildCat.Prod WildCat.Equiv. Require Import WildCat.NatTrans WildCat.Square WildCat.Opposite. (** * Building Symmetric Monoidal Categories *) (** The following construction is what we call the "twist construction". It is a way to build a symmetric monoidal category from simpler pieces than the axioms ask for. The core observation is that the associator can be broken up into a [braid] and what we call a [twist] map. The twist map takes a right associated triple [(A, (B, C))] and swaps the first two factors [(B, (A, C)]. Together with functoriality of the tensor and the braiding, here termed [braid] we can simplify the axioms we ask for. For instance, the hexagon identity is about associators, but if we unfold the definition and simplify the diagram, we get a diagram about only twists and braids. This means in practice, you can show a category has a symmetric monoidal structure by proving some simpler axioms. This idea has been used in TriJoin.v to show the associativity of join for example. *) Section TwistConstruction. (** The aim of this section is to build a symmetric monoidal category. We do this piecewise so that the separate steps are useful in and of themselves. Our basic starting assumption is that we have a category with equivalences, a bifunctor called the tensor product, and a unit object.*) Context (A : Type) `{HasEquivs A} (cat_tensor : A -> A -> A) (cat_tensor_unit : A) `{!Is0Bifunctor cat_tensor, !Is1Bifunctor cat_tensor} (** Next we postulate the existence of a [braid] map. This takes a tensor pair and swaps the factors. We also postulate that [braid] is natural in both factors and self-inverse. *) (braid : SymmetricBraiding cat_tensor) (** We postulate the existence of a [twist] map. This takes a right associated triple [(A, (B, C))] and swaps the first two factors [(B, (A, C)]. We also postulate that [twist] is natural in all three factors and self-inverse. *) (twist : forall a b c, cat_tensor a (cat_tensor b c) $-> cat_tensor b (cat_tensor a c)) (twist_twist : forall a b c, twist a b c $o twist b a c $== Id _) (twist_nat : forall a a' b b' c c' (f : a $-> a') (g : b $-> b') (h : c $-> c'), twist a' b' c' $o fmap11 cat_tensor f (fmap11 cat_tensor g h) $== fmap11 cat_tensor g (fmap11 cat_tensor f h) $o twist a b c) (** We assume that there is a natural isomorphism [right_unitor] witnessing the right unit law. The left unit law will be derived from this one. We also assume a coherence called [twist_unitor] which determines how the right_unitor interacts with [braid] and [twist]. This is the basis of the triangle axiom. *) (right_unitor : RightUnitor cat_tensor cat_tensor_unit) (twist_unitor : forall a b, fmap01 cat_tensor a (right_unitor b) $== braid b a $o fmap01 cat_tensor b (right_unitor a) $o twist a b cat_tensor_unit) (** The hexagon identity is about the interaction of associators and braids. We will derive this axiom from an analogous one for twists and braids. *) (twist_hexagon : forall a b c, fmap01 cat_tensor c (braid b a) $o twist b c a $o fmap01 cat_tensor b (braid a c) $== twist a c b $o fmap01 cat_tensor a (braid b c) $o twist b a c) (** The 9-gon identity. TODO: explain this *) (twist_9_gon : forall a b c d, fmap01 cat_tensor c (braid (cat_tensor a b) d) $o twist (cat_tensor a b) c d $o braid (cat_tensor c d) (cat_tensor a b) $o twist a (cat_tensor c d) b $o fmap01 cat_tensor a (braid b (cat_tensor c d)) $== fmap01 cat_tensor c (twist a d b) $o fmap01 cat_tensor c (fmap01 cat_tensor a (braid b d)) $o twist a c (cat_tensor b d) $o fmap01 cat_tensor a (twist b c d)) . (** *** Setup *) (** Before starting the proofs, we need to setup some useful definitions and helpful lemmas for working with diagrams. *) (** We give notations and abbreviations to the morphisms that will appear in diagrams. This helps us read the goal and understand what is happening, otherwise it is too verbose. *) Declare Scope monoidal_scope. Local Infix "⊗" := cat_tensor (at level 40) : monoidal_scope. Local Infix "⊗R" := (fmap01 cat_tensor) (at level 40) : monoidal_scope. Local Infix "⊗L" := (fmap10 cat_tensor) (at level 40) : monoidal_scope. Local Notation "f ∘ g" := (f $o g) (at level 61, left associativity, format "f '/' '∘' g") : monoidal_scope. (** TODO: in 8.19 this notation causes issues, when updating to 8.20 we should uncomment this. *) (* Local Notation "f $== g :> A" := (GpdHom (A := A) f g) (at level 70, format "'[v' '[v' f ']' '/' $== '/' '[v' g ']' '/' :> '[' A ']' ']'") : long_path_scope. *) Local Open Scope monoidal_scope. (** [twist] is an equivalence which we will call [twiste]. *) Local Definition twiste a b c : cat_tensor a (cat_tensor b c) $<~> cat_tensor b (cat_tensor a c) := cate_adjointify (twist a b c) (twist b a c) (twist_twist a b c) (twist_twist b a c). (** *** Finer naturality *) (** The naturality postulates we have for [twist] are natural in all their arguments similtaneously. We show the finer naturality of [twist] in each argument separately as this becomes more useful in practice. *) Definition twist_nat_l {a a'} (f : a $-> a') b c : twist a' b c $o fmap10 cat_tensor f (cat_tensor b c) $== fmap01 cat_tensor b (fmap10 cat_tensor f c) $o twist a b c. Proof. refine ((_ $@L _^$) $@ twist_nat a a' b b c c f (Id _) (Id _) $@ (_ $@R _)). - refine (fmap12 _ _ _ $@ fmap10_is_fmap11 _ _ _). rapply fmap11_id. - refine (fmap12 _ _ _ $@ fmap01_is_fmap11 _ _ _). rapply fmap10_is_fmap11. Defined. Definition twist_nat_m a {b b'} (g : b $-> b') c : twist a b' c $o fmap01 cat_tensor a (fmap10 cat_tensor g c) $== fmap10 cat_tensor g (cat_tensor a c) $o twist a b c. Proof. refine ((_ $@L _^$) $@ twist_nat a a b b' c c (Id _) g (Id _) $@ (_ $@R _)). - refine (fmap12 _ _ _ $@ fmap01_is_fmap11 _ _ _). rapply fmap10_is_fmap11. - refine (fmap12 _ _ _ $@ fmap10_is_fmap11 _ _ _). rapply fmap11_id. Defined. Definition twist_nat_r a b {c c'} (h : c $-> c') : twist a b c' $o fmap01 cat_tensor a (fmap01 cat_tensor b h) $== fmap01 cat_tensor b (fmap01 cat_tensor a h) $o twist a b c. Proof. refine ((_ $@L _^$) $@ twist_nat a a b b c c' (Id _) (Id _) h $@ (_ $@R _)). - refine (fmap12 _ _ _ $@ fmap01_is_fmap11 _ _ _). rapply fmap01_is_fmap11. - refine (fmap12 _ _ _ $@ fmap01_is_fmap11 _ _ _). rapply fmap01_is_fmap11. Defined. (** *** Movement lemmas *) (** Here we collect lemmas about moving morphisms around in a diagram. We could have created [cate_moveL_eM]-style lemmas for [CatIsEquiv] but this leads to a lot of unnecessary unfolding and duplication. It is typically easier to use a hand crafted lemma for each situation. *) (** TODO: A lot of these proofs are copy and pasted between lemmas. We need to work out an efficient way of proving them. *) (** **** Moving [twist] *) Definition moveL_twistL a b c d f (g : d $-> _) : twist a b c $o f $== g -> f $== twist b a c $o g. Proof. intros p. apply (cate_monic_equiv (twiste a b c)). nrefine ((cate_buildequiv_fun _ $@R _) $@ p $@ _ $@ cat_assoc _ _ _). refine ((cat_idl _)^$ $@ (_^$ $@R _)). refine ((cate_buildequiv_fun _ $@R _) $@ _). apply twist_twist. Defined. Definition moveL_twistR a b c d f (g : _ $-> d) : f $o twist a b c $== g -> f $== g $o twist b a c. Proof. intros p. apply (cate_epic_equiv (twiste a b c)). refine (_ $@ (cat_assoc _ _ _)^$). refine (_ $@ (_ $@L ((_ $@L cate_buildequiv_fun _) $@ _)^$)). 2: apply twist_twist. refine ((_ $@L _) $@ _ $@ (cat_idr _)^$). 1: apply cate_buildequiv_fun. exact p. Defined. Definition moveR_twistL a b c d f (g : d $-> _) : f $== twist b a c $o g -> twist a b c $o f $== g. Proof. intros p; symmetry; apply moveL_twistL; symmetry; exact p. Defined. Definition moveR_twistR a b c d f (g : _ $-> d) : f $== g $o twist b a c -> f $o twist a b c $== g. Proof. intros p; symmetry; apply moveL_twistR; symmetry; exact p. Defined. Definition moveL_fmap01_twistL a b c d e f (g : e $-> _) : fmap01 cat_tensor a (twist b c d) $o f $== g -> f $== fmap01 cat_tensor a (twist c b d) $o g. Proof. intros p. apply (cate_monic_equiv (emap01 cat_tensor a (twiste b c d))). refine (_ $@ cat_assoc _ _ _). refine (_ $@ (_ $@R _)). 2: { refine (_ $@ (_^$ $@R _)). 2: apply cate_buildequiv_fun. refine ((fmap_id _ _)^$ $@ fmap2 _ _ $@ fmap_comp _ _ _). refine (_^$ $@ (_^$ $@R _)). 2: apply cate_buildequiv_fun. apply twist_twist. } refine ((_ $@R _) $@ p $@ (cat_idl _)^$). refine (cate_buildequiv_fun _ $@ fmap02 _ _ _). apply cate_buildequiv_fun. Defined. Definition moveL_fmap01_twistR a b c d e f (g : _ $-> e) : f $o fmap01 cat_tensor a (twist b c d) $== g -> f $== g $o fmap01 cat_tensor a (twist c b d). Proof. intros p. apply (cate_epic_equiv (emap01 cat_tensor a (twiste b c d))). refine (_ $@ (cat_assoc _ _ _)^$). refine (_ $@ (_ $@L _)). 2: { refine (_^$ $@ (_ $@L _^$)). 2: apply cate_buildequiv_fun. refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _). refine ((_ $@L _) $@ _). 1: apply cate_buildequiv_fun. apply twist_twist. } refine ((_ $@L _) $@ p $@ (cat_idr _)^$). refine (cate_buildequiv_fun _ $@ fmap02 _ _ _). apply cate_buildequiv_fun. Defined. Definition moveR_fmap01_twistL a b c d e f (g : e $-> _) : f $== fmap01 cat_tensor a (twist c b d) $o g -> fmap01 cat_tensor a (twist b c d) $o f $== g. Proof. intros p; symmetry; apply moveL_fmap01_twistL; symmetry; exact p. Defined. Definition moveR_fmap01_twistR a b c d e f (g : _ $-> e) : f $== g $o fmap01 cat_tensor a (twist c b d) -> f $o fmap01 cat_tensor a (twist b c d) $== g. Proof. intros p; symmetry; apply moveL_fmap01_twistR; symmetry; exact p. Defined. (** *** The associator *) (** Using [braide] and [twiste] we can build an associator. *) Definition associator_twist' a b c : cat_tensor a (cat_tensor b c) $<~> cat_tensor (cat_tensor a b) c. Proof. (** We can build the associator out of [braide] and [twiste]. *) refine (braide _ _ $oE _). nrefine (twiste _ _ _ $oE _). exact (emap01 cat_tensor a (braide _ _)). Defined. (** We would like to be able to unfold [associator_twist'] to the underlying morphisms. We use this lemma to make that process easier. *) Definition associator_twist'_unfold a b c : cate_fun (associator_twist' a b c) $== braid c (cat_tensor a b) $o (twist a c b $o fmap01 cat_tensor a (braid b c)). Proof. refine (cate_buildequiv_fun _ $@ (_ $@@ cate_buildequiv_fun _)). nrefine (cate_buildequiv_fun _ $@ (_ $@@ cate_buildequiv_fun _)). refine (cate_buildequiv_fun _ $@ fmap2 _ _). apply cate_buildequiv_fun. Defined. (** Now we can use [associator_twist'] and show that it is a natural equivalence in each variable. *) Instance associator_twist : Associator cat_tensor. Proof. snrapply Build_Associator. - exact associator_twist'. - snrapply Build_Is1Natural. simpl; intros [[a b] c] [[a' b'] c'] [[f g] h]; simpl in f, g, h. (** To prove naturality it will be easier to reason about squares. *) change (?w $o ?x $== ?y $o ?z) with (Square z w x y). (** First we remove all the equivalences from the equation. *) nrapply hconcatL. 1: apply associator_twist'_unfold. nrapply hconcatR. 2: apply associator_twist'_unfold. (** The first square involving [braid] on its own is a naturality square. *) nrapply vconcat. 2: rapply braid_nat. (** The second square is just the naturality of twist. *) nrapply vconcat. 2: apply twist_nat. nrapply hconcatL. 2: nrapply hconcatR. 1,3: symmetry; rapply fmap01_is_fmap11. (** Leaving us with a square with a functor application. *) rapply fmap11_square. 1: rapply vrefl. (** We are finally left with the naturality of braid. *) apply braid_nat. Defined. (** We abbreviate the associator to [α] for the remainder of the section. *) Local Notation α := associator_twist. (** *** Unitors *) (** Since we assume the [right_unitor] exists, we can derive the [left_unitor] from it together with [braid]. *) Instance left_unitor_twist : LeftUnitor cat_tensor cat_tensor_unit. Proof. snrapply Build_NatEquiv'. - snrapply Build_NatTrans. + exact (fun a => right_unitor a $o braid cat_tensor_unit a). + snrapply Build_Is1Natural. intros a b f. change (?w $o ?x $== ?y $o ?z) with (Square z w x y). nrapply vconcat. 2: rapply (isnat right_unitor f). rapply braid_nat_r. - intros a. rapply compose_catie'. rapply catie_braid. Defined. (** *** Triangle *) (** The triangle identity can easily be proven by rearranging the diagram, cancelling and using naturality of [braid]. *) Instance triangle_twist : TriangleIdentity cat_tensor cat_tensor_unit. Proof. intros a b. refine (_ $@ (_ $@L _)^$). 2: apply associator_twist'_unfold. refine (fmap02 _ a (cate_buildequiv_fun _) $@ _); cbn. refine (fmap01_comp _ _ _ _ $@ _). do 2 refine (_ $@ cat_assoc _ _ _). refine ((twist_unitor _ _ $@ (_ $@R _)) $@R _). apply braid_nat_r. Defined. (** *** Pentagon *) Local Open Scope long_path_scope. Instance pentagon_twist : PentagonIdentity cat_tensor. Proof. clear twist_unitor right_unitor cat_tensor_unit. intros a b c d. refine ((_ $@@ _) $@ _ $@ ((fmap02 _ _ _ $@ _)^$ $@@ (_ $@@ (fmap20 _ _ _ $@ _))^$)). 1,2,4,6,7: apply associator_twist'_unfold. 2: refine (fmap01_comp _ _ _ _ $@ (_ $@L (fmap01_comp _ _ _ _))). 2: refine (fmap10_comp _ _ _ _ $@ (_ $@L (fmap10_comp _ _ _ _))). (** We use a notation defined above that shows the base type of the groupoid hom and formats the equation in a way that is easier to read. *) (** Normalize brackets on LHS *) refine (cat_assoc _ _ _ $@ _). refine (_ $@L (cat_assoc _ _ _) $@ _). do 4 refine ((cat_assoc _ _ _)^$ $@ _). (** Normalize brackets on RHS *) refine (_ $@ (((cat_assoc _ _ _) $@R _) $@R _)). do 2 refine (_ $@ ((cat_assoc _ _ _) $@R _)). do 2 refine (_ $@ cat_assoc _ _ _). (** Cancel two braids next to eachother. *) apply moveL_fmap01_fmap01_braidR. apply moveL_fmap01_twistR. refine (_ $@ (cat_assoc _ _ _)^$). refine (_ $@ ((_ $@L _) $@ cat_idr _)^$). 2: refine ((fmap01_comp _ _ _ _)^$ $@ fmap02 _ _ _ $@ fmap01_id _ _ _). 2: apply braid_braid. (** *) apply moveL_twistR. refine (_ $@ (cat_assoc _ _ _)^$). refine (_ $@ (_ $@L _)). 2: apply braid_nat_r. refine (_ $@ cat_assoc _ _ _). apply moveL_fmap01_fmap01_braidR. refine (_ $@ (cat_assoc _ _ _)^$). refine (_ $@ (_ $@L _)). 2: apply braid_nat_r. refine (_ $@ cat_assoc _ _ _). apply moveL_fmap01_twistR. refine (_ $@ _). 2: apply braid_nat_r. (** Putting things back. *) apply moveR_fmap01_twistR. apply moveR_fmap01_fmap01_braidR. apply moveR_twistR. apply moveR_fmap01_twistR. (** There are two braids on the RHS of the LHS that can be swapped. *) refine (cat_assoc _ _ _ $@ _). refine ((_ $@L _) $@ _). 1: refine ((fmap01_comp _ _ _ _)^$ $@ fmap02 _ _ _ $@ fmap01_comp _ _ _ _). 1: apply braid_nat_r. refine ((cat_assoc _ _ _)^$ $@ _). apply moveR_fmap01_braidR. (** Naturality of twist on the RHS of the LHS. *) refine (cat_assoc _ _ _ $@ _). refine ((_ $@L _) $@ _). 1: apply twist_nat_m. refine ((cat_assoc _ _ _)^$ $@ _). (** Moving some things to the RHS so that we can braid and cancel on the LHS. *) apply moveR_twistR. refine (cat_assoc _ _ _ $@ _). refine ((_ $@L _) $@ _). 1: apply braid_nat_l. refine ((cat_assoc _ _ _)^$ $@ _). apply moveR_braidR. refine (cat_assoc _ _ _ $@ _). refine ((_ $@L _) $@ cat_idr _ $@ _). 1: refine ((fmap01_comp _ _ _ _)^$ $@ fmap02 _ _ _ $@ fmap01_id _ _ _). 1: apply braid_braid. apply moveL_braidR. apply moveL_twistR. apply moveL_fmap01_braidR. (** We are almost at the desired 9-gon. Now we cancel the inner braid on the LHS. *) do 4 refine (_ $@ (cat_assoc _ _ _)^$). do 3 refine (cat_assoc _ _ _ $@ _). refine (_ $@L _). apply moveR_twistL. do 4 refine (_ $@ cat_assoc _ _ _). refine ((cat_assoc _ _ _)^$ $@ _). (** Now we move terms around in order to get a homotopy in [a ⊗ (b ⊗ (d ⊗ c)) $-> d ⊗ (c ⊗ (a ⊗ b))]. *) apply moveL_fmap01_twistR. apply moveL_twistR. do 2 refine (_ $@ (cat_assoc _ _ _)^$). do 3 refine (cat_assoc _ _ _ $@ _). apply moveL_twistL. refine (_ $@ cat_assoc _ _ _). do 4 refine ((cat_assoc _ _ _)^$ $@ _). apply moveR_twistR. apply moveR_fmap01_twistR. do 3 refine (_ $@ (cat_assoc _ _ _)^$). do 2 refine (cat_assoc _ _ _ $@ _). apply moveL_fmap01_braidL. do 2 refine (_ $@ cat_assoc _ _ _). do 3 refine ((cat_assoc _ _ _)^$ $@ _). (** And finally, this is the 9-gon we asked for. *) apply twist_9_gon. Defined. Local Close Scope long_path_scope. (** *** Hexagon *) Instance hexagon_twist : HexagonIdentity cat_tensor. Proof. intros a b c; simpl. refine (((_ $@L _) $@R _) $@ _ $@ (_ $@@ (_ $@R _))^$). 1,3,4: apply associator_twist'_unfold. do 2 refine (((cat_assoc _ _ _)^$ $@R _) $@ _). refine (cat_assoc _ _ _ $@ (_ $@L _) $@ _). { refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _). apply braid_braid. } refine (cat_idr _ $@ _). refine (_ $@ cat_assoc _ _ _). refine (_ $@ ((cat_assoc _ _ _)^$ $@R _)). refine (_ $@ (((cat_idr _)^$ $@ (_ $@L _^$)) $@R _)). 2: apply braid_braid. refine (((braid_nat_r _)^$ $@R _) $@ _). refine (cat_assoc _ _ _ $@ (_ $@L _) $@ (cat_assoc _ _ _)^$). refine (_ $@ cat_assoc _ _ _). apply moveL_fmap01_braidR. apply twist_hexagon. Defined. (** *** Conclusion *) (** In conclusion, we have proven the following: *) (** There is a monoidal structure on [A]. *) Instance ismonoidal_twist : IsMonoidal A cat_tensor cat_tensor_unit := {}. (** There is a symmetric monoidal category on [A]. *) Instance issymmetricmonoidal_twist : IsSymmetricMonoidal A cat_tensor cat_tensor_unit := {}. (** TODO: WIP *) (** Here is a hexagon involving only twist *) Definition twist_hex' a b c d : fmap01 cat_tensor c (twist a b d) $o twist a c (cat_tensor b d) $o fmap01 cat_tensor a (twist b c d) $== twist b c (cat_tensor a d) $o fmap01 cat_tensor b (twist a c d) $o twist a b (cat_tensor c d). Proof. pose proof (twist_hexagon c a d $@ cat_assoc _ _ _) as p. apply moveR_twistL in p. apply moveR_fmap01_braidL in p. apply (fmap02 cat_tensor b) in p. refine (_ $@ ((_ $@L p) $@R _)); clear p. apply moveL_twistR. apply moveL_twistL. refine (_ $@ (fmap01_comp _ _ _ _)^$). (** TODO simplify *) apply moveR_twistL. refine (_ $@ cat_assoc _ _ _). Abort. End TwistConstruction. Coq-HoTT-9.0/theories/WildCat/NatTrans.v000066400000000000000000000354471474641544500200450ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. Require Import WildCat.Equiv. Require Import WildCat.Square. Require Import WildCat.Opposite. (** * Wild Natural Transformations *) (** ** Transformations *) (** *** Definition *) (** A transformation is simply a family of 1-cells over some base type [A] between the sections of two dependent functions [F] and [G]. In most cases [F] and [G] will be non-dependent functors. *) Definition Transformation {A : Type} {B : A -> Type} `{forall x, IsGraph (B x)} (F G : forall (x : A), B x) := forall (a : A), F a $-> G a. (** This lets us apply transformations to things. Identity Coercion tells coq that this coercion is in fact definitionally the identity map so it doesn't need to insert it, but merely rewrite definitionally when typechecking. *) Identity Coercion fun_trans : Transformation >-> Funclass. Notation "F $=> G" := (Transformation F G). (** The identity transformation between a functor and itself is the identity function at the section. *) Definition trans_id {A B : Type} `{Is01Cat B} (F : A -> B) : F $=> F := fun a => Id (F a). (** Transformations can be composed pointwise. *) Definition trans_comp {A B : Type} `{Is01Cat B} {F G K : A -> B} (gamma : G $=> K) (alpha : F $=> G) : F $=> K := fun a => gamma a $o alpha a. (** Transformations can be prewhiskered by a function. This means we precompose both sides of the transformation with a function. *) Definition trans_prewhisker {A B : Type} {C : B -> Type} {F G : forall x, C x} `{Is01Cat B} `{!forall x, IsGraph (C x)} `{!forall x, Is01Cat (C x)} (gamma : F $=> G) (K : A -> B) : F o K $=> G o K := gamma o K. (** Transformations can be postwhiskered by a function. This means we postcompose both sides of the transformation with a function. *) Definition trans_postwhisker {A B C : Type} {F G : A -> B} (K : B -> C) `{Is01Cat B, Is01Cat C, !Is0Functor K} (gamma : F $=> G) : K o F $=> K o G := fun a => fmap K (gamma a). (** A transformation in the opposite category is simply a transformation in the original category with the direction swapped. *) Definition trans_op {A} {B} `{Is01Cat B} (F : A -> B) (G : A -> B) (alpha : F $=> G) : Transformation (A:=A^op) (B:=fun _ => B^op) G (F : A^op -> B^op) := alpha. (** ** Naturality *) (** A transformation is 1-natural if there exists a 2-cell witnessing the naturality square. The codomain of the transformation must be a wild 1-category. *) Class Is1Natural {A B : Type} `{IsGraph A, Is1Cat B} (F : A -> B) `{!Is0Functor F} (G : A -> B) `{!Is0Functor G} (alpha : F $=> G) := Build_Is1Natural' { isnat {a a'} (f : a $-> a') : alpha a' $o fmap F f $== fmap G f $o alpha a; (** We also include the transposed naturality square in the definition so that opposite natural transformations are definitionally involutive. In most cases, this will be constructed to be the inverse of the [isnat] field. *) isnat_tr {a a'} (f : a $-> a') : fmap G f $o alpha a $== alpha a' $o fmap F f; }. Arguments Is1Natural {A B} {isgraph_A} {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B} F {is0functor_F} G {is0functor_G} alpha : rename. Arguments isnat {_ _ _ _ _ _ _ _ _ _ _} alpha {alnat _ _} f : rename. Arguments isnat_tr {_ _ _ _ _ _ _ _ _ _ _} alpha {alnat _ _} f : rename. (** We coerce naturality proofs to their naturality square as the [isnat] projection can be unwieldy in certain situations where the transformation is difficult to write down. This allows for the naturality proof to be used directly. *) Coercion isnat : Is1Natural >-> Funclass. Definition Build_Is1Natural {A B : Type} `{IsGraph A} `{Is1Cat B} {F G : A -> B} `{!Is0Functor F, !Is0Functor G} (alpha : F $=> G) (isnat : forall a a' (f : a $-> a'), alpha a' $o fmap F f $== fmap G f $o alpha a) : Is1Natural F G alpha. Proof. snrapply Build_Is1Natural'. - exact isnat. - intros a a' f. exact (isnat a a' f)^$. Defined. (** The identity transformation is 1-natural. *) Global Instance is1natural_id {A B : Type} `{IsGraph A} `{Is1Cat B} (F : A -> B) `{!Is0Functor F} : Is1Natural F F (trans_id F). Proof. snrapply Build_Is1Natural. intros a b f; cbn. refine (cat_idl _ $@ (cat_idr _)^$). Defined. (** The composite of 1-natural transformations is 1-natural. *) Global Instance is1natural_comp {A B : Type} `{IsGraph A} `{Is1Cat B} {F G K : A -> B} `{!Is0Functor F} `{!Is0Functor G} `{!Is0Functor K} (gamma : G $=> K) `{!Is1Natural G K gamma} (alpha : F $=> G) `{!Is1Natural F G alpha} : Is1Natural F K (trans_comp gamma alpha). Proof. snrapply Build_Is1Natural. intros a b f; unfold trans_comp; cbn. refine (cat_assoc _ _ _ $@ (_ $@L isnat alpha f) $@ _). refine (cat_assoc_opp _ _ _ $@ (isnat gamma f $@R _) $@ _). apply cat_assoc. Defined. (** Prewhiskering a transformation preserves naturality. *) Global Instance is1natural_prewhisker {A B C : Type} {F G : B -> C} (K : A -> B) `{IsGraph A, Is01Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G, !Is0Functor K} (gamma : F $=> G) `{L : !Is1Natural F G gamma} : Is1Natural (F o K) (G o K) (trans_prewhisker gamma K). Proof. snrapply Build_Is1Natural. intros x y f; unfold trans_prewhisker; cbn. exact (isnat gamma _). Defined. (** Postwhiskering a transformation preserves naturality. *) Global Instance is1natural_postwhisker {A B C : Type} {F G : A -> B} (K : B -> C) `{IsGraph A, Is1Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G, !Is0Functor K, !Is1Functor K} (gamma : F $=> G) `{L : !Is1Natural F G gamma} : Is1Natural (K o F) (K o G) (trans_postwhisker K gamma). Proof. snrapply Build_Is1Natural. intros x y f; unfold trans_postwhisker; cbn. refine (_^$ $@ _ $@ _). 1,3: rapply fmap_comp. rapply fmap2. exact (isnat gamma _). Defined. (** Modifying a transformation to something pointwise equal preserves naturality. *) Definition is1natural_homotopic {A B : Type} `{Is01Cat A} `{Is1Cat B} {F : A -> B} `{!Is0Functor F} {G : A -> B} `{!Is0Functor G} {alpha : F $=> G} (gamma : F $=> G) `{!Is1Natural F G gamma} (p : forall a, alpha a $== gamma a) : Is1Natural F G alpha. Proof. snrapply Build_Is1Natural. intros a b f. exact ((p b $@R _) $@ isnat gamma f $@ (_ $@L (p a)^$)). Defined. (** The opposite of a natural transformation is natural. *) Global Instance is1natural_op A B `{Is01Cat A} `{Is1Cat B} (F : A -> B) `{!Is0Functor F} (G : A -> B) `{!Is0Functor G} (alpha : F $=> G) `{!Is1Natural F G alpha} : Is1Natural (G : A^op -> B^op) (F : A^op -> B^op) (trans_op F G alpha). Proof. unfold op. snrapply Build_Is1Natural'. - intros a b. exact (isnat_tr alpha). - intros a b. exact (isnat alpha). Defined. (** ** Natural transformations *) (** Here we give the bundled definition of a natural transformation which can be more convenient to work with in certain situations. It forms the Hom type of the functor category. *) Record NatTrans {A B : Type} `{IsGraph A} `{Is1Cat B} {F G : A -> B} {ff : Is0Functor F} {fg : Is0Functor G} := { #[reversible=no] trans_nattrans :> F $=> G; is1natural_nattrans : Is1Natural F G trans_nattrans; }. Arguments NatTrans {A B} {isgraph_A} {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B} F G {is0functor_F} {is0functor_G} : rename. Arguments Build_NatTrans {A B isgraph_A isgraph_B is2graph_B is01cat_B is1cat_B F G is0functor_F is0functor_G} alpha isnat_alpha : rename. Global Existing Instance is1natural_nattrans. Definition issig_NatTrans {A B : Type} `{IsGraph A} `{Is1Cat B} (F G : A -> B) {ff : Is0Functor F} {fg : Is0Functor G} : _ <~> NatTrans F G := ltac:(issig). Definition nattrans_id {A B : Type} (F : A -> B) `{IsGraph A, Is1Cat B, !Is0Functor F} : NatTrans F F := Build_NatTrans (trans_id F) _. Definition nattrans_comp {A B : Type} {F G K : A -> B} `{IsGraph A, Is1Cat B, !Is0Functor F, !Is0Functor G, !Is0Functor K} : NatTrans G K -> NatTrans F G -> NatTrans F K := fun alpha beta => Build_NatTrans (trans_comp alpha beta) _. Definition nattrans_prewhisker {A B C : Type} {F G : B -> C} `{IsGraph A, Is1Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G} (alpha : NatTrans F G) (K : A -> B) `{!Is0Functor K} : NatTrans (F o K) (G o K) := Build_NatTrans (trans_prewhisker alpha K) _. Definition nattrans_postwhisker {A B C : Type} {F G : A -> B} (K : B -> C) `{IsGraph A, Is1Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G, !Is0Functor K, !Is1Functor K} : NatTrans F G -> NatTrans (K o F) (K o G) := fun alpha => Build_NatTrans (trans_postwhisker K alpha) _. Definition nattrans_op {A B : Type} `{Is01Cat A} `{Is1Cat B} {F G : A -> B} `{!Is0Functor F, !Is0Functor G} : NatTrans F G -> NatTrans (A:=A^op) (B:=B^op) (G : A^op -> B^op) (F : A^op -> B^op) := fun alpha => Build_NatTrans (trans_op F G alpha) _. (** ** Natural equivalences *) (** Natural equivalences are families of equivalences that are natural. *) Record NatEquiv {A B : Type} `{IsGraph A} `{HasEquivs B} {F G : A -> B} `{!Is0Functor F, !Is0Functor G} := { #[reversible=no] cat_equiv_natequiv :> forall a, F a $<~> G a ; is1natural_natequiv :: Is1Natural F G (fun a => cat_equiv_natequiv a) ; }. Arguments NatEquiv {A B} {isgraph_A} {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B} {hasequivs_B} F G {is0functor_F} {is0functor_G} : rename. Arguments Build_NatEquiv {A B} {isgraph_A} {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B} {hasequivs_B} F G {is0functor_F} {is0functor_G} e isnat_e: rename. Definition issig_NatEquiv {A B : Type} `{IsGraph A} `{HasEquivs B} (F G : A -> B) `{!Is0Functor F, !Is0Functor G} : _ <~> NatEquiv F G := ltac:(issig). (** From a given natural equivalence, we can get the underlying natural transformation. *) Lemma nattrans_natequiv {A B : Type} `{IsGraph A} `{HasEquivs B} {F G : A -> B} `{!Is0Functor F, !Is0Functor G} : NatEquiv F G -> NatTrans F G. Proof. intros alpha. nrapply Build_NatTrans. rapply (is1natural_natequiv alpha). Defined. (** Throws a warning, but can probably be ignored. *) Global Set Warnings "-ambiguous-paths". Coercion nattrans_natequiv : NatEquiv >-> NatTrans. (** The above coercion sometimes doesn't trigger when it should, so we add the following. *) Definition isnat_natequiv {A B : Type} `{IsGraph A} `{HasEquivs B} {F G : A -> B} `{!Is0Functor F, !Is0Functor G} (alpha : NatEquiv F G) {a a' : A} (f : a $-> a') := isnat (nattrans_natequiv alpha) f. (** Often we wish to build a natural equivalence from a natural transformation and a pointwise proof that it is an equivalence. *) Definition Build_NatEquiv' {A B : Type} `{IsGraph A} `{HasEquivs B} {F G : A -> B} `{!Is0Functor F, !Is0Functor G} (alpha : NatTrans F G) `{forall a, CatIsEquiv (alpha a)} : NatEquiv F G. Proof. snrapply Build_NatEquiv. - intro a. refine (Build_CatEquiv (alpha a)). - snrapply Build_Is1Natural'. + intros a a' f. refine ((cate_buildequiv_fun _ $@R _) $@ _ $@ (_ $@L cate_buildequiv_fun _)^$). apply (isnat alpha). + intros a a' f. refine ((_ $@L cate_buildequiv_fun _) $@ _ $@ (cate_buildequiv_fun _ $@R _)^$). apply (isnat_tr alpha). Defined. Definition natequiv_id {A B : Type} `{IsGraph A} `{HasEquivs B} {F : A -> B} `{!Is0Functor F} : NatEquiv F F := Build_NatEquiv' (nattrans_id F). Definition natequiv_compose {A B} {F G H : A -> B} `{IsGraph A} `{HasEquivs B} `{!Is0Functor F, !Is0Functor G, !Is0Functor H} (alpha : NatEquiv G H) (beta : NatEquiv F G) : NatEquiv F H := Build_NatEquiv' (nattrans_comp alpha beta). Definition natequiv_prewhisker {A B C} {H K : B -> C} `{IsGraph A, HasEquivs B, HasEquivs C, !Is0Functor H, !Is0Functor K} (alpha : NatEquiv H K) (F : A -> B) `{!Is0Functor F} : NatEquiv (H o F) (K o F) := Build_NatEquiv' (nattrans_prewhisker alpha F). Definition natequiv_postwhisker {A B C} {F G : A -> B} `{IsGraph A, HasEquivs B, HasEquivs C, !Is0Functor F, !Is0Functor G} (K : B -> C) (alpha : NatEquiv F G) `{!Is0Functor K, !Is1Functor K} : NatEquiv (K o F) (K o G). Proof. srefine (Build_NatEquiv' (nattrans_postwhisker K alpha)). 2: unfold nattrans_postwhisker, trans_postwhisker; cbn. all: exact _. Defined. Lemma natequiv_op {A B : Type} `{Is01Cat A} `{HasEquivs B} {F G : A -> B} `{!Is0Functor F, !Is0Functor G} : NatEquiv F G -> NatEquiv (G : A^op -> B^op) F. Proof. intros [a n]. snrapply Build_NatEquiv. 1: exact a. by rapply is1natural_op. Defined. (** We can form the inverse natural equivalence by inverting each map in the family. The naturality proof follows from standard lemmas about inverses. *) Definition natequiv_inverse {A B : Type} `{IsGraph A} `{HasEquivs B} {F G : A -> B} `{!Is0Functor F, !Is0Functor G} : NatEquiv F G -> NatEquiv G F. Proof. intros [alpha I]. snrapply Build_NatEquiv. 1: exact (fun a => (alpha a)^-1$). snrapply Build_Is1Natural'. + intros X Y f. apply vinverse, I. + intros X Y f. apply hinverse, I. Defined. (** This lemma might seem unnecessery since as functions ((F o G) o K) and (F o (G o K)) are definitionally equal. But the functor instances of both sides are different. This can be a nasty trap since you cannot see this difference clearly. *) Definition natequiv_functor_assoc_ff_f {A B C D : Type} `{IsGraph A, HasEquivs B, HasEquivs C, HasEquivs D} (F : C -> D) (G : B -> C) (K : A -> B) `{!Is0Functor F, !Is0Functor G, !Is0Functor K} : NatEquiv ((F o G) o K) (F o (G o K)). Proof. snrapply Build_NatEquiv. 1: intro; reflexivity. snrapply Build_Is1Natural. intros X Y f. refine (cat_prewhisker (id_cate_fun _) _ $@ cat_idl _ $@ _^$). refine (cat_postwhisker _ (id_cate_fun _) $@ cat_idr _). Defined. (** ** Pointed natural transformations *) Definition PointedTransformation {B C : Type} `{Is1Cat B, Is1Gpd C} `{IsPointed B, IsPointed C} (F G : B -->* C) := {eta : F $=> G & eta (point _) $== bp_pointed F $@ (bp_pointed G)^$}. Notation "F $=>* G" := (PointedTransformation F G) (at level 70). Definition ptransformation_inverse {B C : Type} `{Is1Cat B, Is1Gpd C} `{IsPointed B, IsPointed C} (F G : B -->* C) : (F $=>* G) -> (G $=>* F). Proof. intros [h p]. exists (fun x => (h x)^$). refine (gpd_rev2 p $@ _). refine (gpd_rev_pp _ _ $@ _). refine (_ $@L _). apply gpd_rev_rev. Defined. Notation "h ^*$" := (ptransformation_inverse _ _ h) (at level 5). Definition ptransformation_compose {B C : Type} `{Is1Cat B, Is1Gpd C} `{IsPointed B, IsPointed C} {F0 F1 F2 : B -->* C} : (F0 $=>* F1) -> (F1 $=>* F2) -> (F0 $=>* F2). Proof. intros [h0 p0] [h1 p1]. exists (trans_comp h1 h0). refine ((p1 $@R _) $@ (_ $@L p0) $@ _); unfold gpd_comp; cbn. refine (cat_assoc _ _ _ $@ _). rapply (fmap _). apply gpd_h_Vh. Defined. Notation "h $@* k" := (ptransformation_compose h k) (at level 40). (* TODO: *) (* Morphisms of natural transformations - Modifications *) (* Since [Transformation] is dependent, we can define a modification to be a transformation together with a cylinder condition. This doesn't seem to be too useful as of yet however. We would also need better ways to write down cylinders. *) Coq-HoTT-9.0/theories/WildCat/Opposite.v000066400000000000000000000072631474641544500201100ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. (** ** Opposite categories *) Definition op (A : Type) := A. Notation "A ^op" := (op A). (** This stops typeclass search from trying to unfold op. *) #[global] Typeclasses Opaque op. Global Instance isgraph_op {A : Type} `{IsGraph A} : IsGraph A^op. Proof. apply Build_IsGraph. unfold op; exact (fun a b => b $-> a). Defined. Global Instance is01cat_op {A : Type} `{Is01Cat A} : Is01Cat A^op. Proof. apply Build_Is01Cat. + cbv; exact Id. + cbv; exact (fun a b c g f => f $o g). Defined. (** We don't invert 2-cells as this is op on the first level. *) Global Instance is2graph_op {A : Type} `{Is2Graph A} : Is2Graph A^op. Proof. intros a b; unfold op in *; cbn; exact _. Defined. Global Instance is1cat_op {A : Type} `{Is1Cat A} : Is1Cat A^op. Proof. snrapply Build_Is1Cat; unfold op in *; cbv in *. - intros a b. apply is01cat_hom. - intros a b. apply is0gpd_hom. - intros a b c h. srapply Build_Is0Functor. intros f g p. cbn in *. exact (p $@R h). - intros a b c h. srapply Build_Is0Functor. intros f g p. cbn in *. exact (h $@L p). - intros a b c d f g h; exact (cat_assoc_opp h g f). - intros a b c d f g h; exact (cat_assoc h g f). - intros a b f; exact (cat_idr f). - intros a b f; exact (cat_idl f). Defined. Global Instance is1cat_strong_op A `{Is1Cat_Strong A} : Is1Cat_Strong (A ^op). Proof. snrapply Build_Is1Cat_Strong. 1-4: exact _. all: cbn. - intros a b c d f g h; exact (cat_assoc_opp_strong h g f). - intros a b c d f g h; exact (cat_assoc_strong h g f). - intros a b f. apply cat_idr_strong. - intros a b f. apply cat_idl_strong. Defined. (** Opposite groupoids *) Global Instance is0gpd_op A `{Is0Gpd A} : Is0Gpd (A^op). Proof. srapply Build_Is0Gpd; unfold op in *; cbn in *. intros a b. apply gpd_rev. Defined. Global Instance op0gpd_fun A `{Is0Gpd A} : Is0Functor( (fun x => x) : A^op -> A). Proof. srapply Build_Is0Functor; unfold op in *; cbn. intros a b. exact (fun f => f^$). Defined. (** ** Opposite functors *) Global Instance is0functor_op A B (F : A -> B) `{IsGraph A, IsGraph B, x : !Is0Functor F} : Is0Functor (F : A^op -> B^op). Proof. apply Build_Is0Functor. intros a b; cbn. apply fmap. assumption. Defined. Global Instance is1functor_op A B (F : A -> B) `{Is1Cat A, Is1Cat B, !Is0Functor F, !Is1Functor F} : Is1Functor (F : A^op -> B^op). Proof. apply Build_Is1Functor; cbn. - intros a b; rapply fmap2. - exact (fmap_id F). - intros a b c f g; exact (fmap_comp F g f). Defined. (** Since [Is01Cat] structures are definitionally involutive (see test/WildCat/Opposite.v), we can use [is0functor_op] to transform in the reverse direction as well. This result makes that much easier to use in practice. *) Global Instance is0functor_op' A B (F : A^op -> B^op) `{IsGraph A, IsGraph B, Fop : !Is0Functor (F : A^op -> B^op)} : Is0Functor (F : A -> B) := is0functor_op A^op B^op F. (** [Is1Cat] structures are also definitionally involutive. *) Global Instance is1functor_op' A B (F : A^op -> B^op) `{Is1Cat A, Is1Cat B, !Is0Functor (F : A^op -> B^op), Fop2 : !Is1Functor (F : A^op -> B^op)} : Is1Functor (F : A -> B) := is1functor_op A^op B^op F. Global Instance hasmorext_op {A : Type} `{H0 : HasMorExt A} : HasMorExt A^op. Proof. snrapply Build_HasMorExt. intros a b f g. refine (@isequiv_Htpy_path _ _ _ _ _ H0 b a f g). Defined. Global Instance isinitial_op_isterminal {A : Type} `{Is1Cat A} (x : A) {t : IsTerminal x} : IsInitial (A := A^op) x := t. Global Instance isterminal_op_isinitial {A : Type} `{Is1Cat A} (x : A) {i : IsInitial x} : IsTerminal (A := A^op) x := i. Coq-HoTT-9.0/theories/WildCat/Paths.v000066400000000000000000000074501474641544500173630ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids. Require Import WildCat.Core WildCat.TwoOneCat WildCat.NatTrans. (** * Path groupoids as wild categories *) (** Not global instances for now *) (** These are written so that they can be augmented with an existing wildcat structure. For instance, you may partially define a wildcat and ask for paths for the higher cells. *) (** Any type is a graph with morphisms given by the identity type. *) Definition isgraph_paths (A : Type) : IsGraph A := {| Hom := paths |}. (** Any graph is a 2-graph with 2-cells given by the identity type. *) Definition is2graph_paths (A : Type) `{IsGraph A} : Is2Graph A := fun _ _ => isgraph_paths _. (** Any 2-graph is a 3-graph with 3-cells given by the identity type. *) Definition is3graph_paths (A : Type) `{Is2Graph A} : Is3Graph A := fun _ _ => is2graph_paths _. (** We assume these as instances for the rest of the file with a low priority. *) Local Existing Instances isgraph_paths is2graph_paths is3graph_paths | 10. (** Any type has composition and identity morphisms given by path concatenation and reflexivity. *) Global Instance is01cat_paths (A : Type) : Is01Cat A := {| Id := @idpath _ ; cat_comp := fun _ _ _ x y => concat y x |}. (** Any type has a 0-groupoid structure with inverse morphisms given by path inversion. *) Global Instance is0gpd_paths (A : Type) : Is0Gpd A := {| gpd_rev := @inverse _ |}. (** Postcomposition is a 0-functor when the 2-cells are paths. *) Global Instance is0functor_cat_postcomp_paths (A : Type) `{Is01Cat A} (a b c : A) (g : b $-> c) : Is0Functor (cat_postcomp a g). Proof. snrapply Build_Is0Functor. exact (@ap _ _ (cat_postcomp a g)). Defined. (** Precomposition is a 0-functor when the 2-cells are paths. *) Global Instance is0functor_cat_precomp_paths (A : Type) `{Is01Cat A} (a b c : A) (f : a $-> b) : Is0Functor (cat_precomp c f). Proof. snrapply Build_Is0Functor. exact (@ap _ _ (cat_precomp c f)). Defined. (** Any type is a 1-category with n-morphisms given by paths. *) Global Instance is1cat_paths {A : Type} : Is1Cat A. Proof. snrapply Build_Is1Cat. - exact _. - exact _. - exact _. - exact _. - exact (@concat_p_pp A). - exact (@concat_pp_p A). - exact (@concat_p1 A). - exact (@concat_1p A). Defined. (** Any type is a 1-groupoid with morphisms given by paths. *) Global Instance is1gpd_paths {A : Type} : Is1Gpd A. Proof. snrapply Build_Is1Gpd. - exact (@concat_pV A). - exact (@concat_Vp A). Defined. (** Any type is a 2-category with higher morphhisms given by paths. *) Global Instance is21cat_paths {A : Type} : Is21Cat A. Proof. snrapply Build_Is21Cat. - exact _. - exact _. - intros x y z p. snrapply Build_Is1Functor. + intros a b q r. exact (ap (fun x => whiskerR x _)). + reflexivity. + intros a b c. exact (whiskerR_pp p). - intros x y z p. snrapply Build_Is1Functor. + intros a b q r. exact (ap (whiskerL p)). + reflexivity. + intros a b c. exact (whiskerL_pp p). - intros a b c q r s t h g. exact (concat_whisker q r s t h g)^. - intros a b c d q r. snrapply Build_Is1Natural. intros s t h. apply concat_p_pp_nat_r. - intros a b c d q r. snrapply Build_Is1Natural. intros s t h. apply concat_p_pp_nat_m. - intros a b c d q r. snrapply Build_Is1Natural. intros s t h. apply concat_p_pp_nat_l. - intros a b. snrapply Build_Is1Natural. intros p q h; cbn. apply moveL_Mp. lhs nrapply concat_p_pp. exact (whiskerR_p1 h). - intros a b. snrapply Build_Is1Natural. intros p q h. apply moveL_Mp. lhs rapply concat_p_pp. exact (whiskerL_1p h). - intros a b c d e p q r s. lhs nrapply concat_p_pp. exact (pentagon p q r s). - intros a b c p q. exact (triangulator p q). Defined. Coq-HoTT-9.0/theories/WildCat/PointedCat.v000066400000000000000000000103371474641544500203340ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core WildCat.Opposite. Require Import WildCat.Equiv. (** A wild category is pointed if the initial and terminal object are the same. *) Class IsPointedCat (A : Type) `{Is1Cat A} := { zero_object : A; isinitial_zero_object : IsInitial zero_object; isterminal_zero_object : IsTerminal zero_object; }. Global Existing Instance isinitial_zero_object. Global Existing Instance isterminal_zero_object. (** The zero morphism between objects [a] and [b] of a pointed category [A] is the unique morphism that factors throguh the zero object. *) Definition zero_morphism {A : Type} `{IsPointedCat A} {a b : A} : a $-> b := (mor_initial _ b) $o (mor_terminal a _). Section ZeroLaws. Context {A : Type} `{IsPointedCat A} {a b c : A} (f : a $-> b) (g : b $-> c). Definition cat_zero_source (h : zero_object $-> a) : h $== zero_morphism := (mor_initial_unique _ _ _)^$ $@ (mor_initial_unique _ _ _). Definition cat_zero_target (h : a $-> zero_object) : h $== zero_morphism := (mor_terminal_unique _ _ _)^$ $@ (mor_terminal_unique _ _ _). (** We show the last two arguments so that end pointes can easily be specified. *) Arguments zero_morphism {_ _ _ _ _ _} _ _. Definition cat_zero_l : zero_morphism b c $o f $== zero_morphism a c. Proof. refine (cat_assoc _ _ _ $@ (_ $@L _^$)). apply mor_terminal_unique. Defined. Definition cat_zero_r : g $o zero_morphism a b $== zero_morphism a c. Proof. refine ((_ $@R _) $@ cat_assoc _ _ _)^$. apply mor_initial_unique. Defined. (** Any morphism which factors through an object equivalent to the zero object is homotopic to the zero morphism. *) Definition cat_zero_m `{!HasEquivs A} (be : b $<~> zero_object) : g $o f $== zero_morphism a c. Proof. refine (_ $@L (compose_V_hh be f)^$ $@ _). refine (cat_assoc_opp _ _ _ $@ _). refine (_ $@L (mor_terminal_unique a _ _)^$ $@ _). exact ((mor_initial_unique _ _ _)^$ $@R _). Defined. End ZeroLaws. (** We make the last two arguments explicit so that end points can easily be specified. We had to do this again, since the section encapsulated the previous attempt. *) Local Arguments zero_morphism {_ _ _ _ _ _} _ _. (** A functor is pointed if it preserves the zero object. *) Class IsPointedFunctor {A B : Type} (F : A -> B) `{Is1Functor A B F} := { preservesinitial_pfunctor : PreservesInitial F ; preservesterminal_pfunctor : PreservesTerminal F ; }. Global Existing Instances preservesinitial_pfunctor preservesterminal_pfunctor. (** Here is an alternative constructor using preservation of the zero object. This requires more structure on the categories however. *) Definition Build_IsPointedFunctor' {A B : Type} (F : A -> B) `{Is1Cat A, Is1Cat B, !Is0Functor F, !Is1Functor F} `{!IsPointedCat A, !IsPointedCat B, !HasEquivs A, !HasEquivs B} (p : F zero_object $<~> zero_object) : IsPointedFunctor F. Proof. apply Build_IsPointedFunctor. + intros x inx. rapply isinitial_cate. symmetry. refine (p $oE _). rapply (emap F _). rapply cate_isinitial. + intros x tex. rapply isterminal_cate. refine (p $oE _). rapply (emap F _). rapply cate_isterminal. Defined. (** Pointed functors preserve the zero object upto isomorphism. *) Lemma pfunctor_zero {A B : Type} (F : A -> B) `{IsPointedCat A, IsPointedCat B, !HasEquivs B, !Is0Functor F, !Is1Functor F, !IsPointedFunctor F} : F zero_object $<~> zero_object. Proof. rapply cate_isinitial. Defined. (** Pointed functors preserve the zero morphism upto homotopy *) Lemma fmap_zero_morphism {A B : Type} (F : A -> B) `{IsPointedCat A, IsPointedCat B, !HasEquivs B, !Is0Functor F, !Is1Functor F, !IsPointedFunctor F} {a b : A} : fmap F (zero_morphism a b) $== zero_morphism (F a) (F b). Proof. refine (fmap_comp F _ _ $@ _). refine (_ $@R _ $@ _). 1: nrapply fmap_initial; [exact _]. refine (_ $@L _ $@ _). 1: nrapply fmap_terminal; [exact _]. rapply cat_zero_m. rapply pfunctor_zero. Defined. (** Opposite category of a pointed category is also pointed. *) Global Instance ispointedcat_op {A : Type} `{IsPointedCat A} : IsPointedCat A^op. Proof. snrapply Build_IsPointedCat. 1: unfold op; exact zero_object. 1,2: exact _. Defined. Coq-HoTT-9.0/theories/WildCat/Prod.v000066400000000000000000000232471474641544500172120ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. Require Import WildCat.Equiv. Require Import Types.Prod. (** * Product categories *) (** Products preserve (0,1)-categories. *) Global Instance isgraph_prod A B `{IsGraph A} `{IsGraph B} : IsGraph (A * B) := Build_IsGraph (A * B) (fun x y => (fst x $-> fst y) * (snd x $-> snd y)). Global Instance is01cat_prod A B `{Is01Cat A} `{Is01Cat B} : Is01Cat (A * B). Proof. econstructor. - intros [a b]; exact (Id a, Id b). - intros [a1 b1] [a2 b2] [a3 b3] [f1 g1] [f2 g2]; cbn in *. exact (f1 $o f2 , g1 $o g2). Defined. Global Instance is0gpd_prod A B `{Is0Gpd A} `{Is0Gpd B} : Is0Gpd (A * B). Proof. srapply Build_Is0Gpd. intros [x1 x2] [y1 y2] [f1 f2]. cbn in *. exact ( (f1^$, f2^$) ). Defined. Global Instance is2graph_prod A B `{Is2Graph A, Is2Graph B} : Is2Graph (A * B). Proof. intros [x1 x2] [y1 y2]. rapply isgraph_prod. Defined. Global Instance is1cat_prod A B `{Is1Cat A} `{Is1Cat B} : Is1Cat (A * B). Proof. srapply Build_Is1Cat. - intros [x1 x2] [y1 y2] [z1 z2] [h1 h2]. srapply Build_Is0Functor. intros [f1 f2] [g1 g2] [p1 p2]; cbn in *. exact ( h1 $@L p1 , h2 $@L p2 ). - intros [x1 x2] [y1 y2] [z1 z2] [h1 h2]. srapply Build_Is0Functor. intros [f1 f2] [g1 g2] [p1 p2]; cbn in *. exact ( p1 $@R h1 , p2 $@R h2 ). - intros [a1 a2] [b1 b2] [c1 c2] [d1 d2] [f1 f2] [g1 g2] [h1 h2]. cbn in *. exact(cat_assoc f1 g1 h1, cat_assoc f2 g2 h2). - intros [a1 a2] [b1 b2] [c1 c2] [d1 d2] [f1 f2] [g1 g2] [h1 h2]. cbn in *. exact(cat_assoc_opp f1 g1 h1, cat_assoc_opp f2 g2 h2). - intros [a1 a2] [b1 b2] [f1 f2]. cbn in *. exact (cat_idl _, cat_idl _). - intros [a1 a2] [b1 b2] [g1 g2]. cbn in *. exact (cat_idr _, cat_idr _). Defined. (** Product categories inherit equivalences *) Global Instance hasequivs_prod A B `{HasEquivs A} `{HasEquivs B} : HasEquivs (A * B). Proof. srefine (Build_HasEquivs (A * B) _ _ _ _ (fun a b => (fst a $<~> fst b) * (snd a $<~> snd b)) _ _ _ _ _ _ _ _ _). 1:intros a b f; exact (CatIsEquiv (fst f) * CatIsEquiv (snd f)). all:cbn; intros a b f. - split; [ exact (fst f) | exact (snd f) ]. - split; exact _. - intros [fe1 fe2]; split. + exact (Build_CatEquiv (fst f)). + exact (Build_CatEquiv (snd f)). - intros [fe1 fe2]; cbn; split; apply cate_buildequiv_fun. - split; [ exact ((fst f)^-1$) | exact ((snd f)^-1$) ]. - split; apply cate_issect. - split; apply cate_isretr. - intros g r s; split. + exact (catie_adjointify (fst f) (fst g) (fst r) (fst s)). + exact (catie_adjointify (snd f) (snd g) (snd r) (snd s)). Defined. Global Instance isequivs_prod A B `{HasEquivs A} `{HasEquivs B} {a1 a2 : A} {b1 b2 : B} {f : a1 $-> a2} {g : b1 $-> b2} {ef : CatIsEquiv f} {eg : CatIsEquiv g} : @CatIsEquiv (A*B) _ _ _ _ _ (a1,b1) (a2,b2) (f,g) := (ef,eg). (** ** Product functors *) Global Instance is0functor_prod_functor {A B C D : Type} (F : A -> B) (G : C -> D) `{Is0Functor _ _ F, Is0Functor _ _ G} : Is0Functor (functor_prod F G). Proof. apply Build_Is0Functor. intros [a1 c1] [a2 c2] [f g]. exact (fmap F f , fmap G g). Defined. Global Instance is1functor_prod_functor {A B C D : Type} (F : A -> B) (G : C -> D) `{Is1Functor _ _ F, Is1Functor _ _ G} : Is1Functor (functor_prod F G). Proof. apply Build_Is1Functor. - intros [a1 c1] [a2 c2] [f1 g1] [f2 g2] [p q]. exact (fmap2 F p , fmap2 G q). - intros [a c]. exact (fmap_id F a, fmap_id G c). - intros [a1 c1] [a2 c2] [a3 c3] [f1 g1] [f2 g2]. exact (fmap_comp F f1 f2 , fmap_comp G g1 g2). Defined. Global Instance is0functor_fst {A B : Type} `{!IsGraph A, !IsGraph B} : Is0Functor (@fst A B). Proof. apply Build_Is0Functor. intros ? ? f; exact (fst f). Defined. Global Instance is0functor_snd {A B : Type} `{!IsGraph A, !IsGraph B} : Is0Functor (@snd A B). Proof. apply Build_Is0Functor. intros ? ? f; exact (snd f). Defined. (** Swap functor *) Global Instance is0functor_equiv_prod_symm {A B : Type} `{IsGraph A, IsGraph B} : Is0Functor (equiv_prod_symm A B). Proof. snrapply Build_Is0Functor. intros a b. apply equiv_prod_symm. Defined. Global Instance is1functor_equiv_prod_symm {A B : Type} `{Is1Cat A, Is1Cat B} : Is1Functor (equiv_prod_symm A B). Proof. snrapply Build_Is1Functor. - intros a b f g. apply equiv_prod_symm. - intros a. reflexivity. - reflexivity. Defined. (** Inclusions into a product category are functorial. *) Global Instance is0functor_prod_include10 {A B : Type} `{IsGraph A, Is01Cat B} (b : B) : Is0Functor (fun a : A => (a, b)). Proof. nrapply Build_Is0Functor. intros a c f. exact (f, Id b). Defined. Global Instance is1functor_prod_include10 {A B : Type} `{Is1Cat A, Is1Cat B} (b : B) : Is1Functor (fun a : A => (a, b)). Proof. nrapply Build_Is1Functor. - intros a c f g p. exact (p, Id _). - intros a; reflexivity. - intros a c d f g. exact (Id _, (cat_idl _)^$). Defined. Global Instance is0functor_prod_include01 {A B : Type} `{Is01Cat A, IsGraph B} (a : A) : Is0Functor (fun b : B => (a, b)). Proof. nrapply Build_Is0Functor. intros b c f. exact (Id a, f). Defined. Global Instance is1functor_prod_include01 {A B : Type} `{Is1Cat A, Is1Cat B} (a : A) : Is1Functor (fun b : B => (a, b)). Proof. nrapply Build_Is1Functor. - intros b c f g p. exact (Id _, p). - intros b; reflexivity. - intros b c d f g. exact ((cat_idl _)^$, Id _). Defined. (** Functors from a product category are functorial in each argument *) Global Instance is0functor_functor_uncurried01 {A B C : Type} `{Is01Cat A, IsGraph B, IsGraph C} (F : A * B -> C) `{!Is0Functor F} (a : A) : Is0Functor (fun b => F (a, b)) := is0functor_compose (fun b => (a, b)) F. Global Instance is1functor_functor_uncurried01 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A * B -> C) `{!Is0Functor F, !Is1Functor F} (a : A) : Is1Functor (fun b => F (a, b)) := is1functor_compose (fun b => (a, b)) F. Global Instance is0functor_functor_uncurried10 {A B C : Type} `{IsGraph A, Is01Cat B, IsGraph C} (F : A * B -> C) `{!Is0Functor F} (b : B) : Is0Functor (fun a => F (a, b)) := is0functor_compose (fun a => (a, b)) F. Global Instance is1functor_functor_uncurried10 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A * B -> C) `{!Is0Functor F, !Is1Functor F} (b : B) : Is1Functor (fun a => F (a, b)) := is1functor_compose (fun a => (a, b)) F. (** Conversely, if [F : A * B -> C] is a 0-functor in each variable, then it is a 0-functor. *) Definition is0functor_prod_is0functor {A B C : Type} `{IsGraph A, IsGraph B, Is01Cat C} (F : A * B -> C) `{!forall a, Is0Functor (fun b => F (a,b)), !forall b, Is0Functor (fun a => F (a,b))} : Is0Functor F. Proof. snrapply Build_Is0Functor. intros [a b] [a' b'] [f g]. exact (fmap (fun a0 => F (a0,b')) f $o fmap (fun b0 => F (a,b0)) g). Defined. (** TODO: If we make this an instance, will it cause typeclass search to spin? *) Hint Immediate is0functor_prod_is0functor : typeclass_instances. (** And if [F : A * B -> C] is a 1-functor in each variable and satisfies a coherence, then it is a 1-functor. *) Definition is1functor_prod_is1functor {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A * B -> C) `{!forall a, Is0Functor (fun b => F (a,b)), !forall b, Is0Functor (fun a => F (a,b))} `{!forall a, Is1Functor (fun b => F (a,b)), !forall b, Is1Functor (fun a => F (a,b))} (bifunctor_coh : forall a0 a1 (f : a0 $-> a1) b0 b1 (g : b0 $-> b1), fmap (fun b => F (a1,b)) g $o fmap (fun a => F (a,b0)) f $== fmap (fun a => F(a,b1)) f $o fmap (fun b => F (a0,b)) g) : Is1Functor F. Proof. snrapply Build_Is1Functor. - intros [a b] [a' b'] [f g] [f' g'] [p p']; unfold fst, snd in * |- . exact (fmap2 (fun b0 => F (a,b0)) p' $@@ fmap2 (fun a0 => F (a0,b')) p). - intros [a b]. exact ((fmap_id (fun b0 => F (a,b0)) b $@@ fmap_id (fun a0 => F (a0,b)) _) $@ cat_idr _). - intros [a b] [a' b'] [a'' b''] [f g] [f' g']; unfold fst, snd in * |- . refine ((fmap_comp (fun b0 => F (a,b0)) g g' $@@ fmap_comp (fun a0 => F (a0,b'')) f f') $@ _). nrefine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ cat_assoc _ _ _). refine (cat_assoc _ _ _ $@ (_ $@L _^$) $@ cat_assoc_opp _ _ _). nrapply bifunctor_coh. Defined. Hint Immediate is1functor_prod_is1functor : typeclass_instances. (** Applies a two variable functor via uncurrying. Note that the precondition on [C] is slightly weaker than that of [Bifunctor.fmap11]. *) Definition fmap11_uncurry {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C} (F : A -> B -> C) {H2 : Is0Functor (uncurry F)} {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} (g : b0 $-> b1) : F a0 b0 $-> F a1 b1 := @fmap _ _ _ _ (uncurry F) H2 (a0, b0) (a1, b1) (f, g). Definition fmap_pair {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C} (F : A * B -> C) `{!Is0Functor F} {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} (g : b0 $-> b1) : F (a0, b0) $-> F (a1, b1) := fmap (a := (a0, b0)) (b := (a1, b1)) F (f, g). Definition fmap_pair_comp {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A * B -> C) `{!Is0Functor F, !Is1Functor F} {a0 a1 a2 : A} {b0 b1 b2 : B} (f : a0 $-> a1) (h : b0 $-> b1) (g : a1 $-> a2) (i : b1 $-> b2) : fmap_pair F (g $o f) (i $o h) $== fmap_pair F g i $o fmap_pair F f h := fmap_comp (a := (a0, b0)) (b := (a1, b1)) (c := (a2, b2)) F (f, h) (g, i). Definition fmap2_pair {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A * B -> C) `{!Is0Functor F, !Is1Functor F} {a0 a1 : A} {f f' : a0 $-> a1} (p : f $== f') {b0 b1 : B} {g g' : b0 $-> b1} (q : g $== g') : fmap_pair F f g $== fmap_pair F f' g' := fmap2 F (a := (a0, b0)) (b := (a1, b1)) (f := (f, g)) (g := (f' ,g')) (p, q). Coq-HoTT-9.0/theories/WildCat/Products.v000066400000000000000000001116171474641544500201100ustar00rootroot00000000000000Require Import Basics.Equivalences Basics.Overture Basics.Tactics. Require Import Types.Bool Types.Prod Types.Forall. Require Import WildCat.Bifunctor WildCat.Core WildCat.Equiv WildCat.EquivGpd WildCat.Forall WildCat.NatTrans WildCat.Opposite WildCat.Universe WildCat.Yoneda WildCat.ZeroGroupoid WildCat.Monoidal WildCat.MonoidalTwistConstruction. (** * Categories with products *) Definition cat_prod_corec_inv {I A : Type} `{Is1Cat A} (prod : A) (x : I -> A) (z : A) (pr : forall i, prod $-> x i) : yon_0gpd prod z $-> prod_0gpd I (fun i => yon_0gpd (x i) z). Proof. snrapply equiv_prod_0gpd_corec. intros i. exact (fmap (fun x => yon_0gpd x z) (pr i)). Defined. (* A product of an [I]-indexed family of objects of a category is an object of the category with an [I]-indexed family of projections such that the induced map is an equivalence. *) Class Product (I : Type) {A : Type} `{Is1Cat A} {x : I -> A} := Build_Product' { cat_prod : A; cat_pr : forall i : I, cat_prod $-> x i; cat_isequiv_cat_prod_corec_inv :: forall z : A, CatIsEquiv (cat_prod_corec_inv cat_prod x z cat_pr); }. Arguments Product I {A _ _ _ _} x. Arguments cat_prod I {A _ _ _ _} x {product} : rename. (** A convenience wrapper for building products *) Definition Build_Product (I : Type) {A : Type} `{Is1Cat A} {x : I -> A} (cat_prod : A) (cat_pr : forall i : I, cat_prod $-> x i) (cat_prod_corec : forall z : A, (forall i : I, z $-> x i) -> (z $-> cat_prod)) (cat_prod_beta_pr : forall (z : A) (f : forall i, z $-> x i) (i : I), cat_pr i $o cat_prod_corec z f $== f i) (cat_prod_eta_pr : forall (z : A) (f g : z $-> cat_prod), (forall i : I, cat_pr i $o f $== cat_pr i $o g) -> f $== g) : Product I x. Proof. snrapply (Build_Product' I A _ _ _ _ _ cat_prod cat_pr). intros z. nrapply isequiv_0gpd_issurjinj. nrapply Build_IsSurjInj. - intros f. exists (cat_prod_corec z f). intros i. nrapply cat_prod_beta_pr. - intros f g p. by nrapply cat_prod_eta_pr. Defined. Section Lemmata. Context (I : Type) {A : Type} {x : I -> A} `{Product I _ x}. Definition cate_cat_prod_corec_inv {z : A} : (yon_0gpd (cat_prod I x) z) $<~> prod_0gpd I (fun i => yon_0gpd (x i) z) := Build_CatEquiv (cat_prod_corec_inv (cat_prod I x) x z cat_pr). Definition cate_cat_prod_corec {z : A} : prod_0gpd I (fun i => yon_0gpd (x i) z) $<~> (yon_0gpd (cat_prod I x) z) := cate_cat_prod_corec_inv^-1$. Definition cat_prod_corec {z : A} : (forall i, z $-> x i) -> (z $-> cat_prod I x). Proof. apply cate_cat_prod_corec. Defined. (** Applying the [i]th projection after a tuple of maps gives the [ith] map. *) Lemma cat_prod_beta {z : A} (f : forall i, z $-> x i) : forall i, cat_pr i $o cat_prod_corec f $== f i. Proof. exact (cate_isretr cate_cat_prod_corec_inv f). Defined. (** The pairing map is the unique map that makes the following diagram commute. *) Lemma cat_prod_eta {z : A} (f : z $-> cat_prod I x) : cat_prod_corec (fun i => cat_pr i $o f) $== f. Proof. exact (cate_issect cate_cat_prod_corec_inv f). Defined. Local Instance is0functor_prod_0gpd_helper : Is0Functor (fun z : A^op => prod_0gpd I (fun i => yon_0gpd (x i) z)). Proof. snrapply Build_Is0Functor. intros a b f. snrapply Build_Morphism_0Gpd. - intros g i. exact (f $o g i). - snrapply Build_Is0Functor. intros g h p i. exact (f $@L p i). Defined. Local Instance is1functor_prod_0gpd_helper : Is1Functor (fun z : A^op => prod_0gpd I (fun i => yon_0gpd (x i) z)). Proof. snrapply Build_Is1Functor. - intros a b f g p r i. refine (_ $@L _). exact p. - intros a r i. nrapply cat_idl; exact _. - intros a b c f g r i. nrapply cat_assoc; exact _. Defined. Definition natequiv_cat_prod_corec_inv : NatEquiv (yon_0gpd (cat_prod I x)) (fun z : A^op => prod_0gpd I (fun i => yon_0gpd (x i) z)). Proof. snrapply Build_NatEquiv. 1: intro; nrapply cate_cat_prod_corec_inv. exact (is1natural_yoneda_0gpd (cat_prod I x) (fun z => prod_0gpd I (fun i => yon_0gpd (x i) z)) cat_pr). Defined. Lemma cat_prod_corec_eta {z : A} {f f' : forall i, z $-> x i} : (forall i, f i $== f' i) -> cat_prod_corec f $== cat_prod_corec f'. Proof. intros p. unfold cat_prod_corec. nrapply (moveL_equiv_V_0gpd cate_cat_prod_corec_inv). nrefine (cate_isretr cate_cat_prod_corec_inv _ $@ _). exact p. Defined. Lemma cat_prod_pr_eta {z : A} {f f' : z $-> cat_prod I x} : (forall i, cat_pr i $o f $== cat_pr i $o f') -> f $== f'. Proof. intros p. refine ((cat_prod_eta _)^$ $@ _ $@ cat_prod_eta _). by nrapply cat_prod_corec_eta. Defined. End Lemmata. (** *** Diagonal map *) Definition cat_prod_diag {I : Type} {A : Type} (x : A) `{Product I _ (fun _ => x)} : x $-> cat_prod I (fun _ => x) := cat_prod_corec I (fun _ => Id x). (** *** Uniqueness of products *) Definition cate_cat_prod {I J : Type} (ie : I <~> J) {A : Type} `{HasEquivs A} (x : I -> A) `{!Product I x} (y : J -> A) `{!Product J y} (e : forall i : I, x i $<~> y (ie i)) : cat_prod I x $<~> cat_prod J y. Proof. nrapply yon_equiv_0gpd. nrefine (natequiv_compose _ (natequiv_cat_prod_corec_inv _)). nrefine (natequiv_compose (natequiv_inverse (natequiv_cat_prod_corec_inv _)) _). snrapply Build_NatEquiv. - intros z. nrapply (cate_prod_0gpd ie). intros i. exact (natequiv_yon_equiv_0gpd (e i) _). - snrapply Build_Is1Natural. intros a b f g j. cbn. destruct (eisretr ie j). exact (cat_assoc_opp _ _ _). Defined. (** [I]-indexed products are unique no matter how they are constructed. *) Definition cat_prod_unique {I A : Type} `{HasEquivs A} (x : I -> A) `{!Product I x} (y : I -> A) `{!Product I y} (e : forall i : I, x i $<~> y i) : cat_prod I x $<~> cat_prod I y. Proof. exact (cate_cat_prod 1 x y e). Defined. (** *** Existence of products *) Class HasProducts (I A : Type) `{Is1Cat A} := has_products :: forall x : I -> A, Product I x. Class HasAllProducts (A : Type) `{Is1Cat A} := has_all_products :: forall I : Type, HasProducts I A. (** *** Product functor *) Global Instance is0functor_cat_prod (I : Type) (A : Type) `{HasProducts I A} : Is0Functor (fun x : I -> A => cat_prod I x). Proof. nrapply Build_Is0Functor. intros x y f. exact (cat_prod_corec I (fun i => f i $o cat_pr i)). Defined. Global Instance is1functor_cat_prod (I : Type) (A : Type) `{HasProducts I A} : Is1Functor (fun x : I -> A => cat_prod I x). Proof. nrapply Build_Is1Functor. - intros x y f g p. exact (cat_prod_corec_eta I (fun i => p i $@R cat_pr i)). - intros x. nrefine (_ $@ (cat_prod_eta I (Id _))). exact (cat_prod_corec_eta I (fun i => cat_idl _ $@ (cat_idr _)^$)). - intros x y z f g. nrapply cat_prod_pr_eta. intros i. nrefine (cat_prod_beta _ _ _ $@ _). nrefine (_ $@ cat_assoc _ _ _). symmetry. nrefine (cat_prod_beta _ _ _ $@R _ $@ _). nrefine (cat_assoc _ _ _ $@ _). nrefine (_ $@L cat_prod_beta _ _ _ $@ _). nrapply cat_assoc_opp. Defined. (** *** Categories with specific kinds of products *) Definition isterminal_prodempty {A : Type} {z : A} `{Product Empty A (fun _ => z)} : IsTerminal (cat_prod Empty (fun _ => z)). Proof. intros a. snrefine (cat_prod_corec _ _; fun f => cat_prod_pr_eta _ _); intros []. Defined. (** *** Binary products *) Class BinaryProduct {A : Type} `{Is1Cat A} (x y : A) := binary_product :: Product Bool (fun b => if b then x else y). (** A category with binary products is a category with a binary product for each pair of objects. *) Class HasBinaryProducts (A : Type) `{Is1Cat A} := has_binary_products :: forall x y : A, BinaryProduct x y. Global Instance hasbinaryproducts_hasproductsbool {A : Type} `{HasProducts Bool A} : HasBinaryProducts A := fun x y => has_products (fun b : Bool => if b then x else y). Section BinaryProducts. Context {A : Type} `{Is1Cat A} {x y : A} `{!BinaryProduct x y}. Definition cat_binprod : A := cat_prod Bool (fun b : Bool => if b then x else y). Definition cat_pr1 : cat_binprod $-> x := cat_pr true. Definition cat_pr2 : cat_binprod $-> y := cat_pr false. Definition cat_binprod_corec {z : A} (f : z $-> x) (g : z $-> y) : z $-> cat_binprod. Proof. nrapply (cat_prod_corec Bool). intros [|]. - exact f. - exact g. Defined. Definition cat_binprod_beta_pr1 {z : A} (f : z $-> x) (g : z $-> y) : cat_pr1 $o cat_binprod_corec f g $== f := cat_prod_beta _ _ true. Definition cat_binprod_beta_pr2 {z : A} (f : z $-> x) (g : z $-> y) : cat_pr2 $o cat_binprod_corec f g $== g := cat_prod_beta _ _ false. Definition cat_binprod_eta {z : A} (f : z $-> cat_binprod) : cat_binprod_corec (cat_pr1 $o f) (cat_pr2 $o f) $== f. Proof. unfold cat_binprod_corec. nrapply cat_prod_pr_eta. intros [|]. - exact (cat_binprod_beta_pr1 _ _). - exact (cat_binprod_beta_pr2 _ _). Defined. Definition cat_binprod_eta_pr {z : A} (f g : z $-> cat_binprod) : cat_pr1 $o f $== cat_pr1 $o g -> cat_pr2 $o f $== cat_pr2 $o g -> f $== g. Proof. intros p q. rapply cat_prod_pr_eta. intros [|]. - exact p. - exact q. Defined. Definition cat_binprod_corec_eta {z : A} (f f' : z $-> x) (g g' : z $-> y) : f $== f' -> g $== g' -> cat_binprod_corec f g $== cat_binprod_corec f' g'. Proof. intros p q. rapply cat_prod_corec_eta. intros [|]. - exact p. - exact q. Defined. End BinaryProducts. Arguments cat_binprod {A _ _ _ _} x y {_}. (** A convenience wrapper for building binary products *) Definition Build_BinaryProduct {A : Type} `{Is1Cat A} {x y : A} (cat_binprod : A) (cat_pr1 : cat_binprod $-> x) (cat_pr2 : cat_binprod $-> y) (cat_binprod_corec : forall z : A, z $-> x -> z $-> y -> z $-> cat_binprod) (cat_binprod_beta_pr1 : forall (z : A) (f : z $-> x) (g : z $-> y), cat_pr1 $o cat_binprod_corec z f g $== f) (cat_binprod_beta_pr2 : forall (z : A) (f : z $-> x) (g : z $-> y), cat_pr2 $o cat_binprod_corec z f g $== g) (cat_binprod_eta_pr : forall (z : A) (f g : z $-> cat_binprod), cat_pr1 $o f $== cat_pr1 $o g -> cat_pr2 $o f $== cat_pr2 $o g -> f $== g) : Product Bool (fun b => if b then x else y). Proof. snrapply (Build_Product _ cat_binprod). - intros [|]. + exact cat_pr1. + exact cat_pr2. - intros z f. nrapply cat_binprod_corec. + exact (f true). + exact (f false). - intros z f [|]. + nrapply cat_binprod_beta_pr1. + nrapply cat_binprod_beta_pr2. - intros z f g p. nrapply cat_binprod_eta_pr. + exact (p true). + exact (p false). Defined. Definition cat_binprod_eta_pr_x_xx {A : Type} `{HasBinaryProducts A} {w x y z : A} (f g : w $-> cat_binprod x (cat_binprod y z)) : cat_pr1 $o f $== cat_pr1 $o g -> cat_pr1 $o cat_pr2 $o f $== cat_pr1 $o cat_pr2 $o g -> cat_pr2 $o cat_pr2 $o f $== cat_pr2 $o cat_pr2 $o g -> f $== g. Proof. intros p q r. snrapply cat_binprod_eta_pr. - exact p. - snrapply cat_binprod_eta_pr. + exact (cat_assoc_opp _ _ _ $@ q $@ cat_assoc _ _ _). + exact (cat_assoc_opp _ _ _ $@ r $@ cat_assoc _ _ _). Defined. Definition cat_binprod_eta_pr_xx_x {A : Type} `{HasBinaryProducts A} {w x y z : A} (f g : w $-> cat_binprod (cat_binprod x y) z) : cat_pr1 $o cat_pr1 $o f $== cat_pr1 $o cat_pr1 $o g -> cat_pr2 $o cat_pr1 $o f $== cat_pr2 $o cat_pr1 $o g -> cat_pr2 $o f $== cat_pr2 $o g -> f $== g. Proof. intros p q r. snrapply cat_binprod_eta_pr. 2: exact r. snrapply cat_binprod_eta_pr. 1,2: refine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _). - exact p. - exact q. Defined. Definition cat_binprod_eta_pr_x_xx_id {A : Type} `{HasBinaryProducts A} {x y z : A} (f : cat_binprod x (cat_binprod y z) $-> cat_binprod x (cat_binprod y z)) : cat_pr1 $o f $== cat_pr1 -> cat_pr1 $o cat_pr2 $o f $== cat_pr1 $o cat_pr2 -> cat_pr2 $o cat_pr2 $o f $== cat_pr2 $o cat_pr2 -> f $== Id _. Proof. intros p q r. snrapply cat_binprod_eta_pr_x_xx. - exact (p $@ (cat_idr _)^$). - exact (q $@ (cat_idr _)^$). - exact (r $@ (cat_idr _)^$). Defined. (** From binary products, all Bool-shaped products can be constructed. This should not be an instance to avoid a cycle with [hasbinaryproducts_hasproductsbool]. *) Definition hasproductsbool_hasbinaryproducts {A : Type} `{HasBinaryProducts A} : HasProducts Bool A. Proof. intros x. snrapply Build_Product. - exact (cat_binprod (x true) (x false)). - intros [|]. + exact cat_pr1. + exact cat_pr2. - intros z f. exact (cat_binprod_corec (f true) (f false)). - intros z f [|]. + exact (cat_binprod_beta_pr1 (f true) (f false)). + exact (cat_binprod_beta_pr2 (f true) (f false)). - intros z f g p. nrapply cat_binprod_eta_pr. + exact (p true). + exact (p false). Defined. (** *** Operations on indexed products *) (** We can take the disjoint union of the index set of an indexed product if we have all binary products. This is useful for associating products in a canonical way. This leads to symmetry and associativity of binary products. *) Definition cat_prod_index_sum {I J : Type} {A : Type} `{HasBinaryProducts A} (x : I -> A) (y : J -> A) : Product I x -> Product J y -> Product (I + J) (sum_ind _ x y). Proof. intros p q. snrapply Build_Product. - exact (cat_binprod (cat_prod I x) (cat_prod J y)). - intros [i | j]. + exact (cat_pr _ $o cat_pr1). + exact (cat_pr _ $o cat_pr2). - intros z f. nrapply cat_binprod_corec. + nrapply cat_prod_corec. exact (f o inl). + nrapply cat_prod_corec. exact (f o inr). - intros z f [i | j]. + nrefine (cat_assoc _ _ _ $@ _). nrefine ((_ $@L cat_binprod_beta_pr1 _ _) $@ _). rapply cat_prod_beta. + nrefine (cat_assoc _ _ _ $@ _). nrefine ((_ $@L cat_binprod_beta_pr2 _ _) $@ _). rapply cat_prod_beta. - intros z f g r. rapply cat_binprod_eta_pr. + rapply cat_prod_pr_eta. intros i. exact ((cat_assoc _ _ _)^$ $@ r (inl i) $@ cat_assoc _ _ _). + rapply cat_prod_pr_eta. intros j. exact ((cat_assoc _ _ _)^$ $@ r (inr j) $@ cat_assoc _ _ _). Defined. (** *** Binary product functor *) (** We prove bifunctoriality of [cat_binprod : A -> A -> A] by factoring it as [cat_prod Bool o Bool_rec A]. First, we prove that [Bool_rec A : A -> A -> (Bool -> A)] is a bifunctor. *) Local Instance is0bifunctor_boolrec {A : Type} `{Is1Cat A} : Is0Bifunctor (Bool_rec A). Proof. snrapply Build_Is0Bifunctor'. 1,2: exact _. snrapply Build_Is0Functor. intros [a b] [a' b'] [f g] [ | ]. - exact f. - exact g. Defined. Local Instance is1bifunctor_boolrec {A : Type} `{Is1Cat A} : Is1Bifunctor (Bool_rec A). Proof. snrapply Build_Is1Bifunctor'. snrapply Build_Is1Functor. - intros [a b] [a' b'] [f g] [f' g'] [p q] [ | ]. + exact p. + exact q. - intros [a b] [ | ]; reflexivity. - intros [a b] [a' b'] [a'' b''] [f f'] [g g'] [ | ]; reflexivity. Defined. (** As a special case of the product functor, restriction along [Bool_rec A] yields bifunctoriality of [cat_binprod]. *) Global Instance is0bifunctor_cat_binprod {A : Type} `{HasBinaryProducts A} : Is0Bifunctor (fun x y => cat_binprod x y). Proof. pose (p:=@has_products _ _ _ _ _ _ hasproductsbool_hasbinaryproducts). exact (is0bifunctor_postcompose (Bool_rec A) (fun x => cat_prod Bool x (product:=p x))). Defined. Global Instance is1bifunctor_cat_binprod {A : Type} `{HasBinaryProducts A} : Is1Bifunctor (fun x y => cat_binprod x y). Proof. pose (p:=@has_products _ _ _ _ _ _ hasproductsbool_hasbinaryproducts). exact (is1bifunctor_postcompose (Bool_rec A) (fun x => cat_prod Bool x (product:=p x))). Defined. (** Binary products are functorial in each argument. *) Global Instance is0functor_cat_binprod_l {A : Type} `{HasBinaryProducts A} (y : A) : Is0Functor (fun x => cat_binprod x y). Proof. exact (is0functor10_bifunctor _ y). Defined. Global Instance is1functor_cat_binprod_l {A : Type} `{HasBinaryProducts A} (y : A) : Is1Functor (fun x => cat_binprod x y). Proof. exact (is1functor10_bifunctor _ y). Defined. Global Instance is0functor_cat_binprod_r {A : Type} `{HasBinaryProducts A} (x : A) : Is0Functor (fun y => cat_binprod x y). Proof. exact (is0functor01_bifunctor _ x). Defined. Global Instance is1functor_cat_binprod_r {A : Type} `{HasBinaryProducts A} (x : A) : Is1Functor (fun y => cat_binprod x y). Proof. exact (is1functor01_bifunctor _ x). Defined. (** [cat_binprod_corec] is also functorial in each morphsism. *) Global Instance is0functor_cat_binprod_corec_l {A : Type} `{HasBinaryProducts A} {x y z : A} (g : z $-> y) : Is0Functor (fun f : z $-> y => cat_binprod_corec f g). Proof. snrapply Build_Is0Functor. intros f f' p. by nrapply cat_binprod_corec_eta. Defined. Global Instance is0functor_cat_binprod_corec_r {A : Type} `{HasBinaryProducts A} {x y z : A} (f : z $-> x) : Is0Functor (fun g : z $-> x => cat_binprod_corec f g). Proof. snrapply Build_Is0Functor. intros g h p. by nrapply cat_binprod_corec_eta. Defined. Definition cat_pr1_fmap01_binprod {A : Type} `{HasBinaryProducts A} (a : A) {x y : A} (g : x $-> y) : cat_pr1 $o fmap01 (fun x y => cat_binprod x y) a g $== cat_pr1 := cat_binprod_beta_pr1 _ _ $@ cat_idl _. Definition cat_pr1_fmap10_binprod {A : Type} `{HasBinaryProducts A} {x y : A} (f : x $-> y) (a : A) : cat_pr1 $o fmap10 (fun x y => cat_binprod x y) f a $== f $o cat_pr1 := cat_binprod_beta_pr1 _ _. Definition cat_pr1_fmap11_binprod {A : Type} `{HasBinaryProducts A} {w x y z : A} (f : w $-> y) (g : x $-> z) : cat_pr1 $o fmap11 (fun x y => cat_binprod x y) f g $== f $o cat_pr1 := cat_binprod_beta_pr1 _ _. Definition cat_pr2_fmap01_binprod {A : Type} `{HasBinaryProducts A} (a : A) {x y : A} (g : x $-> y) : cat_pr2 $o fmap01 (fun x y => cat_binprod x y) a g $== g $o cat_pr2 := cat_binprod_beta_pr2 _ _. Definition cat_pr2_fmap10_binprod {A : Type} `{HasBinaryProducts A} {x y : A} (f : x $-> y) (a : A) : cat_pr2 $o fmap10 (fun x y => cat_binprod x y) f a $== cat_pr2 := cat_binprod_beta_pr2 _ _ $@ cat_idl _. Definition cat_pr2_fmap11_binprod {A : Type} `{HasBinaryProducts A} {w x y z : A} (f : w $-> y) (g : x $-> z) : cat_pr2 $o fmap11 (fun x y => cat_binprod x y) f g $== g $o cat_pr2 := cat_binprod_beta_pr2 _ _. (** *** Diagonal *) (** Annoyingly this doesn't follow directly from the general diagonal since [fun b => if b then x else x] is not definitionally equal to [fun _ => x]. *) Definition cat_binprod_diag {A : Type} `{Is1Cat A} (x : A) `{!BinaryProduct x x} : x $-> cat_binprod x x. Proof. snrapply cat_binprod_corec; exact (Id _). Defined. (** *** Lemmas about [cat_binprod_corec] *) Definition cat_binprod_fmap01_corec {A : Type} `{Is1Cat A, !HasBinaryProducts A} {w x y z : A} (f : w $-> z) (g : x $-> y) (h : w $-> x) : fmap01 (fun x y => cat_binprod x y) z g $o cat_binprod_corec f h $== cat_binprod_corec f (g $o h). Proof. snrapply cat_binprod_eta_pr. - nrefine (cat_assoc_opp _ _ _ $@ _). refine ((_ $@R _) $@ cat_assoc _ _ _ $@ cat_idl _ $@ _ $@ _^$). 1-3: rapply cat_binprod_beta_pr1. - nrefine (cat_assoc_opp _ _ _ $@ _). refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ _^$). 1-3: rapply cat_binprod_beta_pr2. Defined. Definition cat_binprod_fmap10_corec {A : Type} `{Is1Cat A, !HasBinaryProducts A} {w x y z : A} (f : x $-> y) (g : w $-> x) (h : w $-> z) : fmap10 (fun x y => cat_binprod x y) f z $o cat_binprod_corec g h $== cat_binprod_corec (f $o g) h. Proof. snrapply cat_binprod_eta_pr. - refine (cat_assoc_opp _ _ _ $@ _). refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ _^$). 1-3: nrapply cat_binprod_beta_pr1. - refine (cat_assoc_opp _ _ _ $@ _). refine ((_ $@R _) $@ cat_assoc _ _ _ $@ cat_idl _ $@ _ $@ _^$). 1-3: nrapply cat_binprod_beta_pr2. Defined. Definition cat_binprod_fmap11_corec {A : Type} `{Is1Cat A, !HasBinaryProducts A} {v w x y z : A} (f : w $-> y) (g : x $-> z) (h : v $-> w) (i : v $-> x) : fmap11 (fun x y => cat_binprod x y) f g $o cat_binprod_corec h i $== cat_binprod_corec (f $o h) (g $o i). Proof. snrapply cat_binprod_eta_pr. - refine (cat_assoc_opp _ _ _ $@ _). refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ _^$). 1-3: nrapply cat_binprod_beta_pr1. - nrefine (cat_assoc_opp _ _ _ $@ _). refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ _^$). 1-3: rapply cat_binprod_beta_pr2. Defined. (** *** Symmetry of binary products *) Section Symmetry. (** The requirement of having all binary products can be weakened further to having specific binary products, but it is not clear this is a useful generality. *) Context {A : Type} `{HasEquivs A} `{!HasBinaryProducts A}. Definition cat_binprod_swap (x y : A) : cat_binprod x y $-> cat_binprod y x := cat_binprod_corec cat_pr2 cat_pr1. Lemma cat_binprod_swap_cat_binprod_swap (x y : A) : cat_binprod_swap x y $o cat_binprod_swap y x $== Id _. Proof. nrapply cat_binprod_eta_pr. - refine ((cat_assoc _ _ _)^$ $@ _). nrefine (cat_binprod_beta_pr1 _ _ $@R _ $@ _). exact (cat_binprod_beta_pr2 _ _ $@ (cat_idr _)^$). - refine ((cat_assoc _ _ _)^$ $@ _). nrefine (cat_binprod_beta_pr2 _ _ $@R _ $@ _). exact (cat_binprod_beta_pr1 _ _ $@ (cat_idr _)^$). Defined. Lemma cate_binprod_swap (x y : A) : cat_binprod x y $<~> cat_binprod y x. Proof. snrapply cate_adjointify. 1,2: nrapply cat_binprod_swap. all: nrapply cat_binprod_swap_cat_binprod_swap. Defined. Definition cat_binprod_swap_corec {a b c : A} (f : a $-> b) (g : a $-> c) : cat_binprod_swap b c $o cat_binprod_corec f g $== cat_binprod_corec g f. Proof. nrapply cat_binprod_eta_pr. - refine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ (_ $@ _^$)). 1,3: nrapply cat_binprod_beta_pr1. nrapply cat_binprod_beta_pr2. - refine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ (_ $@ _^$)). 1,3: nrapply cat_binprod_beta_pr2. nrapply cat_binprod_beta_pr1. Defined. Definition cat_binprod_swap_nat {a b c d : A} (f : a $-> c) (g : b $-> d) : cat_binprod_swap c d $o fmap11 (fun x y : A => cat_binprod x y) f g $== fmap11 (fun x y : A => cat_binprod x y) g f $o cat_binprod_swap a b := cat_binprod_swap_corec _ _ $@ (cat_binprod_fmap11_corec _ _ _ _)^$. Local Instance symmetricbraiding_binprod : SymmetricBraiding (fun x y => cat_binprod x y). Proof. snrapply Build_SymmetricBraiding. - snrapply Build_NatTrans. + intros [x y]. exact (cat_binprod_swap x y). + snrapply Build_Is1Natural. intros [a b] [c d] [f g]; cbn in f, g. exact(cat_binprod_swap_nat f g). - exact cat_binprod_swap_cat_binprod_swap. Defined. End Symmetry. (** *** Associativity of binary products *) Section Associativity. Context {A : Type} `{HasEquivs A} `{!HasBinaryProducts A}. Definition cat_binprod_twist (x y z : A) : cat_binprod x (cat_binprod y z) $-> cat_binprod y (cat_binprod x z). Proof. nrapply cat_binprod_corec. - exact (cat_pr1 $o cat_pr2). - exact (fmap01 (fun x y => cat_binprod x y) x cat_pr2). Defined. Definition cat_binprod_pr1_twist (x y z : A) : cat_pr1 $o cat_binprod_twist x y z $== cat_pr1 $o cat_pr2 := cat_binprod_beta_pr1 _ _. Definition cat_binprod_pr1_pr2_twist (x y z : A) : cat_pr1 $o cat_pr2 $o cat_binprod_twist x y z $== cat_pr1. Proof. nrefine (cat_assoc _ _ _ $@ _). nrefine ((_ $@L cat_binprod_beta_pr2 _ _) $@ _). nrapply cat_pr1_fmap01_binprod. Defined. Definition cat_binprod_pr2_pr2_twist (x y z : A) : cat_pr2 $o cat_pr2 $o cat_binprod_twist x y z $== cat_pr2 $o cat_pr2. Proof. nrefine (cat_assoc _ _ _ $@ _). nrefine ((_ $@L cat_binprod_beta_pr2 _ _) $@ _). nrapply cat_pr2_fmap01_binprod. Defined. Definition cat_binprod_twist_corec {w x y z : A} (f : w $-> x) (g : w $-> y) (h : w $-> z) : cat_binprod_twist x y z $o cat_binprod_corec f (cat_binprod_corec g h) $== cat_binprod_corec g (cat_binprod_corec f h). Proof. nrapply cat_binprod_eta_pr. - nrefine (cat_assoc_opp _ _ _ $@ _). refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ (_ $@ _^$)). 1: nrapply cat_binprod_pr1_twist. 1: nrapply cat_binprod_beta_pr2. 1,2: nrapply cat_binprod_beta_pr1. - refine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _ $@ (cat_binprod_beta_pr2 _ _)^$). 1: nrapply cat_binprod_beta_pr2. nrefine (cat_binprod_fmap01_corec _ _ _ $@ _). nrapply cat_binprod_corec_eta. 1: exact (Id _). nrapply cat_binprod_beta_pr2. Defined. Lemma cat_binprod_twist_cat_binprod_twist (x y z : A) : cat_binprod_twist x y z $o cat_binprod_twist y x z $== Id _. Proof. nrapply cat_binprod_eta_pr_x_xx_id. - nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_pr1_twist _ _ _ $@R _) $@ _). nrapply cat_binprod_pr1_pr2_twist. - nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_pr1_pr2_twist _ _ _ $@R _) $@ _). nrapply cat_binprod_pr1_twist. - nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_pr2_pr2_twist _ _ _ $@R _) $@ _). nrapply cat_binprod_pr2_pr2_twist. Defined. Definition cate_binprod_twist (x y z : A) : cat_binprod x (cat_binprod y z) $<~> cat_binprod y (cat_binprod x z). Proof. snrapply cate_adjointify. 1,2: nrapply cat_binprod_twist. 1,2: nrapply cat_binprod_twist_cat_binprod_twist. Defined. Definition cat_binprod_twist_nat {a a' b b' c c' : A} (f : a $-> a') (g : b $-> b') (h : c $-> c') : cat_binprod_twist a' b' c' $o fmap11 (fun x y => cat_binprod x y) f (fmap11 (fun x y => cat_binprod x y) g h) $== fmap11 (fun x y => cat_binprod x y) g (fmap11 (fun x y => cat_binprod x y) f h) $o cat_binprod_twist a b c. Proof. nrapply cat_binprod_eta_pr. - refine (cat_assoc_opp _ _ _ $@ _). nrefine ((cat_binprod_beta_pr1 _ _ $@R _) $@ _). nrefine (cat_assoc _ _ _ $@ _). nrefine ((_ $@L _) $@ _). 1: nrapply cat_pr2_fmap11_binprod. nrefine (cat_assoc_opp _ _ _ $@ _). nrefine ((_ $@R _) $@ _). 1: nrapply cat_pr1_fmap11_binprod. nrefine (_ $@ cat_assoc _ _ _). refine (_ $@ (_^$ $@R _)). 2: nrapply cat_pr1_fmap11_binprod. refine (cat_assoc _ _ _ $@ (_ $@L _^$) $@ (cat_assoc _ _ _)^$). nrapply cat_binprod_beta_pr1. - nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr2 _ _ $@R _) $@ _). nrefine (_ $@ cat_assoc _ _ _). refine (_ $@ (_^$ $@R _)). 2: nrapply cat_pr2_fmap11_binprod. refine (_ $@ (_ $@L _^$) $@ (cat_assoc _ _ _)^$). 2: nrapply cat_binprod_beta_pr2. refine (_^$ $@ _ $@ _). 1,3: rapply fmap11_comp. rapply fmap22. 1: exact (cat_idl _ $@ (cat_idr _)^$). nrapply cat_binprod_beta_pr2. Defined. Local Existing Instance symmetricbraiding_binprod. Local Instance associator_cat_binprod : Associator (fun x y => cat_binprod x y). Proof. snrapply associator_twist. - exact _. - exact cat_binprod_twist. - exact cat_binprod_twist_cat_binprod_twist. - intros ? ? ? ? ? ?; exact cat_binprod_twist_nat. Defined. Definition cat_pr1_pr1_associator_binprod x y z : cat_pr1 $o cat_pr1 $o associator_cat_binprod x y z $== cat_pr1. Proof. nrefine ((_ $@L associator_twist'_unfold _ _ _ _ _ _ _ _) $@ _). nrefine (cat_assoc _ _ _ $@ (_ $@L (cat_assoc_opp _ _ _ $@ (_ $@R _))) $@ _). 1: nrapply cat_binprod_beta_pr1. do 2 nrefine (cat_assoc_opp _ _ _ $@ _). nrefine ((cat_binprod_pr1_pr2_twist _ _ _ $@R _) $@ _). nrapply cat_pr1_fmap01_binprod. Defined. Definition cat_pr2_pr1_associator_binprod x y z : cat_pr2 $o cat_pr1 $o associator_cat_binprod x y z $== cat_pr1 $o cat_pr2. Proof. nrefine ((_ $@L associator_twist'_unfold _ _ _ _ _ _ _ _) $@ _). nrefine (cat_assoc _ _ _ $@ (_ $@L (cat_assoc_opp _ _ _ $@ (_ $@R _))) $@ _). 1: nrapply cat_binprod_beta_pr1. do 2 nrefine (cat_assoc_opp _ _ _ $@ _). nrefine ((cat_binprod_pr2_pr2_twist _ _ _ $@R _) $@ _). nrefine (cat_assoc _ _ _ $@ (_ $@L cat_pr2_fmap01_binprod _ _) $@ _). exact (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr2 _ _ $@R _)). Defined. Definition cat_pr2_associator_binprod x y z : cat_pr2 $o associator_cat_binprod x y z $== cat_pr2 $o cat_pr2. Proof. nrefine ((_ $@L associator_twist'_unfold _ _ _ _ _ _ _ _) $@ _). nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr2 _ _ $@R _) $@ _). nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_pr1_twist _ _ _ $@R _) $@ _). nrefine (cat_assoc _ _ _ $@ (_ $@L cat_pr2_fmap01_binprod _ _) $@ _). exact (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr1 _ _ $@R _)). Defined. Definition cat_binprod_associator_corec {w x y z} (f : w $-> x) (g : w $-> y) (h : w $-> z) : associator_cat_binprod x y z $o cat_binprod_corec f (cat_binprod_corec g h) $== cat_binprod_corec (cat_binprod_corec f g) h. Proof. nrefine ((associator_twist'_unfold _ _ _ _ _ _ _ _ $@R _) $@ _). nrefine ((cat_assoc_opp _ _ _ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L (_ $@ _)) $@ _). 1: nrapply cat_binprod_fmap01_corec. 1: rapply (cat_binprod_corec_eta _ _ _ _ (Id _)). 1: nrapply cat_binprod_swap_corec. nrefine (cat_assoc _ _ _ $@ (_ $@L _) $@ _). 1: nrapply cat_binprod_twist_corec. nrapply cat_binprod_swap_corec. Defined. Context (unit : A) `{!IsTerminal unit}. Local Instance right_unitor_binprod : RightUnitor (fun x y => cat_binprod x y) unit. Proof. snrapply Build_NatEquiv. - intros a; unfold flip. snrapply cate_adjointify. + exact cat_pr1. + exact (cat_binprod_corec (Id _) (mor_terminal _ _)). + exact (cat_binprod_beta_pr1 _ _). + nrapply cat_binprod_eta_pr. * nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr1 _ _ $@R _) $@ _). exact (cat_idl _ $@ (cat_idr _)^$). * nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr2 _ _ $@R _) $@ _). exact ((mor_terminal_unique _ _ _)^$ $@ mor_terminal_unique _ _ _). - snrapply Build_Is1Natural. intros a b f. refine ((_ $@R _) $@ _ $@ (_ $@L _^$)). 1,3: nrapply cate_buildequiv_fun. nrapply cat_binprod_beta_pr1. Defined. Local Existing Instance left_unitor_twist. Local Instance triangle_binprod : TriangleIdentity (fun x y => cat_binprod x y) unit. Proof. snrapply triangle_twist. intros a b. refine (fmap02 _ _ _ $@ _ $@ ((_ $@L fmap02 _ _ _^$) $@R _)). 1,3: nrapply cate_buildequiv_fun. nrapply cat_binprod_eta_pr. - nrefine (cat_pr1_fmap01_binprod _ _ $@ _ $@ cat_assoc _ _ _). refine (_ $@ (((_^$ $@R _) $@ cat_assoc _ _ _) $@R _)). 2: nrapply cat_binprod_beta_pr1. refine ((_ $@R _) $@ _)^$. 1: nrapply cat_pr2_fmap01_binprod. nrapply cat_binprod_pr1_pr2_twist. - nrefine (cat_pr2_fmap01_binprod _ _ $@ _ $@ cat_assoc _ _ _). refine (_ $@ (((cat_binprod_beta_pr2 _ _)^$ $@R _) $@ cat_assoc _ _ _ $@R _)). refine ((_ $@R _) $@ _)^$. 1: nrapply cat_pr1_fmap01_binprod. nrapply cat_binprod_beta_pr1. Defined. Local Instance pentagon_binprod : PentagonIdentity (fun x y => cat_binprod x y). Proof. intros a b c d. nrapply cat_binprod_eta_pr_xx_x. - nrefine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _). 1: nrapply cat_pr1_pr1_associator_binprod. refine (_ $@ (_ $@L ((((_^$ $@R _) $@ cat_assoc _ _ _) $@R _) $@ cat_assoc _ _ _)) $@ cat_assoc_opp _ _ _). 2: nrapply cat_pr1_fmap10_binprod. do 2 nrefine (_ $@ (_ $@L cat_assoc_opp _ _ _)). nrapply cat_binprod_eta_pr. + nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _). refine (_ $@ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _). 1,3: nrapply cat_pr1_pr1_associator_binprod. do 2 nrefine (_ $@ cat_assoc _ _ _). refine (_^$ $@ (_^$ $@R _)). 2: nrapply cat_pr1_pr1_associator_binprod. nrapply cat_pr1_fmap01_binprod. + nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _). refine (_ $@ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _). 1,3: nrapply cat_pr2_pr1_associator_binprod. do 2 nrefine (_ $@ cat_assoc _ _ _). refine (_ $@ ((cat_assoc _ _ _ $@ (_ $@L (_^$ $@ cat_assoc _ _ _)) $@ cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _) $@R _)). 2: nrapply cat_pr2_pr1_associator_binprod. refine (_^$ $@ (_ $@L _^$) $@ cat_assoc_opp _ _ _). 2: nrapply cat_pr2_fmap01_binprod. nrefine (cat_assoc_opp _ _ _ $@ (_ $@R _)). nrapply cat_pr1_pr1_associator_binprod. - nrefine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _). 1: nrapply cat_pr2_pr1_associator_binprod. nrefine (cat_assoc _ _ _ $@ _ $@ cat_assoc_opp _ _ _). nrefine ((_ $@L cat_pr2_associator_binprod _ _ _) $@ _). refine (_ $@ (_ $@L ((((_^$ $@R _) $@ cat_assoc _ _ _) $@R _) $@ cat_assoc _ _ _))). 2: nrapply cat_pr1_fmap10_binprod. nrefine (_ $@ (_ $@L (cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _))). refine (_ $@ (_^$ $@R _) $@ cat_assoc _ _ _). 2: nrapply cat_pr2_associator_binprod. refine (_ $@ (_ $@L ((_^$ $@R _) $@ cat_assoc _ _ _ $@ cat_assoc _ _ _)) $@ cat_assoc_opp _ _ _). 2: nrapply cat_pr2_pr1_associator_binprod. refine (_ $@ (_ $@L ((_ $@L _^$) $@ cat_assoc_opp _ _ _))). 2: nrapply cat_pr2_fmap01_binprod. refine (cat_assoc_opp _ _ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _ $@ cat_assoc _ _ _). nrapply cat_pr2_pr1_associator_binprod. - nrefine (cat_assoc_opp _ _ _ $@ (cat_pr2_associator_binprod _ _ _ $@R _) $@ _). nrefine (cat_assoc _ _ _ $@ (_ $@L (cat_pr2_associator_binprod _ _ _)) $@ _). refine (_ $@ (_^$ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L (cat_assoc_opp _ _ _))). 2: nrapply cat_pr2_fmap10_binprod. refine (_ $@ cat_assoc_opp _ _ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _). 2: nrapply cat_pr2_associator_binprod. refine (cat_assoc_opp _ _ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L (cat_pr2_fmap01_binprod _ _)^$)). nrapply cat_pr2_associator_binprod. Defined. Local Instance hexagon_identity : HexagonIdentity (fun x y => cat_binprod x y). Proof. intros a b c. nrefine (cat_assoc _ _ _ $@ _ $@ cat_assoc_opp _ _ _). nrapply cat_binprod_eta_pr. { nrefine (cat_assoc_opp _ _ _ $@ (cat_pr1_fmap10_binprod _ _ $@R _) $@ _). nrefine (cat_assoc _ _ _ $@ _). nrapply cat_binprod_eta_pr. { nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _ $@ cat_assoc _ _ _). refine ((_ $@R _) $@ _ $@ (_^$ $@R _)). 1: nrapply cat_binprod_beta_pr1. 2: nrapply cat_pr1_pr1_associator_binprod. nrefine (cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _). refine ((_ $@R _) $@ _ $@ (_^$ $@R _)). 1: nrapply cat_pr2_pr1_associator_binprod. 2: nrapply cat_binprod_beta_pr1. refine (cat_assoc _ _ _ $@ (_ $@L _) $@ cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _^$). 1: nrapply cat_pr2_fmap01_binprod. 2: nrapply cat_pr2_associator_binprod. nrapply cat_binprod_beta_pr1. } nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _ $@ cat_assoc _ _ _). refine ((_ $@R _) $@ _ $@ (_^$ $@R _)). 1: nrapply cat_binprod_beta_pr2. 2: nrapply cat_pr2_pr1_associator_binprod. nrefine (cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _). refine ((_ $@R _) $@ _ $@ (((_ $@L _^$) $@ cat_assoc_opp _ _ _) $@R _)). 1: nrapply cat_pr1_pr1_associator_binprod. 2: nrapply cat_binprod_beta_pr2. refine (cat_pr1_fmap01_binprod _ _ $@ _^$). nrapply cat_pr1_pr1_associator_binprod. } nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _ $@ cat_assoc _ _ _). refine ((_ $@R _) $@ _ $@ ((_^$ $@R _) $@R _)). 1: nrapply cat_pr2_fmap10_binprod. 2: nrapply cat_pr2_associator_binprod. nrefine (cat_assoc_opp _ _ _ $@ (cat_pr2_associator_binprod _ _ _ $@R _) $@ _). nrefine (cat_assoc _ _ _ $@ (_ $@L _) $@ _ $@ (cat_assoc_opp _ _ _ $@R _)). 1: nrapply cat_pr2_fmap01_binprod. refine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _^$ $@ ((_ $@L _^$) $@R _)). 1,3: nrapply cat_binprod_beta_pr2. nrapply cat_pr2_pr1_associator_binprod. Defined. Global Instance ismonoidal_cat_binprod : IsMonoidal A (fun x y => cat_binprod x y) unit := {}. Global Instance issymmetricmonoidal_cat_binprod : IsSymmetricMonoidal A (fun x y => cat_binprod x y) unit := {}. End Associativity. (** *** Products in Type *) (** Since we use the Yoneda lemma in this file, we therefore depend on WildCat.Universe which means these instances have to live here. *) Global Instance hasbinaryproducts_type : HasBinaryProducts Type. Proof. intros X Y. snrapply Build_BinaryProduct. - exact (X * Y). - exact fst. - exact snd. - intros Z f g z. exact (f z, g z). - reflexivity. - reflexivity. - intros Z f g p q x. nrapply path_prod. + exact (p x). + exact (q x). Defined. (** Assuming [Funext], [Type] has all products. *) Global Instance hasallproducts_type `{Funext} : HasAllProducts Type. Proof. intros I x. snrapply Build_Product. - exact (forall (i : I), x i). - intros i f. exact (f i). - intros A f a i. exact (f i a). - reflexivity. - intros A f g p a. exact (path_forall _ _ (fun i => p i a)). Defined. Coq-HoTT-9.0/theories/WildCat/Sigma.v000066400000000000000000000023641474641544500173430ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. (** ** Indexed sum of categories *) Section Sigma. Context (A : Type) (B : A -> Type) `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)} `{forall a, Is0Gpd (B a)}. Global Instance isgraph_sigma : IsGraph (sig B). Proof. srapply Build_IsGraph. intros [x u] [y v]. exact {p : x = y & p # u $-> v}. Defined. Global Instance is01cat_sigma : Is01Cat (sig B). Proof. srapply Build_Is01Cat. + intros [x u]. exists idpath. exact (Id u). + intros [x u] [y v] [z w] [q g] [p f]. exists (p @ q). destruct p, q; cbn in *. exact (g $o f). Defined. Global Instance is0gpd_sigma : Is0Gpd (sig B). Proof. constructor. intros [x u] [y v] [p f]. exists (p^). destruct p; cbn in *. exact (f^$). Defined. End Sigma. Global Instance is0functor_sigma {A : Type} (B C : A -> Type) `{forall a, IsGraph (B a)} `{forall a, IsGraph (C a)} `{forall a, Is01Cat (B a)} `{forall a, Is01Cat (C a)} (F : forall a, B a -> C a) {ff : forall a, Is0Functor (F a)} : Is0Functor (fun (x:sig B) => (x.1 ; F x.1 x.2)). Proof. constructor; intros [a1 b1] [a2 b2] [p f]; cbn. exists p. destruct p; cbn in *. exact (fmap (F a1) f). Defined. Coq-HoTT-9.0/theories/WildCat/Square.v000066400000000000000000000166111474641544500175430ustar00rootroot00000000000000Require Import Basics.Overture. Require Import WildCat.Core. Require Import WildCat.Equiv. (** * Squares of morphisms in a Wild Category. *) (** These come up a lot as naturality squares. In this file we define basic operations on squares, to conveniently work with them. *) (** A Square is a cubical 2-cell in a 1-category. The order of the arguments is left-right-top-bottom: [Square l r t b]. It is defined to be [r $o t $== b $o l]. *) Definition Square@{u v w} {A : Type@{u}} `{Is1Cat@{u w v} A} {x00 x20 x02 x22 : A} (f01 : x00 $-> x02) (f21 : x20 $-> x22) (f10 : x00 $-> x20) (f12 : x02 $-> x22) : Type@{w} := f21 $o f10 $== f12 $o f01. Section Squares. (* We declare a context with a lot of variables: the first component is horizontal, the second vertical. x00 f10 x20 f30 x40 f01 f21 f41 x02 f12 x22 f32 x42 f03 f23 f43 x04 f14 x24 f34 x44 All morphisms are pointed to the right or down. *) Context {A : Type} `{Is1Cat A} {x x' x00 x20 x40 x02 x22 x42 x04 x24 x44 : A} {f10 f10' : x00 $-> x20} {f30 : x20 $-> x40} {f12 f12' : x02 $-> x22} {f32 : x22 $-> x42} {f14 : x04 $-> x24} {f34 : x24 $-> x44} {f01 f01' : x00 $-> x02} {f21 f21' : x20 $-> x22} {f41 f41' : x40 $-> x42} {f03 : x02 $-> x04} {f23 : x22 $-> x24} {f43 : x42 $-> x44}. (** We give a "constructor" and "destructor" for squares. *) Definition Build_Square (p : f21 $o f10 $== f12 $o f01) : Square f01 f21 f10 f12 := p. Definition gpdhom_square (s : Square f01 f21 f10 f12) : f21 $o f10 $== f12 $o f01 := s. (** Squares degenerate in two sides given by a single 2-morphism. *) Definition hdeg_square {f f' : x $-> x'} (p : f $== f') : Square f f' (Id x) (Id x') := cat_idr f' $@ p^$ $@ (cat_idl f)^$. Definition vdeg_square {f f' : x $-> x'} (p : f $== f') : Square (Id x) (Id x') f f' := cat_idl f $@ p $@ (cat_idr f')^$. (** Squares degenerate in two sides given by the identity 2-morphism at some morphism. *) Definition hrefl (f : x $-> x') : Square f f (Id x) (Id x') := hdeg_square (Id f). Definition vrefl (f : x $-> x') : Square (Id x) (Id x') f f := vdeg_square (Id f). (** The transpose of a square *) Definition transpose (s : Square f01 f21 f10 f12) : Square f10 f12 f01 f21 := s^$. (** Horizontal and vertical concatenation of squares *) Definition hconcat (s : Square f01 f21 f10 f12) (t : Square f21 f41 f30 f32) : Square f01 f41 (f30 $o f10) (f32 $o f12) := (cat_assoc _ _ _)^$ $@ (t $@R f10) $@ cat_assoc _ _ _ $@ (f32 $@L s) $@ (cat_assoc _ _ _)^$. Definition vconcat (s : Square f01 f21 f10 f12) (t : Square f03 f23 f12 f14) : Square (f03 $o f01) (f23 $o f21) f10 f14 := cat_assoc _ _ _ $@ (f23 $@L s) $@ (cat_assoc _ _ _)^$ $@ (t $@R f01) $@ cat_assoc _ _ _. (** If the horiztonal morphisms in a square are equivalences then we can flip the square by inverting them. *) Definition hinverse {HE : HasEquivs A} (f10 : x00 $<~> x20) (f12 : x02 $<~> x22) (s : Square f01 f21 f10 f12) : Square f21 f01 f10^-1$ f12^-1$ := (cat_idl _)^$ $@ ((cate_issect f12)^$ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L ((cat_assoc _ _ _)^$ $@ (s^$ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L cate_isretr f10) $@ cat_idr _)). (** The following four declarations modify one side of a Square using a 2-cell. The L or R indicate the side of the 2-cell. This can be thought of as rewriting the sides of a square using a homotopy. *) (** Rewriting the left edge. *) Definition hconcatL (p : f01' $== f01) (s : Square f01 f21 f10 f12) : Square f01' f21 f10 f12 := s $@ (f12 $@L p^$). (** Rewriting the right edge. *) Definition hconcatR (s : Square f01 f21 f10 f12) (p : f21' $== f21) : Square f01 f21' f10 f12 := (p $@R f10) $@ s. (** Rewriting the top edge. *) Definition vconcatL (p : f10' $== f10) (s : Square f01 f21 f10 f12) : Square f01 f21 f10' f12 := (f21 $@L p) $@ s. (** Rewriting the bottom edge. *) Definition vconcatR (s : Square f01 f21 f10 f12) (p : f12' $== f12) : Square f01 f21 f10 f12' := s $@ (p^$ $@R f01). End Squares. Section Squares2. (** We declare the context again, now that we can reuse some declarations where the variables have been inserted. This would not need to be done if coq could generalize variables within sections. Currently this is possible in Lean and Agda. *) Context {A : Type} `{HasEquivs A} {x x' x00 x20 x40 x02 x22 x42 x04 x24 x44 : A} {f10 f10' : x00 $-> x20} {f30 : x20 $-> x40} {f12 f12' : x02 $-> x22} {f32 : x22 $-> x42} {f14 : x04 $-> x24} {f34 : x24 $-> x44} {f01 f01' : x00 $-> x02} {f21 f21' : x20 $-> x22} {f41 f41' : x40 $-> x42} {f03 : x02 $-> x04} {f23 : x22 $-> x24} {f43 : x42 $-> x44}. (** If the vertical morphisms in a square are equivalences then we can flip the square by inverting them. *) Definition vinverse (f01 : x00 $<~> x02) (f21 : x20 $<~> x22) (s : Square f01 f21 f10 f12) : Square (f01^-1$) (f21^-1$) f12 f10 := transpose (hinverse _ _ (transpose s)). (** Whisker a map in one of the corners. For the bottom-left and top-right we have two choices. *) Definition whiskerTL {f : x $-> x00} (s : Square f01 f21 f10 f12) : Square (f01 $o f) f21 (f10 $o f) f12 := (cat_assoc _ _ _)^$ $@ (s $@R f) $@ cat_assoc _ _ _. Definition whiskerBR {f : x22 $-> x} (s : Square f01 f21 f10 f12) : Square f01 (f $o f21) f10 (f $o f12) := cat_assoc _ _ _ $@ (f $@L s) $@ (cat_assoc _ _ _)^$. Definition whiskerBL {f : x $<~> x02} (s : Square f01 f21 f10 f12) : Square (f^-1$ $o f01) f21 f10 (f12 $o f) := s $@ ((compose_hh_V _ _)^$ $@R f01) $@ cat_assoc _ _ _. Definition whiskerLB {f : x02 $<~> x} (s : Square f01 f21 f10 f12) : Square (f $o f01) f21 f10 (f12 $o f^-1$) := s $@ ((compose_hV_h _ _)^$ $@R f01) $@ cat_assoc _ _ _. Definition whiskerTR {f : x20 $<~> x} (s : Square f01 f21 f10 f12) : Square f01 (f21 $o f^-1$) (f $o f10) f12 := cat_assoc _ _ _ $@ (f21 $@L compose_V_hh _ _) $@ s. Definition whiskerRT {f : x $<~> x20} (s : Square f01 f21 f10 f12) : Square f01 (f21 $o f) (f^-1$ $o f10) f12 := cat_assoc _ _ _ $@ (f21 $@L compose_h_Vh _ _) $@ s. (** Moving around maps in a square. Associativity laws. *) Definition move_bottom_left {f01 : x00 $-> x} {f01' : x $-> x02} (s : Square (f01' $o f01) f21 f10 f12) : Square f01 f21 f10 (f12 $o f01') := s $@ (cat_assoc _ _ _)^$. Definition move_left_bottom {f12 : x02 $-> x} {f12' : x $-> x22} (s : Square f01 f21 f10 (f12' $o f12)) : Square (f12 $o f01) f21 f10 f12' := s $@ cat_assoc _ _ _. Definition move_right_top {f10 : x00 $-> x} {f10' : x $-> x20} (s : Square f01 f21 (f10' $o f10) f12) : Square f01 (f21 $o f10') f10 f12 := cat_assoc _ _ _ $@ s. Definition move_top_right {f21 : x20 $-> x} {f21' : x $-> x22} (s : Square f01 (f21' $o f21) f10 f12) : Square f01 f21' (f21 $o f10) f12 := (cat_assoc _ _ _)^$ $@ s. Definition fmap_square {B : Type} `{Is1Cat B} (f : A -> B) `{!Is0Functor f} `{!Is1Functor f} (s : Square f01 f21 f10 f12) : Square (fmap f f01) (fmap f f21) (fmap f f10) (fmap f f12) := (fmap_comp f _ _)^$ $@ fmap2 f s $@ fmap_comp f _ _. End Squares2. Notation "s $@h t" := (hconcat s t). Notation "s $@v t" := (vconcat s t). Notation "s $@hR p" := (hconcatR s p). Notation "s $@hL p" := (hconcatL p s). Notation "s $@vR p" := (vconcatR s p). Notation "s $@vL p" := (vconcatL p s). Notation "s ^h$" := (hinverse _ _ s). Notation "s ^v$" := (vinverse _ _ s). Coq-HoTT-9.0/theories/WildCat/Sum.v000066400000000000000000000045061474641544500170470ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. (** ** Sum categories *) Global Instance isgraph_sum A B `{IsGraph A} `{IsGraph B} : IsGraph (A + B). Proof. econstructor. intros [a1 | b1] [a2 | b2]. + exact (a1 $-> a2). + exact Empty. + exact Empty. + exact (b1 $-> b2). Defined. Global Instance is01cat_sum A B `{ Is01Cat A } `{ Is01Cat B} : Is01Cat (A + B). Proof. srapply Build_Is01Cat. - intros [a | b]; cbn; apply Id. - intros [a | b] [a1 | b1] [a2 | b2]; try contradiction; cbn; apply cat_comp. Defined. Global Instance is2graph_sum A B `{Is2Graph A, Is2Graph B} : Is2Graph (A + B). Proof. intros x y; apply Build_IsGraph. destruct x as [a1 | b1], y as [a2 | b2]; try contradiction; cbn; apply Hom. Defined. (* Note: [try contradiction] deals with empty cases. *) Global Instance is1cat_sum A B `{ Is1Cat A } `{ Is1Cat B} : Is1Cat (A + B). Proof. snrapply Build_Is1Cat. - intros x y. srapply Build_Is01Cat; destruct x as [a1 | b1], y as [a2 | b2]. 2,3,6,7: contradiction. all: cbn. 1,2: exact Id. 1,2: intros a b c; apply cat_comp. - intros x y; srapply Build_Is0Gpd. destruct x as [a1 | b1], y as [a2 | b2]. 2,3: contradiction. all: cbn; intros f g; apply gpd_rev. - intros x y z h; srapply Build_Is0Functor. intros f g p. destruct x as [a1 | b1], y as [a2 | b2]. 2,3: contradiction. all: destruct z as [a3 | b3]. 2,3: contradiction. all: cbn in *; change (f $== g) in p; exact (h $@L p). - intros x y z h; srapply Build_Is0Functor. intros f g p. destruct x as [a1 | b1], y as [a2 | b2]. 2,3: contradiction. all: destruct z as [a3 | b3]. 2,3: contradiction. all: cbn in *; change (f $== g) in p; exact (p $@R h). - intros [a1 | b1] [a2 | b2]. 2,3: contradiction. all: intros [a3 | b3]. 2,3: contradiction. all: intros [a4 | b4]. 2-3: contradiction. all: intros f g h; cbn; apply cat_assoc. - intros [a1 | b1] [a2 | b2]. 2,3: contradiction. all: intros [a3 | b3]. 2,3: contradiction. all: intros [a4 | b4]. 2-3: contradiction. all: intros f g h; cbn; apply cat_assoc_opp. - intros [a1 | b1] [a2 | b2] f. 2, 3: contradiction. all: cbn; apply cat_idl. - intros [a1 | b1] [a2 | b2] f. 2, 3: contradiction. all: cbn; apply cat_idr. Defined. Coq-HoTT-9.0/theories/WildCat/TwoOneCat.v000066400000000000000000000073661474641544500201550ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. Require Import WildCat.NatTrans. (** * Wild (2,1)-categories *) Class Is21Cat (A : Type) `{Is1Cat A, !Is3Graph A} := { is1cat_hom : forall (a b : A), Is1Cat (a $-> b) ; is1gpd_hom : forall (a b : A), Is1Gpd (a $-> b) ; is1functor_postcomp : forall (a b c : A) (g : b $-> c), Is1Functor (cat_postcomp a g) ; is1functor_precomp : forall (a b c : A) (f : a $-> b), Is1Functor (cat_precomp c f) ; bifunctor_coh_comp : forall {a b c : A} {f f' : a $-> b} {g g' : b $-> c} (p : f $== f') (p' : g $== g'), (p' $@R f) $@ (g' $@L p) $== (g $@L p) $@ (p' $@R f') ; (** Naturality of the associator in each variable separately *) is1natural_cat_assoc_l : forall (a b c d : A) (f : a $-> b) (g : b $-> c), Is1Natural (cat_precomp d f o cat_precomp d g) (cat_precomp d (g $o f)) (cat_assoc f g); is1natural_cat_assoc_m : forall (a b c d : A) (f : a $-> b) (h : c $-> d), Is1Natural (cat_precomp d f o cat_postcomp b h) (cat_postcomp a h o cat_precomp c f) (fun g => cat_assoc f g h); is1natural_cat_assoc_r : forall (a b c d : A) (g : b $-> c) (h : c $-> d), Is1Natural (cat_postcomp a (h $o g)) (cat_postcomp a h o cat_postcomp a g) (fun f => cat_assoc f g h); (** Naturality of the unitors *) is1natural_cat_idl : forall (a b : A), Is1Natural (cat_postcomp a (Id b)) idmap cat_idl ; is1natural_cat_idr : forall (a b : A), Is1Natural (cat_precomp b (Id a)) idmap cat_idr; (** Coherence *) cat_pentagon : forall (a b c d e : A) (f : a $-> b) (g : b $-> c) (h : c $-> d) (k : d $-> e), (k $@L cat_assoc f g h) $o (cat_assoc f (h $o g) k) $o (cat_assoc g h k $@R f) $== (cat_assoc (g $o f) h k) $o (cat_assoc f g (k $o h)) ; cat_tril : forall (a b c : A) (f : a $-> b) (g : b $-> c), (g $@L cat_idl f) $o (cat_assoc f (Id b) g) $== (cat_idr g $@R f) }. Global Existing Instance is1cat_hom. Global Existing Instance is1gpd_hom. Global Existing Instance is1functor_precomp. Global Existing Instance is1functor_postcomp. Global Existing Instance is1natural_cat_assoc_l. Global Existing Instance is1natural_cat_assoc_m. Global Existing Instance is1natural_cat_assoc_r. Global Existing Instance is1natural_cat_idl. Global Existing Instance is1natural_cat_idr. (** *** Whiskering functoriality *) Definition cat_postwhisker_pp {A} `{Is21Cat A} {a b c : A} {f g h : a $-> b} (k : b $-> c) (p : f $== g) (q : g $== h) : k $@L (p $@ q) $== (k $@L p) $@ (k $@L q). Proof. rapply fmap_comp. Defined. Definition cat_prewhisker_pp {A} `{Is21Cat A} {a b c : A} {f g h : b $-> c} (k : a $-> b) (p : f $== g) (q : g $== h) : (p $@ q) $@R k $== (p $@R k) $@ (q $@R k). Proof. rapply fmap_comp. Defined. (** *** Exchange law *) Definition cat_exchange {A : Type} `{Is21Cat A} {a b c : A} {f f' f'' : a $-> b} {g g' g'' : b $-> c} (p : f $== f') (q : f' $== f'') (r : g $== g') (s : g' $== g'') : (p $@ q) $@@ (r $@ s) $== (p $@@ r) $@ (q $@@ s). Proof. unfold "$@@". (** We use the distributivity of [$@R] and [$@L] in a (2,1)-category (since they are functors) to see that we have the same dadta on both sides of the 3-morphism. *) nrefine ((_ $@L cat_prewhisker_pp _ _ _ ) $@ _). nrefine ((cat_postwhisker_pp _ _ _ $@R _) $@ _). (** Now we reassociate and whisker on the left and right. *) nrefine (cat_assoc _ _ _ $@ _). refine (_ $@ (cat_assoc _ _ _)^$). nrefine (_ $@L _). refine (_ $@ cat_assoc _ _ _). refine ((cat_assoc _ _ _)^$ $@ _). nrefine (_ $@R _). (** Finally we are left with the bifunctoriality condition for left and right whiskering which is part of the data of the (2,1)-cat. *) apply bifunctor_coh_comp. Defined. Coq-HoTT-9.0/theories/WildCat/UnitCat.v000066400000000000000000000011371474641544500176470ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. (** Unit category *) Global Instance isgraph_unit : IsGraph Unit. Proof. apply Build_IsGraph. intros; exact Unit. Defined. Global Instance is01cat_unit : Is01Cat Unit. Proof. srapply Build_Is01Cat. all: intros; exact tt. Defined. Global Instance is0gpd_unit : Is0Gpd Unit. Proof. constructor; intros; exact tt. Defined. Global Instance is2graph_unit : Is2Graph Unit := fun f g => isgraph_unit. Global Instance is1cat_unit : Is1Cat Unit. Proof. econstructor. 1,2:econstructor. all:intros; exact tt. Defined. Coq-HoTT-9.0/theories/WildCat/Universe.v000066400000000000000000000103671474641544500201050ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.Equivalences Basics.PathGroupoids. Require Import Types.Equiv. Require Import WildCat.Core WildCat.Equiv WildCat.NatTrans WildCat.TwoOneCat. (** ** The (1-)category of types *) Global Instance isgraph_type@{u v} : IsGraph@{v u} Type@{u} := Build_IsGraph Type@{u} (fun a b => a -> b). Global Instance is01cat_type : Is01Cat Type. Proof. econstructor. + intro; exact idmap. + exact (fun a b c g f => g o f). Defined. Global Instance is2graph_type : Is2Graph Type := fun x y => Build_IsGraph _ (fun f g => f == g). Global Instance is01cat_arrow {A B : Type} : Is01Cat (A $-> B). Proof. econstructor. - exact (fun f a => idpath). - exact (fun f g h p q a => q a @ p a). Defined. Global Instance is0gpd_arrow {A B : Type}: Is0Gpd (A $-> B). Proof. apply Build_Is0Gpd. intros f g p a ; exact (p a)^. Defined. Global Instance is0functor_type_postcomp {A B C : Type} (h : B $-> C): Is0Functor (cat_postcomp A h). Proof. apply Build_Is0Functor. intros f g p a; exact (ap h (p a)). Defined. Global Instance is0functor_type_precomp {A B C : Type} (h : A $-> B): Is0Functor (cat_precomp C h). Proof. apply Build_Is0Functor. intros f g p a; exact (p (h a)). Defined. Global Instance is1cat_strong_type : Is1Cat_Strong Type. Proof. srapply Build_Is1Cat_Strong; cbn; intros; reflexivity. Defined. Global Instance hasmorext_type `{Funext} : HasMorExt Type. Proof. srapply Build_HasMorExt. intros A B f g; cbn in *. refine (isequiv_homotopic (@apD10 A (fun _ => B) f g) _). intros p. destruct p; reflexivity. Defined. Global Instance hasequivs_type : HasEquivs Type. Proof. srefine (Build_HasEquivs Type _ _ _ _ Equiv (@IsEquiv) _ _ _ _ _ _ _ _); intros A B. all:intros f. - exact f. - exact _. - apply Build_Equiv. - intros; reflexivity. - intros; exact (f^-1). - cbn. intros ?; apply eissect. - cbn. intros ?; apply eisretr. - intros g r s; refine (isequiv_adjointify f g r s). Defined. Global Instance hasmorext_core_type `{Funext} : HasMorExt (core Type) := _. Definition catie_isequiv {A B : Type} {f : A $-> B} `{IsEquiv A B f} : CatIsEquiv f. Proof. assumption. Defined. #[export] Hint Immediate catie_isequiv : typeclass_instances. Global Instance isinitial_zero : IsInitial (A:=Type) Empty. Proof. intro A. exists (Empty_rec _). intros g. rapply Empty_ind. Defined. Global Instance isterminal_unit : IsTerminal (A:=Type) Unit. Proof. intros A. exists (fun _ => tt). intros f x. by destruct (f x). Defined. (** ** The 2-category of types *) Global Instance is3graph_type : Is3Graph Type. Proof. intros A B f g. apply Build_IsGraph. intros p q. exact (p == q). Defined. Global Instance is1cat_type_hom A B : Is1Cat (A $-> B). Proof. repeat unshelve esplit. - intros f g h p q x. exact (q x @ p x). - intros; by symmetry. - intros f h p x. exact (p x @@ 1). - intros g h p x. exact (1 @@ p x). - intros ? ? ? ? ? ? ? ?; apply concat_p_pp. - intros ? ? ? ? ? ? ? ?; apply concat_pp_p. - intros ? ? ? ?. apply concat_p1. - intros ? ? ? ?. apply concat_1p. Defined. Global Instance is1gpd_type_hom (A B : Type) : Is1Gpd (A $-> B). Proof. repeat unshelve esplit. - intros ? ? ? ?; apply concat_pV. - intros ? ? ? ?; apply concat_Vp. Defined. Global Instance is1functor_cat_postcomp {A B C : Type} (g : B $-> C) : Is1Functor (cat_postcomp A g). Proof. repeat unshelve esplit. - intros ? ? ? ? p ?; exact (ap _ (p _)). - intros ? ? ? ? ? ?; cbn; apply ap_pp. Defined. Global Instance is1functor_cat_precomp {A B C : Type} (f : A $-> B) : Is1Functor (cat_precomp C f). Proof. repeat unshelve esplit. intros ? ? ? ? p ?; exact (p _). Defined. Global Instance is21cat_type : Is21Cat Type. Proof. snrapply Build_Is21Cat. 1-4, 6-7: exact _. - intros a b c f g h k p q x; cbn. symmetry. apply concat_Ap. - intros a b c d f g. snrapply Build_Is1Natural. intros h i p x; cbn. exact (concat_p1 _ @ ap_compose _ _ _ @ (concat_1p _)^). - intros a b. snrapply Build_Is1Natural. intros f g p x; cbn. exact (concat_p1 _ @ ap_idmap _ @ (concat_1p _)^). - intros a b. snrapply Build_Is1Natural. intros f g p x; cbn. exact (concat_p1 _ @ (concat_1p _)^). - reflexivity. - reflexivity. Defined. Coq-HoTT-9.0/theories/WildCat/Yoneda.v000066400000000000000000000530301474641544500175160ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics. Require Import WildCat.Core. Require Import WildCat.Equiv. Require Import WildCat.Universe. Require Import WildCat.Opposite. Require Import WildCat.FunctorCat. Require Import WildCat.NatTrans. Require Import WildCat.Prod. Require Import WildCat.Bifunctor. Require Import WildCat.ZeroGroupoid. (** ** Two-variable hom-functors *) Global Instance is0functor_hom {A} `{Is01Cat A} : @Is0Functor (A^op * A) Type _ _ (uncurry (@Hom A _)). Proof. apply Build_Is0Functor. intros [a1 a2] [b1 b2] [f1 f2] g; cbn in *. exact (f2 $o g $o f1). Defined. (** This requires morphism extensionality! *) Global Instance is1functor_hom {A} `{HasMorExt A} : @Is1Functor (A^op * A) Type _ _ _ _ _ _ _ _ (uncurry (@Hom A _)) _. Proof. apply Build_Is1Functor. - intros [a1 a2] [b1 b2] [f1 f2] [g1 g2] [p1 p2] q; unfold fst, snd in *. apply path_hom. refine (((p2 $@R q) $@R _) $@ ((g2 $o q) $@L p1)). - intros [a1 a2] f; cbn in *. apply path_hom. exact (cat_idr _ $@ cat_idl f). - intros [a1 a2] [b1 b2] [c1 c2] [f1 f2] [g1 g2] h; cbn in *. apply path_hom. refine (cat_assoc _ _ _ $@ _). refine (cat_assoc _ _ _ $@ _). refine (_ $@ cat_assoc_opp _ _ _). refine (g2 $@L _). refine (_ $@ cat_assoc_opp _ _ _). refine (cat_assoc_opp _ _ _). Defined. Global Instance is0bifunctor_hom {A} `{Is01Cat A} : Is0Bifunctor (A:=A^op) (B:=A) (C:=Type) (@Hom A _). Proof. nrapply Build_Is0Bifunctor'. 1-2: exact _. exact is0functor_hom. Defined. (** While it is possible to prove the bifunctor coherence condition from [Is1Cat_Strong], 1-functoriality requires morphism extensionality.*) Global Instance is1bifunctor_hom {A} `{Is1Cat A} `{HasMorExt A} : Is1Bifunctor (A:=A^op) (B:=A) (C:=Type) (@Hom A _). Proof. nrapply Build_Is1Bifunctor'. exact is1functor_hom. Defined. Definition fun01_hom {A} `{Is01Cat A} : Fun01 (A^op * A) Type := @Build_Fun01 _ _ _ _ _ is0functor_hom. (** ** The covariant Yoneda lemma *) (** This is easier than the contravariant version because it doesn't involve any "op"s. *) Definition opyon {A : Type} `{IsGraph A} (a : A) : A -> Type := fun b => (a $-> b). (** We prove this explicitly instead of using the bifunctor instance above so that we can apply [fmap] in each argument independently without mapping an identity in the other. *) Global Instance is0functor_opyon {A : Type} `{Is01Cat A} (a : A) : Is0Functor (opyon a). Proof. apply Build_Is0Functor. unfold opyon; intros b c f g; cbn in *. exact (f $o g). Defined. Global Instance is1functor_opyon {A : Type} `{Is1Cat A} `{!HasMorExt A} (a : A) : Is1Functor (opyon a). Proof. rapply Build_Is1Functor. + intros x y f g p h. apply path_hom. apply (cat_prewhisker p). + intros x h. apply path_hom. apply cat_idl. + intros x y z f g h. apply path_hom. apply cat_assoc. Defined. (** We record these corollaries here, since we use some of them below. *) Definition equiv_postcompose_cat_equiv {A : Type} `{HasEquivs A} `{!HasMorExt A} {x y z : A} (f : y $<~> z) : (x $-> y) <~> (x $-> z) := emap (opyon x) f. Definition equiv_precompose_cat_equiv {A : Type} `{HasEquivs A} `{!HasMorExt A} {x y z : A} (f : x $<~> y) : (y $-> z) <~> (x $-> z) := @equiv_postcompose_cat_equiv A^op _ _ _ _ _ _ z y x f. (* The following implicitly use [hasequivs_core]. Note that when [A] has morphism extensionality, it doesn't follow that [core A] does. We'd need to know that being an equivalence is a proposition, and we don't assume that (since even for [Type] it requires [Funext], see [hasmorext_core_type]). So we need to assume this in the following results. *) (** Postcomposition with a cat_equiv is an equivalence between the types of equivalences. *) Definition equiv_postcompose_core_cat_equiv {A : Type} `{HasEquivs A} `{!HasMorExt (core A)} {x y z : A} (f : y $<~> z) : (x $<~> y) <~> (x $<~> z). Proof. change ((Build_core x $-> Build_core y) <~> (Build_core x $-> Build_core z)). refine (equiv_postcompose_cat_equiv (A := core A) _). exact f. (* It doesn't work to insert [f] on the previous line. *) Defined. Definition equiv_precompose_core_cat_equiv {A : Type} `{HasEquivs A} `{!HasMorExt (core A)} {x y z : A} (f : x $<~> y) : (y $<~> z) <~> (x $<~> z). Proof. change ((Build_core y $-> Build_core z) <~> (Build_core x $-> Build_core z)). refine (equiv_precompose_cat_equiv (A := core A) _). exact f. (* It doesn't work to insert [f] on the previous line. *) Defined. Definition opyoneda {A : Type} `{Is01Cat A} (a : A) (F : A -> Type) {ff : Is0Functor F} : F a -> (opyon a $=> F). Proof. intros x b f. exact (fmap F f x). Defined. Definition un_opyoneda {A : Type} `{Is01Cat A} (a : A) (F : A -> Type) {ff : Is0Functor F} : (opyon a $=> F) -> F a := fun alpha => alpha a (Id a). Global Instance is1natural_opyoneda {A : Type} `{Is1Cat A} (a : A) (F : A -> Type) `{!Is0Functor F, !Is1Functor F} (x : F a) : Is1Natural (opyon a) F (opyoneda a F x). Proof. snrapply Build_Is1Natural. unfold opyon, opyoneda; intros b c f g; cbn in *. exact (fmap_comp F g f x). Defined. (** This is form of injectivity of [opyoneda]. *) Definition opyoneda_isinj {A : Type} `{Is1Cat A} (a : A) (F : A -> Type) `{!Is0Functor F, !Is1Functor F} (x x' : F a) (p : forall b, opyoneda a F x b == opyoneda a F x' b) : x = x'. Proof. refine ((fmap_id F a x)^ @ _ @ fmap_id F a x'). cbn in p. exact (p a (Id a)). Defined. (** This says that [opyon] is faithful, although we haven't yet defined a graph structure on natural transformations to express this in that way. This follows from the previous result, but then would need [HasMorExt A], since the previous result assumes that [F] is a 1-functor, which is stronger than what is needed. The direct proof below only needs the weaker assumption [Is1Cat_Strong A]. *) Definition opyon_faithful {A : Type} `{Is1Cat_Strong A} (a b : A) (f g : b $-> a) (p : forall (c : A) (h : a $-> c), h $o f = h $o g) : f = g := (cat_idl_strong f)^ @ p a (Id a) @ cat_idl_strong g. (** The composite in one direction is the identity map. *) Definition opyoneda_issect {A : Type} `{Is1Cat A} (a : A) (F : A -> Type) `{!Is0Functor F, !Is1Functor F} (x : F a) : un_opyoneda a F (opyoneda a F x) = x := fmap_id F a x. (** We assume for the converse that the coherences in [A] are equalities (this is a weak funext-type assumption). Note that we do not in general recover the witness of 1-naturality. Indeed, if [A] is fully coherent, then a transformation of the form [opyoneda a F x] is always also fully coherently natural, so an incoherent witness of 1-naturality could not be recovered in this way. *) Definition opyoneda_isretr {A : Type} `{Is1Cat_Strong A} (a : A) (F : A -> Type) `{!Is0Functor F, !Is1Functor F} (alpha : opyon a $=> F) {alnat : Is1Natural (opyon a) F alpha} (b : A) : opyoneda a F (un_opyoneda a F alpha) b $== alpha b. Proof. unfold opyoneda, un_opyoneda, opyon; intros f. refine ((isnat alpha f (Id a))^ @ _). cbn. apply ap. exact (cat_idr_strong f). Defined. (** A natural transformation between representable functors induces a map between the representing objects. *) Definition opyon_cancel {A : Type} `{Is01Cat A} (a b : A) : (opyon a $=> opyon b) -> (b $-> a) := un_opyoneda a (opyon b). Definition opyon1 {A : Type} `{Is01Cat A} (a : A) : Fun01 A Type. Proof. rapply (Build_Fun01 _ _ (opyon a)). Defined. Definition opyon11 {A : Type} `{Is1Cat A} `{!HasMorExt A} (a : A) : Fun11 A Type. Proof. rapply (Build_Fun11 _ _ (opyon a)). Defined. (** An equivalence between representable functors induces an equivalence between the representing objects. *) Definition opyon_equiv {A : Type} `{HasEquivs A} `{!Is1Cat_Strong A} {a b : A} : (opyon1 a $<~> opyon1 b) -> (b $<~> a). Proof. intros f. refine (cate_adjointify (f a (Id a)) (f^-1$ b (Id b)) _ _); apply GpdHom_path; cbn in *. - refine ((isnat_natequiv (natequiv_inverse f) (f a (Id a)) (Id b))^ @ _); cbn. refine (_ @ cate_issect (f a) (Id a)); cbn. apply ap. srapply cat_idr_strong. - refine ((isnat_natequiv f (f^-1$ b (Id b)) (Id a))^ @ _); cbn. refine (_ @ cate_isretr (f b) (Id b)); cbn. apply ap. srapply cat_idr_strong. Defined. Definition natequiv_opyon_equiv {A : Type} `{HasEquivs A} `{!HasMorExt A} {a b : A} : (b $<~> a) -> (opyon1 a $<~> opyon1 b). Proof. intro e. snrapply Build_NatEquiv. - intros c. exact (equiv_precompose_cat_equiv e). - rapply is1natural_opyoneda. Defined. (** ** The covariant Yoneda lemma using 0-groupoids *) (** We repeat the above, regarding [opyon] as landing in 0-groupoids, using the 1-category structure on [ZeroGpd] in [ZeroGroupoid.v]. This has many advantages. It avoids [HasMorExt], which means that we don't need [Funext] in many examples. It also avoids [Is1Cat_Strong], which means the results all have the same hypotheses, namely that [A] is a 1-category. This allows us to simplify the proof of [opyon_equiv_0gpd], making use of [opyoneda_isretr_0gpd]. *) Definition opyon_0gpd {A : Type} `{Is1Cat A} (a : A) : A -> ZeroGpd := fun b => Build_ZeroGpd (a $-> b) _ _ _. Global Instance is0functor_hom_0gpd {A : Type} `{Is1Cat A} : Is0Functor (A:=A^op*A) (B:=ZeroGpd) (uncurry (opyon_0gpd (A:=A))). Proof. nrapply Build_Is0Functor. intros [a1 a2] [b1 b2] [f1 f2]; unfold op in *; cbn in *. rapply (Build_Morphism_0Gpd (opyon_0gpd a1 a2) (opyon_0gpd b1 b2) (cat_postcomp b1 f2 o cat_precomp a2 f1)). Defined. Global Instance is1functor_hom_0gpd {A : Type} `{Is1Cat A} : Is1Functor (A:=A^op*A) (B:=ZeroGpd) (uncurry (opyon_0gpd (A:=A))). Proof. nrapply Build_Is1Functor. - intros [a1 a2] [b1 b2] [f1 f2] [g1 g2] [p q] h. exact (h $@L p $@@ q). - intros [a1 a2] h. exact (cat_idl _ $@ cat_idr _). - intros [a1 a2] [b1 b2] [c1 c2] [f1 f2] [g1 g2] h. refine (cat_assoc _ _ _ $@ _). refine (g2 $@L _). refine (_ $@L (cat_assoc_opp _ _ _) $@ _). exact (cat_assoc_opp _ _ _). Defined. Global Instance is0bifunctor_hom_0gpd {A : Type} `{Is1Cat A} : Is0Bifunctor (A:=A^op) (B:=A) (C:=ZeroGpd) (opyon_0gpd (A:=A)). Proof. snrapply Build_Is0Bifunctor'. 1,2: exact _. exact is0functor_hom_0gpd. Defined. Global Instance is1bifunctor_hom_0gpd {A : Type} `{Is1Cat A} : Is1Bifunctor (A:=A^op) (B:=A) (C:=ZeroGpd) (opyon_0gpd (A:=A)). Proof. snrapply Build_Is1Bifunctor'. exact is1functor_hom_0gpd. Defined. Global Instance is0functor_opyon_0gpd {A : Type} `{Is1Cat A} (a : A) : Is0Functor (opyon_0gpd a). Proof. apply Build_Is0Functor. intros b c f. exact (Build_Morphism_0Gpd (opyon_0gpd a b) (opyon_0gpd a c) (cat_postcomp a f) _). Defined. Global Instance is1functor_opyon_0gpd {A : Type} `{Is1Cat A} (a : A) : Is1Functor (opyon_0gpd a). Proof. rapply Build_Is1Functor. + intros x y f g p h. apply (cat_prewhisker p). + intros x h. apply cat_idl. + intros x y z f g h. apply cat_assoc. Defined. Definition opyoneda_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} : F a -> (opyon_0gpd a $=> F). Proof. intros x b. refine (Build_Morphism_0Gpd (opyon_0gpd a b) (F b) (fun f => fmap F f x) _). rapply Build_Is0Functor. intros f1 f2 h. exact (fmap2 F h x). Defined. Definition un_opyoneda_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A -> ZeroGpd) {ff : Is0Functor F} : (opyon_0gpd a $=> F) -> F a := fun alpha => alpha a (Id a). Global Instance is1natural_opyoneda_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (x : F a) : Is1Natural (opyon_0gpd a) F (opyoneda_0gpd a F x). Proof. snrapply Build_Is1Natural. unfold opyon_0gpd, opyoneda_0gpd; intros b c f g; cbn in *. exact (fmap_comp F g f x). Defined. (** This is form of injectivity of [opyoneda_0gpd]. *) Definition opyoneda_isinj_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (x x' : F a) (p : forall b : A, opyoneda_0gpd a F x b $== opyoneda_0gpd a F x' b) : x $== x'. Proof. refine ((fmap_id F a x)^$ $@ _ $@ fmap_id F a x'). cbn in p. exact (p a (Id a)). Defined. (** This says that [opyon_0gpd] is faithful, although we haven't yet defined a graph structure on natural transformations to express this in that way. *) Definition opyon_faithful_0gpd {A : Type} `{Is1Cat A} (a b : A) (f g : b $-> a) (p : forall (c : A) (h : a $-> c), h $o f $== h $o g) : f $== g := opyoneda_isinj_0gpd a _ f g p. (** The composite in one direction is the identity map. *) Definition opyoneda_issect_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (x : F a) : un_opyoneda_0gpd a F (opyoneda_0gpd a F x) $== x := fmap_id F a x. (** For the other composite, note that we do not in general recover the witness of 1-naturality. Indeed, if [A] is fully coherent, then a transformation of the form [opyoneda a F x] is always also fully coherently natural, so an incoherent witness of 1-naturality could not be recovered in this way. *) Definition opyoneda_isretr_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (alpha : opyon_0gpd a $=> F) {alnat : Is1Natural (opyon_0gpd a) F alpha} (b : A) : opyoneda_0gpd a F (un_opyoneda_0gpd a F alpha) b $== alpha b. Proof. unfold opyoneda, un_opyoneda, opyon; intros f. refine ((isnat alpha f (Id a))^$ $@ _). cbn. apply (fmap (alpha b)). exact (cat_idr f). Defined. (** A natural transformation between representable functors induces a map between the representing objects. *) Definition opyon_cancel_0gpd {A : Type} `{Is1Cat A} (a b : A) : (opyon_0gpd a $=> opyon_0gpd b) -> (b $-> a) := un_opyoneda_0gpd a (opyon_0gpd b). (** Since no extra hypotheses are needed, we use the name with "1" for the [Fun11] version. *) Definition opyon1_0gpd {A : Type} `{Is1Cat A} (a : A) : Fun11 A ZeroGpd := Build_Fun11 _ _ (opyon_0gpd a). (** An equivalence between representable functors induces an equivalence between the representing objects. We explain how this compares to [opyon_equiv] above. Instead of assuming that each [f c : (a $-> c) -> (b $-> c)] is an equivalence of types, it only needs to be an equivalence of 0-groupoids. For example, this means that we have a map [g c : (b $-> c) -> (a $-> c)] such that for each [k : a $-> c], [g c (f c k) $== k], rather than [g c (f c k) = k] as the version with types requires. Similarly, the naturality is up to 2-cells, instead of up to paths. This allows us to avoid [Funext] and [HasMorExt] when using this result. As a side benefit, we also don't require that [A] is strong. The proof is also simpler, since we can re-use the work done in [opyoneda_isretr_0gpd]. *) Definition opyon_equiv_0gpd {A : Type} `{HasEquivs A} {a b : A} (f : opyon1_0gpd a $<~> opyon1_0gpd b) : b $<~> a. Proof. (* These are the maps that will define the desired equivalence: *) set (fa := (cate_fun f a) (Id a)). (* Equivalently, [un_opyoneda_0gpd a _ f]. *) set (gb := (cate_fun f^-1$ b) (Id b)). (* Equivalently, [un_opyoneda_0gpd b _ f^-1$]. *) srapply (cate_adjointify fa gb). (* [opyoneda_0gpd] is defined by postcomposition, so [opyoneda_isretr_0gpd] simplifies both LHSs.*) - exact (opyoneda_isretr_0gpd _ _ f^-1$ a fa $@ cat_eissect (f a) (Id a)). - exact (opyoneda_isretr_0gpd _ _ f b gb $@ cat_eisretr (f b) (Id b)). Defined. (** Since [opyon_0gpd] is a 1-functor, postcomposition with a [cat_equiv] is an equivalence between the hom 0-groupoids. Note that we do not require [HasMorExt], as [equiv_postcompose_cat_equiv] does. *) Definition equiv_postcompose_cat_equiv_0gpd {A : Type} `{HasEquivs A} {x y z : A} (f : y $<~> z) : opyon_0gpd x y $<~> opyon_0gpd x z := emap (opyon_0gpd x) f. (** The dual result, which is used in the next result. *) Definition equiv_precompose_cat_equiv_0gpd {A : Type} `{HasEquivs A} {x y z : A} (f : x $<~> y) : opyon_0gpd y z $<~> opyon_0gpd x z := @equiv_postcompose_cat_equiv_0gpd A^op _ _ _ _ _ z y x f. (** A converse to [opyon_equiv_0gpd]. Together, we get a logical equivalence between [b $<~> a] and [opyon_0gpd a $<~> opyon_0gpd b], without [HasMorExt]. *) Definition natequiv_opyon_equiv_0gpd {A : Type} `{HasEquivs A} {a b : A} (e : b $<~> a) : opyon1_0gpd a $<~> opyon1_0gpd b. Proof. snrapply Build_NatEquiv. - intro c; exact (equiv_precompose_cat_equiv_0gpd e). - rapply is1natural_opyoneda_0gpd. Defined. (** ** The contravariant Yoneda lemma *) (** We can deduce this from the covariant version with some boilerplate. *) Definition yon {A : Type} `{IsGraph A} (a : A) : A^op -> Type := opyon (A:=A^op) a. Global Instance is0functor_yon {A : Type} `{H : Is01Cat A} (a : A) : Is0Functor (yon a) := is0functor_opyon (A:=A^op) a. Global Instance is1functor_yon {A : Type} `{H : Is1Cat A} `{!HasMorExt A} (a : A) : Is1Functor (yon a) := is1functor_opyon (A:=A^op) a. Definition yoneda {A : Type} `{Is01Cat A} (a : A) (F : A^op -> Type) `{!Is0Functor F} : F a -> (yon a $=> F) := @opyoneda (A^op) _ _ a F _. Definition un_yoneda {A : Type} `{Is01Cat A} (a : A) (F : A^op -> Type) `{!Is0Functor F} : (yon a $=> F) -> F a := un_opyoneda (A:=A^op) a F. Global Instance is1natural_yoneda {A : Type} `{Is1Cat A} (a : A) (F : A^op -> Type) `{!Is0Functor F, !Is1Functor F} (x : F a) : Is1Natural (yon a) F (yoneda a F x) := is1natural_opyoneda (A:=A^op) a F x. Definition yoneda_isinj {A : Type} `{Is1Cat A} (a : A) (F : A^op -> Type) `{!Is0Functor F, !Is1Functor F} (x x' : F a) (p : forall b, yoneda a F x b == yoneda a F x' b) : x = x' := opyoneda_isinj (A:=A^op) a F x x' p. Definition yon_faithful {A : Type} `{Is1Cat_Strong A} (a b : A) (f g : b $-> a) (p : forall (c : A) (h : c $-> b), f $o h = g $o h) : f = g := opyon_faithful (A:=A^op) b a f g p. Definition yoneda_issect {A : Type} `{Is1Cat A} (a : A) (F : A^op -> Type) `{!Is0Functor F, !Is1Functor F} (x : F a) : un_yoneda a F (yoneda a F x) = x := opyoneda_issect (A:=A^op) a F x. Definition yoneda_isretr {A : Type} `{Is1Cat_Strong A} (a : A) (F : A^op -> Type) `{!Is0Functor F} (* Without the hint here, Coq guesses to first project from [Is1Cat_Strong A] and then pass to opposites, whereas what we need is to first pass to opposites and then project. *) `{@Is1Functor _ _ _ _ _ (is1cat_is1cat_strong A^op) _ _ _ _ F _} (alpha : yon a $=> F) {alnat : Is1Natural (yon a) F alpha} (b : A) : yoneda a F (un_yoneda a F alpha) b $== alpha b := opyoneda_isretr (A:=A^op) a F alpha b. Definition yon_cancel {A : Type} `{Is01Cat A} (a b : A) : (yon a $=> yon b) -> (a $-> b) := un_yoneda a (yon b). Definition yon1 {A : Type} `{Is01Cat A} (a : A) : Fun01 A^op Type := opyon1 (A:=A^op) a. Definition yon11 {A : Type} `{Is1Cat A} `{!HasMorExt A} (a : A) : Fun11 A^op Type := opyon11 (A:=A^op) a. Definition yon_equiv {A : Type} `{HasEquivs A} `{!Is1Cat_Strong A} (a b : A) : (yon1 a $<~> yon1 b) -> (a $<~> b) := opyon_equiv (A:=A^op). Definition natequiv_yon_equiv {A : Type} `{HasEquivs A} `{!HasMorExt A} (a b : A) : (a $<~> b) -> (yon1 a $<~> yon1 b) := natequiv_opyon_equiv (A:=A^op). (** ** The contravariant Yoneda lemma using 0-groupoids *) Definition yon_0gpd {A : Type} `{Is1Cat A} (a : A) : A^op -> ZeroGpd := opyon_0gpd (A:=A^op) a. Global Instance is0functor_yon_0gpd {A : Type} `{Is1Cat A} (a : A) : Is0Functor (yon_0gpd a) := is0functor_opyon_0gpd (A:=A^op) a. Global Instance is1functor_yon_0gpd {A : Type} `{Is1Cat A} (a : A) : Is1Functor (yon_0gpd a) := is1functor_opyon_0gpd (A:=A^op) a. Definition yoneda_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A^op -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} : F a -> (yon_0gpd a $=> F) := opyoneda_0gpd (A:=A^op) a F. Definition un_yoneda_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A^op -> ZeroGpd) {ff : Is0Functor F} : (yon_0gpd a $=> F) -> F a := un_opyoneda_0gpd (A:=A^op) a F. Global Instance is1natural_yoneda_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A^op -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (x : F a) : Is1Natural (yon_0gpd a) F (yoneda_0gpd a F x) := is1natural_opyoneda_0gpd (A:=A^op) a F x. Definition yoneda_isinj_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A^op -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (x x' : F a) (p : forall b : A, yoneda_0gpd a F x b $== yoneda_0gpd a F x' b) : x $== x' := opyoneda_isinj_0gpd (A:=A^op) a F x x' p. Definition yon_faithful_0gpd {A : Type} `{Is1Cat A} (a b : A) (f g : b $-> a) (p : forall (c : A) (h : c $-> b), f $o h $== g $o h) : f $== g := opyon_faithful_0gpd (A:=A^op) b a f g p. Definition yoneda_issect_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A^op -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (x : F a) : un_yoneda_0gpd a F (yoneda_0gpd a F x) $== x := opyoneda_issect_0gpd (A:=A^op) a F x. Definition yoneda_isretr_0gpd {A : Type} `{Is1Cat A} (a : A) (F : A^op -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (alpha : yon_0gpd a $=> F) {alnat : Is1Natural (yon_0gpd a) F alpha} (b : A) : yoneda_0gpd a F (un_yoneda_0gpd a F alpha) b $== alpha b := opyoneda_isretr_0gpd (A:=A^op) a F alpha b. Definition yon_cancel_0gpd {A : Type} `{Is1Cat A} (a b : A) : (yon_0gpd a $=> yon_0gpd b) -> (a $-> b) := opyon_cancel_0gpd (A:=A^op) a b. Definition yon1_0gpd {A : Type} `{Is1Cat A} (a : A) : Fun11 A^op ZeroGpd := opyon1_0gpd (A:=A^op) a. Definition yon_equiv_0gpd {A : Type} `{HasEquivs A} {a b : A} (f : yon1_0gpd a $<~> yon1_0gpd b) : a $<~> b := opyon_equiv_0gpd (A:=A^op) f. Definition natequiv_yon_equiv_0gpd {A : Type} `{HasEquivs A} {a b : A} (e : a $<~> b) : yon1_0gpd (A:=A) a $<~> yon1_0gpd b := natequiv_opyon_equiv_0gpd (A:=A^op) (e : CatEquiv (A:=A^op) b a). Coq-HoTT-9.0/theories/WildCat/ZeroGroupoid.v000066400000000000000000000203331474641544500207270ustar00rootroot00000000000000Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids. Require Import WildCat.Core WildCat.Equiv WildCat.EquivGpd WildCat.Forall. (** * The wild 1-category of 0-groupoids. *) (** Here we define a wild 1-category structure on the type of 0-groupoids. We think of the 1-cells [g $== h] in a 0-groupoid [G] as a substitute for the paths [g = h], and so we closely follow the definitions used for the 1-category of types with [=] replaced by [$==]. In fact, the 1-category structure on types should be the pullback of the 1-category structure on 0-groupoids along a natural map [Type -> ZeroGpd] which sends [A] to [A] equipped with its path types. A second motivating example is the 0-groupoid with underlying type [A -> B] and homotopies as the 1-cells. The definitions chosen here exactly make the Yoneda lemma [opyon_equiv_0gpd] go through. *) Record ZeroGpd := { carrier :> Type; isgraph_carrier : IsGraph carrier; is01cat_carrier : Is01Cat carrier; is0gpd_carrier : Is0Gpd carrier; }. Global Existing Instance isgraph_carrier. Global Existing Instance is01cat_carrier. Global Existing Instance is0gpd_carrier. (* The morphisms of 0-groupoids are the 0-functors. This is the same as [Fun01], but we put a different graph and 01-category structure on it, so we give this a custom name. *) Record Morphism_0Gpd (G H : ZeroGpd) := { fun_0gpd :> carrier G -> carrier H; is0functor_fun_0gpd : Is0Functor fun_0gpd; }. Global Existing Instance is0functor_fun_0gpd. (** Now we show that the type [ZeroGpd] of 0-groupoids is itself a 1-category, with morphisms the 0-functors. *) Global Instance isgraph_0gpd : IsGraph ZeroGpd. Proof. apply Build_IsGraph. exact Morphism_0Gpd. Defined. Global Instance is01cat_0gpd : Is01Cat ZeroGpd. Proof. srapply Build_Is01Cat. - intro G. exact (Build_Morphism_0Gpd G G idmap _). - intros G H K f g. exact (Build_Morphism_0Gpd _ _ (f o g) _). Defined. (* The 2-cells are unnatural transformations, and are analogous to homotopies. *) Global Instance is2graph_0gpd : Is2Graph ZeroGpd. Proof. intros G H. snrapply Build_IsGraph. intros f g. exact (forall x : G, f x $== g x). Defined. Global Instance is1cat_0gpd : Is1Cat ZeroGpd. Proof. snrapply Build_Is1Cat. - intros G H. srapply Build_Is01Cat. + intro f. exact (fun x => Id (f x)). + intros f g h p q. exact (fun x => q x $@ p x). - intros G H. srapply Build_Is0Gpd. intros f g p. exact (fun x => (p x)^$). - intros G H K f. srapply Build_Is0Functor. intros g h p x. cbn. exact (fmap f (p x)). - intros G H K f. srapply Build_Is0Functor. intros g h p x. cbn. exact (p (f x)). - reflexivity. (* Associativity. *) - reflexivity. (* Associativity in opposite direction. *) - reflexivity. (* Left identity. *) - reflexivity. (* Right identity. *) Defined. (** We define equivalences of 0-groupoids as the bi-invertible maps, using [Cat_BiInv] and [Cat_IsBiInv]. This definition is chosen to provide what is needed for the Yoneda lemma, and because it specializes to one of the correct definitions for types. *) Global Instance hasequivs_0gpd : HasEquivs ZeroGpd := cat_hasequivs ZeroGpd. (** Coq can't find the composite of the coercions [cate_fun : G $<~> H >-> G $-> H] and [fun_0gpd : Morphism_0Gpd G H >-> G -> H], probably because it passes through the definitional equality of [G $-> H] and [Morphism_0Gpd G H]. I couldn't find a solution, so instead here is a helper function to manually do the coercion when needed. *) Definition equiv_fun_0gpd {G H : ZeroGpd} (f : G $<~> H) : G -> H := fun_0gpd _ _ (cat_equiv_fun _ _ _ f). (** ** Tools for manipulating equivalences of 0-groupoids Even though the proofs are easy, in certain contexts Coq gets confused about [$==] vs [$->], which makes it hard to prove this inline. So we record them here. *) (** Every equivalence is injective. *) Definition isinj_equiv_0gpd {G H : ZeroGpd} (f : G $<~> H) {x y : G} (h : equiv_fun_0gpd f x $== equiv_fun_0gpd f y) : x $== y. Proof. exact ((cat_eissect f x)^$ $@ fmap (equiv_fun_0gpd f^-1$) h $@ cat_eissect f y). Defined. (** This is one example of many things that could be ported from Basics/Equivalences.v. *) Definition moveR_equiv_V_0gpd {G H : ZeroGpd} (f : G $<~> H) (x : H) (y : G) (p : x $== equiv_fun_0gpd f y) : equiv_fun_0gpd f^-1$ x $== y := fmap (equiv_fun_0gpd f^-1$) p $@ cat_eissect f y. Definition moveL_equiv_V_0gpd {G H : ZeroGpd} (f : G $<~> H) (x : H) (y : G) (p : equiv_fun_0gpd f y $== x) : y $== equiv_fun_0gpd f^-1$ x := (cat_eissect f y)^$ $@ fmap (equiv_fun_0gpd f^-1$) p. (** ** [f] is an equivalence of 0-groupoids iff [IsSurjInj f] We now give a different characterization of the equivalences of 0-groupoids, as the injective split essentially surjective 0-functors, which are defined in EquivGpd. Advantages of this logically equivalent formulation are that it tends to be easier to prove in examples and that in some cases it is definitionally equal to [ExtensionAlong], which is convenient. See Homotopy/Suspension.v and Algebra/AbGroups/Abelianization for examples. Advantages of the bi-invertible definition are that it reproduces a definition that is equivalent to [IsEquiv] when applied to types, assuming [Funext]. It also works in any 1-category. *) (** Every equivalence is injective and split essentially surjective. *) Global Instance issurjinj_equiv_0gpd {G H : ZeroGpd} (f : G $<~> H) : IsSurjInj (equiv_fun_0gpd f). Proof. econstructor. - intro y. exists (equiv_fun_0gpd f^-1$ y). rapply cat_eisretr. - apply isinj_equiv_0gpd. Defined. (** Conversely, every injective split essentially surjective 0-functor is an equivalence. In practice, this is often the easiest way to prove that a functor is an equivalence. *) Definition isequiv_0gpd_issurjinj {G H : ZeroGpd} (F : G $-> H) {e : IsSurjInj F} : Cat_IsBiInv F. Proof. destruct e as [e0 e1]; unfold SplEssSurj in e0. srapply catie_adjointify. - snrapply Build_Morphism_0Gpd. 1: exact (fun y => (e0 y).1). snrapply Build_Is0Functor; cbn beta. intros y1 y2 m. apply e1. exact ((e0 y1).2 $@ m $@ ((e0 y2).2)^$). - cbn. apply e0. - cbn. intro x. apply e1. apply e0. Defined. (** [I]-indexed products for an [I]-indexed family of 0-groupoids. *) Definition prod_0gpd (I : Type) (G : I -> ZeroGpd) : ZeroGpd. Proof. rapply (Build_ZeroGpd (forall i, G i)). Defined. (** The [i]-th projection from the [I]-indexed product of 0-groupoids. *) Definition prod_0gpd_pr {I : Type} {G : I -> ZeroGpd} : forall i, prod_0gpd I G $-> G i. Proof. intros i. snrapply Build_Morphism_0Gpd. 1: exact (fun f => f i). snrapply Build_Is0Functor; cbn beta. intros f g p. exact (p i). Defined. (** The universal property of the product of 0-groupoids holds almost definitionally. *) Definition equiv_prod_0gpd_corec {I : Type} {G : ZeroGpd} {H : I -> ZeroGpd} : (forall i, G $-> H i) <~> (G $-> prod_0gpd I H). Proof. snrapply Build_Equiv. { intro f. snrapply Build_Morphism_0Gpd. 1: exact (fun x i => f i x). snrapply Build_Is0Functor; cbn beta. intros x y p i; simpl. exact (fmap (f i) p). } snrapply Build_IsEquiv. - intro f. intros i. exact (prod_0gpd_pr i $o f). - intro f. reflexivity. - intro f. reflexivity. - reflexivity. Defined. (** Indexed products of groupoids with equivalent indices and fiberwise equivalent factors are equivalent. *) Definition cate_prod_0gpd {I J : Type} (ie : I <~> J) (G : I -> ZeroGpd) (H : J -> ZeroGpd) (f : forall (i : I), G i $<~> H (ie i)) : prod_0gpd I G $<~> prod_0gpd J H. Proof. snrapply cate_adjointify. - snrapply Build_Morphism_0Gpd. + intros h j. exact (transport H (eisretr ie j) (cate_fun (f (ie^-1 j)) (h _))). + nrapply Build_Is0Functor. intros g h p j. destruct (eisretr ie j). refine (_ $o Hom_path (transport_1 _ _)). apply Build_Morphism_0Gpd. exact (p _). - exact (equiv_prod_0gpd_corec (fun i => (f i)^-1$ $o prod_0gpd_pr (ie i))). - intros h j. cbn. destruct (eisretr ie j). exact (cate_isretr (f _) _). - intros g i. cbn. refine (_ $o Hom_path (ap (cate_fun (f i)^-1$) (transport2 _ (eisadj ie i) _))). destruct (eissect ie i). exact (cate_issect (f _) _). Defined. Coq-HoTT-9.0/theories/dune000066400000000000000000000002731474641544500154400ustar00rootroot00000000000000; Tell dune to look through subdirectories (include_subdirs qualified) ; Main theory stanza telling dune how the HoTT library is compiled (coq.theory (name HoTT) (package coq-hott))