├── .devcontainer ├── Dockerfile └── devcontainer.json ├── .gitattributes ├── .github └── workflows │ ├── nix-action-coq-8.20.yml │ └── nix-action-coq-9.0.yml ├── .gitignore ├── .nix ├── config.nix ├── coq-nix-toolbox.nix ├── coq-overlays │ ├── HoTT │ │ └── default.nix │ ├── devshell │ │ └── default.nix │ ├── trocq-hott-examples │ │ └── default.nix │ ├── trocq-hott │ │ └── default.nix │ ├── trocq-std-examples │ │ └── default.nix │ ├── trocq-std │ │ └── default.nix │ └── trocq │ │ └── default.nix └── rocq-overlays │ └── trocq │ └── default.nix ├── AUTHORS ├── CHANGELOG.md ├── CITATION.cff ├── INSTALL.md ├── LICENSE ├── Makefile ├── README.md ├── artifact-doc ├── CLAIMS.md ├── INSTALL.md ├── LICENSE ├── README.md ├── REQUIREMENTS.md ├── STATUS.md └── TUTORIAL.md ├── coq-trocq.opam ├── default.nix ├── docs ├── .nojekyll ├── about.md ├── hierarchy.jpeg ├── home.md ├── index.html ├── inria-logo.png ├── merce-logo.png ├── quick-start.md ├── sidebar.md ├── trocq-logo-text.png └── trocq-logo.png ├── elpi ├── annot.elpi ├── class.elpi ├── constraints │ ├── constraint-graph.elpi │ ├── constraints-impl.elpi │ ├── constraints.elpi │ └── simple-graph.elpi ├── database.elpi ├── generation │ ├── hierarchy.elpi │ ├── param-arrow.elpi │ ├── param-forall.elpi │ ├── param-prop.elpi │ ├── param-type.elpi │ └── pparam-type.elpi ├── param-class-util.elpi ├── param.elpi ├── tactic.elpi ├── util-rocq.elpi ├── util.elpi └── vernac.elpi ├── examples ├── Makefile ├── N.v ├── artifact_paper_example.v ├── hott │ ├── Makefile │ ├── N.v │ ├── _CoqProject │ ├── artifact_paper_example.v │ ├── list_option.v │ ├── misc.v │ ├── nat_ind.v │ ├── peano_bin_nat.v │ ├── setoid_rewrite.v │ ├── summable.v │ ├── trocq_gen_rewrite.v │ └── trocq_setoid_rewrite.v ├── list_option.v ├── misc.v ├── nat_ind.v ├── peano_bin_nat.v ├── setoid_rewrite.v ├── std │ ├── Makefile │ ├── N.v │ ├── Vector_tuple.v │ ├── _CoqProject │ ├── artifact_paper_example.v │ ├── flt3_step.v │ ├── int_to_Zp.v │ ├── list_option.v │ ├── misc.v │ ├── nat_ind.v │ ├── peano_bin_nat.v │ ├── setoid_rewrite.v │ ├── square_and_cube_mod7.v │ ├── stuck.v │ ├── summable.v │ ├── trocq_gen_rewrite.v │ └── trocq_setoid_rewrite.v └── summable.v ├── generic ├── Database.v ├── Param_Empty.v ├── Param_bool.v ├── Param_list.v ├── Param_nat.v ├── Param_option.v ├── Param_paths.v ├── Param_prod.v ├── Param_sigma.v ├── Param_sum.v ├── Param_trans.v ├── Param_vector.v ├── Trocq.v └── Vernac.v ├── hott ├── Common.v ├── Hierarchy.v ├── HoTT_additions.v ├── Makefile ├── Optimality.v ├── Param.v ├── Param_Type.v ├── Param_arrow.v ├── Param_forall.v ├── Param_lemmas.v ├── Stdlib.v ├── Uparam.v ├── _CoqProject └── generic │ ├── Database.v │ ├── Param_Empty.v │ ├── Param_bool.v │ ├── Param_list.v │ ├── Param_nat.v │ ├── Param_option.v │ ├── Param_paths.v │ ├── Param_prod.v │ ├── Param_sigma.v │ ├── Param_sum.v │ ├── Param_trans.v │ ├── Param_vector.v │ ├── Trocq.v │ └── Vernac.v ├── meta.yml └── std ├── Common.v ├── Hierarchy.v ├── HoTTNotations.v ├── Makefile ├── Param.v ├── Param_Prop.v ├── Param_Type.v ├── Param_arrow.v ├── Param_forall.v ├── Param_lemmas.v ├── Stdlib.v ├── _CoqProject └── generic ├── Database.v ├── Param_Empty.v ├── Param_bool.v ├── Param_list.v ├── Param_nat.v ├── Param_option.v ├── Param_paths.v ├── Param_prod.v ├── Param_sigma.v ├── Param_sum.v ├── Param_trans.v ├── Param_vector.v ├── Trocq.v └── Vernac.v /.devcontainer/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM coqorg/coq:8.17.1 2 | RUN eval $(opam env "--switch=${COMPILER}" --set-switch) 3 | RUN opam update -y 4 | RUN opam install -y coq-lsp 5 | RUN git clone -b strat --depth 1 https://github.com/ecranceMERCE/coq-elpi 6 | RUN opam install -y ./coq-elpi 7 | RUN opam install -y coq-mathcomp-algebra.1.19.0 -------------------------------------------------------------------------------- /.devcontainer/devcontainer.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "Trocq", 3 | "build": { 4 | "dockerfile": "Dockerfile" 5 | }, 6 | "postAttachCommand": "make -j8 -k", 7 | "customizations": { 8 | "vscode": { 9 | "extensions": ["ejgallego.coq-lsp", "gares.elpi-lang", "gares.coq-elpi-lang"], 10 | } 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.elpi linguist-language=prolog -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.aux 2 | .lia.cache 3 | *.glob 4 | *.vo 5 | *.vok 6 | *.vos 7 | *~ 8 | .*.d 9 | **/Makefile.conf 10 | -------------------------------------------------------------------------------- /.nix/config.nix: -------------------------------------------------------------------------------- 1 | { 2 | format = "1.0.0"; 3 | 4 | shell-attribute = "devshell"; 5 | attribute = "trocq"; 6 | 7 | default-bundle = "coq-9.0"; 8 | bundles."coq-8.20" = { 9 | coqPackages.trocq-std.main-job = true; 10 | coqPackages.trocq-hott.main-job = true; 11 | 12 | coqPackages.coq.override.version = "8.20"; 13 | }; 14 | bundles."coq-9.0" = { 15 | coqPackages.trocq-std.main-job = true; 16 | coqPackages.trocq-hott.main-job = true; 17 | 18 | coqPackages.coq.override.version = "9.0"; 19 | }; 20 | 21 | cachix.coq = { }; 22 | cachix.math-comp = { }; 23 | cachix.coq-community.authToken = "CACHIX_AUTH_TOKEN"; 24 | } 25 | -------------------------------------------------------------------------------- /.nix/coq-nix-toolbox.nix: -------------------------------------------------------------------------------- 1 | "0d640bae117cd64fd202e1453613d614b6e29aea" 2 | -------------------------------------------------------------------------------- /.nix/coq-overlays/HoTT/default.nix: -------------------------------------------------------------------------------- 1 | # waiting on https://github.com/NixOS/nixpkgs/pull/405615 to be merged 2 | 3 | { 4 | lib, 5 | mkCoqDerivation, 6 | coq, 7 | version ? null, 8 | }: 9 | 10 | mkCoqDerivation { 11 | pname = "HoTT"; 12 | repo = "Coq-HoTT"; 13 | owner = "HoTT"; 14 | inherit version; 15 | defaultVersion = 16 | with lib.versions; 17 | lib.switch coq.coq-version [ 18 | { 19 | case = range "8.14" "9.0"; 20 | out = coq.coq-version; 21 | } 22 | ] null; 23 | releaseRev = v: "V${v}"; 24 | release."8.14".sha256 = "sha256-7kXk2pmYsTNodHA+Qts3BoMsewvzmCbYvxw9Sgwyvq0="; 25 | release."8.15".sha256 = "sha256-JfeiRZVnrjn3SQ87y6dj9DWNwCzrkK3HBogeZARUn9g="; 26 | release."8.16".sha256 = "sha256-xcEbz4ZQ+U7mb0SEJopaczfoRc2GSgF2BGzUSWI0/HY="; 27 | release."8.17".sha256 = "sha256-GjTUpzL9UzJm4C2ilCaYEufLG3hcj7rJPc5Op+OMal8="; 28 | release."8.18".sha256 = "sha256-URoUoQOsG0432wg9i6pTRomWQZ+ewutq2+V29TBrVzc="; 29 | release."8.19".sha256 = "sha256-igG3mhR6uPXV+SCtPH9PBw/eAtTFFry6HPT5ypWj3tQ="; 30 | release."8.20".sha256 = "sha256-XHAvomi0of11j4x5gpTgD5Mw53eF1FpnCyBvdbV3g6I="; 31 | release."9.0".sha256 = "sha256-etdLH1qDyDc+ZM7K/65iib0MRlLhsnVmzWBCULUDD50="; 32 | 33 | # versions of HoTT for Coq 8.17 and onwards will use dune 34 | # opam-name = if lib.versions.isLe "8.17" coq.coq-version then "coq-hott" else null; 35 | opam-name = "coq-hott"; 36 | useDune = lib.versions.isGe "8.17" coq.coq-version; 37 | 38 | patchPhase = '' 39 | patchShebangs etc 40 | ''; 41 | 42 | meta = { 43 | homepage = "https://homotopytypetheory.org/"; 44 | description = "Homotopy Type Theory library"; 45 | longDescription = '' 46 | Homotopy Type Theory is an interpretation of Martin-Löf’s intensional 47 | type theory into abstract homotopy theory. Propositional equality is 48 | interpreted as homotopy and type isomorphism as homotopy equivalence. 49 | Logical constructions in type theory then correspond to 50 | homotopy-invariant constructions on spaces, while theorems and even 51 | proofs in the logical system inherit a homotopical meaning. As the 52 | natural logic of homotopy, type theory is also related to higher 53 | category theory as it is used e.g. in the notion of a higher topos. 54 | 55 | The HoTT library is a development of homotopy-theoretic ideas in the Coq 56 | proof assistant. It draws many ideas from Vladimir Voevodsky's 57 | Foundations library (which has since been incorporated into the Unimath 58 | library) and also cross-pollinates with the HoTT-Agda library. 59 | ''; 60 | maintainers = with lib.maintainers; [ 61 | alizter 62 | siddharthist 63 | ]; 64 | }; 65 | } 66 | -------------------------------------------------------------------------------- /.nix/coq-overlays/devshell/default.nix: -------------------------------------------------------------------------------- 1 | { 2 | mkCoqDerivation, 3 | lib, 4 | trocq, 5 | ... 6 | }: 7 | 8 | mkCoqDerivation { 9 | pname = "devshell"; 10 | inherit (trocq) version; 11 | 12 | src = ../../../.; 13 | 14 | installPhase = '' 15 | touch $out 16 | ''; 17 | 18 | buildInputs = 19 | let 20 | flattenMap = f: v: lib.flatten (lib.map f v); 21 | in 22 | lib.unique ( 23 | flattenMap (attr: flattenMap (v: v.${attr}) trocq.variants) [ 24 | "propagatedBuildInputs" 25 | "buildInputs" 26 | "propagatedNativeBuildInputs" 27 | "nativeBuildInputs" 28 | ] 29 | ); 30 | } 31 | -------------------------------------------------------------------------------- /.nix/coq-overlays/trocq-hott-examples/default.nix: -------------------------------------------------------------------------------- 1 | { 2 | lib, 3 | mathcomp, 4 | mkCoqDerivation, 5 | version ? null, 6 | trocq, 7 | }: 8 | 9 | let 10 | cleanSource = source: lib.cleanSourceWith { 11 | filter = ( 12 | name: type: 13 | let 14 | baseName = baseNameOf (toString name); 15 | in 16 | type != "regular" 17 | || !( 18 | baseName == ".Makefile.d" 19 | || lib.hasSuffix ".vo" baseName 20 | || lib.hasSuffix ".vok" baseName 21 | || lib.hasSuffix ".vos" baseName 22 | || lib.hasSuffix ".glob" baseName 23 | || lib.match "^\..*\.aux$" baseName != null 24 | ) 25 | ); 26 | src = lib.cleanSource source; 27 | }; 28 | in 29 | mkCoqDerivation { 30 | pname = "trocq-hott-examples"; 31 | inherit (trocq.hott) version; 32 | 33 | src = cleanSource ../../../examples; 34 | 35 | makeFlags = [ 36 | "-C" 37 | "hott" 38 | ]; 39 | 40 | propagatedBuildInputs = [ 41 | trocq.hott 42 | mathcomp.ssreflect 43 | mathcomp.algebra 44 | ]; 45 | } 46 | -------------------------------------------------------------------------------- /.nix/coq-overlays/trocq-hott/default.nix: -------------------------------------------------------------------------------- 1 | { 2 | lib, 3 | mkCoqDerivation, 4 | coq-elpi, 5 | HoTT, 6 | trocq, 7 | }: 8 | 9 | mkCoqDerivation { 10 | pname = "trocq-hott"; 11 | inherit (trocq) version; 12 | 13 | makeFlags = [ 14 | "-C" 15 | "hott" 16 | ]; 17 | 18 | propagatedBuildInputs = [ 19 | coq-elpi 20 | HoTT 21 | ]; 22 | } 23 | -------------------------------------------------------------------------------- /.nix/coq-overlays/trocq-std-examples/default.nix: -------------------------------------------------------------------------------- 1 | { 2 | lib, 3 | mathcomp, 4 | mkCoqDerivation, 5 | version ? null, 6 | trocq, 7 | }: 8 | 9 | let 10 | cleanSource = source: lib.cleanSourceWith { 11 | filter = ( 12 | name: type: 13 | let 14 | baseName = baseNameOf (toString name); 15 | in 16 | type != "regular" 17 | || !( 18 | baseName == ".Makefile.d" 19 | || baseName == "Makefile.conf" 20 | || lib.hasSuffix ".vo" baseName 21 | || lib.hasSuffix ".vok" baseName 22 | || lib.hasSuffix ".vos" baseName 23 | || lib.hasSuffix ".glob" baseName 24 | || lib.match "^\..*\.aux$" baseName != null 25 | ) 26 | ); 27 | src = lib.cleanSource source; 28 | }; 29 | in 30 | mkCoqDerivation { 31 | pname = "trocq-std-examples"; 32 | inherit (trocq.std) version; 33 | 34 | src = cleanSource ../../../examples; 35 | 36 | makeFlags = [ 37 | "-C" 38 | "std" 39 | ]; 40 | 41 | propagatedBuildInputs = [ 42 | trocq.std 43 | mathcomp.ssreflect 44 | mathcomp.algebra 45 | ]; 46 | } 47 | -------------------------------------------------------------------------------- /.nix/coq-overlays/trocq-std/default.nix: -------------------------------------------------------------------------------- 1 | { 2 | lib, 3 | mkCoqDerivation, 4 | coq-elpi, 5 | trocq, 6 | }: 7 | 8 | mkCoqDerivation { 9 | pname = "trocq-std"; 10 | inherit (trocq) version; 11 | 12 | makeFlags = [ 13 | "-C" 14 | "std" 15 | ]; 16 | 17 | propagatedBuildInputs = [ 18 | coq-elpi 19 | ]; 20 | } 21 | -------------------------------------------------------------------------------- /.nix/coq-overlays/trocq/default.nix: -------------------------------------------------------------------------------- 1 | { 2 | stdenv, 3 | lib, 4 | version ? null, 5 | trocq-std, 6 | trocq-hott, 7 | trocq-std-examples, 8 | trocq-hott-examples, 9 | }: 10 | 11 | stdenv.mkDerivation rec { 12 | name = "trocq"; 13 | inherit version; 14 | 15 | dontUnpack = true; 16 | 17 | passthru = rec { 18 | std = trocq-std; 19 | hott = trocq-hott; 20 | 21 | variants = [ 22 | std 23 | hott 24 | ]; 25 | examples = [ 26 | trocq-std-examples 27 | trocq-hott-examples 28 | ]; 29 | }; 30 | 31 | propagatedBuildInputs = passthru.variants; 32 | } 33 | -------------------------------------------------------------------------------- /.nix/rocq-overlays/trocq/default.nix: -------------------------------------------------------------------------------- 1 | # When building on the coq-9.0 bundle, the toolbox expects trocq to live in the 2 | # rocqPackages set despite using the compatibility Coq 9.0 version. To work 3 | # around this issue, redirect rocqPackages.trocq to coqPackages.trocq 4 | { coqPackages, ... }: coqPackages.trocq 5 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Cyril Cohen 2 | Enzo Crance 3 | Assia Mahboubi 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | -------------------------------------------------------------------------------- /CITATION.cff: -------------------------------------------------------------------------------- 1 | cff-version: 1.2.0 2 | authors: 3 | - family-names: Cohen 4 | given-names: Cyril 5 | orcid: https://orcid.org/0000-0003-3540-1050 6 | - family-names: Crance 7 | given-names: Enzo 8 | orcid: https://orcid.org/0000-0002-0498-0910 9 | - family-names: Lahaye 10 | given-names: Lucie 11 | - family-names: Mahboubi 12 | given-names: Assia 13 | orcid: https://orcid.org/0000-0002-0312-5461 14 | title: "Trocq" 15 | identifiers: 16 | - type: doi 17 | value: 10.5281/zenodo.10492403 18 | -------------------------------------------------------------------------------- /INSTALL.md: -------------------------------------------------------------------------------- 1 | # Getting started 2 | 3 | ## Getting the right setup 4 | 5 | This artifact contains an implementation of the Trocq parametricity framework as 6 | a plugin for the Coq proof assistant. As such, we offer several possibilities 7 | for the reader, according to their level of familiarity with the ecosystem and 8 | interest in our work for their own use. All methods were tested on Linux and 9 | macOS, we therefore recommend that the reader use one of these operating 10 | systems. 11 | 12 | ### Via codespaces (recommended browser setup) 13 | 14 | [Open codespaces](https://github.com/codespaces/new?skip_quickstart=true&machine=standardLinux32gb&repo=717137925&ref=master&devcontainer_path=.devcontainer%2Fdevcontainer.json&geo=EuropeWest) and click "Create codespace". 15 | 16 | ### Via VSCode and Docker (recommended machine setup) 17 | 18 | In this set-up, the reader considers this code mainly as the artifact 19 | for our paper, and thus wants to check it is working properly. To that 20 | end, we propose to interact in an easy way with a Docker container 21 | containing our code. The main requirement for the reader is to have 22 | [Docker](https://www.docker.com) and 23 | [VSCode](https://code.visualstudio.com) installed on their 24 | machine. The VSCode current user must have permission to run 25 | Docker. You also need to ensure you have more than 6GB of disk space 26 | available. 27 | 28 | The container with all the dependencies is accessible on Dockerhub as [`cohencyril/trocq-deps`](https://hub.docker.com/repository/docker/cohencyril/trocq-deps) and the corresponding `Dockerfile` is in [.devcontainer/Dockerfile](https://github.com/coq-community/trocq/blob/master/.devcontainer/Dockerfile) in this repo. You could run it manually using `docker run -it cohencyril/trocq-deps` but you would not be able to run VSCode in the docker terminal, hence the setup described below. 29 | 30 | Here are the instructions: 31 | - Make sure your VSCode has the [Dev 32 | Containers](https://marketplace.visualstudio.com/items?itemName=ms-vscode-remote.remote-containers) 33 | extension by running `code --install-extension 34 | ms-vscode-remote.remote-containers` or from the menus. 35 | - Clone or download the repository of the [Trocq 36 | plugin](https://github.com/coq-community/trocq), e.g. 37 | `curl -L -O https://github.com/coq-community/trocq/archive/master.zip && unzip master.zip` 38 | - Run VSCode in it (e.g. `code trocq-master`, or `code trocq-ESOP2024` if you are browsing the companion artifact to the paper) and immediately after opening it 39 | will suggest to "Reopen in Container", click this (otherwise type F1 and 40 | "Reopen in Container"). 41 | - Wait for VSCode to download a 1.28 GB archive that extracts to about 6 GB, on 42 | our system this takes about 2 min. 43 | - Wait for VSCode to compile the code of the plugin, this takes about 30s. 44 | The last line of the terminal output should be 45 | ``` 46 | make[1]: Leaving directory '/workspaces/trocq' 47 | ``` 48 | before you can actually skip to the next section. 49 | 50 | ### Via Nix (recommended only for nix/nixos users) 51 | 52 | 1. First install nix https://nixos.org/download 53 | 2. Add the [cachix](https://docs.cachix.org/installation) repository `coq-community` 54 | ```shell 55 | nix-env -iA cachix -f https://cachix.org/api/v1/install 56 | cachix use coq-community 57 | ``` 58 | 3. Clone the current repository and type `nix-shell` 59 | ```shell 60 | git clone https://github.com/coq-community/trocq.git 61 | nix-shell 62 | ``` 63 | 4. You may also use `nix-build` to build it and reuse it as a nix package. 64 | 65 | ### Via Opam (recommended only for ocaml/coq/opam users) 66 | 67 | 1. Install [opam](https://opam.ocaml.org/doc/Install.html) and configure the [coq opam repository](https://coq.inria.fr/opam-using.html#coq-packages) 68 | 2. Install the custom version of `coq-elpi` 69 | ```shell 70 | opam pin add coq-elpi https://github.com/ecranceMERCE/coq-elpi/archive/refs/heads/strat.tar.gz 71 | ``` 72 | 3. Build Trocq 73 | ```shell 74 | git clone https://github.com/coq-community/trocq.git 75 | cd trocq 76 | opam install . --deps-only # to install dependencies 77 | make # or make -j 78 | ``` 79 | 4. You can also run `make install` to install Trocq on your system. 80 | 81 | 82 | ## Exploring the examples with VSCode 83 | 84 | After completing the **Getting the right setup** phase above, the `examples` 85 | folder can be unfolded and the files can be inspected by clicking on them. 86 | 87 | When a file is clicked, it is displayed and a `Goals` tab opens. It shows the 88 | state of step-by-step execution of the file by Coq. The main actions related to 89 | the Trocq plugin are the `Trocq Use` commands feeding the database of the 90 | plugin, and the `trocq` tactic actually performing the expected proof transfer 91 | step. 92 | 93 | One can check that this tactic is working as expected by clicking right before 94 | it in the Coq file, waiting for Coq to execute the file until the pointer and 95 | update the proof state in the `Goals` panel, then clicking right after the dot 96 | after `trocq` and waiting for the proof state to be updated with the associated 97 | goal generated by Trocq to replace the initial one. The process should be almost 98 | instantaneous on all the examples. Please note that on the first time a line is 99 | clicked in a file, the proof state can take a few seconds to update. 100 | 101 | **If you have unexpected errors** press "Ctrl-Shift-P" to get the command palette 102 | and type `Coq LSP: Restart the Coq Language Server` and enter to reload the 103 | Coq $\leftrightarrow$ VSCode communication. 104 | 105 | ### Example from the artifact paper 106 | 107 | In file `artifact_paper_example.v`, this amounts to putting the pointer on line 108 | 38 column 7 (counter visible on the bottom right-hand side of the editor), then 109 | on line 38 column 14 and checking the updated goal is the expected one (in this 110 | particular case, featuring `nat` in the associated goal instead of `N` in the 111 | initial goal). 112 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: hott std 2 | .PHONY: all 3 | 4 | hott: 5 | $(MAKE) -C hott all 6 | .PHONY: hott 7 | 8 | std: 9 | $(MAKE) -C std all 10 | .PHONY: std 11 | 12 | clean: 13 | $(MAKE) -C hott clean 14 | $(MAKE) -C std clean 15 | .PHONY: clean 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # Trocq 6 | 7 | [![Contributing][contributing-shield]][contributing-link] 8 | [![Code of Conduct][conduct-shield]][conduct-link] 9 | [![Zulip][zulip-shield]][zulip-link] 10 | [![DOI][doi-shield]][doi-link] 11 | 12 | 13 | [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg 14 | [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md 15 | 16 | [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg 17 | [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md 18 | 19 | [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg 20 | [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users 21 | 22 | 23 | [doi-shield]: https://zenodo.org/badge/DOI/10.5281/zenodo.10492403.svg 24 | [doi-link]: https://doi.org/10.5281/zenodo.10492403 25 | 26 | Trocq is a modular parametricity plugin for Coq. It can be used to 27 | achieve proof transfer by both translating a user goal into another, 28 | related, variant, and computing a proof that proves the corresponding implication. 29 | 30 | The plugin features a hierarchy of structures on relations, whose 31 | instances are computed from registered user-defined proof via 32 | parametricity. This hierarchy ranges from structure-less relations 33 | to an original formulation of type equivalence. The resulting 34 | framework generalizes [raw 35 | parametricity](https://arxiv.org/abs/1209.6336), [univalent 36 | parametricity](https://doi.org/10.1145/3429979) and 37 | [CoqEAL](https://github.com/coq-community/coqeal), and includes them 38 | in a unified framework. 39 | 40 | The plugin computes a parametricity translation "à la carte", by 41 | performing a fine-grained analysis of the requires properties for a 42 | given proof of relatedness. In particular, it is able to prove 43 | implications without resorting to full-blown type equivalence, 44 | allowing this way to perform proof transfer without necessarily 45 | pulling in the univalence axiom. 46 | 47 | The plugin is implemented in Coq-Elpi and the code of the 48 | parametricity translation is fairly close to a pen-and-paper 49 | sequent-style presentation. 50 | 51 | ## Meta 52 | 53 | - Author(s): 54 | - Cyril Cohen (initial) 55 | - Enzo Crance (initial) 56 | - Lucie Lahaye 57 | - Assia Mahboubi (initial) 58 | - Coq-community maintainer(s): 59 | - Cyril Cohen ([**@CohenCyril**](https://github.com/CohenCyril)) 60 | - Enzo Crance ([**@ecranceMERCE**](https://github.com/ecranceMERCE)) 61 | - Lucie Lahaye ([**@lweqx**](https://github.com/lweqx)) 62 | - Assia Mahboubi ([**@amahboubi**](https://github.com/amahboubi)) 63 | - License: [GNU Lesser General Public License v3.0](LICENSE) 64 | - Compatible Coq versions: 8.20, 9.0 65 | - Additional dependencies: 66 | - [Coq-Elpi](https://github.com/LPCIC/coq-elpi) 67 | - Coq namespace: `Trocq` 68 | - Related publication(s): 69 | - [Trocq: Proof Transfer for Free, With or Without Univalence](https://hal.science/hal-04177913/document) 70 | 71 | ## Building and installation instructions 72 | 73 | Trocq is still a prototype. It is not yet packaged in Opam or Nix. 74 | 75 | There are however three ways to experiment with it, all documented 76 | in the [INSTALL.md file](INSTALL.md). 77 | 78 | ## Documentation 79 | 80 | See the [tutorial](artifact-doc/TUTORIAL.md) for concrete use cases. 81 | 82 | In short, the plugin provides a tactic: 83 | - `trocq` (without arguments) which attempts to run a translation on 84 | a given goal, using the information provided by the user with the 85 | commands described below. 86 | - `trocq R1 R2 ...` which works similarly to its argumentless counterpart 87 | except that it also uses translations associated to the relations `R1`, 88 | `R2`... ; see below regarding how to associated translations to a relation. 89 | 90 | And four commands: 91 | - `Trocq Use t` to use a translation `t` during the subsequent calls 92 | to the tactic `trocq`. 93 | - `Trocq Register Univalence u` to declare a univalence axiom `u`. 94 | - `Trocq Register Funext fe` to declare a function extensionality 95 | axiom `fe`. 96 | - `Trocq RelatedWith R t1 t2 ...` to associate `t1`, `t2`, ... to `R`. 97 | Subsequent calls to `trocq R` will be able to use the translations `t1`, 98 | `t2`, ... 99 | - `Trocq Logging "off"|"info"|"debug"|"trace"` to set the verbosity level. 100 | 101 | ## ESOP 2024 artifact documentation 102 | 103 | The ESOP 2024 artifact documentation files can be found in the `artifact-doc` directory, except for `INSTALL.md` that can be found in the current directory. 104 | -------------------------------------------------------------------------------- /artifact-doc/CLAIMS.md: -------------------------------------------------------------------------------- 1 | # Claims of the paper supported by the artifact 2 | 3 | ### Our formulation of type equivalence enables automation in the proofs. 4 | 5 | As this variant of type equivalence is symmetrical, the parametricity lemmas can be proved by combining atomic proofs over map classes. Indeed, for example, in file `Param_forall.v`, the following lemma is proved: 6 | ```coq 7 | Definition Map2a_forall 8 | (A A' : Type) (AR : Param04.Rel A A') (B : A -> Type) (B' : A' -> Type) 9 | (BR : forall a a', AR a a' -> Param2a0.Rel (B a) (B' a')) : 10 | Map2a.Has (R_forall AR BR). 11 | ``` 12 | 6 such lemmas are written, one for each level of the map class hierarchy. Then, by combining *e.g.* `Map1_forall` and a `Map2a_forall`, we can get the following parametricity lemma: 13 | ```coq 14 | Param12a_forall : 15 | (A A' : Type) (AR : Param42a.Rel A A') (B : A -> Type) (B' : A' -> Type) 16 | (BR : forall a a', AR a a' -> Param12a.Rel (B a) (B' a')) : 17 | Param12a.Rel (forall a, B a) (forall a', B' a'). 18 | ``` 19 | In the present implementation, all the possible combinations are generated with a meta-program, hence showing a high level of automation. The same remark can be made with other files such as `Param_Type.v`. 20 | 21 | ### Trocq can avoid univalence in some cases, whereas univalent parametricity systematically needs it. 22 | 23 | As explained in the paper, univalent parametricity makes use of the univalence axiom for every occurrence of `Type` in the initial goal. Yet, in our `peano_bin_nat.v` example file, we show that it is possible to perform proof transfer on the induction principle of natural numbers, between Coq representations `nat` and `N` of this mathematical concept, without resorting to the univalence axiom, even though it features an occurrence of `Type` in the codomain of the predicate `P`. 24 | 25 | ### Trocq handles non-bijective relations. 26 | 27 | In the `int_to_Zp.v` file, we present proof transfer done by Trocq on a goal featuring integers modulo a hypothetical constant $p$, which is not equivalent to the whole set of integers, but a weaker relation — a split surjection — can still be stated between them. Whereas tools like univalent parametricity propagate type equivalences everywhere, Trocq can handle more diverse relations in a finer-grained way. 28 | Another supporting evidence is in `nat_ind.v` where we show any type `I` with abstract zero and successor and a split surjection from `nat` compatible with zero and successor, can be endowed with an induction principle similar to the one of `nat`. 29 | 30 | ### Trocq can get stuck if the wrong translation is picked 31 | 32 | In the `stuck.v` file, we show that assuming that lists preserves equivalences `Param44_list` is too strong and that we need to have other preservation properties such as `Param2a4_list`, that are thus incomparable between themselves through the weakening relation. 33 | 34 | ### Trocq supports polymorphism and dependent types. 35 | 36 | The `Vector_tuple.v` file defines a type equivalence between fixed-size vectors and iterated tuples, which are both implemented in Coq using polymorphism — elements inside these data structures can be anything — and dependent types — to ensure the size is a fixed integer $n$. 37 | Proof transfer is then performed on a few goals to prove over iterated tuples, in order to be able to exploit standard library lemmas about vectors and get these properties "for free". 38 | 39 | ### Trocq subsumes the core features of generalised rewriting. 40 | 41 | Files `*_rewrite.v` show that Trocq can be used to rewrite with relations different from Leibniz equality, such as a custom equality over integers or an order relation over integers. 42 | 43 | ### Combining an inference-rule-based presentation of parametricity with the logic programming paradigm of Coq-Elpi allows to write the code in a readable way. 44 | 45 | The most telling example supporting this claim is the `elpi/param.elpi` file, featuring an instance of the Elpi `param` predicate for each syntactic construction, in correspondence with the inference rules of the paper. 46 | -------------------------------------------------------------------------------- /artifact-doc/INSTALL.md: -------------------------------------------------------------------------------- 1 | ../INSTALL.md -------------------------------------------------------------------------------- /artifact-doc/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /artifact-doc/README.md: -------------------------------------------------------------------------------- 1 | ../README.md -------------------------------------------------------------------------------- /artifact-doc/REQUIREMENTS.md: -------------------------------------------------------------------------------- 1 | # Requirements 2 | 3 | According to the path you want to follow there are different sets of 4 | requirements. 5 | 6 | ## Using github codespaces 7 | 8 | You need a github account and remaining minutes of usage in your Codespaces plan. 9 | Unless you are often using Codespaces for free, this requirement should be met. 10 | 11 | ## Using VSCode 12 | 13 | The main requirement is to have [Docker](https://www.docker.com) and 14 | [VSCode](https://code.visualstudio.com) installed on their machine. 15 | The VSCode current user must have permission to run Docker. You also 16 | need to ensure you have more than 6GB of disk space available. 17 | 18 | ## Using opam 19 | 20 | You need to have [opam](https://opam.ocaml.org/doc/Install.html) 21 | properly installed. 22 | 23 | ## Using nix 24 | 25 | You need to have either the nix package manager installed on your 26 | system (Linux, MacOS, WSL2) via https://nixos.org/download or a NixOS 27 | linux distribution. 28 | -------------------------------------------------------------------------------- /artifact-doc/STATUS.md: -------------------------------------------------------------------------------- 1 | # Badges applied for 2 | 3 | We apply for the Functional, Reusable and Available badges on this artifact. 4 | 5 | ## Functional 6 | 7 | We believe that this artifact covers the content of the paper. Indeed, the Coq files include a formalisation of the parametricity witness types presented in the paper, proofs of equivalence of the highest witness type with univalent parametricity, and various lemmas (symmetry, reflexivity, *etc.*). The fact that these proofs are formal proofs gives extra confidence that our results are correct. The Elpi files contain a parametricity framework implementation on top of this hierarchy of parametricity witness types. The architecture of the plugin enables the presentation of readable code, such as the `param.elpi` file corresponding to the core of the inference rules presented in the paper. 8 | 9 | ## Reusable 10 | 11 | This artifact is in reality a specially packaged version of a Coq plugin that, as such, aims to be installed by a substantial number of users and to evolve with the proof assistant in the mid term. To that end, we provide extensive documentation, both for users and developers, and the architecture of the plugin is made so that a user can actually make use of it in conditions of a real Coq formalisation. 12 | 13 | ## Available 14 | 15 | We archive our repository on both Zenodo and Software Heritage. 16 | - Via [Zenodo DOI 10.5281/zenodo.10492403](https://zenodo.org/records/10492404), 17 | - Via [Software Heritage](https://www.softwareheritage.org/), with direct link: [swh:1:dir:f7d5b646b2ee339c1bf50713763511da659582fb](https://archive.softwareheritage.org/browse/directory/f7d5b646b2ee339c1bf50713763511da659582fb/). 18 | -------------------------------------------------------------------------------- /coq-trocq.opam: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | 4 | opam-version: "2.0" 5 | maintainer: "Enzo Crance " 6 | version: "dev" 7 | 8 | homepage: "https://github.com/coq-community/trocq" 9 | dev-repo: "git+https://github.com/coq-community/trocq.git" 10 | bug-reports: "https://github.com/coq-community/trocq/issues" 11 | license: "LGPL-3.0-or-later" 12 | 13 | synopsis: "A modular parametricity plugin for proof transfer in Coq" 14 | description: """ 15 | Trocq is a modular parametricity plugin for Coq. It can be used to 16 | achieve proof transfer by both translating a user goal into another, 17 | related, variant, and computing a proof that proves the corresponding implication. 18 | 19 | The plugin features a hierarchy of structures on relations, whose 20 | instances are computed from registered user-defined proof via 21 | parametricity. This hierarchy ranges from structure-less relations 22 | to an original formulation of type equivalence. The resulting 23 | framework generalizes [raw 24 | parametricity](https://arxiv.org/abs/1209.6336), [univalent 25 | parametricity](https://doi.org/10.1145/3429979) and 26 | [CoqEAL](https://github.com/coq-community/coqeal), and includes them 27 | in a unified framework. 28 | 29 | The plugin computes a parametricity translation "à la carte", by 30 | performing a fine-grained analysis of the requires properties for a 31 | given proof of relatedness. In particular, it is able to prove 32 | implications without resorting to full-blown type equivalence, 33 | allowing this way to perform proof transfer without necessarily 34 | pulling in the univalence axiom. 35 | 36 | The plugin is implemented in Coq-Elpi and the code of the 37 | parametricity translation is fairly close to a pen-and-paper 38 | sequent-style presentation.""" 39 | 40 | build: [make "-j%{jobs}%"] 41 | install: [make "install"] 42 | depends: [ 43 | "coq" {>= "8.20" & < "9.1"} 44 | "coq-elpi" {= "2.5.2"} 45 | ] 46 | 47 | tags: [ 48 | "category:Computer Science/Decision Procedures and Certified Algorithms/Decision procedures" 49 | "category:Miscellaneous/Coq Extensions" 50 | "keyword:automation" 51 | "keyword:elpi" 52 | "keyword:proof transfer" 53 | "keyword:isomorphism" 54 | "keyword:univalence" 55 | "keyword:parametricity" 56 | "logpath:Trocq" 57 | ] 58 | authors: [ 59 | "Cyril Cohen" 60 | "Enzo Crance" 61 | "Lucie Lahaye" 62 | "Assia Mahboubi" 63 | ] 64 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { 2 | config ? { }, 3 | withEmacs ? false, 4 | print-env ? false, 5 | do-nothing ? false, 6 | update-nixpkgs ? false, 7 | ci-matrix ? false, 8 | override ? { }, 9 | ocaml-override ? { }, 10 | global-override ? { }, 11 | bundle ? null, 12 | job ? null, 13 | inNixShell ? null, 14 | src ? ./., 15 | }@args: 16 | let 17 | auto = fetchGit { 18 | url = "https://github.com/coq-community/coq-nix-toolbox.git"; 19 | ref = "master"; 20 | rev = import .nix/coq-nix-toolbox.nix; 21 | }; 22 | in 23 | import auto ({ inherit src; } // args) 24 | -------------------------------------------------------------------------------- /docs/.nojekyll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rocq-community/trocq/a508bc4ee8bfeb1f300b1d2f26c3b5fb0dc9c749/docs/.nojekyll -------------------------------------------------------------------------------- /docs/about.md: -------------------------------------------------------------------------------- 1 | # Authors 2 | 3 | This plugin is the joint work of [Cyril Cohen](https://perso.crans.org/cohen/), [Enzo Crance](https://ecrance.net), and [Assia Mahboubi](https://people.rennes.inria.fr/Assia.Mahboubi/). 4 | 5 | Should you have any question or remark about Trocq or anything related, please feel free to contact us by email or on the Coq Zulip server. 6 | 7 | ``` 8 | name [dot] surname [at] inria [dot] fr 9 | ``` -------------------------------------------------------------------------------- /docs/hierarchy.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rocq-community/trocq/a508bc4ee8bfeb1f300b1d2f26c3b5fb0dc9c749/docs/hierarchy.jpeg -------------------------------------------------------------------------------- /docs/home.md: -------------------------------------------------------------------------------- 1 |

