├── .gitattributes ├── .github └── workflows │ └── metacoq.yml ├── .gitignore ├── AUTHORS ├── LICENSE ├── Makefile ├── Makefile.local ├── README.md ├── _CoqProject ├── coq-sniper.opam ├── docs ├── .nojekyll ├── README.md ├── _sidebar.md ├── alg.md ├── anon.md ├── decide.md ├── definitions.md ├── fix.md ├── gen.md ├── ho.md ├── hoeq.md ├── index.html ├── indrelprop.md ├── mono.md └── pm.md ├── elpi ├── eliminate_fix.elpi ├── higher_order.elpi ├── ref_elim_utils.elpi ├── subterms.elpi └── utilities.elpi ├── examples ├── example_ho.v └── examples.v ├── orchestrator ├── Sniper.v ├── filters.v ├── orchestrator.v ├── printer.v ├── run_tactic.v ├── simpleordo.v ├── tests │ └── tests.v ├── triggers.v └── triggers_tactics.v ├── tests └── tests.v └── theories ├── Transfos.v ├── add_compdecs.v ├── anonymous_functions.v ├── case_analysis.v ├── case_analysis_existentials.v ├── deciderel ├── add_hypothesis_on_parameters.v ├── compdec_plugin.v ├── examples.v ├── generate_fix.v ├── linearize_plugin.v └── proof_correctness.v ├── elimination_fixpoints.v ├── elimination_pattern_matching.v ├── expand.v ├── fold_local_def.v ├── higher_order.v ├── indrel.v ├── instantiate_state.v ├── instantiate_type.v ├── interpretation_algebraic_types.v ├── pattern_matching_goal.v ├── refinement_elimination.v ├── refinement_elimination_elpi.v ├── reflexivity.v ├── subterms.v ├── tree.v ├── unfold_in.v ├── unfold_reflexivity.v ├── utilities.v └── verit.v /.gitattributes: -------------------------------------------------------------------------------- 1 | *.elpi linguist-language=prolog 2 | Makefile linguist-detectable=false 3 | -------------------------------------------------------------------------------- /.github/workflows/metacoq.yml: -------------------------------------------------------------------------------- 1 | name: MetaCoq CI 2 | 3 | on: 4 | schedule: 5 | # Every week at sunday midnight 6 | - cron: '0 0 * * 0' 7 | # Enables manually running the workflow 8 | workflow_dispatch: 9 | 10 | permissions: 11 | contents: read 12 | 13 | jobs: 14 | build: 15 | runs-on: ubuntu-latest 16 | 17 | steps: 18 | - name: Checkout Metacoq Repository 19 | uses: actions/checkout@v3 20 | with: 21 | repository: metacoq/metacoq 22 | ref: main 23 | path: metacoq 24 | 25 | - name: Get Date of Last Commit 26 | id: get_last_commit_date 27 | run: | 28 | last_commit_date=$(cd metacoq && git log -1 --format=%cd --date=iso) 29 | echo "last_commit_date=$last_commit_date" >> $GITHUB_ENV 30 | 31 | - name: Check if Last Commit was Within Last Week 32 | id: check_commit_date 33 | run: | 34 | LAST_COMMIT_DATE=$(date -d "${{ env.last_commit_date }}" +%s) 35 | ONE_WEEK_AGO=$(date -d "1 week ago" +%s) 36 | if [ $LAST_COMMIT_DATE -gt $ONE_WEEK_AGO ]; then 37 | echo "recent_commit=true" >> $GITHUB_ENV 38 | else 39 | echo "recent_commit=false" >> $GITHUB_ENV 40 | fi 41 | 42 | - name: Checkout Sniper master 43 | if: env.recent_commit == 'true' 44 | uses: actions/checkout@v3 45 | with: 46 | ref: coq-master 47 | 48 | - name: Build Sniper 49 | if: env.recent_commit == 'true' 50 | uses: coq-community/docker-coq-action@v1 51 | with: 52 | coq_version: dev 53 | opam_file: 'coq-sniper.opam' 54 | custom_image: mattam82/metacoq:latest-coq-dev 55 | custom_script: | 56 | sudo chown -R coq:coq . 57 | opam update 58 | opam upgrade -y 59 | opam install . --deps-only -y 60 | make 61 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.d 2 | .*.aux 3 | *.vo 4 | *.vok 5 | *.vos 6 | *.glob 7 | .lia.cache 8 | Makefile.conf 9 | *~ 10 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Authors: 2 | Valentin Blot 3 | Louise Dubois de Prisque 4 | Chantal Keller 5 | Pierre Vial 6 | Tomaz Mascarenhas 7 | 8 | Institutes: 9 | Inria 10 | Université Paris-Saclay 11 | CNRS 12 | 13 | This work is funded by a Nomadic Labs-Inria collaboration. 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smtcoq/sniper/83afa3ef1817b69315faf29145a81ba898d2bcdb/LICENSE -------------------------------------------------------------------------------- /Makefile.local: -------------------------------------------------------------------------------- 1 | examples: examples/examples.v 2 | $(SHOW)COQC $< 3 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) 4 | 5 | tests: tests/tests.v 6 | $(SHOW)COQC $< 7 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) 8 | 9 | tests_triggers: orchestrator/tests/tests.v 10 | $(SHOW)COQC $< 11 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) 12 | 13 | test: examples tests tests_triggers 14 | 15 | clean:: 16 | rm -f examples/examples.glob examples/examples.vo examples/examples.vok examples/examples.vos tests/tests.glob tests/tests.vo tests/tests.vok tests/tests.vos benchs/*.glob benchs/*.vo benchs/*.vok benchs/*.vos 17 | 18 | .PHONY: examples tests 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Sniper 2 | 3 | `Sniper` is a Coq plugin that provides a new Coq tactic, `snipe`, that 4 | provides general proof automation. 5 | 6 | This plugin is an extension of [SMTCoq](https://smtcoq.github.io), a 7 | plugin to safely call external SMT solvers from Coq. `Sniper` extends 8 | SMTCoq by translating (a subset) of Coq goals into first-order logic 9 | before calling SMTCoq. 10 | 11 | The translation is implemented through a combination of modular, small 12 | transformations that independently eliminate specific aspects of Coq 13 | logic towards first-order logic. These small transformations are safe, 14 | either generating proof terms on the fly (*certifying* transformations) 15 | or being proved once and for all in Coq (*certified* transformations). A 16 | crucial transformation is given by the 17 | [Trakt](https://github.com/ecranceMERCE/trakt) plugin. 18 | 19 | This version is an experimental version using the Trakt plugin. 20 | 21 | 22 | ## Installation and use 23 | 24 | This part describes the steps required to try the `snipe` tactic. It can 25 | be used with Coq-8.17. 26 | 27 | You will need the following packages. The names are those for debian, please adapt as required for your distribution. 28 | - opam: for installing coqide, metacoq and smtcoq 29 | - pkg-config: required for creating an opam switch 30 | - libgtksourceview-3.0-dev: required by coqide 31 | - git: for installing smtcoq through opam 32 | - bison, flex: for compiling veriT 33 | 34 | If opam was not installed on your machine you have to initialize it (all the files are confined within ~/.opam): 35 | ``` 36 | opam init --bare --no-setup 37 | ``` 38 | 39 | It requires OCaml between 4.09 and 4.10: 40 | ``` 41 | opam switch create 4.09.1 42 | eval $(opam env) 43 | ``` 44 | 45 | You need to add two opam repositories: 46 | ``` 47 | opam repo add coq-released https://coq.inria.fr/opam/released 48 | opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev 49 | ``` 50 | 51 | Then simply install this version of `Sniper`: 52 | ``` 53 | opam install -y . 54 | ``` 55 | 56 | ### Installation of the automatic prover and use 57 | 58 | You also need the veriT SMT solver, using [these sources](https://www.lri.fr/~keller/Documents-recherche/Smtcoq/veriT9f48a98.tar.gz). 59 | Once unpacked, compilation of veriT is as follows: 60 | ``` 61 | cd veriT9f48a98 62 | ./configure 63 | make 64 | ``` 65 | 66 | We need the veriT binary to be in PATH in order for `Sniper` to use it: 67 | ``` 68 | export PATH="$PATH:$(pwd)" 69 | cd .. 70 | ``` 71 | 72 | ## Examples, tests and benchmarks 73 | 74 | Commented examples are available at ``examples.v``. 75 | 76 | ## License 77 | As an extension of SMTCoq, `Sniper` is released under the same license 78 | as SMTCoq: CeCILL-C. See the file LICENSE for details. 79 | 80 | 81 | ## Authors 82 | See the file [AUTHORS](https://github.com/smtcoq/sniper/blob/master/AUTHORS). 83 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | # -R ./orchestrator Sniper.orchestrator 2 | -R . Sniper 3 | # -Q ./elpi Sniper.elpi 4 | -docroot Sniper 5 | 6 | orchestrator/triggers.v 7 | orchestrator/filters.v 8 | orchestrator/triggers_tactics.v 9 | orchestrator/run_tactic.v 10 | orchestrator/printer.v 11 | orchestrator/orchestrator.v 12 | orchestrator/Sniper.v 13 | 14 | theories/utilities.v 15 | theories/indrel.v 16 | theories/reflexivity.v 17 | theories/unfold_reflexivity.v 18 | theories/unfold_in.v 19 | theories/expand.v 20 | theories/fold_local_def.v 21 | theories/elimination_fixpoints.v 22 | theories/elimination_pattern_matching.v 23 | theories/pattern_matching_goal.v 24 | theories/anonymous_functions.v 25 | theories/higher_order.v 26 | theories/instantiate_type.v 27 | theories/instantiate_state.v 28 | theories/interpretation_algebraic_types.v 29 | theories/case_analysis.v 30 | theories/case_analysis_existentials.v 31 | theories/tree.v 32 | theories/add_compdecs.v 33 | theories/verit.v 34 | theories/Transfos.v 35 | theories/refinement_elimination.v 36 | theories/refinement_elimination_elpi.v 37 | 38 | theories/deciderel/add_hypothesis_on_parameters.v 39 | theories/deciderel/compdec_plugin.v 40 | theories/deciderel/linearize_plugin.v 41 | theories/deciderel/generate_fix.v 42 | theories/deciderel/proof_correctness.v 43 | -------------------------------------------------------------------------------- /coq-sniper.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Chantal.Keller@lri.fr" 3 | homepage: "https://github.com/smtcoq/sniper" 4 | dev-repo: "git+https://github.com/smtcoq/sniper.git" 5 | bug-reports: "https://github.com/smtcoq/sniper/issues" 6 | authors: ["Valentin Blot " 7 | "Louise Dubois de Prisque " 8 | "Chantal Keller " 10 | "Tomaz Mascarenhas " 11 | ] 12 | license: "CECILL-C" 13 | build: [ 14 | [make "-j%{jobs}%"] 15 | ] 16 | install: [ 17 | [make "install"] 18 | ] 19 | depends: [ 20 | "coq" {>= "8.17" & < "8.18~"} 21 | "coq-metacoq-utils" {= "1.3+8.17"} 22 | "coq-metacoq-template" {= "1.3+8.17"} 23 | "elpi" 24 | "coq-trakt" 25 | "coq-elpi" 26 | "coq-smtcoq" 27 | ] 28 | pin-depends: [ 29 | [ "coq-smtcoq.dev" "git+https://github.com/smtcoq/smtcoq.git#with-trakt-coq-8.17" ] 30 | [ "coq-trakt.1.2" "git+https://github.com/ecranceMERCE/trakt.git#1.2" ] 31 | ] 32 | tags: [ 33 | "category:Computer Science/Decision Procedures and Certified Algorithms/Decision procedures" 34 | "category:Miscellaneous/Coq Extensions" 35 | "keyword: SMT" 36 | "keyword: automation" 37 | "logpath:Sniper" 38 | ] 39 | synopsis: "A Coq plugin for general proof automation" 40 | description: """ 41 | Sniper is a Coq plugin that provides a new Coq tactic, snipe, for general proof automation. 42 | 43 | This plugin is an extension of SMTCoq, a plugin to safely call external SMT solvers from Coq. Sniper extends SMTCoq by translating (a subset) of Coq goals into first-order logic before calling SMTCoq. 44 | 45 | The translation is implemented through a combination of modular, small transformations that independently eliminate specific aspects of Coq logic towards first-order logic. These small transformations are safe, either generating proof terms on the fly (certifying transformations) or being proved once and for all in Coq (certified transformations). 46 | """ 47 | url { 48 | src: "git+https://github.com/smtcoq/sniper.git#coq-8.17-with-trakt" 49 | } 50 | -------------------------------------------------------------------------------- /docs/.nojekyll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smtcoq/sniper/83afa3ef1817b69315faf29145a81ba898d2bcdb/docs/.nojekyll -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | # Sniper 2 | 3 | `Sniper` is a Coq plugin that provides a new Coq tactic, `snipe`, that 4 | provides general proof automation. 5 | 6 | This plugin can be seen as an extension of [SMTCoq](https://smtcoq.github.io), a 7 | plugin to safely call external SMT solvers from Coq. 8 | 9 | `Sniper` extends 10 | SMTCoq by translating (a subset) of Coq goals into first-order logic 11 | before calling SMTCoq. 12 | 13 | The translation is implemented through a combination of modular, small 14 | transformations that independently eliminate specific aspects of Coq 15 | logic towards first-order logic. These small transformations are safe, 16 | generating proof terms on the fly (*certifying* transformations). 17 | They could have been *certified* and we plan to also write or use transformations proven once and for all in `Sniper`, as both methods are compatible with the plugin. 18 | 19 | A 20 | crucial transformation but external to this repository is given by the 21 | [Trakt](https://ecrancemerce.github.io/trakt/#/) plugin. 22 | 23 | 24 | ## Installation and use 25 | 26 | This part describes the steps required to try the `snipe` tactic. 27 | 28 | 29 | You will need the following packages. The names are those for debian, please adapt as required for your distribution. 30 | - opam: for installing coqide, metacoq and smtcoq 31 | - pkg-config: required for creating an opam switch 32 | - libgtksourceview-3.0-dev: required by coqide 33 | - git: for installing smtcoq through opam 34 | - bison, flex: for compiling veriT 35 | 36 | If opam was not installed on your machine you have to initialize it (all the files are confined within ~/.opam): 37 | ``` 38 | opam init --bare --no-setup 39 | ``` 40 | 41 | It requires OCaml between 4.09 and 4.10: 42 | ``` 43 | opam switch create 4.09.1 44 | eval $(opam env) 45 | ``` 46 | 47 | You need to add two opam repositories: 48 | ``` 49 | opam repo add coq-released https://coq.inria.fr/opam/released 50 | opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev 51 | ``` 52 | 53 | Then simply install this version of `Sniper`: 54 | ``` 55 | opam install coq-sniper 56 | ``` 57 | 58 | ### Installation of the automatic prover and use 59 | 60 | You also need the veriT SMT solver, using [these sources](https://www.lri.fr/~keller/Documents-recherche/Smtcoq/veriT9f48a98.tar.gz). 61 | Once unpacked, compilation of veriT is as follows: 62 | ``` 63 | cd veriT9f48a98 64 | ./configure 65 | make 66 | ``` 67 | 68 | We need the veriT binary to be in PATH in order for `Sniper` to use it: 69 | ``` 70 | export PATH="$PATH:$(pwd)" 71 | cd .. 72 | ``` 73 | 74 | ## Examples 75 | 76 | Commented examples are available at ``examples.v``. 77 | 78 | ## Transformations 79 | 80 | The documentation about each transformation is available here: 81 | 82 | * [Definitions](definitions.md) 83 | * [Higher Order Equalities](hoeq.md) 84 | * [Elimination of Anonymous Fixpoints](fix.md) 85 | * [Pattern Matching](pm.md) 86 | * [Algebraic Datatypes](alg.md) 87 | * [Generation Principle](gen.md) 88 | * [Monomorphization](mono.md) 89 | * [Anonymous Functions](anon.md) 90 | * [Prenex Higher Order](ho.md) 91 | * [Inductive Relations in Prop](indrelprop.md) 92 | * [Decision of Inductive Relations](decide.md) 93 | 94 | ## License 95 | As an extension of SMTCoq, `Sniper` is released under the same license 96 | as SMTCoq: CeCILL-C. See the file LICENSE for details. 97 | 98 | ## Papers about Sniper 99 | 100 | * [CPP' 23](https://arxiv.org/pdf/2204.02643.pdf) 101 | * [PXTP' 21](https://hal.science/hal-03328935/document) 102 | 103 | ## Authors 104 | See the file [AUTHORS](https://github.com/smtcoq/sniper/blob/master/AUTHORS). 105 | -------------------------------------------------------------------------------- /docs/_sidebar.md: -------------------------------------------------------------------------------- 1 | * [Presentation](/) 2 | * [Definitions](definitions.md) 3 | * [Higher Order Equalities](hoeq.md) 4 | * [Elimination of Anonymous Fixpoints](fix.md) 5 | * [Pattern Matching](pm.md) 6 | * [Algebraic Datatypes](alg.md) 7 | * [Generation Principle](gen.md) 8 | * [Monomorphization](mono.md) 9 | * [Anonymous Functions](anon.md) 10 | * [Prenex Higher Order](ho.md) 11 | * [Inductive Relations in Prop](indrelprop.md) 12 | * [Decision of Inductive Relations](decide.md) -------------------------------------------------------------------------------- /docs/alg.md: -------------------------------------------------------------------------------- 1 | # Algebraic Datatypes 2 | 3 | The corresponding `Coq` file is `/theories/interpretation_algebraic_types.v`. 4 | 5 | ## What does this transformation do? 6 | 7 | This transformation, called `interp_alg_types`, 8 | takes as an argument an inductive type `I` (not applied to its eventual parameters). 9 | It will fail if the inductive type is not an algebraic datatype 10 | (that is, a datatype which can be encoded as a combination of sum types and product types), 11 | or if the datatype is applied to some parameter. 12 | For instance, `interp_alg_types (list nat)` will fail (because of the parameter), 13 | `interp_alg_types list` will succeed, and `interp_alg_types True` will fail 14 | (because `True` is not an algebraic datatype). 15 | 16 | The transformation generates and proves in the local context: 17 | 18 | * The *non-confusion principle*: each constructor of `I` is disjoint 19 | * The *injectivity of constructors*: each constuctor of `I` is injective 20 | 21 | The *generation principle* is dealt with in two separated files for technical reasons (see [Generation Principle](gen.md)). 22 | 23 | The transformation is written in `MetaCoq` and each application is proved thanks to a `Ltac` proof script. 24 | 25 | ## An example 26 | 27 | The transformation `interp_alg_types list` will generate 28 | and prove: 29 | 30 | ``` 31 | H1 : forall (A : Type) (x : A) (xs : list A), 32 | [] = x :: xs -> False 33 | H2 : forall (A : Type) (x x' : A) (xs xs' : list A), 34 | x :: xs = x' :: xs' -> x = x' /\ xs = xs' 35 | ``` -------------------------------------------------------------------------------- /docs/anon.md: -------------------------------------------------------------------------------- 1 | # Anonymous functions 2 | 3 | This transformation is defined in the file `theories/anonymous_functions.v`. 4 | 5 | ## What does this transformation do? 6 | 7 | This transformation takes all the anonymous functions in the local context 8 | of the form `fun (x: T) => ...`, creates a definition `f := fun (x: T) => ...` 9 | and folds the definition of `f`. It also proves and adds the propositional 10 | equality `f = fun (x: T) => ...` in the local context. 11 | 12 | Note that branches in pattern matching are anonymous functions 13 | that you may want to deal with differently, so the transformation avoids them. 14 | 15 | ## An example 16 | 17 | ``` 18 | 1 goal 19 | A : Type 20 | B : Type 21 | C : Type 22 | l : list A 23 | f : A -> B 24 | g : B -> C 25 | H : (fun x : nat => x + 1) 42 = 43 26 | ______________________________________(1/1) 27 | map g (map f l) = map (fun x : A => g (f x)) l 28 | 29 | anonymous_funs. 30 | 31 | 1 goal 32 | A : Type 33 | B : Type 34 | C : Type 35 | l : list A 36 | f : A -> B 37 | g : B -> C 38 | f0 := fun x : A => g (f x) : A -> C 39 | H : (fun x : nat => x + 1) 42 = 43 40 | H0 : f0 = (fun x : A => g (f x)) 41 | ______________________________________(1/1) 42 | map g (map f l) = map f0 l 43 | ``` 44 | 45 | -------------------------------------------------------------------------------- /docs/decide.md: -------------------------------------------------------------------------------- 1 | # Automatic decision of Inductive Relations 2 | 3 | This transformation is divided in 5 files and it is presented 4 | as a separated plugin called `Decide`. 5 | 6 | * File: `theories/deciderel/add_hypothesis_on_parameters.v` 7 | * File: `theories/deciderel/compdec_plugin.v` 8 | * File: `theories/deciderel/linearize_plugin.v` 9 | * File: `theories/deciderel/generate_fix.v` 10 | * File: `theories/deciderel/proof_correctness.v` 11 | 12 | These files provide `Coq` vernacular commands but no tactic. 13 | 14 | ## What does the transformation do? 15 | 16 | Some inductives relations (`Coq` inductives whose codomain 17 | is $Prop$) are inductively-defined whereas there are decidable. 18 | 19 | The transformation transforms a subset of the decidable inductive relations into an equivalent function whose return type is `bool`. A `Ltac2` proof script tries to generate the proof of the equivalence and if it fails, the proof is left to the user. 20 | 21 | Example: 22 | 23 | ``` 24 | Inductive even (n: nat) : Prop := 25 | | evenO : even 0 26 | | evenSucc n : even n -> even (S (S n)). 27 | ``` 28 | 29 | is transformed into 30 | 31 | ``` 32 | Fixpoint even_dec (n: nat) : bool := 33 | match n with 34 | | 0 => true 35 | | 1 => false 36 | | S (S n') => even_dec n' 37 | end. 38 | ``` 39 | 40 | Each constructor of these decidable relations should have a 41 | conclusion which mentions *every* constructor variable in order to the transformation to be applicable. 42 | 43 | For instance, this constructor (for the typing relation in the simply-typed lambda-calculus) is not in the scope of the 44 | transformation: 45 | 46 | ``` 47 | Inductive has_type : env -> term -> typ -> Prop := 48 | ... 49 | | typ_app G A B t u : 50 | has_type G t (Arrow A B) -> 51 | has_type G u A -> 52 | has_type G (App t u) B 53 | ... 54 | ``` 55 | 56 | Indeed, the variable `A` does not occurs in the conclusion 57 | `has_type G (App t u) B`. 58 | 59 | In addition, in the current state of the plugin, if you want to generate an equivalent function, each type mentionned by the inductive relation (except $Prop$) must be a member of a specific typeclass from the `SMTCoq` plugin called `CompDec`. 60 | 61 | Indeed, decidable equalities are often required during the transformation and the `CompDec` types are also member of the `EqDec` typeclass. Furthermore, the main purpose of this transformation is to be useful for `SMTCoq`, so it relies on its typeclasses. 62 | 63 | An improvement would be to replace `CompDec` by `EqDec` and to ask for decidable equalities on the fly (during the [linearization](#linearization) procedure). 64 | 65 | ## Add hypothesis on parameters 66 | 67 | Suppose given $P: Type \to Type$ and an inductive $I$ of type 68 | $\forall \overrightarrow{(A_{i}: Type)},\; B$. 69 | 70 | The purpose of this file is to transform an inductive $I$ quoted in `MetaCoq` 71 | into $I': \; \forall \overrightarrow{(A_{i}: Type) (H_{A_{i}}: \; P \; A_{i})}, \; B$, still quoted. 72 | 73 | ## CompDec Plugin 74 | 75 | The `SMTCoq` plugin relies heavily on the `CompDec` typeclass 76 | (see [here](https://github.com/smtcoq/smtcoq/blob/coq-8.13/src/classes/SMT_classes.v#L148)): 77 | each type on which a proof is built in `SMTCoq` should belong to this typeclass (types of this typeclass are inhabited, are well-ordered and have a decidable equality `eqb_of_compdec`). 78 | 79 | The file `theories/deciderel/compdec_plugin.v` instantiates 80 | the previous predicate $P$ by `CompDec`. It will generate in the global environement the inductive $I'$ (so unquoted). 81 | 82 | For each concrete type `T` mentioned by the inductive, a proof `HT` of `CompDec T` will be researched in the global environment, and the pair 83 | `(T, HT)` will be registered and used later (for the linearization step may need it). 84 | 85 | ## Linearization 86 | 87 | The linearization procedure is required as `Coq`'s pattern matching 88 | always introduces *fresh* pattern variables. 89 | 90 | As the fixpoint which decides our inductive relation $I$ will perfom *pattern matching* on the variables that occurs in the conclusion of the constructors of $I$, we need a *linear* conclusion. 91 | 92 | Consider the following inductive relation: 93 | 94 | ``` 95 | Inductive mem : nat -> list nat -> Prop := 96 | | MemMatch n l : mem n (n::l) 97 | | MemRecur n n' l : mem n l -> mem n (n' :: l). 98 | ``` 99 | 100 | Its equivalent boolean fixpoint is *NOT*: 101 | 102 | ``` 103 | Fixpoint mem_dec (n: nat) (l : list nat) : bool := 104 | match l with 105 | | [] => false 106 | | n :: xs => true 107 | | x :: xs => mem n xs 108 | end 109 | ``` 110 | 111 | The second occurence of `n` replaces the first occurence and is *NOT* the same variable. 112 | 113 | We need to linearize the conclusion of `mem`. 114 | 115 | Thus, the file `linearize_plugin.v` creates a new relation `mem_linear` 116 | in the global environment: 117 | 118 | 119 | ``` 120 | Inductive mem_linear : 121 | nat -> list nat -> Prop := 122 | | MemMatch_linear n n' l : 123 | eqb_of_compdec nat_compdec n n' -> 124 | mem_linear n (n'::l) 125 | | MemRecur_linear n n' l : mem_linear n l -> 126 | mem_linear n (n' :: l). 127 | ``` 128 | 129 | A new variable `n'` is introduced to replace an occurence of `n` in the conclusion, and the two variables are supposed to be equal. 130 | 131 | As we have previously registered proofs of `CompDec nat` thanks to the ["compdec plugin"](#compdec-plugin), we have at our disposal the proof `nat_compdec` which has to be the first argument of `eqb_of_compdec` (the decidable equality of the `CompDec` typeclass). 132 | 133 | ## Generation of fixpoint 134 | 135 | Taking the linearized version of $I$, say, $I_{linear}$, 136 | the purpose of this file is to generate the equivalent fixpoint in `bool`. 137 | 138 | It relies on an unification algorithm: each variable given to the fixpoint 139 | is destructed by pattern matching until a case which unifies with a conclusion of a constructor of $I_{linear}$ is reached. Then, either the conjonction of the premises should hold, or we continue the algorithm for the other constructors of $I_{linear}$. 140 | 141 | To go back to our `mem` example, the fixpoint generated is the following: 142 | 143 | ``` 144 | Fixpoint mem_dec (n: nat) (l : list nat) : bool := 145 | match l with 146 | | [] => false (* no constructor of mem_linerar has [] for second argument in its conclusion *) 147 | | x :: xs => eqb_of_compdec x n || (* first constructor *) 148 | mem_dec n xs (* second constructor *) 149 | end. 150 | ``` 151 | 152 | The `TemplateMonad` of `MetaCoq` is used to define vernacular commands 153 | to build the fixpoints. 154 | 155 | In this file, the available commands are: 156 | 157 | `MetaCoq Run (build_fixpoint_auto I_linear l)` 158 | 159 | Here, `l` is a list of triple of decidable inductive relations, their boolean version and the proof of their equivalence in the `term` inductive type of `MetaCoq` quoted terms. 160 | 161 | Indeed, some inductive relations may mention other inductive relations, and in its current state the plugin is not able to decide them recursively. 162 | 163 | There is also the command: 164 | 165 | `MetaCoq Run (build_fixpoint_recarg I_linear l n)` 166 | 167 | Indeed, our plugin may not be able to find the structurally decreasing 168 | argument automatically, so it should be provided by the user in some cases. 169 | 170 | The last command is: 171 | 172 | `MetaCoq Run (linearize_and_fixpoint_auto I l).` 173 | 174 | which also perfoms the linearization step. 175 | 176 | 177 | ## Proof of equivalence 178 | 179 | The main command of this file `theories/proof_correctness.v` is: 180 | 181 | `MetaCoq Run (decide I l).` 182 | 183 | When it succeeds, it generates automatically the fixpoint version `I_linear_decidable` of `I`, 184 | and a proof of equivalence between `I` and `I_linear_decidable`. 185 | 186 | Because of `MetaCoq`'s `TemplateMonad` limitations (there is no way of catching an exception, so it is not possible to handle a failure case when the proof cannot be generated automatically), the proof is only printed. That is, if the proof is called `decidable_proof` the user should write: 187 | 188 | ``` 189 | Next Obligation. 190 | exact decidable_proof. 191 | Qed. 192 | ``` 193 | in order to define it in the global environment. 194 | 195 | If the `Ltac2` proof script fails, the user can write its own proof of equivalence thanks to: 196 | 197 | ``` 198 | Next Obligation. 199 | my_proof_script. 200 | Qed. 201 | ``` 202 | 203 | In particular, whenever some kind of strong induction is required, the proof script will fail. 204 | 205 | It is the case for the `even` predicate, for instance, as the induction step of the proof with weak induction will ask 206 | for `even (S n)` knowing only `even n` whereas we would have needed 207 | to be asked to prove 208 | `even (S (S n))` knowing `even n`. 209 | -------------------------------------------------------------------------------- /docs/definitions.md: -------------------------------------------------------------------------------- 1 | # Definitions 2 | 3 | This transformation is available in the file `theories/definitions.v`. 4 | 5 | ## What does this transformation do? 6 | 7 | This transformation, at an atomic level, is called `get_def` and takes as an argument a Coq constant `c`. 8 | By delta-reduction, `c` is convertible to its definition `c_def`. 9 | Thus, `get_def c` asserts and proves the propositional equality `H: c = c_def` in the Coq proof context. 10 | 11 | ## An example 12 | 13 | ``` 14 | Goal False. 15 | 16 | (* 1 goal 17 | ______________________________________(1/1) 18 | False *) 19 | 20 | get_def List.app. 21 | 22 | (* 1 goal 23 | app_def : app = 24 | (fun A : Type => 25 | fix app (l m : list A) {struct l} : list A := 26 | match l with 27 | | nil => m 28 | | a :: l1 => a :: app l1 m 29 | end) 30 | ______________________________________(1/1) 31 | False *) 32 | 33 | ``` -------------------------------------------------------------------------------- /docs/fix.md: -------------------------------------------------------------------------------- 1 | # Elimination of anonymous fixpoints 2 | 3 | This transformation is defined in the file `theories/elimination_fixpoints.v`. 4 | 5 | ## What does this transformation do? 6 | 7 | This transformation `eliminate_fix_hyp`, takes as an argument a hypothesis `H` whose type 8 | contains an anonymous fixpoint of the form `fix f_anon (x1: A1) ... (xn: An) := ...`. 9 | 10 | It looks in the global environment of Coq and in the local context to see if there is 11 | a constant `f` or a local definition `f := ...` which reduces to this anonymous fixpoint by delta-reduction. 12 | 13 | Similarly, it also looks if a *generalization* of `fix f_anon ...` (a constant which reduces to `fun x1 ... xn => fix f_anon ... := ...`) is convertible to a constant. 14 | 15 | The tactic transforms `H` into a new hypothesis of the same identifier `H`, in which each occurence of the anonymous fixpoint in its own body is replaced by the definition discovered. 16 | In addition, a step of beta-reduction is made if possible (that is, if the function is applied to some arguments). 17 | 18 | This transformation is written using the plugin [coq-elpi](https://github.com/LPCIC/coq-elpi), and the proof of each application of the transformation is a `Ltac` proof. 19 | 20 | There is a version `eliminate_fix_cont` taking an additional argument: a `Ltac` continuation, 21 | which can bind the transformed hypothesis `H`. 22 | 23 | ## An example 24 | 25 | ``` 26 | Goal (forall (H : forall (A: Type) (l : A), @length A l = 27 | (fix length (l : list A) : nat := 28 | match l with 29 | | [] => 0 30 | | _ :: l' => S (length l') 31 | end) A l), False). intros. 32 | 33 | 1 goal 34 | H : forall (A: Type) (l : A), @length A l = 35 | (fix length (l : list A) : nat := 36 | match l with 37 | | [] => 0 38 | | _ :: l' => S (length l') 39 | end) A l 40 | ______________________________________(1/1) 41 | False 42 | 43 | eliminate_fix_hyp H. 44 | 45 | 1 goal 46 | 47 | H : forall (A : Type) (l : list A), 48 | length l = 49 | match l with 50 | | [] => 0 51 | | _ :: l' => S (length l') 52 | end 53 | ______________________________________(1/1) 54 | False 55 | ``` 56 | 57 | In this example, the anonymous fixpoint `(fix length (l : list A) := ...` is **not** convertible to `length` 58 | as it is applied to the type variable `A`, but its abstraction over `A` is. 59 | -------------------------------------------------------------------------------- /docs/gen.md: -------------------------------------------------------------------------------- 1 | # Generation Principle 2 | 3 | This transformation is available in two different versions, 4 | in two separated files: 5 | 6 | * The file `theories/case_analysis_existentials.v` for the version with *existentials* 7 | quantifiers 8 | * The file `theories/case_analysis.v` for the version with the 9 | *projection functions* 10 | 11 | ## What does this transformation do? 12 | 13 | This transformation takes an *algebraic datatype* `I` 14 | not applied to its parameters (an inductive type made of non dependent sums 15 | or products whose codomain is `Type` or `Set`) 16 | and states and proves its *generation principle*, that is, 17 | each term `t : I` comes from one of its constructors. 18 | 19 | If we have the following `Coq` definition (`S` is either 20 | `Set` or `Type`): 21 | 22 | ``` 23 | Inductive I (a1 : A1) ... (an : An) : S := 24 | | c1 : T11 -> ... -> T1k -> I a1 ... an 25 | ... 26 | | cl : Tl1 -> ... -> Tlk -> I a1 ... an 27 | ``` 28 | 29 | then, the generation principle for `I` *with existentials* would be: 30 | 31 | $\forall (\overrightarrow{a_{i} : A_{i}}) (t : I \; \vec{a_{i}}), \; 32 | \exists (\overrightarrow{x_{1_{i}}: T_{1_{i}}}), \; 33 | t = c_{1} \; \vec{x_{1_{i}}} \lor ... \lor 34 | \exists (\overrightarrow{x_{l_{i}}: T_{l_{i}}}), 35 | t = c_{l} \; \vec{x_{l_{i}}}$. 36 | 37 | The tactic is `gen_statement_existentials I H`, where `I` is the 38 | inductive and `H` a fresh name. 39 | 40 | The version *without* existentials uses the projections functions $p_{u_{v}}$, each of 41 | of type $\forall (\overrightarrow{a_{i} : A_{i}}) 42 | (t : I \; \vec{a_{i}}) (d_{u_{v}}: T_{u_{v}}), T_{u_{v}}$ 43 | 44 | such that 45 | $p_{u_{v}} \; \vec{a_{i}} \; d_{u_{v}} \; (c_{u} \; \overrightarrow{x_{u_{i}}}) = x_{u_{v}}$ 46 | and $p_{u_{v}} \; \vec{a_{i}} \; d_{u_{v}} \; t = d$ otherwise. 47 | 48 | In other words, the projection function $p_{u_{v}}$ returns 49 | either the $v$-th value of the constructor $u$, or a default value. 50 | 51 | With the projections, the generation statement becomes: 52 | 53 | $\forall (\overrightarrow{a_{i} : A_{i}}) (t : I \; \vec{a_{i}}) \overrightarrow{(d_{i_{j}} : T_{i_{j}})}, \; 54 | t = c_{1} \; \overrightarrow{p_{1_{i}} \; \vec{a_{i}} \; d_{1_{i}} \; x_{1_{i}}} \lor ... \lor 55 | t = c_{l} \; \overrightarrow{p_{l_{i}} \; \vec{a_{i}} \; d_{l_{i}} \; x_{l_{i}}}$. 56 | 57 | The tactic is `pose_gen_statement I`, with `I` the inductive we are 58 | interested in. The projections functions are added in the local context 59 | but their bodies are cleared. 60 | 61 | ## Why do we need a statement without existentials? 62 | 63 | The main backend of `Sniper` is the `SMTCoq` plugin, which does not handle existentials. 64 | 65 | For this reason, in order to help `SMTCoq` to perform case analysis on terms from an algebraic datatype, the generation principle should be stated without existentials. 66 | 67 | Furthermore, all terms on which `SMTCoq` is able to reason should be part of a typeclass in which all types are inhabited. Indeed, `SMTCoq` uses the `Array` theory, for which a default value is required. 68 | 69 | For this reason, the presence of default values required in the projection functions is not a problem: once the statement is monomorphized, we can instantiate each of them by a canonical inhabitant. 70 | 71 | ## An example 72 | 73 | * Generation principle for lists with existentials: 74 | 75 | ``` 76 | forall (A : Type) (t : list A), 77 | t = [] \/ (exists (x : A) (xs : list A), t = x :: xs) 78 | ``` 79 | 80 | * The generation principle for list with projections will add 81 | these variables in the local context: 82 | 83 | ``` 84 | proj0: forall (A : Type), A -> list A -> A 85 | proj1: forall (A : Type), list A -> list A -> list A 86 | gen_list: forall (A : Type) (l ld : list A) (d : A), 87 | l = [] \/ l = proj0 A a l :: proj1 A ld l 88 | ``` 89 | 90 | 91 | -------------------------------------------------------------------------------- /docs/ho.md: -------------------------------------------------------------------------------- 1 | # Prenex higher-order 2 | 3 | This transformation is defined in the file `theories/higher_order.v` 4 | 5 | ## What does this transformation do? 6 | 7 | This transformation is a very simple encoding of some higher-order features, in order to avoid complex encodings when they are not needed. It works only when there are higher-order functions taking concrete functions as arguments. 8 | 9 | For any higher-order application `f g`, the transformation poses the definition `f_g := f g` 10 | and folds the definition of `f_g` in order to hide the higher-order feature. 11 | 12 | In addition, it adds and proves the propositionnal equality `f_g = f g` in the local context. 13 | 14 | ## An example 15 | 16 | ``` 17 | 1 goal 18 | A : Type 19 | B : Type 20 | C : Type 21 | l : list A 22 | f : A -> B 23 | g : B -> C 24 | ______________________________________(1/1) 25 | map g (map f l) = map (fun x : A => g (f x)) l 26 | 27 | prenex_higher_order. 28 | 29 | 1 goal 30 | A : Type 31 | B : Type 32 | C : Type 33 | l : list A 34 | f : A -> B 35 | g : B -> C 36 | f0 := map g : list B -> list C 37 | f1 := map f : list A -> list B 38 | f2 := map (fun x : A => g (f x)) : list A -> list C 39 | H : f0 = 40 | (fix map (l : list B) : list C := 41 | match l with 42 | | [] => [] 43 | | a :: t => g a :: map t 44 | end) 45 | H0 : f1 = 46 | (fix map (l : list A) : list B := 47 | match l with 48 | | [] => [] 49 | | a :: t => f a :: map t 50 | end) 51 | H1 : f2 = 52 | (fix map (l : list A) : list C := 53 | match l with 54 | | [] => [] 55 | | a :: t => g (f a) :: map t 56 | end) 57 | ______________________________________(1/1) 58 | f0 (f1 l) = f2 l 59 | ``` 60 | 61 | -------------------------------------------------------------------------------- /docs/hoeq.md: -------------------------------------------------------------------------------- 1 | # Elimination of higher-order equlities 2 | 3 | ## What does this transformation do? 4 | 5 | This transformation `expand_hyp`, takes as an argument a hypothesis `H` of 6 | type `f = g`, where `f` or `g` are functions taking `k` arguments. 7 | Suppose that `T1 ... Tk` are the types of these arguments. 8 | 9 | The tactic `expand_hyp` creates a new hypothesis `H'` starting from `H`: 10 | ``` 11 | H': forall (x1: T1) ... (xk: Tk), f x1 ... xk = g x1 ... xk 12 | ``` 13 | 14 | There is a version `expand_hyp_cont` taking an additional argument: a `Ltac` continuation, 15 | which can bind the produced hypothesis `H'` 16 | 17 | This transformation is written using `Ltac` and the [MetaCoq plugin](https://github.com/MetaCoq/metacoq). 18 | In particular, it uses `template-coq`, which is the metaprogramming tool for Coq written in Coq. 19 | 20 | ## An example 21 | 22 | ``` 23 | Goal (forall (length_def :length = 24 | (fun A : Type => 25 | fix length (l : list A) : nat := 26 | match l with 27 | | [] => 0 28 | | _ :: l' => S (length l') 29 | end)) -> False). intros. 30 | 31 | 1 goal 32 | length_def : length = 33 | (fun A : Type => 34 | fix length (l : list A) : nat := 35 | match l with 36 | | [] => 0 37 | | _ :: l' => S (length l') 38 | end) 39 | ______________________________________(1/1) 40 | False 41 | 42 | expand_hyp length_def. 43 | 44 | 1 goal 45 | length_def : length = 46 | (fun A : Type => 47 | fix length (l : list A) : nat := 48 | match l with 49 | | [] => 0 50 | | _ :: l' => S (length l') 51 | end) 52 | H : forall (A : Type) (l : list A), 53 | length l = 54 | (fix length (l0 : list A) : nat := 55 | match l0 with 56 | | [] => 0 57 | | _ :: l' => S (length l') 58 | end) l 59 | ______________________________________(1/1) 60 | False 61 | ``` -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Document 6 | 7 | 8 | 9 | 10 | 11 | 12 |
13 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /docs/indrelprop.md: -------------------------------------------------------------------------------- 1 | # Inductive Relations in Prop 2 | 3 | This transformation is defined in the file `theories/indrel.v`. 4 | 5 | ## What does this transformation do? 6 | 7 | It is designed for intuitionnistic external backend that may not have access to the definition of some inductive relation `I` 8 | (that is, an inductive whose codomain is $Prop$). 9 | 10 | This transformation has no use for `SMTCoq` but it can be useful for other backends (work in progress...). 11 | 12 | The transformation adds and proves the definition of the constructors of `I` and the inversion principle of `I` 13 | in the local context. 14 | 15 | ## An example 16 | 17 | Suppose that we have this inductive: 18 | 19 | ``` 20 | Inductive Add {A : Type} (a : A) : list A -> list A -> Prop := 21 | | Add_head : forall l : list A, Add a l (a :: l) 22 | | Add_cons : forall (x : A) (l l' : list A), 23 | Add a l l' -> Add a (x :: l) (x :: l'). 24 | ``` 25 | 26 | Then, running the tactic `inversion_principle @Add` 27 | will add these hypothesis in the local context: 28 | 29 | ``` 30 | Add_head0 : forall (A : Type) (a : A) (l : list A), 31 | Add a l (a :: l) 32 | Add_cons0 : forall (A : Type) (a x : A) (l l' : list A), 33 | Add a l l' -> Add a (x :: l) (x :: l') 34 | Hinv : forall (A : Type) (a : A) (l l' : list A), 35 | Add a l l' <-> 36 | (exists l'' : list A, l = l'' /\ l' = a :: l'') \/ 37 | (exists (x : A) (l1 l2 : list A), 38 | Add a l1 l2 /\ l = x :: l1 /\ l' = x :: l2) 39 | ``` 40 | 41 | 42 | -------------------------------------------------------------------------------- /docs/mono.md: -------------------------------------------------------------------------------- 1 | # Monomorphization 2 | 3 | This transformation is available in two versions: 4 | 5 | * In `theories/instantiate_type.v` you will find the first strategy of instantiation. 6 | * In `theories/instantiate_inductive_pars.v` you will find the second strategy of instantiation. 7 | 8 | ## What does this transformation do? 9 | 10 | The transformation `inst` from `theories/instantiate_type.v` 11 | and the one `elimination_polymorphism` from `theories/instantiate_inductive_pars.v` 12 | both select instances and instantiate hypotheses with prenex polymorphism with these instances. 13 | 14 | That is, they instantiate all the statements of the form: 15 | 16 | $\forall (A : Type), B$ 17 | 18 | where $B$ is a proposition. 19 | 20 | The `inst` strategy will select all the subterms of type $Type$ 21 | in the local context and will create one instance for each subterm. 22 | 23 | The `elimination_polymorphism` strategy will look at all the 24 | ground parameters of inductives $I$ in the local context. 25 | Suppose that there is the ground parameter $u$ at the argument position $n$ for the inductive $I$ 26 | 27 | If a type variable $A$ is also used at the $n$-th argument position of $I$, then $u$ is a relevant instance. 28 | 29 | ## An example 30 | 31 | 32 | ``` 33 | H: forall (A : Type) (B : Type) (x x' : A) (y y' : B), 34 | (x, y) = (x', y') -> x = x' 35 | ______________________________________(1/1) 36 | forall (x x': nat) (y y': bool), 37 | (x, y) = (x', y') -> x = x' 38 | 39 | inst. 40 | 41 | H1: forall (x x' : nat*bool) (y y' : nat*bool), 42 | (x, y) = (x', y') -> x = x' 43 | H2: forall (x x' : nat*bool) (y y' : bool), 44 | (x, y) = (x', y') -> x = x' 45 | H3: forall (x x' : nat*bool) (y y' : nat), 46 | (x, y) = (x', y') -> x = x' 47 | H4: forall (x x' : nat) (y y' : nat*bool), 48 | (x, y) = (x', y') -> x = x' 49 | H5: forall (x x' : nat) (y y' : bool), 50 | (x, y) = (x', y') -> x = x' 51 | H6: forall (x x' : nat) (y y' : nat), 52 | (x, y) = (x', y') -> x = x' 53 | H7: forall (x x' : bool) (y y' : nat*bool), 54 | (x, y) = (x', y') -> x = x' 55 | H8: forall (x x' : bool) (y y' : bool), 56 | (x, y) = (x', y') -> x = x' 57 | H9: forall (x x' : bool) (y y' : nat), 58 | (x, y) = (x', y') -> x = x' 59 | ______________________________________(1/1) 60 | forall (x x': nat) (y y': bool), 61 | (x, y) = (x', y') -> x = x' 62 | 63 | Undo. elimination_polymorphism. 64 | 65 | H1: forall (x x' : nat) (y y' : bool), 66 | (x, y) = (x', y') -> x = x' 67 | ______________________________________(1/1) 68 | forall (x x': nat) (y y': bool), 69 | (x, y) = (x', y') -> x = x' 70 | 71 | ``` 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /docs/pm.md: -------------------------------------------------------------------------------- 1 | # Elimination of pattern matching 2 | 3 | This transformation is available in the file `theories/elimination_pattern_matching.v`. 4 | 5 | ## What does this transformation do? 6 | 7 | This transformation `eliminate_dependent_pattern_matching`, takes as argument a hypothesis `H` whose type 8 | is of the form : 9 | ```Coq 10 | forall (x1: A1) ... (xn: An), 11 | C[match f xi1 ... xin with 12 | | c1 y11 ... y1j => g1 y11 ... y1j 13 | ... 14 | | ck yk1 ... ykj => gk yk1 ... ykj 15 | ... 16 | | cm ym1 ... ymj => gm ym1 ... ymj 17 | ] 18 | ``` 19 | 20 | where `C[_]` is a context. 21 | 22 | The term `f xi1 ... xin` should be an inductive, of constructors `c1 ... cm`. 23 | 24 | For each branch of the `match`, a new hypothesis `Hk` is created: 25 | 26 | ``` 27 | Hk: forall x1 ... xn yk1 ... ykj, f xi1 ... xin = ck yk1 ... ykj -> 28 | C[gk yk1 ... ykj] 29 | ``` 30 | 31 | There is a version of the transformation `elim_match_with_no_forall` which works on hypotheses where the 32 | `match` construction is not under any universal quantification. 33 | 34 | ## An example 35 | 36 | ``` 37 | H : forall (A : Type) (l : list A), 38 | length l = 39 | match l with 40 | | [] => 0 41 | | _ :: l' => S (length l') 42 | end 43 | ______________________________________(1/1) 44 | False 45 | 46 | eliminate_dependent_pattern_matching H. 47 | 48 | H1 : forall (A : Type), length [] = 0 49 | H2 : forall (A : Type) (x : A) (xs : list A), 50 | length (x::xs) = S (length xs) 51 | ______________________________________(1/1) 52 | False 53 | ``` 54 | -------------------------------------------------------------------------------- /elpi/eliminate_fix.elpi: -------------------------------------------------------------------------------- 1 | % returns the recursive argument of a fixpoint 2 | pred index_struct_argument i:term, o:int. 3 | index_struct_argument (fix _ N _ _) N. 4 | index_struct_argument (fun _ _ F) N1 :- 5 | pi x\ index_struct_argument (F x) N, % get the body and recurse 6 | N1 is N + 1. 7 | 8 | pred args_before_fix i: term, o: int. 9 | args_before_fix (global (const C)) I :- coq.env.const C (some Bo) _, args_before_fix Bo I. 10 | args_before_fix (fun _ _ F) N1 :- 11 | pi x\ args_before_fix (F x) N, 12 | N1 is N + 1. 13 | args_before_fix (fix _ _ _ _) 0. 14 | 15 | % builds the equality between two terms 16 | % (applied to the same list of terms) 17 | pred mkEq_aux i: term, i: term, i: term, i: list term, o: term. 18 | mkEq_aux T1 T2 (prod Na Ty F) L (prod Na Ty R) :- pi x\ decl x Na Ty => 19 | mkEq_aux T1 T2 (F x) [x | L] (R x). 20 | mkEq_aux T1 T2 T3 L (app [ {{ @eq }}, T3, app [T1|L'], app [T2| L'] ]) :- std.rev L L'. 21 | 22 | pred mkEq i: term, i: term, o: term. 23 | mkEq T1 T2 R :- coq.typecheck T2 T3 ok, mkEq_aux T1 T2 T3 [] R. 24 | 25 | pred nb_prod i: term, o: int. 26 | nb_prod (prod Na Ty F) N' :- !, pi x\ decl x Na Ty => nb_prod (F x) N, N' is N + 1. 27 | nb_prod _ 0. 28 | 29 | pred mk_napp i: term, i: int, o: term. 30 | mk_napp T1 0 T1 :- !. 31 | mk_napp T1 N' (app [T2, _]) :- N is N' - 1, mk_napp T1 N T2. 32 | 33 | pred subst_anon_fix i: term, i: term, o: term. 34 | subst_anon_fix (fun Na Ty F) T2 (fun Na Ty R) :- pi x\ decl x Na Ty => 35 | subst_anon_fix (F x) T2 (R x). 36 | subst_anon_fix (fix Na I Ty F) T2 T3 :- 37 | coq.typecheck (fix Na I Ty F) TyF ok, 38 | args_before_fix T2 Nb, mk_napp T2 Nb T2', 39 | @holes! => 40 | coq.elaborate-skeleton (F T2') TyF T3 ok. 41 | 42 | pred is_fix i: term. 43 | is_fix (fix _ _ _ _). 44 | is_fix (fun N Ty F) :- pi x\ decl x N Ty => is_fix (F x). 45 | is_fix T :- whd1 T T', is_fix T'. 46 | is_fix (app [T|_L]) :- is_fix T. 47 | 48 | pred recover_types i: (list term), o: (list (pair term term)). 49 | recover_types [X | XS] [pr X Ty | R] :- coq.typecheck X Ty ok, 50 | recover_types XS R. 51 | recover_types [] []. 52 | 53 | type abs term. 54 | 55 | pred bind i: bool, i: term, i: term, o: term. 56 | bind tt T Ty T1 :- T1 = {{ fun (x : lp:Ty) => lp:(B x) }}, 57 | pi x\ (copy (abs) x :- !) => bind ff T Ty (B x). 58 | bind ff T _ T1 :- copy T T1. 59 | 60 | pred abstract i: term, i: list (pair term term), o: term. 61 | abstract T [pr X Ty | XS] R :- (copy X abs :- !) => copy T T1, 62 | bind tt T1 Ty T2, 63 | abstract T2 XS R. 64 | abstract T [] T. 65 | 66 | % all the subterms which are fixpoints of a function except its toplevel fix 67 | pred subterms_fix_fun i: term, o: (list term). 68 | subterms_fix_fun (fun N Ty F) R :- pi x\ decl x N Ty => subterms_fix_fun (F x) R. 69 | subterms_fix_fun (fix N _ Ty F) R :- pi x\ decl x N Ty => subterms_fix (F x) R. 70 | 71 | %warning: does not work with not real fixpoints (there must be a recursive call) 72 | pred subterms_fix i: term, o: (list term). 73 | subterms_fix (sort _U) [] :- !. 74 | subterms_fix (fun N Ty F) R :- !, 75 | subterms_fix Ty R1, pi x\ decl x N Ty => subterms_fix (F x) R2, 76 | std.append R1 R2 R. 77 | subterms_fix (prod N Ty F) R :- !, 78 | subterms_fix Ty R1, pi x\ decl x N Ty => 79 | subterms_fix (F x) R2, 80 | std.append R1 R2 R. 81 | subterms_fix (app L) R :- !, 82 | std.map L subterms_fix R', 83 | std.flatten R' R. 84 | subterms_fix (global _G) [] :- !. 85 | subterms_fix (let N Ty V F) R :- !, 86 | subterms_fix Ty R1, subterms_fix V R2, pi x\ def x N Ty V => subterms_fix (F x) R3, 87 | std.append R1 R2 R12, 88 | std.append R12 R3 R. 89 | subterms_fix (match T U L) R :- !, 90 | subterms_fix T R1, subterms_fix U R2, std.append R1 R2 R12, 91 | std.map L subterms_fix R3, 92 | std.flatten R3 R', 93 | std.append R12 R' R. 94 | subterms_fix ((fix Na _I Ty F) as Fix) [Res|R] :- 95 | names Nms, std.filter Nms (x\ occurs x Fix) Nms', 96 | std.rev Nms' Nmsrev, recover_types Nmsrev NTy, 97 | abstract Fix NTy Res, !, 98 | subterms_fix Ty R1, pi x\ decl x Na Ty => subterms_fix (F x) R2, 99 | std.append R1 R2 R. 100 | subterms_fix _T []. 101 | 102 | pred subterms_glob_const i: term, o: (list term). 103 | subterms_glob_const (sort _U) [] :- !. 104 | subterms_glob_const (fun N Ty F) R :- !, 105 | subterms_glob_const Ty R1, pi x\ decl x N Ty => subterms_glob_const (F x) R2, 106 | std.append R1 R2 R. 107 | subterms_glob_const (prod N Ty F) R :- !, 108 | subterms_glob_const Ty R1, pi x\ decl x N Ty => subterms_glob_const (F x) R2, 109 | std.append R1 R2 R. 110 | subterms_glob_const (app L) R :- !, 111 | std.map L subterms_glob_const R', 112 | std.flatten R' R. 113 | subterms_glob_const (global (const G)) [global (const G)]. 114 | subterms_glob_const (let N Ty V F) R :- !, 115 | subterms Ty R1, subterms V R2, pi x\ def x N Ty V => subterms_glob_const (F x) R3, 116 | std.append R1 R2 R12, 117 | std.append R12 R3 R. 118 | subterms_glob_const (match T U L) R :- !, 119 | subterms_glob_const T R1, subterms_glob_const U R2, std.append R1 R2 R12, 120 | std.map L subterms_glob_const R3, 121 | std.flatten R3 R', 122 | std.append R12 R' R. 123 | subterms_glob_const (fix Na _ Ty F) R :- !, 124 | subterms_glob_const Ty R1, pi x\ decl x Na Ty => subterms_glob_const (F x) R2, 125 | std.append R1 R2 R. 126 | subterms_glob_const _ []. 127 | 128 | pred globals_const_or_def_in_goal i: goal-ctx, o: (list term). 129 | globals_const_or_def_in_goal [(decl _ _ X)| L] L1 :- subterms_glob_const X L', 130 | globals_const_or_def_in_goal L L'', std.append L' L'' L1. 131 | globals_const_or_def_in_goal [(def _X0 _ _Ty X)| L] L1 :- subterms_glob_const X L', 132 | globals_const_or_def_in_goal L L'', std.append L' L'' L1. 133 | globals_const_or_def_in_goal [] []. 134 | 135 | pred abstract_unify_aux i: term, i: term, i: term. 136 | abstract_unify_aux (fun _ _ F1) (fun Na Ty F2) (prod _Na Ty F3) :- !, 137 | pi x\ decl x Na Ty => 138 | abstract_unify_aux (F1 _) (F2 _) (F3 x). 139 | abstract_unify_aux (fun _Na _Ty F1) T2 T3 :- !, 140 | abstract_unify_aux (F1 _) T2 T3. 141 | abstract_unify_aux T1 (fun _ _ F2) (prod Na Ty F3) :- !, 142 | pi x\ decl x Na Ty => 143 | abstract_unify_aux T1 (F2 _) (F3 x). 144 | abstract_unify_aux T1 T2 T3 :- @holes! => !, 145 | coq.elaborate-skeleton T1 T3 T1' ok, coq.elaborate-skeleton T2 T3 T2' ok, 146 | coq.unify-leq T1' T2' ok. 147 | 148 | pred abstract_unify i: term, i: term. 149 | abstract_unify T1 T2 :- coq.typecheck T2 T3 ok, whd1 T1 T1', abstract_unify_aux T1' T2 T3. 150 | 151 | % if we have a term of the form forall x1 ... xn, t x1 ... xn = u x1 ... xn 152 | % and another one of the form forall y1 ... yn, u y1 ... yn = v y1 ... xn, 153 | % returns forall x1 ... xn, t x1 ... xn = v y1 ... yn 154 | pred setoid_rewrite i: term, i: term, o: term. 155 | setoid_rewrite (prod Na Ty F) (prod _Na' _Ty' G) (prod Na Ty R) :- pi x\ decl x Na Ty => 156 | setoid_rewrite (F x) (G x) (R x). 157 | setoid_rewrite (app [{{@eq}}, Ty, T, U]) (app [{{@eq}}, _, U, V]) (app [{{@eq}}, Ty, T, V]). -------------------------------------------------------------------------------- /elpi/higher_order.elpi: -------------------------------------------------------------------------------- 1 | pred is_prod i: term. 2 | is_prod (prod _ _ _). 3 | is_prod (global (const C)) :- coq.env.const C (some Bo) _, is_prod Bo. 4 | 5 | pred prenex_ho1 i: term. 6 | prenex_ho1 (prod _ Ty F) :- not (is_prod Ty), pi x\ decl x _ Ty => prenex_ho1 (F x). 7 | prenex_ho1 (prod _ ((prod _ Ty' _) as Ty) F) :- not (is_prod Ty'), pi x\ decl x _ Ty => prenex_ho1 (F x). 8 | prenex_ho1 T :- name T. 9 | prenex_ho1 (sort (typ _)). 10 | prenex_ho1 (global (const C)) :- (coq.env.const C (some Bo) _, prenex_ho1 Bo; coq.env.const C _ Ty, coq.unify-leq Ty {{Type}} ok). 11 | prenex_ho1 (global (indt _)). 12 | prenex_ho1 (app [global _ | _]). 13 | 14 | pred prenex_ho1_ty i: term. 15 | prenex_ho1_ty T :- coq.typecheck T Ty ok, prenex_ho1 Ty. 16 | 17 | pred contains_prenex_ho i: term. 18 | contains_prenex_ho (prod _ (prod _ _ _) _). 19 | contains_prenex_ho (prod Na Ty F) :- pi x\ decl x Na Ty => contains_prenex_ho (F x). 20 | 21 | pred contains_prenex_ho_ty i: term. 22 | contains_prenex_ho_ty T :- coq.typecheck T Ty ok, contains_prenex_ho Ty. 23 | 24 | pred replace i:list (pair A B), i:A, i: B, o: list (pair A B). 25 | replace [pr X _|LS] X Z [pr X Z |LS]. 26 | replace [U |LS] X Z [U|R] :- replace LS X Z R. 27 | 28 | pred contains_only_context_variables i: list term, i: term. 29 | contains_only_context_variables Na T :- names Na', std.length Na N, std.drop N Na' Na'', 30 | std.forall Na'' (x\ not (occurs x T)). 31 | %contains_only_context_variables _ _ :- coq.error "the term contains free variables that are not context or section variables". 32 | 33 | % TODO : speed up predicate, ignore non pertinent subterms 34 | pred subterms_and_args i: term, i: list term, o: (list (pair term (list term))). %closed subterms of a term and their arguments if they are applied 35 | subterms_and_args (sort U) _ [pr (sort U) []] :- !. 36 | subterms_and_args (fun N Ty F) Na [pr (fun N Ty F) [] | R] :- contains_only_context_variables Na (fun N Ty F), !, 37 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2, 38 | std.append R1 R2 R. %backtracks when the function depends on a variable bound by a previous rule 39 | subterms_and_args (fun N Ty F) Na R :- !, 40 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2, 41 | std.append R1 R2 R. 42 | subterms_and_args (prod N Ty F) Na [pr (prod N Ty F) [] | R] :- contains_only_context_variables Na (prod N Ty F), !, 43 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2, 44 | std.append R1 R2 R. 45 | subterms_and_args (prod N Ty F) Na R :- !, 46 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2, 47 | std.append R1 R2 R. 48 | % TODO : define curry 49 | subterms_and_args (app [T|L]) Na [pr (app [T|L]) [], pr T L |R] :- contains_only_context_variables Na T, 50 | std.forall L (contains_only_context_variables Na), !, 51 | std.map L (x\ subterms_and_args x Na) R', std.flatten R' R. 52 | subterms_and_args (app [_T|L]) Na R :- !, 53 | std.map L (x\ subterms_and_args x Na) R', std.flatten R' R. 54 | subterms_and_args (global G) _Na [pr (global G) []] :- !. 55 | subterms_and_args (let N Ty V F) Na [pr (let N Ty V F) []| R] :- contains_only_context_variables Na (let N Ty V F), !, 56 | subterms_and_args Ty Na R1, subterms_and_args V Na R2, pi x\ def x N Ty V => subterms_and_args (F x) Na R3, 57 | std.append R1 R2 R12, 58 | std.append R12 R3 R. 59 | subterms_and_args (let N Ty V F) Na R :- !, 60 | subterms_and_args Ty Na R1, subterms_and_args V Na R2, pi x\ def x N Ty V => subterms_and_args (F x) Na R3, 61 | std.append R1 R2 R12, 62 | std.append R12 R3 R. 63 | subterms_and_args (match T U L) Na [pr (match T U L) [] | R] :- contains_only_context_variables Na (match T U L), !, 64 | subterms_and_args T Na R1, subterms_and_args U Na R2, std.append R1 R2 R12, 65 | std.map L (x\ subterms_and_args x Na) R3, 66 | std.flatten R3 R', 67 | std.append R12 R' R. 68 | subterms_and_args (match T U L) Na R :- !, 69 | subterms_and_args T Na R1, subterms_and_args U Na R2, std.append R1 R2 R12, 70 | std.map L (x\ subterms_and_args x Na) R3, 71 | std.flatten R3 R', 72 | std.append R12 R' R. 73 | subterms_and_args (fix N Rno Ty F) Na [pr (fix N Rno Ty F) []|R] :- contains_only_context_variables Na (fix N Rno Ty F), !, 74 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2, 75 | std.append R1 R2 R. 76 | subterms_and_args (fix N _ Ty F) Na R :- !, 77 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2, 78 | std.append R1 R2 R. 79 | subterms_and_args T Na [pr T []] :- contains_only_context_variables Na T. 80 | subterms_and_args _ _ []. 81 | 82 | pred subterms_list_and_args i: (list term), i: list term, o: (list (pair term (list term))). 83 | subterms_list_and_args [X|XS] Na R :- !, subterms_and_args X Na L1, subterms_list_and_args XS Na L2, std.append L1 L2 R. 84 | subterms_list_and_args [] _ []. 85 | 86 | shorten coq.ltac.{ open, set-goal-arguments }. 87 | 88 | pred select_args_type_funs i: list term, o: list term. 89 | select_args_type_funs [X | XS] [X |RS] :- (coq.typecheck X {{ Type }} ok ; coq.typecheck X {{ lp:_A -> lp:_B}} ok), select_args_type_funs XS RS. 90 | select_args_type_funs _ []. 91 | 92 | pred trm_and_args_type_funs i: list (pair term (list term)), o: list (pair term (list term)). 93 | trm_and_args_type_funs [pr X Y | XS] [pr X L| RS] :- select_args_type_funs Y L, trm_and_args_type_funs XS RS. 94 | trm_and_args_type_funs [] []. -------------------------------------------------------------------------------- /elpi/ref_elim_utils.elpi: -------------------------------------------------------------------------------- 1 | shorten std.{map}. 2 | 3 | % Checks if the input term contains a `sig` in its definition up to evaluation. 4 | pred sigfull i:term. 5 | pred sigfull_rec i:term. 6 | 7 | sigfull_rec ({{ @sig _ _ }}). 8 | 9 | sigfull_rec (fun _ T _) :- 10 | sigfull T. 11 | sigfull_rec (fun _ T F) :- 12 | pi x\ decl x _ T => sigfull (F x). 13 | 14 | sigfull_rec (let _ T _ _) :- 15 | sigfull T. 16 | sigfull_rec (let _ _ B _) :- 17 | sigfull B. 18 | sigfull_rec (let _ T _ F) :- 19 | pi x\ decl x _ T => sigfull (F x). 20 | 21 | sigfull_rec (prod _ T _) :- 22 | sigfull T. 23 | sigfull_rec (prod _ T F) :- 24 | pi x\ decl x _ T => sigfull (F x). 25 | 26 | sigfull_rec (app L) :- std.exists L sigfull. 27 | 28 | sigfull_rec (fix _ _ Ty _) :- 29 | sigfull Ty. 30 | sigfull_rec (fix _ _ Ty F) :- 31 | pi x\ decl x _ Ty => sigfull (F x). 32 | 33 | sigfull_rec (match T _ _) :- 34 | sigfull T. 35 | sigfull_rec (match _ Rty _) :- 36 | sigfull Rty. 37 | sigfull_rec (match _ _ B) :- 38 | std.exists B sigfull. 39 | 40 | sigfull_rec (uvar _ L) :- std.exists L sigfull. 41 | 42 | sigfull I :- 43 | coq.reduction.lazy.whd I Ir, 44 | sigfull_rec Ir. 45 | 46 | % Expand all the necessary subterms of `i` in order to reveal any `sig`. 47 | pred smart_sig_expand i:term o:term. 48 | pred sig_expand i:term o:term. 49 | pred sig_expand_rec i:term o:term. 50 | 51 | smart_sig_expand I O :- 52 | sigfull I, !, 53 | sig_expand I O. 54 | smart_sig_expand I I. 55 | 56 | sig_expand I O :- 57 | coq.reduction.lazy.whd I Ir, 58 | sig_expand_rec Ir O. 59 | 60 | % There probably is a more direct algorithm that simultaneously checks whether there is a `sig` inside the term and 61 | % expands. Chantal's idea: as we traverse the tree, remember which constructors we went through and rebuild then when 62 | % we find a `sig`. Another approach would be to understand how to use memoization 63 | sig_expand_rec (global _ as C) C :- !. 64 | sig_expand_rec (pglobal _ _ as C) C :- !. 65 | sig_expand_rec (sort _ as C) C :- !. 66 | sig_expand_rec (fun N T F) (fun N T1 F1) :- !, 67 | smart_sig_expand T T1, pi x\ decl x _ T => smart_sig_expand (F x) (F1 x). 68 | sig_expand_rec (let N T B F) (let N T1 B1 F1) :- !, 69 | smart_sig_expand T T1, smart_sig_expand B B1, pi x\ decl x _ T => smart_sig_expand (F x) (F1 x). 70 | sig_expand_rec (prod N T F) (prod N T1 F1) :- !, 71 | smart_sig_expand T T1, (pi x\ decl x _ T => smart_sig_expand (F x) (F1 x)). 72 | sig_expand_rec (app L) (app L1) :- 73 | std.map L smart_sig_expand L1. 74 | sig_expand_rec (fix N Rno Ty F) (fix N Rno Ty1 F1) :- !, 75 | smart_sig_expand Ty Ty1, pi x\ decl x _ Ty => smart_sig_expand (F x) (F1 x). 76 | sig_expand_rec (match T Rty B) (match T1 Rty1 B1) :- !, 77 | smart_sig_expand T T1, smart_sig_expand Rty Rty1, 78 | std.map B smart_sig_expand B1. 79 | sig_expand_rec (primitive _ as C) C :- !. 80 | sig_expand_rec (uvar M L) W :- !, 81 | std.map L smart_sig_expand L1, coq.mk-app-uvar M L1 W. 82 | % when used in CHR rules 83 | sig_expand_rec (uvar X L) (uvar X L1) :- 84 | std.map L smart_sig_expand L1. 85 | 86 | % Checks if the input term contains `sig`, `proj1_sig` or `exist` in its definition up to evaluation. 87 | pred refinefull i:term. 88 | pred refinefull_rec i:term. 89 | 90 | refinefull_rec ({{ exist _ _ _ }}). 91 | refinefull_rec ({{ @sig _ _ }}). 92 | refinefull_rec ({{ @proj1_sig _ _ _ }}). 93 | 94 | refinefull_rec (fun _ T _) :- refinefull_rec T, !. 95 | refinefull_rec (fun _ T F) :- 96 | pi x\ decl x _ T => 97 | refinefull_rec (F x), !. 98 | 99 | refinefull_rec (let _ T _ _) :- 100 | refinefull T, !. 101 | refinefull_rec (let _ _ B _) :- 102 | refinefull B, !. 103 | refinefull_rec (let _ T _ F) :- 104 | pi x\ decl x _ T => refinefull (F x), !. 105 | 106 | refinefull_rec (prod _ T _) :- 107 | refinefull T, !. 108 | refinefull_rec (prod _ T F) :- 109 | pi x\ decl x _ T => refinefull (F x), !. 110 | 111 | refinefull_rec (app L) :- !, std.exists L refinefull. 112 | 113 | refinefull_rec (fix _ _ Ty _) :- 114 | refinefull Ty, !. 115 | refinefull_rec (fix _ _ Ty F) :- 116 | pi x\ decl x _ Ty => refinefull (F x), !. 117 | 118 | refinefull_rec (match T _ _) :- refinefull T, !. 119 | refinefull_rec (match _ Rty _) :- refinefull Rty, !. 120 | refinefull_rec (match _ _ B) :- !, 121 | std.exists B refinefull. 122 | 123 | refinefull_rec (uvar _ L) :- std.exists L refinefull, !. 124 | 125 | refinefull I :- 126 | coq.reduction.lazy.whd I Ir, 127 | refinefull_rec Ir. 128 | 129 | % Remove all refinement types in the input term. `sig A P` is replaced by `A`, `proj1_sig x` is replaced by `x` and 130 | % `exist p h` is replaced by p. Works up to delta reduction. 131 | pred replace i:term, o:term. 132 | replace ({{ exist _ lp:P _ }}) P' :- !, replace P P'. 133 | replace ({{ @sig lp:A _ }}) A' :- !, replace A A'. 134 | replace ({{ @proj1_sig _ _ lp:X }}) X' :- !, replace X X'. 135 | replace (fun N T F) (fun N T1 F1) :- !, 136 | % We should add another variable and figure out which rule to add between the two introduced variables 137 | replace T T1, pi x\ decl x _ T => replace (F x) (F1 x). 138 | replace X Y :- name X, !, X = Y, !. % avoid loading "replace x x" at binders 139 | replace (global _ as C) C1 :- 140 | refinefull C, !, 141 | @redflags! coq.redflags.delta => coq.reduction.lazy.whd C C2, 142 | replace C2 C1. 143 | replace (global _ as C) C. 144 | replace (pglobal _ _ as C) C1 :- 145 | refinefull C, !, 146 | @redflags! coq.redflags.delta => coq.reduction.lazy.whd C C2, 147 | replace C2 C1. 148 | replace (pglobal _ _ as C) C :- !. 149 | replace (sort _ as C) C :- !. 150 | replace (let N T B F) (let N T1 B1 F1) :- !, 151 | replace T T1, replace B B1, pi x\ decl x _ T => replace (F x) (F1 x). 152 | replace (prod N T F) (prod N T1 F1) :- !, 153 | replace T T1, (pi x\ decl x _ T => replace (F x) (F1 x)). 154 | replace (app L) (app L1) :- !, map L replace L1. 155 | replace (fix N Rno Ty F) (fix N Rno Ty1 F1) :- !, 156 | replace Ty Ty1, pi x\ decl x _ Ty => replace (F x) (F1 x). 157 | replace (match T Rty B) (match T1 Rty1 B1) :- !, 158 | replace T T1, replace Rty Rty1, map B replace B1. 159 | replace (primitive _ as C) C :- !. 160 | replace (uvar M L as X) W :- var X, !, map L replace L1, coq.mk-app-uvar M L1 W. 161 | % when used in CHR rules 162 | replace (uvar X L) (uvar X L1) :- map L replace L1. 163 | -------------------------------------------------------------------------------- /elpi/subterms.elpi: -------------------------------------------------------------------------------- 1 | pred subterms i: term, o: (list term). %closed subterms of a term (can contain a context variable) 2 | subterms (sort U) [sort U] :- !. 3 | subterms (fun N Ty F) [fun N Ty F | R] :- 4 | subterms Ty R1, pi x\ decl x N Ty => subterms (F x) R2, 5 | std.append R1 R2 R. 6 | subterms (fun N Ty F) R :- !, 7 | subterms Ty R1, pi x\ decl x N Ty => subterms (F x) R2, 8 | std.append R1 R2 R. 9 | subterms (prod N Ty F) [prod N Ty F | R] :- 10 | subterms Ty R1, pi x\ decl x N Ty => subterms (F x) R2, 11 | std.append R1 R2 R. 12 | subterms (prod N Ty F) R :- !, 13 | subterms Ty R1, pi x\ decl x N Ty => subterms (F x) R2, 14 | std.append R1 R2 R. 15 | subterms (app L) R :- !, 16 | std.map L subterms R', 17 | std.flatten R' R. 18 | subterms (global G) [global G]. 19 | subterms (let N Ty V F) [let N Ty V F| R] :- 20 | subterms Ty R1, subterms V R2, pi x\ def x N Ty V => subterms (F x) R3, 21 | std.append R1 R2 R12, 22 | std.append R12 R3 R. 23 | subterms (let N Ty V F) R :- !, 24 | subterms Ty R1, subterms V R2, pi x\ def x N Ty V => subterms (F x) R3, 25 | std.append R1 R2 R12, 26 | std.append R12 R3 R. 27 | subterms (match T U L) [match T U L | R] :- !, 28 | subterms T R1, subterms U R2, std.append R1 R2 R12, 29 | std.map L subterms R3, 30 | std.flatten R3 R', 31 | std.append R12 R' R. 32 | subterms (fix Na _ Ty F) [fix Na _ Ty F|R] :- 33 | subterms Ty R1, pi x\ decl x Na Ty => subterms (F x) R2, 34 | std.append R1 R2 R. 35 | subterms (fix Na _ Ty F) R :- !, 36 | subterms Ty R1, pi x\ decl x Na Ty => subterms (F x) R2, 37 | std.append R1 R2 R. 38 | subterms _ []. 39 | 40 | pred subterms2 i: term, o: (list term). 41 | subterms2 T L :- subterms T L1, names L2, std.filter L2 (x\ occurs x T) L2', append_nodup L1 L2' L. 42 | 43 | pred subterms2_list i: (list term), o: (list term). 44 | subterms2_list [X|XS] R :- subterms2 X L1, subterms2_list XS L2, append_nodup L1 L2 R. 45 | subterms2_list [] []. 46 | 47 | pred add_if_type i: term, i: (list term), o: (list term). 48 | add_if_type T L [T|L] :- not (std.mem! L T), coq.typecheck T {{ Prop }} (error _), coq.typecheck T {{Type}} ok. 49 | add_if_type _ L L. 50 | 51 | pred subterms_type i: term, o: (list term). 52 | subterms_type (sort U) [sort U]. 53 | subterms_type (fun N Ty F) R :- !, 54 | subterms_type Ty R1, pi x\ decl x N Ty => subterms_type (F x) R2, 55 | std.append R1 R2 R. 56 | subterms_type (prod N Ty F) R :- !, 57 | subterms_type Ty R1, pi x\ decl x N Ty => subterms_type (F x) R2, 58 | std.append R1 R2 R. 59 | subterms_type (app L) R :- !, 60 | std.map L subterms_type R1, 61 | std.flatten R1 R', 62 | add_if_type (app L) R' R. 63 | subterms_type (global G) L :- !, 64 | add_if_type (global G) [] L. 65 | subterms_type (let N Ty V F) R :- !, 66 | subterms_type Ty R1, subterms_type V R2, pi x\ def x N Ty V => subterms_type (F x) R3, 67 | std.append R1 R2 R12, 68 | std.append R12 R3 R. 69 | subterms_type (fix Na _ Ty F) R :- !, 70 | subterms_type Ty R1, pi x\ decl x Na Ty => subterms_type (F x) R2, 71 | std.append R1 R2 R. 72 | subterms_type T R :- add_if_type T [] R. 73 | -------------------------------------------------------------------------------- /elpi/utilities.elpi: -------------------------------------------------------------------------------- 1 | % the type term is extended by one constructor, the position in the local context 2 | type pos_ctx int -> term. 3 | 4 | pred pos_ctx_to_var i: goal-ctx, i: term, o: term. 5 | pos_ctx_to_var Ctx (pos_ctx N) X :- nth N Ctx (decl X _ _). 6 | pos_ctx_to_var Ctx (pos_ctx N) X :- nth N Ctx (def X _ _ _). 7 | pos_ctx_to_var Ctx (app L) (app X) :- std.map L (pos_ctx_to_var Ctx) X. 8 | pos_ctx_to_var _ T T. 9 | 10 | pred var_to_pos_ctx i: goal-ctx, i: term, o: term. 11 | var_to_pos_ctx Ctx X (pos_ctx N) :- nth N Ctx (decl X _ _). 12 | var_to_pos_ctx Ctx X (pos_ctx N) :- nth N Ctx (def X _ _ _). 13 | var_to_pos_ctx Ctx (app L) (app X) :- std.map L (var_to_pos_ctx Ctx) X. 14 | var_to_pos_ctx _ T T. 15 | 16 | % version with the integer representing the position in the context already given and with two outputs 17 | pred var_pos_ctx i: prop, i: int, o: term, o: term. 18 | var_pos_ctx (decl X _ _) I X (pos_ctx I). 19 | var_pos_ctx (def X _ _ _) I X (pos_ctx I). 20 | 21 | pred add_pos_ctx_aux i: goal-ctx, i: int, i: term, o: term. 22 | add_pos_ctx_aux [X | XS] I A B :- !, var_pos_ctx X I T1 T2, 23 | (copy T1 T2 :- !) => (I' is I + 1, !, add_pos_ctx_aux XS I' A B). 24 | add_pos_ctx_aux [] _ A B :- !, copy A B. 25 | 26 | pred add_pos_ctx i: goal-ctx, i: term, o: term. 27 | add_pos_ctx L T1 T2 :- add_pos_ctx_aux L 0 T1 T2. 28 | 29 | pred add_pos_ctx_pr i: goal-ctx, i: (list (pair term (list term))), o: (list (pair term (list term))). 30 | add_pos_ctx_pr Ctx [pr T L | XS] [pr T L'|XS'] :- std.map L (add_pos_ctx Ctx) L', add_pos_ctx_pr Ctx XS XS'. 31 | add_pos_ctx_pr _ [] []. 32 | 33 | pred elim_pos_ctx_aux i: goal-ctx, i: int, i: term, o: term. 34 | elim_pos_ctx_aux [X | XS] I A B :- var_pos_ctx X I T1 T2, (copy T2 T1 :- !) => (I' is I + 1, elim_pos_ctx_aux XS I' A B). 35 | elim_pos_ctx_aux [] _ A B :- copy A B. 36 | 37 | pred elim_pos_ctx i: goal-ctx, i: term, o: term. 38 | elim_pos_ctx Ctx A B :- elim_pos_ctx_aux Ctx 0 A B. 39 | 40 | pred pos_ctx_to_var_in_term_aux i: goal-ctx, i: list term, o: list term. 41 | pos_ctx_to_var_in_term_aux Ctx [(pos_ctx N)| XS] [X|XS'] :- nth N Ctx (decl X _ _), !, pos_ctx_to_var_in_term_aux Ctx XS XS'. 42 | pos_ctx_to_var_in_term_aux Ctx [(pos_ctx N)| XS] [X|XS'] :- 43 | pos_ctx_to_var_in_term_aux Ctx XS XS', nth N Ctx (def X _ _ _). 44 | pos_ctx_to_var_in_term_aux Ctx [(app L)| XS] [app L'|XS'] :- !, std.map L (pos_ctx_to_var Ctx) L', 45 | pos_ctx_to_var_in_term_aux Ctx XS XS'. 46 | pos_ctx_to_var_in_term_aux Ctx [T|XS] [T| XS'] :- pos_ctx_to_var_in_term_aux Ctx XS XS'. 47 | pos_ctx_to_var_in_term_aux _Ctx [] []. 48 | 49 | pred pos_ctx_to_var_in_term i: goal-ctx, i:(list (pair term (list term))), o: list (pair term (list term)). 50 | pos_ctx_to_var_in_term Ctx L1 L2 :- std.unzip L1 LT LI, std.map LI (pos_ctx_to_var_in_term_aux Ctx) L2', std.zip LT L2' L2. 51 | 52 | pred type_global i: term, o: term. 53 | type_global (global (indt I)) Ty :- coq.env.indt I _ _ _ Ty _ _. 54 | type_global (global (indc C)) Ty :- coq.env.indc C _ _ _ Ty. 55 | 56 | pred ctx_to_trms i: goal-ctx, o: list term. 57 | ctx_to_trms [(decl X _ _)|XS] [X|R] :- ctx_to_trms XS R. 58 | ctx_to_trms [(def X _ _ _)|XS] [X|R] :- ctx_to_trms XS R. 59 | ctx_to_trms [] []. 60 | 61 | pred ctx_to_hyps i: goal-ctx, o: list term. 62 | ctx_to_hyps [(decl _ _ Ty)|XS] [Ty|R] :- coq.typecheck Ty {{ Prop }} ok, ctx_to_hyps XS R. 63 | ctx_to_hyps [_|XS] R :- ctx_to_hyps XS R. 64 | ctx_to_hyps [] []. 65 | 66 | pred codomain i:term, o:term. 67 | codomain (prod Na Ty F) R :- !, pi x\ decl x Na Ty => codomain (F x) R. 68 | codomain T T. 69 | 70 | pred is_not_prop i: term, o: diagnostic. 71 | is_not_prop T ok :- not (coq.unify-leq T {{Prop}} ok). 72 | 73 | pred codomain_not_prop i: term, o: diagnostic. 74 | codomain_not_prop (prod Na Ty F) D :- !, pi x\ decl x Na Ty => codomain_not_prop (F x) D. 75 | codomain_not_prop T ok :- !, is_not_prop T ok. 76 | 77 | pred get_number_of_parameters i: term, o: int. 78 | get_number_of_parameters (global (indt I)) NB :- coq.env.indt I _ NB _ _ _ _. 79 | get_number_of_parameters (global (indc C)) NB :- coq.env.indc C NB _ _ _. 80 | get_number_of_parameters _ 0. 81 | 82 | pred tuple_to_list i: term, o: (list term). 83 | tuple_to_list {{ pair lp:P1 lp:P2 }} R :- !, tuple_to_list P1 R1, tuple_to_list P2 R2, 84 | std.append R1 R2 R. 85 | tuple_to_list T [T]. 86 | 87 | pred singl_tuple_to_list i: (list argument), o: (list term). 88 | singl_tuple_to_list [trm T] R :- tuple_to_list T R. 89 | singl_tuple_to_list [] []. 90 | 91 | pred add_if_polymorphic i: term, i: (list term), o: (list term). 92 | add_if_polymorphic ((prod _Na Ty _Bod) as T) L [T | L] :- coq.unify-eq Ty {{ Type }} ok. 93 | add_if_polymorphic _ L L. 94 | 95 | pred is_polymorphic i: pair term term. 96 | is_polymorphic (pr _ (prod _Na Ty _F)) :- coq.unify-eq Ty {{ Type }} ok. 97 | 98 | pred polymorphic_hypotheses i: (list (pair term term)), o: (list (pair term term)). 99 | polymorphic_hypotheses L R :- std.filter L is_polymorphic R. 100 | 101 | pred collect_hypotheses_from_context i: goal-ctx, o: list term, o: list (pair term term). 102 | collect_hypotheses_from_context [(decl X _ Ty)| XS] [Ty|R] [pr X Ty|R'] :- !, collect_hypotheses_from_context XS R R'. 103 | collect_hypotheses_from_context [def _ _ _ _ | XS] R R' :- !, collect_hypotheses_from_context XS R R'. 104 | collect_hypotheses_from_context [] [] []. 105 | 106 | pred find_pos_in_context_aux i: goal-ctx, i: term, i: int, o: term. 107 | find_pos_in_context_aux [(decl T' _ _)| _XS] T N (pos_ctx N) :- coq.unify-eq T' T ok. 108 | find_pos_in_context_aux [(decl _T' _ _)| XS] T N R :- !, M is N + 1, find_pos_in_context_aux XS T M R. 109 | find_pos_in_context_aux [(def T' _ _ _) | _XS] T N (pos_ctx N) :- coq.unify-eq T' T ok. 110 | find_pos_in_context_aux [(def _T' _ _ _)| XS] T N R :- !, M is N + 1, find_pos_in_context_aux XS T M R. 111 | find_pos_in_context_aux [] T _ T. 112 | 113 | pred find_pos_in_context i: goal-ctx, i: term, o: term. 114 | find_pos_in_context Ctx (app L) (app L') :- !, 115 | std.map L (x\ find_pos_in_context_aux Ctx x 0) L'. 116 | find_pos_in_context Ctx T Inst :- find_pos_in_context_aux Ctx T 0 Inst. 117 | 118 | pred append_nodup i: list A, i: list A, o: list A. 119 | append_nodup [X|XS] Y R :- append_nodup XS Y R, std.mem! R X. 120 | append_nodup [X|XS] Y [X|R] :- !, append_nodup XS Y R. 121 | append_nodup [] Y Y. 122 | 123 | pred find_occurences_aux i: list A, i: A, i: int, o: list int. 124 | find_occurences_aux [X|XS] X N [N|R] :- !, M is N + 1, find_occurences_aux XS X M R. 125 | find_occurences_aux [_Y |XS] X N R :- M is N + 1, find_occurences_aux XS X M R. 126 | find_occurences_aux [] _X _N []. 127 | 128 | pred find_occurences i: list A, i: A, o: list int. 129 | find_occurences L X R :- find_occurences_aux L X 0 R. 130 | 131 | pred nth i:int, i:list A, o:A. % a version of nth with no fatal error to handle backtracking 132 | nth 0 [X|_ ] R :- !, X = R. 133 | nth N [_|XS] R :- N > 0, !, N1 is N - 1, nth N1 XS R. 134 | 135 | pred argument_to_term i: list argument, o: list (pair term term). 136 | argument_to_term [trm T| XS] [pr T Ty|R] :- !, coq.typecheck T Ty ok, argument_to_term XS R. 137 | argument_to_term [] []. 138 | 139 | pred term_to_argument i: list term, o: list argument. 140 | term_to_argument [T| XS] [trm T|R] :- !, term_to_argument XS R. 141 | term_to_argument [] []. 142 | 143 | pred int_to_term i: int, o: term. 144 | int_to_term 0 {{ 0 }}. 145 | int_to_term N (app [{{ S }}, N']) :- calc (N - 1) N1, int_to_term N1 N'. 146 | -------------------------------------------------------------------------------- /examples/example_ho.v: -------------------------------------------------------------------------------- 1 | From SMTCoq Require Import SMTCoq. 2 | From Sniper.orchestrator Require Import Sniper. 3 | From Sniper Require Import tree. 4 | From Sniper Require Import Transfos. 5 | Require Import String. 6 | Require Import ZArith. 7 | Require Import Bool. 8 | Require Import Coq.Lists.List. 9 | Import ListNotations. 10 | 11 | 12 | Section higher_order. 13 | 14 | Variable A B C: Type. 15 | Variable HA : CompDec A. 16 | Variable HB : CompDec B. 17 | Variable HC : CompDec C. 18 | 19 | Lemma map_compound : forall (f : A -> B) (g : B -> C) (l : list A), 20 | map g (map f l) = map (fun x => g (f x)) l. 21 | Proof. 22 | induction l; time scope_info. Admitted. 23 | 24 | End higher_order. -------------------------------------------------------------------------------- /examples/examples.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Sniper *) 4 | (* Copyright (C) 2021 *) 5 | (* *) 6 | (* See file "AUTHORS" for the list of authors *) 7 | (* *) 8 | (* This file is distributed under the terms of the CeCILL-C licence *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | From Sniper Require Import Sniper. 13 | From Sniper Require Import tree. 14 | Require Import String. 15 | Require Import ZArith. 16 | Require Import Bool. 17 | Require Import Coq.Lists.List. 18 | Import ListNotations. 19 | 20 | 21 | Local Open Scope Z_scope. 22 | 23 | (** Examples on lists *) 24 | 25 | (* A simple example *) 26 | Goal forall (l : list Z) (x : Z), hd_error l = Some x -> (l <> nil). 27 | Proof. snipe. Qed. 28 | 29 | (* The `snipe` and `snipe_no_check` tactics requires instances of equality to be decidable. 30 | It is in particular visible with type variables. *) 31 | Section Generic. 32 | 33 | Variable A : Type. 34 | Goal forall (l : list A) (x : A), hd_error l = Some x -> (l <> nil). 35 | Proof. 36 | scope. 3: verit. 37 | (* New goals are open that require instances of equality to be 38 | decidable. On usual types such as `Z` in the previous example, 39 | these goals are automatically discharged. On other concrete 40 | types, it is up to the user to prove it or admit it. *) 41 | Abort. 42 | 43 | (* On abstract type, it has to be assumed. *) 44 | Hypothesis HA : CompDec A. 45 | Goal forall (l : list A) (x : A), hd_error l = Some x -> (l <> nil). 46 | Proof. snipe_no_check. Qed. 47 | 48 | End Generic. 49 | 50 | 51 | (* When the goal is automatically provable by the `snipe` tactic, it is 52 | often done in a few seconds. To avoid too long runs when the goal is 53 | not provable, the tactic can be called with a timeout, in seconds. *) 54 | Section Timeout. 55 | 56 | Variable A : Type. 57 | Hypothesis HA : CompDec A. 58 | Goal forall (l : list A) (x : A), hd_error l = Some x -> (l <> nil). 59 | Proof. (* snipe_timeout 10. *) snipe_no_check. Qed. 60 | 61 | End Timeout. 62 | 63 | 64 | (* A more involved example *) 65 | Section destruct_auto. 66 | 67 | Variable A : Type. 68 | Variable HA : CompDec A. 69 | 70 | 71 | (* This theorem needs a case analysis on x and y *) 72 | Theorem app_eq_unit (x y:list A) (a:A) : 73 | x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = []. 74 | Proof. 75 | destruct x as [|a' l]; [ destruct y as [|a' l] | destruct y as [| a0 l0] ]; 76 | simpl. 77 | intros H; discriminate H. 78 | left; split; auto. 79 | intro H; right; split; auto. 80 | generalize H. 81 | generalize (app_nil_r l); intros E. 82 | rewrite -> E; auto. 83 | intros H. 84 | injection H as [= H H0]. 85 | assert ([] = l ++ a0 :: l0) as H1 by auto. 86 | apply app_cons_not_nil in H1 as []. 87 | Qed. 88 | 89 | Theorem app_eq_unit_auto : 90 | forall (x y: list A) (a:A), 91 | x ++ y = a :: nil -> x = [] /\ y = [a] \/ x = [a] /\ y = []. 92 | Proof. snipe_no_check. Qed. 93 | 94 | 95 | End destruct_auto. 96 | 97 | Section search. 98 | 99 | Variable (A: Type). 100 | Variable (H : CompDec A). 101 | 102 | 103 | (* Example of searching an element in a list *) 104 | Fixpoint search (x : A) l := 105 | match l with 106 | | [] => false 107 | | x0 :: l0 => eqb_of_compdec H x x0 || search x l0 108 | end. 109 | 110 | Lemma search_app : forall (x: A) (l1 l2: list A), 111 | search x (l1 ++ l2) = ((search x l1) || (search x l2))%bool. 112 | Proof. 113 | intros x l1 l2. induction l1 as [ | x0 l0 IH]. 114 | - reflexivity. 115 | - simpl. destruct (eqb_of_compdec H x x0). 116 | + reflexivity. 117 | + rewrite IH. reflexivity. 118 | Qed. 119 | 120 | (* The proof of this lemma, except induction, can be automatized *) 121 | Lemma search_app_snipe : forall (x: A) (l1 l2: list A), 122 | @search x (l1 ++ l2) = ((@search x l1) || (@search x l2))%bool. 123 | Proof. induction l1 ; snipe_no_check. Qed. 124 | 125 | 126 | (* Manually using this lemma *) 127 | Lemma search_lemma : forall (x: A) (l1 l2 l3: list A), 128 | search x (l1 ++ l2 ++ l3) = search x (l3 ++ l2 ++ l1). 129 | Proof. 130 | intros x l1 l2 l3. rewrite !search_app. 131 | rewrite orb_comm with (b1 := search x l3). 132 | rewrite orb_comm with (b1 := search x l2) (b2 := search x l1 ). 133 | rewrite orb_assoc. 134 | reflexivity. 135 | Qed. 136 | 137 | (* It can be fully automatized *) 138 | Lemma snipe_search_lemma : forall (x: A) (l1 l2 l3: list A), 139 | search x (l1 ++ l2 ++ l3) = search x (l3 ++ l2 ++ l1). 140 | Proof. pose proof search_app. snipe_no_check. Qed. 141 | 142 | Lemma in_inv : forall (a b:A) (l:list A), 143 | search b (a :: l) -> orb (eqb_of_compdec H a b) (search b l). 144 | Proof. snipe. Qed. 145 | 146 | 147 | (* Another example with an induction *) 148 | Lemma app_nil_r : forall (A: Type) (H: CompDec A) (l:list A), (l ++ [])%list = l. 149 | Proof. intros ; induction l; snipe_no_check. Qed. 150 | 151 | End search. 152 | 153 | Section higher_order. 154 | 155 | 156 | Variable A B C: Type. 157 | Variable HA : CompDec A. 158 | Variable HB : CompDec B. 159 | Variable HC : CompDec C. 160 | 161 | 162 | Lemma map_compound : forall (f : A -> B) (g : B -> C) (l : list A), 163 | map g (map f l) = map (fun x => g (f x)) l. 164 | Proof. 165 | induction l; time snipe. Qed. 166 | 167 | End higher_order. 168 | 169 | (** Examples on trees *) 170 | 171 | Section Tree. 172 | 173 | 174 | Lemma empty_tree_Z2 : forall (t : @tree Z) a t' b, 175 | is_empty t = true -> t <> Node a t' b. 176 | Proof. snipe. Qed. 177 | 178 | Lemma rev_elements_app : 179 | forall A (H:CompDec A) s acc, tree.rev_elements_aux A acc s = ((tree.rev_elements A s) ++ acc)%list. 180 | Proof. intros A H s ; induction s. 181 | - pose proof List.app_nil_r; snipe. 182 | - pose proof app_ass ; pose proof List.app_nil_r; snipe. 183 | Qed. 184 | 185 | Lemma rev_elements_node c (H: CompDec c) l x r : 186 | rev_elements c (Node l x r) = (rev_elements c r ++ x :: rev_elements c l)%list. 187 | Proof. pose proof app_ass ; pose proof rev_elements_app ; snipe. Qed. 188 | 189 | End Tree. 190 | 191 | Section RefinementTypes. 192 | 193 | (* Source: CompCert (https://github.com/AbsInt/CompCert/blob/bf8a3e19dcdd8fec1f8b49e137262c7280d6d8a8/lib/IntvSets.v#L326) *) 194 | (* Note: we did modify the example *) 195 | Inductive data : Type := Nil | Cons (lo hi: Z) (tl: data). 196 | 197 | (* The original version of this was an equivalent function returning `Prop` *) 198 | Fixpoint InBool (x: Z) (s: data) : bool := 199 | match s with 200 | | Nil => false 201 | | Cons l h s' => ((Z.leb l x) && (Z.ltb x h)) || InBool x s' 202 | end. 203 | 204 | (* The original version of this was an equivalent function returning `Prop` *) 205 | Fixpoint ok (x : data) : bool := 206 | match x with 207 | | Nil => true 208 | | Cons l1 h1 s => 209 | match s with 210 | | Nil => l1 (l1 l <= x < h. 236 | snipe. (* Not fully proved due to a bug in SMTCoq *) 237 | Abort. 238 | 239 | End RefinementTypes. 240 | -------------------------------------------------------------------------------- /orchestrator/Sniper.v: -------------------------------------------------------------------------------- 1 | From SMTCoq Require Export SMTCoq. 2 | 3 | From Ltac2 Require Import Ltac2. 4 | 5 | Require Import ZArith. 6 | Require Import PArith.BinPos. 7 | Require Import NArith.BinNatDef. 8 | 9 | From SMTCoq Require Import SMT_classes SMT_classes_instances BVList FArray. 10 | 11 | From Trakt Require Import Trakt. 12 | 13 | From Sniper Require Import Transfos. 14 | 15 | Require Import triggers_tactics. 16 | Require Import run_tactic. 17 | Require Import triggers. 18 | Require Import printer. 19 | Require Import orchestrator. 20 | Require Import filters. 21 | Require Import verit. 22 | 23 | Require Import tree. 24 | 25 | Local Open Scope bs_scope. 26 | 27 | Ltac revert_all := 28 | repeat match goal with 29 | | H : _ |- _ => try revert H 30 | end. 31 | 32 | Ltac my_reflexivity t := assert_refl t. 33 | 34 | Ltac my_unfold_refl H := unfold_refl H. 35 | 36 | Ltac my_unfold_in H t := unfold_in H t. 37 | 38 | (* Ltac my_trakt_bool := revert_all ; trakt bool ; intros. *) 39 | 40 | Ltac my_higher_order_equalities H := expand_hyp H ; clear H. 41 | 42 | Ltac my_higher_order := prenex_higher_order. 43 | 44 | Ltac my_fixpoints H := eliminate_fix_hyp H. 45 | 46 | Ltac my_pattern_matching H := try (eliminate_dependent_pattern_matching H). 47 | 48 | Ltac my_anonymous_function f := anonymous_fun f. 49 | 50 | Ltac my_algebraic_types t := try (interp_alg_types t). 51 | 52 | Ltac my_gen_principle t := 53 | pose_gen_statement t. 54 | 55 | Ltac my_gen_principle_temporary := ltac2:(get_projs_in_variables '(Z, bool, True, False, positive, and, or, Init.Peano.le, 56 | @CompDec, Comparable, EqbType, Inhabited, OrderedType.Compare)). 57 | 58 | Ltac my_polymorphism_state := 59 | ltac2:(Notations.do0 max_quantifiers elimination_polymorphism) ; 60 | clear_prenex_poly_hyps_in_context. 61 | 62 | 63 | Ltac my_polymorphism := elimination_polymorphism_exhaustive unit. 64 | 65 | Ltac my_add_compdec t := add_compdecs_terms t. 66 | 67 | Ltac my_fold_local_def_in_hyp_goal H t := fold_local_def_in_hyp_goal H t. 68 | 69 | Ltac my_pose_case := pose_case. 70 | 71 | Ltac my_elim_refinement_types := elim_refinement_types. 72 | 73 | Ltac2 trigger_generation_principle := TAlways. 74 | 75 | (* Ltac2 trigger_anonymous_funs := TAlways. *) 76 | 77 | Ltac2 trigger_higher_order := 78 | TAlways. 79 | 80 | Ltac2 scope_verbos v := orchestrator 5 81 | { all_tacs := [ 82 | ((trigger_elim_refinement_types (), false, None), "my_elim_refinement_types", filter_elim_refinement_types ()); 83 | ((trigger_pose_case (), false, None), "my_pose_case", trivial_filter); 84 | ((trigger_anonymous_fun (), false, None), "my_anonymous_function", trivial_filter); 85 | ((trigger_higher_order, false, None), "my_higher_order", trivial_filter) ; 86 | ((trigger_reflexivity (), false, None), "my_reflexivity", filter_reflexivity ()); 87 | ((trigger_unfold_reflexivity (), false, None), "my_unfold_refl", filter_unfold_reflexivity ()); 88 | ((trigger_unfold_in (), false, None), "my_unfold_in", filter_unfold_in ()); 89 | ((trigger_higher_order_equalities, false, None), "my_higher_order_equalities", trivial_filter) ; 90 | ((trigger_fixpoints, false, None), "my_fixpoints", trivial_filter) ; 91 | ((trigger_pattern_matching, false, None), "my_pattern_matching", trivial_filter); 92 | ((trigger_algebraic_types, false, None), "my_algebraic_types", filter_algebraic_types ()) ; 93 | ((trigger_generation_principle, false, None), "my_gen_principle_temporary", trivial_filter) ; 94 | ((trigger_polymorphism (), true, None), "my_polymorphism_state", trivial_filter) ; 95 | ((trigger_fold_local_def_in_hyp (), false, None), "my_fold_local_def_in_hyp_goal", trivial_filter); 96 | ((trigger_add_compdecs (), false, Some (2, 2)), "my_add_compdec", filter_add_compdecs ()) ]} 97 | { already_triggered := [] } v. 98 | 99 | Ltac2 scope () := scope_verbos Nothing. 100 | 101 | Ltac2 scope_info () := scope_verbos Info. 102 | 103 | Ltac2 scope_debug () := scope_verbos Debug. 104 | 105 | Ltac2 scope_full () := scope_verbos Full. 106 | 107 | Ltac2 scope2_verbos v := orchestrator 5 108 | { all_tacs := 109 | [((trigger_pose_case (), false, None), "my_pose_case", trivial_filter); 110 | ((trigger_anonymous_fun (), false, None), "my_anonymous_function", trivial_filter) ; 111 | ((trigger_higher_order, false, None), "my_higher_order", trivial_filter) ; 112 | ((trigger_reflexivity (), false, None), "my_reflexivity", filter_reflexivity ()); 113 | ((trigger_unfold_reflexivity (), false, None), "my_unfold_refl", trivial_filter); 114 | ((trigger_higher_order_equalities, false, None), "my_higher_order_equalities", trivial_filter); 115 | ((trigger_fixpoints, false, None), "my_fixpoints", trivial_filter); 116 | ((trigger_pattern_matching, false, None), "my_pattern_matching", trivial_filter); 117 | ((trigger_algebraic_types, false, None), "my_algebraic_types", filter_algebraic_types ()); 118 | ((trigger_generation_principle, false, None), "my_gen_principle_temporary", trivial_filter) ; 119 | ((trigger_fold_local_def_in_hyp (), false, None), "my_fold_local_def_in_hyp_goal", trivial_filter); 120 | ((trigger_polymorphism (), false, Some (2, 2)), "my_polymorphism", trivial_filter); 121 | ((trigger_add_compdecs (), false, None), "my_add_compdec", filter_add_compdecs ()) ] } 122 | { already_triggered := [] } v. 123 | 124 | Ltac2 scope2 () := scope2_verbos Nothing. 125 | 126 | Ltac2 scope2_info () := scope2_verbos Info. 127 | 128 | Ltac2 scope2_debug () := scope2_verbos Debug. 129 | 130 | Ltac2 scope2_full () := scope2_verbos Full. 131 | 132 | Tactic Notation "scope" := ltac2:(Control.enter (fun () => intros; scope ())). 133 | 134 | Tactic Notation "scope_info" := ltac2:(Control.enter (fun () => intros; scope_info ())). 135 | 136 | Tactic Notation "scope_full" := ltac2:(Control.enter (fun () => intros; scope_full ())). 137 | 138 | Tactic Notation "scope2" := ltac2:(Control.enter (fun () => intros ; scope2 ())). 139 | 140 | Tactic Notation "snipe_no_check" := 141 | ltac2:(Control.enter (fun () => intros; scope (); ltac1:(verit_no_check_orch))). 142 | 143 | Tactic Notation "snipe2_no_check" := 144 | ltac2:(Control.enter (fun () => intros; scope2 (); ltac1:(verit_no_check_orch))). 145 | 146 | Tactic Notation "snipe" := 147 | ltac2:(Control.enter (fun () => intros; scope (); ltac1:(verit_orch))). 148 | 149 | Tactic Notation "snipe2" := 150 | ltac2:(Control.enter (fun () => intros; scope2 (); ltac1:(verit_orch))). 151 | 152 | -------------------------------------------------------------------------------- /orchestrator/filters.v: -------------------------------------------------------------------------------- 1 | From Ltac2 Require Import Ltac2 Init. 2 | 3 | (** A filter is useful to block the application of a transformation 4 | even if the transformation is triggered *) 5 | 6 | Ltac2 Type rec filter := [ 7 | | FConstr (constr list) 8 | | FConstrList (constr list list) 9 | | FPredList (constr list -> bool) 10 | | FConj (filter, filter) 11 | | FTrivial ]. 12 | 13 | Ltac2 fPred p := FPredList (List.exist p). 14 | 15 | Ltac2 Notation "FPred" p(tactic) := fPred p. 16 | 17 | Ltac2 trivial_filter := FTrivial. 18 | 19 | Ltac2 Type exn ::= [ WrongArgNumber(string) ]. 20 | 21 | (** [l] is the list of arguments of the tactic (returned by the interpretation 22 | of the trigger 23 | and f is the filter applied to them *) 24 | 25 | Ltac2 rec pass_the_filter 26 | (l : constr list) 27 | (f : filter) : bool := 28 | match f with 29 | | FConstr lc => 30 | match l with 31 | | [] => true 32 | | x :: xs => if List.exist (Constr.equal x) lc then false else pass_the_filter xs f 33 | end 34 | | FConstrList lc => if List.exist (List.equal Constr.equal l) lc then false else true 35 | | FPredList p => if p l then false else true 36 | | FConj f1 f2 => Bool.and (pass_the_filter l f1) (pass_the_filter l f2) 37 | | FTrivial => true 38 | end. -------------------------------------------------------------------------------- /orchestrator/orchestrator.v: -------------------------------------------------------------------------------- 1 | From Ltac2 Require Import Ltac2. 2 | From Ltac2 Require Import Ltac1. 3 | From Ltac2 Require Import Constr. 4 | From Ltac2 Require Import Printf. 5 | Require Import List. 6 | Import ListNotations. 7 | Require Import printer. 8 | Require Import triggers. 9 | Require Import filters. 10 | Require Import triggers_tactics. 11 | Require Import run_tactic. 12 | 13 | Ltac2 Type all_tacs := 14 | { mutable all_tacs : ((trigger * bool * (int * int) option) * string * filter) list }. 15 | 16 | Ltac2 rec remove_tac (na : string) (all_tacs : ((trigger * bool * (int * int) option) * string * filter) list ) := 17 | match all_tacs with 18 | | [] => [] 19 | | (tr, na', f) :: xs => 20 | if String.equal na na' then xs 21 | else (tr, na', f) :: remove_tac na xs 22 | end. 23 | 24 | Ltac2 rec list_pair_equal (eq : 'a -> 'a -> bool) l1 l2 := 25 | match l1, l2 with 26 | | [], [] => true 27 | | (x1, y1) :: l1', (x2, y2) :: l2' => 28 | Bool.and (Bool.and (eq x1 x2) (eq y1 y2)) (list_pair_equal eq l1' l2') 29 | | _ => false 30 | end. 31 | 32 | (** Checks if the tactic was already triggered *) 33 | 34 | Ltac2 already_triggered 35 | (l : (string * ((constr*constr) list)) list) 36 | (p : string * constr list) := 37 | let (nametac, largs) := p in 38 | let tyargs := List.map type largs in 39 | let largstyargs := List.combine largs tyargs in 40 | let rec aux l := 41 | match l with 42 | | (s, llc) :: l' => 43 | if String.equal s nametac then 44 | if list_pair_equal equal largstyargs llc then true else aux l' 45 | else aux l' 46 | | [] => false 47 | end in aux l. 48 | 49 | Ltac2 hyp_equal h h' := 50 | let (id1, opt1, c1) := h in 51 | let (id2, opt2, c2) := h' in 52 | if Ident.equal id1 id2 then 53 | if Constr.equal c1 c2 then 54 | match opt1, opt2 with 55 | | Some x, Some y => Constr.equal x y 56 | | None, Some _ => false 57 | | Some _, None => false 58 | | None, None => true 59 | end 60 | else false 61 | else false. 62 | 63 | Ltac2 rec diff_hyps hs1 hs2 := 64 | match hs1, hs2 with 65 | | [], hs2' => hs2' 66 | | x :: xs, y :: ys => 67 | if hyp_equal x y then diff_hyps xs ys 68 | else y :: diff_hyps xs ys 69 | | x :: xs, [] => [] (* we do not consider removed hypotheses *) 70 | end. 71 | 72 | Ltac2 Type verbosity := 73 | [ Nothing | Info | Debug | Full ]. 74 | 75 | Ltac2 leq_verb (v1 : verbosity) (v2 : verbosity) := 76 | match v1 with 77 | | Nothing => true 78 | | Info => 79 | match v2 with 80 | | Nothing => false 81 | | _ => true 82 | end 83 | | Debug => 84 | match v2 with 85 | | Nothing => false 86 | | Info => false 87 | | _ => true 88 | end 89 | | Full => 90 | match v2 with 91 | | Full => true 92 | | _ => false 93 | end 94 | end. 95 | 96 | Ltac2 print_tactic_not_triggered (v : verbosity) (s : string) := 97 | if leq_verb v Debug then () else 98 | printf "NONE: The following tactic was not triggered: %s" s. 99 | 100 | Ltac2 print_tactic_already_applied (v : verbosity) (s : string) (l : constr list) := 101 | if leq_verb v Debug then () else 102 | (printf "%s was already applied with the following args :" s ; 103 | List.iter (fun x => printf "%t" x) l). 104 | 105 | Ltac2 print_tactic_already_applied_once (v : verbosity) (s : string) := 106 | if leq_verb v Debug then () else 107 | printf "%s was already applied one time" s. 108 | 109 | Ltac2 print_tactic_global_in_local (v : verbosity) (s : string) := 110 | if leq_verb v Debug then () else 111 | printf "%s is global and cannot be applied in a local state" s. 112 | 113 | Ltac2 print_state_verb (v : verbosity) it := 114 | if leq_verb v Debug then () else 115 | print_state (it.(local_env)). 116 | 117 | Ltac2 print_applied_tac (v : verbosity) (s : string) (l : constr list) := 118 | if leq_verb v Nothing then () else 119 | (printf "Applied %s with the following args" s ; 120 | List.iter (fun x => printf "%t: %t" x (Constr.type x)) l). 121 | 122 | Ltac2 print_tactic_trigger_filtered (v : verbosity) (s : string) (l : constr list) := 123 | if leq_verb v Debug then () else 124 | (printf "The tactic %s was filtered with the following args" s ; 125 | List.iter (fun x => printf "%t" x) l). 126 | 127 | Ltac2 rec remove_dups (ll : constr list list) := 128 | match ll with 129 | | [] => [] 130 | | l :: ll' => if List.mem (List.equal Constr.equal) l ll' then remove_dups ll' else l :: remove_dups ll' 131 | end. 132 | 133 | Ltac2 Type count := { mutable count : int }. 134 | 135 | Ltac2 numgoals () := 136 | let c := { count := 0 } in 137 | Control.enter (fun _ => 138 | c.(count) := Int.add 1 (c.(count)) 139 | ); (c).(count). 140 | 141 | Ltac2 rec orchestrator_aux 142 | alltacs (* the mutable field of all tactics *) 143 | init_fuel 144 | fuel 145 | it (* the interpretation state (see [triggers.v]) *) 146 | env (* local triggers variables *) 147 | (trigstacsfis : ((trigger * bool * (int * int) option) * string * filter) list) 148 | (trigtacs : already_triggered) (* Triggered tactics, pair between a string and a list of arguments and their types *) 149 | (v: verbosity) : (* number of information required *) unit := 150 | if Int.le fuel 0 then (* a problematic tactic used all the fuel *) 151 | match trigstacsfis with 152 | | [] => () 153 | | (_, name, _) :: trs => (alltacs).(all_tacs) := remove_tac name ((alltacs).(all_tacs)) ; 154 | Control.enter (fun () => orchestrator init_fuel alltacs trigtacs v) 155 | end 156 | else 157 | print_state_verb v it ; 158 | match trigstacsfis with 159 | | [] => 160 | if (it).(global_flag) then () 161 | else Control.enter (fun () => orchestrator fuel alltacs trigtacs v) 162 | | ((trig, multipletimes, opt), name, fi) :: trigstacsfis' => 163 | (it).(name_of_tac) := name ; 164 | Control.enter (fun () => let interp := interpret_trigger it env trigtacs trig in 165 | match interp with 166 | | [] => 167 | print_tactic_not_triggered v name ; 168 | orchestrator_aux alltacs init_fuel fuel it env trigstacsfis' trigtacs v 169 | | ll => 170 | let rec aux ll := (* if String.equal name "my_fold_local_def_in_hyp_goal" then print_interp_trigger ll else () ; DEBUG *) 171 | match ll with 172 | | [] => orchestrator_aux alltacs init_fuel fuel it env trigstacsfis' trigtacs v 173 | | l :: ll' => 174 | if Bool.and (Int.equal 0 (List.length l)) (Bool.neg ((it).(global_flag))) then 175 | print_tactic_global_in_local v name ; 176 | orchestrator_aux alltacs init_fuel fuel it env trigstacsfis' trigtacs v 177 | else if Bool.and (Bool.neg multipletimes) (already_triggered ((trigtacs).(already_triggered)) (name, l)) then 178 | print_tactic_already_applied v name l ; 179 | aux ll' 180 | else if Bool.neg (pass_the_filter l fi) then 181 | print_tactic_trigger_filtered v name l ; 182 | let ltysargs := List.map (fun x => type x) l in 183 | let argstac := List.combine l ltysargs in 184 | trigtacs.(already_triggered) := (name, argstac) :: (trigtacs.(already_triggered)) ; 185 | aux ll' 186 | else 187 | let ltysargs := List.map (fun x => type x) l in (* computes types before a hypothesis may be removed *) 188 | print_applied_tac v name l ; 189 | let hs1 := Control.hyps () in 190 | let g1 := Control.goal () in 191 | run name l; 192 | let argstac := List.combine l ltysargs in 193 | trigtacs.(already_triggered) := (name, argstac) :: (trigtacs.(already_triggered)) ; 194 | match opt with 195 | | None => 196 | Control.enter (fun () => 197 | let cg' := (it).(local_env) in 198 | let hs2 := Control.hyps () in 199 | let g2 := Control.goal () in 200 | let goalChanged := Bool.neg (Constr.equal g1 g2) in 201 | let g3 := if goalChanged then Some g2 else None in 202 | if goalChanged then (let (hyps, _) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := (hyps, None)) else (); 203 | let diff := diff_hyps hs1 hs2 in 204 | let hypsChanged := Int.gt (List.length diff) 0 in 205 | if hypsChanged then (let (_, g) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := ([], g)) else (); 206 | it.(local_env) := (diff, g3) ; 207 | it.(global_flag) := false ; 208 | let fuel' := 209 | if multipletimes then 210 | Int.sub fuel 1 else fuel in 211 | orchestrator_aux alltacs init_fuel fuel' it env trigstacsfis trigtacs v) 212 | | Some (nbg1, nbg2) => 213 | let nb := numgoals () in if Int.lt nb nbg2 then 214 | Control.enter (fun () => 215 | let cg' := (it).(local_env) in 216 | let hs2 := Control.hyps () in 217 | let g2 := Control.goal () in 218 | let goalChanged := Bool.neg (Constr.equal g1 g2) in 219 | let g3 := if goalChanged then Some g2 else None in 220 | if goalChanged then (let (hyps, _) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := (hyps, None)) else (); 221 | let diff := diff_hyps hs1 hs2 in 222 | let hypsChanged := Int.gt (List.length diff) 0 in 223 | if hypsChanged then (let (_, g) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := ([], g)) else (); 224 | it.(local_env) := (diff, g3) ; 225 | it.(global_flag) := false ; 226 | let fuel' := 227 | if multipletimes then 228 | Int.sub fuel 1 else fuel in 229 | orchestrator_aux alltacs init_fuel fuel' it env trigstacsfis trigtacs v) else 230 | Control.focus nbg1 nbg2 (fun () => 231 | let cg' := (it).(local_env) in 232 | let hs2 := Control.hyps () in 233 | let g2 := Control.goal () in 234 | let goalChanged := Bool.neg (Constr.equal g1 g2) in 235 | let g3 := if goalChanged then Some g2 else None in 236 | if goalChanged then (let (hyps, _) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := (hyps, None)) else (); 237 | let diff := diff_hyps hs1 hs2 in 238 | let hypsChanged := Int.gt (List.length diff) 0 in 239 | if hypsChanged then (let (_, g) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := ([], g)) else (); 240 | it.(local_env) := (diff, g3) ; 241 | it.(global_flag) := false ; 242 | let fuel' := 243 | if multipletimes then 244 | Int.sub fuel 1 else fuel in 245 | orchestrator_aux alltacs init_fuel fuel' it env trigstacsfis trigtacs v) 246 | end 247 | end in aux (remove_dups ll) 248 | end) 249 | end 250 | with orchestrator n alltacs trigtacs v := 251 | if Int.le n 0 then () else 252 | let g := Control.goal () in 253 | let hyps := Control.hyps () in 254 | let env := { env_triggers := [] } in 255 | let it := { subterms_coq_goal := ([], None) ; local_env := (hyps, Some g); global_flag := true ; name_of_tac := ""} in 256 | orchestrator_aux alltacs n n it env ((alltacs).(all_tacs)) trigtacs v. 257 | 258 | (** 259 | - TODO : essayer avec les tactiques de Sniper en les changeant le moins possible (scope) 260 | - position des arguments 261 | - Ltac2 notations (thunks) 262 | - idée de Matthieu Sozeau, tag pour ce qui doit être unfoldé ou non, plutôt que de le mettre à l'intérieur des triggers 263 | - regarder crush ou le crush des software foundations 264 | - essayer d'ajouter autoinduct à Snipe 265 | - 2 types de tactiques: celles qui disent ce qu'elles font et celles qui ne le disent pas 266 | - relancer sur Actema 267 | *) 268 | 269 | -------------------------------------------------------------------------------- /orchestrator/printer.v: -------------------------------------------------------------------------------- 1 | Require Import triggers. 2 | From Ltac2 Require Import Ltac2. 3 | Require Import Ltac2.Printf. 4 | Require Import Ltac2.Message. 5 | 6 | Ltac2 print_case (c: constr) := 7 | match Constr.Unsafe.kind c with 8 | | Constr.Unsafe.Case _ c1 _ c2 ca => printf "%t" c1 ; printf "%t" c2 ; Array.iter (fun x => printf "%t" x) ca 9 | | _ => () 10 | end. 11 | 12 | Ltac2 rec print_interp_trigger (ll : constr list list) := 13 | match ll with 14 | | [] => printf "no more triggers to print" 15 | | l :: ll' => printf "trigger interpreted:" ; List.iter (fun x => printf "%t" x) l ; print_interp_trigger ll' 16 | end. 17 | 18 | (* Ltac2 Eval (print_case '(match 1 as t return 19 | match t with | 0 => Type | S _ => nat end with | 0 => Prop | S x => x end)). *) 20 | 21 | Ltac2 rec concat_list (l : message list) := 22 | match l with 23 | | [] => of_string " " 24 | | x :: xs => concat x (concat (of_string " ") (concat_list xs)) 25 | end. 26 | 27 | Ltac2 print_bool b := 28 | if b then print (of_string "true") else 29 | print (of_string "false"). 30 | 31 | Ltac2 of_option_constr o := 32 | match o with 33 | | None => (of_string "None") 34 | | Some x => (concat (of_string "Some ") (of_constr x)) 35 | end. 36 | 37 | Ltac2 print_hyp h := 38 | let (x, y, z) := h in 39 | print 40 | (concat_list [of_ident x; of_option_constr y ; of_constr z]). 41 | 42 | Ltac2 print_hyps hyps := 43 | List.iter print_hyp hyps. 44 | 45 | Ltac2 print_env env := 46 | List.iter (fun (x, y) => print (concat_list [of_string x; of_string "is"; of_constr y])) env. 47 | 48 | Ltac2 print_state cg := 49 | let (hs, g) := cg in 50 | print (of_string "The goal in the state is") ; 51 | print (of_option_constr g) ; 52 | print (of_string "The hyps in the state are of type") ; 53 | print_hyps hs ; 54 | Message.print (Message.of_string "End state"). 55 | 56 | Ltac2 rec print_triggered_tacs trigtacs := 57 | match trigtacs with 58 | | [] => Message.print (Message.of_string "empty list") 59 | | (name, l) :: xs => Message.print (Message.of_string name) ; 60 | print_triggered_tacs xs 61 | end. 62 | 63 | Ltac2 print_goal () := 64 | let _ := print (of_string "The Goal is") in 65 | let g := Control.goal () in 66 | let _ := print (of_constr g) in 67 | let _ := print (of_string "The hypotheses are") in 68 | let hyps := Control.hyps () in 69 | print_hyps hyps. 70 | 71 | 72 | Ltac2 print_closed_subterms c := 73 | let lc := closed_subterms c in List.iter (fun x => printf "%t" x) lc. 74 | -------------------------------------------------------------------------------- /orchestrator/run_tactic.v: -------------------------------------------------------------------------------- 1 | From Ltac2 Require Import Ltac2. 2 | From Ltac2 Require Import Ltac1. 3 | From Ltac2 Require Import Constr. 4 | From Ltac2 Require Import String. 5 | 6 | (** We need to use a trick here: there 7 | is no function in Ltac2's API which returns 8 | a Ltac1 value given its ident. We always need the absolute path 9 | and we cannot look at several paths because the function [Ltac1.ref] 10 | throws an uncatchable exception whenever the path is not the good one. 11 | Consequently, all the Orchestrator's tactics should be in one file, or the user has to 12 | provide the absolute path herself, which is not convenient at all. 13 | Using elpi avoid these difficulties, even if the user needs 14 | to create its own copy of all the tactic which take arguments 15 | TODO : a PR in Coq to avoid this problem *) 16 | 17 | From elpi Require Import elpi. 18 | 19 | Elpi Tactic apply_ltac1. 20 | Elpi Accumulate lp:{{ 21 | 22 | solve ((goal _ _ _ _ [str S| H]) as G) GS :- 23 | coq.ltac.call S H G GS. 24 | 25 | }}. 26 | Elpi Typecheck. 27 | 28 | Ltac2 get_opt o := match o with None => Control.throw Not_found | Some x => x end. 29 | 30 | (** [run] runs a Ltac1 tactic given its ident and its arguments (provided as a string) *) 31 | 32 | Ltac2 run (s : string) (l : constr list) := 33 | let id := Ident.of_string s in 34 | let id := of_ident (get_opt id) in 35 | let l := of_list (List.map of_constr l) in 36 | Ltac1.apply ltac1val:(fun s l => 37 | let id := s in elpi apply_ltac1 ltac_string:(id) ltac_term_list:(l)) [id; l] run. 38 | 39 | Section tests. 40 | 41 | (** For tests *) 42 | Ltac myapply2 A B := split ; [apply A | apply B]. 43 | Ltac myexact t := exact t. 44 | 45 | Goal (True /\ True) /\ (True -> True -> True /\ True). 46 | Proof. 47 | run "split" []. 48 | let str := "split" in run str []. 49 | run "myexact" ['I]. 50 | run "myexact" ['I]. 51 | intros H1 H2. 52 | run "myapply2" ['H1; 'H2]. 53 | Qed. 54 | 55 | End tests. -------------------------------------------------------------------------------- /orchestrator/simpleordo.v: -------------------------------------------------------------------------------- 1 | From Ltac2 Require Import Init Message Int Bool. 2 | 3 | (* Ref.v *) 4 | Ltac2 Type 'a ref := 'a Init.ref. 5 | 6 | Ltac2 ref (v : 'a) : 'a ref := { contents := v}. 7 | Ltac2 get (r : 'a ref) : 'a := r.(contents). 8 | Ltac2 set (r : 'a ref) (v : 'a) : unit := r.(contents) := v. 9 | 10 | Ltac2 update (r : 'a ref) (f : 'a -> 'a) : unit := 11 | r.(contents) := f (r.(contents)). 12 | 13 | 14 | (* Ça commence ici *) 15 | Ltac2 Type refs := [ .. ]. 16 | 17 | Ltac2 Type refs ::= [ IR (int ref) ]. 18 | Ltac2 bar r := 19 | match r with 20 | | IR r => 21 | set r (Int.add (get r) 1); 22 | ltac1:(idtac "youpi"); 23 | set r (Int.add (get r) 1); 24 | print (of_int (get r)) 25 | | _ => ltac1:(idtac "pas la bonne réf") 26 | end. 27 | Ltac2 initbar () : refs := IR (ref 3). 28 | 29 | Ltac2 Type refs ::= [ BR (bool ref) ]. 30 | Ltac2 foo r := 31 | match r with 32 | | BR b => 33 | set b (Bool.neg (get b)); 34 | print (of_string (if (get b) then "true" else "false")) 35 | | _ => ltac1:(idtac "pas la bonne réf") 36 | end. 37 | Ltac2 initfoo () : refs := BR (ref true). 38 | 39 | Ltac2 rec ordoSimplet transfos := 40 | match transfos with 41 | | [] => ltac1:(idtac "finito pipo !") 42 | | (t, i)::transfos' => 43 | let r := i () in 44 | t r; 45 | ordoSimplet transfos' 46 | end. 47 | 48 | Ltac2 transfos := [ (bar, initbar); (foo, initfoo) ]. 49 | Ltac2 Eval (ordoSimplet transfos). -------------------------------------------------------------------------------- /orchestrator/tests/tests.v: -------------------------------------------------------------------------------- 1 | Require Import orchestrator.triggers. 2 | Require Import orchestrator.printer. 3 | Require Import List. 4 | From Ltac2 Require Import Ltac2 Printf. 5 | From Ltac2 Require Import Constr. 6 | Import Unsafe. 7 | From Ltac2 Require Import Message. 8 | Import ListNotations. 9 | 10 | Ltac2 env_triggers () := 11 | { env_triggers := [] }. 12 | 13 | Ltac2 init_already_triggered () := 14 | { already_triggered := [] }. 15 | 16 | Ltac2 init_interpretation_state () := 17 | (* subterms already computed in the goal *) 18 | { subterms_coq_goal := ([], None); 19 | (* hypotheses or/and goal considered *) 20 | local_env := (Control.hyps (), Some (Control.goal ())) ; 21 | (* are all the hypotheses considered ? *) 22 | global_flag := true; 23 | (* name of the tactic interpreted *) 24 | name_of_tac := "toto" }. 25 | 26 | Ltac2 test_trigger (t: trigger) := 27 | let env := env_triggers () in 28 | let alr_triggered := init_already_triggered () in 29 | let init := init_interpretation_state () in 30 | let res := interpret_trigger init env alr_triggered t in 31 | match res with 32 | | _ :: _ => print_interp_trigger res 33 | | [] => printf "Not triggered" 34 | end. 35 | 36 | Ltac2 test_anon () := 37 | TDisj ( 38 | TMetaLetIn (TContains (TSomeHyp, Arg Constr.type) (TLambda tDiscard tDiscard (Arg id))) ["H"; "f"] 39 | (TConj (TNot (TMetaLetIn (TContains (TNamed "H", NotArg) (TCase tDiscard tDiscard None (Arg id))) ["c"] 40 | (TContains (TNamed "c", NotArg) (TTrigVar (TNamed "f") NotArg)))) 41 | (TIs (TNamed "f", Arg id) tDiscard))) 42 | (TMetaLetIn (TContains (TGoal, Arg id) (TLambda tDiscard tDiscard (Arg id))) ["H"; "f"] 43 | (TConj (TNot (TMetaLetIn (TContains (TNamed "H", NotArg) (TCase tDiscard tDiscard None (Arg id))) ["c"] 44 | (TContains (TNamed "c", NotArg) (TTrigVar (TNamed "f") NotArg)))) (TIs (TNamed "f", Arg id) tDiscard))). 45 | 46 | (* anonymous funs that are not branches of match *) 47 | 48 | Lemma test u : match u with | 0 => True | S u => False end -> (fun x : nat => x) u = u -> False. 49 | intros H H1. test_trigger (test_anon ()). Abort. 50 | 51 | Lemma test u : (fun x : nat => x) u = u -> False. 52 | intros H. test_trigger (test_anon ()). Abort. 53 | 54 | Lemma test u : match u with | 0 => True | S u => False end -> False. 55 | intros H. test_trigger (test_anon ()). Abort. 56 | 57 | (** Test De Brujin indexes, eq and anonymous functions **) 58 | 59 | Goal forall (n: nat), (fun x => x) n = n. 60 | intros n. 61 | test_trigger (TContains (TGoal , NotArg) (TRel 1 NotArg)). 62 | pose (H := fun (x : nat) => x). 63 | test_trigger (TContains (TSomeDef, NotArg) (TLambda (TTerm 'nat (Arg id)) tDiscard NotArg)). 64 | test_trigger (TContains (TGoal, NotArg) (TLambda tDiscard (TRel 1 NotArg) NotArg)). (* warning: as in 65 | the kernel, De Brujin indexes start with 1 *) 66 | test_trigger (TIs (TGoal, NotArg) (TEq (TTerm 'nat (Arg id)) tDiscard tDiscard (Arg id))). 67 | let g := Control.goal () in print_closed_subterms g. 68 | Abort. 69 | 70 | (** Test match, definitions and fixpoints **) 71 | 72 | Goal (length = 73 | fun A : Type => 74 | fix length (l : list A) : nat := match l with 75 | | [] => 0 76 | | _ :: l' => S (length l') 77 | end). 78 | test_trigger (TContains (TGoal, NotArg) (TConstant None (Arg Constr.type))). 79 | test_trigger (TContains (TGoal, NotArg) (TConstant (Some "length") (Arg Constr.type))). 80 | test_trigger (TContains (TGoal, NotArg) (TFix tDiscard tDiscard NotArg)). 81 | test_trigger (TContains (TGoal, NotArg) (TFix tDiscard tDiscard NotArg)). 82 | test_trigger (TContains (TGoal, NotArg) (TCase tDiscard tDiscard (Some [TTerm '0 NotArg; tDiscard]) NotArg)). 83 | Abort. 84 | 85 | Goal (forall A, @length A = 86 | fix length (l : list A) : nat := match l with 87 | | [] => 0 88 | | _ :: l' => S (length l') 89 | end). 90 | test_trigger (TContains (TGoal, NotArg) (TFix (TAny (Arg id)) tDiscard NotArg)). 91 | test_trigger (TContains (TGoal, NotArg) (TFix tDiscard tDiscard NotArg)). 92 | Abort. 93 | 94 | (* Test named *) 95 | 96 | Goal (forall (A B C : Prop), (A /\ B) -> (A /\ B) \/ C). 97 | intros A B C H. 98 | test_trigger (TIs (TGoal, NotArg) (TOr tDiscard tDiscard NotArg)). 99 | test_trigger (TMetaLetIn (TIs (TGoal, NotArg) (TOr tArg tDiscard NotArg)) ["A"] (TIs ((TNamed "A"), NotArg) (TAnd tArg tDiscard NotArg))). 100 | Abort. 101 | 102 | Goal unit. 103 | test_trigger (TIs (TGoal, NotArg) (TTerm 'unit (Arg id))). (* unit is in the list of used arguments *) 104 | Abort. 105 | 106 | Goal False. 107 | ltac1:(pose proof app_nil_end). 108 | test_trigger (TIs (TSomeHyp, NotArg) (TProd (TSort TBigType NotArg) tDiscard NotArg)). 109 | Abort. 110 | 111 | Ltac2 trigger_trakt_bool () := 112 | TMetaLetIn (TIs (TSomeHyp, (Arg type)) (TType 'Prop NotArg)) ["H"] 113 | (TNot (TIs (TNamed "H", NotArg) (TEq (TTerm 'bool NotArg) tDiscard tDiscard NotArg))). 114 | 115 | (* test for trakt tactic *) 116 | Lemma toto (H : true = false) (H1 : andb true true = true) (n : nat) (H2 : False) : True. 117 | Proof. 118 | test_trigger (trigger_trakt_bool ()). 119 | Abort. 120 | 121 | Goal False. 122 | ltac1:(pose proof app_nil_end). 123 | test_trigger (trigger_trakt_bool ()). 124 | Abort. 125 | 126 | Fixpoint zip {A B : Type} (l : list A) (l' : list B) := 127 | match l, l' with 128 | | [], _ => [] 129 | | x :: xs, [] => [] 130 | | x :: xs, y :: ys => (x, y) :: zip xs ys 131 | end. 132 | 133 | Ltac2 trigger_pattern_matching := 134 | TContains (TSomeHyp, Arg id) (TCase tDiscard tDiscard None NotArg). 135 | 136 | Goal (forall (H1 : forall (A B : Type) (l : list A) (l' : list B), 137 | zip l l' = 138 | match l with 139 | | [] => [] 140 | | x :: xs => match l' with 141 | | [] => [] 142 | | y :: ys => (x, y) :: zip xs ys 143 | end end), False). 144 | Proof. intros. test_trigger (trigger_pattern_matching). Abort. 145 | 146 | 147 | 148 | -------------------------------------------------------------------------------- /orchestrator/triggers_tactics.v: -------------------------------------------------------------------------------- 1 | From Ltac2 Require Import Ltac2. 2 | From Ltac2 Require Import Constr. 3 | From Ltac2 Require Import String. 4 | Require Import List ZArith. 5 | Import ListNotations. 6 | Require Import printer. 7 | Require Import triggers. 8 | Require Import filters. 9 | 10 | From SMTCoq Require SMT_classes Conversion Tactics Trace State SMT_classes_instances QInst BVList FArray. 11 | 12 | Ltac2 is_prod (c: constr) := 13 | match Constr.Unsafe.kind c with 14 | | Constr.Unsafe.Prod _ _ => true 15 | | _ => false 16 | end. 17 | 18 | Ltac2 higher_order (c: constr) := 19 | let t := Constr.type c in 20 | let rec aux t := 21 | match Constr.Unsafe.kind t with 22 | | Constr.Unsafe.Prod bind t' => 23 | Bool.or (let ty := Constr.Binder.type bind in (is_prod ty)) (aux t') 24 | | _ => false 25 | end 26 | in aux t. 27 | 28 | Ltac2 is_prop (c: constr) := Constr.equal c 'Prop. 29 | 30 | Ltac2 is_proof (c: constr) := 31 | let t := Constr.type c in 32 | let t2 := Constr.type t in 33 | is_prop t2. 34 | 35 | Ltac2 rec codomain_not_prop_aux (c: constr) := 36 | match Constr.Unsafe.kind c with 37 | | Constr.Unsafe.Prod bi c' => codomain_not_prop_aux c' 38 | | Constr.Unsafe.App x1 arr => codomain_not_prop_aux x1 39 | | _ => Bool.neg (is_prop c) 40 | end. 41 | 42 | Require Import refinement_elimination_elpi. 43 | From elpi Require Import elpi. 44 | 45 | Tactic Notation "sigfull" constr(x) := 46 | elpi sigfull_tac ltac_term:(x). 47 | 48 | Ltac2 contains_refinement_type (c: constr) : bool := 49 | match! constr:(true) with 50 | | _ => (ltac1:(c' |- (sigfull c'))) (Ltac1.of_constr (Constr.type c)); true 51 | | _ => false 52 | end. 53 | 54 | Ltac2 codomain_not_prop (c: constr) := codomain_not_prop_aux (Constr.type c). 55 | 56 | Ltac2 codomain_prop (c: constr) := Bool.neg (codomain_not_prop c). 57 | 58 | Ltac2 trigger_hyp_or_goal trig := TDisj (trig TSomeHyp) (trig TGoal). 59 | 60 | (* Ltac2 Eval (higher_order '@nth). *) 61 | 62 | (** Triggers and filters for Sniper tactics *) 63 | 64 | Ltac2 trigger_reflexivity () := 65 | TDisj (TIs (TSomeDef, (Arg id)) (TAny NotArg)) 66 | (TDisj (TContains (TSomeHyp, NotArg) (TConstant None (Arg id))) 67 | (TContains (TGoal, NotArg) (TConstant None (Arg id)))). 68 | 69 | Ltac2 filter_reflexivity () := 70 | FConj 71 | (FConj 72 | (FConstr 73 | ['Z.add; 'Z.sub; 'Z.mul; 'Z.eqb; 'Z.ltb; 'Z.leb; 'Z.geb; 'Z.gtb; 'Z.lt; 74 | 'Z.le; 'Z.ge; 'Z.gt; 'Pos.lt; 'Pos.le; 'Pos.ge; 'Pos.gt; 'Z.to_nat; 'Pos.mul; 75 | 'Pos.sub; 'Init.Nat.add; 'Init.Nat.mul; 'Nat.eqb; 'Nat.leb; 'Nat.ltb; 'ge; 'gt; 76 | 'N.add; 'N.mul; 'N.eqb; 'N.leb; 'N.leb; 'N.ltb; 'Peano.lt; 'negb; 'not; 'andb; 'orb; 'implb; 'xorb; 77 | 'Bool.eqb; 'iff; 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_eq; 78 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_and; 79 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_or; 80 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_xor; 81 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_add; 82 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_mult; 83 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_ult; 84 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_slt; 85 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_concat; 86 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_shl; 87 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_shr; 88 | '@FArray.select; 89 | '@FArray.diff; 90 | 'is_true; 91 | '@SMTCoq.classes.SMT_classes.eqb_of_compdec; 92 | '@SMTCoq.classes.SMT_classes.CompDec; 93 | '@SMTCoq.classes.SMT_classes_instances.Nat_compdec; 94 | '@SMTCoq.classes.SMT_classes_instances.list_compdec; 95 | '@SMTCoq.classes.SMT_classes_instances.prod_compdec; 96 | '@SMTCoq.classes.SMT_classes_instances.option_compdec; 97 | '@SMTCoq.classes.SMT_classes_instances.Z_compdec]) 98 | (FPred higher_order)) 99 | (FConj (FPred is_proof) (FPred contains_refinement_type)). 100 | 101 | Ltac2 trigger_unfold_reflexivity () := 102 | TIs (TSomeHyp, Arg id) (TEq tDiscard tDiscard tDiscard NotArg). 103 | 104 | Ltac2 filter_unfold_reflexivity () := 105 | FPred (fun x => (Bool.neg 106 | ( 107 | let ty := Constr.type x in 108 | match! ty with 109 | | @eq ?a ?t ?u => Constr.equal t u 110 | | _ => false 111 | end))). 112 | 113 | Ltac2 trigger_unfold_in () := 114 | TDisj (TMetaLetIn (TIs (TSomeHyp, Arg id) (TEq tDiscard tDiscard (TAny (Arg id)) NotArg)) ["H"; "eq"] 115 | (TConj (TIs (TNamed "H", Arg id) tDiscard) 116 | (TContains (TNamed "eq", NotArg) (TConstant None (Arg id))))) 117 | (TMetaLetIn (TIs (TSomeHyp, Arg id) (TEq tDiscard tDiscard tDiscard (Arg id))) ["H"; "eq"] 118 | (TConj (TIs (TNamed "H", Arg id) tDiscard) 119 | (TContains (TNamed "eq", NotArg) (TVar TLocalDef (Arg id))))). 120 | 121 | Ltac2 filter_unfold_in () := 122 | FPredList (fun l => match l with | [x; y] => 123 | Bool.or 124 | (let t := type x in 125 | match! t with 126 | | @eq ?a ?u ?v => Bool.neg (Constr.is_var u) 127 | end) (Bool.neg (higher_order y)) | _ => true end). 128 | 129 | Ltac2 trigger_higher_order_equalities := 130 | TIs (TSomeHyp, Arg id) (TEq (TProd tDiscard tDiscard NotArg) tDiscard tDiscard NotArg). 131 | 132 | Ltac2 trigger_fixpoints := 133 | TContains (TSomeHyp, Arg id) (TFix tDiscard tDiscard NotArg). 134 | 135 | Ltac2 trigger_pattern_matching := 136 | TContains (TSomeHyp, Arg id) (TCase tDiscard tDiscard None NotArg). 137 | 138 | Ltac2 trigger_polymorphism () := 139 | TDisj (TIs (TSomeHypProp, NotArg) 140 | (TProd (TSort TSet NotArg) tDiscard NotArg)) 141 | (TIs (TSomeHypProp, NotArg) 142 | (TProd (TSort TBigType NotArg) tDiscard NotArg)). 143 | 144 | Ltac2 trigger_higher_order := 145 | TContains (TSomeHyp, NotArg) (TProd (TProd tDiscard tDiscard NotArg) tDiscard NotArg). 146 | 147 | 148 | Ltac2 trigger_algebraic_types := 149 | TDisj (TContains (TGoal, NotArg) (TInd None (Arg id))) (TContains (TSomeHyp, NotArg) (TInd None (Arg id))). 150 | 151 | Ltac2 filter_algebraic_types () := 152 | FConj (FConstr 153 | ['Z; 'bool; 'positive; 'N; 'nat ; 'FArray.farray; 'SMTCoq.classes.SMT_classes.EqbType; 154 | 'SMTCoq.classes.SMT_classes.CompDec; 155 | 'SMTCoq.classes.SMT_classes.Comparable; 156 | 'SMTCoq.classes.SMT_classes.Inhabited ; 'Coq.Structures.OrderedType.Compare]) 157 | (FPred codomain_prop). 158 | 159 | Ltac2 trigger_generation_principle () := 160 | TIs (TSomeHyp, NotArg) (TInd None (Arg id)). 161 | 162 | Ltac2 filter_generation_principle () := 163 | FConj (FConstr 164 | ['Z; 'bool; 'positive; 'FArray.farray; 'SMTCoq.classes.SMT_classes.EqbType; 165 | 'SMTCoq.classes.SMT_classes.CompDec; 166 | 'SMTCoq.classes.SMT_classes.Comparable; 167 | 'SMTCoq.classes.SMT_classes.Inhabited ; 'Coq.Structures.OrderedType.Compare]) 168 | (FPred codomain_prop). 169 | 170 | Ltac2 trigger_anonymous_fun () := 171 | TDisj ( 172 | TMetaLetIn (TContains (TSomeHyp, Arg Constr.type) (TLambda tDiscard tDiscard (Arg id))) ["H"; "f"] 173 | (TConj (TNot (TMetaLetIn (TContains (TNamed "H", NotArg) (TCase tDiscard tDiscard None (Arg id))) ["c"] 174 | (TContains (TNamed "c", NotArg) (TTrigVar (TNamed "f") NotArg)))) 175 | (TIs (TNamed "f", Arg id) tDiscard))) 176 | (TMetaLetIn (TContains (TGoal, Arg id) (TLambda tDiscard tDiscard (Arg id))) ["H"; "f"] 177 | (TConj (TNot (TMetaLetIn (TContains (TNamed "H", NotArg) (TCase tDiscard tDiscard None (Arg id))) ["c"] 178 | (TContains (TNamed "c", NotArg) (TTrigVar (TNamed "f") NotArg)))) (TIs (TNamed "f", Arg id) tDiscard))). 179 | 180 | Ltac2 trigger_add_compdecs () := 181 | TDisj 182 | (triggered when (AnyHyp) contains TEq (TAny (Arg id)) tDiscard tDiscard NotArg) 183 | (triggered when (TGoal) contains TEq (TAny (Arg id)) tDiscard tDiscard NotArg). 184 | 185 | Ltac2 filter_add_compdecs () := 186 | (FConj 187 | (FConstr ['Z; 'bool; 'positive; 'nat ; 'FArray.farray; 'Prop; 'Set; 'Type]) 188 | (FPred (fun x => Bool.or (is_prod x) 189 | (match Constr.Unsafe.kind x with | Constr.Unsafe.App u ca => Bool.or (Constr.equal u '@SMT_classes.CompDec) (Constr.equal u '@sig) | _=> false end )))). 190 | 191 | 192 | (* Ltac2 trigger_fold_local_def () := 193 | tlet def ; def_unfold := (triggered when (TSomeDef) is (tArg) on (Arg id)) in 194 | TConj (triggered when (TSomeHypProp) contains (TTrigVar (TNamed "def_unfold") (NotArg)) on (NotArg)) 195 | (triggered when (TNamed "def") is (TTrigVar (TNamed "def") (NotArg)) on (Arg id)) 196 | (* trick to get as argument the definition not unfolded*). *) 197 | 198 | Ltac2 trigger_fold_local_def_in_hyp () := 199 | TDisj 200 | (tlet def ; def_unfold := (triggered when (TSomeDef) is (tArg) on (Arg id)) in 201 | TConj (triggered when (TSomeHypProp) contains (TTrigVar (TNamed "def_unfold") (NotArg)) on (Arg id)) 202 | (triggered when (TNamed "def") is (TTrigVar (TNamed "def") (NotArg)) on (Arg id))) 203 | (tlet def ; def_unfold := (triggered when (TSomeDef) is (tArg) on (Arg id)) in 204 | TConj (triggered when (TSomeDef) contains (TTrigVar (TNamed "def_unfold") (NotArg)) on (Arg id)) 205 | (triggered when (TNamed "def") is (TTrigVar (TNamed "def") (NotArg)) on (Arg id))). 206 | (* trick to get as argument the definition not unfolded*) 207 | 208 | (** warning A TNot is not interesting whenever all hypotheses are not considered !!! *) 209 | Ltac2 trigger_trakt_bool_hyp () := 210 | (TNot (TIs (TSomeHypProp, Arg id) (TEq (TTerm 'bool NotArg) tDiscard tDiscard NotArg))). 211 | 212 | Ltac2 trigger_trakt_bool_goal () := 213 | (TNot (TIs (TGoal, NotArg) (TEq (TTerm 'bool NotArg) tDiscard tDiscard NotArg))). 214 | 215 | Ltac2 trigger_pose_case () := 216 | TMetaLetIn (TContains (TGoal, NotArg) (TCase tDiscard tDiscard None (Arg id))) ["M"] 217 | (TConj 218 | (TNot (TMetaLetIn (TContains (TGoal, NotArg) (TProd tArg tDiscard NotArg)) ["f"] 219 | (TContains (TNamed "f", NotArg) (TTrigVar (TNamed "M") NotArg)))) 220 | (TIs (TNamed "M", Arg id) tDiscard)). 221 | 222 | 223 | (* There is an hypothesis or the goal which contain a term whose type contains a `sig` and it returns the set of minimal such terms *) 224 | Ltac2 trigger_elim_refinement_types_loc loc := 225 | let containsSigInType trig_var := 226 | TMetaLetIn (TIs (trig_var, Arg type) tDiscard) ["T"] 227 | (TContains (TNamed "T", NotArg) (TTerm 'sig NotArg)) 228 | in 229 | TMetaLetIn (TContainsClosed (loc, NotArg) tArg) ["x"] 230 | (TConj 231 | (TConj 232 | (containsSigInType (TNamed "x")) 233 | (TNot (TMetaLetIn (TContainsClosed (TNamed "x", NotArg) tArg) ["y"] 234 | (TConj 235 | (TNot (TIs (TNamed "x", NotArg) (TTrigVar (TNamed "y") NotArg))) 236 | (containsSigInType (TNamed "y")) 237 | )))) 238 | (TIs (TNamed "x", Arg id) tDiscard)). 239 | 240 | Ltac2 trigger_elim_refinement_types () := 241 | trigger_hyp_or_goal trigger_elim_refinement_types_loc. 242 | 243 | Ltac2 filter_elim_refinement_types () := 244 | FConstr ['@proj1_sig]. 245 | -------------------------------------------------------------------------------- /tests/tests.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Sniper *) 4 | (* Copyright (C) 2021 *) 5 | (* *) 6 | (* See file "AUTHORS" for the list of authors *) 7 | (* *) 8 | (* This file is distributed under the terms of the CeCILL-C licence *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | From Sniper Require Import Sniper. 13 | From Sniper Require Import Transfos. 14 | Require Import String. 15 | Require Import ZArith. 16 | Require Import Bool. 17 | Require Import List. 18 | Import ListNotations. 19 | 20 | Section poly. 21 | 22 | 23 | Goal (forall A B C : Type, 24 | forall (f : A -> B) (g : A -> C), 25 | let f0 := fun x : A => (f x, g x) in 26 | let f1 := @map A (B * C) f0 in 27 | let f2 := @map A B f in 28 | let f3 := @map A C g in 29 | (forall (H5 H7 : Type) (l' : list H7), @zip H5 H7 [] l' = []) -> 30 | (forall (H7 H9 : Type) (H10 : H7) (H11 : list H7), @zip H7 H9 (H10 :: H11) [] = []) -> 31 | (forall (H7 H9 : Type) (H10 : H7) (H11 : list H7) (h : H9) (l : list H9), 32 | @zip H7 H9 (H10 :: H11) (h :: l) = (H10, h) :: @zip H7 H9 H11 l) -> 33 | f1 [] = [] -> 34 | (forall (a : A) (l : list A), f1 (a :: l) = f0 a :: f1 l) -> 35 | f2 [] = [] -> 36 | (forall (a : A) (l : list A), f2 (a :: l) = f a :: f2 l) -> 37 | f3 [] = [] -> 38 | (forall (a : A) (l : list A), f3 (a :: l) = g a :: f3 l) -> 39 | (forall (x : Type) (x0 x1 : x) (x2 x3 : list x), x0 :: x2 = x1 :: x3 -> x0 = x1 /\ x2 = x3) -> 40 | (forall (x : Type) (x0 : x) (x1 : list x), [] = x0 :: x1 -> False) -> 41 | (forall (x x0 : Type) (x1 x2 : x) (x3 x4 : x0), (x1, x3) = (x2, x4) -> x1 = x2 /\ x3 = x4) -> 42 | f1 [] = @zip B C (f2 []) (f3 [])). 43 | Proof. intros. elimination_polymorphism. Abort. 44 | 45 | End poly. 46 | 47 | Section tests_for_decidable_relations. 48 | 49 | Variable (A : Type). 50 | Variable (HA : CompDec A). 51 | 52 | Fixpoint smaller_dec_bis (l l' : list A) := 53 | match l with 54 | | nil => true 55 | | cons x xs => false 56 | end 57 | || 58 | match l with 59 | | nil => false 60 | | cons x xs => match l' with 61 | | nil => false 62 | | cons x' xs' => smaller_dec_bis xs xs' 63 | end 64 | end. 65 | 66 | Goal forall (l l' l'' : list A) (x : A), 67 | smaller_dec_bis l l' -> l' = [] -> l <> cons x l''. 68 | Proof. snipe. Qed. 69 | 70 | End tests_for_decidable_relations. 71 | 72 | Section tests. 73 | 74 | Goal ((forall (A : Type) (l : list A), 75 | length l = match l with 76 | | [] => 0 77 | | _ :: xs => S (length xs) 78 | end) -> True). 79 | intro H. 80 | eliminate_dependent_pattern_matching H. 81 | exact I. 82 | Qed. 83 | 84 | Definition true_hidden := true. 85 | Definition definition_no_variables := if true_hidden then 1=1 else 2=2. 86 | 87 | Goal definition_no_variables -> True. 88 | intros. 89 | unfold definition_no_variables in H. 90 | eliminate_dependent_pattern_matching H. 91 | Abort. 92 | 93 | Lemma if_var_in_context x y : (if Nat.eqb x y then x = x else y = y) -> True. 94 | intros H. 95 | scope. 96 | Abort. 97 | 98 | Lemma nth_default_eq : 99 | forall (A : Type) (HA : CompDec A) n l (d:A), nth_default d l n = nth n l d. 100 | Proof. intros A HA n ; induction n. 101 | - snipe. 102 | - intros l ; destruct l. 103 | * snipe. 104 | * scope. get_projs_st option. (* specialize (gen_option A d). *) 105 | (* verit does not succed because p and p0 are not Zified by trakt (see "Preprocessing" channel *) 106 | Abort. 107 | 108 | (* Test polymorphism *) 109 | Goal (forall (A B : Type) (x1 x2 : A) (y1 y2 : B), 110 | (x1, y1) = (x2, y2) -> (x1 = x2 /\ y1 = y2)) -> ((forall (x1 x2 : bool) (y1 y2 : nat), 111 | (x1, y1) = (x2, y2) -> (x1 = x2 /\ y1 = y2)) /\ (forall (x1 x2 : nat) (y1 y2 : bool), 112 | (x1, y1) = (x2, y2) -> (x1 = x2 /\ y1 = y2)) /\ (forall (x1 x2 : bool) (y1 y2 : bool), 113 | (x1, y1) = (x2, y2) -> (x1 = x2 /\ y1 = y2))). 114 | intro H. elimination_polymorphism. split. assumption. split. assumption. assumption. 115 | Qed. 116 | 117 | (* Test projs *) 118 | Variable A : Type. 119 | Variable a : A. 120 | 121 | Goal forall (n : nat) (l : list A)(x : A) (xs: list A), l = nil \/ l = cons x xs. 122 | Proof. 123 | get_projs_in_goal. 124 | Abort. 125 | 126 | Variable HA : CompDec A. 127 | 128 | Definition search := 129 | fix search {A : Type} {H : CompDec A} (x : A) (l : list A) {struct l} : bool := 130 | match l with 131 | | [] => false 132 | | x0 :: l0 => orb (eqb_of_compdec H x x0) (search x l0) 133 | end. 134 | 135 | Local Open Scope list_scope. 136 | Import ListNotations. 137 | 138 | Lemma search_append_neq : 139 | forall l1 l2 l3 x, search x (l1 ++ l2) <> search x l3 -> l1 ++ l2 <> l3. 140 | Proof. 141 | Time snipe. Qed. 142 | 143 | 144 | Open Scope list_scope. 145 | 146 | Import ListNotations. 147 | Variable a_0 : A. 148 | 149 | (** The boolean In *) 150 | Fixpoint Inb (a:A) (l:list A) : bool := 151 | match l with 152 | | [] => false 153 | | b :: m => orb (eqb_of_compdec HA a b) (Inb a m) 154 | end. 155 | 156 | 157 | (* 158 | Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l. 159 | Proof. 160 | Time snipe. 161 | Abort. *) 162 | 163 | Lemma hd_error_tl_repr : forall l (a:A) r, 164 | hd_error l = Some a /\ tl l = r <-> l = a :: r. 165 | Proof. Time snipe. 166 | Qed. 167 | 168 | Lemma hd_error_some_nil : forall l (a:A), hd_error l = Some a -> l <> nil. 169 | Proof. 170 | Time snipe_no_check. 171 | Qed. 172 | 173 | Theorem hd_error_nil : hd_error (@nil A) = None. 174 | Proof. 175 | Time snipe_no_check. 176 | Qed. 177 | 178 | 179 | (* Theorem in_eq : forall (a:A) (l:list A), Inb a (a :: l) = true. 180 | Proof. 181 | Time snipe. 182 | Qed. *) 183 | 184 | Theorem in_cons : forall (a b:A) (l:list A), Inb b l = true -> Inb b (a :: l) = true. 185 | Proof. 186 | Time snipe_no_check. 187 | Qed. 188 | 189 | Theorem not_in_cons (x b : A) (l : list A): 190 | ~ Inb x (a::l) = true <-> x<>a /\ ~ Inb x l = true. 191 | Proof. 192 | Time snipe_no_check. 193 | Qed. 194 | 195 | Theorem in_nil : forall a:A, ~ Inb a nil. 196 | Proof. 197 | Time snipe_no_check. 198 | Qed. 199 | 200 | Lemma in_inv : forall (a b:A) (l:list A), Inb b (a :: l) -> a = b \/ Inb b l. 201 | Proof. 202 | Time snipe. 203 | Qed. 204 | 205 | Theorem app_cons_not_nil : forall (x y:list A) (a:A), nil <> ((a :: y) ++ x). 206 | Proof. 207 | Time snipe_no_check. 208 | Qed. 209 | 210 | Theorem app_nil_l : forall l:list A, [] ++ l = l. 211 | Proof. 212 | Time snipe_no_check. 213 | Qed. 214 | 215 | Theorem app_nil_r : forall l:list A, l ++ [] = l. 216 | Proof. 217 | Time induction l ; snipe_no_check. 218 | Qed. 219 | 220 | Theorem app_nil_end : forall (l:list A), l = l ++ []. 221 | Proof. pose proof app_nil_r. snipe_no_check. Qed. 222 | 223 | Theorem app_assoc : forall l m n:list A, (l ++ m ++ n) = ((l ++ m) ++ n). 224 | Proof. 225 | Time intros l ; induction l ; snipe_no_check. 226 | Qed. 227 | 228 | Theorem app_assoc_reverse : forall l m n:list A, ((l ++ m) ++ n) = (l ++ m ++ n). 229 | Proof. 230 | pose proof app_assoc. Time snipe_no_check. 231 | Qed. 232 | 233 | Theorem app_comm_cons : forall (x y:list A) (a:A), (a :: (x ++ y)) = ((a :: x) ++ y). 234 | Proof. 235 | Time snipe_no_check. 236 | Qed. 237 | 238 | Theorem app_eq_nil' : forall l l':list A, 239 | (l ++ l') = nil -> l = nil /\ l' = nil. 240 | Proof. 241 | Time snipe_no_check. Qed. 242 | 243 | Theorem app_eq_unit : 244 | forall (x y:list A) (a:A), 245 | x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil. 246 | Proof. 247 | Time snipe_no_check. Qed. 248 | 249 | Lemma app_inj_tail : 250 | forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b. 251 | Proof. 252 | Time induction x ; snipe_no_check. 253 | Qed. 254 | 255 | Lemma in_app_or : forall (l m:list A) (a:A), Inb a (l ++ m) -> or (Inb a l) (Inb a m). 256 | Proof. 257 | intros l m b. Time induction l; snipe_no_check. 258 | Qed. 259 | 260 | Lemma app_inv_head: 261 | forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2. 262 | Proof. 263 | Time induction l ; snipe_no_check. Qed. 264 | 265 | Goal forall (l : list A), l = [] -> hd_error l = None. 266 | snipe_no_check. Qed. 267 | 268 | End tests. 269 | 270 | Section Pairs. 271 | Variable A B : Type. 272 | Variable HA : CompDec A. 273 | Variable HB : CompDec B. 274 | 275 | Definition fst (p:A * B) := match p with (x, y) => x end. 276 | Definition snd (p:A * B) := match p with (x, y) => y end. 277 | 278 | Lemma surjective_pairing : 279 | forall (p:A * B), p = (fst p, snd p). 280 | Proof. Time snipe_no_check. Qed. 281 | 282 | End Pairs. 283 | 284 | Check N. 285 | 286 | (* `expand_hyp` shouldn't rely on the body of the symbol, but on the proof of equality *) 287 | Section expand_hyp_without_body. 288 | 289 | Variable x : nat. 290 | Variable f g : nat -> nat. 291 | Variable h1 : f 42 = 42. 292 | Variable h2 : g 42 = 42. 293 | Variable M : nat -> nat. 294 | Variable pf_refl : M = match x with | 0 => f | S _ => g end. 295 | 296 | Goal M 42 = 42. 297 | scope. 298 | Abort. 299 | 300 | End expand_hyp_without_body. 301 | 302 | (* Testing interaction of `pose_case` with other transformations - verit won't conclude the goal due to silent simplification *) 303 | Goal forall (x : nat) (f g : nat -> nat) , (f 2 = 2) -> (g 2 = 2) -> ((match x with O => f | S _ => g end) 2 = 2). 304 | Proof. 305 | scope. 306 | verit. 307 | Abort. 308 | 309 | Set Default Proof Mode "Classic". 310 | 311 | Definition p := fun x : nat => x > 3. 312 | 313 | Program Definition k : nat -> sig p -> nat -> sig p -> nat -> sig p := fun _ _ _ _ _ => exist _ 4 _. 314 | Next Obligation. 315 | unfold p. 316 | auto. 317 | Qed. 318 | 319 | Goal 4 > 3. 320 | elim_refinement_types k. 321 | assert (five: 5 > 3) by auto. 322 | exact (H 5 5 five 5 5 five 5). 323 | Qed. 324 | 325 | Fixpoint rep_sig (i : nat) : Set := 326 | match i with 327 | | 0 => nat 328 | | S i' => @sig (rep_sig i') (fun x => x = x) 329 | end. 330 | 331 | Goal True. 332 | convert_sigless h (rep_sig 100). 333 | trivial. 334 | Qed. 335 | 336 | Section CompCertExample. 337 | 338 | Local Open Scope Z_scope. 339 | 340 | (* The trigger does not work up to delta conversion, but the tactic does *) 341 | Inductive data : Type := Nil | Cons (lo hi: Z) (tl: data). 342 | 343 | Fixpoint ok (x : data) : bool := 344 | match x with 345 | | Nil => true 346 | | Cons l1 h1 s => 347 | match s with 348 | | Nil => l1 (l1 idtac 13 | (* Otherwise, add it in the local context *) 14 | | _ => 15 | let p := fresh "p" in 16 | assert (p:SMT_classes.CompDec t); 17 | [ try (exact _) (* Use the typeclass machinery *) 18 | | .. ] 19 | end | idtac]. 20 | 21 | Goal (forall (A: Type) (l : list A), False). 22 | intros. ltac1:(add_compdecs_terms A). Abort. 23 | -------------------------------------------------------------------------------- /theories/anonymous_functions.v: -------------------------------------------------------------------------------- 1 | Require Import utilities. 2 | Require Import List. 3 | From Ltac2 Require Import Ltac2. 4 | 5 | Ltac anonymous_fun f_body := 6 | let f' := fresh "f" in pose (f' := f_body); 7 | try fold f'; 8 | let tac := 9 | ltac2:(f' |- 10 | let hs := Control.hyps () in 11 | List.iter (fun (x, _, _) => 12 | ltac1:(f' x |- try (fold f' in x)) f' (Ltac1.of_ident x)) hs) 13 | in tac f'. 14 | 15 | Section tests. 16 | 17 | Set Default Proof Mode "Classic". 18 | 19 | Lemma bar : forall (A B C : Type) (l : list A) (f : A -> B) (g : B -> C), 20 | map g (map f l) = map (fun x => g (f x)) l. 21 | intros. 22 | assert (H : (fun x => x + 1) 42 = 43) by reflexivity. 23 | anonymous_fun (fun x : nat => x + 1). 24 | anonymous_fun (fun x : A => g (f x)). 25 | Abort. 26 | 27 | Goal (forall (A: Type) (n : nat) (l : list A) (x : A), 28 | (fun (n : nat) (l : list A) (default : A) => nth n l default) n l x = x -> 29 | (n >= (fun (l : list A) => length l) l)). 30 | Proof. intros. 31 | anonymous_fun (fun (A: Type) (n: nat) (l : list A) (d : A) => 32 | nth n l d). 33 | anonymous_fun (fun l0 : list A => length l0). Abort. 34 | 35 | End tests. 36 | 37 | 38 | -------------------------------------------------------------------------------- /theories/case_analysis_existentials.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Sniper *) 4 | (* Copyright (C) 2021 *) 5 | (* *) 6 | (* See file "AUTHORS" for the list of authors *) 7 | (* *) 8 | (* This file is distributed under the terms of the CeCILL-C licence *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | 13 | Require Import utilities. 14 | Require Import instantiate_type. 15 | Require Import MetaCoq.Template.All. 16 | Require Import String. 17 | Require Import List. 18 | Require Import ZArith. 19 | Require Import interpretation_algebraic_types. 20 | Require Import case_analysis. 21 | Unset MetaCoq Strict Unquote Universe Mode. 22 | 23 | Local Open Scope bs_scope. 24 | 25 | (** Generates the generation statement in a non-constructive way: 26 | the projection functions are replaced by existentials : 27 | see the example st_list *) 28 | 29 | Fixpoint statement_one_constructor 30 | (n : nat) (* De Brujin index of the list we consider *) 31 | (n' : nat) (* the number of arguments of the constructor *) 32 | (c : term) (* the constructor not applied to its parameters *) 33 | (largs : list term) (* the list of the arguments of the constructor, initialized with the parameters 34 | and updated with one variable after one recursive call *) 35 | := match n' with 36 | | 0 => mkEq hole (tRel n) (tApp c largs) 37 | | S n' => tApp <% ex %> [hole ; 38 | tLambda (mkNamed "x") hole (statement_one_constructor (S n) n' c ((List.map (lift 1 0) largs)++[tRel 0])) ] 39 | end. 40 | 41 | Definition statement_constructors 42 | (I : term) (* the inductive we want to deal with *) 43 | (typars : list term) (* the type of the parameters *) 44 | (lc : list term) (* the constructors of the inductive (not applied) *) 45 | (largs : list nat) (* for each constructor, the number of their non parametric arguments *) 46 | := 47 | let n := Datatypes.length typars in 48 | let lpars := Rel_list n 0 in 49 | let fix aux lpars lc largs := 50 | match lc, largs with 51 | | [], [] => [] 52 | | c :: lc', args :: largs' => statement_one_constructor 0 args c lpars :: aux lpars lc' largs' 53 | | _, _ => [] 54 | end 55 | in 56 | mkProd_rec typars (mkProdName "t" (tApp I lpars) (mkOr_n (aux (List.map (lift 1 0) lpars) lc largs))). 57 | 58 | Definition statement_list := statement_constructors <%@list %> [<% Type %>] [<%@nil%> ; <%@cons%>] [0 ; 2]. 59 | 60 | MetaCoq Unquote Definition st_list := statement_list. 61 | 62 | (* Print st_list. 63 | st_list = 64 | forall (x : Type) (t : list x), 65 | t = [] \/ (exists (x0 : x) (x1 : list x), t = x0 :: x1) 66 | : Prop *) 67 | 68 | MetaCoq Quote Recursively Definition list_reif_rec := @list. 69 | 70 | Fixpoint skipn_forall (n : nat) (t : term) := 71 | match n with 72 | | 0 => t 73 | | S n' => 74 | match t with 75 | | tProd _ _ u => skipn_forall n' u 76 | | _ => t 77 | end 78 | end. 79 | 80 | Definition get_nb_args_not_params (t : term) (npars : nat) := 81 | let t' := skipn_forall npars t in 82 | let fix aux t' n := 83 | match t' with 84 | | tProd _ _ u => aux u (S n) 85 | | _ => n 86 | end in aux t' 0. 87 | 88 | (* generates two lists : the constructors and the number of their arguments *) 89 | Fixpoint find_nb_args_constructors_and_ctors 90 | (I : inductive) (inst : Instance.t) (npars n : nat) (l : list ((ident × term) × nat)) 91 | := 92 | match l with 93 | | [] => ([], []) 94 | | x :: xs => 95 | let resu := find_nb_args_constructors_and_ctors I inst npars (S n) xs in 96 | let nb := get_nb_args_not_params x.1.2 npars in 97 | (tConstruct I n inst :: resu.1, nb :: resu.2) 98 | end. 99 | 100 | Definition get_indu_and_instance (t : term) := 101 | match t with 102 | | tInd Ind inst => (Ind, inst) 103 | | _ => ( {| 104 | inductive_mind := 105 | (MPfile ["utilities"; "theories"; "Sniper"], 106 | "impossible_term"); 107 | inductive_ind := 0 108 | |}, []) 109 | end. 110 | 111 | Definition dest_app (t : term) := 112 | match t with 113 | | tApp u v => (u, v) 114 | | _ => (t, []) 115 | end. 116 | 117 | Ltac prove_by_destruct_varn n := 118 | match n with 119 | | 0 => 120 | let x := fresh in 121 | intro x ; destruct x; repeat eexists ; repeat first [ left ; progress (eauto) | first [right | eauto]] 122 | | S ?m => let y := fresh in intro y ; prove_by_destruct_varn m 123 | end. 124 | 125 | Ltac gen_statement_existentials I H := 126 | let I_reif := metacoq_get_value (tmQuoteRec I) in 127 | let res0 := eval cbv in (dest_app I_reif.2) in 128 | let I_no_app := eval cbv in (res0.1) in 129 | let params := eval cbv in (res0.2) in 130 | let len_params := eval cbv in (Datatypes.length params) in 131 | let indu := eval cbv in (info_inductive I_reif.1 I_no_app ) in 132 | let constructors := eval cbv in (info_nonmutual_inductive I_reif.1 I_no_app).2 in 133 | match indu with 134 | | Some ?i => 135 | let info_params := eval cbv in (get_params_from_mind i) in 136 | let npars := eval cbv in info_params.1 in 137 | let typars := eval cbv in info_params.2 in 138 | let res1 := eval cbv in (get_indu_and_instance I_no_app) in 139 | let indu := eval cbv in res1.1 in 140 | let inst := eval cbv in res1.2 in 141 | let res2 := eval cbv in (find_nb_args_constructors_and_ctors indu inst npars 0 142 | (get_na_nb_args_type_list_constructor_body constructors)) in 143 | let largs := eval cbv in res2.2 in 144 | let lc := eval cbv in res2.1 in 145 | let gen_st_reif := eval cbv in (statement_constructors I_no_app typars lc largs) in 146 | let gen_st_reif_instances := eval cbv in (subst params 0 (skipn_forall len_params gen_st_reif)) in 147 | let gen_st := metacoq_get_value (tmUnquoteTyped Prop gen_st_reif_instances) in 148 | let nb_vars_intro := eval cbv in (npars-len_params) in 149 | assert (H : gen_st) by (prove_by_destruct_varn (nb_vars_intro)) 150 | | None => fail 151 | end. 152 | 153 | Section test_gen_statement. 154 | 155 | Goal False. 156 | gen_statement_existentials nat H. clear. 157 | gen_statement_existentials list H. clear. 158 | gen_statement_existentials @nelist H. clear. 159 | gen_statement_existentials @biclist H. clear. 160 | gen_statement_existentials Ind_test H. clear. 161 | gen_statement_existentials Ind_test2 H. clear. 162 | gen_statement_existentials (@list nat) H. clear. 163 | Abort. 164 | 165 | End test_gen_statement. 166 | 167 | (* Checks if a given term is a variable *) 168 | Ltac is_var v := 169 | let v_reif := metacoq_get_value (tmQuote v) in 170 | match v_reif with 171 | | tVar _ => idtac 172 | | _ => fail 173 | end. 174 | 175 | (* Returns the tuple of variables in a local context *) 176 | Ltac vars := 177 | match goal with 178 | | v : _ |- _ => let _ := match goal with _ => is_var v ; revert v end in let acc := vars in 179 | let _ := match goal with _ => intro v end in constr:((v, acc)) 180 | | _ => constr:(unit) 181 | end. 182 | 183 | Ltac get_gen_statement_for_variables_in_context := 184 | let t := vars in 185 | let rec tac_rec v := 186 | match v with 187 | | (?v1, ?v') => let T := type of v1 in first [ let U := type of T in constr_eq U Prop ; tac_rec v' | 188 | first [let H := fresh in 189 | gen_statement_existentials T H; specialize (H v1) ; try (tac_rec v') | tac_rec v' ]] 190 | | _ => idtac 191 | end in tac_rec t. 192 | 193 | Section test_vars_in_context. 194 | 195 | Goal forall (A: Type) (x : list nat) (y : nat) (u : list A), 1 = 2 -> False. 196 | Proof. intros ; get_gen_statement_for_variables_in_context. inversion H. Qed. 197 | 198 | End test_vars_in_context. 199 | 200 | -------------------------------------------------------------------------------- /theories/deciderel/add_hypothesis_on_parameters.v: -------------------------------------------------------------------------------- 1 | From MetaCoq.Template Require Import All. 2 | Require Import String. 3 | Require Import List. 4 | Import ListNotations. 5 | Require Import utilities. 6 | Unset MetaCoq Strict Unquote Universe Mode. 7 | 8 | (** The purpose of this file is to transform an 9 | inductive of type [A1 -> ... -> An -> B1 -> ... Bm], 10 | (where the Ais are parameters and the Bjs are indexes) 11 | into a new inductive of type 12 | [A1 -> P A1 -> ... -> An -> P An -> B1 ... -> Bm]. 13 | [P] is a property on types (think of [EqDec], or in the SMTCoq case, 14 | of [CompDec]) *) 15 | 16 | Section P. 17 | 18 | Variable P : term. 19 | Definition P_app := 20 | tApp P [tRel 0]. 21 | 22 | (* As the source is the type A1 -> ... -> An 23 | and the target is the type A1 -> P A1 -> A2 -> P A2 ... -> An -> P An, 24 | we need to lift the first variable n times, the second variable n-1 times and so on *) 25 | Fixpoint liftn_aux (n n' : nat) (t : term) := 26 | match n with 27 | | 0 => t 28 | | S m => lift 1 n' (liftn_aux m (S n') t) 29 | end. 30 | 31 | Definition liftn (n : nat) (t : term) := liftn_aux n 0 t. 32 | 33 | Fixpoint add_trm_parameter_aux 34 | (t : term) (* the term considered *) 35 | (n : nat) (* the db index of the inductive of interest *) 36 | (lrel : list term) (* the new parameters of the inductive considered (P A1) ... (P An) *) 37 | (fuel : nat) : term := 38 | let len := Datatypes.length lrel in 39 | match fuel with 40 | | 0 => default_reif 41 | | S m => 42 | match t with 43 | | tProd Na u v => 44 | let u' := match u with 45 | | tApp (tRel k) l => 46 | if Nat.eqb n k then tApp (tRel (k+ len)) (List.map (lift len 0) (List.firstn len l) ++ lrel ++ 47 | (List.map (lift len (n - 1)) (List.skipn len l))) 48 | else (liftn_aux len (n - len) u) 49 | | _ => (liftn_aux len (n - len) u) 50 | end in 51 | tProd Na u' (add_trm_parameter_aux v (S n) (List.map (lift 1 0) lrel) m) 52 | | tApp u l => match u with 53 | | tRel k => 54 | if Nat.eqb n k then tApp (tRel (k+ len)) (List.map (lift len 0) (List.firstn len l) ++ lrel ++ 55 | (List.map (lift len (n - 1)) (List.skipn len l))) 56 | else tApp u l 57 | | _ => lift len 0 t 58 | end 59 | | _ => lift len 0 t 60 | end 61 | end. 62 | 63 | (* Auxiliary functions to find a new suitable name *) 64 | Definition find_name_trm : ident := 65 | match P with 66 | | tInd i _ => ("H"++(i.(inductive_mind)).2)%bs 67 | | tConst k _ => k.2 68 | | _ => "new_ident"%bs 69 | end. 70 | 71 | Definition trm_aname (na : aname) := 72 | let new_name := 73 | match na.(binder_name) with 74 | | nNamed id => nNamed (find_name_trm++id)%bs 75 | | nAnon => nNamed find_name_trm 76 | end in 77 | {| binder_name := new_name; binder_relevance := na.(binder_relevance) |}. 78 | 79 | Definition is_prop (s: sort) := 80 | match s with 81 | | sProp => true 82 | | _ => false 83 | end. 84 | 85 | Fixpoint add_trm_for_each_poly_var (t: term) (acc: list term) (fuel : nat) : term := 86 | match t with 87 | | tProd Na u v => 88 | match u with 89 | | tSort s => 90 | if negb (is_prop s) then 91 | let acc' := (List.map (lift 1 0) acc) ++ [tRel 0] in 92 | tProd Na (tSort s) (mkProdName (find_name_trm) P_app (add_trm_for_each_poly_var v acc' fuel)) 93 | else 94 | let len := Datatypes.length acc in (add_trm_parameter_aux t len acc fuel) 95 | | _ => let len := Datatypes.length acc in add_trm_parameter_aux t len acc fuel 96 | end 97 | | _ => let len := Datatypes.length acc in add_trm_parameter_aux t len acc fuel 98 | end. 99 | 100 | Fixpoint fuel_trm t := 101 | match t with 102 | | tProd _ u v => fuel_trm u + fuel_trm v + 1 103 | | _ => 1 104 | end. 105 | 106 | Definition add_trm_parameter (t : term) := 107 | let fuel := fuel_trm t in 108 | add_trm_for_each_poly_var t [] fuel. 109 | 110 | End P. 111 | 112 | Section tests. 113 | 114 | Variable (P : Type -> Type). 115 | 116 | MetaCoq Unquote Definition 117 | trm_unq := (add_trm_parameter <% P %> <% forall (A : Type) (a : A), list A -> list A -> Prop %>). 118 | 119 | MetaCoq Unquote Definition 120 | trm_unq2 := (add_trm_parameter <% P %> <% forall (A : Type) (B: Type), A -> B -> Prop %>). 121 | 122 | (* Print trm_unq. *) 123 | (* Print trm_unq2. *) 124 | 125 | End tests. 126 | -------------------------------------------------------------------------------- /theories/deciderel/examples.v: -------------------------------------------------------------------------------- 1 | From MetaCoq.Template Require Import All. 2 | Unset MetaCoq Strict Unquote Universe Mode. 3 | From SMTCoq Require Import SMTCoq. 4 | From Sniper.orchestrator Require Import Sniper. 5 | Import MCMonadNotation. 6 | Require Import List. 7 | Import ListNotations. 8 | Require Import String. 9 | Require Import ZArith. 10 | Require Import Bool. 11 | Require Import proof_correctness. 12 | Import Decide. (* We import the module containing the main command *) 13 | 14 | 15 | Section Examples. 16 | (* A first example : 17 | - mem n l is true whenever n belongs to l 18 | - the plugin linearize the type of MemMatch because n is mentionned twice (and 19 | we want to define a function by pattern matching so we need fresh pattern variables) 20 | - then it generates an equivalent boolean fixpoint defined by pattern matching 21 | on the list 22 | - it also generates the correctness lemma and uses a tactic based on 23 | heuristics to inhabitate it 24 | *) 25 | Inductive mem : Z -> list Z -> Prop := 26 | MemMatch : forall (xs : list Z) (n : Z), mem n (n :: xs) 27 | | MemRecur : forall (xs : list Z) (n n' : Z), mem n xs -> mem n (n' :: xs). 28 | 29 | (* running the main command *) 30 | MetaCoq Run (decide mem []). 31 | Next Obligation. 32 | (* the proof can be automatized thanks to tactics : 33 | it generates a proof term decidable_proof that we use here 34 | *) 35 | apply decidable_proof. Qed. 36 | 37 | (* Another parametric example : 38 | the predicate smaller_than_all holds between a 39 | natural number and a list of integers whenever the term is 40 | smaller than all the elements of the list 41 | Here, we need to pass the quotations of Z.le, the boolean version of Z.le and the proof 42 | of equivalence as arguments to the command 43 | *) 44 | 45 | Inductive smaller_than_all : Z -> list Z -> Prop := 46 | | sNil : forall n, smaller_than_all n nil 47 | | sCons : forall n n' l, BinInt.Z.le n n' -> smaller_than_all n l -> smaller_than_all n (n' :: l). 48 | 49 | 50 | (* Here the proof should be done manually because we need to use an 51 | intermediate lemma Z.leb_le *) 52 | MetaCoq Run (decide (smaller_than_all) [(<%Z.le%>, <%Z.leb%>, <%Z.leb_le%>)]). 53 | Next Obligation. 54 | split. 55 | - intros H1. induction H1; auto. 56 | simpl. apply Z.leb_le in H. rewrite H. rewrite IHsmaller_than_all. auto. 57 | - intros H1. induction H0. constructor. simpl in H1; 58 | elim_and_and_or. constructor. apply Z.leb_le. assumption. apply IHlist. assumption. Qed. 59 | 60 | 61 | (* Example of proof automation with snipe and the decided predicates *) 62 | 63 | Lemma mem_imp_not_nil_fail : (forall (n : Z) (l : list Z), 64 | mem n l -> l <> []). 65 | Proof. Fail snipe. (* snipe does not know about inductive predicates *) Abort. 66 | 67 | (* We add to Trakt's database the information that mem_linear_decidable 68 | is a decidable version of mem and the proof of this fact 69 | and snipe will use it to reason about the boolean function instead 70 | of the predicate *) 71 | 72 | Trakt Add Relation 2 (mem) (mem_linear_decidable) (decidable_lemma). 73 | 74 | Require Import elimination_pattern_matching. 75 | 76 | Lemma mem_imp_not_nil : (forall (n : Z) (l : list Z), 77 | mem n l -> l <> []). 78 | Proof. trakt bool; snipe_no_check. Qed. 79 | 80 | (* We do the same for smaller_than_all *) 81 | Trakt Add Relation 2 (smaller_than_all) (smaller_than_all_decidable) (decidable_lemma0). 82 | 83 | Lemma smaller_than_all_nil : (forall (z: Z), smaller_than_all z nil). 84 | Proof. trakt bool; snipe_no_check. Qed. 85 | 86 | (* An example with an inductive type which takes a parameter: 87 | all the elements of the list are smaller than the one given as parameters *) 88 | 89 | Inductive elt_smaller_than (n : nat) : list nat -> Prop := 90 | | smThanNil : elt_smaller_than n nil 91 | | smThanCons : forall (n' : nat) (l : list nat), Nat.le n' n -> elt_smaller_than n l -> 92 | elt_smaller_than n (n' :: l). 93 | 94 | MetaCoq Run (decide (elt_smaller_than) [(<%Nat.le%>, <%Nat.leb%>, <%Nat.leb_le%>)]). 95 | Next Obligation. 96 | split. 97 | - intro Hyp. induction Hyp. auto. simpl. rewrite IHHyp. simpl. rewrite Nat.leb_le. 98 | assumption. 99 | - intros Hyp. induction H. constructor. constructor; simpl in Hyp; 100 | elim_and_and_or. apply Nat.leb_le. assumption. apply IHlist. assumption. Qed. 101 | 102 | Trakt Add Relation 2 (elt_smaller_than) (elt_smaller_than_decidable) (decidable_lemma1). 103 | 104 | (* Lemma smaller_than_mem : 105 | forall (n n' : Z) (l : list Z), smaller_than_all n l -> mem n' l -> Z.le n n'. 106 | Proof. 107 | intros n n' l H1 H2. induction l; snipe. Qed. TODO silent simplifications veriT *) 108 | 109 | (* An example with instantiated polymorphic types : 110 | the inductive says that second list is smaller than the second one 111 | We do not handle polymorphism (with an hypothesis of decidable equality whenever it is needed) 112 | for now because Trakt does not either 113 | *) 114 | 115 | Inductive smaller_list {A : Type} : list A -> list A -> Prop := 116 | | smNil : forall l, smaller_list [] l 117 | | smCons: forall l l' x x', smaller_list l l' -> smaller_list (x :: l) (x' :: l'). 118 | 119 | MetaCoq Run (decide (@smaller_list nat) []). 120 | Next Obligation. 121 | split. 122 | - revert_all ; ltac2:(completeness_auto_npars 'smaller_list_decidable 0). 123 | - revert_all. induction H. constructor. destruct H0 eqn:E; intro H1; inversion H1. 124 | constructor. apply IHlist. assumption. Qed. 125 | 126 | Variable A : Type. 127 | Variable HA : CompDec A. (* commenting this line makes the command fail because of 128 | universe instances *) 129 | 130 | MetaCoq Run (decide (@Add) []). 131 | Next Obligation. intros A0 H a l1 l2. 132 | split. 133 | - intro H1. induction H1. destruct l; simpl. rewrite eqb_of_compdec_reflexive. auto. 134 | rewrite eqb_of_compdec_reflexive. rewrite eqb_of_compdec_reflexive. auto. 135 | simpl. rewrite eqb_of_compdec_reflexive. rewrite IHAdd. rewrite orb_comm. 136 | auto. 137 | - revert l2. induction l1. intro l2. intro H1. 138 | destruct l2. simpl in H1. inversion H1. 139 | simpl in H1. elim_and_and_or; elim_eq. unfold is_true in H0. 140 | unfold is_true in H1. rewrite <- compdec_eq_eqb in H1. rewrite <- compdec_eq_eqb in H0. 141 | subst. constructor. 142 | intros. simpl in H0. destruct l2 ; simpl in *. 143 | inversion H0. elim_and_and_or; unfold is_true in * ; elim_eq. subst. constructor. 144 | subst. constructor. apply IHl1. assumption. 145 | Qed. 146 | 147 | (* Trakt does not handle polymorphism yet but Deciderel deals with polymorphism with 148 | CompDec hypothesis *) 149 | 150 | End Examples. 151 | 152 | 153 | -------------------------------------------------------------------------------- /theories/elimination_pattern_matching.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Sniper *) 4 | (* Copyfalse (C) 2021 *) 5 | (* *) 6 | (* See file "AUTHORS" for the list of authors *) 7 | (* *) 8 | (* This file is distributed under the terms of the CeCILL-C licence *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | 13 | Require Import MetaCoq.Template.All. 14 | Require Import String. 15 | Require Import utilities. 16 | Require Import reflexivity. 17 | Require Import unfold_reflexivity. 18 | Require Import elimination_fixpoints. 19 | Require Import expand. 20 | Require Import List. 21 | Import ListNotations. 22 | 23 | Ltac create_evars_for_each_constructor i := 24 | let i_reif := metacoq_get_value (tmQuote i) in 25 | match i_reif with 26 | | tInd (?indu ?kn _) ?inst => 27 | let y := metacoq_get_value (tmQuoteInductive kn) in 28 | let n:= eval cbv in (get_nb_constructors_dcl y) in 29 | let rec tac_rec u := match constr:(u) with 30 | | 0 => idtac 31 | | S ?m => let H' := fresh in let H'_evar := fresh H' in epose (H' := ?[H'_evar] : Prop) ; tac_rec m 32 | end in tac_rec n 33 | | _ => idtac 34 | end. 35 | 36 | Goal True. 37 | create_evars_for_each_constructor bool. 38 | create_evars_for_each_constructor unit. 39 | create_evars_for_each_constructor nat. 40 | Abort. 41 | 42 | Ltac intro_and_tuple_rec n l := 43 | match constr:(n) with 44 | | 0 => let u := fresh in let _ := match goal with _ => intro u end in constr:((u, l)) 45 | | S ?m => let H := fresh in let _ := match goal with _ => intro H end in intro_and_tuple_rec m (H, l) 46 | end. 47 | 48 | Ltac intro_and_tuple n := 49 | intro_and_tuple_rec n unit. 50 | 51 | Ltac intro_return_vars_aux l := 52 | lazymatch goal with 53 | | |- forall _, forall _, _ => let H := fresh in 54 | let _ := match goal with _ => intro H end in intro_return_vars_aux (H, l) 55 | | |- forall _, _ => let H := fresh in let _ := match goal with _ => intro H end in constr:(l) 56 | | _ => constr:(l) 57 | end. 58 | 59 | Ltac intro_return_vars := intro_return_vars_aux default. 60 | 61 | Ltac specialize_tuple p H := 62 | lazymatch constr:(p) with 63 | | (?x, ?y) => specialize_tuple y H ; try (specialize (H x)) 64 | | default => idtac 65 | end. 66 | 67 | Goal forall (A : Type) (l : list A) (n : nat), False. 68 | assert (foo : forall (A : Type) (l : list A) (n : nat), l = l) by reflexivity. 69 | let x := intro_return_vars in specialize_tuple x foo. Abort. 70 | 71 | 72 | Ltac revert_tuple_clear p indu := 73 | lazymatch constr:(p) with 74 | | (?x, ?y) => match indu with 75 | | context [x] => clear x 76 | | _ => revert x 77 | end 78 | ; revert_tuple_clear y indu 79 | | unit => idtac 80 | end. 81 | 82 | Definition head_tuple (A B : Type) (x : A×B) := match x with 83 | |(y, z) => y 84 | end. 85 | 86 | Definition tail_tuple (A B : Type) (x : A*B) := match x with 87 | |(y, z) => z 88 | end. 89 | 90 | Ltac detect_var_match H := 91 | 92 | let T := type of H in 93 | let H' := fresh in 94 | assert (H' : False -> T) by 95 | (match goal with | |-context C[match ?x with _ => _ end] => idtac end; let Hfalse := fresh in 96 | intro Hfalse; destruct Hfalse) ; clear H' ; idtac. 97 | 98 | Ltac remove_app t := 99 | lazymatch constr:(t) with 100 | | ?u ?v => remove_app u 101 | | _ => t 102 | end. 103 | 104 | Goal forall (A : Type) (x: list A), x = x. 105 | Proof. intros. let T := type of x in let T' := remove_app T in pose T'. 106 | reflexivity. 107 | Qed. 108 | 109 | Ltac revert_count := 110 | let rec revert_count_rec n := 111 | match goal with 112 | | H : _ |- _ => let _ := match goal with _ => revert H end in revert_count_rec (S n) 113 | | _ => n 114 | end in revert_count_rec 0. 115 | 116 | Ltac contains t u := 117 | match t with 118 | | context [u] => idtac 119 | | _ => fail 120 | end. 121 | 122 | Ltac all_quantifers_introduced := 123 | lazymatch goal with 124 | | |- forall _, _ => fail 125 | | _ => idtac 126 | end. 127 | 128 | Ltac elim_match_with_no_forall H := 129 | let U := type of H in 130 | match U with 131 | | context C[match ?expr with _ => _ end] => 132 | let Ty := type of expr in 133 | let T' := remove_app Ty in 134 | create_evars_for_each_constructor T' ; 135 | let foo := fresh in 136 | assert (foo : False -> U) 137 | by (let Hfalse := fresh in 138 | intro Hfalse ; 139 | (case_eq expr) ; 140 | match goal with 141 | | u : Prop |- ?G => instantiate (u := G); destruct Hfalse 142 | end) ; clear foo ; 143 | repeat match goal with 144 | | u : Prop |-_ => let H0 := fresh in let u' := eval unfold u in u in assert (H0 : u') by 145 | (first [ try (rewrite H); reflexivity 146 | |intros ; match goal with 147 | | Hinv : _ |- _ => rewrite Hinv in H ; auto 148 | end]); try elim_match_with_no_forall H0 ; clear u 149 | end 150 | end ; clear H. 151 | 152 | (* Tests *) 153 | 154 | Fixpoint leb (n:nat)(m:nat) := 155 | match n,m with 156 | | 0,_ => true 157 | | (S _) , 0 => false 158 | | S n, S m => leb n m 159 | end. 160 | 161 | Lemma leb_le : forall n m, (leb n m = true) -> le n m. 162 | intros n. induction n. intros m. 163 | intros H. induction m. 164 | constructor. constructor. apply IHm. 165 | constructor. intros m. intro H. simpl in H. 166 | elim_match_with_no_forall H. Abort. 167 | 168 | 169 | Ltac eliminate_dependent_pattern_matching H := 170 | let n := fresh "n" in 171 | let T := fresh "T" in 172 | epose (n := ?[n_evar] : nat) ; 173 | epose (T := ?[T_evar]) ; 174 | let U := type of H in 175 | let H' := fresh in 176 | assert (H' : False -> U); 177 | [ let HFalse := fresh in 178 | intro HFalse; 179 | let rec tac_rec m x := 180 | match goal with 181 | | |- context C[match ?expr with _ => _ end] => match constr:(m) with 182 | | 0 => fail 183 | | S ?p => contains expr x ; instantiate (n_evar := p) ; 184 | let Ty := type of expr in let T' := remove_app Ty in 185 | instantiate (T_evar := T') 186 | end 187 | | |- forall _, _ => let y := fresh in intro y; tac_rec (S m) y 188 | | _ => fail 189 | end 190 | in 191 | tac_rec 0 ltac:(fresh) ; 192 | destruct HFalse 193 | | clear H' ; let indu := eval unfold T in T in 194 | create_evars_for_each_constructor indu ; let foo := fresh in assert 195 | (foo : False -> U) by 196 | (let Hfalse' := fresh in intro Hfalse' ; 197 | let nb_var := eval unfold n in n in 198 | let t := intro_and_tuple nb_var in 199 | match goal with 200 | |- context C[match ?expr with _ => _ end] => 201 | let var_match := eval cbv in (head_tuple _ _ t) in 202 | let var_to_revert := eval cbv in (tail_tuple _ _ t) in 203 | tryif (constr_eq var_match expr) 204 | then 205 | (case var_match ; 206 | let indu' := type of var_match in clear var_match ; 207 | revert_tuple_clear var_to_revert indu') 208 | else 209 | (case_eq expr ; 210 | let indu' := type of expr in revert var_match ; 211 | revert_tuple_clear var_to_revert indu') 212 | end 213 | ; match goal with 214 | | u : Prop |- ?G => instantiate (u := G) ; destruct Hfalse' end) 215 | ; clear foo ; 216 | repeat match goal with 217 | | u : Prop |-_ => let H0 := fresh in let u' := eval unfold u in u in assert (H0 : u') by 218 | first [ intros; rewrite H ; reflexivity 219 | | let hyps := intro_return_vars in specialize_tuple hyps H ; 220 | lazymatch goal with 221 | | Hrew : _ |- _ => solve [rewrite Hrew in H; assumption] 222 | end 223 | ] ; clear u ; try (eliminate_dependent_pattern_matching H0) end] ; clear H ; 224 | clear n; clear T. 225 | 226 | Tactic Notation "eliminate_dependent_pattern_matching" constr(H) := 227 | first [eliminate_dependent_pattern_matching H | elim_match_with_no_forall H]. 228 | 229 | Module Tests. 230 | 231 | Definition dumb_def (n m : nat) := match Nat.eqb n m with true => true | false => false end. 232 | 233 | Goal (forall n m : nat, dumb_def n m = false)-> False. 234 | intros. assert_refl dumb_def. 235 | unfold_refl H0. 236 | expand_hyp H0. 237 | eliminate_dependent_pattern_matching H1. 238 | assert_refl length. unfold_refl H1. expand_hyp H1. 239 | eliminate_fix_hyp H2. eliminate_dependent_pattern_matching H2. 240 | Abort. 241 | 242 | 243 | Lemma foo x y :( if (Nat.leb x y) then 2 + 2 = 4 else 3+4 = 6) -> False. 244 | intros. 245 | eliminate_dependent_pattern_matching H. 246 | Abort. 247 | 248 | Lemma bar: ( forall x y, if (Nat.leb x y) then 2 + 2 = 4 else 3+4 = 6) -> False. 249 | intros. eliminate_dependent_pattern_matching H. 250 | Abort. 251 | 252 | Lemma toto (A : Type) (x : list A) : 253 | match x with 254 | | nil => 0 = 0 255 | | y :: ys => ys = ys 256 | end 257 | -> True. 258 | Proof. intros. eliminate_dependent_pattern_matching H. 259 | exact I. Qed. 260 | 261 | 262 | Definition min1 (x : nat) := match x with 263 | | 0 => 0 264 | | S x => x 265 | end. 266 | Definition min1' := min1. 267 | 268 | Definition min1'' := min1'. 269 | 270 | Definition min1''' := min1''. 271 | 272 | 273 | MetaCoq Quote Definition hyp_cons_reif := ((forall (A: Type) (x : A) (a : A) (l : list A), 274 | @hd A x (@cons A a l) = match (@cons A a l) with 275 | | nil => x 276 | | y :: xs => y 277 | end)). 278 | 279 | Definition bool_pair := (bool * bool)%type. 280 | Inductive dep_type : Type -> Type := 281 | | ToBool : bool -> dep_type bool 282 | | ToUnit : bool -> dep_type unit. 283 | 284 | Definition dep_fun : bool -> bool_pair -> bool := fun d : bool => match d with 285 | | true => fst 286 | | false => snd 287 | end 288 | . 289 | 290 | Definition dep_match : forall (ω : bool_pair) (a : Type) (D : dep_type a), (match D with 291 | | ToBool _ => bool 292 | | ToUnit _ => unit 293 | end) -> bool := 294 | fun ω a D => match D with 295 | | ToBool d => fun x => Bool.eqb (dep_fun d ω) x 296 | | ToUnit d => fun x => true 297 | end. 298 | 299 | 300 | Goal True. 301 | assert_refl Nat.add. unfold_refl H. expand_hyp H. eliminate_fix_hyp H0. 302 | eliminate_dependent_pattern_matching H0. 303 | assert_refl dep_match. 304 | unfold_refl H0. 305 | expand_hyp H0. 306 | clear - H1. eliminate_dependent_pattern_matching H1. 307 | Abort. 308 | 309 | Fixpoint nth {A : Type} (n:nat) (l:list A) (default:A) {struct l} : A := 310 | match n, l with 311 | | O, x :: l' => x 312 | | O, _other => default 313 | | S m, [] => default 314 | | S m, x :: t => nth m t default 315 | end. 316 | 317 | Goal False. 318 | assert_refl @nth. unfold_refl H. 319 | expand_hyp H. 320 | eliminate_fix_hyp H0. 321 | eliminate_dependent_pattern_matching H0. 322 | assert_refl @nth_default. unfold_refl H0. 323 | expand_hyp H0. 324 | eliminate_dependent_pattern_matching H1. 325 | Abort. 326 | 327 | End Tests. 328 | -------------------------------------------------------------------------------- /theories/expand.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Sniper *) 4 | (* Copyright (C) 2021 *) 5 | (* *) 6 | (* See file "AUTHORS" for the list of authors *) 7 | (* *) 8 | (* This file is distributed under the terms of the CeCILL-C licence *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | Require Import MetaCoq.Template.All. 13 | Require Import utilities. 14 | Require Import reflexivity. 15 | Require Import unfold_reflexivity. 16 | Require Import unfold_in. 17 | Require Import List. 18 | Import ListNotations. 19 | Require Import String. 20 | 21 | Definition list_of_args_and_codomain (t : term) := 22 | let fix aux acc t := 23 | match t with 24 | | tProd _ t1 t2 => aux (t1 :: acc) t2 25 | | _ => (acc, t) 26 | end in aux [] t. 27 | 28 | Unset Guard Checking. (* Not dangerous: we do not use this function in proofs ! *) 29 | 30 | (* Takes a term, if it is a function or a fixpoint 31 | returns the names of its arguments, otherwise returns []. 32 | The goal is to improve names generation in Sniper *) 33 | 34 | Fixpoint get_names_args_fix (f : mfixpoint term) := 35 | match f with 36 | | [] => [] 37 | | {| dname := _ ; dtype := _ ; dbody := t ; rarg := _ |} :: xs => 38 | get_names_args_fun t ++ get_names_args_fix xs 39 | end with 40 | get_names_args_fun (t : term) := 41 | match t with 42 | | tLambda {| binder_name := x; binder_relevance := _ |} _ u => 43 | let na := 44 | match x with 45 | | nAnon => "x"%bs 46 | | nNamed y => y 47 | end 48 | in na :: get_names_args_fun u 49 | | tFix f _ => get_names_args_fix f 50 | | _ => [] 51 | end. 52 | 53 | Set Guard Checking. 54 | 55 | Open Scope string_scope. 56 | 57 | Definition names_aux (l : list bytestring.string) : 58 | (bytestring.string * list bytestring.string) := 59 | (hd "x"%bs l, tl l). 60 | 61 | (* gen_eq [A1; ...; An] B t u = 62 | tProd A1 ... (tProd An (tApp < @eq > (tApp (tApp ... (tApp (lift 1 n t) [tRel (n-1)]) ... [tRel 0]) 63 | (tApp (tApp ... (tApp (lift 1 n u) [tRel (n-1)]) ... [tRel 0]) *) 64 | 65 | Fixpoint gen_eq 66 | (l : list term) (* types of args of the functions *) 67 | (B : term) (* codomain of functions *) 68 | (t : term) (* function 1 *) 69 | (u : term) (* function 2 *) 70 | (lnames : list bytestring.string) (* list of names *) 71 | {struct l} := 72 | match l with 73 | | [] => mkEq B t u 74 | | A :: l' => 75 | let p := names_aux lnames in 76 | mkProdName (p.1)%bs A 77 | (gen_eq l' B (tApp (lift 1 0 t) [tRel 0]) (tApp (lift 1 0 u) [tRel 0]) p.2) 78 | end. 79 | 80 | (* if H : t = u then expand_hyp H produces the hypothesis forall x1 ... xn, t x1 ... xn = u x1 ... xn *) 81 | 82 | Ltac expand_hyp_cont H := fun k => 83 | lazymatch type of H with 84 | | @eq ?A ?t ?u => 85 | let A := metacoq_get_value (tmQuote A) in 86 | let t := metacoq_get_value (tmQuote t) in 87 | let u := metacoq_get_value (tmQuote u) in 88 | let names1 := eval cbv in (get_names_args_fun t) in 89 | let names := 90 | match names1 with 91 | | [] => constr:(get_names_args_fun u) 92 | | _ :: _ => names1 93 | end in 94 | let p := eval cbv in (list_of_args_and_codomain A) in 95 | let l := eval cbv in (rev p.1) in 96 | let B := eval cbv in p.2 in 97 | let eq := eval cbv in (gen_eq l B t u names) 98 | in let z := metacoq_get_value (tmUnquote eq) in 99 | let u := eval hnf in (z.(my_projT2)) in let H' := fresh in 100 | (assert (H': u) by now rewrite H ; 101 | k H') 102 | | _ => k H 103 | end. 104 | 105 | Ltac expand_tuple p := fun k => 106 | match constr:(p) with 107 | | (?x, ?y) => 108 | expand_hyp_cont x ltac:(fun H' => expand_tuple constr:(y) ltac:(fun p => k (H', p))) ; clear x 109 | | unit => k unit 110 | end. 111 | 112 | Ltac expand_hyp H := expand_hyp_cont H ltac:(fun _ => idtac). 113 | 114 | Ltac expand_fun f := 115 | let f_def := eval unfold f in f in 116 | let H := fresh in assert (H : f = f_def) by reflexivity ; 117 | expand_hyp H ; clear H. 118 | 119 | Section tests. 120 | 121 | Goal False. 122 | assert_refl length. 123 | unfold_refl H. 124 | expand_hyp H. 125 | assert (forall x : string, length x = match x with 126 | | ""%string => 0 127 | | String _ s' => S (length s') 128 | end). intros x. destruct x ; simpl ; reflexivity. 129 | Abort. 130 | 131 | Goal False. 132 | expand_fun Datatypes.length. 133 | expand_fun hd. 134 | Abort. 135 | 136 | Variable (A B: Type). 137 | Variable (f: A -> B). 138 | 139 | Goal False. 140 | pose (map' := List.map f). 141 | assert_refl map'. 142 | unfold_refl H. 143 | expand_hyp H. 144 | unfold_refl H0. 145 | unfold_in H0 map. 146 | Abort. 147 | 148 | End tests. 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | -------------------------------------------------------------------------------- /theories/fold_local_def.v: -------------------------------------------------------------------------------- 1 | From Ltac2 Require Import Ltac2. 2 | 3 | Ltac2 fold_local_def (c : constr) := 4 | let hs := Control.hyps () in 5 | try (fold $c) ; 6 | let rec aux hs := 7 | match hs with 8 | | (id, _, _) :: hs' => 9 | try (fold $c in $id) ; aux hs' 10 | | [] => () 11 | end 12 | in aux hs. 13 | 14 | Tactic Notation "fold_local_def" constr(t) := 15 | let tac := 16 | ltac2:(t |- let t := Ltac1.to_constr t in let t := Option.get t in fold_local_def t) 17 | in tac t. 18 | 19 | Ltac fold_local_def_in_hyp_goal H t := 20 | try (fold t in H); fold t. 21 | 22 | Set Default Proof Mode "Classic". 23 | Section tests. 24 | 25 | Goal (let x := True in True -> True -> False -> True). 26 | intros. 27 | fold_local_def x. (* Undo. fold_local_def_in_hyp H x. *) 28 | Abort. 29 | 30 | End tests. -------------------------------------------------------------------------------- /theories/higher_order.v: -------------------------------------------------------------------------------- 1 | Require Import utilities. 2 | Require Import expand. 3 | Require Import elimination_fixpoints. 4 | Require Import elimination_pattern_matching. 5 | Require Import anonymous_functions. 6 | 7 | From elpi Require Import elpi. 8 | 9 | Ltac mypose_elpi t := 10 | tryif (is_local_def t) then idtac else 11 | let t' := 12 | match t with 13 | | ?u ?v => 14 | match goal with 15 | | x := v |- _ => constr:(u x) 16 | | _ => t 17 | end 18 | | _ => t 19 | end in 20 | tryif (is_local_def t') then idtac else 21 | let Na := fresh "f" in pose t as Na ; (* HACK : fold local def eagerly in order 22 | to avoid unification failures with the fixpoint transformation *) 23 | match t with 24 | | ?u ?v => 25 | match goal with 26 | | x := v |- _ => try (fold x in Na) 27 | | _ => idtac 28 | end 29 | | _ => idtac 30 | end. 31 | 32 | Elpi Tactic prenex_higher_order. 33 | 34 | From Sniper.elpi Extra Dependency "higher_order.elpi" as HigherOrder. 35 | From Sniper.elpi Extra Dependency "utilities.elpi" as Utils. 36 | From Sniper.elpi Extra Dependency "subterms.elpi" as Subterms. 37 | Elpi Accumulate File Utils. 38 | Elpi Accumulate File Subterms. 39 | Elpi Accumulate File HigherOrder. 40 | 41 | Elpi Accumulate lp:{{ 42 | 43 | pred mypose_list i: list (pair term (list term)), i: goal, o: list sealed-goal. 44 | mypose_list [pr X L |XS] (goal Ctx _ _ _ _ as G) GL :- 45 | std.rev Ctx Ctx', 46 | std.map L (elim_pos_ctx Ctx') L', 47 | coq.ltac.call "mypose_elpi" [trm (app [X | L'])] G [G'], 48 | coq.ltac.open (mypose_list XS) G' GL. 49 | mypose_list [] _ _. 50 | 51 | 52 | solve (goal Ctx _ TyG _ _ as G) GL :- ctx_to_hyps Ctx Trms, names Na, 53 | subterms_list_and_args [TyG|Trms] Na Subs, 54 | std.filter Subs (x\ fst x X, contains_prenex_ho_ty X, prenex_ho1_ty X) L, trm_and_args_type_funs L L', 55 | std.rev Ctx Ctx', 56 | add_pos_ctx_pr Ctx' L' L'', mypose_list L'' G GL. 57 | 58 | }}. 59 | Elpi Typecheck. 60 | 61 | Require Import List. 62 | 63 | Lemma bar : forall (A B C : Type) (l : list A) (f : A -> B) (g : B -> C), 64 | List.map g (List.map f l) = map (fun x => g (f x)) l. 65 | intros. 66 | elpi prenex_higher_order. Abort. 67 | 68 | Tactic Notation "prenex_higher_order" := 69 | elpi prenex_higher_order. 70 | 71 | Import ListNotations. 72 | 73 | Section Tests. 74 | 75 | Lemma bar : forall (A B C : Type) (l : list A) (f : A -> B) (g : B -> C), 76 | map g (map f l) = map (fun x => g (f x)) l. 77 | intros. 78 | prenex_higher_order. 79 | Abort. 80 | 81 | Lemma bar : forall (A B C : Type) (l : list A) (f : A -> B) (g : B -> C), 82 | map g (map f l) = map (fun x => g (f x)) l. 83 | intros. 84 | assert (IHl : map g (map f l) = map (fun x : A => g (f x)) l) by admit. 85 | prenex_higher_order. (* remove duplicates *) 86 | Abort. 87 | 88 | Goal ( 89 | forall (A B C : Type) 90 | (f : A -> B) 91 | (g : B -> C), 92 | let f0 := fun x : A => g (f x) in 93 | ((forall x : A, f0 x = g (f x)) -> 94 | (forall (x : Type) (x0 x1 : x) (x2 x3 : list x), 95 | x0 :: x2 = x1 :: x3 -> x0 = x1 /\ x2 = x3) -> 96 | (forall (x : Type) (x0 : x) (x1 : list x), 97 | [] = x0 :: x1) -> 98 | map g (map f []) = map f0 [])). 99 | Proof. intros. prenex_higher_order. Abort. 100 | 101 | End Tests. 102 | -------------------------------------------------------------------------------- /theories/instantiate_type.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Sniper *) 4 | (* Copyright (C) 2021 *) 5 | (* *) 6 | (* See file "AUTHORS" for the list of authors *) 7 | (* *) 8 | (* This file is distributed under the terms of the CeCILL-C licence *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | 13 | From MetaCoq.Template Require Import All. 14 | Require Import List. 15 | Require Import utilities. 16 | Import ListNotations. 17 | Require Import String. 18 | 19 | 20 | (* Instantiate a hypothesis with the parameter x *) 21 | Ltac instantiate_par H x := 22 | let T := type of H in 23 | lazymatch T with 24 | | forall (y : ?A), _ => tryif (let H':= fresh H "_" x in assert (H':= H) ; 25 | let U := type of (H' x) in notHyp U ; specialize (H' x)) then idtac else (let H':= fresh H in assert (H':= H) ; 26 | let U := type of (H' x) in notHyp U ; specialize (H' x)) 27 | | _ => fail 28 | end. 29 | 30 | 31 | (* Instantiate a hypothesis with the parameter x and return its identifier *) 32 | Ltac instantiate_par_ident H x := 33 | let T := type of H in 34 | lazymatch T with 35 | | forall (y : ?A), _ => let H':= fresh H in 36 | let _ := match goal with _ => assert (H':= H) ; 37 | let U := type of (H' x) in notHyp U ; specialize (H' x) end in H' 38 | | _ => fail 39 | end. 40 | 41 | 42 | Goal (forall (A : Type) (B : Type), A = A /\ B = B) -> forall (x : nat) (y : bool), x=x /\ y= y. 43 | intro H. 44 | let H' := instantiate_par_ident H bool in instantiate_par H' bool. 45 | Abort. 46 | 47 | 48 | Ltac instantiate_tuple_terms H t1 t2 := match t1 with 49 | | (?x, ?t1') => try (let H' := instantiate_par_ident H x in let u := type of H' in 50 | instantiate_tuple_terms H' t2 t2 ) ; try (instantiate_tuple_terms H t1' t2) 51 | | default => let T := type of H in 52 | match T with 53 | | forall (y : ?A), _ => constr_eq A Type ; clear H 54 | | _ => idtac 55 | end 56 | end. 57 | 58 | 59 | (* Reifies a term and calls is_type *) 60 | Ltac is_type_quote t := idtac t ; 61 | let t' := eval hnf in t in 62 | let T := metacoq_get_value (tmQuote t') in 63 | if_else_ltac idtac fail ltac:(idtac T ; eval compute in (is_type T)). 64 | 65 | 66 | Ltac is_type_quote_bool t := let t' := eval hnf in t in let T := 67 | metacoq_get_value (tmQuote t') in constr:(is_type T). 68 | 69 | Fixpoint list_of_subterms (t: term) : list term := match t with 70 | | tLambda _ Ty u => t :: (list_of_subterms Ty) ++ (list_of_subterms u) 71 | | tProd _ Ty u => t :: (list_of_subterms Ty) ++ (list_of_subterms u) 72 | | tLetIn _ u v w => t :: (list_of_subterms u) ++ (list_of_subterms v) ++ (list_of_subterms w) 73 | | tCast t1 _ t2 => t :: (list_of_subterms t1) ++ (list_of_subterms t2) 74 | | tApp u l => t :: (list_of_subterms u) ++ (List.flat_map list_of_subterms l) 75 | | tCase _ _ t2 l => t:: (list_of_subterms t2) ++ 76 | (List.flat_map (fun x => list_of_subterms (bbody x)) l) 77 | | tFix l _ => t :: (List.flat_map (fun x => list_of_subterms (x.(dbody))) l) 78 | | tCoFix l _ => t :: (List.flat_map (fun x => list_of_subterms (x.(dbody))) l) 79 | | _ => [t] 80 | end. 81 | 82 | Definition filter_closed (l: list term) := List.filter (closedn 0) l. 83 | 84 | 85 | Ltac get_list_of_closed_subterms t := let t_reif := metacoq_get_value (tmQuote t) in 86 | let l := eval cbv in (filter_closed (list_of_subterms t_reif)) in l. 87 | 88 | Ltac return_unquote_tuple_terms l := let rec aux l acc := 89 | match constr:(l) with 90 | | nil => constr:(acc) 91 | | cons ?x ?xs => 92 | let y := metacoq_get_value (tmUnquote x) in 93 | let u := constr:(y.(my_projT2)) in 94 | let w := eval hnf in u in 95 | let T := type of w in 96 | let b0 := ltac:(is_type_quote_bool T) in 97 | let b := eval hnf in b0 in 98 | match b with 99 | | true => (aux xs (pair w acc)) 100 | | false => aux xs acc 101 | end 102 | end 103 | in aux l default. 104 | 105 | Ltac return_tuple_subterms_of_type_type := match goal with 106 | |- ?x => let l0 := (get_list_of_closed_subterms x) in let l := eval cbv in l0 in return_unquote_tuple_terms l 107 | end. 108 | 109 | Goal forall (A: Type) (x:nat) (y: bool) (z : list A), y = y -> z=z -> x = x. 110 | let t := return_tuple_subterms_of_type_type in pose t. 111 | Abort. 112 | 113 | Goal forall (A : Type) (l : list A), Datatypes.length l = 0 -> l = nil. 114 | let t := return_tuple_subterms_of_type_type in pose t. 115 | Abort. 116 | 117 | Ltac instantiate_tuple_terms_goal H := let t0 := return_tuple_subterms_of_type_type in 118 | let t := eval cbv in t0 in instantiate_tuple_terms H t t. 119 | 120 | Goal (forall (A B C : Type), B = B -> C = C -> A = A) -> nat = nat -> bool = bool. 121 | intros H. 122 | let p := return_tuple_subterms_of_type_type in pose p. 123 | instantiate_tuple_terms_goal H. 124 | Abort. 125 | 126 | 127 | Ltac instantiate_tuple_terms_tuple_hyp t terms := match t with 128 | | (?H, ?t') => instantiate_tuple_terms H terms terms ; instantiate_tuple_terms_tuple_hyp t' terms 129 | | default => idtac 130 | end. 131 | 132 | 133 | Ltac instantiate_tuple_terms_tuple_hyp_no_ip_term t terms := lazymatch t with 134 | | (?t1, ?t2 ) => instantiate_tuple_terms_tuple_hyp_no_ip_term t1 terms ; 135 | instantiate_tuple_terms_tuple_hyp_no_ip_term t2 terms 136 | | ?H => let T := type of H in 137 | match T with 138 | | forall (y : ?A), _ => constr_eq A Type ; try (instantiate_tuple_terms H terms terms) 139 | | _ => try (let U := type of T in constr_eq U Prop ; notHyp H ; let H0 := fresh H in assert (H0 : T) by exact H) 140 | end 141 | end. 142 | 143 | Ltac elimination_polymorphism_exhaustive t0 := 144 | let t := eval cbv in t0 in 145 | let terms0 := return_tuple_subterms_of_type_type in 146 | let terms := eval cbv in terms0 in 147 | let h0 := hyps in 148 | let h := eval cbv in h0 in 149 | instantiate_tuple_terms_tuple_hyp_no_ip_term t terms ; 150 | instantiate_tuple_terms_tuple_hyp h terms. 151 | 152 | Ltac test t0 := 153 | let t := eval cbv in t0 in 154 | let h0 := hyps in 155 | let h := eval cbv in h0 in 156 | let x := constr:((nat, (bool, unit))) in 157 | instantiate_tuple_terms_tuple_hyp_no_ip_term t x ; 158 | instantiate_tuple_terms_tuple_hyp h x. 159 | 160 | Ltac test2 t0 := 161 | let h0 := hyps in 162 | let t := eval cbv in t0 in 163 | let x := constr:((nat, (bool, unit))) in 164 | instantiate_tuple_terms_tuple_hyp_no_ip_term t0 x. 165 | 166 | 167 | Goal (forall (A B C : Type), B = B -> C = C -> A = A) -> nat = nat -> bool = bool. 168 | intro. 169 | elimination_polymorphism_exhaustive (rev_involutive, default). 170 | 171 | Abort. 172 | 173 | 174 | Tactic Notation "inst" := elimination_polymorphism_exhaustive unit. 175 | Tactic Notation "inst" constr(t) := elimination_polymorphism_exhaustive (t, default). 176 | 177 | 178 | Goal (forall (A : Type) (a : A), a = a) -> (forall (x : nat), x = x). 179 | Proof. intros H. inst app_length. 180 | Abort. 181 | 182 | Section test. 183 | 184 | Variable A : Type. 185 | Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l. 186 | Proof. 187 | intros. unfold "<>". intro H. inversion H. 188 | Qed. 189 | 190 | Goal False -> forall (x : nat) (y : bool), x=x /\ y= y. 191 | inst (pair_equal_spec, app_length, nil_cons, app_comm_cons). 192 | Abort. 193 | 194 | 195 | Goal True -> forall (x:A) (l:list A), [] <> x :: l. 196 | intros. 197 | test2 nil_cons. apply nil_cons0. Qed. 198 | 199 | End test. 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | -------------------------------------------------------------------------------- /theories/pattern_matching_goal.v: -------------------------------------------------------------------------------- 1 | Require Import ZArith. 2 | 3 | Ltac pose_case M := 4 | let pat := fresh "pat" in 5 | let pf_refl := fresh "pf_refl" in 6 | pose (pat := M); 7 | assert (pf_refl : M = pat) by reflexivity; 8 | rewrite pf_refl; 9 | clearbody pat. 10 | 11 | Section Examples. 12 | 13 | Set Default Proof Mode "Classic". 14 | 15 | (* This did not work with fold (automatic reduction), but works with rewrite *) 16 | Goal match O with O => 42 | S _ => 41 end = 42. 17 | pose_case (match O with O => 42 | S _ => 41 end). 18 | reflexivity. 19 | Qed. 20 | 21 | (* pose_case does not work here (but regular scope works) -> we have to avoid lambdas? *) 22 | Goal forall x : nat , ((fun y => (match y with O => 42 | _ => 41 end)) x) = 41. 23 | intro x. 24 | Fail 25 | let m := constr:(match y with O => 42 | _ => 41 end) in 26 | pose_case m. 27 | Abort. 28 | 29 | (* This case was not covered before *) 30 | Goal forall (x : nat) (f g : nat -> nat) , ((match x with O => f | S _ => g end) 42 = 42). 31 | intros x f g. 32 | (* pose (m := match x with O => f | S _ => g end); assert (H : match x with O => f | S _ => g end = m) by reflexivity; rewrite H. *) 33 | pose_case (match x with O => f | S _ => g end). 34 | (* now one can do scope *) 35 | Abort. 36 | 37 | (* This one was already covered *) 38 | Goal forall y : nat , let x := match y with | O => 2 | S _ => 3 end in x = x. 39 | intro y. 40 | pose_case (match y with O => 2 | S _ => 3 end). 41 | Abort. 42 | 43 | (* veriT gets stuck here but z3 and cvc5 can solve it *) 44 | Goal forall (x : nat) , (match x with O => 3 | _ => 3 end) = 3. 45 | intro x. 46 | pose_case (match x with O => 3 | _ => 3 end). 47 | (* (* scope. *) *) 48 | (* (* verit. *) *) 49 | Abort. 50 | 51 | Goal forall y : nat , let x := (match y with | O => 2 | S _ => 3 end)%Z in x = x. 52 | intro y. 53 | pose_case (match y with O => 2%Z | S _ => 3%Z end). 54 | Abort. 55 | 56 | End Examples. 57 | -------------------------------------------------------------------------------- /theories/refinement_elimination.v: -------------------------------------------------------------------------------- 1 | (* TODO: The trigger should work with equality modulo delta, but it doesn't yet *) 2 | (* TODO: Check again how far we are from proving automatically the `interval` example in CompCert *) 3 | (* TODO: Currently we are relying on the fact that if the user has an application `f x` such that `f` takes *) 4 | (* a refinement type and `x` has a refinement in its type then the transformation will be fired on `f` before *) 5 | (* `x`. We shouldn't rely on this. Maybe we could split it into two transformations, one for generating the term *) 6 | (* and proving the equality; other for rewriting the equality. *) 7 | (* TODO: Create a new version of this tactic that will operate in terms without a body. *) 8 | (* - NOTE: It will only work if the input symbol does not contain refinement types in its domain *) 9 | (* - The new symbol should be defined using `p` directly, instead of the body of `p` *) 10 | (* - After defining the new symbol, the rest of the tactic should be approximately the same *) 11 | (* TODO: In the future we will want to support dependent records - for that we need to generalize the parts in *) 12 | (* which we deal specifically with `proj1_sig` *) 13 | (* TODO: Depending on the place we put this transformation in orchestrator, then some other transformation fails *) 14 | (* Investigate if this is due to the transformation itself or is a bug in orchestrator *) 15 | (* Ref: https://github.com/smtcoq/sniper/issues/27 *) 16 | 17 | Require Import refinement_elimination_elpi. 18 | From elpi Require Import elpi. 19 | From Ltac2 Require Import Ltac2. 20 | Import Constr.Unsafe. 21 | 22 | (* The trigger should be activated for any symbol that contains a refinement type in its type *) 23 | (* param p: symbol whose type contain a refinement type *) 24 | (* 1. Define new equivalent symbol free of refinement types *) 25 | (* 2. Prove that the first projection of p is equal to the new symbol *) 26 | (* 3. Prove that the new symbol satisfies the predicate of p *) 27 | (* 4. Replace p by the new symbol everywhere *) 28 | 29 | (* Assumes `t` is the type of a function. Computes the arity of the function. *) 30 | Ltac2 rec arity (t : constr) : int := 31 | match kind t with 32 | | Prod _ c => Int.add 1 (arity c) 33 | | _ => 0 34 | end. 35 | 36 | (* Assumes `t` is the type of a function. Computer the number of arguments that are refinement types. *) 37 | Ltac2 rec count_ref_types (t : constr) : int := 38 | match kind t with 39 | | Prod b c => 40 | lazy_match! Constr.Binder.type b with 41 | | @sig _ _ => Int.add 1 (count_ref_types c) 42 | | _ => count_ref_types c 43 | end 44 | | _ => 0 45 | end. 46 | 47 | (* Assumes that `t` is the type of a function that returns a refinement type. Returns the predicate of the return type. *) 48 | Ltac2 rec get_ret_sig (t : constr) : constr option := 49 | match kind t with 50 | | Prod _ c => get_ret_sig c 51 | | _ => 52 | lazy_match! t with 53 | | @sig _ ?p => Some p 54 | | _ => None 55 | end 56 | end. 57 | 58 | (* Auxiliary function for `make_eq`. Traverses the arrows of the type of `g`, adding `proj1_sig` whenever it encouters an argument *) 59 | (* which is a refinement type. `i` is the De Bruijn index of the current argument. The arguments to be applied to `f` and `g` are *) 60 | (* accumulated in `argsF` and `argsG`, respectively. *) 61 | Ltac2 rec make_eq' (f : constr) (g : constr) (body_type_g : constr) (i : int) (argsF : constr list) (argsG : constr list) := 62 | match kind body_type_g with 63 | | Prod b c => 64 | (* If the current argument is a `sig`, we apply the function to `proj1_sig (Rel i)`, otherwise is just `Rel i` *) 65 | lazy_match! Constr.Binder.type b with 66 | | @sig ?d ?p => 67 | let argF : constr := make (App constr:(@proj1_sig) (Array.of_list [d; p; make (Rel i)])) in 68 | make (Prod b (make_eq' f g c (Int.sub i 1) (argF :: argsF) (make (Rel i) :: argsG))) 69 | | _ => make (Prod b (make_eq' f g c (Int.sub i 1) (make (Rel i) :: argsF) (make (Rel i) :: argsG))) 70 | end 71 | | _ => 72 | let lhs := make (App f (Array.of_list (List.rev argsF))) in 73 | let rhs := make (App g (Array.of_list (List.rev argsG))) in 74 | (* If the return type is a `sig` we apply `proj1_sig` to the right side of the equality *) 75 | lazy_match! body_type_g with 76 | | @sig ?d ?p => 77 | let rhs' := make (App constr:(@proj1_sig) (Array.of_list [d; p; rhs])) in 78 | make (App constr:(@eq) (Array.of_list [d; lhs; rhs'])) 79 | | _ => make (App constr:(@eq) (Array.of_list [body_type_g; lhs; rhs])) 80 | end 81 | end. 82 | 83 | (* Given two symbols `f` and `g` produces the term corresponding to `forall x1 .. xn , f x1 .. xn = g x1 .. xn, applying `proj1_sig` *) 84 | (* whenever there is a type mismatch in the arguments or in the return value *) 85 | Ltac2 make_eq (f : constr) (g : constr) (body_type_g : constr) := 86 | (* `arity body_type_g` represents the De Bruijn index of `x1` in the final expression *) 87 | make_eq' f g body_type_g (arity body_type_g) [] []. 88 | 89 | Ltac2 rec make_pred' (f : constr) (body_type_g : constr) (pred : constr) (i : int) (args : constr list) := 90 | match kind body_type_g with 91 | | Prod b c => 92 | lazy_match! Constr.Binder.type b with 93 | (* In this case we want to produce forall x : d , forall h : pred x , (recursive call) *) 94 | | @sig ?d ?p => 95 | (* binder for a variable of type `d` *) 96 | let binder_d := Constr.Binder.make None d in 97 | (* binder for a proof of `pred` of the variable we just introduced *) 98 | let d_pred := make (App pred (Array.of_list [make (Rel 1)])) in 99 | let binder_d_pred := Constr.Binder.make None d_pred in 100 | (* Here instead of adding just `x` to the args of `f` in the final expression, we add `proj1_sig (exist x h)` *) 101 | (* Which evaluates to `x`. This is necessary since, when proving that the resulting expression holds, we will *) 102 | (* use the result of the previous step, which states that `f (proj1_sig x) = g x`. *) 103 | (* Note: `Rel i` is `x` and `Rel (Int.sub i 1)` is `h` in the final expression. *) 104 | let exist_arg := make (App constr:(@exist) (Array.of_list [d; p; make (Rel i); make (Rel (Int.sub i 1))])) in 105 | let arg := make (App constr:(@proj1_sig) (Array.of_list [d; p; exist_arg])) in 106 | (* We subtract 2 from `i` in the recursive call since we added two binders *) 107 | let rest := make_pred' f c pred (Int.sub i 2) (arg :: args) in 108 | make (Prod binder_d (make (Prod binder_d_pred rest))) 109 | | _ => make (Prod b (make_pred' f c pred (Int.sub i 1) (make (Rel i) :: args))) 110 | end 111 | | _ => 112 | let fApplied := make (App f (Array.of_list (List.rev args))) in 113 | make (App pred (Array.of_list [fApplied])) 114 | end. 115 | 116 | (* Given a symbol `f` and a predicate `pred`, produces the term corresponding to *) 117 | (* `forall x1 .. xn , pred y1 -> .. -> pred ym -> pred (f x1 .. xn) *) 118 | (* The variables `y1` .. `ym` are defined based on which parameters in `body_type_g` are refinement types. *) 119 | (* The parameters of `f` and `g` need to have the same type, except for some parameters that have the form *) 120 | (* `sig A P` in `g` and `A` in `f`. *) 121 | Ltac2 make_pred (body_type_g : constr) (f : constr) (pred : constr) := 122 | (* Int.add (arity body_type_g) (count_ref_types body_type_g) represents the De Bruijn index of x1 in the final expression *) 123 | make_pred' f body_type_g pred (Int.add (arity body_type_g) (count_ref_types body_type_g)) []. 124 | 125 | Tactic Notation "convert_sigless" ident(i) constr(x) := 126 | elpi convert_sigless_tac ltac_string:(i) ltac_term:(x). 127 | 128 | Tactic Notation "sig_expand" ident(i) constr(x) := 129 | elpi sig_expand_tac ltac_string:(i) ltac_term:(x). 130 | 131 | Ltac elim_refinement_types p := 132 | let sigless_p := fresh "sigless_symbol" in 133 | let reduced_p := eval hnf in p in 134 | 135 | (* Replace every `sig`s, `proj1_sig`s and `exist`s in reduced_p *) 136 | convert_sigless sigless_p reduced_p; 137 | 138 | (* Replace sigless_p by its body *) 139 | let sigless_p := eval cbn in sigless_p in 140 | 141 | let id_conversion := fresh "id_conversion" in 142 | let type_p := type of p in 143 | let type_p_expanded := fresh "type_symbol" in 144 | 145 | (* Delta expand every `sig` in type_p *) 146 | sig_expand type_p_expanded type_p; 147 | 148 | (* Extract body from type_p_expanded *) 149 | let body_type_p := eval red in type_p_expanded in 150 | 151 | (* Declare and prove equality between `p` and `sigless_p` *) 152 | let tac := ltac2:(sigless_p' p' body_type_p' id_conversion' |- 153 | let sigless_p'' := Option.get (Ltac1.to_constr sigless_p') in 154 | let p'' := Option.get (Ltac1.to_constr p') in 155 | let body_type_p'' := Option.get (Ltac1.to_constr body_type_p') in 156 | let eq := make_eq sigless_p'' p'' body_type_p'' in 157 | ltac1:(eq' id_conversion'' |- assert (id_conversion'' : eq') by reflexivity ) (Ltac1.of_constr eq) id_conversion' 158 | ) in tac sigless_p p body_type_p id_conversion; 159 | 160 | (* Declare and prove the fact that `sigless_p` also has the property of `p` *) 161 | let tac := ltac2:(sigless_p' body_type_p' id_conversion' |- 162 | let body_type_p'' := Option.get (Ltac1.to_constr body_type_p') in 163 | match get_ret_sig body_type_p'' with 164 | | Some pred => 165 | let pred_applied := make_pred body_type_p'' (Option.get (Ltac1.to_constr sigless_p')) pred in 166 | ltac1:(pred' sigless_p'' id_conversion'' |- 167 | let H := fresh "H" in 168 | assert (pred') by (intros; rewrite id_conversion''; apply proj2_sig); 169 | cbn in H (* eliminate `proj1_sig (exist ...)` introduced by make_pred *) 170 | ) (Ltac1.of_constr pred_applied) sigless_p' id_conversion' 171 | (* If `p` only has refinement types in its arguments we skip this step, since we can't guarantee the property for the returned value *) 172 | | _ => () 173 | end 174 | ) 175 | in tac sigless_p body_type_p id_conversion; 176 | 177 | (* Replace `p` by `sigless_p` everywhere in the context *) 178 | try (rewrite <- id_conversion in *; clear id_conversion); 179 | clear type_p_expanded. 180 | -------------------------------------------------------------------------------- /theories/refinement_elimination_elpi.v: -------------------------------------------------------------------------------- 1 | From elpi Require Import elpi. 2 | 3 | From Sniper.elpi Extra Dependency "ref_elim_utils.elpi" as ref_elim_utils. 4 | 5 | Elpi Tactic convert_sigless_tac. 6 | 7 | Elpi Accumulate File ref_elim_utils. 8 | 9 | Elpi Accumulate lp:{{ 10 | 11 | solve (goal _ _ _ _ [str S, trm P] as G) GL :- 12 | !, 13 | coq.string->name S N, 14 | replace P P', 15 | refine (let N _ P' Tgt_) G GL. 16 | 17 | solve (goal _ _ _ _ [_, trm _]) _ :- coq.ltac.fail 0 "The first argument should be an identifier". 18 | 19 | solve (goal _ _ _ _ [_, _]) _ :- coq.ltac.fail 0 "The second argument should be a term". 20 | 21 | solve (goal _ _ _ _ _) _ :- coq.ltac.fail 0 "There should be exactly two arguments". 22 | 23 | }}. 24 | Elpi Typecheck. 25 | 26 | Elpi Tactic sig_expand_tac. 27 | 28 | Elpi Accumulate File ref_elim_utils. 29 | 30 | Elpi Accumulate lp:{{ 31 | 32 | solve (goal _ _ _ _ [str S, trm P] as G) GL :- 33 | !, 34 | coq.string->name S N, 35 | smart_sig_expand P P', 36 | refine (let N _ P' Tgt_) G GL. 37 | 38 | solve (goal _ _ _ _ [_, trm _]) _ :- coq.ltac.fail 0 "The first argument should be an identifier". 39 | 40 | solve (goal _ _ _ _ [_, _]) _ :- coq.ltac.fail 0 "The second argument should be a term". 41 | 42 | solve (goal _ _ _ _ _) _ :- coq.ltac.fail 0 "There should be exactly two arguments". 43 | 44 | }}. 45 | Elpi Typecheck. 46 | 47 | Elpi Tactic sigfull_tac. 48 | 49 | Elpi Accumulate File ref_elim_utils. 50 | 51 | Elpi Accumulate lp:{{ 52 | 53 | solve (goal _ _ _ _ [trm P]) _ :- 54 | sigfull P. 55 | 56 | solve (goal _ _ _ _ [trm _]) _ :- 57 | coq.ltac.fail 0 "The argument is not sigfull". 58 | 59 | solve (goal _ _ _ _ [_]) _ :- 60 | coq.ltac.fail 0 "The argument should be a term". 61 | 62 | solve (goal _ _ _ _ _) _ :- 63 | coq.ltac.fail 0 "There should be exactly 1 argument". 64 | 65 | }}. 66 | Elpi Typecheck. 67 | -------------------------------------------------------------------------------- /theories/reflexivity.v: -------------------------------------------------------------------------------- 1 | 2 | Ltac assert_refl c := 3 | let H := fresh in assert (H : c = c) by reflexivity. 4 | 5 | Goal False. 6 | assert_refl nat. 7 | assert_refl Nat.add. 8 | Abort. -------------------------------------------------------------------------------- /theories/subterms.v: -------------------------------------------------------------------------------- 1 | From elpi Require Import elpi. 2 | 3 | Elpi Command Collect_subterms. 4 | Elpi Accumulate File "elpi/subterms.elpi". 5 | Elpi Accumulate File "elpi/utilities.elpi". 6 | Elpi Accumulate lp:{{ 7 | main [trm Term] :- subterms Term L, coq.say L. 8 | }}. 9 | Elpi Typecheck. 10 | 11 | Elpi Collect_subterms (Prop). 12 | Elpi Collect_subterms (fun x : Prop => Prop). 13 | Elpi Collect_subterms (fun x : nat => x). 14 | Elpi Collect_subterms (nat). 15 | Elpi Collect_subterms 16 | (fun x : nat => match x with 17 | | 0 => unit 18 | | S x' => Type 19 | end). 20 | Elpi Collect_subterms 21 | (fun A : Type => 22 | fix length (l : list A) {struct l} : nat := 23 | match l with 24 | | nil => 0 25 | | (_ :: l')%list => S (length l') 26 | end). 27 | 28 | Definition toto := fun A : Type => 29 | fix length (l : list A) : nat := 30 | match l with 31 | | nil => 0 32 | | (_ :: l')%list => S (length l') 33 | end. 34 | 35 | Print toto. 36 | 37 | Elpi Collect_subterms (toto). 38 | 39 | (* TODO : struct *) 40 | 41 | Elpi Tactic tata. 42 | Elpi Accumulate File "elpi/subterms.elpi". 43 | 44 | Elpi Accumulate lp:{{ 45 | solve (goal _ _ Ty _ _ as G) GL :- subterms Ty R, coq.say R. 46 | 47 | }}. 48 | Elpi Typecheck. 49 | 50 | Elpi Tactic test_nth. 51 | Elpi Accumulate File "elpi/utilities.elpi". 52 | 53 | Elpi Accumulate lp:{{ 54 | solve (goal _ _ Ty _ _ as G) GL :- nth 4 [1, 2, 3] R, coq.say R. 55 | solve (goal _ _ Ty _ _ as G) GL :- nth 2 [1, 2, 3] R, coq.say R. 56 | 57 | }}. 58 | Elpi Typecheck. 59 | 60 | Goal False. 61 | elpi test_nth. Abort. 62 | 63 | Elpi Tactic test_context. 64 | Elpi Accumulate File "elpi/utilities.elpi". 65 | Elpi Accumulate File "elpi/instantiate.elpi". 66 | Elpi Accumulate lp:{{ 67 | 68 | solve (goal _ _ Ty _ _ as G) GL :- globals_using_var Ty L, coq.say L. 69 | }}. 70 | Elpi Typecheck. 71 | 72 | Goal forall (A B: Type) (l : A*B), l = l. 73 | intro A. 74 | elpi test_context. Abort. 75 | 76 | Goal forall (A B : Type) (l: list B), l = l. 77 | elpi test_context. Abort. 78 | 79 | 80 | Goal toto = toto. 81 | unfold toto. elpi tata. 82 | Abort. 83 | 84 | 85 | Elpi Command Collect_subterms_type. 86 | 87 | Elpi Accumulate File "elpi/subterms.elpi". 88 | Elpi Accumulate lp:{{ 89 | main [trm Term] :- subterms_type Term L, coq.say L. 90 | }}. 91 | Elpi Typecheck. 92 | 93 | Elpi Accumulate File "elpi/subterms.elpi". 94 | Elpi Collect_subterms_type (Prop). 95 | Elpi Collect_subterms_type (fun x : Prop => Prop). 96 | Elpi Collect_subterms_type ((fun x : Type => Prop) Prop). 97 | Elpi Collect_subterms_type (nat). 98 | Elpi Collect_subterms_type (fun x : nat => x). 99 | Elpi Collect_subterms_type (forall A : Type, nat -> unit). 100 | 101 | Elpi Tactic swap. 102 | Elpi Accumulate lp:{{ 103 | pred last i: (list sealed-goal), o: sealed-goal. 104 | last [_ | GS] R :- last GS R. 105 | last [G] G. 106 | pred remove_last i: (list sealed-goal), o: (list sealed-goal). 107 | remove_last [G1, G2 | GS] R :- remove_last [G2 | GS] R1, 108 | std.append [G1] R1 R. 109 | remove_last [_] []. 110 | remove_last [] []. 111 | msolve GS R :- last GS R1, remove_last GS R2, 112 | std.append [R1] R2 R. 113 | }}. 114 | Elpi Typecheck. 115 | 116 | 117 | 118 | Elpi Tactic instantiate_with_subterms_type_type_of_goal. 119 | Elpi Accumulate File "elpi/subterms.elpi". 120 | Elpi Accumulate File "elpi/instantiate.elpi". 121 | Elpi Accumulate File "elpi/utilities.elpi". 122 | Elpi Typecheck. 123 | Elpi Accumulate File "elpi/construct_cuts.elpi". 124 | Elpi Accumulate lp:{{ 125 | 126 | solve (goal _ _ Ty _ [trm T] as G) GL :- !, 127 | subterms_type Ty L, instantiate_term_list T L R, coq.say R, construct_cuts R Trm, 128 | refine Trm G GL. 129 | 130 | }}. 131 | Elpi Typecheck. 132 | 133 | Elpi Tactic assert_list. 134 | Elpi Accumulate File "elpi/construct_cuts.elpi". 135 | 136 | Elpi Accumulate lp:{{ 137 | 138 | solve (goal _ _ _ _ L as G) GL :- construct_cuts_args L R, coq.say R, 139 | refine R G GL1, 140 | refine_list_of_true GL1 GL. 141 | 142 | 143 | }}. 144 | Elpi Typecheck. 145 | 146 | Goal False. 147 | assert (H : False). 148 | elpi assert_list (True) (True) (True). 149 | Show 2. 150 | all: elpi swap. 151 | Abort. 152 | 153 | 154 | Elpi Tactic create_new_goal. 155 | Elpi Accumulate lp:{{ 156 | 157 | solve (goal _ _ _ _ [trm H, trm H1] as G) [GL1| GL] :- 158 | std.assert-ok! (coq.elaborate-ty-skeleton H _ H') "cut formula illtyped", 159 | refine (app[(fun `new_hyp` H' x\ G1_ x), G2_]) G [GL1, GL2], 160 | coq.ltac.open (refine (app [H1, _ , _])) GL2 GL. 161 | 162 | }}. 163 | Elpi Typecheck. 164 | 165 | Check pair_equal_spec. 166 | 167 | Goal False. 168 | elpi create_new_goal (forall (a1 a2 : nat) (b1 b2 : nat), (a1, b1) = (a2, b2) <-> a1 = a2 /\ b1 = b2) (pair_equal_spec). 169 | 170 | 171 | 172 | 173 | 174 | Goal False. 175 | elpi instantiate_with_subterms_type_type_of_goal (forall x: Type, x = x). 176 | Abort. 177 | 178 | Ltac instantiate_hyp_with_subterms_of_type_type H := let Ty := type of H in 179 | elpi instantiate_with_subterms_type_type_of_goal (Ty). 180 | 181 | Goal ((forall x: Type, x = x) -> unit -> nat -> Prop). 182 | intro H. 183 | instantiate_hyp_with_subterms_of_type_type H; try apply H. 184 | Abort. 185 | 186 | 187 | 188 | Elpi Command Tuple_to_list. 189 | Elpi Accumulate File "elpi/utilities.elpi". 190 | Elpi Accumulate lp:{{ 191 | main [trm Term] :- tuple_to_list Term L, coq.say L. 192 | }}. 193 | Elpi Typecheck. 194 | 195 | Elpi Tuple_to_list ((1, unit, bool)). 196 | 197 | Lemma test_clever_instances : forall (A B C D E : Type) (l : list A) (l' : list B) 198 | (p : C * D) (p' : D*E), l = l -> l' = l' -> p = p -> (forall (A : Type) (x : A), x= x) 199 | -> (forall (A : Type) (l : list A), l = l) -> (forall (A B : Type) (p : A *B), p =p ) -> 200 | p' = p'. 201 | intros. 202 | 203 | 204 | -------------------------------------------------------------------------------- /theories/tree.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Sniper *) 4 | (* Copyright (C) 2021 *) 5 | (* *) 6 | (* See file "AUTHORS" for the list of authors *) 7 | (* *) 8 | (* This file is distributed under the terms of the CeCILL-C licence *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | 13 | Require Import SMTCoq.SMTCoq. 14 | Require Import Bool OrderedType OrderedTypeEx. 15 | 16 | Section tree. 17 | 18 | Variable A : Type. 19 | 20 | Inductive tree : Type := 21 | | Leaf : tree 22 | | Node : tree -> A -> tree -> tree. 23 | 24 | 25 | 26 | Definition is_empty (t : tree) := 27 | match t with 28 | | Leaf => true 29 | | _ => false 30 | end. 31 | 32 | 33 | Fixpoint rev_elements_aux acc s := 34 | match s with 35 | | Leaf => acc 36 | | Node l x r => rev_elements_aux (x :: rev_elements_aux acc l) r 37 | end. 38 | 39 | Definition rev_elements := rev_elements_aux nil. 40 | 41 | Fixpoint cardinal (s : tree) : nat := 42 | match s with 43 | | Leaf => 0 44 | | Node l _ r => S (cardinal l + cardinal r) 45 | end. 46 | 47 | Fixpoint maxdepth s := 48 | match s with 49 | | Leaf => 0 50 | | Node l _ r => S (max (maxdepth l) (maxdepth r)) 51 | end. 52 | 53 | 54 | 55 | 56 | Context `{HA : CompDec A}. 57 | 58 | 59 | Fixpoint tree_eqb (xs ys : tree) : bool := 60 | match xs, ys with 61 | | Leaf, Leaf => true 62 | | Node t1 a t2, Node u1 b u2 => @eqb_of_compdec _ HA a b && tree_eqb t1 u1 && tree_eqb t2 u2 63 | | _, _ => false 64 | end. 65 | 66 | 67 | 68 | 69 | Lemma tree_eqb_spec : forall (t t' : tree), tree_eqb t t' = true <-> t = t'. 70 | Proof. 71 | induction t as [ |t1 IHt1 a t2 IHt2]; intros [ |t1' b t2']; simpl; split; try discriminate; auto. 72 | - rewrite andb_true_iff. intros [H1 H2]. 73 | destruct (eqb_of_compdec HA a b) eqn:E. rewrite Typ.eqb_compdec_spec in E. 74 | simpl in H1. rewrite IHt1 in H1. rewrite IHt2 in H2. now subst. 75 | inversion H1. 76 | - intros H. inversion H as [H1]. rewrite andb_true_iff; split. 77 | + rewrite andb_true_iff; split. now rewrite Typ.eqb_compdec_spec. 78 | * subst t1'. now rewrite IHt1. 79 | + subst t2'. now rewrite IHt2. 80 | Qed. 81 | 82 | Instance tree_eqbtype : EqbType (tree) := Build_EqbType _ _ tree_eqb_spec. 83 | 84 | Fixpoint tree_lt (t1 t2 : tree) : Prop := 85 | match t1, t2 with 86 | | Leaf, Leaf => False 87 | | Leaf, Node _ _ _ => True 88 | | Node _ _ _, Leaf => False 89 | | Node t1 a t2, Node u1 b u2 => (lt a b) \/ (@eqb_of_compdec _ HA a b /\ tree_lt t1 u1) 90 | \/ (tree_eqb t1 u1 /\ @eqb_of_compdec _ HA a b /\ tree_lt t2 u2) 91 | end. 92 | 93 | 94 | Lemma tree_lt_trans : forall (x y z : tree), 95 | tree_lt x y -> tree_lt y z -> tree_lt x z. 96 | Proof. 97 | induction x as [ |x1 IHx1 a x2 IHx2]; intros [ |y1 b y2] [ |z1 c z2]; simpl; auto. 98 | - inversion 1. 99 | - intros [H1a | H1b] [H2a | H2b]. 100 | + left; eapply lt_trans; eauto. 101 | + left. destruct H2b as [H2b | H2c]. 102 | * destruct H2b as [H2c H2d]. unfold is_true in H2c. rewrite Typ.eqb_compdec_spec in H2c. 103 | subst c. assumption. 104 | * destruct H2c as [H2c [H2d H2e]]. unfold is_true in H2d. rewrite Typ.eqb_compdec_spec in H2d. 105 | subst c. assumption. 106 | + left. destruct H1b as [ [H1b H1c] | [H1d [H1e H1f]]]. unfold is_true in H1b. rewrite Typ.eqb_compdec_spec in H1b. 107 | now subst b. unfold is_true in H1e. rewrite Typ.eqb_compdec_spec in H1e. now subst b. 108 | + right. destruct H1b as [ [H1c H1d] | [H1e [H1f H1g]]]. destruct H2b as [ [H2c H2d] | [H2e [H2f H2g]]]. left. split. 109 | 110 | * unfold is_true in H1c. rewrite Typ.eqb_compdec_spec in H1c. now subst a. 111 | * apply IHx1 with y1. assumption. assumption. 112 | * left. split. unfold is_true in H2f. rewrite Typ.eqb_compdec_spec in H2f. now subst b. unfold is_true in H2e. 113 | rewrite tree_eqb_spec in H2e. subst. assumption. 114 | * destruct H2b as [ [H2c H2d] | [H2e [H2f H2g]]]. 115 | { left. unfold is_true in H1f. rewrite Typ.eqb_compdec_spec in H1f. subst. 116 | split. assumption. unfold is_true in H1e. rewrite tree_eqb_spec in H1e. subst. assumption. } 117 | right. unfold is_true in H1e. rewrite tree_eqb_spec in H1e. subst. split. assumption. 118 | unfold is_true in H1f. rewrite Typ.eqb_compdec_spec in H1f. subst b. split. assumption. 119 | apply IHx2 with y2; easy. 120 | Qed. 121 | 122 | 123 | 124 | Lemma tree_lt_not_eq : forall (x y : tree), tree_lt x y -> x <> y. 125 | Proof. 126 | induction x as [ |x1 IHx1 a x2 IHx2]; intros [ |y1 b y2]; simpl; auto. 127 | - discriminate. 128 | - intros [H1 |[ [H1 H2] | [H3 [H4 H5]]]]; intros H; inversion H; subst. 129 | + apply lt_not_eq in H1. auto. 130 | + eapply IHx1; eauto. 131 | + apply IHx2 in H5. auto. 132 | Qed. 133 | 134 | 135 | Instance tree_ord : OrdType (tree) := 136 | Build_OrdType _ _ tree_lt_trans tree_lt_not_eq. 137 | 138 | Definition tree_compare : forall (x y : tree), Compare tree_lt Logic.eq x y. 139 | Proof. 140 | induction x as [ |x1 IHx1 a x2 IHx2]; intros [ |y1 b y2]; simpl. 141 | - now apply EQ. 142 | - now apply LT. 143 | - now apply GT. 144 | - specialize (IHx1 y1). case_eq (compare a b); intros l H. 145 | 146 | + apply LT. simpl. now left. 147 | + destruct IHx1 as [H1 | H2 | H3]. 148 | * apply LT. simpl. right. left. split; auto. now apply Typ.eqb_compdec_spec. 149 | * specialize (IHx2 y2). destruct IHx2 as [H4 | H5 | H6]. apply LT. subst. 150 | simpl. right. right. split. apply tree_eqb_spec. reflexivity. 151 | split. apply Typ.eqb_compdec_spec. reflexivity. assumption. apply EQ. subst. reflexivity. 152 | apply GT. simpl. right. right. split; auto. now apply tree_eqb_spec. split. 153 | now apply Typ.eqb_compdec_spec. easy. 154 | * apply GT. simpl. right. left. split. apply Typ.eqb_compdec_spec. subst. reflexivity. 155 | assumption. 156 | + specialize (IHx2 y2). destruct IHx2 as [H4 | H5 | H6]. 157 | * apply GT. simpl. left. assumption. 158 | * apply GT. simpl. left. assumption. 159 | * apply GT. simpl. left. assumption. 160 | Defined. 161 | 162 | 163 | Instance tree_comp : Comparable (tree) := Build_Comparable _ _ tree_compare. 164 | 165 | 166 | Instance tree_inh : Inhabited (tree) := Build_Inhabited _ Leaf. 167 | 168 | 169 | Instance tree_compdec : CompDec (tree) := {| 170 | Eqb := tree_eqbtype; 171 | Ordered := tree_ord; 172 | Comp := tree_comp; 173 | Inh := tree_inh 174 | |}. 175 | 176 | 177 | 178 | 179 | End tree. 180 | 181 | Arguments tree {_}. 182 | Arguments Leaf {_}. 183 | Arguments Node {_} _ _ _. 184 | Arguments is_empty {_} _. 185 | 186 | 187 | 188 | #[export] Hint Resolve tree_compdec : typeclass_instances. 189 | -------------------------------------------------------------------------------- /theories/unfold_in.v: -------------------------------------------------------------------------------- 1 | Require List. 2 | 3 | Ltac unfold_in H t := 4 | try unfold t in H. 5 | 6 | Section Tests. 7 | Variable (A B : Type). 8 | Variable (f : A -> B). 9 | 10 | Goal False. 11 | pose (mapf := List.map f). 12 | assert (H : mapf = List.map f) by reflexivity. 13 | unfold_in H List.map. 14 | Abort. 15 | 16 | End Tests. -------------------------------------------------------------------------------- /theories/unfold_reflexivity.v: -------------------------------------------------------------------------------- 1 | 2 | Ltac unfold_refl H := 3 | let T := type of H in 4 | match T with 5 | | ?x = ?x => try unfold x at 2 in H 6 | | _ => idtac 7 | end. 8 | 9 | Goal False. 10 | assert (H : length = length) by reflexivity. 11 | unfold_refl H. 12 | Abort. -------------------------------------------------------------------------------- /theories/verit.v: -------------------------------------------------------------------------------- 1 | From Ltac2 Require Import Ltac2. 2 | From Trakt Require Import Trakt. 3 | Require Import ZArith. 4 | 5 | Require Import add_compdecs. 6 | 7 | From SMTCoq Require SMT_classes Conversion Tactics. 8 | Import Tactics. 9 | 10 | Ltac trakt_rels rels := 11 | lazymatch rels with 12 | | Some ?rels' => first [trakt Z bool with rel rels' | trakt bool with rel rels'] 13 | | None => first [trakt Z bool | trakt bool] 14 | end. 15 | 16 | Ltac revert_and_trakt Hs rels := 17 | lazymatch Hs with 18 | | (?Hs, ?H) => 19 | revert H; 20 | revert_and_trakt Hs rels 21 | (* intro H *) 22 | | ?H => 23 | revert H; 24 | trakt_rels rels 25 | (* intro H *) 26 | end. 27 | 28 | Definition sep := True. 29 | 30 | Ltac get_hyps_upto_sep := 31 | lazymatch goal with 32 | | H' : ?P |- _ => 33 | lazymatch P with 34 | | sep => constr:(@None unit) 35 | | _ => 36 | let T := type of P in 37 | lazymatch T with 38 | | Prop => 39 | let _ := match goal with _ => revert H' end in 40 | let acc := get_hyps_upto_sep in 41 | let _ := match goal with _ => intro H' end in 42 | lazymatch acc with 43 | | Some ?acc' => constr:(Some (acc', H')) 44 | | None => constr:(Some H') 45 | end 46 | | _ => 47 | let _ := match goal with _ => revert H' end in 48 | let acc := get_hyps_upto_sep in 49 | let _ := match goal with _ => intro H' end in 50 | acc 51 | end 52 | end 53 | end. 54 | 55 | 56 | (* Goal False -> 1 = 1 -> unit -> false = true -> True. *) 57 | (* Proof. *) 58 | (* intros H1 H2. *) 59 | (* assert (H : sep) by exact I. *) 60 | (* intros H3 H4. *) 61 | (* let Hs := get_hyps_upto_sep in idtac Hs. *) 62 | (* Abort. *) 63 | 64 | 65 | Ltac intros_names := 66 | let H := fresh in 67 | let _ := match goal with _ => assert (H : sep) by exact I; intros end in 68 | let Hs := get_hyps_upto_sep in 69 | let _ := match goal with _ => clear H end in 70 | Hs. 71 | 72 | 73 | (* Goal False -> 1 = 1 -> unit -> false = true -> True. *) 74 | (* Proof. *) 75 | (* intros H1 H2. *) 76 | (* let Hs := intros_names in idtac Hs. *) 77 | (* Abort. *) 78 | 79 | 80 | Ltac post_trakt Hs := 81 | lazymatch Hs with 82 | | (?Hs1, ?Hs2) => 83 | post_trakt Hs1; 84 | post_trakt Hs2 85 | | ?H => try (revert H; trakt_reorder_quantifiers; trakt_boolify_arrows; intro H) 86 | end. 87 | 88 | Ltac trakt1 rels Hs := 89 | lazymatch Hs with 90 | | Some ?Hs => revert_and_trakt Hs rels 91 | | None => trakt_rels rels 92 | end. 93 | 94 | (** Remove add compdecs from SMTCoq's preprocess1 *) 95 | 96 | Ltac preprocess1 Hs := 97 | Conversion.remove_compdec_hyps_option Hs; 98 | let cpds := Conversion.collect_compdecs in 99 | let rels := Conversion.generate_rels cpds in 100 | trakt1 rels Hs. 101 | 102 | 103 | Tactic Notation "verit_bool_no_check" constr(h) := 104 | let tac := 105 | ltac2:(h |- Tactics.get_hyps_cont_ltac1 (ltac1:(h hs |- 106 | match hs with 107 | | Some ?hs => verit_bool_no_check_base_auto (Some (h, hs)) 108 | | None => verit_bool_no_check_base_auto (Some h) 109 | end; 110 | QInst.vauto) h)) in tac h. 111 | 112 | Tactic Notation "verit_bool_no_check" := 113 | ltac2:(Tactics.get_hyps_cont_ltac1 ltac1:(hs |- verit_bool_no_check_base_auto hs; QInst.vauto)). 114 | 115 | Tactic Notation "verit_no_check_orch" constr(global) := 116 | let tac := 117 | ltac2:(h |- intros; unfold is_true in *; Tactics.get_hyps_cont_ltac1 (ltac1:(h local |- 118 | let Hsglob := Conversion.pose_hyps h (@None unit) in 119 | let Hs := 120 | lazymatch local with 121 | | Some ?local' => Conversion.pose_hyps local' Hsglob 122 | | None => constr:(Hsglob) 123 | end 124 | in 125 | preprocess1 Hs; 126 | [ .. | 127 | let Hs' := Conversion.intros_names in 128 | Conversion.preprocess2 Hs'; 129 | verit_bool_no_check_base_auto Hs'; 130 | QInst.vauto 131 | ]) h)) in tac global. 132 | 133 | Tactic Notation "verit_no_check_orch" := 134 | ltac2:(intros; unfold is_true in *; Tactics.get_hyps_cont_ltac1 ltac1:(local |- 135 | let Hs := 136 | lazymatch local with 137 | | Some ?local' => Conversion.pose_hyps local' (@None unit) 138 | | None => constr:(@None unit) 139 | end 140 | in 141 | preprocess1 Hs; 142 | [ .. | 143 | let Hs' := Conversion.intros_names in 144 | Conversion.preprocess2 Hs'; 145 | verit_bool_no_check_base_auto Hs'; 146 | QInst.vauto 147 | ])). 148 | 149 | Tactic Notation "verit_bool_base_auto" constr(h) := verit_bool_base h; try (exact _). 150 | 151 | Tactic Notation "verit_bool" constr(h) := 152 | let tac := 153 | ltac2:(h |- Tactics.get_hyps_cont_ltac1 (ltac1:(h hs |- 154 | match hs with 155 | | Some ?hs => verit_bool_base_auto (Some (h, hs)) 156 | | None => verit_bool_base_auto (Some h) 157 | end; 158 | QInst.vauto) h)) in tac h. 159 | 160 | Tactic Notation "verit_bool" := 161 | ltac2:(Tactics.get_hyps_cont_ltac1 ltac1:(hs |- verit_bool_base_auto hs; QInst.vauto)). 162 | 163 | Tactic Notation "verit_orch" constr(global) := 164 | let tac := 165 | ltac2:(h |- intros; unfold is_true in *; Tactics.get_hyps_cont_ltac1 (ltac1:(h local |- 166 | let Hsglob := Conversion.pose_hyps h (@None unit) in 167 | let Hs := 168 | lazymatch local with 169 | | Some ?local' => Conversion.pose_hyps local' Hsglob 170 | | None => constr:(Hsglob) 171 | end 172 | in 173 | preprocess1 Hs; 174 | [ .. | 175 | let Hs' := Conversion.intros_names in 176 | Conversion.preprocess2 Hs'; 177 | verit_bool_base_auto Hs'; 178 | QInst.vauto 179 | ]) h)) in tac global. 180 | 181 | Tactic Notation "verit_orch" := 182 | ltac2:(intros; unfold is_true in *; Tactics.get_hyps_cont_ltac1 ltac1:(local |- 183 | let Hs := 184 | lazymatch local with 185 | | Some ?local' => Conversion.pose_hyps local' (@None unit) 186 | | None => constr:(@None unit) 187 | end 188 | in 189 | preprocess1 Hs; 190 | [ .. | 191 | let Hs' := Conversion.intros_names in 192 | Conversion.preprocess2 Hs'; 193 | verit_bool_base_auto Hs'; 194 | QInst.vauto 195 | ])). 196 | --------------------------------------------------------------------------------