Trocq logo

2 | 3 | [![GitHub repository][github-shield]][github-link] 4 | [![Contributing][contributing-shield]][contributing-link] 5 | [![Code of Conduct][conduct-shield]][conduct-link] 6 | [![Zulip][zulip-shield]][zulip-link] 7 | [![DOI][doi-shield]][doi-link] 8 | 9 | [github-shield]: https://img.shields.io/github/v/release/coq-community/trocq 10 | [github-link]: https://github.com/coq-community/trocq 11 | 12 | [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg 13 | [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md 14 | 15 | [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg 16 | [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md 17 | 18 | [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg 19 | [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users 20 | 21 | [doi-shield]: https://zenodo.org/badge/DOI/10.5281/zenodo.10492403.svg 22 | [doi-link]: https://doi.org/10.5281/zenodo.10492403 23 | 24 | **Trocq** is a prototype of a modular parametricity plugin for **Coq**, aiming 25 | to perform proof transfer by translating the goal into an associated 26 | goal featuring the target data structures as well as a rich 27 | parametricity witness from which a function justifying the goal 28 | substitution can be extracted. 29 | 30 | The plugin features a hierarchy of parametricity witness types, 31 | ranging from structure-less relations to a new formulation of type 32 | equivalence, gathering several pre-existing parametricity 33 | translations, including 34 | [univalent parametricity](https://doi.org/10.1145/3429979) and 35 | [CoqEAL](https://github.com/coq-community/coqeal), in the same framework. 36 | 37 | This modular translation performs a fine-grained analysis and 38 | generates witnesses that are rich enough to preprocess the goal yet 39 | are not always a full-blown type equivalence, allowing to perform 40 | proof transfer with the power of univalent parametricity, but trying 41 | not to pull in the univalence axiom in cases where it is not required. 42 | 43 | The translation is implemented in **Coq-Elpi** and features transparent 44 | and readable code with respect to a sequent-style theoretical presentation. 45 | 46 | ## Building and installation instructions 47 | 48 | As **Trocq** is a prototype, it is currently unreleased, and depends on a 49 | [custom version](https://github.com/ecranceMERCE/coq-elpi/tree/strat) 50 | of **Coq-Elpi**. It is not yet packaged in **Opam** or **Nix**, but will be in 51 | the near future. 52 | 53 | There are however three ways to develop it and experiment with it, 54 | they are documented in the [INSTALL.md file](https://github.com/coq-community/trocq/blob/master/INSTALL.md) of the repository. 55 | 56 | ## Documentation 57 | 58 | There are several kinds of documentation for **Trocq**: 59 | 60 | 1. The motivation, theoretical basis, and formal definition of **Trocq** are given in our [article](https://hal.science/hal-04177913/document), with details about our parametricity framework, the supported hierarchy of structures, *etc*. 61 | More theoretical details are available and implementation issues are discussed in a less space-constrained format in the related parts of Enzo Crance's [PhD thesis](https://ecrance.net/files/thesis-Enzo-Crance-en-light.pdf): 62 | - Part III, called *Trocq: proof transfer by parametricity*, currently page 69; 63 | - Part IV, called *Implementation of preprocessing tools with Coq-Elpi*, currently page 99. 64 | 65 | 2. A showcase of all the features of **Trocq** is available in the [examples](https://github.com/coq-community/trocq/tree/master/examples/) directory of the repository, and some of them are explained in the [tutorial](https://github.com/coq-community/trocq/blob/master/artifact-doc/TUTORIAL.md). 66 | 67 | 3. A quick start guide for complete beginners, written with practical utility in mind, is available on [this website](quick-start.md). -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Trocq 6 | 7 | 8 | 9 | 10 | 11 | 26 | 27 | 28 |
29 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /docs/inria-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rocq-community/trocq/a508bc4ee8bfeb1f300b1d2f26c3b5fb0dc9c749/docs/inria-logo.png -------------------------------------------------------------------------------- /docs/merce-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rocq-community/trocq/a508bc4ee8bfeb1f300b1d2f26c3b5fb0dc9c749/docs/merce-logo.png -------------------------------------------------------------------------------- /docs/sidebar.md: -------------------------------------------------------------------------------- 1 |

2 | Trocq logo 3 |

4 | 5 | - [Home](home.md) 6 | - [GitHub repository](https://github.com/coq-community/trocq/) 7 | - [Quick start](quick-start.md) 8 | + [Type isomorphisms](/quick-start?id=proof-transfer-with-type-isomorphisms) 9 | + [Directed relations](/quick-start?id=using-trocq-with-directed-relations-sections-and-retractions) 10 | + [Polymorphic and dependent container types](/quick-start?id=polymorphic-and-dependent-container-types) 11 | + [Trocq for advanced refinements](/quick-start?id=trocq-for-advanced-refinements) 12 | - [About](about.md) 13 | 14 |

15 | 16 | MERCE logo 17 | 18 | 19 | Inria logo 20 | 21 |

22 | -------------------------------------------------------------------------------- /docs/trocq-logo-text.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rocq-community/trocq/a508bc4ee8bfeb1f300b1d2f26c3b5fb0dc9c749/docs/trocq-logo-text.png -------------------------------------------------------------------------------- /docs/trocq-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rocq-community/trocq/a508bc4ee8bfeb1f300b1d2f26c3b5fb0dc9c749/docs/trocq-logo.png -------------------------------------------------------------------------------- /elpi/constraints/constraints.elpi: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % Trocq % 3 | % _______ % Copyright (C) 2023 Inria & MERCE % 4 | % |__ __| % (Mitsubishi Electric R&D Centre Europe) % 5 | % | |_ __ ___ ___ __ _ % Cyril Cohen % 6 | % | | '__/ _ \ / __/ _` | % Enzo Crance % 7 | % | | | | (_) | (_| (_| | % Assia Mahboubi % 8 | % |_|_| \___/ \___\__, | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 9 | % | | % This file is distributed under the terms of % 10 | % |_| % GNU Lesser General Public License Version 3 % 11 | % % (see LICENSE file for the text of the license) % 12 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13 | % ----------------------------------------------------------------------------- 14 | % API accessible to the rest of the plugin to handle the constraint graph 15 | % ----------------------------------------------------------------------------- 16 | 17 | typeabbrev class-id int. 18 | 19 | namespace cstr { 20 | 21 | pred init. 22 | 23 | % link a variable parametricity class C to its Coq representation (arguments of PType) 24 | pred univ-link o:param-class, o:term, o:term. 25 | 26 | % D_π(C, C_A, C_B) 27 | pred dep-pi i:param-class, o:param-class, o:param-class. 28 | 29 | % D_->(C, C_A, C_B) 30 | pred dep-arrow i:param-class, o:param-class, o:param-class. 31 | 32 | % D_□(C, C_R) 33 | pred dep-type i:param-class, i:param-class. 34 | 35 | % D_K(C, C_1, ..., C_n) 36 | pred dep-gref i:gref, i:term, o:term, o:gref. 37 | 38 | % C >= C' 39 | pred geq i:param-class, i:param-class. 40 | 41 | % C = C' 42 | pred eq i:param-class, i:param-class. 43 | 44 | % trigger reduction of the graph and instantiation of variables 45 | pred reduce-graph. 46 | 47 | pred local-db i:list prop. 48 | 49 | } % cstr 50 | -------------------------------------------------------------------------------- /elpi/constraints/simple-graph.elpi: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % Trocq % 3 | % _______ % Copyright (C) 2023 Inria & MERCE % 4 | % |__ __| % (Mitsubishi Electric R&D Centre Europe) % 5 | % | |_ __ ___ ___ __ _ % Cyril Cohen % 6 | % | | '__/ _ \ / __/ _` | % Enzo Crance % 7 | % | | | | (_) | (_| (_| | % Assia Mahboubi % 8 | % |_|_| \___/ \___\__, | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 9 | % | | % This file is distributed under the terms of % 10 | % |_| % GNU Lesser General Public License Version 3 % 11 | % % (see LICENSE file for the text of the license) % 12 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13 | % ----------------------------------------------------------------------------- 14 | % definition of a directed graph with no annotation on edges 15 | % ----------------------------------------------------------------------------- 16 | 17 | kind simple-graph type -> type. 18 | type simple-graph std.map A (list A) -> simple-graph A. 19 | 20 | namespace simple-graph { 21 | 22 | pred empty i:A -> A -> cmp -> prop, o:simple-graph A. 23 | empty Cmp (simple-graph G) :- 24 | std.map.make Cmp G. 25 | 26 | pred add-node i:A, i:simple-graph A, o:simple-graph A. 27 | add-node X (simple-graph G) (simple-graph G') :- 28 | std.map.add X [] G G'. 29 | 30 | pred add-edge i:A, i:A, i:simple-graph A, o:simple-graph A. 31 | add-edge X Y (simple-graph G) (simple-graph G') :- 32 | util.map.update X (add-edge.aux Y) G G'. 33 | 34 | pred add-edge.aux i:A, i:option (list A), o:option (list A). 35 | add-edge.aux Y none (some [Y]). 36 | add-edge.aux Y (some L) (some [Y|L]). 37 | 38 | % topological sort 39 | pred toposort i:simple-graph A, o:option (list A). 40 | toposort (simple-graph G) SortedNodes :- 41 | reversed-kahn {std.map.bindings G} [] SortedNodes. 42 | 43 | % Kahn's algorithm 44 | % reversed: we remove exit nodes instead of entry nodes 45 | pred reversed-kahn i:list (pair A (list A)), i:list A, o:option (list A). 46 | reversed-kahn Bindings Stack SortedNodes :- 47 | std.map-filter Bindings (p\ n\ p = pr n []) ExitNodes, 48 | if (ExitNodes = []) ( 49 | if (Bindings = []) 50 | (SortedNodes = some Stack) 51 | (SortedNodes = none) 52 | ) ( 53 | std.map-filter Bindings (p\ p'\ sigma Node Successors Successors'\ 54 | p = pr Node Successors, 55 | not (std.mem! ExitNodes Node), 56 | std.filter Successors (s\ not (std.mem! ExitNodes s)) Successors', 57 | p' = pr Node Successors' 58 | ) Bindings', 59 | reversed-kahn Bindings' {std.append ExitNodes Stack} SortedNodes 60 | ). 61 | 62 | } % simple-graph 63 | -------------------------------------------------------------------------------- /elpi/generation/param-prop.elpi: -------------------------------------------------------------------------------- 1 | pred generate-fields 2 | i:map-class, i:term, i:param-class, o:list term. 3 | generate-fields map0 R _ [R]. 4 | generate-fields map1 R _ [R, Map] :- 5 | Map = (fun `T` (sort prop) t\ t). 6 | generate-fields map2a R RClass [R, Map, MapInR] :- std.do! [ 7 | Prop = sort prop, 8 | Map = (fun `T` Prop t\ t), 9 | (pi a\ coq.mk-app R [a] (RF a)), 10 | Paths = {trocq.db.paths _}, 11 | coq.locate "transport" Transport, 12 | IdParam = const {trocq.db.id-param RClass}, 13 | coq.env.global Transport TransportTm, 14 | coq.env.global IdParam IdParamTm, 15 | MapInR = 16 | (fun `A` Prop a\ fun `B` Prop b\ 17 | fun `e` (app [Paths, Prop, a, b]) e\ 18 | app [TransportTm, Prop, RF a, a, b, 19 | e, app [IdParamTm, a]]) 20 | ]. 21 | 22 | pred generate-map-prop i:map-class, i:param-class. 23 | generate-map-prop M RClass :- std.do! [ 24 | trocq.db.rel RClass R _ _ _ _, 25 | Prop = sort prop, 26 | coq.env.global R RTm, 27 | % RTm = {{fun A B : Prop => lp:RTmNoEta A B}}, 28 | generate-fields M RTm RClass Fields, 29 | coq.locate "sym_rel" SymRel, 30 | coq.env.global SymRel SymRelTm, 31 | generate-fields 32 | M (app [SymRelTm, Prop, Prop, RTm]) 33 | RClass FieldsSym, 34 | coq.locate {calc ("Map" ^ {map-class.to_string M} ^ ".BuildHas")} BuildHas, 35 | coq.env.global BuildHas BuildHasTm, 36 | coq.mk-app BuildHasTm [Prop, Prop | Fields] Decl, 37 | coq.mk-app BuildHasTm [Prop, Prop | FieldsSym] DeclSym, 38 | MapProp is 39 | "Map" ^ {map-class.to_string M} ^ "_Prop" ^ {param-class.to_string RClass}, 40 | MapPropSym is 41 | "Map" ^ {map-class.to_string M} ^ "_Prop_sym" ^ 42 | {param-class.to_string RClass}, 43 | % these typechecks are very important: they add L < L1 to the constraint graph 44 | std.assert-ok! (coq.elaborate-skeleton Decl _Ty Decl') 45 | "generate-map-prop: Decl cannot be elaborated", 46 | std.assert-ok! (coq.elaborate-skeleton DeclSym _Ty' DeclSym') 47 | "generate-map-prop: Decl cannot be elaborated", 48 | % std.assert-ok! (coq.typecheck Decl _) 49 | % "generate-map-prop: Decl ill-typed", 50 | % std.assert-ok! (coq.typecheck DeclSym _) 51 | % "generate-map-prop: DeclSym ill-typed", 52 | @univpoly! ==> 53 | coq.env.add-const MapProp Decl' _ @transparent! _, 54 | coq.env.add-const MapPropSym DeclSym' _ @transparent! _ 55 | ]. 56 | -------------------------------------------------------------------------------- /elpi/generation/param-type.elpi: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % Trocq % 3 | % _______ % Copyright (C) 2023 Inria & MERCE % 4 | % |__ __| % (Mitsubishi Electric R&D Centre Europe) % 5 | % | |_ __ ___ ___ __ _ % Cyril Cohen % 6 | % | | '__/ _ \ / __/ _` | % Enzo Crance % 7 | % | | | | (_) | (_| (_| | % Assia Mahboubi % 8 | % |_|_| \___/ \___\__, | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 9 | % | | % This file is distributed under the terms of % 10 | % |_| % GNU Lesser General Public License Version 3 % 11 | % % (see LICENSE file for the text of the license) % 12 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13 | 14 | pred generate-fields 15 | i:map-class, i:term, i:param-class, i:univ, 16 | i:univ.variable, i:univ.variable, o:list term. 17 | generate-fields map0 R _ _ _ _ [R]. 18 | generate-fields map1 R _ U _ _ [R, Map] :- 19 | Map = (fun `T` (sort (typ U)) t\ t). 20 | generate-fields map2a R RClass U L L1 [R, Map, MapInR] :- 21 | Type = sort (typ U), 22 | coq.univ-instance UI [L], 23 | coq.univ-instance UI1 [L1], 24 | coq.univ-instance UI11 [L1, L1], 25 | Map = (fun `T` Type t\ t), 26 | (pi a\ coq.mk-app R [a] (RF a)), 27 | Paths = {trocq.db.paths UI1}, 28 | coq.locate "transport" Transport, 29 | IdParam = const {trocq.db.id-param RClass}, 30 | MapInR = 31 | (fun `A` Type a\ fun `B` Type b\ 32 | fun `e` (app [Paths, Type, a, b]) e\ 33 | app [pglobal Transport UI11, Type, RF a, a, b, 34 | e, app [pglobal IdParam UI, a]]). 35 | 36 | pred generate-map-type 37 | i:map-class, i:param-class, i:univ, i:univ.variable, i:univ.variable. 38 | generate-map-type M RClass U L L1 :- 39 | trocq.db.rel RClass R _ _ _ _, 40 | Type = sort (typ U), 41 | coq.univ-instance UI [L], 42 | coq.univ-instance UI1 [L1], 43 | generate-fields M (pglobal R UI) RClass U L L1 Fields, 44 | coq.locate "sym_rel" SymRel, 45 | generate-fields 46 | M (app [pglobal SymRel UI1, Type, Type, pglobal R UI]) 47 | RClass U L L1 FieldsSym, 48 | coq.locate {calc ("Map" ^ {map-class.to_string M} ^ ".BuildHas")} BuildHas, 49 | Decl = app [pglobal BuildHas UI1, Type, Type | Fields], 50 | DeclSym = app [pglobal BuildHas UI1, Type, Type | FieldsSym], 51 | MapType is 52 | "Map" ^ {map-class.to_string M} ^ "_Type" ^ {param-class.to_string RClass}, 53 | MapTypeSym is 54 | "Map" ^ {map-class.to_string M} ^ "_Type_sym" ^ 55 | {param-class.to_string RClass}, 56 | % these typechecks are very important: they add L < L1 to the constraint graph 57 | std.assert-ok! (coq.typecheck Decl _) "generate-map-type: Decl ill-typed", 58 | std.assert-ok! (coq.typecheck DeclSym _) "generate-map-type: DeclSym ill-typed", 59 | @udecl! [L, L1] ff [lt L L1] tt ==> 60 | coq.env.add-const MapType Decl _ @transparent! _, 61 | coq.env.add-const MapTypeSym DeclSym _ @transparent! _. 62 | 63 | pred generate-param-type 64 | i:param-class, i:param-class, i:univ, i:univ.variable, i:univ.variable. 65 | generate-param-type (pc M N as Class) RClass U L L1 :- 66 | map-class.to_string M MStr, 67 | map-class.to_string N NStr, 68 | coq.univ-instance UI [L], 69 | coq.univ-instance UI1 [L1], 70 | coq.univ-instance UI2 [L, L1], 71 | trocq.db.rel Class _ BuildRel _ _ _, 72 | coq.locate 73 | {calc ("Map" ^ MStr ^ "_Type" ^ {param-class.to_string RClass})} MapType, 74 | coq.locate 75 | {calc ("Map" ^ NStr ^ "_Type_sym" ^ {param-class.to_string RClass})} 76 | MapTypeSym, 77 | trocq.db.rel RClass R _ _ _ _, 78 | if (std.mem! [map2b, map3, map4] M) ( 79 | UnivalentDecl = true, 80 | MapTypeF = (u\ app [pglobal MapType UI2, u]), 81 | if (std.mem! [map2b, map3, map4] N) 82 | (MapTypeSymF = (u\ app [pglobal MapTypeSym UI2, u])) 83 | (MapTypeSymF = (_\ pglobal MapTypeSym UI2)) 84 | ) ( 85 | MapTypeF = (_\ pglobal MapType UI2), 86 | if (std.mem! [map2b, map3, map4] N) ( 87 | MapTypeSymF = (u\ app [pglobal MapTypeSym UI2, u]), 88 | UnivalentDecl = true 89 | ) ( 90 | MapTypeSymF = (_\ pglobal MapTypeSym UI2), 91 | UnivalentDecl = false 92 | ) 93 | ), 94 | % in the univalent case, add the axiom in the binder 95 | if (UnivalentDecl) ( 96 | coq.locate "Univalence" Univalence, 97 | Decl = 98 | (fun `H` (global Univalence) u\ 99 | app [pglobal BuildRel UI1, sort (typ U), sort (typ U), pglobal R UI, 100 | MapTypeF u, MapTypeSymF u]) 101 | ) ( 102 | Dummy = (fun `x` (sort (typ U)) x\ x), 103 | Decl = 104 | app [pglobal BuildRel UI1, sort (typ U), sort (typ U), pglobal R UI, 105 | MapTypeF Dummy, MapTypeSymF Dummy] 106 | ), 107 | ParamType is "Param" ^ MStr ^ NStr ^ "_Type" ^ {param-class.to_string RClass}, 108 | % this typecheck is very important: it adds L < L1 to the constraint graph 109 | std.assert-ok! (coq.typecheck Decl _) "generate-param-type: Decl is ill-typed", 110 | (@udecl! [L, L1] ff [lt L L1] tt => 111 | coq.env.add-const ParamType Decl _ @transparent! Const), 112 | coq.elpi.accumulate _ "trocq.db" (clause _ _ (trocq.db.param-type Class RClass Const)). 113 | -------------------------------------------------------------------------------- /elpi/generation/pparam-type.elpi: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % Trocq % 3 | % _______ % Copyright (C) 2023 Inria & MERCE % 4 | % |__ __| % (Mitsubishi Electric R&D Centre Europe) % 5 | % | |_ __ ___ ___ __ _ % Cyril Cohen % 6 | % | | '__/ _ \ / __/ _` | % Enzo Crance % 7 | % | | | | (_) | (_| (_| | % Assia Mahboubi % 8 | % |_|_| \___/ \___\__, | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 9 | % | | % This file is distributed under the terms of % 10 | % |_| % GNU Lesser General Public License Version 3 % 11 | % % (see LICENSE file for the text of the license) % 12 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13 | 14 | pred generate-branch i:univ-instance, i:param-class, i:param-class, o:term. 15 | generate-branch UI2 Class RClass (pglobal ParamType UI2) :- 16 | coq.locate 17 | {calc ("Param" ^ {param-class.to_string Class} ^ "_Type" ^ {param-class.to_string RClass})} 18 | ParamType. 19 | 20 | pred generate-match2 21 | i:term, i:univ-instance, i:param-class, i:term, i:map-class, o:term. 22 | generate-match2 RetType UI2 Class QVar P Match :- 23 | map-class.all-of-kind all Classes, std.map Classes 24 | (q\ b\ generate-branch UI2 Class (pc P q) b) Branches, 25 | coq.locate "map_class" MapClass, 26 | coq.univ-instance UI0 [], 27 | Match = (match QVar (fun `_` (pglobal MapClass UI0) _\ RetType) Branches). 28 | 29 | pred generate-match1 30 | i:term, i:univ-instance, i:param-class, i:term, i:term, o:term. 31 | generate-match1 RetType UI2 Class PVar QVar Match :- 32 | map-class.all-of-kind all Classes, std.map Classes 33 | (p\ b\ generate-match2 RetType UI2 Class QVar p b) Branches, 34 | coq.locate "map_class" MapClass, 35 | coq.univ-instance UI0 [], 36 | Match = (match PVar (fun `_` (pglobal MapClass UI0) _\ RetType) Branches). 37 | 38 | pred generate-pparam-type 39 | i:univ.variable, i:univ.variable, i:param-class. 40 | generate-pparam-type L L1 Class :- 41 | trocq.db.rel Class ParamRel _ _ _ _, 42 | coq.univ-instance UI1 [L1], 43 | RetType = app [pglobal ParamRel UI1, sort (typ U), sort (typ U)], 44 | coq.univ-instance UI2 [L, L1], 45 | (pi p q\ generate-match1 RetType UI2 Class p q (MatchF p q)), 46 | Decl = (fun `p` {{ map_class }} p\ fun `q` {{ map_class }} q\ MatchF p q), 47 | % this typecheck is very important: it adds L < L1 to the constraint graph 48 | std.assert-ok! (coq.typecheck Decl _) "generate-pparam-type: Decl is ill-typed", 49 | PParamType is "PParam" ^ {param-class.to_string Class} ^ "_Type", 50 | (@udecl! [L, L1] ff [lt L L1] tt => 51 | coq.env.add-const PParamType Decl _ @transparent! Const), 52 | coq.elpi.accumulate _ "trocq.db" (clause _ _ (trocq.db.pparam-type Class Const)). 53 | 54 | pred generate-pparam-type44 55 | i:univ.variable, i:univ.variable, i:param-class. 56 | generate-pparam-type44 L L1 Class :- 57 | coq.univ-instance UI2 [L, L1], 58 | coq.locate {calc ("Param" ^ {param-class.to_string Class} ^ "_Type44")} ParamType, 59 | Decl = (fun `_` {{ map_class }} _\ fun `_` {{ map_class }} _\ pglobal ParamType UI2), 60 | % this typecheck is very important: it adds L < L1 to the constraint graph 61 | std.assert-ok! (coq.typecheck Decl _) "generate-pparam-type44: Decl is ill-typed", 62 | PParamType is "PParam" ^ {param-class.to_string Class} ^ "_Type", 63 | (@udecl! [L, L1] ff [lt L L1] ff => 64 | coq.env.add-const PParamType Decl _ @transparent! Const), 65 | coq.elpi.accumulate _ "trocq.db" (clause _ _ (trocq.db.pparam-type Class Const)). 66 | -------------------------------------------------------------------------------- /elpi/param-class-util.elpi: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % Trocq % 3 | % _______ % Copyright (C) 2023 Inria & MERCE % 4 | % |__ __| % (Mitsubishi Electric R&D Centre Europe) % 5 | % | |_ __ ___ ___ __ _ % Cyril Cohen % 6 | % | | '__/ _ \ / __/ _` | % Enzo Crance % 7 | % | | | | (_) | (_| (_| | % Assia Mahboubi % 8 | % |_|_| \___/ \___\__, | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 9 | % | | % This file is distributed under the terms of % 10 | % |_| % GNU Lesser General Public License Version 3 % 11 | % % (see LICENSE file for the text of the license) % 12 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13 | % ----------------------------------------------------------------------------- 14 | % utilities about param-class 15 | % ----------------------------------------------------------------------------- 16 | 17 | namespace param-class { 18 | 19 | % generate a weakening function from a parametricity class to another, by forgetting fields 1 by 1 20 | pred forget i:param-class, i:param-class, o:univ-instance -> term -> term -> term -> term. 21 | forget (pc M N) (pc M N) (_\ _\ _\ r\ r) :- !. 22 | forget (pc M N) (pc M N') ForgetF :- !, 23 | std.mem {map-class.weakenings-from N} N1, 24 | forget (pc M N1) (pc M N') ForgetF', !, 25 | map-class.to_string M MStr, 26 | coq.locate 27 | {calc ("forget_" ^ MStr ^ {map-class.to_string N} ^ "_" ^ MStr ^ {map-class.to_string N1})} Forget1, 28 | ForgetF = (ui\ a\ b\ r\ ForgetF' ui a b (app [pglobal Forget1 ui, a, b, r])). 29 | forget (pc M N) (pc M' N') ForgetF :- 30 | std.mem {map-class.weakenings-from M} M1, 31 | forget (pc M1 N) (pc M' N') ForgetF', !, 32 | map-class.to_string N NStr, 33 | coq.locate 34 | {calc ("forget_" ^ {map-class.to_string M} ^ NStr ^ "_" ^ {map-class.to_string M1} ^ NStr)} Forget1, 35 | ForgetF = (ui\ a\ b\ r\ ForgetF' ui a b (app [pglobal Forget1 ui, a, b, r])). 36 | 37 | % weaking of the out class of a gref. 38 | % e.g. if GR has type `forall A B, R A B -> Param21 X Y` 39 | % then `weaken-out (pc map1 map0) GR T` 40 | % where `T` has type `forall A B, R A B -> Param10 X Y` 41 | pred weaken-out i:param-class, i:gref, o:term. 42 | weaken-out OutC GR WT :- std.do! [ 43 | coq.env.global GR T, 44 | coq.env.typeof GR Ty, 45 | replace-out-ty OutC Ty WTy, 46 | std.assert-ok! (coq.elaborate-skeleton T WTy WT) 47 | "weaken-out: failed to weaken" 48 | ]. 49 | 50 | pred replace-out-ty i:param-class, i:term, o:term. 51 | replace-out-ty OutC (prod N A B) (prod N A B') :- !, 52 | pi x\ replace-out-ty OutC (B x) (B' x). 53 | replace-out-ty OutC InT OutT :- std.do! [ 54 | coq.safe-dest-app InT HD Ts, 55 | trocq.db.gref->class OutGRClass OutC, 56 | subst-gref HD OutGRClass HD', 57 | coq.mk-app HD' Ts OutT 58 | ]. 59 | 60 | % find classes present in a term 61 | pred type->class i:term, o:list param-class, o:list term. 62 | type->class X [Class] Ts :- 63 | coq.safe-dest-app X HD Ts, 64 | (do-not-fail => coq.term->gref HD GRClass), 65 | trocq.db.gref->class GRClass Class. 66 | type->class X [] Ts :- coq.safe-dest-app X _ Ts. 67 | type->class _ [] []. 68 | 69 | pred type->classes.rec i:term, o:list param-class, o:list param-class. 70 | type->classes.rec (prod N A B) OutList BLast:- !, 71 | @pi-decl N A x\ 72 | type->classes.rec A AList ALast, !, 73 | type->classes.rec (B x) BList BLast, !, 74 | std.append {std.append AList ALast} BList OutList. 75 | type->classes.rec X [] Class :- !, type->class X Class _. 76 | 77 | pred type->classes.main i:term, o:list param-class, o:list param-class, o:gref, o:gref. 78 | type->classes.main (prod N A B) OutList BLast GR GR' :- !, 79 | @pi-decl N A x\ 80 | type->classes.rec A AList ALast, !, 81 | type->classes.main (B x) BList BLast GR GR', !, 82 | std.append {std.append AList ALast} BList OutList. 83 | type->classes.main X [] Class GR GR' :- !, 84 | type->class X Class Ts, !, 85 | std.rev Ts [T', T | _], 86 | coq.term->gref T GR, coq.term->gref T' GR'. 87 | 88 | pred type->classes i:term, o:param-class, o:list param-class, o:gref, o:gref. 89 | type->classes T OutClass DepClasses GR GR' :- 90 | type->classes.main T DepClasses LastClass GR GR', 91 | if (LastClass = [OutClass]) true (OutClass = pc map0 map0). 92 | 93 | } % param-class 94 | -------------------------------------------------------------------------------- /elpi/tactic.elpi: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % Trocq % 3 | % _______ % Copyright (C) 2023 Inria & MERCE % 4 | % |__ __| % (Mitsubishi Electric R&D Centre Europe) % 5 | % | |_ __ ___ ___ __ _ % Cyril Cohen % 6 | % | | '__/ _ \ / __/ _` | % Enzo Crance % 7 | % | | | | (_) | (_| (_| | % Assia Mahboubi % 8 | % |_|_| \___/ \___\__, | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 9 | % | | % This file is distributed under the terms of % 10 | % |_| % GNU Lesser General Public License Version 3 % 11 | % % (see LICENSE file for the text of the license) % 12 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13 | 14 | :before "coq-assign-evar-raw" 15 | evar _ _ _ :- !. 16 | 17 | :before "coq-assign-evar-refined" 18 | evar _ _ _ :- !. 19 | 20 | pred known->gref i:prop, o:prop. 21 | known->gref 22 | (trocq.db.known-gref _Rel GR OutCl Classes GR' GRR) 23 | (trocq.db.gref GR OutCl Classes GR' GRR :- !). 24 | 25 | pred load-rel i:gref, o:list prop. 26 | load-rel GRRel DB :- std.do! [ 27 | std.findall 28 | (trocq.db.known-gref GRRel _GR _OutCl _Classes _GR' _GRR) 29 | AllRel, 30 | std.map AllRel known->gref DB 31 | ]. 32 | 33 | pred load-rels i:list gref, o:list prop. 34 | load-rels GRRels DB :- std.do! [ 35 | std.map GRRels load-rel DBs, 36 | std.flatten DBs DB 37 | ]. 38 | 39 | solve InitialGoal NewGoals :- std.do! [ 40 | InitialGoal = goal _Context _ G _ Args, 41 | std.assert-ok! (coq.typecheck G Ty) "goal ill-typed", 42 | logging.info (coq.say "translating args" Args), 43 | std.map Args util.argument->gref GRArgs, 44 | logging.info (coq.say "loading rels" GRArgs), 45 | load-rels GRArgs DB, 46 | logging.info (coq.say "local DB" DB), 47 | logging.info (coq.say "goal" {coq.term->string G}), 48 | translate-goal DB Ty G (pc map0 map1) G' GR, 49 | logging.info ( 50 | coq.say "trocq:" {coq.term->string G} "~" {coq.term->string G'} 51 | "by" {coq.term->string GR} 52 | ), 53 | FinalProof = {{ @comap lp:G lp:G' lp:GR (_ : lp:G') }}, 54 | logging.info (coq.say {coq.term->string FinalProof}), 55 | 56 | std.assert-ok! (coq.elaborate-skeleton FinalProof G EFinalProof) "proof elaboration error", 57 | std.assert-ok! (coq.typecheck EFinalProof G2) "proof typechecking error", 58 | std.assert-ok! (coq.unify-leq G2 G) "goal unification error", 59 | refine.no_check EFinalProof InitialGoal NewGoals 60 | ]. 61 | 62 | pred translate-goal i:list prop, i:term, i:term, i:param-class, o:term, o:term. 63 | translate-goal DB Ty G (pc M N) G' GR' :- DB => std.do! [ 64 | cstr.init, 65 | if (Ty = sort prop) 66 | (SortAnnotation = pglobal (const {trocq.db.pprop}) _; 67 | coq.error "Prop goals are not supported when using the HoTT variant.") 68 | (SortAnnotation = pglobal (const {trocq.db.ptype}) _), 69 | T = app [SortAnnotation, {trocq.db.map-class->term M}, {trocq.db.map-class->term N}], 70 | % first annotate the initial goal with fresh parametricity class variables 71 | term->annot-term G AG, 72 | logging.debug ( 73 | coq.say "will translate" AG "at level" T, 74 | coq.say "***********************************************************************************" 75 | ), 76 | % generate the associated goal G' and witness GR 77 | param AG T G' GR, 78 | logging.debug ( 79 | coq.say "***********************************************************************************", 80 | coq.say "after translation:", 81 | coq.say "goal:" G', 82 | coq.say "proof:" GR, 83 | coq.say "***********************************************************************************" 84 | ), 85 | % reduce the graph, so the variables all become ground in the terms 86 | cstr.local-db DB, 87 | cstr.reduce-graph, 88 | % now we can remove the weaken placeholders and replace them with real weakening functions 89 | % or nothing if it is weaken α α 90 | param.subst-weaken GR GR', 91 | logging.debug ( 92 | coq.say "***********************************************************************************", 93 | coq.say "after reduction:", 94 | coq.say "goal:" {coq.term->string G'}, 95 | coq.say "proof:" {coq.term->string GR'}, 96 | coq.say "***********************************************************************************" 97 | ) 98 | % no need to remove the remaining annotations because they are invisible modulo conversion 99 | ]. 100 | 101 | -------------------------------------------------------------------------------- /elpi/util.elpi: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % Trocq % 3 | % _______ % Copyright (C) 2023 Inria & MERCE % 4 | % |__ __| % (Mitsubishi Electric R&D Centre Europe) % 5 | % | |_ __ ___ ___ __ _ % Cyril Cohen % 6 | % | | '__/ _ \ / __/ _` | % Enzo Crance % 7 | % | | | | (_) | (_| (_| | % Assia Mahboubi % 8 | % |_|_| \___/ \___\__, | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 9 | % | | % This file is distributed under the terms of % 10 | % |_| % GNU Lesser General Public License Version 3 % 11 | % % (see LICENSE file for the text of the license) % 12 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13 | % ----------------------------------------------------------------------------- 14 | % utility predicates 15 | % ----------------------------------------------------------------------------- 16 | 17 | % Note: should only contain definitions available during synterp 18 | 19 | pred do-not-fail. 20 | 21 | kind or type -> type -> type. 22 | type inl A -> or A B. 23 | type inr B -> or A B. 24 | 25 | kind verbosity type. 26 | type level.off verbosity. 27 | type level.info verbosity. 28 | type level.debug verbosity. 29 | type level.trace verbosity. 30 | 31 | % Returns the numeric level associated to a verbosity, the higher the more verbose. 32 | pred verbosity->int i:verbosity, o:int. 33 | verbosity->int level.off -1. 34 | verbosity->int level.info 0. 35 | verbosity->int level.debug 1. 36 | verbosity->int level.trace 2. 37 | 38 | % Returns the verbosity level given a name. 39 | pred string->verbosity i:string o:verbosity. 40 | string->verbosity "off" level.off. 41 | string->verbosity "info" level.info. 42 | string->verbosity "debug" level.debug. 43 | string->verbosity "trace" level.trace. 44 | 45 | pred log-level o:verbosity. 46 | :name "log-level" 47 | log-level level.info. 48 | 49 | pred logging.info i:prop. 50 | logging.info P :- util.at-level level.info P. 51 | pred logging.debug i:prop. 52 | logging.debug P :- util.at-level level.debug P. 53 | pred logging.trace i:prop. 54 | logging.trace P :- util.at-level level.trace P. 55 | 56 | namespace util { 57 | 58 | pred option.value i:option A, i:A, o:A. 59 | option.value none Default Default. 60 | option.value (some A) _ A. 61 | 62 | pred cmp-int i:int, i:int, o:cmp. 63 | cmp-int A B lt :- A < B, !. 64 | cmp-int A B eq :- A = B, !. 65 | cmp-int _ _ gt. 66 | 67 | pred at-level i:verbosity, i:prop. 68 | at-level MinimumLevel Log :- log-level CurrentLevel, !, 69 | if ({verbosity->int CurrentLevel} >= {verbosity->int MinimumLevel}) Log true. 70 | at-level _ _. 71 | 72 | pred when i:prop, i:prop. 73 | when Condition Goal :- 74 | if (Condition) Goal true. 75 | 76 | pred unless i:prop, i:prop. 77 | unless Condition Goal :- 78 | if (Condition) true Goal. 79 | 80 | pred if-suspend i:A, i:prop, i:prop, i:prop. 81 | if-suspend V B T E :- var V, !, declare_constraint (if B T E) [V]. 82 | if-suspend _ B T E :- if B T E. 83 | 84 | pred map.find-opt i:A, i:std.map A B, o:option B. 85 | map.find-opt K M (some V) :- std.map.find K M V, !. 86 | map.find-opt _ _ none. 87 | 88 | pred map.update i:A, i:(option B -> option B -> prop), i:std.map A B, o:std.map A B. 89 | map.update K F M M' :- 90 | map.find-opt K M (some V), !, 91 | F (some V) OV', 92 | if (OV' = some V') 93 | (std.map.add K V' M M') % replace 94 | (std.map.remove K M M'). % remove 95 | map.update K F M M' :- 96 | F none (some V'), 97 | std.map.add K V' M M'. % add 98 | map.update _ _ M M. % no-op 99 | 100 | pred delete i:A, i:list A, o:list A. 101 | delete A [A|Xs] Xs :- !. 102 | delete A [X|Xs] [X|Xs'] :- delete A Xs Xs'. 103 | delete _ [] []. 104 | 105 | % Elpi does not allow replacing a named clause with a named clause. This is not allowed: 106 | % coq.elpi.accumulate Scope Database (clause ClauseName (replace ClauseName) Content) 107 | % (read the explanation: https://github.com/LPCIC/elpi/blob/62d3f0c311206cb4b0cf033c34fca8336c61822e/ELPI.md?plain=1#L281) 108 | % This utility predicate emulates this feature. 109 | % However it does not solve the fundamental issue that lead Elpi to forbid 110 | % this, so one has to be cautious when using it. 111 | pred accumulate-replacing-named-clause i:scope, i:id, i:id, i:prop. 112 | accumulate-replacing-named-clause Scope Database ClauseName Content :- 113 | GraftingPoint is ClauseName ^ "-temporary-grafting-point", 114 | coq.elpi.accumulate Scope Database (clause GraftingPoint (after ClauseName) Content), 115 | coq.elpi.accumulate Scope Database (clause _ (remove ClauseName) Content), 116 | coq.elpi.accumulate Scope Database (clause ClauseName (before GraftingPoint) Content), 117 | coq.elpi.accumulate Scope Database (clause _ (remove GraftingPoint) Content). 118 | 119 | } % util 120 | 121 | pred std.string.list->set i:list string, o:std.string.set. 122 | std.string.list->set [] Empty :- std.string.set.empty Empty. 123 | std.string.list->set [S|Rest] Set :- 124 | std.string.set.add S {std.string.list->set Rest} Set. 125 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | .PHONY: all 3 | 4 | clean: 5 | $(MAKE) -C hott clean 6 | $(MAKE) -C std clean 7 | .PHONY: clean 8 | 9 | std: 10 | $(MAKE) -C std 11 | .PHONY: std 12 | 13 | hott: 14 | $(MAKE) -C hott 15 | .PHONY: clean 16 | -------------------------------------------------------------------------------- /examples/N.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From Trocq Require Import Stdlib Common. 15 | From mathcomp Require Import ssreflect. 16 | 17 | Set Universe Polymorphism. 18 | Set Bullet Behavior "Strict Subproofs". 19 | 20 | (* definition of binary natural numbers *) 21 | 22 | Inductive positive : Set := 23 | | xI : positive -> positive 24 | | xO : positive -> positive 25 | | xH : positive. 26 | 27 | Declare Scope positive_scope. 28 | Delimit Scope positive_scope with positive. 29 | Bind Scope positive_scope with positive. 30 | 31 | Notation "1" := xH : positive_scope. 32 | Notation "p ! 1" := (xI p) 33 | (at level 1, left associativity, format "p '!' '1'") : positive_scope. 34 | Notation "p ! 0" := (xO p) 35 | (at level 1, left associativity, format "p '!' '0'") : positive_scope. 36 | 37 | Module Pos. 38 | Local Open Scope positive_scope. 39 | Fixpoint succ x := 40 | match x with 41 | | p!1 => (succ p)!0 42 | | p!0 => p!1 43 | | 1 => 1!0 44 | end. 45 | 46 | Fixpoint to_nat (x : positive) : nat := 47 | match x with 48 | | p!1 => 1 + (to_nat p + to_nat p) 49 | | p!0 => to_nat p + to_nat p 50 | | 1 => 1 51 | end. 52 | 53 | Fixpoint add (x y : positive) : positive := 54 | match x, y with 55 | | 1, p | p, 1 => succ p 56 | | p!0, q!0 => (add p q)!0 57 | | p!0, q!1 | p!1, q!0 => (add p q)!1 58 | | p!1, q!1 => succ (add p q)!1 59 | end. 60 | Infix "+" := add : positive_scope. 61 | Notation "p .+1" := (succ p) : positive_scope. 62 | 63 | Lemma addpp x : x + x = x!0. Proof. by elim: x => //= ? ->. Defined. 64 | Lemma addp1 x : x + 1 = x.+1. Proof. by elim: x. Defined. 65 | Lemma addpS x y : x + y.+1 = (x + y).+1. 66 | Proof. by elim: x y => // p IHp [q|q|]//=; rewrite ?IHp ?addp1//. Defined. 67 | Lemma addSp x y : x.+1 + y = (x + y).+1. 68 | Proof. by elim: x y => [p IHp|p IHp|]// [q|q|]//=; rewrite ?IHp//. Defined. 69 | 70 | End Pos. 71 | Infix "+" := Pos.add : positive_scope. 72 | Notation "p .+1" := (Pos.succ p) : positive_scope. 73 | 74 | Inductive N : Set := 75 | | N0 : N 76 | | Npos : positive -> N. 77 | 78 | Declare Scope N_scope. 79 | Delimit Scope N_scope with N. 80 | Bind Scope N_scope with N. 81 | Coercion Npos : positive >-> N. 82 | 83 | Notation "0" := N0 : N_scope. 84 | 85 | Module N. 86 | Local Definition succ_subdef (n : N) : positive := 87 | match n with 88 | | N0 => 1%positive 89 | | Npos p => Pos.succ p 90 | end. 91 | Arguments succ_subdef /. 92 | Definition succ : N -> N := succ_subdef. 93 | 94 | Definition add (m n : N) := match m, n with 95 | | N0, x | x, N0 => x 96 | | Npos p, Npos q => Pos.add p q 97 | end. 98 | Infix "+" := add : N_scope. 99 | Notation "n .+1" := (succ n) : N_scope. 100 | 101 | Lemma addpp p : (Npos p + Npos p)%N = Npos p!0. 102 | Proof. by elim: p => //= p IHp; rewrite Pos.addpp. Defined. 103 | 104 | Definition to_nat (n : N) : nat := 105 | match n with N0 => 0 | Npos p => Pos.to_nat p end. 106 | 107 | Fixpoint of_nat (n : nat) : N := 108 | match n with O => 0 | S n => succ (of_nat n) end. 109 | 110 | (* from ssrnat, inlined because ssrnat clashes with HoTT. *) 111 | Lemma addn0 : forall n, (n + 0)%nat = n. 112 | Proof. 113 | move=> n; induction n as [|n IHn] => //= ; 114 | rewrite IHn ; 115 | done. 116 | Qed. 117 | Lemma addSn : forall n m, (S n + m)%nat = S (n + m)%nat. 118 | Proof. done. Qed. 119 | Lemma addnS : forall n m, (n + S m)%nat = S (n + m)%nat. 120 | Proof. 121 | move=> n m; induction n as [|n IHn] => /= [//|]. 122 | by rewrite IHn //. 123 | Qed. 124 | 125 | Lemma of_natD i j : of_nat (i + j) = (of_nat i + of_nat j)%N. 126 | Proof. 127 | elim: i j => [//|i IHi] [|j] ; first by rewrite /= addn0. 128 | rewrite addSn addnS /= IHi. 129 | case: (of_nat i) => // p; case: (of_nat j) => //=. 130 | - by rewrite /succ/= Pos.addp1. 131 | - by move=> q; rewrite /succ/= Pos.addpS Pos.addSp. 132 | Defined. 133 | 134 | Local Definition of_nat_double p k : 135 | of_nat k = Npos p -> of_nat (k + k) = Npos p!0. 136 | Proof. by move=> kp; rewrite of_natD kp addpp. Defined. 137 | 138 | Lemma to_natK (n : N) : of_nat (to_nat n) = n. 139 | Proof. by case: n => //= ; elim=> //= p /of_nat_double/= ->. Defined. 140 | 141 | Lemma of_natK (n : nat) : to_nat (of_nat n) = n. 142 | Proof. 143 | elim: n => //= n IHn; rewrite -[in X in _ = X]IHn. 144 | by case: (of_nat n)=> //; elim=> //= p ->; rewrite /= addnS. 145 | Defined. 146 | 147 | Definition of_nat_iso := Iso.Build of_natK to_natK. 148 | End N. 149 | Infix "+" := N.add : N_scope. 150 | Notation "n .+1" := (N.succ n) : N_scope. 151 | -------------------------------------------------------------------------------- /examples/artifact_paper_example.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From Trocq Require Import Stdlib Trocq. 16 | From Trocq_examples Require Import N. 17 | From elpi Require Import elpi. 18 | 19 | Set Universe Polymorphism. 20 | 21 | (*Elpi Trace.*) 22 | 23 | (** In this example, we transport the induction principle on natural numbers 24 | from two equivalent representations of `N`: the unary one `nat` and the binary 25 | one `N`. We introduce the `Trocq Use` command to register such translations. 26 | *) 27 | Definition RN : (N <=> nat)%P := Iso.toParamSym N.of_nat_iso. 28 | Trocq Use RN. (* registering related types *) 29 | 30 | (** This equivalence proof coerces to a relation of type `N -> nat -> Type`, 31 | which we show relates the respective zero and successor constants of these 32 | types: *) 33 | Definition RN0 : RN 0%N 0%nat. Proof. done. Defined. 34 | Definition RNS m n : RN m n -> RN (N.succ m) (S n). Proof. by case: _ /. Defined. 35 | Trocq Use RN0 RNS. (* registering related constants *) 36 | 37 | (** We can now make use of the tactic to prove an induction principle on `N` *) 38 | Lemma N_Srec : forall (P : N -> Type), P 0%N -> 39 | (forall n, P n -> P (N.succ n)) -> forall n, P n. 40 | Proof. trocq. (* replaces N by nat in the goal *) exact nat_rect. Defined. 41 | 42 | (** Inspecting the proof term actually reveals that univalence was not needed in 43 | the proof of `N_Srec`. The `example` directory of the artifact provides more 44 | examples, for weaker relations than equivalences, and beyond representation 45 | independence. *) 46 | Set Printing Depth 20. 47 | Print Assumptions N_Srec. 48 | 49 | -------------------------------------------------------------------------------- /examples/hott/N.v: -------------------------------------------------------------------------------- 1 | ../N.v -------------------------------------------------------------------------------- /examples/hott/_CoqProject: -------------------------------------------------------------------------------- 1 | -arg -noinit 2 | -arg -indices-matter 3 | -arg -w -arg +elpi.typechecker 4 | 5 | -R . Trocq_examples 6 | 7 | # fl3_step.v, int_to_Zp.v, square_and_cube_mod7.v depend on mathcomp features 8 | # that clashes with HoTT, so they are std-only. 9 | 10 | list_option.v 11 | misc.v 12 | N.v 13 | peano_bin_nat.v 14 | setoid_rewrite.v 15 | summable.v 16 | artifact_paper_example.v 17 | nat_ind.v 18 | trocq_setoid_rewrite.v 19 | trocq_gen_rewrite.v 20 | -------------------------------------------------------------------------------- /examples/hott/artifact_paper_example.v: -------------------------------------------------------------------------------- 1 | ../artifact_paper_example.v -------------------------------------------------------------------------------- /examples/hott/list_option.v: -------------------------------------------------------------------------------- 1 | ../list_option.v -------------------------------------------------------------------------------- /examples/hott/misc.v: -------------------------------------------------------------------------------- 1 | ../misc.v -------------------------------------------------------------------------------- /examples/hott/nat_ind.v: -------------------------------------------------------------------------------- 1 | ../nat_ind.v -------------------------------------------------------------------------------- /examples/hott/peano_bin_nat.v: -------------------------------------------------------------------------------- 1 | ../peano_bin_nat.v -------------------------------------------------------------------------------- /examples/hott/setoid_rewrite.v: -------------------------------------------------------------------------------- 1 | ../setoid_rewrite.v -------------------------------------------------------------------------------- /examples/hott/summable.v: -------------------------------------------------------------------------------- 1 | ../summable.v -------------------------------------------------------------------------------- /examples/hott/trocq_gen_rewrite.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From Trocq Require Import Stdlib Trocq. 16 | 17 | Set Universe PolymoRinthism. 18 | 19 | Declare Scope int_scope. 20 | Delimit Scope int_scope with int. 21 | 22 | Axiom (int@{i} : Type@{i}) (zero : int) (add : int -> int -> int) (p : int). 23 | Axiom (le@{i} : int@{i} -> int@{i} -> Type@{i}). 24 | Notation "x + y" := (add x%int y%int) : int_scope. 25 | Notation "x <= y" := (le x%int y%int) 26 | (format "x <= y", at level 70) : int_scope. 27 | 28 | Axiom (le_refl : Reflexive le). 29 | Axiom (le_trans : Transitive le). 30 | 31 | Axiom add_morph : 32 | forall m m' : int, (m <= m')%int -> 33 | forall n n' : int, (n <= n')%int -> 34 | (m + n <= m' + n')%int. 35 | 36 | Lemma le_morph : 37 | forall m m' : int, (m <= m')%int -> 38 | forall n n' : int, (n' <= n)%int -> 39 | (m' <= n')%int -> (m <= n)%int. 40 | Proof. 41 | move=> m m' Rm n n' Rn Rmn. 42 | exact (le_trans _ _ _ Rm (le_trans _ _ _ Rmn Rn)). 43 | Qed. 44 | 45 | Lemma le01 : 46 | forall m m' : int, (m <= m')%int -> 47 | forall n n' : int, (n' <= n)%int -> 48 | Param01.Rel (m <= n)%int (m' <= n')%int. 49 | Proof. 50 | move=> m m' Rm n n' Rn. 51 | apply: (@Param01.BuildRel (m <= n)%int (m' <= n')%int (fun _ _ => Unit)). 52 | - constructor. 53 | - by constructor => mn; apply (le_morph _ _ Rm _ _ Rn). 54 | Qed. 55 | 56 | Trocq Use le01 add_morph. 57 | 58 | Parameters i j : int. 59 | Parameters ip : (j <= i)%int. 60 | Definition iid : (i <= i)%int := le_refl i. 61 | 62 | Trocq Use ip iid. 63 | 64 | Example ipi : (j + i + j <= i + i + i)%int. 65 | Proof. 66 | trocq. 67 | apply le_refl. 68 | Qed. 69 | Print ipi. 70 | Print Assumptions ipi. 71 | -------------------------------------------------------------------------------- /examples/hott/trocq_setoid_rewrite.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect Setoid. 15 | From Trocq Require Import Stdlib Trocq. 16 | 17 | Set Universe Polymorphism. 18 | 19 | Declare Scope int_scope. 20 | Delimit Scope int_scope with int. 21 | 22 | Axiom (int : Type) (zero : int) (add : int -> int -> int) (p : int). 23 | Axiom (eqmodp : int -> int -> Type). 24 | Notation "x + y" := (add x%int y%int) : int_scope. 25 | Notation "x == y" := (eqmodp x%int y%int) 26 | (format "x == y", at level 70) : int_scope. 27 | 28 | #[local] Axiom (eqp_refl : Reflexive eqmodp). 29 | Existing Instance eqp_refl. 30 | #[local] Axiom (eqp_sym : Symmetric eqmodp). 31 | Existing Instance eqp_sym. 32 | #[local] Axiom (eqp_trans : Transitive eqmodp). 33 | Existing Instance eqp_trans. 34 | 35 | #[local] Axiom add_morph : 36 | forall m m' : int, (m == m')%int -> 37 | forall n n' : int, (n == n')%int -> 38 | (m + n == m' + n')%int. 39 | 40 | Definition eqmodp_morph : 41 | forall m m' : int, (m == m')%int -> 42 | forall n n' : int, (n == n')%int -> 43 | (m' == n')%int -> (m == n)%int. 44 | Proof. 45 | move=> m m' Rm n n' Rn Rmn. 46 | exact (eqp_trans _ _ _ Rm (eqp_trans _ _ _ Rmn (eqp_sym _ _ Rn))). 47 | Qed. 48 | 49 | Lemma eqmodp01 : 50 | forall m m' : int, (m == m')%int -> 51 | forall n n' : int, (n == n')%int -> 52 | Param01.Rel (m == n)%int (m' == n')%int. 53 | Proof. 54 | move=> m m' Rm n n' Rn. 55 | apply: (@Param01.BuildRel (m == n)%int (m' == n')%int (fun _ _ => Unit)). 56 | - constructor. 57 | - by constructor => mn; apply (eqmodp_morph _ _ Rm _ _ Rn). 58 | Qed. 59 | 60 | Trocq Use eqmodp01 add_morph. 61 | 62 | #[local] Parameter i : int. 63 | #[local] Definition j := (i + p)%int. 64 | #[local] Parameter ip : (j == i)%int. 65 | Definition iid : (i == i)%int := eqp_refl i. 66 | 67 | Trocq Use ip iid. 68 | 69 | Example ipi : (j + i == i + i)%int. 70 | Proof. 71 | trocq. 72 | apply eqp_refl. 73 | Qed. 74 | 75 | Print ipi. 76 | Print Assumptions ipi. 77 | -------------------------------------------------------------------------------- /examples/list_option.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From Trocq Require Import Stdlib Trocq. 16 | From Trocq Require Import Param_trans Param_list. 17 | 18 | Set Universe Polymorphism. 19 | 20 | Definition option_to_list {A : Type} (xo : option A) : list A := 21 | match xo with 22 | | None => nil 23 | | Some x => cons x nil 24 | end. 25 | 26 | Definition list_to_option {A : Type} (l : list A) : option A := 27 | match l with 28 | | nil => None 29 | | cons x _ => Some x 30 | end. 31 | 32 | Theorem option_to_listR (A : Type) (xo : option A) : list_to_option (option_to_list xo) = xo. 33 | Proof. destruct xo; reflexivity. Qed. 34 | 35 | Definition option_list_inj (A : Type) : @SplitInj.type (option A) (list A) := 36 | SplitInj.Build (option_to_listR A). 37 | 38 | Definition Param_option_list_d (A : Type) : Param42b.Rel (option A) (list A) := 39 | SplitInj.toParam (option_list_inj A). 40 | 41 | Definition Param42b_option_list (A A' : Type) (AR : Param42b.Rel A A') : 42 | Param42b.Rel (option A) (list A'). 43 | Proof. 44 | apply (@Param42b_trans _ (list A)). 45 | - apply Param_option_list_d. 46 | - apply (Param42b_list A A' AR). 47 | Defined. 48 | Trocq Use Param42b_option_list. 49 | 50 | Definition omap {A B : Type} (f : A -> B) (xo : option A) : option B := 51 | match xo with 52 | | None => None 53 | | Some x => Some (f x) 54 | end. 55 | 56 | Definition map {A B : Type} (f : A -> B) : list A -> list B := 57 | fix F l := 58 | match l with 59 | | nil => nil 60 | | cons a l => cons (f a) (F l) 61 | end. 62 | 63 | Definition mapR 64 | (A A' : Type) (AR : Param00.Rel A A') 65 | (B B' : Type) (BR : Param00.Rel B B') 66 | (f : A -> B) (f' : A' -> B') (fR : R_arrow AR BR f f') 67 | (l : list A) (l' : list A') (lR : listR A A' AR l l') : 68 | listR B B' BR (map f l) (map f' l'). 69 | Proof. 70 | induction lR; simpl. 71 | - apply nilR. 72 | - apply consR. 73 | + apply (fR a a' aR). 74 | + apply IHlR. 75 | Defined. 76 | 77 | Lemma option_to_list_map_morph (A B : Type) (f : A -> B) (xo : option A) : 78 | option_to_list (omap f xo) = map f (option_to_list xo). 79 | Proof. destruct xo; reflexivity. Qed. 80 | 81 | Definition omap_map_R 82 | (A A' : Type) (AR : Param42b.Rel A A') 83 | (B B' : Type) (BR : Param42b.Rel B B') 84 | (f : A -> B) (f' : A' -> B') (fR : R_arrow AR BR f f') 85 | (xo : option A) (l' : list A') (r : Param42b_option_list A A' AR xo l') : 86 | Param42b_option_list B B' BR (omap f xo) (map f' l'). 87 | Proof. 88 | destruct r as [l [r lR]]. 89 | unshelve econstructor. 90 | - exact (map f l). 91 | - split. 92 | + rewrite <- r. apply option_to_list_map_morph. 93 | + exact (mapR A A' AR B B' BR f f' fR l l' lR). 94 | Defined. 95 | Trocq Use omap_map_R. 96 | 97 | Trocq Use Param01_paths. 98 | 99 | Theorem map_compose (A B C : Type) (l : list A) (f : A -> B) (g : B -> C) : 100 | map g (map f l) = map (fun x => g (f x)) l. 101 | Proof. 102 | induction l; simpl. 103 | - reflexivity. 104 | - apply ap. apply IHl. 105 | Qed. 106 | 107 | Goal forall A B C (xo : option A) (f : A -> B) (g : B -> C), 108 | omap g (omap f xo) = omap (fun x => g (f x)) xo. 109 | Proof. 110 | trocq. 111 | apply map_compose. 112 | Qed. 113 | -------------------------------------------------------------------------------- /examples/misc.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import ssreflect. 16 | From Trocq Require Import Stdlib Trocq. 17 | 18 | Set Universe Polymorphism. 19 | 20 | (* Example file on CCω *) 21 | (* Feel free to comment commands adding the axioms to the Trocq database, 22 | in order to see which goals can be pre-processed without them, and which ones cannot *) 23 | 24 | Section test. 25 | Universe i. 26 | 27 | Goal 28 | (* Type@{i}. *) 29 | (* Type@{i} -> Type@{i}. *) 30 | (* forall (A : Type@{i}), A. *) 31 | forall (A : Type@{i}), A -> A. 32 | (* forall (A B : Type@{i}), A -> B. *) 33 | (* forall (F : Type@{i} -> Type@{i}) (A : Type@{i}), F A. *) 34 | (* forall (F : Type@{i} -> Type@{i}) (A B : Type@{i}), F A -> F B. *) 35 | (* forall (F : Type@{i} -> Type@{i} -> Type@{i}) (A B : Type@{i}), F A B. *) 36 | (* forall (F : Type@{i} -> Type@{i} -> Type@{i}) (A B : Type@{i}), F A B -> F B A. *) 37 | (* forall (F : Type@{i} -> Type@{i}) (A : Type@{i}), F A -> forall (B : Type@{i}), F B. *) 38 | (* forall (F : Type@{i} -> Type@{i}) (A : Type@{i}), F A -> forall (B : Type@{i}), F B -> F A. *) 39 | (* forall (A : Type@{i}) (F : A -> Type@{i}) (a : A), F a. *) 40 | (* forall (A : Type@{i}) (F : A -> Type@{i}) (a : A), F a -> F a. *) 41 | (* forall (F : Type@{i} -> Type@{i}) (A : Type@{i}) (H : F A -> Type@{i}) (J : F A), H J. *) 42 | (* forall (F : Type@{i} -> Type@{i}) (A B : Type@{i}) (H : F A -> F B) (J : F A) (K : F B -> Type), K (H J). *) 43 | (* forall 44 | (F : Type@{i} -> Type@{i}) (A : Type@{i}) (H : F A), 45 | F A -> forall (B : Type@{i}) (J : F A -> F B), (forall (K : F B -> Type@{i}), K (J H)) -> 46 | F B -> F A. *) 47 | (* forall (X : forall (A : Type@{i}), A -> Type@{i}) (A : Type@{i}) (a : A), A -> X A a -> A. *) 48 | (* forall (T : (Type@{i} -> Type@{j})) (F : ((Type@{i} -> Type@{j}) -> Type@{k})), F T. *) 49 | Proof. 50 | trocq. 51 | Abort. 52 | End test. 53 | -------------------------------------------------------------------------------- /examples/nat_ind.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From Trocq Require Import Stdlib Trocq. 16 | 17 | Set Universe Polymorphism. 18 | 19 | Section IndType. 20 | Variables (I : Type) (I0 : I) (IS : I -> I). 21 | Variables (to_nat : I -> nat) (of_nat : nat -> I). 22 | 23 | Hypothesis to_natK : forall x, of_nat (to_nat x) = x. 24 | Hypothesis of_nat0 : of_nat O = I0. 25 | Hypothesis of_natS : forall n, of_nat (S n) = IS (of_nat n). 26 | 27 | (* We only need (2a,3), so it suffices that to_nat is a retraction *) 28 | Definition RI : Param2a3.Rel I nat := 29 | SplitSurj.toParamSym (SplitSurj.Build to_natK). 30 | 31 | Definition RI0 : RI I0 O. Proof. exact of_nat0. Qed. 32 | Definition RIS m n : RI m n -> RI (IS m) (S n). 33 | Proof. by move=> <-; apply: of_natS. Qed. 34 | 35 | Trocq Use RI RI0 RIS. 36 | 37 | Lemma I_Srec : forall (P : I -> Type), P I0 -> 38 | (forall n, P n -> P (IS n)) -> forall n, P n. 39 | Proof. 40 | trocq. 41 | (* the output sort of P' is (1,1) because of the covariant and contravariant occurrences of P in 42 | the input goal; this annotation was made to be definitionally equal to Type: from there, 43 | the induction principle of nat can be applied directly *) 44 | exact nat_rect. 45 | Defined. 46 | 47 | End IndType. 48 | 49 | Check I_Srec. 50 | Print I_Srec. 51 | Print Assumptions I_Srec. 52 | -------------------------------------------------------------------------------- /examples/peano_bin_nat.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From Trocq Require Import Stdlib Trocq. 16 | From Trocq_examples Require Import N. 17 | 18 | Set Universe Polymorphism. 19 | 20 | (* the best we can do to link these types is (4,4), but 21 | we only need (2a,3) si ut suffices that N.to_nat is a retraction *) 22 | Definition RN : Param2a3.Rel N nat := 23 | SplitSurj.toParamSym (SplitSurj.Build N.to_natK). 24 | 25 | (* as 0 and Nsucc appear in the goal, we need to link them with nat constructors *) 26 | (* NB: as these are not type formers, only class (0,0) is required, so these proofs amount to what 27 | would be done in the context of raw parametricity *) 28 | 29 | Definition RN0 : RN 0%N 0%nat. Proof. done. Qed. 30 | Definition RNS m n : RN m n -> RN (N.succ m) (S n). Proof. by case: _ /. Qed. 31 | 32 | Trocq Use RN RN0 RNS. 33 | 34 | Lemma N_Srec : forall (P : N -> Type), P N0 -> 35 | (forall n, P n -> P n.+1%N) -> forall n, P n. 36 | Proof. 37 | trocq. 38 | (* the output sort of P' is (1,1) because of the covariant and contravariant occurrences of P in 39 | the input goal; this annotation was made to be definitionally equal to Type: from there, 40 | the induction principle of nat can be applied directly *) 41 | exact nat_rect. 42 | Defined. 43 | 44 | Print N_Srec. 45 | Print Assumptions N_Srec. 46 | -------------------------------------------------------------------------------- /examples/setoid_rewrite.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import Prelude Setoid Morphisms. 15 | 16 | (* what it can do *) 17 | Section Test. 18 | Declare Scope int_scope. 19 | Delimit Scope int_scope with int. 20 | Context (int : Set) (zero : int) (add : int -> int -> int). 21 | Context (eqmodp : int -> int -> Prop). 22 | Hypothesis eqmodp_equiv : Equivalence eqmodp. 23 | Existing Instance eqmodp_equiv. 24 | 25 | Hypothesis add_proper : Proper (eqmodp ==> eqmodp ==> eqmodp) add. 26 | Existing Instance add_proper. 27 | 28 | Notation "x == y" := (eqmodp x y) (format "x == y", at level 70) : int_scope. 29 | Notation "x + y" := (add x%int y%int) : int_scope. 30 | 31 | Goal (forall x y : int, x + y == y + x)%int -> 32 | forall x y z, (x + y + z == y + x + z)%int. 33 | Proof. 34 | intros addC x y z. 35 | rewrite (addC x y). 36 | reflexivity. 37 | Qed. 38 | 39 | End Test. 40 | 41 | (* what it cannot do : handle heterogenous relations *) 42 | -------------------------------------------------------------------------------- /examples/std/N.v: -------------------------------------------------------------------------------- 1 | ../N.v -------------------------------------------------------------------------------- /examples/std/_CoqProject: -------------------------------------------------------------------------------- 1 | -arg -indices-matter 2 | -arg -w -arg +elpi.typechecker 3 | 4 | -R . Trocq_examples 5 | 6 | artifact_paper_example.v 7 | flt3_step.v 8 | int_to_Zp.v 9 | list_option.v 10 | misc.v 11 | nat_ind.v 12 | N.v 13 | peano_bin_nat.v 14 | setoid_rewrite.v 15 | square_and_cube_mod7.v 16 | summable.v 17 | trocq_setoid_rewrite.v 18 | stuck.v 19 | Vector_tuple.v 20 | trocq_gen_rewrite.v 21 | -------------------------------------------------------------------------------- /examples/std/artifact_paper_example.v: -------------------------------------------------------------------------------- 1 | ../artifact_paper_example.v -------------------------------------------------------------------------------- /examples/std/int_to_Zp.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From mathcomp Require Import all_ssreflect all_algebra. 15 | From Trocq Require Import Stdlib Trocq. 16 | Import GRing.Theory. 17 | Local Open Scope bool_scope. 18 | 19 | Set Universe Polymorphism. 20 | 21 | Lemma Zp_int_mod [p : nat] : 1 < p -> 22 | forall n : int, ((n %% p)%Z%:~R)%R = (n%:~R)%R :> 'Z_p. 23 | Proof. 24 | move=> p_gt1 n; rewrite [in RHS](divz_eq n p) [in RHS]intrD intrM. 25 | by rewrite [p%:~R%R]char_Zp// mulr0 add0r. 26 | Qed. 27 | 28 | Lemma val_Zp_int p : 1 < p -> 29 | forall n : int, ((n%:~R)%R : 'Z_p)%:Z%R = (n %% p)%Z. 30 | Proof. 31 | move=> p_gt1 n; rewrite -Zp_int_mod//. 32 | have: ((n %% p)%Z >= 0)%R by rewrite modz_ge0//; case: p p_gt1. 33 | rewrite -[RHS]modz_mod; case: (n %% p)%Z => //= k _ /=. 34 | by rewrite val_Zp_nat// modz_nat. 35 | Qed. 36 | 37 | Section modp. 38 | Variable (p : nat) (p_gt1 : p > 1). 39 | Let p_gt0 : p > 0. by case: p p_gt1. Qed. 40 | 41 | Definition binop_param {X X'} RX {Y Y'} RY {Z Z'} RZ 42 | (f : X -> Y -> Z) (g : X' -> Y' -> Z') := 43 | forall x x', RX x x' -> forall y y', RY y y' -> RZ (f x y) (g x' y'). 44 | 45 | (*** 46 | We setup an axiomatic context in order not to develop 47 | arithmetic modulo in Coq/HoTT. 48 | **) 49 | Definition eqmodp (x y : int) := (x = y %[mod p])%Z. 50 | 51 | (* for now translations need the support of a global reference: *) 52 | Definition eq_Zmodp (x y : 'Z_p) := (x = y). 53 | 54 | Lemma eq_intZp (m n : int) : (m%:~R == n%:~R :> 'Z_p)%R = (m == n %[mod p])%Z. 55 | Proof. 56 | apply/eqP/eqP. 57 | by move=> /(congr1 val)/(congr1 Posz); rewrite !val_Zp_int. 58 | by move=> /(congr1 (fun n => n%:~R : 'Z_p)%R); rewrite !Zp_int_mod. 59 | Qed. 60 | 61 | Lemma eq_natZp (m n : nat) : (m%:R == n%:R :> 'Z_p)%R = (m == n %[mod p]). 62 | Proof. by rewrite (eq_intZp m n) !modz_nat. Qed. 63 | Locate "==". 64 | 65 | Lemma intZp_eq0 (n : int) : (n%:~R == 0 :> 'Z_p)%R = (p %| n)%Z. 66 | Proof. by rewrite -[0%R]/(0%:~R)%R eq_intZp mod0z; apply/eqP/dvdz_mod0P. Qed. 67 | 68 | Lemma natZp_eq0 (n : nat) : (n%:R == 0 :> 'Z_p)%R = (p %| n). 69 | Proof. by rewrite -[0%R]/(0%:R)%R eq_natZp mod0n. Qed. 70 | 71 | Search (_ %% _)%N ('I__). 72 | Search GRing.natmul nat_of_ord. 73 | 74 | Arguments eq_Zmodp /. 75 | 76 | Definition Zp := 'Z_p. 77 | Arguments Zp /. 78 | 79 | Lemma reprK : cancel (val : Zp -> int) (intmul 1 : int -> Zp). 80 | Proof. exact: natr_Zp. Qed. 81 | 82 | Definition Rp := SplitSurj.toParam (SplitSurj.Build reprK). 83 | Lemma Rzero : Rp 0%R 0%R. Proof. done. Qed. 84 | 85 | Arguments graph /. 86 | 87 | 88 | Definition int_add (x y : int) : int := (x + y)%R. 89 | Definition int_mul (x y : int) : int := (x * y)%R. 90 | 91 | Definition Zp_add (x y : Zp) : 'Z_p := (x + y)%R. 92 | Definition Zp_mul (x y : Zp) : 'Z_p := (x * y)%R. 93 | 94 | Lemma Radd : binop_param Rp Rp Rp (int_add) (Zp_add). 95 | Proof. 96 | move=> /= m _ <- n _ <- /=. 97 | rewrite /Rp /SplitSurj.toParam /rel /=. 98 | by rewrite rmorphD. 99 | Qed. 100 | 101 | Lemma Rmul : binop_param Rp Rp Rp (int_mul) (Zp_mul). 102 | Proof. 103 | move=> /= m _ <- n _ <- /=. 104 | rewrite /Rp /SplitSurj.toParam /rel /=. 105 | by rewrite rmorphM. 106 | Qed. 107 | 108 | Definition Reqmodp01 : forall (m : int) (x : 'Z_p), Rp m x -> 109 | forall n y, Rp n y -> Param01.Rel (eqmodp m n) (eq_Zmodp x y). 110 | Proof. 111 | move=> /= m _ <- n _ <-; exists (fun _ _ => True) => //=. 112 | by split=> /eqP; rewrite eq_intZp => /eqP. 113 | Qed. 114 | 115 | Definition RTrue : Param01.Rel True True. 116 | Proof. by unshelve eexists (fun _ _ => True); constructor. Defined. 117 | 118 | Definition Runit : Param01.Rel unit unit. 119 | Proof. by unshelve eexists (fun _ _ => unit); constructor. Defined. 120 | 121 | Trocq Use RTrue Runit. 122 | 123 | Trocq RelatedWith Rp Rp Rmul Rzero Reqmodp01. 124 | 125 | Local Open Scope ring_scope. 126 | 127 | Lemma IntRedModZp : 128 | (forall (m n : 'Z_p), m = n * n -> m = n) -> 129 | forall (m n : int), m = int_mul n n -> eqmodp m n. 130 | Proof. 131 | move=> Hyp. 132 | trocq Rp; simpl. 133 | exact: Hyp. 134 | Qed. 135 | 136 | (* Print Assumptions IntRedModZp. (* No Univalence *) *) 137 | 138 | End modp. 139 | -------------------------------------------------------------------------------- /examples/std/list_option.v: -------------------------------------------------------------------------------- 1 | ../list_option.v -------------------------------------------------------------------------------- /examples/std/misc.v: -------------------------------------------------------------------------------- 1 | ../misc.v -------------------------------------------------------------------------------- /examples/std/nat_ind.v: -------------------------------------------------------------------------------- 1 | ../nat_ind.v -------------------------------------------------------------------------------- /examples/std/peano_bin_nat.v: -------------------------------------------------------------------------------- 1 | ../peano_bin_nat.v -------------------------------------------------------------------------------- /examples/std/setoid_rewrite.v: -------------------------------------------------------------------------------- 1 | ../setoid_rewrite.v -------------------------------------------------------------------------------- /examples/std/square_and_cube_mod7.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From mathcomp Require Import all_ssreflect all_algebra. 16 | From Trocq Require Import Stdlib Trocq. 17 | 18 | Import GRing.Theory. 19 | Open Scope ring_scope. 20 | 21 | Set Universe Polymorphism. 22 | 23 | Declare Scope int_scope. 24 | Delimit Scope int_scope with int. 25 | Delimit Scope int_scope with ℤ. 26 | Local Open Scope int_scope. 27 | Declare Scope Zmod7_scope. 28 | Delimit Scope Zmod7_scope with Zmod7. 29 | Local Open Scope Zmod7_scope. 30 | 31 | (* Helper predicates *) 32 | Definition unop_param {X X'} RX {Y Y'} RY 33 | (f : X -> Y) (g : X' -> Y') := 34 | forall x x', RX x x' -> RY (f x) (g x'). 35 | 36 | Definition binop_param {X X'} RX {Y Y'} RY {Z Z'} RZ 37 | (f : X -> Y -> Z) (g : X' -> Y' -> Z') := 38 | forall x x', RX x x' -> forall y y', RY y y' -> RZ (f x y) (g x' y'). 39 | 40 | (* For now translations need the support of monomorphic identifiers: *) 41 | 42 | (* Arithmetic on Z_7*) 43 | Definition Zmod7 := 'Z_7. 44 | Notation "ℤ/7ℤ" := Zmod7. 45 | 46 | Definition zerop : ℤ/7ℤ := Zp0. 47 | Definition addp : ℤ/7ℤ -> ℤ/7ℤ -> ℤ/7ℤ := @Zp_add 7. 48 | Definition mulp : ℤ/7ℤ -> ℤ/7ℤ -> ℤ/7ℤ := @Zp_mul 7. 49 | Definition onep : ℤ/7ℤ := Zp1. 50 | 51 | (* Quotient *) 52 | Definition modp : int -> ℤ/7ℤ := fun x => (x)%:~R. 53 | Definition reprp : ℤ/7ℤ -> int := id. 54 | 55 | Lemma reprpK : forall x, modp (reprp x) = x. Proof. exact: natr_Zp. Qed. 56 | 57 | (* Mod 3 in Z7 *) 58 | Lemma mk_mod7_mod3 (n : 'I_7) : (n %% 3 < 7)%N. 59 | Proof. apply: (@ltn_trans 3) => //; exact: ltn_pmod. Qed. 60 | 61 | Definition modp3 : ℤ/7ℤ -> ℤ/7ℤ := fun n => Ordinal (mk_mod7_mod3 n). 62 | 63 | (* Equality on integers *) 64 | Definition eqmodp (x y : int) := modp x = modp y. 65 | 66 | Definition eq_Zmod7 (x y : ℤ/7ℤ) := (x = y). 67 | Arguments eq_Zmod7 /. 68 | 69 | Definition zero : int := 0. 70 | Definition one : int := 1. 71 | 72 | Definition add : int -> int -> int := fun x y => x + y. 73 | Definition mul : int -> int -> int := fun x y => x * y. 74 | 75 | Notation "0" := zero : int_scope. 76 | Notation "0" := zerop : Zmod7_scope. 77 | Notation "1" := one : int_scope. 78 | Notation "1" := onep : Zmod7_scope. 79 | Notation "x + y" := (add x%int y%int) : int_scope. 80 | Notation "x + y" := (addp x%Zmod7 y%Zmod7) : Zmod7_scope. 81 | Notation "x * y" := (mul x%int y%int) : int_scope. 82 | Notation "x * y" := (mulp x%Zmod7 y%Zmod7) : Zmod7_scope. 83 | Notation not A := (A -> False). 84 | Notation "m ²" := (m * m)%int (at level 2) : int_scope. 85 | Notation "m ²" := (m * m)%Zmod7 (at level 2) : Zmod7_scope. 86 | Notation "m ³" := (m * m * m)%int (at level 2) : int_scope. 87 | Notation "m ³" := (m * m * m)%Zmod7 (at level 2) : Zmod7_scope. 88 | Notation "m % 3" := (modp3 m)%Zmod7 (at level 2) : Zmod7_scope. 89 | Notation "x ≡ y" := (eqmodp x%int y%int) 90 | (format "x ≡ y", at level 70) : int_scope. 91 | Notation "x ≢ y" := (not (eqmodp x%int y%int)) 92 | (format "x ≢ y", at level 70) : int_scope. 93 | Notation "x ≠ y" := (not (x = y)) (at level 70). 94 | Notation "A ∨ B" := ((not A) -> B) (at level 85) : type_scope. 95 | Notation ℤ := int. 96 | 97 | Definition Rp := SplitSurj.toParam (SplitSurj.Build reprpK). 98 | 99 | Lemma Rzero : Rp zero zerop. Proof. done. Qed. 100 | 101 | Lemma Rone : Rp one onep. Proof. done. Qed. 102 | 103 | 104 | (* These lemmas are about congruence mod 7, of + and * *) 105 | Lemma Radd : binop_param Rp Rp Rp add addp. 106 | Proof. 107 | rewrite /Rp /SplitSurj.toParam /= /graph /==> x1 y1 <- x2 y2 <-. 108 | by rewrite /rel/= /modp rmorphE. 109 | Qed. 110 | 111 | Lemma Rmul : binop_param Rp Rp Rp mul mulp. 112 | Proof. 113 | rewrite /Rp /SplitSurj.toParam /= /graph /= => x1 y1 <- x2 y2 <-. 114 | by rewrite /rel/= /modp rmorphM. 115 | Qed. 116 | 117 | Lemma Reqmodp01 : forall (m : int) (x : ℤ/7ℤ), Rp m x -> 118 | forall n y, Rp n y -> Param01.Rel (eqmodp m n) (eq_Zmod7 x y). 119 | Proof. 120 | rewrite /Rp /= /graph /=. 121 | move=> x k exk y l eyl. 122 | apply: (@Param01.BuildRel (x ≡ y) (k = l) (fun _ _ => unit)) => //. 123 | by constructor; rewrite -exk -eyl. 124 | Qed. 125 | 126 | Trocq Use Rp Rmul Rzero Rone Radd Param10_paths Reqmodp01. 127 | Trocq Use Param01_Empty. 128 | Trocq Use Param10_Empty. 129 | 130 | Lemma square_and_cube_mod7 : forall (m n p : ℤ), 131 | (m = n²)%Z -> (m = p³)%Z -> m ≡ 0 ∨ m ≡ 1. 132 | Proof. 133 | trocq => /=. 134 | 135 | (* the following should be a call to troq to compute *) 136 | move=> m n p /eqP mn /eqP mp /eqP m0. apply/eqP; move: m n p mn mp m0. 137 | do 3![case; do 7?[case=> //=] => ?] => /=. 138 | 139 | (* Ultimately, it should be: 140 | 141 | by rewrite (mod 7); decide. 142 | 143 | *) 144 | Qed. 145 | Print Assumptions square_and_cube_mod7. 146 | -------------------------------------------------------------------------------- /examples/std/stuck.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From Trocq Require Import Trocq Param_list. 16 | 17 | Set Universe Polymorphism. 18 | 19 | Declare Scope int_scope. 20 | Delimit Scope int_scope with int. 21 | Delimit Scope int_scope with ℤ. 22 | Local Open Scope int_scope. 23 | Declare Scope Zmodp_scope. 24 | Delimit Scope Zmodp_scope with Zmodp. 25 | Local Open Scope Zmodp_scope. 26 | 27 | Definition binop_param {X X'} RX {Y Y'} RY {Z Z'} RZ 28 | (f : X -> Y -> Z) (g : X' -> Y' -> Z') := 29 | forall x x', RX x x' -> forall y y', RY y y' -> RZ (f x y) (g x' y'). 30 | 31 | (*** 32 | We setup an axiomatic context in order not to develop 33 | arithmetic modulo in Coq/HoTT. 34 | **) 35 | Axiom (int@{i} : Type@{i}) (zero : int) (add : int -> int -> int) 36 | (mul : int -> int -> int) (one : int). 37 | Axiom (addC : forall m n, add m n = add n m). 38 | Axiom (Zmodp : Type) (zerop : Zmodp) (addp : Zmodp -> Zmodp -> Zmodp) 39 | (mulp : Zmodp -> Zmodp -> Zmodp) (onep : Zmodp). 40 | Axiom (modp : int -> Zmodp) (reprp : Zmodp -> int) 41 | (reprpK : forall x, modp (reprp x) = x). 42 | 43 | Definition eqmodp (x y : int) := modp x = modp y. 44 | 45 | Definition Rp := SplitSurj.toParamSym (SplitSurj.Build reprpK). 46 | 47 | Axiom Rzero : Rp zerop zero. 48 | Axiom Radd : binop_param Rp Rp Rp addp add. 49 | Axiom paths_to_eqmodp : binop_param Rp Rp iff eq eqmodp. 50 | 51 | Trocq Use Rp Param01_paths Param10_paths Radd Rzero Param_cons Param_nil. 52 | 53 | Module Stuck. 54 | 55 | Trocq Use Param44_list. 56 | Goal forall (l : list Zmodp), l = l. 57 | Fail trocq. 58 | Abort. 59 | 60 | End Stuck. 61 | 62 | Module Works. 63 | 64 | Trocq Use Param2a4_list. 65 | Goal forall (l : list Zmodp), l = l. 66 | trocq. 67 | reflexivity. 68 | Qed. 69 | 70 | End Works. 71 | 72 | -------------------------------------------------------------------------------- /examples/std/summable.v: -------------------------------------------------------------------------------- 1 | ../summable.v -------------------------------------------------------------------------------- /examples/std/trocq_gen_rewrite.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect Setoid. 15 | From Trocq Require Import Stdlib Trocq. 16 | 17 | Set Universe Polymorphism. 18 | 19 | Declare Scope int_scope. 20 | Delimit Scope int_scope with int. 21 | 22 | Axiom (int@{i} : Type@{i}) (zero : int) (add : int -> int -> int) (p : int). 23 | Axiom (le_int@{i} : int@{i} -> int@{i} -> Prop). 24 | Notation "x + y" := (add x%int y%int) : int_scope. 25 | Notation "x <= y" := (le_int x%int y%int) 26 | (format "x <= y", at level 70) : int_scope. 27 | 28 | Axiom (le_refl : Reflexive le_int). 29 | Axiom (le_trans : Transitive le_int). 30 | 31 | Axiom add_morph : 32 | forall m m' : int, (m <= m')%int -> 33 | forall n n' : int, (n <= n')%int -> 34 | (m + n <= m' + n')%int. 35 | 36 | Lemma le_morph : 37 | forall m m' : int, (m <= m')%int -> 38 | forall n n' : int, (n' <= n)%int -> 39 | (m' <= n')%int -> (m <= n)%int. 40 | Proof. 41 | move=> m m' Rm n n' Rn Rmn. 42 | exact (le_trans _ _ _ Rm (le_trans _ _ _ Rmn Rn)). 43 | Qed. 44 | 45 | Lemma le01 : 46 | forall m m' : int, (m <= m')%int -> 47 | forall n n' : int, (n' <= n)%int -> 48 | Param01.Rel (m <= n)%int (m' <= n')%int. 49 | Proof. 50 | move=> m m' Rm n n' Rn. 51 | apply: (@Param01.BuildRel (m <= n)%int (m' <= n')%int (fun _ _ => unit)). 52 | - constructor. 53 | - by constructor => mn; apply (le_morph _ _ Rm _ _ Rn). 54 | Qed. 55 | 56 | Trocq Use le01 add_morph. 57 | 58 | Parameters i j : int. 59 | Parameters ip : (j <= i)%int. 60 | Definition iid : (i <= i)%int := le_refl i. 61 | 62 | Trocq Use ip iid. 63 | 64 | Example ipi : (j + i + j <= i + i + i)%int. 65 | Proof. 66 | trocq. 67 | apply le_refl. 68 | Qed. 69 | Print ipi. 70 | Print Assumptions ipi. 71 | -------------------------------------------------------------------------------- /examples/std/trocq_setoid_rewrite.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect Setoid. 15 | From Trocq Require Import Stdlib Trocq. 16 | 17 | Set Universe Polymorphism. 18 | 19 | Declare Scope int_scope. 20 | Delimit Scope int_scope with int. 21 | 22 | Axiom (int : Type) (zero : int) (add : int -> int -> int) (p : int). 23 | Axiom (eqmodp : int -> int -> Prop). 24 | Notation "x + y" := (add x%int y%int) : int_scope. 25 | Notation "x == y" := (eqmodp x%int y%int) 26 | (format "x == y", at level 70) : int_scope. 27 | 28 | #[local] Axiom (eqp_refl : Reflexive eqmodp). 29 | Existing Instance eqp_refl. 30 | #[local] Axiom (eqp_sym : Symmetric eqmodp). 31 | Existing Instance eqp_sym. 32 | #[local] Axiom (eqp_trans : Transitive eqmodp). 33 | Existing Instance eqp_trans. 34 | 35 | #[local] Axiom add_morph : 36 | forall m m' : int, (m == m')%int -> 37 | forall n n' : int, (n == n')%int -> 38 | (m + n == m' + n')%int. 39 | 40 | Definition eqmodp_morph : 41 | forall m m' : int, (m == m')%int -> 42 | forall n n' : int, (n == n')%int -> 43 | (m' == n')%int -> (m == n)%int. 44 | Proof. 45 | move=> m m' Rm n n' Rn Rmn. 46 | exact (eqp_trans _ _ _ Rm (eqp_trans _ _ _ Rmn (eqp_sym _ _ Rn))). 47 | Qed. 48 | 49 | Lemma eqmodp01 : 50 | forall m m' : int, (m == m')%int -> 51 | forall n n' : int, (n == n')%int -> 52 | Param01.Rel (m == n)%int (m' == n')%int. 53 | Proof. 54 | move=> m m' Rm n n' Rn. 55 | apply: (@Param01.BuildRel (m == n)%int (m' == n')%int (fun _ _ => unit)). 56 | - constructor. 57 | - by constructor => mn; apply (eqmodp_morph _ _ Rm _ _ Rn). 58 | Qed. 59 | 60 | Trocq Use eqmodp01 add_morph. 61 | 62 | #[local] Parameter i : int. 63 | #[local] Definition j := (i + p)%int. 64 | #[local] Parameter ip : (j == i)%int. 65 | Definition iid : (i == i)%int := eqp_refl i. 66 | 67 | Trocq Use ip iid. 68 | 69 | Example ipi : (j + i == i + i)%int. 70 | Proof. 71 | trocq. 72 | apply eqp_refl. 73 | Qed. 74 | 75 | Print ipi. 76 | Print Assumptions ipi. 77 | -------------------------------------------------------------------------------- /generic/Database.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Export elpi. 15 | 16 | From Trocq.Elpi Extra Dependency "util.elpi" as util. 17 | From Trocq.Elpi Extra Dependency "class.elpi" as class. 18 | From Trocq.Elpi Extra Dependency "database.elpi" as database. 19 | 20 | Elpi Db trocq.db lp:{{ }}. 21 | Elpi Accumulate trocq.db File util. 22 | Elpi Accumulate trocq.db File class. 23 | #[superglobal] Elpi Accumulate trocq.db File database. 24 | -------------------------------------------------------------------------------- /generic/Param_Empty.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | Require Import Stdlib Hierarchy. 16 | 17 | Set Universe Polymorphism. 18 | Unset Universe Minimization ToSet. 19 | 20 | Import HoTTNotations. 21 | 22 | Inductive EmptyR : Empty -> Empty -> Type := . 23 | 24 | Definition map_Empty (e : Empty) : Empty := e. 25 | 26 | Definition map_in_R_Empty : forall (e e' : Empty), map_Empty e = e' -> EmptyR e e' := 27 | fun e => match e with end. 28 | 29 | Definition R_in_map_Empty : forall (e e' : Empty), EmptyR e e' -> map_Empty e = e' := 30 | fun e => match e with end. 31 | 32 | Definition R_in_mapK_Empty : forall (e e' : Empty) (eR : EmptyR e e'), 33 | map_in_R_Empty e e' (R_in_map_Empty e e' eR) = eR := 34 | fun e => match e with end. 35 | 36 | Definition Map0_Empty : Map0.Has EmptyR. 37 | Proof. constructor. Defined. 38 | 39 | Definition Map1_Empty : Map1.Has EmptyR. 40 | Proof. constructor. exact map_Empty. Defined. 41 | 42 | Definition Map2a_Empty : Map2a.Has EmptyR. 43 | Proof. 44 | unshelve econstructor. 45 | - exact map_Empty. 46 | - exact map_in_R_Empty. 47 | Defined. 48 | 49 | Definition Map2b_Empty : Map2b.Has EmptyR. 50 | Proof. 51 | unshelve econstructor. 52 | - exact map_Empty. 53 | - exact R_in_map_Empty. 54 | Defined. 55 | 56 | Definition Map3_Empty : Map3.Has EmptyR. 57 | Proof. 58 | unshelve econstructor. 59 | - exact map_Empty. 60 | - exact map_in_R_Empty. 61 | - exact R_in_map_Empty. 62 | Defined. 63 | 64 | Definition Map4_Empty : Map4.Has EmptyR. 65 | Proof. 66 | unshelve econstructor. 67 | - exact map_Empty. 68 | - exact map_in_R_Empty. 69 | - exact R_in_map_Empty. 70 | - exact R_in_mapK_Empty. 71 | Defined. 72 | 73 | Definition Param01_Empty : Param01.Rel Empty Empty. 74 | Proof. 75 | unshelve econstructor; first exact: EmptyR. 76 | - done. 77 | - constructor; exact map_Empty. 78 | Defined. 79 | 80 | Definition Param10_Empty : Param10.Rel Empty Empty. 81 | Proof. 82 | unshelve econstructor; first exact: EmptyR. 83 | - constructor; exact map_Empty. 84 | - done. 85 | Defined. 86 | 87 | -------------------------------------------------------------------------------- /generic/Param_bool.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | Require Import Stdlib Hierarchy Param_lemmas. 16 | 17 | Set Universe Polymorphism. 18 | Unset Universe Minimization ToSet. 19 | 20 | Import HoTTNotations. 21 | 22 | Inductive BoolR : Bool -> Bool -> Type := 23 | | falseR : BoolR false false 24 | | trueR : BoolR true true. 25 | 26 | Definition map_Bool : Bool -> Bool := idmap. 27 | 28 | Definition map_in_R_Bool {b b' : Bool} (e : map_Bool b = b') : BoolR b b' := 29 | match e with 30 | | idpath => 31 | match b with 32 | | false => falseR 33 | | true => trueR 34 | end 35 | end. 36 | 37 | Definition R_in_map_Bool {b b' : Bool} (bR : BoolR b b') : map_Bool b = b' := 38 | match bR with 39 | | falseR => idpath 40 | | trueR => idpath 41 | end. 42 | 43 | Definition R_in_mapK_Bool {b b' : Bool} (bR : BoolR b b') : 44 | map_in_R_Bool (R_in_map_Bool bR) = bR := 45 | match bR with 46 | | falseR => idpath 47 | | trueR => idpath 48 | end. 49 | 50 | Definition Param_Bool_sym {b b' : Bool} (bR : BoolR b b') : BoolR b' b := 51 | match bR with 52 | | falseR => falseR 53 | | trueR => trueR 54 | end. 55 | 56 | Definition Param_Bool_sym_inv {b b' : Bool} (bR : BoolR b b') : 57 | Param_Bool_sym (Param_Bool_sym bR) = bR := 58 | match bR with 59 | | falseR => idpath 60 | | trueR => idpath 61 | end. 62 | 63 | Definition BoolR_sym : forall (b b' : Bool), sym_rel BoolR b b' <->> BoolR b b'. 64 | Proof. 65 | intros b b'; unshelve eexists _,_ . 66 | - apply Param_Bool_sym. 67 | - apply Param_Bool_sym. 68 | - intro bR. apply Param_Bool_sym_inv. 69 | Defined. 70 | 71 | Definition Map4_Bool : Map4.Has BoolR. 72 | Proof. 73 | unshelve econstructor. 74 | - exact map_Bool. 75 | - exact @map_in_R_Bool. 76 | - exact @R_in_map_Bool. 77 | - exact @R_in_mapK_Bool. 78 | Defined. 79 | 80 | Definition Param44_Bool : Param44.Rel Bool Bool. 81 | Proof. 82 | unshelve econstructor. 83 | - exact BoolR. 84 | - exact Map4_Bool. 85 | - apply (fun e => @eq_Map4 _ _ (sym_rel BoolR) BoolR e Map4_Bool). 86 | apply BoolR_sym. 87 | Defined. 88 | -------------------------------------------------------------------------------- /generic/Param_nat.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect ssrbool. 15 | Require Import Stdlib Hierarchy Param_lemmas. 16 | 17 | Set Universe Polymorphism. 18 | Unset Universe Minimization ToSet. 19 | 20 | Import HoTTNotations. 21 | 22 | Inductive natR : nat -> nat -> Type := 23 | | OR : natR O O 24 | | SR : forall (n n' : nat), natR n n' -> natR (S n) (S n'). 25 | 26 | (* From Rocq's stdlib *) 27 | Fixpoint eqb n m : Bool := 28 | match n, m with 29 | | O, O => true 30 | | O, S _ => false 31 | | S _, O => false 32 | | S n', S m' => eqb n' m' 33 | end. 34 | 35 | Lemma uip_lifted_bool (b: Bool) (x1 x2 : is_true b): 36 | x1 = x2. 37 | Proof. 38 | revert x1 x2. 39 | case b=> /= ; case. 40 | by case. 41 | Qed. 42 | 43 | Lemma natR_irrelevant m n (nR nR' : natR m n) : nR = nR'. 44 | Proof. 45 | have @phi k l (r : natR k l) : is_true (eqb k l). 46 | 1: { 47 | elim: r => {k l}; first by reflexivity. 48 | move=> k l r e; exact: e. 49 | } 50 | have @psi k l (e : is_true (eqb k l)) : natR k l. 51 | - elim: k l e => [| k ihk] l e. 52 | + case: l e => [| l] // _; exact OR. 53 | + case: l e => [| l] // e. 54 | exact: SR (ihk _ e). 55 | - have phiK k l r : psi k l (phi k l r) = r. 56 | + elim: r => {k l} // k l r e /=. 57 | by rewrite [X in SR _ _ X]e. 58 | + rewrite -(phiK m n nR) -(phiK m n nR'). 59 | suff -> : phi _ _ nR = phi _ _ nR' by []. 60 | apply uip_lifted_bool. 61 | Defined. 62 | 63 | Definition map_nat : nat -> nat := idmap. 64 | 65 | Definition map_in_R_nat : forall {n n' : nat}, map_nat n = n' -> natR n n' := 66 | fun n n' e => 67 | match e with 68 | | idpath => 69 | (fix F n := 70 | match n with 71 | | O => OR 72 | | S m => SR m m (F m) 73 | end) n 74 | end. 75 | 76 | Definition R_in_map_nat : forall {n n' : nat}, natR n n' -> map_nat n = n' := 77 | fix F n n' (nR : natR n n') : map_nat n = n' := 78 | match nR with 79 | | OR => idpath 80 | | SR m m' mR => ap S (F m m' mR) 81 | end. 82 | 83 | Definition R_in_mapK_nat : forall {n n' : nat} (nR : natR n n'), 84 | map_in_R_nat (R_in_map_nat nR) = nR. 85 | Proof. 86 | by move=> n n'; case: _ / => //= {}n {}n' nR; apply: natR_irrelevant. 87 | Qed. 88 | 89 | Definition Param_nat_sym {n n' : nat} : natR n n' -> natR n' n. 90 | Proof. 91 | intro nR. induction nR as [|m m' _ IH]. 92 | - exact OR. 93 | - exact (SR m' m IH). 94 | Defined. 95 | 96 | Definition Param_nat_sym_inv {n n' : nat} : 97 | forall (nR : natR n n'), Param_nat_sym (Param_nat_sym nR) = nR. 98 | Proof. by elim => //= {}n {}n' nR ->. Defined. 99 | 100 | Definition natR_sym : forall (n n' : nat), sym_rel natR n n' <->> natR n n'. 101 | Proof. 102 | intros n n'; unshelve eexists _, _. 103 | - apply Param_nat_sym. 104 | - apply Param_nat_sym. 105 | - intro nR. apply Param_nat_sym_inv. 106 | Defined. 107 | 108 | Definition Map4_nat : Map4.Has natR. 109 | Proof. 110 | unshelve econstructor. 111 | - exact map_nat. 112 | - exact @map_in_R_nat. 113 | - exact @R_in_map_nat. 114 | - exact @R_in_mapK_nat. 115 | Defined. 116 | 117 | Definition Param44_nat : Param44.Rel nat nat. 118 | Proof. 119 | unshelve econstructor. 120 | - exact natR. 121 | - exact Map4_nat. 122 | - apply (fun e => @eq_Map4 _ _ (sym_rel natR) natR e Map4_nat). 123 | apply natR_sym. 124 | Defined. 125 | 126 | Definition Param00_nat : Param00.Rel nat nat := Param44_nat. 127 | Definition Param2a0_nat : Param2a0.Rel nat nat := Param44_nat. 128 | 129 | Definition Param_add : 130 | forall (n1 n1' : nat) (n1R : natR n1 n1') (n2 n2' : nat) (n2R : natR n2 n2'), 131 | natR (n1 + n2) (n1' + n2'). 132 | Proof. 133 | intros n1 n1' n1R n2 n2' n2R. 134 | induction n1R as [|n1 n1' n1R IHn1R]. 135 | - simpl. exact n2R. 136 | - simpl. apply SR. exact IHn1R. 137 | Defined. 138 | -------------------------------------------------------------------------------- /generic/Param_option.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | Require Import Stdlib Hierarchy Param_lemmas. 16 | 17 | Set Universe Polymorphism. 18 | Unset Universe Minimization ToSet. 19 | 20 | Import HoTTNotations. 21 | 22 | Inductive optionR (A A' : Type) (AR : A -> A' -> Type) : 23 | option A -> option A' -> Type := 24 | | someR : 25 | forall (a : A) (a' : A'), AR a a' -> 26 | optionR A A' AR (Some a) (Some a') 27 | | noneR : optionR A A' AR None None. 28 | 29 | Definition option_map : 30 | forall (A A' : Type) (AR : Param10.Rel A A'), option A -> option A' := 31 | fun A A' AR => 32 | fun oa => 33 | match oa in option _ return option A' with 34 | | Some a => Some (map AR a) 35 | | None => None 36 | end. 37 | 38 | Definition some_inj1 : 39 | forall (A : Type) (a1 a2 : A), Some a1 = Some a2 -> a1 = a2 := 40 | fun A a1 a2 e => 41 | let proj1 (oa : option A) := 42 | match oa with 43 | | Some a => a 44 | | None => a1 45 | end 46 | in ap proj1 e. 47 | 48 | Definition exfalso_option_some_none : 49 | forall (T : Type) (A : Type) (a : A), Some a = None -> T := 50 | fun T A a e => 51 | match e in @paths _ _ t 52 | return 53 | match t with 54 | | Some _ => Unit 55 | | _ => T 56 | end 57 | with 58 | | idpath => tt 59 | end. 60 | 61 | Definition exfalso_option_none_some : 62 | forall (T : Type) (A : Type) (a : A), None = Some a -> T := 63 | fun T A a e => 64 | match e in @paths _ _ t 65 | return 66 | match t with 67 | | None => Unit 68 | | Some _ => T 69 | end 70 | with 71 | | idpath => tt 72 | end. 73 | 74 | Definition option_map_in_R : 75 | forall (A A' : Type) (AR : Param2a0.Rel A A') 76 | (oa : option A) (oa' : option A'), 77 | option_map A A' AR oa = oa' -> optionR A A' AR oa oa' := 78 | fun A A' AR => 79 | fun oa oa' => 80 | match oa with 81 | | Some a => 82 | match oa' with 83 | | Some a' => 84 | fun e => 85 | someR A A' AR a a' (map_in_R AR a a' (some_inj1 A' (map AR a) a' e)) 86 | | None => 87 | fun e => 88 | exfalso_option_some_none (optionR A A' AR (Some a) (None)) 89 | A' (map AR a) e 90 | end 91 | | None => 92 | match oa' with 93 | | Some a' => 94 | fun e => 95 | exfalso_option_none_some (optionR A A' AR (None) (Some a')) 96 | A' a' e 97 | | None => fun e => noneR A A' AR 98 | end 99 | end. 100 | 101 | Definition option_R_in_map : 102 | forall (A A' : Type) (AR : Param2b0.Rel A A') 103 | (oa : option A) (oa' : option A'), 104 | optionR A A' AR oa oa' -> option_map A A' AR oa = oa' 105 | := 106 | fun A A' AR => 107 | fun oa oa' oaR => 108 | match oaR in optionR _ _ _ oa oa' return option_map A A' AR oa = oa' with 109 | | @someR _ _ _ a a' aR => 110 | @transport A' (fun t => Some t = Some a') 111 | a' (map AR a) (R_in_map AR a a' aR)^ 112 | idpath 113 | | @noneR _ _ _ => idpath 114 | end. 115 | 116 | Definition option_R_in_mapK (A A' : Type) (AR : Param40.Rel A A') 117 | (oa : option A) (oa' : option A') (oaR : optionR A A' AR oa oa') : 118 | option_map_in_R A A' AR oa oa' (option_R_in_map A A' AR oa oa' oaR) = oaR. 119 | Proof. 120 | by case: oaR => [a a' aR|]//=; elim/(ind_map AR): _; rewrite transport_1. 121 | Qed. 122 | -------------------------------------------------------------------------------- /generic/Param_prod.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | Require Import Stdlib Hierarchy Param_lemmas. 16 | 17 | Set Universe Polymorphism. 18 | Unset Universe Minimization ToSet. 19 | 20 | Import HoTTNotations. 21 | 22 | Inductive prodR 23 | {A A'} (AR : A -> A' -> Type) {B B'} (BR : B -> B' -> Type) : A * B -> A' * B' -> Type := 24 | | pairR a a' (aR : AR a a') b b' (bR : BR b b') : prodR AR BR (a, b) (a', b'). 25 | 26 | Arguments pairR {A A' AR B B' BR} a a' aR b b' bR. 27 | 28 | (* *) 29 | 30 | Definition prod_map 31 | (A A' : Type) (AR : Param10.Rel A A') (B B' : Type) (BR : Param10.Rel B B') : 32 | A * B -> A' * B' := 33 | fun p => 34 | match p with 35 | | (a, b) => (map AR a, map BR b) 36 | end. 37 | 38 | (* *) 39 | 40 | Definition pair_inj1 A B (a1 a2 : A) (b1 b2 : B) : 41 | (a1, b1) = (a2, b2) -> a1 = a2 := 42 | fun e => 43 | match e in _ = (a, b) return _ = a with 44 | | @idpath _ _ => @idpath _ a1 45 | end. 46 | 47 | Definition pair_inj2 A B (a1 a2 : A) (b1 b2 : B) : 48 | (a1, b1) = (a2, b2) -> b1 = b2 := 49 | fun e => 50 | match e in @paths _ _ (a, b) return _ = b with 51 | | @idpath _ _ => @idpath _ b1 52 | end. 53 | 54 | Definition prod_map_in_R 55 | (A A' : Type) (AR : Param2a0.Rel A A') (B B' : Type) (BR : Param2a0.Rel B B') : 56 | forall p p', prod_map A A' AR B B' BR p = p' -> prodR AR BR p p' := 57 | fun p p' => 58 | match p with 59 | | (a, b) => 60 | match p' with 61 | | (a', b') => 62 | fun e => 63 | pairR 64 | a a' (map_in_R AR a a' (pair_inj1 A' B' (map AR a) a' (map BR b) b' e)) 65 | b b' (map_in_R BR b b' (pair_inj2 A' B' (map AR a) a' (map BR b) b' e)) 66 | end 67 | end. 68 | 69 | (* *) 70 | 71 | Definition prod_R_in_map 72 | (A A' : Type) (AR : Param2b0.Rel A A') (B B' : Type) (BR : Param2b0.Rel B B') : 73 | forall p p', prodR AR BR p p' -> prod_map A A' AR B B' BR p = p' := 74 | fun p p' r => 75 | match r with 76 | | pairR a a' aR b b' bR => 77 | @transport _ (fun t => (t, map BR b) = (a', b')) _ _ (R_in_map AR a a' aR)^ 78 | (@transport _ (fun t => (a', t) = (a', b')) _ _ (R_in_map BR b b' bR)^ idpath) 79 | end. 80 | 81 | (* *) 82 | 83 | Definition prod_R_in_mapK 84 | (A A' : Type) (AR : Param40.Rel A A') (B B' : Type) (BR : Param40.Rel B B') : 85 | forall p p' (r : prodR AR BR p p'), 86 | prod_map_in_R A A' AR B B' BR p p' (prod_R_in_map A A' AR B B' BR p p' r) = r. 87 | Proof. 88 | intros p p' []; rewrite /prod_R_in_map/=. 89 | by elim/(ind_map AR): _; elim/(ind_map BR): _. 90 | Qed. 91 | 92 | (* *) 93 | 94 | Definition Map0_prod A A' (AR : Param00.Rel A A') B B' (BR : Param00.Rel B B') : 95 | Map0.Has (prodR AR BR). 96 | Proof. constructor. Defined. 97 | 98 | Definition Map1_prod A A' (AR : Param10.Rel A A') B B' (BR : Param10.Rel B B') : 99 | Map1.Has (prodR AR BR). 100 | Proof. constructor. exact (prod_map A A' AR B B' BR). Defined. 101 | 102 | Definition Map2a_prod A A' (AR : Param2a0.Rel A A') B B' (BR : Param2a0.Rel B B') : 103 | Map2a.Has (prodR AR BR). 104 | Proof. 105 | unshelve econstructor. 106 | - exact (prod_map A A' AR B B' BR). 107 | - exact (prod_map_in_R A A' AR B B' BR). 108 | Defined. 109 | 110 | Definition Map2b_prod A A' (AR : Param2b0.Rel A A') B B' (BR : Param2b0.Rel B B') : 111 | Map2b.Has (prodR AR BR). 112 | Proof. 113 | unshelve econstructor. 114 | - exact (prod_map A A' AR B B' BR). 115 | - exact (prod_R_in_map A A' AR B B' BR). 116 | Defined. 117 | 118 | Definition Map3_prod A A' (AR : Param30.Rel A A') B B' (BR : Param30.Rel B B') : 119 | Map3.Has (prodR AR BR). 120 | Proof. 121 | unshelve econstructor. 122 | - exact (prod_map A A' AR B B' BR). 123 | - exact (prod_map_in_R A A' AR B B' BR). 124 | - exact (prod_R_in_map A A' AR B B' BR). 125 | Defined. 126 | 127 | Definition Map4_prod A A' (AR : Param40.Rel A A') B B' (BR : Param40.Rel B B') : 128 | Map4.Has (prodR AR BR). 129 | Proof. 130 | unshelve econstructor. 131 | - exact (prod_map A A' AR B B' BR). 132 | - exact (prod_map_in_R A A' AR B B' BR). 133 | - exact (prod_R_in_map A A' AR B B' BR). 134 | - exact (prod_R_in_mapK A A' AR B B' BR). 135 | Defined. 136 | -------------------------------------------------------------------------------- /generic/Param_sigma.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | Require Import Stdlib Hierarchy Param_lemmas. 16 | 17 | Set Universe Polymorphism. 18 | Unset Universe Minimization ToSet. 19 | 20 | Import HoTTNotations. 21 | 22 | Inductive sigR 23 | A A' (AR : A -> A' -> Type) 24 | P P' (PR : forall a a', AR a a' -> P a -> P' a' -> Type) : 25 | {x : A & P x} -> {x' : A' & P' x'} -> Type := 26 | | existR a a' (aR : AR a a') p p' (pR : PR a a' aR p p') : 27 | sigR A A' AR P P' PR (a; p) (a'; p'). 28 | 29 | Definition sig_map 30 | (A A' : Type) (AR : Param2a0.Rel A A') 31 | (P : A -> Type) (P' : A' -> Type) (PR : forall a a', AR a a' -> Param10.Rel (P a) (P' a')) : 32 | {x : A & P x} -> {x' : A' & P' x'} := 33 | fun s => (map AR s.1; map (PR s.1 (map AR s.1) (map_in_R AR s.1 (map AR s.1) idpath)) s.2). 34 | 35 | Definition sig_map_in_R 36 | (A A' : Type) (AR : Param2a0.Rel A A') 37 | (P : A -> Type) (P' : A' -> Type) (PR : forall a a', AR a a' -> Param2a0.Rel (P a) (P' a')) : 38 | forall (s : {x : A & P x}) (s' : {x' : A' & P' x'}), 39 | sig_map A A' AR P P' PR s = s' -> sigR A A' AR P P' PR s s'. 40 | Proof. 41 | move=> [x Px] [y Py]; case: _ /. 42 | exists (@map_in_R A A' AR x _ 1); exact: map_in_R. 43 | Defined. 44 | 45 | Arguments rel : simpl never. 46 | 47 | Definition sig_R_in_map 48 | (A A' : Type) (AR : Param40.Rel A A') 49 | (P : A -> Type) (P' : A' -> Type) (PR : forall a a', AR a a' -> Param2b0.Rel (P a) (P' a')) : 50 | forall (s : {x : A & P x}) (s' : {x' : A' & P' x'}), 51 | sigR A A' AR P P' PR s s' -> sig_map A A' AR P P' PR s = s'. 52 | Proof. 53 | move=> [x Px] [u Py]; elim=> a a' aR p p' pR. 54 | elim: (R_in_map _ _ _ pR) => {pR}. 55 | by elim/(ind_map AR): _ aR / _. 56 | Defined. 57 | 58 | Definition sig_R_in_mapK 59 | (A A' : Type) (AR : Param40.Rel A A') 60 | (P : A -> Type) (P' : A' -> Type) (PR : forall a a', AR a a' -> Param40.Rel (P a) (P' a')) : 61 | forall (s : {x : A & P x}) (s' : {x' : A' & P' x'}), 62 | (sig_map_in_R A A' AR P P' PR s s') o (sig_R_in_map A A' AR P P' PR s s') == idmap. 63 | Proof. 64 | move=> _ _ [a a' aR p p' pR] //=. 65 | elim/(ind_map (PR a a' aR)): _. 66 | by elim/(ind_mapP AR): _. 67 | Qed. 68 | -------------------------------------------------------------------------------- /generic/Param_trans.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | Require Import Stdlib Hierarchy Common Param_lemmas. 16 | 17 | Set Universe Polymorphism. 18 | Unset Universe Minimization ToSet. 19 | 20 | Import HoTTNotations. 21 | 22 | (* transitivity proofs for Param 23 | * makes some proofs easier cf example in Vector_tuple.v 24 | *) 25 | 26 | Definition R_trans {A B C : Type} (R1 : A -> B -> Type) (R2 : B -> C -> Type) : A -> C -> Type := 27 | fun a c => {b : B & (R1 a b * R2 b c)%type}. 28 | 29 | Definition map_trans {A B C : Type} (R1 : Param10.Rel A B) (R2 : Param10.Rel B C) : A -> C := 30 | map R2 o map R1. 31 | 32 | Definition map_in_R_trans {A B C : Type} (R1 : Param2a0.Rel A B) (R2 : Param2a0.Rel B C) : 33 | forall (a : A) (c : C), map_trans R1 R2 a = c -> R_trans R1 R2 a c. 34 | Proof. 35 | intros a c e; exists (map R1 a); split. 36 | - apply (map_in_R R1); reflexivity. 37 | - apply (map_in_R R2); exact: e. 38 | Defined. 39 | 40 | Definition R_in_map_trans {A B C : Type} (R1 : Param2b0.Rel A B) (R2 : Param2b0.Rel B C) : 41 | forall (a : A) (c : C), R_trans R1 R2 a c -> map_trans R1 R2 a = c. 42 | Proof. 43 | intros a c [b [r1 r2]]; apply R_in_map. 44 | exact: (transport (fun x => R2 x c) (R_in_map R1 a b r1)^). 45 | Defined. 46 | 47 | Definition R_in_mapK_trans {A B C : Type} (R1 : Param40.Rel A B) (R2 : Param40.Rel B C) : 48 | forall (a : A) (c : C) (r : R_trans R1 R2 a c), 49 | map_in_R_trans R1 R2 a c (R_in_map_trans R1 R2 a c r) = r. 50 | Proof. 51 | move=> a c [b [ab bc]]. 52 | rewrite /map_in_R_trans /R_in_map_trans. 53 | elim /(ind_map R1): _ in bc *. 54 | rewrite transport_1. 55 | by elim /(ind_map R2): _. 56 | Qed. 57 | 58 | Definition Map0_trans {A B C : Type} (R1 : Param00.Rel A B) (R2 : Param00.Rel B C) : 59 | Map0.Has (R_trans R1 R2). 60 | Proof. constructor. Defined. 61 | 62 | Definition Map1_trans {A B C : Type} (R1 : Param10.Rel A B) (R2 : Param10.Rel B C) : 63 | Map1.Has (R_trans R1 R2). 64 | Proof. constructor. exact (map_trans R1 R2). Defined. 65 | 66 | Definition Map2a_trans {A B C : Type} (R1 : Param2a0.Rel A B) (R2 : Param2a0.Rel B C) : 67 | Map2a.Has (R_trans R1 R2). 68 | Proof. 69 | unshelve econstructor. 70 | - exact (map_trans R1 R2). 71 | - exact (map_in_R_trans R1 R2). 72 | Defined. 73 | 74 | Definition Map2b_trans {A B C : Type} (R1 : Param2b0.Rel A B) (R2 : Param2b0.Rel B C) : 75 | Map2b.Has (R_trans R1 R2). 76 | Proof. 77 | unshelve econstructor. 78 | - exact (map_trans R1 R2). 79 | - exact (R_in_map_trans R1 R2). 80 | Defined. 81 | 82 | Definition Map3_trans {A B C : Type} (R1 : Param30.Rel A B) (R2 : Param30.Rel B C) : 83 | Map3.Has (R_trans R1 R2). 84 | Proof. 85 | unshelve econstructor. 86 | - exact (map_trans R1 R2). 87 | - exact (map_in_R_trans R1 R2). 88 | - exact (R_in_map_trans R1 R2). 89 | Defined. 90 | 91 | Definition Map4_trans {A B C : Type} (R1 : Param40.Rel A B) (R2 : Param40.Rel B C) : 92 | Map4.Has (R_trans R1 R2). 93 | Proof. 94 | unshelve econstructor. 95 | - exact (map_trans R1 R2). 96 | - exact (map_in_R_trans R1 R2). 97 | - exact (R_in_map_trans R1 R2). 98 | - exact (R_in_mapK_trans R1 R2). 99 | Defined. 100 | 101 | Definition R_trans_sym {A B C : Type} (R1 : Param00.Rel A B) (R2 : Param00.Rel B C) : 102 | forall (c : C) (a : A), 103 | sym_rel (R_trans R1 R2) c a <->> R_trans (sym_rel R2) (sym_rel R1) c a. 104 | Proof. 105 | intros c a. 106 | unfold sym_rel, R_trans. 107 | unshelve eexists _, _. 108 | - intros [b [r1 r2]]. exact (b; (r2, r1)). 109 | - intros [b [r2 r1]]. exact (b; (r1, r2)). 110 | - intros [b [r2 r1]]; reflexivity. 111 | Defined. 112 | 113 | Definition Param44_trans {A B C : Type} : Param44.Rel A B -> Param44.Rel B C -> Param44.Rel A C. 114 | Proof. 115 | intros R1 R2. 116 | unshelve econstructor. 117 | - exact (R_trans R1 R2). 118 | - exact (Map4_trans R1 R2). 119 | - unshelve eapply (@eq_Map4 _ _ (sym_rel (R_trans R1 R2)) (R_trans (sym_rel R2) (sym_rel R1))). 120 | + exact (R_trans_sym R1 R2). 121 | + exact (Map4_trans (Param44_sym B C R2) (Param44_sym A B R1)). 122 | Defined. 123 | 124 | Definition Param42b_trans {A B C : Type} : 125 | Param42b.Rel A B -> Param42b.Rel B C -> Param42b.Rel A C. 126 | Proof. 127 | intros R1 R2. 128 | unshelve econstructor. 129 | - exact (R_trans R1 R2). 130 | - exact (@Map4_trans A B C R1 R2). 131 | - unshelve eapply (@eq_Map2b _ _ (sym_rel (R_trans R1 R2)) (R_trans (sym_rel R2) (sym_rel R1))). 132 | + exact (R_trans_sym R1 R2). 133 | + exact (Map2b_trans (Param02b_sym B C R2) (Param02b_sym A B R1)). 134 | Defined. 135 | -------------------------------------------------------------------------------- /generic/Trocq.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Export elpi. 15 | From Trocq Require Export 16 | Database Hierarchy Vernac Param Common 17 | Param_arrow Param_Type Param_forall Param_prod Param_sigma 18 | Param_Empty Param_option Param_sum Param_trans Param_paths Param_vector 19 | Param_nat Param_list Param_bool Param_lemmas. 20 | 21 | (* TODO: should we also export some variant-specific files, such as Param_Prop.v? *) 22 | 23 | Trocq Use Param10_paths. 24 | Trocq Use Param01_paths. 25 | -------------------------------------------------------------------------------- /generic/Vernac.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | From Trocq Require Import Param. 16 | 17 | From Trocq.Elpi Extra Dependency "util-rocq.elpi" as util_rocq. 18 | From Trocq.Elpi Extra Dependency "annot.elpi" as annot. 19 | From Trocq.Elpi Extra Dependency "param-class-util.elpi" as param_class_util. 20 | From Trocq.Elpi.constraints Extra Dependency "simple-graph.elpi" as simple_graph. 21 | From Trocq.Elpi.constraints Extra Dependency "constraint-graph.elpi" as constraint_graph. 22 | From Trocq.Elpi.constraints Extra Dependency "constraints.elpi" as constraints. 23 | From Trocq.Elpi Extra Dependency "vernac.elpi" as vernac. 24 | 25 | Elpi Command Trocq. 26 | Elpi Accumulate Db trocq.db. 27 | Elpi Accumulate File util_rocq. 28 | Elpi Accumulate File annot. 29 | Elpi Accumulate File param_class_util. 30 | Elpi Accumulate File simple_graph. 31 | Elpi Accumulate File constraint_graph. 32 | Elpi Accumulate File constraints. 33 | Elpi Accumulate File vernac. 34 | Elpi Export Trocq. 35 | -------------------------------------------------------------------------------- /hott/HoTT_additions.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From HoTT Require Export HoTT. 16 | 17 | Set Universe Polymorphism. 18 | Unset Universe Minimization ToSet. 19 | 20 | Definition equiv_forall_sigma {A : Type} {P : A -> Type} {Q : forall a, P a -> Type} : 21 | (forall a (b : P a), Q a b) <~> forall x : { a : A | P a }, Q x.1 x.2. 22 | Proof. 23 | unshelve econstructor. { move=> f [a b]; exact (f a b). } 24 | unshelve econstructor. { move=> g a b; exact (g (a; b)). } 25 | all: constructor. 26 | Defined. 27 | 28 | Lemma equiv_invK {A B} (e : A <~> B) x : e (e^-1%equiv x) = x. 29 | Proof. by case: e => [f []]. Defined. 30 | 31 | Lemma equiv_funK {A B} (e : A <~> B) x : e^-1%equiv (e x) = x. 32 | Proof. by case: e => [f []]. Defined. 33 | 34 | Definition IsFun {A B : Type@{i}} (R : A -> B -> Type@{i}) := 35 | (forall x, Contr {y | R x y}). 36 | 37 | Fact isfun_isprop `{Funext} {A B : Type@{i}} (R : A -> B -> Type@{i}) : 38 | IsHProp (IsFun R). 39 | Proof. typeclasses eauto. Defined. 40 | 41 | Lemma fun_isfun {A B : Type@{i}} (f : A -> B) : IsFun (fun x y => f x = y). 42 | Proof. by move=> x; apply (Build_Contr _ (f x; 1)) => -[y]; elim. Defined. 43 | 44 | Lemma isequiv_isfun `{Univalence} {A B : Type@{i}} (f : A -> B) : 45 | IsEquiv f <~> IsFun (fun x y => f y = x). 46 | Proof. by symmetry; apply equiv_contr_map_isequiv. Defined. 47 | 48 | Lemma type_equiv_contr `{Univalence} {A : Type@{i}} : 49 | A <~> {P : A -> Type | Contr {x : A & P x}}. 50 | Proof. 51 | apply equiv_inverse; unshelve eapply equiv_adjointify. 52 | - move=> [F c]. 53 | eapply pr1, center. 54 | exact c. 55 | - by move=> a; exists (paths a); apply contr_basedpaths. 56 | - done. 57 | - move=> [P Pc]; unshelve eapply path_sigma. { 58 | apply: path_arrow => a; apply: equiv_path_universe. 59 | apply: equiv_inverse; apply: equiv_path_from_contr. 60 | exact (center {x | P x}).2. } 61 | by apply: path_contr. 62 | Defined. 63 | 64 | Lemma fun_equiv_isfun `{Univalence} {A B : Type} : 65 | (A -> B) <~> {R : A -> B -> Type | IsFun R}. 66 | Proof. 67 | have@ fe : Funext by apply: Univalence_implies_Funext. 68 | transitivity (A -> {P : B -> Type | Contr {y : B & P y}}). 69 | { apply: equiv_postcompose'; exact type_equiv_contr. } 70 | by apply (equiv_composeR' (equiv_sig_coind _ _)^-1). 71 | Defined. 72 | 73 | Lemma equiv_sig_relequiv `{Univalence} {A B : Type@{i}} : 74 | (A <~> B) <~> RelEquiv A B. 75 | Proof. 76 | apply (equiv_composeR' (issig_equiv _ _)^-1). 77 | apply (equiv_compose' issig_relequiv). 78 | apply (equiv_compose' (equiv_sigma_assoc' _ _)^-1). 79 | unshelve eapply equiv_functor_sigma. 80 | - exact: fun_equiv_isfun. 81 | - by move=> f; apply: isequiv_isfun. 82 | - exact: equiv_isequiv. 83 | - by move=> f; apply: equiv_isequiv. 84 | Defined. 85 | 86 | Definition apD10_path_forall_cancel `{Funext} : 87 | forall {A : Type} {B : A -> Type} {f g : forall x : A, B x} (p : forall x, f x = g x), 88 | apD10 (path_forall f g p) = p. 89 | Proof. 90 | intros. unfold path_forall. 91 | apply moveR_equiv_M. 92 | reflexivity. 93 | Defined. 94 | 95 | Definition transport_apD10 : 96 | forall {A : Type} {B : A -> Type} {a : A} (P : B a -> Type) 97 | {t1 t2 : forall x : A, B x} {e : t1 = t2} {p : P (t1 a)}, 98 | transport (fun (t : forall x : A, B x) => P (t a)) e p = 99 | transport (fun (t : B a) => P t) (apD10 e a) p. 100 | Proof. 101 | intros A B a P t1 t2 [] p; reflexivity. 102 | Defined. 103 | 104 | Definition ap2 : forall {A B C : Type} (f : A -> B -> C) {a1 a2 : A} {b1 b2 : B}, 105 | a1 = a2 -> b1 = b2 -> f a1 b1 = f a2 b2. 106 | Proof. 107 | intros A B C f a1 a2 b1 b2 ea eb. 108 | destruct ea. destruct eb. reflexivity. 109 | Defined. 110 | 111 | Definition coe_inverse_cancel {A B} (e : A = B) p: coe e (coe e^ p) = p. 112 | Proof. elim: e p; reflexivity. Defined. 113 | 114 | Definition coe_inverse_cancel' {A B} (e : A = B) p : coe e^ (coe e p) = p. 115 | Proof. elim: e p; reflexivity. Defined. 116 | 117 | Definition path_forall_types `{Funext} A F G : 118 | (forall (a : A), F a = G a) -> (forall a, F a) = (forall a, G a). 119 | Proof. by move=> /(path_forall _ _)->. Defined. 120 | 121 | Notation "A <--> B" := ((A -> B) * (B -> A))%type (at level 70) : fibration_scope. 122 | 123 | (* TODO: that's an awful name *) 124 | Definition LeftInversesBetween@{i} (A B: Type@{i}) : Type@{i} := { 125 | f : A -> B | { 126 | g : B -> A | ( 127 | forall x, g (f x) = x 128 | )}}. 129 | Notation "A <->> B" := (LeftInversesBetween A B) (at level 70) : fibration_scope. 130 | 131 | Definition equiv_flip@{i k} (A B : Type@{i}) (P : A -> B -> Type@{k}) : 132 | LeftInversesBetween@{k} (forall (a : A) (b : B), P a b) (forall (b : B) (a : A), P a b). 133 | Proof. by do 2!exists (fun PAB b a => PAB a b). Defined. 134 | -------------------------------------------------------------------------------- /hott/Param.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import ssreflect. 16 | Require Export Database. 17 | Require Import Hierarchy. 18 | Require Export Param_Type Param_arrow Param_forall. 19 | 20 | From Trocq.Elpi Extra Dependency "annot.elpi" as annot. 21 | From Trocq.Elpi Extra Dependency "util-rocq.elpi" as util_rocq. 22 | From Trocq.Elpi Extra Dependency "class.elpi" as class. 23 | From Trocq.Elpi Extra Dependency "param-class-util.elpi" as param_class_util. 24 | From Trocq.Elpi Extra Dependency "param.elpi" as param. 25 | From Trocq.Elpi.constraints Extra Dependency "simple-graph.elpi" as simple_graph. 26 | From Trocq.Elpi.constraints Extra Dependency "constraint-graph.elpi" as constraint_graph. 27 | From Trocq.Elpi.constraints Extra Dependency "constraints.elpi" as constraints. 28 | From Trocq.Elpi.constraints Extra Dependency "constraints-impl.elpi" as constraints_impl. 29 | From Trocq.Elpi.generation Extra Dependency "pparam-type.elpi" as pparam_type_generation. 30 | From Trocq.Elpi Extra Dependency "tactic.elpi" as tactic. 31 | 32 | Set Universe Polymorphism. 33 | Unset Universe Minimization ToSet. 34 | 35 | Elpi Command genpparam. 36 | Elpi Accumulate Db trocq.db. 37 | Elpi Accumulate File class. 38 | 39 | Elpi Command genpparamtype. 40 | Elpi Accumulate Db trocq.db. 41 | Elpi Accumulate File class. 42 | Elpi Accumulate File pparam_type_generation. 43 | 44 | Elpi Query lp:{{ 45 | coq.univ.new U, 46 | coq.univ.variable U L, 47 | coq.univ.alg-super U U1, 48 | coq.univ.variable U1 L1, 49 | map-class.all-of-kind low Classes1, 50 | map-class.all-of-kind high Classes2, 51 | map-class.all-of-kind all Classes, 52 | % first the ones where the arguments matter 53 | std.forall Classes1 (m\ 54 | std.forall Classes1 (n\ 55 | generate-pparam-type L L1 (pc m n) 56 | ) 57 | ), 58 | % then the ones where the (4,4) relation is always returned 59 | std.forall Classes (m\ 60 | std.forall Classes2 (n\ 61 | generate-pparam-type44 L L1 (pc m n) 62 | ) 63 | ), 64 | std.forall Classes2 (m\ 65 | std.forall Classes1 (n\ 66 | generate-pparam-type44 L L1 (pc m n) 67 | ) 68 | ). 69 | }}. 70 | 71 | Elpi Tactic trocq. 72 | Elpi Accumulate Db trocq.db. 73 | Elpi Accumulate File class. 74 | Elpi Accumulate File simple_graph. 75 | Elpi Accumulate File constraints. 76 | Elpi Accumulate File annot. 77 | Elpi Accumulate File constraint_graph. 78 | Elpi Accumulate File constraints_impl. 79 | Elpi Accumulate File param_class_util. 80 | Elpi Accumulate File param. 81 | Elpi Accumulate File util_rocq. 82 | Elpi Accumulate File tactic. 83 | 84 | Tactic Notation "trocq" ident_list(l) := elpi trocq ltac_string_list:(l). 85 | -------------------------------------------------------------------------------- /hott/Param_Type.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From elpi Require Import elpi. 16 | Require Import Hierarchy Stdlib Database Param_lemmas. 17 | 18 | From Trocq.Elpi Extra Dependency "class.elpi" as class. 19 | From Trocq.Elpi.generation Extra Dependency "param-type.elpi" as param_type_generation. 20 | 21 | Set Universe Polymorphism. 22 | Unset Universe Minimization ToSet. 23 | 24 | Local Open Scope param_scope. 25 | 26 | (* generate MapM_TypeNP@{i} : 27 | MapM.Has Type@{i} Type@{i} ParamNP.Rel@{i}, 28 | for all N P, for M = map2a and below (above, NP is always 44) 29 | + symmetry MapM_Type_symNP *) 30 | 31 | Elpi Command genmaptype. 32 | Elpi Accumulate Db trocq.db. 33 | Elpi Accumulate File class. 34 | Elpi Accumulate File param_type_generation. 35 | 36 | Elpi Query lp:{{ 37 | coq.univ.new U, 38 | coq.univ.variable U L, 39 | coq.univ.alg-super U U1, 40 | % cannot have only one binder in the declaration because this line creates a fresh level: 41 | coq.univ.variable U1 L1, 42 | map-class.all-of-kind all Classes, 43 | map-class.all-of-kind low LowClasses, 44 | std.forall LowClasses (m\ 45 | std.forall Classes (n\ 46 | std.forall Classes (p\ 47 | generate-map-type m (pc n p) U L L1 48 | ) 49 | ) 50 | ). 51 | }}. 52 | 53 | (* now R is always Param44.Rel *) 54 | 55 | (* NB: here we would like to use i+1 instead of j but Coq does not allow it 56 | * Map*.Has is a constant so it currently cannot be instantiated with an algebraic universe 57 | *) 58 | 59 | Definition Map2b_Type44@{i j | i < j} `{Univalence} : 60 | @Map2b.Has@{j} Type@{i} Type@{i} Param44.Rel@{i}. 61 | Proof. 62 | unshelve econstructor. 63 | - exact idmap. 64 | - move=> A B /uparam_equiv. apply: path_universe_uncurried. 65 | Defined. 66 | 67 | Definition Map2b_Type_sym44@{i j | i < j} `{Univalence} : 68 | @Map2b.Has@{j} Type@{i} Type@{i} (sym_rel@{j} Param44.Rel@{i}). 69 | Proof. 70 | unshelve econstructor. 71 | - exact idmap. 72 | - move=> A B /uparam_equiv /path_universe_uncurried /inverse. exact. 73 | Defined. 74 | 75 | Definition Map3_Type44@{i j | i < j} `{Univalence} : 76 | @Map3.Has@{j} Type@{i} Type@{i} Param44.Rel@{i}. 77 | Proof. 78 | unshelve econstructor. 79 | - exact idmap. 80 | - exact (fun A B e => e # id_Param44 A). 81 | - move=> A B /uparam_equiv. apply: path_universe_uncurried. 82 | Defined. 83 | 84 | Definition Map3_Type_sym44@{i j | i < j} `{Univalence} : 85 | @Map3.Has@{j} Type@{i} Type@{i} (sym_rel@{j} Param44.Rel@{i}). 86 | Proof. 87 | unshelve econstructor. 88 | - exact idmap. 89 | - exact (fun A B e => e # id_Param44 A). 90 | - move=> A B /uparam_equiv /path_universe_uncurried /inverse. exact. 91 | Defined. 92 | 93 | Definition Map4_Type44@{i j | i < j} `{Univalence} : 94 | @Map4.Has@{j} Type@{i} Type@{i} Param44.Rel@{i}. 95 | Proof. 96 | unshelve econstructor. 97 | - exact idmap. 98 | - exact (fun A B e => e # id_Param44 A). 99 | - move=> A B /uparam_equiv. apply: path_universe_uncurried. 100 | - move=> A B; elim/uparam_induction. 101 | by rewrite uparam_equiv_id /= [path_universe_uncurried _] path_universe_1. 102 | Defined. 103 | 104 | Definition Map4_Type_sym44@{i j | i < j} `{Univalence} : 105 | @Map4.Has@{j} Type@{i} Type@{i} (sym_rel@{j} Param44.Rel@{i}). 106 | Proof. 107 | unshelve econstructor. 108 | - exact idmap. 109 | - exact (fun A B e => e # id_Param44 A). 110 | - move=> A B /uparam_equiv /path_universe_uncurried /inverse. exact. 111 | - move=> A B; elim/uparam_induction. 112 | by rewrite uparam_equiv_id /= [path_universe_uncurried _] path_universe_1. 113 | Defined. 114 | 115 | Elpi Command genparamtype. 116 | Elpi Accumulate Db trocq.db. 117 | Elpi Accumulate File class. 118 | Elpi Accumulate File param_type_generation. 119 | 120 | Elpi Query lp:{{ 121 | coq.univ.new U, 122 | coq.univ.variable U L, 123 | coq.univ.alg-super U U1, 124 | % cannot have only one binder in the declaration because this line creates a fresh level: 125 | coq.univ.variable U1 L1, 126 | map-class.all-of-kind all AllClasses, 127 | map-class.all-of-kind low Classes__, 128 | map-class.all-of-kind high Classes44, 129 | std.forall Classes__ (m\ 130 | std.forall Classes__ (n\ 131 | std.forall AllClasses (p\ 132 | std.forall AllClasses (q\ 133 | generate-param-type (pc m n) (pc p q) U L L1 134 | ) 135 | ) 136 | ), 137 | std.forall Classes44 (n\ 138 | generate-param-type (pc m n) (pc map4 map4) U L L1 139 | ) 140 | ), 141 | std.forall Classes44 (m\ 142 | std.forall AllClasses (n\ 143 | generate-param-type (pc m n) (pc map4 map4) U L L1 144 | ) 145 | ). 146 | }}. 147 | 148 | -------------------------------------------------------------------------------- /hott/Param_arrow.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import ssreflect. 16 | Require Import Stdlib Hierarchy Database Param_lemmas. 17 | 18 | From Trocq.Elpi Extra Dependency "util-rocq.elpi" as util_rocq. 19 | From Trocq.Elpi Extra Dependency "param-class-util.elpi" as param_class_util. 20 | From Trocq.Elpi.generation Extra Dependency "param-arrow.elpi" as param_arrow_generation. 21 | 22 | Set Universe Polymorphism. 23 | Unset Universe Minimization ToSet. 24 | 25 | Local Open Scope param_scope. 26 | 27 | Elpi Command genparamarrow. 28 | Elpi Accumulate Db trocq.db. 29 | Elpi Accumulate File util_rocq. 30 | Elpi Accumulate File param_class_util. 31 | 32 | (* relation for arrow *) 33 | 34 | Definition R_arrow@{i j} 35 | {A A' : Type@{i}} (PA : Param00.Rel@{i} A A') 36 | {B B' : Type@{j}} (PB : Param00.Rel@{j} B B') := 37 | fun f f' => forall a a', PA a a' -> PB (f a) (f' a'). 38 | 39 | (* MapN for arrow *) 40 | 41 | (* (00, 00) -> 00 *) 42 | Definition Map0_arrow@{i j k | i <= k, j <= k} 43 | {A A' : Type@{i}} (PA : Param00.Rel@{i} A A') 44 | {B B' : Type@{j}} (PB : Param00.Rel@{j} B B') : 45 | Map0.Has@{k} (R_arrow PA PB). 46 | Proof. exists. Defined. 47 | 48 | (* (01, 10) -> 10 *) 49 | Definition Map1_arrow@{i j k} 50 | {A A' : Type@{i}} (PA : Param01.Rel@{i} A A') 51 | {B B' : Type@{j}} (PB : Param10.Rel@{j} B B') : 52 | Map1.Has@{k} (R_arrow PA PB). 53 | Proof. 54 | exists; exact (fun f a' => map PB (f (comap PA a'))). 55 | Defined. 56 | 57 | (* (02b, 2a0) -> 2a0 *) 58 | Definition Map2a_arrow@{i j k} 59 | {A A' : Type@{i}} (PA : Param02b.Rel@{i} A A') 60 | {B B' : Type@{j}} (PB : Param2a0.Rel@{j} B B') : 61 | Map2a.Has@{k} (R_arrow PA PB). 62 | Proof. 63 | exists (Map1.map@{k} _ (Map1_arrow@{i j k} PA PB)). 64 | move=> f f' /= e a a' aR; apply (map_in_R@{j} PB). 65 | apply (transport@{j j} (fun t => _ = t a') e) => /=. 66 | by apply (transport@{j j} (fun t => _ = map _ (f t)) 67 | (R_in_comap@{i} PA _ _ aR)^). 68 | Defined. 69 | 70 | (* (02a, 2b0) + funext -> 2b0 *) 71 | Definition Map2b_arrow@{i j k} `{Funext} 72 | {A A' : Type@{i}} (PA : Param02a.Rel@{i} A A') 73 | {B B' : Type@{j}} (PB : Param2b0.Rel@{j} B B') : 74 | Map2b.Has@{k} (R_arrow PA PB). 75 | Proof. 76 | exists (Map1.map@{k} _ (Map1_arrow PA PB)). 77 | move=> f f' /= fR; apply path_forall => a'. 78 | by apply (R_in_map PB); apply fR; apply (comap_in_R PA). 79 | Defined. 80 | 81 | (* (03, 30) + funext -> 30 *) 82 | Definition Map3_arrow@{i j k} `{Funext} 83 | {A A' : Type@{i}} (PA : Param03.Rel@{i} A A') 84 | {B B' : Type@{j}} (PB : Param30.Rel@{j} B B') : 85 | Map3.Has@{k} (R_arrow PA PB). 86 | Proof. 87 | exists (Map1.map@{k} _ (Map1_arrow PA PB)). 88 | - exact: (Map2a.map_in_R _ (Map2a_arrow PA PB)). 89 | - move=> f f' /= fR; apply path_arrow => a'. 90 | by apply (R_in_map PB); apply fR; apply (comap_in_R PA). 91 | Defined. 92 | 93 | (* (04, 40) + funext -> 40 *) 94 | Definition Map4_arrow@{i j k} `{Funext} 95 | {A A' : Type@{i}} (PA : Param04.Rel@{i} A A') 96 | {B B' : Type@{j}} (PB : Param40.Rel@{j} B B') : 97 | Map4.Has@{k} (R_arrow PA PB). 98 | Proof. 99 | exists 100 | (Map1.map@{k} _ (Map1_arrow PA PB)) 101 | (Map2a.map_in_R _ (Map2a_arrow PA PB)) 102 | (Map2b.R_in_map _ (Map2b_arrow PA PB)). 103 | (***) 104 | move=> f f' fR /=. 105 | apply path_forall@{i k k} => a. 106 | apply path_forall@{i k k} => a'. 107 | apply path_arrow@{i k k} => aR /=. 108 | rewrite -[in X in _ = X](R_in_comapK PA a' a aR). 109 | set t := (R_in_comap PA a' a aR). 110 | dependent inversion t. 111 | rewrite transport_apD10 /=. 112 | rewrite apD10_path_forall_cancel/=. 113 | rewrite <- (R_in_mapK PB). 114 | set u := (R_in_map _ _ _ _). 115 | by dependent inversion u. 116 | Defined. 117 | 118 | (* Param_arrowMN : forall A A' AR B B' BR, ParamMN.Rel (A -> B) (A' -> B') *) 119 | 120 | Elpi Accumulate File param_arrow_generation. 121 | Elpi Query lp:{{ 122 | coq.univ.new Ui, 123 | coq.univ.variable Ui Li, 124 | coq.univ.new Uj, 125 | coq.univ.variable Uj Lj, 126 | coq.univ.alg-max Ui Uj Uk, 127 | % cannot have only 2 binders in the declaration because this line creates a fresh level: 128 | coq.univ.variable Uk Lk, 129 | map-class.all-of-kind all Classes, 130 | std.forall Classes (m\ 131 | std.forall Classes (n\ 132 | generate-param-arrow (pc m n) Ui Uj Li Lj Lk 133 | ) 134 | ). 135 | }}. 136 | -------------------------------------------------------------------------------- /hott/Param_forall.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import ssreflect. 16 | Require Import Stdlib Hierarchy Database Param_lemmas. 17 | 18 | From Trocq.Elpi Extra Dependency "util-rocq.elpi" as util_rocq. 19 | From Trocq.Elpi Extra Dependency "param-class-util.elpi" as param_class_util. 20 | From Trocq.Elpi.generation Extra Dependency "param-forall.elpi" as param_forall_generation. 21 | 22 | Set Universe Polymorphism. 23 | Unset Universe Minimization ToSet. 24 | 25 | Local Open Scope param_scope. 26 | 27 | Elpi Command genparamforall. 28 | Elpi Accumulate Db trocq.db. 29 | Elpi Accumulate File util_rocq. 30 | Elpi Accumulate File param_class_util. 31 | 32 | 33 | Definition R_forall@{i j} 34 | {A A' : Type@{i}} (PA : Param00.Rel@{i} A A') 35 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 36 | (PB : forall (a : A) (a' : A'), PA a a' -> Param00.Rel@{j} (B a) (B' a')) := 37 | fun f f' => forall a a' aR, (PB a a' aR) (f a) (f' a'). 38 | 39 | (* MapN for forall *) 40 | 41 | (* (00, 00) -> 00 *) 42 | Definition Map0_forall@{i j k | i <= k, j <= k} 43 | {A A' : Type@{i}} (PA : Param00.Rel@{i} A A') 44 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 45 | (PB : forall (a : A) (a' : A'), PA a a' -> Param00.Rel@{j} (B a) (B' a')) : 46 | Map0.Has@{k} (R_forall@{i j} PA PB). 47 | Proof. constructor. Defined. 48 | 49 | (* (02a, 10) -> 1 *) 50 | Definition Map1_forall@{i j k} 51 | {A A' : Type@{i}} (PA : Param02a.Rel@{i} A A') 52 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 53 | (PB : forall (a : A) (a' : A'), PA a a' -> Param10.Rel@{j} (B a) (B' a')) : 54 | Map1.Has@{k} (R_forall@{i j} PA PB). 55 | Proof. 56 | constructor. 57 | exact (fun f a' => map (PB _ _ (comap_in_R _ _ _ 1)) (f (comap PA a'))). 58 | Defined. 59 | 60 | (* (04, 2a0) -> 2a0 *) 61 | Definition Map2a_forall@{i j k} 62 | {A A' : Type@{i}} (PA : Param04.Rel@{i} A A') 63 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 64 | (PB : forall (a : A) (a' : A'), PA a a' -> Param2a0.Rel@{j} (B a) (B' a')) : 65 | Map2a.Has@{k} (R_forall@{i j} PA PB). 66 | Proof. 67 | exists (Map1.map@{k} _ (Map1_forall@{i j k} PA PB)). 68 | move=> f f' /= e a a' aR; apply (map_in_R@{j} (PB _ _ _)). 69 | elim/(ind_comap PA): _ aR / _. 70 | exact: (ap (fun f => f a') e). 71 | Defined. 72 | 73 | (* (02a, 2b0) + funext -> 2b0 *) 74 | Definition Map2b_forall@{i j k} `{Funext} 75 | {A A' : Type@{i}} (PA : Param02a.Rel@{i} A A') 76 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 77 | (PB : forall (a : A) (a' : A'), PA a a' -> Param2b0.Rel@{j} (B a) (B' a')) : 78 | Map2b.Has@{k} (R_forall@{i j} PA PB). 79 | Proof. 80 | exists (Map1.map@{k} _ (Map1_forall PA PB)). 81 | - move=> f f' fR; apply path_forall => a'. 82 | apply (R_in_map (PB _ _ _)); exact: fR. 83 | Defined. 84 | 85 | (* (04, 30) + funext -> 30 *) 86 | Definition Map3_forall@{i j k} `{Funext} 87 | {A A' : Type@{i}} (PA : Param04.Rel@{i} A A') 88 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 89 | (PB : forall (a : A) (a' : A'), PA a a' -> Param30.Rel@{j} (B a) (B' a')) : 90 | Map3.Has@{k} (R_forall@{i j} PA PB). 91 | Proof. 92 | exists (Map1.map@{k} _ (Map1_forall PA PB)). 93 | - exact: (Map2a.map_in_R _ (Map2a_forall PA PB)). 94 | - move=> f f' fR; apply path_forall => a'. 95 | apply (R_in_map (PB _ _ _)); exact: fR. 96 | Defined. 97 | 98 | Lemma ap_path_forall `{Funext} X Y (f g : forall x : X, Y x) x (e : f == g): 99 | ap (fun f => f x) (path_forall f g e) = e x. 100 | Proof. 101 | move: e; apply (equiv_ind apD10). 102 | case. 103 | rewrite Forall.eta_path_forall //. 104 | Qed. 105 | 106 | (* (04, 40) + funext -> 40 *) 107 | Definition Map4_forall@{i j k} `{Funext} 108 | {A A' : Type@{i}} (PA : Param04.Rel@{i} A A') 109 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 110 | (PB : forall (a : A) (a' : A'), PA a a' -> Param40.Rel@{j} (B a) (B' a')) : 111 | Map4.Has@{k} (R_forall@{i j} PA PB). 112 | Proof. 113 | exists 114 | (Map1.map@{k} _ (Map1_forall PA PB)) 115 | (Map3.map_in_R _ (Map3_forall PA PB)) 116 | (Map3.R_in_map _ (Map3_forall PA PB)). 117 | move=> f f' fR /=. 118 | apply path_forall@{i k k} => a. 119 | apply path_forall@{i k k} => a'. 120 | apply path_forall => aR. 121 | elim/(ind_comapP PA): _ => {a aR}. 122 | rewrite ap_path_forall. 123 | by elim/(ind_map (PB (comap PA a') a' (comap_in_R PA a' (comap PA a') 1))): _ _ / _. 124 | Qed. 125 | 126 | (* Param_forallMN : forall A A' AR B B' BR, 127 | ParamMN.Rel (forall a, B a) (forall a', B' a') *) 128 | 129 | Elpi Accumulate File param_forall_generation. 130 | Elpi Query lp:{{ 131 | coq.univ.new Ui, 132 | coq.univ.variable Ui Li, 133 | coq.univ.new Uj, 134 | coq.univ.variable Uj Lj, 135 | coq.univ.alg-max Ui Uj Uk, 136 | % cannot have only 2 binders in the declaration because this line creates a fresh level: 137 | coq.univ.variable Uk Lk, 138 | map-class.all-of-kind all Classes, 139 | std.forall Classes (m\ 140 | std.forall Classes (n\ 141 | generate-param-forall (pc m n) Ui Uj Li Lj Lk 142 | ) 143 | ). 144 | }}. 145 | -------------------------------------------------------------------------------- /hott/Stdlib.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From HoTT Require Export HoTT. 15 | From Trocq Require Export HoTT_additions. 16 | 17 | Module HoTTNotations. 18 | (* Stub for compatibility with stdlib version *) 19 | End HoTTNotations. 20 | -------------------------------------------------------------------------------- /hott/_CoqProject: -------------------------------------------------------------------------------- 1 | -arg -noinit 2 | -arg -indices-matter 3 | -arg -w -arg +elpi.typechecker 4 | 5 | -R . Trocq 6 | -R ../elpi/ Trocq.Elpi 7 | 8 | Common.v 9 | Hierarchy.v 10 | HoTT_additions.v 11 | Optimality.v 12 | Param.v 13 | Param_Type.v 14 | Param_arrow.v 15 | Param_forall.v 16 | Param_lemmas.v 17 | Stdlib.v 18 | generic/Database.v 19 | generic/Param_Empty.v 20 | generic/Param_bool.v 21 | generic/Param_list.v 22 | generic/Param_nat.v 23 | generic/Param_option.v 24 | generic/Param_paths.v 25 | generic/Param_prod.v 26 | generic/Param_sigma.v 27 | generic/Param_sum.v 28 | generic/Param_trans.v 29 | generic/Param_vector.v 30 | generic/Trocq.v 31 | generic/Vernac.v 32 | -------------------------------------------------------------------------------- /hott/generic/Database.v: -------------------------------------------------------------------------------- 1 | ../../generic/Database.v -------------------------------------------------------------------------------- /hott/generic/Param_Empty.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_Empty.v -------------------------------------------------------------------------------- /hott/generic/Param_bool.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_bool.v -------------------------------------------------------------------------------- /hott/generic/Param_list.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_list.v -------------------------------------------------------------------------------- /hott/generic/Param_nat.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_nat.v -------------------------------------------------------------------------------- /hott/generic/Param_option.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_option.v -------------------------------------------------------------------------------- /hott/generic/Param_paths.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_paths.v -------------------------------------------------------------------------------- /hott/generic/Param_prod.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_prod.v -------------------------------------------------------------------------------- /hott/generic/Param_sigma.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_sigma.v -------------------------------------------------------------------------------- /hott/generic/Param_sum.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_sum.v -------------------------------------------------------------------------------- /hott/generic/Param_trans.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_trans.v -------------------------------------------------------------------------------- /hott/generic/Param_vector.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_vector.v -------------------------------------------------------------------------------- /hott/generic/Trocq.v: -------------------------------------------------------------------------------- 1 | ../../generic/Trocq.v -------------------------------------------------------------------------------- /hott/generic/Vernac.v: -------------------------------------------------------------------------------- 1 | ../../generic/Vernac.v -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | fullname: Trocq 3 | shortname: trocq 4 | organization: coq-community 5 | community: true 6 | action: false 7 | coqdoc: false 8 | doi: 10.5281/zenodo.10492403 9 | 10 | synopsis: >- 11 | A modular parametricity plugin for proof transfer in Coq 12 | 13 | description: |- 14 | Trocq is a modular parametricity plugin for Coq. It can be used to 15 | achieve proof transfer by both translating a user goal into another, 16 | related, variant, and computing a proof that proves the corresponding implication. 17 | 18 | The plugin features a hierarchy of structures on relations, whose 19 | instances are computed from registered user-defined proof via 20 | parametricity. This hierarchy ranges from structure-less relations 21 | to an original formulation of type equivalence. The resulting 22 | framework generalizes [raw 23 | parametricity](https://arxiv.org/abs/1209.6336), [univalent 24 | parametricity](https://doi.org/10.1145/3429979) and 25 | [CoqEAL](https://github.com/coq-community/coqeal), and includes them 26 | in a unified framework. 27 | 28 | The plugin computes a parametricity translation "à la carte", by 29 | performing a fine-grained analysis of the requires properties for a 30 | given proof of relatedness. In particular, it is able to prove 31 | implications without resorting to full-blown type equivalence, 32 | allowing this way to perform proof transfer without necessarily 33 | pulling in the univalence axiom. 34 | 35 | The plugin is implemented in Coq-Elpi and the code of the 36 | parametricity translation is fairly close to a pen-and-paper 37 | sequent-style presentation. 38 | 39 | publications: 40 | - pub_url: https://hal.science/hal-04177913/document 41 | pub_title: 'Trocq: Proof Transfer for Free, With or Without Univalence' 42 | 43 | authors: 44 | - name: Cyril Cohen 45 | initial: true 46 | - name: Enzo Crance 47 | initial: true 48 | - name: Lucie Lahaye 49 | initial: false 50 | - name: Assia Mahboubi 51 | initial: true 52 | 53 | maintainers: 54 | - name: Cyril Cohen 55 | nickname: CohenCyril 56 | - name: Enzo Crance 57 | nickname: ecranceMERCE 58 | - name: Lucie Lahaye 59 | nickname: lweqx 60 | - name: Assia Mahboubi 61 | nickname: amahboubi 62 | 63 | opam-file-maintainer: Enzo Crance 64 | 65 | opam-file-version: dev 66 | 67 | license: 68 | fullname: GNU Lesser General Public License v3.0 69 | identifier: LGPL-3.0-or-later 70 | file: LICENSE 71 | 72 | supported_coq_versions: 73 | text: "8.20, 9.0" 74 | opam: '{>= "8.20" & < "9.1"}' 75 | 76 | tested_coq_opam_versions: 77 | - version: '8.20, 9.0' 78 | 79 | dependencies: 80 | - opam: 81 | name: coq-elpi 82 | version: '{= "2.5.2"}' 83 | description: |- 84 | [Coq-Elpi](https://github.com/LPCIC/coq-elpi) 85 | 86 | namespace: Trocq 87 | 88 | keywords: 89 | - name: automation 90 | - name: elpi 91 | - name: proof transfer 92 | - name: isomorphism 93 | - name: univalence 94 | - name: parametricity 95 | 96 | categories: 97 | - name: Computer Science/Decision Procedures and Certified Algorithms/Decision procedures 98 | - name: Miscellaneous/Coq Extensions 99 | 100 | build: |- 101 | ## Building and installation instructions 102 | 103 | Trocq is still a prototype. It is not yet packaged in Opam or Nix. 104 | 105 | There are however three ways to experiment with it, all documented 106 | in the [INSTALL.md file](INSTALL.md). 107 | 108 | documentation: |- 109 | ## Documentation 110 | 111 | See the [tutorial](artifact-doc/TUTORIAL.md) for concrete use cases. 112 | 113 | In short, the plugin provides a tactic: 114 | - `trocq` (without arguments) which attempts to run a translation on 115 | a given goal, using the information provided by the user with the 116 | commands described below. 117 | - `trocq R1 R2 ...` which works similarly to its argumentless counterpart 118 | except that it also uses translations associated to the relations `R1`, 119 | `R2`... ; see below regarding how to associated translations to a relation. 120 | 121 | And four commands: 122 | - `Trocq Use t` to use a translation `t` during the subsequent calls 123 | to the tactic `trocq`. 124 | - `Trocq Register Univalence u` to declare a univalence axiom `u`. 125 | - `Trocq Register Funext fe` to declare a function extensionality 126 | axiom `fe`. 127 | - `Trocq RelatedWith R t1 t2 ...` to associate `t1`, `t2`, ... to `R`. 128 | Subsequent calls to `trocq R` will be able to use the translations `t1`, 129 | `t2`, ... 130 | - `Trocq Logging "off"|"info"|"debug"|"trace"` to set the verbosity level. 131 | 132 | ## ESOP 2024 artifact documentation 133 | 134 | The ESOP 2024 artifact documentation files can be found in the `artifact-doc` directory, except for `INSTALL.md` that can be found in the current directory. 135 | --- 136 | -------------------------------------------------------------------------------- /std/Common.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | Require Import ssreflect. 15 | From Trocq Require Export Stdlib Hierarchy. 16 | 17 | Set Universe Polymorphism. 18 | 19 | Import HoTTNotations. 20 | 21 | Definition graph@{i} {A B : Type@{i}} (f : A -> B) := paths o f. 22 | 23 | Module Fun. 24 | Section Fun. 25 | Universe i. 26 | Context {A B : Type@{i}} (f : A -> B) (g : B -> A). 27 | Definition toParam : Param40.Rel@{i} A B := 28 | @Param40.BuildRel A B (graph f) 29 | (@Map4.BuildHas@{i} _ _ _ _ 30 | (fun _ _ => idmap) (fun _ _ => idmap) (fun _ _ _ => 1%path)) 31 | (@Map0.BuildHas@{i} _ _ _). 32 | 33 | Definition toParamSym : Param04.Rel@{i} A B := 34 | @Param04.BuildRel A B (sym_rel (graph g)) 35 | (@Map0.BuildHas@{i} _ _ _) 36 | (@Map4.BuildHas@{i} _ _ _ g (fun _ _ => idmap) (fun _ _ => idmap) 37 | (fun _ _ _ => 1%path)). 38 | End Fun. 39 | End Fun. 40 | 41 | Module SplitInj. 42 | Section SplitInj. 43 | Universe i. 44 | Context {A B : Type@{i}}. 45 | Record type@{} := Build { 46 | section :> A -> B; 47 | retract : B -> A; 48 | sectionK : forall x, retract (section x) = x 49 | }. 50 | 51 | Definition fromParam@{} (R : Param2a2b.Rel@{i} A B) := {| 52 | section := map R; 53 | retract := comap R; 54 | sectionK x := R_in_comap R _ _ (map_in_R R _ _ 1%path) 55 | |}. 56 | 57 | Section to. 58 | Variable (f : type). 59 | 60 | Let section_in_retract b a (e : f a = b) : retract f b = a := 61 | transport (fun x => retract f x = a) e (sectionK f a). 62 | 63 | Definition toParam@{} : Param42b.Rel@{i} A B := 64 | @Param42b.BuildRel A B (graph f) 65 | (@Map4.BuildHas@{i} _ _ _ _ (fun _ _ => idmap) (fun _ _ => idmap) 66 | (fun _ _ _ => 1%path)) 67 | (@Map2b.BuildHas@{i} _ _ _ _ section_in_retract). 68 | 69 | Definition toParamSym@{} : Param2b4.Rel@{i} B A := 70 | @Param2b4.BuildRel B A (sym_rel (graph f)) 71 | (@Map2b.BuildHas@{i} _ _ _ _ section_in_retract) 72 | (@Map4.BuildHas@{i} _ _ _ _ (fun _ _ => idmap) (fun _ _ => idmap) 73 | (fun _ _ _ => 1%path)). 74 | 75 | End to. 76 | 77 | End SplitInj. 78 | End SplitInj. 79 | Arguments SplitInj.Build {A B section retract}. 80 | 81 | Module SplitSurj. 82 | Section SplitSurj. 83 | Universe i. 84 | Context {A B : Type@{i}}. 85 | Record type := Build { 86 | retract :> A -> B; 87 | section : B -> A; 88 | sectionK : forall x, retract (section x) = x 89 | }. 90 | 91 | Definition fromParam@{} (R : Param2b2a.Rel@{i} A B) := {| 92 | retract := map R; 93 | section := comap R; 94 | sectionK x := R_in_map R (comap R x) x (comap_in_R R x (comap R x) 1%path) 95 | |}. 96 | 97 | Section to. 98 | Context (f : type). 99 | 100 | Let section_in_retract b a (e : section f b = a) : f a = b := 101 | transport (fun x => f x = b) e (sectionK f b). 102 | 103 | Definition toParam@{} : Param42a.Rel@{i} A B := 104 | @Param42a.BuildRel A B (graph f) 105 | (@Map4.BuildHas@{i} _ _ _ _ (fun _ _ => idmap) (fun _ _ => idmap) 106 | (fun _ _ _ => 1%path)) 107 | (@Map2a.BuildHas@{i} _ _ _ _ section_in_retract). 108 | 109 | Definition toParamSym@{} : Param2a4.Rel@{i} B A := 110 | @Param2a4.BuildRel B A (sym_rel (graph f)) 111 | (@Map2a.BuildHas@{i} _ _ _ _ (section_in_retract)) 112 | (@Map4.BuildHas@{i} _ _ _ _ (fun _ _ => idmap) (fun _ _ => idmap) 113 | (fun _ _ _ => 1%path)). 114 | 115 | End to. 116 | 117 | End SplitSurj. 118 | End SplitSurj. 119 | Arguments SplitSurj.Build {A B retract section}. 120 | 121 | Module Iso. 122 | Section Iso. 123 | Universe i. 124 | Context {A B : Type@{i}}. 125 | Record type@{} := Build { 126 | map :> A -> B; 127 | comap : B -> A; 128 | mapK : forall x, comap (map x) = x; 129 | comapK : forall x, map (comap x) = x 130 | }. 131 | 132 | Section to. 133 | Variable (f : type). 134 | 135 | Let mapK' x : comap f (f x) = x := 136 | ap (comap f) (ap f (mapK f x)^) @ ap (comap f) (comapK f _) @ mapK f x. 137 | 138 | Let comap_in_map b a (e : comap f b = a) : f a = b := 139 | ap f e^ @ comapK f b. 140 | 141 | Let map_in_comap b a (e : f a = b) : comap f b = a := 142 | ap (comap f) e^ @ mapK' a. 143 | 144 | Let map_in_comapK b a (e : f a = b) : 145 | comap_in_map b a (map_in_comap b a e) = e. 146 | Proof. 147 | rewrite /map_in_comap /comap_in_map /mapK' /=. 148 | dependent inversion e as [H] => {H}. 149 | rewrite concat_1p eq_trans_sym_distr ap_pp !concat_pp_p. 150 | rewrite [ap f (mapK f a)^]ap_V. 151 | set p1 := ap f _. set p2 := comapK _ _. 152 | rewrite eq_trans_sym_distr. 153 | rewrite -2!ap_V inv_V -ap_pp -ap_compose. 154 | set i := (X in ap X _). 155 | rewrite concat_A1p. 156 | by rewrite -concat_pp_p concat_pV concat_1p concat_Vp. 157 | Defined. 158 | 159 | Definition toParam@{} : Param44.Rel@{i} A B := 160 | @Param44.BuildRel A B (graph f) 161 | (@Map4.BuildHas@{i} _ _ _ _ (fun _ _ => idmap) (fun _ _ => idmap) 162 | (fun _ _ _ => 1%path)) 163 | (@Map4.BuildHas@{i} _ _ _ _ comap_in_map map_in_comap map_in_comapK). 164 | 165 | Definition toParamSym@{} : Param44.Rel@{i} B A := 166 | @Param44.BuildRel B A (sym_rel (graph f)) 167 | (@Map4.BuildHas@{i} _ _ _ _ comap_in_map map_in_comap map_in_comapK) 168 | (@Map4.BuildHas@{i} _ _ _ _ (fun _ _ => idmap) (fun _ _ => idmap) 169 | (fun _ _ _ => 1%path)). 170 | 171 | End to. 172 | 173 | End Iso. 174 | End Iso. 175 | Arguments Iso.Build {A B map comap}. 176 | -------------------------------------------------------------------------------- /std/HoTTNotations.v: -------------------------------------------------------------------------------- 1 | Reserved Notation "p ^" (at level 1, format "p '^'"). 2 | Reserved Notation "p @ q" (at level 20). 3 | Reserved Notation "p @@ q" (at level 20). 4 | Reserved Notation "p @' q" (at level 21, left associativity, 5 | format "'[v' p '/' '@'' q ']'"). 6 | Reserved Notation "f == g" (at level 70, no associativity). 7 | Reserved Notation "g 'o' f" (at level 40, left associativity). 8 | Reserved Notation "x .1" (at level 1, left associativity, format "x '.1'"). 9 | Reserved Notation "x .2" (at level 1, left associativity, format "x '.2'"). 10 | Reserved Notation "A <=> B" (at level 70, no associativity, format "A <=> B"). 11 | Reserved Notation "A <--> B" (at level 70). 12 | Reserved Notation "A <->> B" (at level 70). 13 | Reserved Notation "n .+1" (at level 2, left associativity, format "n .+1"). 14 | Reserved Notation "n .+2" (at level 2, left associativity, format "n .+2"). 15 | Reserved Notation "n .+3" (at level 2, left associativity, format "n .+3"). 16 | Reserved Notation "n .+4" (at level 2, left associativity, format "n .+4"). 17 | Reserved Notation "n .+5" (at level 2, left associativity, format "n .+5"). 18 | Reserved Notation "n '.-1'" (at level 2, left associativity, format "n .-1"). 19 | Reserved Notation "n '.-2'" (at level 2, left associativity, format "n .-2"). 20 | Reserved Notation "m +2+ n" (at level 50, left associativity). 21 | Reserved Infix "mod" (at level 40, no associativity). 22 | Reserved Notation "p ~ 1" (at level 7, left associativity, format "p '~' '1'"). 23 | Reserved Notation "p ~ 0" (at level 7, left associativity, format "p '~' '0'"). 24 | 25 | Declare Scope fibration_scope. 26 | Declare Scope path_scope. 27 | Delimit Scope path_scope with path. 28 | 29 | (* compatibility layer with HoTT *) 30 | Open Scope fibration_scope. 31 | Open Scope path_scope. 32 | 33 | 34 | Notation pr1 := projT1. 35 | Notation pr2 := projT2. 36 | 37 | Notation paths := eq. 38 | Notation "x = y" := (Logic.eq x y) : type_scope. 39 | 40 | Notation idpath := eq_refl. 41 | Notation inverse := eq_sym. 42 | Notation concat := eq_trans. 43 | Notation idmap := (fun x => x). 44 | Notation Unit := unit. 45 | Notation none := None. 46 | Notation Bool := bool. 47 | Notation Empty := False. 48 | Notation "f == g" := (forall x, f x = g x). 49 | Notation "g 'o' f" := ((fun g0 f0 x => g0 (f0 x)) g f). 50 | 51 | Notation "( x ; y )" := (existT _ x y) : fibration_scope. 52 | Notation "x .1" := (pr1 x) : fibration_scope. 53 | Notation "x .2" := (pr2 x) : fibration_scope. 54 | Notation "A <--> B" := ((A -> B) * (B -> A))%type : fibration_scope. 55 | Notation "A <->> B" := {f : A -> B & { g : B -> A & forall x, g (f x) = x}} : fibration_scope. 56 | 57 | Notation "1" := idpath : path_scope. 58 | Notation "e ^" := (eq_sym e%path) : path_scope. 59 | Notation "p @ q" := (eq_trans p q) : path_scope. 60 | -------------------------------------------------------------------------------- /std/Param.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import ssreflect. 16 | Require Export Database. 17 | Require Import Hierarchy. 18 | Require Export Param_Type Param_arrow Param_forall. 19 | 20 | From Trocq.Elpi Extra Dependency "annot.elpi" as annot. 21 | From Trocq.Elpi Extra Dependency "util-rocq.elpi" as util_rocq. 22 | From Trocq.Elpi Extra Dependency "class.elpi" as class. 23 | From Trocq.Elpi Extra Dependency "param-class-util.elpi" as param_class_util. 24 | From Trocq.Elpi Extra Dependency "param.elpi" as param. 25 | From Trocq.Elpi.constraints Extra Dependency "simple-graph.elpi" as simple_graph. 26 | From Trocq.Elpi.constraints Extra Dependency "constraint-graph.elpi" as constraint_graph. 27 | From Trocq.Elpi.constraints Extra Dependency "constraints.elpi" as constraints. 28 | From Trocq.Elpi.constraints Extra Dependency "constraints-impl.elpi" as constraints_impl. 29 | From Trocq.Elpi.generation Extra Dependency "pparam-type.elpi" as pparam_type_generation. 30 | From Trocq.Elpi Extra Dependency "tactic.elpi" as tactic. 31 | 32 | Set Universe Polymorphism. 33 | Unset Universe Minimization ToSet. 34 | 35 | Elpi Command genpparam. 36 | Elpi Accumulate Db trocq.db. 37 | Elpi Accumulate File class. 38 | 39 | Elpi Command genpparamtype. 40 | Elpi Accumulate Db trocq.db. 41 | Elpi Accumulate File class. 42 | Elpi Accumulate File pparam_type_generation. 43 | 44 | Elpi Query lp:{{ 45 | coq.univ.new U, 46 | coq.univ.variable U L, 47 | coq.univ.alg-super U U1, 48 | coq.univ.variable U1 L1, 49 | map-class.all-of-kind low Classes1, 50 | % first the ones where the arguments matter 51 | std.forall Classes1 (m\ 52 | std.forall Classes1 (n\ 53 | generate-pparam-type L L1 (pc m n) 54 | ) 55 | ). 56 | }}. 57 | 58 | Elpi Tactic trocq. 59 | Elpi Accumulate Db trocq.db. 60 | Elpi Accumulate File class. 61 | Elpi Accumulate File simple_graph. 62 | Elpi Accumulate File constraints. 63 | Elpi Accumulate File annot. 64 | Elpi Accumulate File constraint_graph. 65 | Elpi Accumulate File constraints_impl. 66 | Elpi Accumulate File param_class_util. 67 | Elpi Accumulate File param. 68 | Elpi Accumulate File util_rocq. 69 | Elpi Accumulate File tactic. 70 | 71 | Tactic Notation "trocq" ident_list(l) := elpi trocq ltac_string_list:(l). 72 | -------------------------------------------------------------------------------- /std/Param_Prop.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import ssreflect. 16 | Require Import Stdlib Hierarchy Database. 17 | 18 | From Trocq.Elpi Extra Dependency "class.elpi" as class. 19 | From Trocq.Elpi.generation Extra Dependency "param-prop.elpi" as param_prop_generation. 20 | 21 | Set Universe Polymorphism. 22 | Unset Universe Minimization ToSet. 23 | 24 | Local Open Scope param_scope. 25 | 26 | (* generate MapM_PropNP@{i} : 27 | MapM.Has Prop@{i} Prop@{i} ParamNP.Rel@{i}, 28 | for all N P, for M = map2a and below (above, NP is always 44) 29 | + symmetry MapM_Prop_symNP *) 30 | 31 | Elpi Command genmapprop. 32 | Elpi Accumulate Db trocq.db. 33 | Elpi Accumulate File class. 34 | Elpi Accumulate File param_prop_generation. 35 | 36 | Elpi Query lp:{{ 37 | % cannot have only one binder in the declaration because this line creates a fresh level: 38 | map-class.all-of-kind all Classes, 39 | map-class.all-of-kind low LowClasses, 40 | std.forall LowClasses (m\ 41 | std.forall Classes (n\ 42 | std.forall Classes (p\ 43 | generate-map-prop m (pc n p) 44 | ) 45 | ) 46 | ). 47 | }}. 48 | -------------------------------------------------------------------------------- /std/Param_Type.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import Stdlib Hierarchy Database. 16 | 17 | From Trocq.Elpi Extra Dependency "class.elpi" as class. 18 | From Trocq.Elpi.generation Extra Dependency "param-type.elpi" as param_type_generation. 19 | 20 | Set Universe Polymorphism. 21 | Unset Universe Minimization ToSet. 22 | 23 | Local Open Scope param_scope. 24 | 25 | (* generate MapM_TypeNP@{i} : 26 | MapM.Has Type@{i} Type@{i} ParamNP.Rel@{i}, 27 | for all N P, for M = map2a and below (above, NP is always 44) 28 | + symmetry MapM_Type_symNP *) 29 | 30 | Elpi Command genmaptype. 31 | Elpi Accumulate Db trocq.db. 32 | Elpi Accumulate File class. 33 | Elpi Accumulate File param_type_generation. 34 | 35 | Elpi Query lp:{{ 36 | coq.univ.new U, 37 | coq.univ.variable U L, 38 | coq.univ.alg-super U U1, 39 | % cannot have only one binder in the declaration because this line creates a fresh level: 40 | coq.univ.variable U1 L1, 41 | map-class.all-of-kind all Classes, 42 | map-class.all-of-kind low LowClasses, 43 | std.forall LowClasses (m\ 44 | std.forall Classes (n\ 45 | std.forall Classes (p\ 46 | generate-map-type m (pc n p) U L L1 47 | ) 48 | ) 49 | ). 50 | }}. 51 | 52 | Elpi Command genparamtype. 53 | Elpi Accumulate Db trocq.db. 54 | Elpi Accumulate File class. 55 | Elpi Accumulate File param_type_generation. 56 | 57 | Elpi Query lp:{{ 58 | coq.univ.new U, 59 | coq.univ.variable U L, 60 | coq.univ.alg-super U U1, 61 | % cannot have only one binder in the declaration because this line creates a fresh level: 62 | coq.univ.variable U1 L1, 63 | map-class.all-of-kind all AllClasses, 64 | map-class.all-of-kind low Classes__, 65 | std.forall Classes__ (m\ 66 | std.forall Classes__ (n\ 67 | std.forall AllClasses (p\ 68 | std.forall AllClasses (q\ 69 | generate-param-type (pc m n) (pc p q) U L L1 70 | ) 71 | ) 72 | ) 73 | ). 74 | }}. 75 | -------------------------------------------------------------------------------- /std/Param_arrow.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import ssreflect. 16 | Require Import Stdlib Hierarchy Database Param_lemmas. 17 | 18 | From Trocq.Elpi Extra Dependency "util-rocq.elpi" as util_rocq. 19 | From Trocq.Elpi Extra Dependency "param-class-util.elpi" as param_class_util. 20 | From Trocq.Elpi.generation Extra Dependency "param-arrow.elpi" as param_arrow_generation. 21 | 22 | Set Universe Polymorphism. 23 | Unset Universe Minimization ToSet. 24 | 25 | Import HoTTNotations. 26 | Local Open Scope param_scope. 27 | 28 | Elpi Command genparamarrow. 29 | Elpi Accumulate Db trocq.db. 30 | Elpi Accumulate File util_rocq. 31 | Elpi Accumulate File param_class_util. 32 | 33 | (* relation for arrow *) 34 | 35 | Definition R_arrow@{i j} 36 | {A A' : Type@{i}} (PA : Param00.Rel@{i} A A') 37 | {B B' : Type@{j}} (PB : Param00.Rel@{j} B B') := 38 | fun f f' => forall a a', PA a a' -> PB (f a) (f' a'). 39 | 40 | (* MapN for arrow *) 41 | 42 | (* (00, 00) -> 00 *) 43 | Definition Map0_arrow@{i j k | i <= k, j <= k} 44 | {A A' : Type@{i}} (PA : Param00.Rel@{i} A A') 45 | {B B' : Type@{j}} (PB : Param00.Rel@{j} B B') : 46 | Map0.Has@{k} (R_arrow PA PB). 47 | Proof. exists. Defined. 48 | 49 | (* (01, 10) -> 10 *) 50 | Definition Map1_arrow@{i j k} 51 | {A A' : Type@{i}} (PA : Param01.Rel@{i} A A') 52 | {B B' : Type@{j}} (PB : Param10.Rel@{j} B B') : 53 | Map1.Has@{k} (R_arrow PA PB). 54 | Proof. 55 | exists; exact (fun f a' => map PB (f (comap PA a'))). 56 | Defined. 57 | 58 | (* (02b, 2a0) -> 2a0 *) 59 | Definition Map2a_arrow@{i j k} 60 | {A A' : Type@{i}} (PA : Param02b.Rel@{i} A A') 61 | {B B' : Type@{j}} (PB : Param2a0.Rel@{j} B B') : 62 | Map2a.Has@{k} (R_arrow PA PB). 63 | Proof. 64 | exists (Map1.map@{k} _ (Map1_arrow@{i j k} PA PB)). 65 | move=> f f' /= e a a' aR; apply (map_in_R@{j} PB). 66 | apply (transport@{j j} (fun t => _ = t a') e) => /=. 67 | by apply (transport@{j j} (fun t => _ = map _ (f t)) 68 | (R_in_comap@{i} PA _ _ aR)^). 69 | Defined. 70 | 71 | (* (02a, 2b0) + funext -> 2b0 *) 72 | Definition Map2b_arrow@{i j k} `{Funext} 73 | {A A' : Type@{i}} (PA : Param02a.Rel@{i} A A') 74 | {B B' : Type@{j}} (PB : Param2b0.Rel@{j} B B') : 75 | Map2b.Has@{k} (R_arrow PA PB). 76 | Proof. 77 | exists (Map1.map@{k} _ (Map1_arrow PA PB)). 78 | move=> f f' /= fR; apply path_forall => a'. 79 | by apply (R_in_map PB); apply fR; apply (comap_in_R PA). 80 | Defined. 81 | 82 | (* (03, 30) + funext -> 30 *) 83 | Definition Map3_arrow@{i j k} `{Funext} 84 | {A A' : Type@{i}} (PA : Param03.Rel@{i} A A') 85 | {B B' : Type@{j}} (PB : Param30.Rel@{j} B B') : 86 | Map3.Has@{k} (R_arrow PA PB). 87 | Proof. 88 | exists (Map1.map@{k} _ (Map1_arrow PA PB)). 89 | - exact: (Map2a.map_in_R _ (Map2a_arrow PA PB)). 90 | - move=> f f' /= fR; apply path_arrow => a'. 91 | by apply (R_in_map PB); apply fR; apply (comap_in_R PA). 92 | Defined. 93 | 94 | (* (04, 40) + funext -> 40 *) 95 | Definition Map4_arrow@{i j k} `{Funext} 96 | {A A' : Type@{i}} (PA : Param04.Rel@{i} A A') 97 | {B B' : Type@{j}} (PB : Param40.Rel@{j} B B') : 98 | Map4.Has@{k} (R_arrow PA PB). 99 | Proof. 100 | exists 101 | (Map1.map@{k} _ (Map1_arrow PA PB)) 102 | (Map2a.map_in_R _ (Map2a_arrow PA PB)) 103 | (Map2b.R_in_map _ (Map2b_arrow PA PB)). 104 | (***) 105 | move=> f f' fR /=. 106 | apply path_forall@{i k} => a. 107 | apply path_forall@{i k} => a'. 108 | apply path_arrow@{i k} => aR /=. 109 | rewrite -[in X in _ = X](R_in_comapK PA a' a aR). 110 | set t := (R_in_comap PA a' a aR). 111 | dependent inversion t. 112 | rewrite transport_apD10 /=. 113 | rewrite apD10_path_forall_cancel/=. 114 | rewrite <- (R_in_mapK PB). 115 | set u := (R_in_map _ _ _ _). 116 | by dependent inversion u. 117 | Defined. 118 | 119 | (* Param_arrowMN : forall A A' AR B B' BR, ParamMN.Rel (A -> B) (A' -> B') *) 120 | 121 | Elpi Accumulate File param_arrow_generation. 122 | Elpi Query lp:{{ 123 | coq.univ.new Ui, 124 | coq.univ.variable Ui Li, 125 | coq.univ.new Uj, 126 | coq.univ.variable Uj Lj, 127 | coq.univ.alg-max Ui Uj Uk, 128 | % cannot have only 2 binders in the declaration because this line creates a fresh level: 129 | coq.univ.variable Uk Lk, 130 | map-class.all-of-kind all Classes, 131 | std.forall Classes (m\ 132 | std.forall Classes (n\ 133 | generate-param-arrow (pc m n) Ui Uj Li Lj Lk 134 | ) 135 | ). 136 | }}. 137 | -------------------------------------------------------------------------------- /std/Param_forall.v: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* * Trocq *) 3 | (* _______ * Copyright (C) 2023 Inria & MERCE *) 4 | (* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) 5 | (* | |_ __ ___ ___ __ _ * Cyril Cohen *) 6 | (* | | '__/ _ \ / __/ _` | * Enzo Crance *) 7 | (* | | | | (_) | (_| (_| | * Assia Mahboubi *) 8 | (* |_|_| \___/ \___\__, | ************************************************) 9 | (* | | * This file is distributed under the terms of *) 10 | (* |_| * GNU Lesser General Public License Version 3 *) 11 | (* * see LICENSE file for the text of the license *) 12 | (*****************************************************************************) 13 | 14 | From elpi Require Import elpi. 15 | Require Import ssreflect. 16 | Require Import Stdlib Hierarchy Database Param_lemmas. 17 | 18 | From Trocq.Elpi Extra Dependency "util-rocq.elpi" as util_rocq. 19 | From Trocq.Elpi Extra Dependency "param-class-util.elpi" as param_class_util. 20 | From Trocq.Elpi.generation Extra Dependency "param-forall.elpi" as param_forall_generation. 21 | 22 | Set Universe Polymorphism. 23 | Unset Universe Minimization ToSet. 24 | 25 | Import HoTTNotations. 26 | Local Open Scope param_scope. 27 | 28 | Elpi Command genparamforall. 29 | Elpi Accumulate Db trocq.db. 30 | Elpi Accumulate File util_rocq. 31 | Elpi Accumulate File param_class_util. 32 | 33 | 34 | Definition R_forall@{i j} 35 | {A A' : Type@{i}} (PA : Param00.Rel@{i} A A') 36 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 37 | (PB : forall (a : A) (a' : A'), PA a a' -> Param00.Rel@{j} (B a) (B' a')) := 38 | fun f f' => forall a a' aR, (PB a a' aR) (f a) (f' a'). 39 | 40 | (* MapN for forall *) 41 | 42 | (* (00, 00) -> 00 *) 43 | Definition Map0_forall@{i j k | i <= k, j <= k} 44 | {A A' : Type@{i}} (PA : Param00.Rel@{i} A A') 45 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 46 | (PB : forall (a : A) (a' : A'), PA a a' -> Param00.Rel@{j} (B a) (B' a')) : 47 | Map0.Has@{k} (R_forall@{i j} PA PB). 48 | Proof. constructor. Defined. 49 | 50 | (* (02a, 10) -> 1 *) 51 | Definition Map1_forall@{i j k} 52 | {A A' : Type@{i}} (PA : Param02a.Rel@{i} A A') 53 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 54 | (PB : forall (a : A) (a' : A'), PA a a' -> Param10.Rel@{j} (B a) (B' a')) : 55 | Map1.Has@{k} (R_forall@{i j} PA PB). 56 | Proof. 57 | constructor. 58 | exact (fun f a' => map (PB _ _ (comap_in_R _ _ _ 1)) (f (comap PA a'))). 59 | Defined. 60 | 61 | (* (04, 2a0) -> 2a0 *) 62 | Definition Map2a_forall@{i j k} 63 | {A A' : Type@{i}} (PA : Param04.Rel@{i} A A') 64 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 65 | (PB : forall (a : A) (a' : A'), PA a a' -> Param2a0.Rel@{j} (B a) (B' a')) : 66 | Map2a.Has@{k} (R_forall@{i j} PA PB). 67 | Proof. 68 | exists (Map1.map@{k} _ (Map1_forall@{i j k} PA PB)). 69 | move=> f f' /= e a a' aR; apply (map_in_R@{j} (PB _ _ _)). 70 | elim/(ind_comap PA): _ aR / _. 71 | exact: (ap (fun f => f a') e). 72 | Defined. 73 | 74 | (* (02a, 2b0) + funext -> 2b0 *) 75 | Definition Map2b_forall@{i j k} `{Funext} 76 | {A A' : Type@{i}} (PA : Param02a.Rel@{i} A A') 77 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 78 | (PB : forall (a : A) (a' : A'), PA a a' -> Param2b0.Rel@{j} (B a) (B' a')) : 79 | Map2b.Has@{k} (R_forall@{i j} PA PB). 80 | Proof. 81 | exists (Map1.map@{k} _ (Map1_forall PA PB)). 82 | - move=> f f' fR; apply path_forall => a'. 83 | apply (R_in_map (PB _ _ _)); exact: fR. 84 | Defined. 85 | 86 | (* (04, 30) + funext -> 30 *) 87 | Definition Map3_forall@{i j k} `{Funext} 88 | {A A' : Type@{i}} (PA : Param04.Rel@{i} A A') 89 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 90 | (PB : forall (a : A) (a' : A'), PA a a' -> Param30.Rel@{j} (B a) (B' a')) : 91 | Map3.Has@{k} (R_forall@{i j} PA PB). 92 | Proof. 93 | exists (Map1.map@{k} _ (Map1_forall PA PB)). 94 | - exact: (Map2a.map_in_R _ (Map2a_forall PA PB)). 95 | - move=> f f' fR; apply path_forall => a'. 96 | apply (R_in_map (PB _ _ _)); exact: fR. 97 | Defined. 98 | 99 | Lemma ap_path_forall `{Funext} X Y (f g : forall x : X, Y x) x (e : f == g): 100 | ap (fun f => f x) (path_forall f g e) = e x. 101 | Proof. by rewrite -{2}(apD10_retr _ _ e). Qed. 102 | 103 | (* (04, 40) + funext -> 40 *) 104 | Definition Map4_forall@{i j k} `{Funext} 105 | {A A' : Type@{i}} (PA : Param04.Rel@{i} A A') 106 | {B : A -> Type@{j}} {B' : A' -> Type@{j}} 107 | (PB : forall (a : A) (a' : A'), PA a a' -> Param40.Rel@{j} (B a) (B' a')) : 108 | Map4.Has@{k} (R_forall@{i j} PA PB). 109 | Proof. 110 | exists 111 | (Map1.map@{k} _ (Map1_forall PA PB)) 112 | (Map3.map_in_R _ (Map3_forall PA PB)) 113 | (Map3.R_in_map _ (Map3_forall PA PB)). 114 | move=> f f' fR /=. 115 | apply path_forall@{i k} => a. 116 | apply path_forall@{i k} => a'. 117 | apply path_forall => aR. 118 | elim/(ind_comapP PA): _ => {a aR}. 119 | rewrite ap_path_forall. 120 | by elim/(ind_map (PB (comap PA a') a' (comap_in_R PA a' (comap PA a') 1))): _ _ / _. 121 | Qed. 122 | (* Param_forallMN : forall A A' AR B B' BR, 123 | ParamMN.Rel (forall a, B a) (forall a', B' a') *) 124 | 125 | Elpi Accumulate File param_forall_generation. 126 | Elpi Query lp:{{ 127 | coq.univ.new Ui, 128 | coq.univ.variable Ui Li, 129 | coq.univ.new Uj, 130 | coq.univ.variable Uj Lj, 131 | coq.univ.alg-max Ui Uj Uk, 132 | % cannot have only 2 binders in the declaration because this line creates a fresh level: 133 | coq.univ.variable Uk Lk, 134 | map-class.all-of-kind all Classes, 135 | std.forall Classes (m\ 136 | std.forall Classes (n\ 137 | generate-param-forall (pc m n) Ui Uj Li Lj Lk 138 | ) 139 | ). 140 | }}. 141 | -------------------------------------------------------------------------------- /std/_CoqProject: -------------------------------------------------------------------------------- 1 | -arg -indices-matter 2 | -arg -w -arg +elpi.typechecker 3 | 4 | -R . Trocq 5 | -R ../elpi/ Trocq.Elpi 6 | 7 | HoTTNotations.v 8 | Common.v 9 | Hierarchy.v 10 | Param.v 11 | Param_Prop.v 12 | Param_Type.v 13 | Param_arrow.v 14 | Param_forall.v 15 | Param_lemmas.v 16 | Stdlib.v 17 | generic/Database.v 18 | generic/Param_Empty.v 19 | generic/Param_bool.v 20 | generic/Param_list.v 21 | generic/Param_nat.v 22 | generic/Param_option.v 23 | generic/Param_paths.v 24 | generic/Param_prod.v 25 | generic/Param_sigma.v 26 | generic/Param_sum.v 27 | generic/Param_trans.v 28 | generic/Param_vector.v 29 | generic/Trocq.v 30 | generic/Vernac.v 31 | -------------------------------------------------------------------------------- /std/generic/Database.v: -------------------------------------------------------------------------------- 1 | ../../generic/Database.v -------------------------------------------------------------------------------- /std/generic/Param_Empty.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_Empty.v -------------------------------------------------------------------------------- /std/generic/Param_bool.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_bool.v -------------------------------------------------------------------------------- /std/generic/Param_list.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_list.v -------------------------------------------------------------------------------- /std/generic/Param_nat.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_nat.v -------------------------------------------------------------------------------- /std/generic/Param_option.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_option.v -------------------------------------------------------------------------------- /std/generic/Param_paths.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_paths.v -------------------------------------------------------------------------------- /std/generic/Param_prod.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_prod.v -------------------------------------------------------------------------------- /std/generic/Param_sigma.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_sigma.v -------------------------------------------------------------------------------- /std/generic/Param_sum.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_sum.v -------------------------------------------------------------------------------- /std/generic/Param_trans.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_trans.v -------------------------------------------------------------------------------- /std/generic/Param_vector.v: -------------------------------------------------------------------------------- 1 | ../../generic/Param_vector.v -------------------------------------------------------------------------------- /std/generic/Trocq.v: -------------------------------------------------------------------------------- 1 | ../../generic/Trocq.v -------------------------------------------------------------------------------- /std/generic/Vernac.v: -------------------------------------------------------------------------------- 1 | ../../generic/Vernac.v --------------------------------------------------------------------------------