├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── .gitmodules ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── TexMakefile ├── bib.bib ├── coq-autosubst-ci.opam ├── coq-autosubst.opam ├── examples ├── plain │ ├── Context.v │ ├── Decidable.v │ ├── Demo.v │ ├── Makefile │ ├── POPLmark.v │ └── Size.v └── ssr │ ├── ARS.v │ ├── AutosubstSsr.v │ ├── BetaSubstitution.v │ ├── CR.v │ ├── Context.v │ ├── Makefile │ ├── POPLmark.v │ ├── SystemF_CBV.v │ ├── SystemF_SN.v │ └── pred_CC_omega.v ├── manual.tex ├── meta.yml └── theories ├── Autosubst.v ├── Autosubst_Basics.v ├── Autosubst_Classes.v ├── Autosubst_Derive.v ├── Autosubst_Lemmas.v ├── Autosubst_MMap.v ├── Autosubst_MMapInstances.v ├── Autosubst_Tactics.v └── Makefile /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | name: Docker CI 4 | 5 | on: 6 | push: 7 | branches: 8 | - master 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | - 'mathcomp/mathcomp-dev:coq-dev' 21 | - 'mathcomp/mathcomp:2.2.0-coq-8.19' 22 | - 'mathcomp/mathcomp:2.1.0-coq-8.18' 23 | - 'mathcomp/mathcomp:2.0.0-coq-8.17' 24 | - 'mathcomp/mathcomp:1.17.0-coq-8.17' 25 | - 'mathcomp/mathcomp:1.16.0-coq-8.17' 26 | - 'mathcomp/mathcomp:1.15.0-coq-8.16' 27 | - 'mathcomp/mathcomp:1.14.0-coq-8.15' 28 | - 'mathcomp/mathcomp:1.13.0-coq-8.15' 29 | - 'mathcomp/mathcomp:1.12.0-coq-8.14' 30 | fail-fast: false 31 | steps: 32 | - uses: actions/checkout@v3 33 | - uses: coq-community/docker-coq-action@v1 34 | with: 35 | opam_file: 'coq-autosubst-ci.opam' 36 | custom_image: ${{ matrix.image }} 37 | 38 | 39 | # See also: 40 | # https://github.com/coq-community/docker-coq-action#readme 41 | # https://github.com/erikmd/docker-coq-github-action-demo 42 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.vo 2 | *.vos 3 | *.vok 4 | *.vio 5 | *.glob 6 | *.v.d 7 | *.coq 8 | doc/* 9 | .DS_Store 10 | *.aux 11 | Makefile.coq.conf 12 | .Makefile.coq.d 13 | .coqdeps.d 14 | .lia.cache 15 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "coqdocjs"] 2 | path = coqdocjs 3 | url = https://github.com/tebbi/coqdocjs.git 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | In this changelog we document various changes to the Autosubst 2 | library, especially the API-breaking ones. 3 | 4 | ## Unreleased 5 | 6 | - Add support for Coq 8.13-8.14. 7 | - Remove support for Coq 8.10. 8 | 9 | ## v1.7 (2020-12-19) 10 | 11 | - This is a maintenance release. This version of Autosubst supports the latest 12 | Coq version 8.12 and the latest SSReflect version 1.12. 13 | - Ownership of the library has be transferred to the 14 | [coq-community](https://github.com/coq-community/autosubst). 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-present Steven Schäfer, Tobias Tebbi 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: The above copyright notice and this 10 | permission notice shall be included in all copies or substantial 11 | portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 14 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 15 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 16 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 17 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 18 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 19 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | THEORIES := $(wildcard theories/*.v) 2 | EXAMPLES_PLAIN := $(wildcard examples/plain/*.v) 3 | EXAMPLES_SSR := $(wildcard examples/ssr/*.v) 4 | DOC := doc/ 5 | EXTRA_DIR := coqdocjs/extra/ 6 | HEADER := $(EXTRA_DIR)header.html 7 | FOOTER := $(EXTRA_DIR)footer.html 8 | COQDOCFLAGS := \ 9 | --external 'http://ssr2.msr-inria.inria.fr/doc/ssreflect-1.5/' Ssreflect \ 10 | --external 'http://ssr2.msr-inria.inria.fr/doc/mathcomp-1.5/' MathComp \ 11 | --toc --toc-depth 2 --html --interpolate \ 12 | --index indexpage --no-lib-name --parse-comments \ 13 | --with-header $(HEADER) --with-footer $(FOOTER) \ 14 | -d $(DOC) 15 | 16 | ifneq "$(COQBIN)" "" 17 | COQBIN := $(COQBIN)/ 18 | endif 19 | 20 | lib: 21 | $(MAKE) -C theories 22 | 23 | all: lib examples-plain examples-ssr 24 | 25 | examples-plain: lib 26 | $(MAKE) -C examples/plain 27 | 28 | examples-ssr: lib 29 | $(MAKE) -C examples/ssr 30 | 31 | clean-doc: 32 | $(MAKE) -f TexMakefile clean 33 | rm -rf $(DOC) 34 | 35 | clean: clean-doc 36 | $(MAKE) -C theories clean 37 | $(MAKE) -C "examples/plain" clean 38 | $(MAKE) -C "examples/ssr" clean 39 | 40 | dist: 41 | git archive -o autosubst-HEAD.tar.gz HEAD 42 | 43 | doc: clean-doc manual.pdf 44 | - mkdir -p $(DOC) 45 | coqdoc $(COQDOCFLAGS) -R theories Autosubst -R examples/plain Plain \ 46 | -R examples/ssr Ssr $(THEORIES) $(EXAMPLES_PLAIN) $(EXAMPLES_SSR) 47 | cp $(EXTRA_DIR)resources/* $(DOC) 48 | cp manual.pdf $(DOC) 49 | 50 | install: 51 | $(MAKE) -C theories install 52 | 53 | %.pdf: 54 | $(MAKE) -f TexMakefile $@ 55 | 56 | .PHONY: all clean clean-doc dist doc examples-plain examples-ssr install lib 57 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # Autosubst 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | [![Contributing][contributing-shield]][contributing-link] 9 | [![Code of Conduct][conduct-shield]][conduct-link] 10 | [![Zulip][zulip-shield]][zulip-link] 11 | [![DOI][doi-shield]][doi-link] 12 | 13 | [docker-action-shield]: https://github.com/coq-community/autosubst/workflows/Docker%20CI/badge.svg?branch=master 14 | [docker-action-link]: https://github.com/coq-community/autosubst/actions?query=workflow:"Docker%20CI" 15 | 16 | [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg 17 | [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md 18 | 19 | [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg 20 | [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md 21 | 22 | [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg 23 | [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users 24 | 25 | 26 | [doi-shield]: https://zenodo.org/badge/DOI/10.1007/978-3-319-22102-1_24.svg 27 | [doi-link]: https://doi.org/10.1007/978-3-319-22102-1_24 28 | 29 | Autosubst is a library for the Coq proof assistant which 30 | provides automation for formalizing syntactic theories with 31 | variable binders. Given an inductive definition of syntactic 32 | objects in de Bruijn representation augmented with binding 33 | annotations, Autosubst synthesizes the parallel substitution 34 | operation and automatically proves the basic lemmas about 35 | substitutions. 36 | 37 | ## Meta 38 | 39 | - Author(s): 40 | - Steven Schäfer (initial) 41 | - Tobias Tebbi (initial) 42 | - Coq-community maintainer(s): 43 | - Ralf Jung ([**@RalfJung**](https://github.com/RalfJung)) 44 | - Dan Frumin ([**@co-dan**](https://github.com/co-dan)) 45 | - License: [MIT License](LICENSE) 46 | - Compatible Coq versions: 8.14 or later 47 | - Additional dependencies: none 48 | - Coq namespace: `Autosubst` 49 | - Related publication(s): 50 | - [Autosubst: Reasoning with de Bruijn Terms and Parallel Substitutions](https://www.ps.uni-saarland.de/Publications/documents/SchaeferEtAl_2015_Autosubst_-Reasoning.pdf) doi:[10.1007/978-3-319-22102-1_24](https://doi.org/10.1007/978-3-319-22102-1_24) 51 | 52 | ## Building and installation instructions 53 | 54 | The easiest way to install the latest released version of Autosubst 55 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 56 | 57 | ```shell 58 | opam repo add coq-released https://coq.inria.fr/opam/released 59 | opam install coq-autosubst 60 | ``` 61 | 62 | To instead build and install manually, do: 63 | 64 | ``` shell 65 | git clone https://github.com/coq-community/autosubst.git 66 | cd autosubst 67 | make # or make -j 68 | make install 69 | ``` 70 | 71 | 72 | To build the examples that do not need ssreflect, type 73 | ``` 74 | make examples-plain 75 | ``` 76 | 77 | The examples that depend on ssreflect are built with 78 | ``` 79 | make examples-ssr 80 | ``` 81 | 82 | To build the documentation (including all examples), type 83 | ``` 84 | make doc 85 | ``` 86 | 87 | You can use the file `doc/toc.html` to browse the documentation. 88 | 89 | ## Bug Reports 90 | 91 | Please submit bugs reports on https://github.com/coq-community/autosubst/issues 92 | 93 | -------------------------------------------------------------------------------- /bib.bib: -------------------------------------------------------------------------------- 1 | @article{abadi1991, 2 | author = {Mart\'{\i}n Abadi and 3 | Luca Cardelli and 4 | Pierre-Louis Curien and 5 | Jean-Jacques L{\'e}vy}, 6 | title = {Explicit Substitutions}, 7 | journal = {J. Funct. Program.}, 8 | volume = {1}, 9 | number = {4}, 10 | year = {1991}, 11 | pages = {375-416}, 12 | bibsource = {DBLP, http://dblp.uni-trier.de} 13 | } 14 | @article{deBruijn1972381, 15 | title = "Lambda calculus notation with nameless dummies, a tool for automatic formula manipulation, with application to the {C}hurch-{R}osser theorem", 16 | journal = "Indagationes Mathematicae (Proceedings)", 17 | volume = 75, 18 | number = 5, 19 | pages = "381 - 392", 20 | year = 1972, 21 | issn = "1385-7258", 22 | author = {de Bruijn, N. G.} 23 | } 24 | 25 | @incollection{adams2006formalized, 26 | year=2006, 27 | isbn={978-3-540-31428-8}, 28 | booktitle={Types for Proofs and Programs}, 29 | volume=3839, 30 | series={Lecture Notes in Computer Science}, 31 | title={Formalized Metatheory with Terms Represented by an Indexed Family of Types}, 32 | publisher={Springer Berlin Heidelberg}, 33 | author={Adams, Robin}, 34 | pages={1-16} 35 | } 36 | 37 | @incollection{polonowski2013dbgen, 38 | year={2013}, 39 | isbn={978-3-642-39633-5}, 40 | booktitle={Interactive Theorem Proving}, 41 | volume={7998}, 42 | series={Lecture Notes in Computer Science}, 43 | title={Automatically Generated Infrastructure for De {Bruijn} Syntaxes}, 44 | publisher={Springer Berlin Heidelberg}, 45 | keywords={De Bruijn syntax; formalization; infrastructure generation; Coq proof assistant}, 46 | author={Polonowski, Emmanuel}, 47 | pages={402-417} 48 | } 49 | 50 | @incollection{poplmark, 51 | year=2005, 52 | isbn={978-3-540-28372-0}, 53 | booktitle={Theorem Proving in Higher Order Logics}, 54 | volume=3603, 55 | series={Lecture Notes in Computer Science}, 56 | doi={10.1007/11541868_4}, 57 | title={Mechanized Metatheory for the Masses: The {PoplMark} Challenge}, 58 | publisher={Springer Berlin Heidelberg}, 59 | author={Aydemir, Brian E. and Bohannon, Aaron and Fairbairn, Matthew and Foster, J. Nathan and Pierce, Benjamin C. and Sewell, Peter and Vytiniotis, Dimitrios and Washburn, Geoffrey and Weirich, Stephanie and Zdancewic, Steve}, 60 | pages={50-65} 61 | } -------------------------------------------------------------------------------- /coq-autosubst-ci.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "palmskog@gmail.com" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/coq-community/autosubst" 6 | dev-repo: "git+https://github.com/coq-community/autosubst.git" 7 | bug-reports: "https://github.com/coq-community/autosubst/issues" 8 | license: "MIT" 9 | 10 | synopsis: "Autosubst (CI only)" 11 | 12 | build: [make "-j%{jobs}%" "all"] 13 | depends: [ 14 | "coq" 15 | "coq-mathcomp-ssreflect" 16 | ] 17 | -------------------------------------------------------------------------------- /coq-autosubst.opam: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | 4 | opam-version: "2.0" 5 | maintainer: "palmskog@gmail.com" 6 | version: "dev" 7 | 8 | homepage: "https://github.com/coq-community/autosubst" 9 | dev-repo: "git+https://github.com/coq-community/autosubst.git" 10 | bug-reports: "https://github.com/coq-community/autosubst/issues" 11 | license: "MIT" 12 | 13 | synopsis: "Coq library for parallel de Bruijn substitutions" 14 | description: """ 15 | Autosubst is a library for the Coq proof assistant which 16 | provides automation for formalizing syntactic theories with 17 | variable binders. Given an inductive definition of syntactic 18 | objects in de Bruijn representation augmented with binding 19 | annotations, Autosubst synthesizes the parallel substitution 20 | operation and automatically proves the basic lemmas about 21 | substitutions.""" 22 | 23 | build: [make "-j%{jobs}%"] 24 | install: [make "install"] 25 | depends: [ 26 | "coq" {(>= "8.14" & < "8.21~") | (= "dev")} 27 | ] 28 | 29 | tags: [ 30 | "category:Computer Science/Lambda Calculi" 31 | "keyword:abstract syntax" 32 | "keyword:binders" 33 | "keyword:de Bruijn indices" 34 | "keyword:substitution" 35 | "logpath:Autosubst" 36 | ] 37 | authors: [ 38 | "Steven Schäfer" 39 | "Tobias Tebbi" 40 | ] 41 | -------------------------------------------------------------------------------- /examples/plain/Context.v: -------------------------------------------------------------------------------- 1 | (** * Context *) 2 | Require Import Lia ZArith List Program.Equality. 3 | Require Import Autosubst.Autosubst. 4 | 5 | Fixpoint atn {X} l n (x : X) := 6 | match l with 7 | | nil => False 8 | | y :: l' => match n with 9 | | 0 => x = y 10 | | S n' => atn l' n' x 11 | end 12 | end. 13 | 14 | 15 | Section SubstInstance. 16 | 17 | Context {term : Type}. 18 | Context {Ids_term : Ids term} {Rename_term : Rename term} 19 | {Subst_term : Subst term} {SubstLemmas_term : SubstLemmas term}. 20 | 21 | Inductive atnd: list term -> var -> term -> Prop := 22 | | Atnd0 Delta A A' : 23 | A' = A.[ren(+1)] -> atnd (A :: Delta) 0 A' 24 | | AtndS Delta x A B B' : 25 | atnd Delta x B -> B' = B.[ren(+1)] -> atnd (A :: Delta) (S x) B'. 26 | 27 | Lemma atn_mmap {f : term -> term} {Gamma x A A'} : 28 | atn Gamma x A -> A' = (f A) -> atn (mmap f Gamma) x A'. 29 | Proof. 30 | revert x. 31 | induction Gamma; intros; simpl in *; trivial. 32 | destruct x; subst; eauto. 33 | Qed. 34 | 35 | Lemma mmap_atn {f : term -> term} {Gamma x A'} : 36 | atn (mmap f Gamma) x A' -> exists A, A' = (f A) /\ atn Gamma x A. 37 | Proof. 38 | revert x. induction Gamma; intros; simpl in *. 39 | - contradiction. 40 | - destruct x; subst; eauto. 41 | Qed. 42 | 43 | Lemma up_mmap_atn zeta xi Gamma1 Gamma2 A x : 44 | (forall x B, atn Gamma1 x B -> atn Gamma2 (zeta x) B.[ren xi]) -> 45 | atn (mmap (subst (ren (+1))) Gamma1) x A -> 46 | atn (mmap (subst (ren (+1))) Gamma2) (zeta x) A.[ren (0 .: xi >>> (+1))]. 47 | Proof. 48 | intros H1 H2. 49 | edestruct (mmap_atn H2) as [? [? ?]]. subst. 50 | eapply atn_mmap; eauto. autosubst. 51 | Qed. 52 | 53 | Lemma up_atnd xi Delta1 Delta2 A B x: 54 | (forall x C, atnd Delta1 x C -> atnd Delta2 (xi x) C.[ren xi]) -> 55 | atnd (A :: Delta1) x B -> 56 | atnd (A.[ren xi] :: Delta2) ((0 .: xi >>> (+1)) x) B.[ren (0 .: xi >>> (+1))]. 57 | Proof. 58 | intros H1 H2; destruct x; simpl; inv H2; econstructor; eauto; autosubst. 59 | Qed. 60 | 61 | Lemma atnd_steps x Gamma Delta A : 62 | atnd Gamma x A <-> 63 | atnd (Delta ++ Gamma) (length Delta + x) A.[ren(+(length Delta))]. 64 | Proof. 65 | revert A x. 66 | induction Delta; intros. 67 | - split. 68 | + autosubst. 69 | + autosubst. 70 | - simpl. 71 | replace (A.[ren (+S (length Delta))]) with 72 | (A.[ren(+length Delta)].[ren(+1)]); [idtac|autosubst]. 73 | split. 74 | + econstructor. eapply IHDelta; eassumption. reflexivity. 75 | + intros H. inv H. rewrite IHDelta. apply lift_inj in H5. 76 | subst. eassumption. 77 | Qed. 78 | 79 | Lemma atnd_steps' x Gamma Delta A : 80 | atnd (Delta ++ Gamma) (x + length Delta) A -> 81 | exists B, A = B.[ren(+(length Delta))] /\ atnd Gamma x B. 82 | Proof. 83 | revert A x. 84 | induction Delta; intros. 85 | - exists A. 86 | simpl in H. 87 | rewrite Nat.add_0_r in H. intuition autosubst. 88 | - asimpl. simpl in *. 89 | rewrite plusnS in *. 90 | inv H. 91 | edestruct IHDelta as [B' [? ?]]; eauto. exists B'. subst. 92 | intuition autosubst. 93 | Qed. 94 | 95 | Corollary atnd_step Delta A x B : 96 | atnd Delta x A <-> atnd (B :: Delta) (S x) A.[ren(+1)]. 97 | Proof. 98 | apply atnd_steps with (Delta := B :: nil). 99 | Qed. 100 | 101 | Lemma atnd_repl Gamma A Delta : 102 | (atnd (Delta ++ A :: Gamma) (length Delta) A.[ren(+ S (length Delta))]) /\ 103 | (forall x B A', 104 | x <> length Delta -> atnd (Delta ++ A :: Gamma) x B -> 105 | atnd (Delta ++ A' :: Gamma) x B). 106 | Proof. 107 | split. 108 | - pose proof (atnd_steps 0 (A :: Gamma) Delta A.[ren(+1)]) as H. asimpl in H. 109 | apply H. now constructor. 110 | - intros x. revert Gamma A Delta. 111 | induction x; intros Gamma A Delta H B A' H_atn. 112 | + destruct Delta as [| C Delta]. { now intuition. } 113 | simpl in *. 114 | inv H_atn. now constructor. 115 | + destruct Delta as [| C Delta]; simpl in *. 116 | * inv H_atn. econstructor. eassumption. reflexivity. 117 | * inv H_atn. econstructor. eapply IHx; eauto. reflexivity. 118 | Qed. 119 | 120 | Lemma atnd_defined Delta x : (exists B, atnd Delta x B) <-> x < length Delta. 121 | Proof. 122 | revert x. induction Delta; intuition; asimpl in *; ainv. 123 | - destruct x. lia. cut(x < length Delta). lia. 124 | ainv. firstorder. 125 | - destruct x. 126 | + eexists. now econstructor. 127 | + edestruct IHDelta as [_ [? ?]]. cut(x < length Delta); eauto. lia. 128 | eexists. econstructor; eauto. 129 | Qed. 130 | 131 | End SubstInstance. 132 | 133 | (* Local Variables: *) 134 | (* coq-load-path: (("." "Plain") ("../../theories" "Autosubst")) *) 135 | (* End: *) 136 | -------------------------------------------------------------------------------- /examples/plain/Decidable.v: -------------------------------------------------------------------------------- 1 | (** * Notation for decidable propositions *) 2 | Require Import Arith. 3 | 4 | Definition dec (X : Prop) : Type := {X} + {~ X}. 5 | Class Dec (X : Prop) : Type := decide : dec X. 6 | Arguments decide X {_}. 7 | 8 | Ltac gen_Dec_eq := unfold Dec; unfold dec; decide equality. 9 | 10 | Global Instance decide_eq_nat (x y : nat) : Dec (x = y). gen_Dec_eq. Defined. 11 | 12 | Global Instance decide_le_nat (x y : nat) : Dec (x <= y). apply le_dec. Defined. 13 | 14 | Global Instance decide_lt_nat (x y : nat) : Dec (x < y). apply lt_dec. Defined. 15 | 16 | Tactic Notation "decide" constr(p) := destruct (decide p). 17 | -------------------------------------------------------------------------------- /examples/plain/Demo.v: -------------------------------------------------------------------------------- 1 | (** * Autosubst Tutorial 2 | 3 | ## 4 | In this tutorial we will use Autosubst to formalize the simply typed lambda calculus and show substitutivity and type preservation of the reduction relation. *) 5 | 6 | Require Import Autosubst.Autosubst. 7 | 8 | (** ** Syntax and the substitution operation 9 | 10 | The syntax of the untyped lambda calculus is given by the following grammar. 11 | #\[ s, t := x \mid s \, t \mid \lambda s \]# 12 | 13 | To generate the substitution operation we need an inductive type 14 | corresponding to the terms above with a few annotations. 15 | 16 | - There must be _exactly_ one variable constructor which has a single 17 | argument of type [var]. The type [var] is convertible to [nat], which is 18 | used to represent de Bruijn indices. 19 | - Subterms with additional bound variables must be of type [{bind term}] 20 | instead of [term]. The notation [{bind T}] is convertible to [T]. *) 21 | 22 | Inductive term := 23 | | Var (x : var) 24 | | App (s t : term) 25 | | Lam (s : {bind term}). 26 | 27 | (** Now we can automatically derive the substitution operations and lemmas. 28 | This is done by generating instances for the following typeclasses: 29 | 30 | - [Ids term] provides the generic identity substitution [ids] for term. 31 | It is always equivalent to the variable constructor of term, i.e. 32 | to the unique constructor having a single argument of type [var]. 33 | In this example, [ids] is convertible to [Var]. 34 | - [Rename term] provides the renaming operation on term. 35 | - [Subst term] provides the substitution operation on term and needs a 36 | [Rename] instance in the presence of binders. 37 | - [SubstLemmas term] contains proofs for the basic lemmas. 38 | 39 | Each instance is inferred automatically by using the [derive] tactic. *) 40 | 41 | Global Instance Ids_term : Ids term. derive. Defined. 42 | Global Instance Rename_term : Rename term. derive. Defined. 43 | Global Instance Subst_term : Subst term. derive. Defined. 44 | Global Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 45 | 46 | (** At this point we can use the notations: 47 | 48 | - [s.[sigma]] for the application of the substitution [sigma] to a term [s]. 49 | - [sigma >> tau] for the composition of sigma and tau, i.e., the 50 | substitution [fun x => (sigma x).[tau]]. 51 | 52 | Additionally there is a generic cast [ren] from renamings (functions of type 53 | [nat -> nat] to substitutions). 54 | 55 | Let us test the simplification behavior of [s.[sigma]]. 56 | *) 57 | 58 | Eval simpl in fun sigma x => (Var x).[sigma]. 59 | (* simplifies to [sigma x]*) 60 | 61 | Eval simpl in fun sigma s t => (App s t).[sigma]. 62 | (* simplifies to [App s.[sigma] t.[sigma]]*) 63 | 64 | Eval simpl in fun sigma s => (Lam s).[sigma]. 65 | (* simplifies to [Lam s.[up sigma]]*) 66 | 67 | 68 | (** The operator [up] adapts a substitution when going below a binder. 69 | It does not simplify with [simpl], but we can use our tactic [asimpl] 70 | to perform the simplification. 71 | 72 | *) 73 | Goal forall sigma, 74 | (Lam (App (Var 0) (Var 3))).[sigma] = Lam (App (Var 0) (sigma 2).[ren(+1)]). 75 | intros. asimpl. reflexivity. Qed. 76 | 77 | (** ** Reduction and substitutivity 78 | 79 | The single-step reduction relation is defined by the following inference 80 | rules 81 | #\[ \cfrac{}{(\lambda s)\, t \rhd s.[t {\,.:\,} \text{ids}]} \quad 82 | \cfrac{s_1 \rhd s_2}{s_1 \, t \rhd s_2 \, t} \quad 83 | \cfrac{t_1 \rhd t_2}{s \, t_1 \rhd s \, t_2} \quad 84 | \cfrac{s_1 \rhd s_2}{\lambda s_1 \rhd \lambda s_2} \quad 85 | \]# 86 | 87 | We write [ids] for the identity substitution and [s .: sigma] for the stream-cons 88 | operation. Note that substitutions being functions from natural numbers to 89 | terms can be seen as streams of terms. 90 | Stream-cons satisfies the following equations. 91 | #
# 92 | [(s .: sigma) 0 = s] 93 | #
# 94 | [(s .: sigma) (S x) = sigma x] 95 | #
# 96 | 97 | Note that [s.[t .: ids]] replaces [0] in [s] by [t] and decreases all other 98 | variables by one. So this just expresses the usual definition of beta-reduction. 99 | We use the abbreviation [s.[t/]] for [s.[t .: ids]]. 100 | 101 | The definition below is an almost verbatim copy of the inference rules. The 102 | one difference is in the beta rule. Instead of using [s.[t/]] 103 | directly, we add an equation to the premise. 104 | This makes the constructor applicable even if the reduced term does not 105 | syntactically match [s1.[t/]]. *) 106 | 107 | Inductive step : term -> term -> Prop := 108 | | Step_beta (s1 s2 t : term) : 109 | s1.[t/] = s2 -> step (App (Lam s1) t) s2 110 | | Step_appL (s1 s2 t : term) : 111 | step s1 s2 -> step (App s1 t) (App s2 t) 112 | | Step_appR (s t1 t2 : term) : 113 | step t1 t2 -> step (App s t1) (App s t2) 114 | | Step_lam (s1 s2 : term) : 115 | step s1 s2 -> step (Lam s1) (Lam s2). 116 | 117 | (** The proof of substitutivity proceeds by induction on the reduction relation. 118 | In every case we apply the respective constructor of [step]. 119 | Apart from [Step_beta], every case is trivial. 120 | For [Step_beta], we have to show the equation 121 | #
# 122 | [s1.[t/].[sigma] = s1.[up sigma].[t.[sigma]/]]. 123 | #
# 124 | Since both sides of the equation are simplified to [s1.[t.[sigma] .: sigma]] using 125 | [asimpl], this goal can be solved using [autosubst]. *) 126 | 127 | Lemma substitutivity s1 s2 : 128 | step s1 s2 -> forall sigma, step s1.[sigma] s2.[sigma]. 129 | Proof. 130 | induction 1; constructor; subst; autosubst. 131 | Restart. 132 | induction 1; intros; simpl; eauto using step; subst. 133 | constructor. asimpl. reflexivity. 134 | Qed. 135 | 136 | (** ** Type Preservation *) 137 | 138 | (** We define the syntax for simple types. *) 139 | Inductive type := 140 | | Base 141 | | Arr (A B : type). 142 | 143 | (** For simplicity, the typing relation uses infinite contexts, that is, substitutions 144 | Thus we can reuse the primitives and tactics for substitutions. 145 | *) 146 | Inductive ty (Gamma : var -> type) : term -> type -> Prop := 147 | | Ty_Var x A : Gamma x = A -> 148 | ty Gamma (Var x) A 149 | | Ty_Lam s A B : ty (A .: Gamma) s B -> 150 | ty Gamma (Lam s) (Arr A B) 151 | | Ty_App s t A B : ty Gamma s (Arr A B) -> ty Gamma t A -> 152 | ty Gamma (App s t) B. 153 | 154 | (** This lemma is a generalization of the usual weakening lemma and a specialization 155 | of [ty_subst], which we will prove next. 156 | *) 157 | Lemma ty_ren Gamma s A: 158 | ty Gamma s A -> forall Delta xi, 159 | Gamma = xi >>> Delta -> 160 | ty Delta s.[ren xi] A. 161 | Proof. 162 | induction 1; intros; subst; asimpl; econstructor; eauto. 163 | - eapply IHty. autosubst. 164 | Qed. 165 | 166 | (** By generalizing [ty_ren] to substitutions, we obtain that we preserve typing 167 | if we replace variables by terms of the same type. 168 | *) 169 | Lemma ty_subst Gamma s A: 170 | ty Gamma s A -> forall sigma Delta, 171 | (forall x, ty Delta (sigma x) (Gamma x)) -> 172 | ty Delta s.[sigma] A. 173 | Proof. 174 | induction 1; intros; subst; asimpl; eauto using ty. 175 | - econstructor. eapply IHty. 176 | intros [|]; asimpl; eauto using ty, ty_ren. 177 | Qed. 178 | 179 | (** To show type preservation of the simply typed lambda calculus, we use [ty_subst] to 180 | justify the typing of the result of the beta reduction. 181 | *) 182 | Lemma ty_pres Gamma s A : 183 | ty Gamma s A -> forall s', 184 | step s s' -> 185 | ty Gamma s' A. 186 | Proof. 187 | induction 1; intros s' H_step; asimpl; 188 | inversion H_step; ainv; eauto using ty. 189 | - eapply ty_subst; try eassumption. 190 | intros [|]; simpl; eauto using ty. 191 | Qed. 192 | 193 | (* Local Variables: *) 194 | (* coq-load-path: (("." "Plain") ("../../theories" "Autosubst")) *) 195 | (* End: *) 196 | -------------------------------------------------------------------------------- /examples/plain/Makefile: -------------------------------------------------------------------------------- 1 | COQMAKEFILE := Makefile.coq 2 | COQMAKE := +$(MAKE) -f $(COQMAKEFILE) 3 | 4 | LIB := ../../theories 5 | VS := $(wildcard *.v) 6 | 7 | all: $(COQMAKEFILE) 8 | +$(MAKE) -f $(COQMAKEFILE) all 9 | 10 | $(COQMAKEFILE): Makefile $(VS) 11 | coq_makefile -R $(LIB) Autosubst -R . Plain $(VS) -o $(COQMAKEFILE) 12 | 13 | clean: $(COQMAKEFILE) 14 | -$(COQMAKE) clean 15 | rm -f $(COQMAKEFILE) 16 | 17 | .PHONY: all clean 18 | -------------------------------------------------------------------------------- /examples/plain/POPLmark.v: -------------------------------------------------------------------------------- 1 | (** * POPLmark Part 1 2 | 3 | The #POPLmark# 4 | challenge is a set of benchmark problems to evaluate approaches to the 5 | formalization of syntactic theories. We solve part 1, that is, 6 | progress and preservation of System F with subtyping. *) 7 | 8 | Require Import Program.Equality List Lia. 9 | Require Import Autosubst.Autosubst. 10 | Require Import Size Decidable Context. 11 | 12 | Inductive type : Type := 13 | | TyVar (x : var) 14 | | Top 15 | | Arr (A1 A2 : type) 16 | | All (A1 : type) (A2 : {bind type}). 17 | 18 | Global Instance Ids_type : Ids type. derive. Defined. 19 | Global Instance Rename_type : Rename type. derive. Defined. 20 | Global Instance Subst_type : Subst type. derive. Defined. 21 | 22 | Global Instance SubstLemmas_type : SubstLemmas type. derive. Qed. 23 | 24 | Global Instance size_type : Size type. 25 | assert(Size var). exact(fun _ => 0). derive. 26 | Defined. 27 | 28 | Inductive term := 29 | | TeVar (x : var) 30 | | Abs (A : type) (s : {bind term}) 31 | | App (s t : term) 32 | | TAbs (A : type) (s : {bind type in term}) 33 | | TApp (s : term) (A : type). 34 | 35 | Global Instance hsubst_term : HSubst type term. derive. Defined. 36 | 37 | Global Instance Ids_term : Ids term. derive. Defined. 38 | Global Instance Rename_term : Rename term. derive. Defined. 39 | Global Instance Subst_term : Subst term. derive. Defined. 40 | 41 | Global Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed. 42 | 43 | Global Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed. 44 | 45 | Global Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 46 | 47 | Global Instance size_term : Size term. 48 | assert(Size var). exact(fun _ => 0). derive. 49 | Defined. 50 | 51 | Lemma ren_size_inv (A : type) : forall xi, size A.[ren xi] = size A. 52 | Proof. 53 | induction A; intros; sizesimpl; repeat(asimpl; try autorew); slia. 54 | Qed. 55 | 56 | Fixpoint wf_ty Delta A := match A with 57 | | TyVar x => exists B, atnd Delta x B 58 | | Top => True 59 | | Arr A B => wf_ty Delta A /\ wf_ty Delta B 60 | | All A B => wf_ty Delta A /\ wf_ty (A :: Delta) B 61 | end. 62 | 63 | Reserved Notation "'SUB' Delta |- A <: B" 64 | (at level 68, A at level 99, no associativity). 65 | Inductive sub (Delta : list type) : type -> type -> Prop := 66 | | SA_Top A : 67 | wf_ty Delta A -> SUB Delta |- A <: Top 68 | | SA_Refl x : 69 | wf_ty Delta (TyVar x) -> SUB Delta |- TyVar x <: TyVar x 70 | | SA_Trans x A B : 71 | atnd Delta x A -> SUB Delta |- A <: B -> SUB Delta |- TyVar x <: B 72 | | SA_Arrow A1 A2 B1 B2 : 73 | SUB Delta |- B1 <: A1 -> SUB Delta |- A2 <: B2 -> 74 | SUB Delta |- Arr A1 A2 <: Arr B1 B2 75 | | SA_All A1 A2 B1 B2 : 76 | SUB Delta |- B1 <: A1 -> wf_ty Delta B1 -> SUB (B1 :: Delta) |- A2 <: B2 -> 77 | SUB Delta |- All A1 A2 <: All B1 B2 78 | where "'SUB' Delta |- A <: B" := (sub Delta A B). 79 | 80 | Lemma wf_weak Delta1 Delta2 A xi : 81 | wf_ty Delta1 A -> 82 | (forall x B, atnd Delta1 x B -> exists B', atnd Delta2 (xi x) B') -> 83 | wf_ty Delta2 A.[ren xi]. 84 | Proof. 85 | autorevert A. induction A; intros; ainv; simpl; eauto. 86 | asimpl. split; eauto. 87 | eapply IHA0. eassumption. 88 | intros. ainv (asimpl; eauto using @atnd). 89 | edestruct H0; eauto. eauto using @atnd. 90 | Qed. 91 | 92 | Lemma wf_weak1 Delta A A' B : 93 | wf_ty Delta A -> A' = A.[ren(+1)] -> wf_ty (B :: Delta) A'. 94 | Proof. intros. subst. eapply wf_weak; eauto using @atnd. Qed. 95 | 96 | Corollary wf_weak' Delta1 Delta2 A : 97 | wf_ty Delta1 A -> 98 | (length Delta1 <= length Delta2) -> 99 | wf_ty Delta2 A. 100 | Proof. 101 | intros. replace A with A.[ren id] by now autosubst. 102 | eapply wf_weak; eauto. 103 | intros. apply atnd_defined. 104 | cut(id x < length Delta1). lia. 105 | apply atnd_defined. eauto. 106 | Qed. 107 | 108 | Lemma sub_refl Delta A : wf_ty Delta A -> SUB Delta |- A <: A. 109 | Proof. 110 | revert Delta. induction A; simpl; intuition; 111 | constructor; simpl; eauto using sub. 112 | Qed. 113 | 114 | Lemma sub_weak Delta1 Delta2 A1 A2 A1' A2' xi : SUB Delta1 |- A1 <: A2 -> 115 | (forall x B, atnd Delta1 x B -> atnd Delta2 (xi x) B.[ren xi]) -> 116 | A1' = A1.[ren xi] -> A2' = A2.[ren xi] -> 117 | SUB Delta2 |- A1' <: A2' . 118 | Proof. 119 | intros H. intros. subst. autorevert H. 120 | induction H; intros; simpl; try now (econstructor; simpl; ainv eauto). 121 | - eauto using sub, wf_weak. 122 | - econstructor; asimpl; eauto using wf_weak. 123 | apply IHsub2. 124 | intros [|]; intros; asimpl; ainv; econstructor; eauto; now autosubst. 125 | Qed. 126 | 127 | Lemma sub_weak1 Delta A A' B B' C : 128 | SUB Delta |- A <: B -> A' = A.[ren(+1)] -> B' = B.[ren(+1)] -> 129 | SUB (C :: Delta) |- A' <: B'. 130 | Proof. intros. eapply sub_weak; eauto using @atnd. Qed. 131 | 132 | Lemma sub_wf {Delta A B} : 133 | SUB Delta |- A <: B -> wf_ty Delta A /\ wf_ty Delta B. 134 | Proof. 135 | intros H. induction H; ainv; simpl; eauto using wf_weak'. 136 | Qed. 137 | 138 | Lemma sub_wf_1 Delta A B : SUB Delta |- A <: B -> wf_ty Delta A. 139 | Proof. apply sub_wf. Qed. 140 | 141 | 142 | Lemma sub_wf_2 Delta A B : SUB Delta |- A <: B -> wf_ty Delta B. 143 | Proof. apply sub_wf. Qed. 144 | 145 | Lemma conj' (A B : Prop) : A -> (A -> B) -> A /\ B. 146 | Proof. tauto. Qed. 147 | 148 | Lemma sub_trans' n : 149 | (forall Delta A B C, n = size B -> 150 | SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C) /\ 151 | (forall Delta' Delta B B' A C, n = size B -> 152 | SUB Delta' ++ B :: Delta |- A <: C -> 153 | SUB Delta |- B' <: B -> 154 | SUB Delta' ++ B' :: Delta |- A <: C). 155 | Proof. 156 | induction n as [n IH] using (size_rec (fun x => x)). 157 | apply conj'. 158 | { 159 | intros Delta A B C ? H_AB H_BC. subst. 160 | revert C H_BC. 161 | induction H_AB; intros; ainv; eauto using sub. 162 | - inv H_BC. 163 | + constructor. simpl. split; eauto using sub_wf_1, sub_wf_2. 164 | + constructor; eapply IH; eauto; slia. 165 | - inv H_BC. 166 | + constructor; constructor. 167 | * eapply sub_wf; now eauto. 168 | * eapply wf_weak'. now eapply (sub_wf H_AB2). now simpl. 169 | + rename B0 into C1. rename B3 into C2. 170 | constructor; eauto. 171 | * eapply IH; eauto; slia. 172 | * eapply IH; eauto; try slia. 173 | (refine (proj2 (IH _ _) nil _ B1 _ _ _ _ _ _)); eauto; simpl; lia. 174 | } 175 | { 176 | intros H_trans Delta' Delta B B' A C ? H H_B'B. subst. 177 | revert B' H_B'B. 178 | depind H; intros; simpl in *. 179 | - constructor. 180 | eapply wf_weak'. eassumption. 181 | repeat rewrite app_length. simpl. lia. 182 | - constructor. simpl. 183 | apply atnd_defined. apply atnd_defined in H. 184 | repeat rewrite -> app_length in *. simpl in *. lia. 185 | - decide (x = length Delta'). 186 | + subst. 187 | econstructor. { apply atnd_repl. } 188 | apply atnd_steps' with (x := 0) in H. 189 | destruct H as [? [? H]]. inv H. 190 | eapply H_trans;[idtac | eapply sub_weak; 191 | try reflexivity; try eassumption | idtac]. 192 | * now rewrite ren_size_inv. 193 | * intros. change (B' :: Delta) with ((B' :: nil) ++ Delta). 194 | rewrite app_assoc. 195 | replace (S (length Delta')) with (length (Delta' ++ B' :: nil)). 196 | now apply atnd_steps. 197 | rewrite app_length. simpl. lia. 198 | * asimpl in IHsub. 199 | eapply IHsub; now eauto. 200 | + econstructor; eauto. 201 | eapply atnd_repl; now eauto. 202 | - constructor; now eauto. 203 | - constructor. 204 | + now eauto. 205 | + eapply wf_weak'. eassumption. 206 | repeat rewrite app_length. simpl. lia. 207 | + change (B1 :: Delta' ++ B' :: Delta) 208 | with ((B1 :: Delta') ++ B' :: Delta). 209 | eapply IHsub2; eauto. 210 | } 211 | Qed. 212 | 213 | Corollary sub_trans Delta A B C: 214 | SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C. 215 | Proof. intros. eapply sub_trans'; eauto. Qed. 216 | 217 | Corollary sub_narrow Delta' Delta B B' A C : 218 | SUB Delta' ++ B :: Delta |- A <: C -> 219 | SUB Delta |- B' <: B -> 220 | SUB Delta' ++ B' :: Delta |- A <: C. 221 | Proof. intros. eapply sub_trans'; eauto. Qed. 222 | 223 | Inductive value : term -> Prop := 224 | | Value_Abs A s : value(Abs A s) 225 | | Value_TAbs A s : value(TAbs A s). 226 | 227 | Reserved Notation "'TY' Delta ; Gamma |- A : B" 228 | (at level 68, A at level 99, no associativity, 229 | format "'TY' Delta ; Gamma |- A : B"). 230 | Inductive ty (Delta Gamma : list type) : term -> type -> Prop := 231 | | T_Var A x : 232 | atn Gamma x A -> 233 | TY Delta;Gamma |- TeVar x : A 234 | | T_Abs A B s: 235 | TY Delta;A::Gamma |- s : B -> wf_ty Delta A -> 236 | TY Delta;Gamma |- Abs A s : Arr A B 237 | | T_App A B s t: 238 | TY Delta;Gamma |- s : Arr A B -> TY Delta;Gamma |- t : A -> 239 | TY Delta;Gamma |- App s t : B 240 | | T_TAbs A B s : 241 | TY A::Delta ; Gamma..[ren(+1)] |- s : B -> wf_ty Delta A -> 242 | TY Delta;Gamma |- TAbs A s : All A B 243 | | T_TApp A B A' s B' : 244 | TY Delta;Gamma |- s : All A B -> 245 | SUB Delta |- A' <: A -> B' = B.[A'/] -> 246 | TY Delta;Gamma |- TApp s A' : B' 247 | | T_Sub A B s : 248 | TY Delta;Gamma |- s : A -> SUB Delta |- A <: B -> 249 | TY Delta;Gamma |- s : B 250 | where "'TY' Delta ; Gamma |- s : A" := (ty Delta Gamma s A). 251 | 252 | Reserved Notation "'EV' s => t" 253 | (at level 68, s at level 80, no associativity, format "'EV' s => t"). 254 | Inductive eval : term -> term -> Prop := 255 | | E_AppAbs A s t : EV App (Abs A s) t => s.[t/] 256 | | E_TAppTAbs A s B : EV TApp (TAbs A s) B => s.|[B/] 257 | | E_AppFun s s' t : 258 | EV s => s' -> 259 | EV App s t => App s' t 260 | | E_AppArg s s' v: 261 | EV s => s' -> value v -> 262 | EV App v s => App v s' 263 | | E_TypeFun s s' A : 264 | EV s => s' -> 265 | EV TApp s A => TApp s' A 266 | where "'EV' s => t" := (eval s t). 267 | 268 | 269 | Lemma ty_weak xi zeta Delta1 Delta2 Gamma1 Gamma2 s A : 270 | TY Delta1;Gamma1 |- s : A -> 271 | (forall x B, atnd Delta1 x B -> atnd Delta2 (xi x) B.[ren xi]) -> 272 | (forall x B, atn Gamma1 x B -> atn Gamma2 (zeta x) B.[ren xi]) -> 273 | TY Delta2;Gamma2 |- s.|[ren xi].[ren zeta] : A.[ren xi] . 274 | Proof. 275 | intros H. autorevert H. induction H; intros; simpl. 276 | - econstructor; now eauto. 277 | - asimpl. econstructor. 278 | + apply IHty; eauto. intros x C H_C. 279 | destruct x; simpl in *; subst; eauto. 280 | + eauto using wf_weak. 281 | - asimpl; econstructor; simpl; eauto; apply IHty1; eauto. 282 | - asimpl. econstructor. apply IHty. 283 | + intros. now eapply up_atnd; eauto. 284 | + intros. eapply up_mmap_atn; eauto. 285 | + eauto using wf_weak. 286 | - econstructor. 287 | + simpl in IHty. apply IHty; eauto. 288 | + eauto using sub_weak. 289 | + subst. autosubst. 290 | - eauto using ty, sub_weak. 291 | Qed. 292 | 293 | Lemma ty_weak_ty xi Delta1 Delta2 Gamma1 Gamma2 s s' A A': 294 | TY Delta1;Gamma1 |- s : A -> 295 | (forall x B, atnd Delta1 x B -> atnd Delta2 (xi x) B.[ren xi]) -> 296 | (forall x B, atn Gamma1 x B -> atn Gamma2 x B.[ren xi]) -> 297 | A' = A.[ren xi] -> 298 | s' = s.|[ren xi] -> 299 | TY Delta2;Gamma2 |- s' : A'. 300 | Proof. 301 | intros. subst. 302 | replace (s.|[ren xi]) with (s.|[ren xi].[ren id]). 303 | eapply ty_weak; eauto. now autosubst. 304 | Qed. 305 | 306 | Lemma ty_weak_ty' Delta Gamma s s' A A' B: 307 | TY Delta;Gamma |- s : A -> 308 | A' = A.[ren (+1)] -> 309 | s' = s.|[ren (+1)] -> 310 | TY B::Delta ; Gamma..[ren(+1)] |- s' : A'. 311 | Proof. 312 | intros. eapply ty_weak_ty; eauto; intros. 313 | - econstructor; eauto. 314 | - eapply atn_mmap; eauto. 315 | Qed. 316 | 317 | Lemma ty_weak_ter xi Delta Gamma1 Gamma2 s A : 318 | TY Delta;Gamma1 |- s : A -> 319 | (forall x B, atn Gamma1 x B -> atn Gamma2 (xi x) B) -> 320 | TY Delta;Gamma2 |- s.[ren xi] : A. 321 | Proof. 322 | intros. 323 | replace s with (s.|[ren id]). 324 | replace A with (A.[ren id]). 325 | eapply ty_weak; eauto; intros; asimpl; now eauto. 326 | autosubst. autosubst. 327 | Qed. 328 | 329 | Lemma ty_weak_ter1 Delta Gamma s s' A B : 330 | TY Delta;Gamma |- s : A -> 331 | s' = s.[ren(+1)] -> 332 | TY Delta ; B::Gamma |- s' : A. 333 | Proof. 334 | intros. subst. eapply ty_weak_ter; eauto. 335 | Qed. 336 | 337 | Lemma ty_narrow Delta2 Delta1 Gamma A B C s: 338 | TY Delta2 ++ B :: Delta1 ; Gamma |- s : C -> 339 | SUB Delta1 |- A <: B -> 340 | TY Delta2 ++ A :: Delta1 ; Gamma |- s : C. 341 | Proof. 342 | intros H. depind H; econstructor; eauto using ty. 343 | - eapply wf_weak'. eassumption. repeat rewrite app_length. simpl. lia. 344 | - change (A0 :: Delta2 ++ A :: Delta1) with ((A0 :: Delta2) ++ A :: Delta1). 345 | eapply IHty. reflexivity. assumption. 346 | - eapply wf_weak'. eassumption. repeat rewrite app_length. simpl. lia. 347 | - now eapply sub_narrow; eauto. 348 | - now eapply sub_narrow; eauto. 349 | Qed. 350 | 351 | Lemma wf_subst Delta1 Delta2 A sigma : 352 | wf_ty Delta1 A -> 353 | (forall x B, atnd Delta1 x B -> wf_ty Delta2 (sigma x)) -> 354 | wf_ty Delta2 A.[sigma]. 355 | Proof. 356 | intros H. autorevert A. induction A; eauto; intros; asimpl. 357 | - ainv; eauto. 358 | - ainv; eauto. 359 | - split. ainv; eauto. ainv. eapply IHA0. eassumption. 360 | intros [|]; intros. 361 | + simpl. eauto using @atnd. 362 | + ainv. asimpl. eapply wf_weak; eauto using @atnd. 363 | Qed. 364 | 365 | Lemma sub_subst Delta1 Delta2 A B sigma: 366 | SUB Delta1 |- A <: B -> 367 | (forall x C, atnd Delta1 x C -> SUB Delta2 |- sigma x <: C.[sigma]) -> 368 | SUB Delta2 |- A.[sigma] <: B.[sigma]. 369 | Proof. 370 | intros H. autorevert H. 371 | induction H; intros; simpl; try econstructor; asimpl; 372 | eauto using sub, wf_subst, sub_wf_1. 373 | - inv H. eauto using sub_refl, wf_subst, sub_wf_1. 374 | - eauto using sub_trans. 375 | - apply IHsub2. intros. inv H3. 376 | + econstructor. eauto using @atnd. 377 | asimpl. apply sub_refl. 378 | eapply wf_weak1; eauto using sub_wf_1. autosubst. 379 | + asimpl. eapply sub_weak1; try reflexivity; eauto. autosubst. 380 | Qed. 381 | 382 | Lemma ty_subst Delta1 Delta2 Gamma1 Gamma2 s A sigma tau: 383 | TY Delta1;Gamma1 |- s : A -> 384 | (forall x B, atnd Delta1 x B -> SUB Delta2 |- sigma x <: B.[sigma] ) -> 385 | (forall x B, atn Gamma1 x B -> TY Delta2;Gamma2 |- tau x : B.[sigma]) -> 386 | TY Delta2;Gamma2 |- s.|[sigma].[tau] : A.[sigma]. 387 | Proof. 388 | intros H. 389 | autorevert H. induction H; intros; asimpl. 390 | - now eauto. 391 | - econstructor. 392 | + apply IHty; eauto. 393 | intros ? ? H_get. destruct x; asimpl in *; subst; 394 | eauto using ty_weak_ter1. now constructor. 395 | + eauto using wf_subst, sub_wf_1. 396 | - econstructor; eauto. 397 | - econstructor. apply IHty. 398 | + intros ? ? H_get. inv H_get; asimpl. 399 | * econstructor. constructor; eauto. 400 | asimpl. apply sub_refl. 401 | eapply wf_weak1; eauto using wf_subst, sub_wf_1. 402 | autosubst. 403 | * eapply sub_weak; eauto using @atnd. now autosubst. 404 | + intros. 405 | apply mmap_atn in H3. ainv. 406 | eapply ty_weak_ty'; eauto. now autosubst. 407 | + eauto using wf_subst, sub_wf_1. 408 | - subst. simpl in *. econstructor; eauto using sub_subst. now autosubst. 409 | - eauto using ty, sub_subst. 410 | Qed. 411 | 412 | Corollary ty_subst_term Delta Gamma1 Gamma2 s A sigma: 413 | TY Delta;Gamma1 |- s : A -> 414 | (forall x B, atnd Delta x B -> wf_ty Delta B) -> 415 | (forall x B, atn Gamma1 x B -> TY Delta;Gamma2 |- sigma x : B) -> 416 | TY Delta;Gamma2 |- s.[sigma] : A. 417 | Proof. 418 | intros. 419 | replace s with (s.|[ids]);[idtac|autosubst]. 420 | replace A with (A.[ids]);[idtac|autosubst]. 421 | eapply ty_subst; eauto; intros. 422 | - asimpl; eauto using sub, sub_refl. 423 | - asimpl; eauto using sub, sub_refl. 424 | Qed. 425 | 426 | Lemma can_form_arr {s A B}: 427 | TY nil;nil |- s : Arr A B -> value s -> exists C t, s = Abs C t. 428 | Proof. 429 | intros H. 430 | depind H; intros; eauto; ainv. 431 | inv H0. ainv. eauto. (* JK: With the 8.6 Goal matching default hypothesis order (newest first) this would break with the old ainv version! *) 432 | Qed. 433 | 434 | Lemma can_form_all {s A B}: 435 | TY nil;nil |- s : All A B -> value s -> exists C t, s = TAbs C t. 436 | Proof. 437 | intros H. 438 | depind H; intros; eauto; ainv. 439 | inv H0. ainv. eauto. 440 | Qed. 441 | 442 | Theorem ev_progress s A: 443 | TY nil;nil |- s : A -> value s \/ exists t, EV s => t. 444 | Proof. 445 | intros. depind H. (* depind appears to not remove generated trivial equality guards any longer *) 446 | - inv H. 447 | - left; constructor. 448 | - right. destruct IHty1 as [? | [? ?]]; trivial. 449 | + edestruct (can_form_arr H H1) as [? [? ?]]; subst. eauto using eval. 450 | + eauto using eval. 451 | - left; constructor. 452 | - right. destruct IHty as [? | [? ?]]; trivial. 453 | + edestruct (can_form_all H H1) as [? [? ?]]; subst. eauto using eval. 454 | + eauto using eval. 455 | - auto. 456 | Qed. 457 | 458 | Lemma ty_inv_abs {Delta Gamma A A' B C s}: 459 | TY Delta;Gamma |- Abs A s : C -> SUB Delta |- C <: Arr A' B -> 460 | (SUB Delta |- A' <: A /\ 461 | exists B', TY Delta;A::Gamma |- s : B' /\ SUB Delta |- B' <: B). 462 | Proof. 463 | intros H. depind H; intros. 464 | - inv H1. split; eauto. 465 | - eauto using sub_trans. 466 | Qed. 467 | 468 | Lemma ty_inv_tabs {Delta Gamma A A' B C s}: 469 | TY Delta;Gamma |- TAbs A s : C -> SUB Delta |- C <: All A' B -> 470 | (SUB Delta |- A' <: A /\ exists B', 471 | TY A'::Delta;Gamma..[ren(+1)] |- s : B' /\ SUB A'::Delta |- B' <: B). 472 | Proof. 473 | intros H. depind H; intros. 474 | - inv H1. split; eauto. 475 | eexists. split; eauto. eapply (ty_narrow nil); eauto. 476 | - eauto using sub_trans. 477 | Qed. 478 | 479 | Theorem preservation Delta Gamma s t A : 480 | TY Delta;Gamma |- s : A -> EV s => t -> 481 | (forall x B, atnd Delta x B -> wf_ty Delta B) -> 482 | TY Delta;Gamma |- t : A. 483 | Proof. 484 | intros H_ty H_ev. 485 | autorevert H_ev. induction H_ev; intros; depind H_ty; eauto using ty. 486 | - inv H_ty1. 487 | + eapply ty_subst_term; eauto. intros [|] ? ?; simpl in *; 488 | subst; eauto using ty. 489 | + pose proof (ty_inv_abs H0 H1) as [? [B' [? ?]]]. 490 | eapply ty_subst_term; eauto using ty. 491 | intros [|] ? ?; simpl in *; subst; eauto using ty. 492 | - replace (s.|[B/]) with (s.|[B/].[ids]);[idtac|autosubst]. 493 | inv H_ty; [idtac | pose proof (ty_inv_tabs H1 H2) as [? [B' [? ?]]]]; 494 | (eapply ty_subst; eauto using ty; [ 495 | now intros ? ? H_atnd; inv H_atnd; asimpl; eauto using sub, sub_refl 496 | | now intros [|] ? H_atn; simpl in *; subst; apply mmap_atn in H_atn; 497 | destruct H_atn as [? [? ?]]; subst; asimpl; eauto using ty ]). 498 | Qed. 499 | 500 | (* Local Variables: *) 501 | (* coq-load-path: (("." "Plain") ("../../theories" "Autosubst")) *) 502 | (* End: *) 503 | -------------------------------------------------------------------------------- /examples/plain/Size.v: -------------------------------------------------------------------------------- 1 | (** * Support for Size Induction *) 2 | Require Import ZArith Lia List Program.Equality. 3 | Require Import Autosubst.Autosubst_Basics. 4 | 5 | Class Size (A : Type) := size : A -> nat. 6 | 7 | Arguments size {A _} !x /. 8 | 9 | Ltac derive_Size := 10 | let size' := fresh "dummy" in 11 | hnf; match goal with [ |- ?A -> nat] => 12 | fix size' 1; 13 | let s := fresh "s" in 14 | intros s; 15 | assert(size_inst : Size A);[exact size' | idtac]; 16 | let E := fresh "E" in 17 | destruct s eqn:E; 18 | match goal with 19 | [E : s = ?s' |- _] => 20 | let rec map s := 21 | (match s with 22 | ?s1 ?s2 => 23 | let size_s1 := map s1 in 24 | let s2_T := type of s2 in 25 | let size_s2 := constr:(1 + size s2) in 26 | constr:(size_s1 + size_s2) 27 | | _ => constr:(O) end) in 28 | let t' := map s' in 29 | let t'' := eval simpl plus in t' in 30 | exact (t'') 31 | end 32 | end. 33 | 34 | Global Hint Extern 0 (Size _) => derive_Size : derive. 35 | 36 | Lemma size_rec {A : Type} f (x : A) : 37 | forall P : A -> Type, (forall x, (forall y, f y < f x -> P y) -> P x) -> P x. 38 | Proof. 39 | intros P IS. cut (forall n x, f x <= n -> P x). { eauto. } 40 | intros n. induction n; intros; apply IS; intros. 41 | - lia. 42 | - apply IHn. lia. 43 | Defined. 44 | 45 | Lemma size_ind2 {A B : Type} f g (x : A) (y : B) : 46 | forall P : A -> B -> Prop, 47 | (forall x1 y1, 48 | (forall x2 y2, f x2 < f x1 -> P x2 y2) -> 49 | (forall x2 y2, f x2 = f x1 -> g y2 < g y1 -> P x2 y2) -> P x1 y1) -> 50 | P x y. 51 | Proof. 52 | intros P IS. cut (forall n x, f x <= n -> forall y, P x y). { eauto. } 53 | intros n. induction n; intros. 54 | - apply IS; intros. 55 | + lia. 56 | + cut (forall m x, f x = 0 -> forall y, g y <= m -> P x y). { 57 | intros H_c. eapply H_c. lia. eauto. } 58 | intros m. induction m; intros; apply IS; intros; try lia. 59 | apply IHm; lia. 60 | - apply IS; intros. 61 | + apply IHn; lia. 62 | + cut (forall m x y, f x = f x2 -> g y <= m -> P x y). { eauto. } 63 | intros m. depind m; intros; apply IS; intros; try lia. 64 | * apply IHn; lia. 65 | * apply IHn; lia. 66 | * apply IHm; lia. 67 | Qed. 68 | 69 | Ltac sind H := 70 | let IH := fresh "IH" in 71 | let x := fresh "x" in 72 | induction H as [x IH] using (@size_rec _ size); try rename x into H. 73 | 74 | Ltac sizesimpl := repeat(simpl in *; 75 | repeat match goal with [|- context[size ?t]] => 76 | let s := constr:(size t) in progress change (size t) with s in * 77 | end; autorewrite with size in *). 78 | 79 | Tactic Notation "slia" := sizesimpl; try lia; now trivial. 80 | 81 | Global Instance size_list (A : Type) (size_A : Size A) : Size (list A). 82 | derive. 83 | Defined. 84 | 85 | Global Instance size_nat : Size nat := id. 86 | 87 | (** A database of facts about the size function *) 88 | 89 | Class SizeFact (A : Type) (x : A) (P : Prop) := size_fact : P. 90 | 91 | Arguments size_fact {A} x {P _}. 92 | 93 | Lemma size_app (A : Type) (size_A : Size A) l1 l2 : 94 | size (app l1 l2) = size l1 + size l2. 95 | Proof. induction l1; simpl; intuition (auto with zarith). Qed. 96 | Global Hint Rewrite @size_app : size. 97 | 98 | Global Instance size_fact_app (A : Type) (size_A : Size A) l1 l2 : 99 | SizeFact _ (app l1 l2) (size(app l1 l2) = size l1 + size l2). 100 | Proof. apply size_app. Qed. 101 | 102 | Lemma size_In A (size_A : Size A) (x : A) l : In x l -> size x < size l. 103 | Proof. 104 | revert x. 105 | induction l; intros; simpl in *; intuition subst. 106 | - lia. 107 | - pose (IHl _ H0). lia. 108 | Qed. 109 | 110 | Global Instance size_fact_In (A : Type) (size_A : Size A) x l (x_in_l : In x l) : 111 | SizeFact _ x (size x < size l). 112 | Proof. now apply size_In. Qed. 113 | 114 | (* Local Variables: *) 115 | (* coq-load-path: (("." "Plain") ("../../theories" "Autosubst")) *) 116 | (* End: *) 117 | -------------------------------------------------------------------------------- /examples/ssr/ARS.v: -------------------------------------------------------------------------------- 1 | (** * Abstract Reduction Systems 2 | 3 | Useful lemmas when working with small-step reduction relations. *) 4 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | Declare Scope prop_scope. 11 | Delimit Scope prop_scope with PROP. 12 | Open Scope prop_scope. 13 | 14 | Notation "e1 <=2 e2" := (forall x y, e1 x y -> e2 x y) 15 | (at level 70, no associativity) : prop_scope. 16 | Notation "e1 <=>2 e2" := (e1 <=2 e2 /\ e2 <=2 e1) 17 | (at level 70, no associativity) : prop_scope. 18 | 19 | Definition Pred (T : Type) := T -> Prop. 20 | Definition Rel (T : Type) := T -> Pred T. 21 | 22 | (** **** Reflexive, Transitive(, Symmetric) closure *) 23 | 24 | Section Definitions. 25 | 26 | Variables (T : Type) (e : Rel T). 27 | Implicit Types (R S : T -> T -> Prop). 28 | 29 | Inductive star (x : T) : T -> Prop := 30 | | starR : star x x 31 | | starSE y z : star x y -> e y z -> star x z. 32 | 33 | Inductive conv (x : T) : T -> Prop := 34 | | convR : conv x x 35 | | convSE y z : conv x y -> e y z -> conv x z 36 | | convSEi y z : conv x y -> e z y -> conv x z. 37 | 38 | Definition com R S := forall x y z, R x y -> S x z -> exists2 u, S y u & R z u. 39 | 40 | Definition joinable R x y := exists2 z, R x z & R y z. 41 | Definition diamond := forall x y z, e x y -> e x z -> exists2 u, e y u & e z u. 42 | Definition confluent := forall x y z, star x y -> star x z -> joinable star y z. 43 | Definition CR := forall x y, conv x y -> joinable star x y. 44 | 45 | Local Hint Resolve starR convR : core. 46 | 47 | Lemma star1 x y : e x y -> star x y. 48 | Proof. exact: starSE. Qed. 49 | 50 | Lemma star_trans y x z : star x y -> star y z -> star x z. 51 | Proof. move=> A. elim=> //={z} y' z _. exact: starSE. Qed. 52 | 53 | Lemma starES x y z : e x y -> star y z -> star x z. 54 | Proof. move/star1. exact: star_trans. Qed. 55 | 56 | Lemma star_conv x y : star x y -> conv x y. 57 | Proof. elim=> //={} y z _. exact: convSE. Qed. 58 | 59 | Lemma conv1 x y : e x y -> conv x y. 60 | Proof. exact: convSE. Qed. 61 | 62 | Lemma conv1i x y : e y x -> conv x y. 63 | Proof. exact: convSEi. Qed. 64 | 65 | Lemma conv_trans y x z : conv x y -> conv y z -> conv x z. 66 | Proof. move=> A. elim=> //={z} y' z _. exact: convSE. exact: convSEi. Qed. 67 | 68 | Lemma convES x y z : e x y -> conv y z -> conv x z. 69 | Proof. move/conv1. exact: conv_trans. Qed. 70 | 71 | Lemma convESi x y z : e y x -> conv y z -> conv x z. 72 | Proof. move/conv1i. exact: conv_trans. Qed. 73 | 74 | Lemma conv_sym x y : conv x y -> conv y x. 75 | Proof. elim=> //={} y z _ ih h; [exact: convESi ih|exact: convES ih]. Qed. 76 | 77 | Lemma join_conv x y z : star x y -> star z y -> conv x z. 78 | Proof. 79 | move=> sxy szy. apply: (@conv_trans y); [|apply: conv_sym]; exact: star_conv. 80 | Qed. 81 | 82 | Lemma confluent_cr : 83 | confluent <-> CR. 84 | Proof. 85 | split=> [h x y|h x y z /star_conv A /star_conv B]. 86 | - elim=> [|{} y z _ [u h1 h2] /star1 h3|{} y z _ [u h1 h2] h3]. 87 | + by exists x. 88 | + case: (h y u z h2 h3) => v {h3} h2 h3. 89 | exists v => //. exact: star_trans h2. 90 | + exists u => //. exact: starES h2. 91 | - apply: h. apply: conv_trans B. exact: conv_sym. 92 | Qed. 93 | 94 | End Definitions. 95 | 96 | Global Hint Resolve starR convR : core. 97 | Arguments star_trans {T e} y {x z} A B. 98 | Arguments conv_trans {T e} y {x z} A B. 99 | 100 | Lemma star_img T1 T2 (f : T1 -> T2) (e1 : Rel T1) e2 : 101 | (forall x y, e1 x y -> star e2 (f x) (f y)) -> 102 | (forall x y, star e1 x y -> star e2 (f x) (f y)). 103 | Proof. 104 | move=> A x y. elim=> //=y' z _ B /A. exact: star_trans. 105 | Qed. 106 | 107 | Lemma star_hom T1 T2 (f : T1 -> T2) (e1 : Rel T1) (e2 : Rel T2) : 108 | (forall x y, e1 x y -> e2 (f x) (f y)) -> 109 | (forall x y, star e1 x y -> star e2 (f x) (f y)). 110 | Proof. 111 | move=> A. apply: star_img => x y /A. exact: star1. 112 | Qed. 113 | 114 | Lemma conv_img T1 T2 (f : T1 -> T2) (e1 : Rel T1) e2 : 115 | (forall x y, e1 x y -> conv e2 (f x) (f y)) -> 116 | (forall x y, conv e1 x y -> conv e2 (f x) (f y)). 117 | Proof. 118 | move=> A x y. elim=> //=y' z _ B /A. exact: conv_trans. 119 | move=> C. apply: conv_trans B _. exact: conv_sym. 120 | Qed. 121 | 122 | Lemma conv_hom T1 T2 (f : T1 -> T2) (e1 : Rel T1) (e2 : Rel T2) : 123 | (forall x y, e1 x y -> e2 (f x) (f y)) -> 124 | (forall x y, conv e1 x y -> conv e2 (f x) (f y)). 125 | Proof. 126 | move=> A. apply: conv_img => x y /A. exact: conv1. 127 | Qed. 128 | 129 | Arguments star_img {T1 T2} f e1 {e2} A x y B. 130 | Arguments star_hom {T1 T2} f e1 {e2} A x y B. 131 | Arguments conv_img {T1 T2} f e1 {e2} A x y B. 132 | Arguments conv_hom {T1 T2} f e1 {e2} A x y B. 133 | 134 | Lemma star_closure T (e1 e2 : Rel T) : e1 <=2 star e2 -> star e1 <=2 star e2. 135 | Proof. exact: star_img. Qed. 136 | 137 | Lemma star_monotone T (e1 e2 : Rel T) : e1 <=2 e2 -> star e1 <=2 star e2. 138 | Proof. move=> A. apply: star_closure => x y /A. exact: star1. Qed. 139 | 140 | Lemma eq_star T (e1 e2 : Rel T) : 141 | e1 <=2 star e2 -> e2 <=2 star e1 -> star e1 <=>2 star e2. 142 | Proof. move=> A B. split; exact: star_closure. Qed. 143 | 144 | Lemma star_interpolation T (e1 e2 : Rel T) : 145 | e1 <=2 e2 -> e2 <=2 star e1 -> star e1 <=>2 star e2. 146 | Proof. move=> A B. apply: eq_star => // x y /A. exact: star1. Qed. 147 | 148 | Lemma confluent_stable T (e1 e2 : Rel T) : 149 | star e1 <=>2 star e2 -> confluent e1 -> confluent e2. 150 | Proof. 151 | move=>[A B] C x y z /B exy /B exz. case: (C _ _ _ exy exz) => u /A eyu /A ezu. 152 | by exists u. 153 | Qed. 154 | 155 | Lemma conv_closure T (e1 e2 : Rel T) : e1 <=2 conv e2 -> conv e1 <=2 conv e2. 156 | Proof. 157 | move=> A x y. elim=> //=y' z _ B /A. exact: conv_trans. 158 | move=> C. apply: conv_trans B _. exact: conv_sym. 159 | Qed. 160 | 161 | (** **** Commutation Properties *) 162 | 163 | Section Commutation. 164 | Variable T : Type. 165 | 166 | Lemma com_strip (e1 e2 : Rel T) : com e1 e2 -> com (star e2) e1. 167 | Proof. 168 | move=> A x y z. elim=> {y} [B|y w C ih eyw /ih[u eyu s]]. by exists z. 169 | case: (A _ _ _ eyu eyw) => v euv ewv. exists v => //. exact: starSE euv. 170 | Qed. 171 | 172 | Lemma com_lift (e1 e2 : Rel T) : com e1 e2 -> com (star e1) (star e2). 173 | Proof. by move/com_strip/com_strip. Qed. 174 | 175 | Corollary diamond_confluent (e : Rel T) : diamond e -> confluent e. 176 | Proof. exact: com_lift. Qed. 177 | 178 | End Commutation. 179 | 180 | (** **** Weak and Strong Normalization *) 181 | 182 | Section Termination. 183 | Variables (T : Type) (e : Rel T). 184 | 185 | Definition reducible x := exists y, e x y. 186 | Definition normal x := ~ reducible x. 187 | 188 | Definition nf x y := star e x y /\ normal y. 189 | Definition wn x := exists y, nf x y. 190 | 191 | Inductive sn x : Prop := 192 | | SNI : (forall y, e x y -> sn y) -> sn x. 193 | 194 | Lemma sn_preimage (h : T -> T) x : 195 | (forall x y, e x y -> e (h x) (h y)) -> sn (h x) -> sn x. 196 | Proof. 197 | move eqn:(h x) => v A B. elim: B h x A eqn => {} v _ ih h x A eqn. 198 | apply: SNI => y /A. rewrite eqn => /ih; eauto. 199 | Qed. 200 | 201 | Lemma normal_star x y : star e x y -> normal x -> x = y. 202 | Proof. move=> A B. elim: A => // y' z _ <- A. case: B. by exists z. Qed. 203 | 204 | Hypothesis cr : CR e. 205 | 206 | Lemma cr_star_normal x y : conv e x y -> normal y -> star e x y. 207 | Proof. move=> /cr[z A B] C. by rewrite (normal_star B C). Qed. 208 | 209 | Lemma cr_conv_normal x y : conv e x y -> normal x -> normal y -> x = y. 210 | Proof. by move=> /cr[z A B] /(normal_star A)->/(normal_star B)->. Qed. 211 | 212 | End Termination. 213 | 214 | (** **** Cofinal and Normalizing Strategies *) 215 | 216 | Section CoFinal. 217 | Variables (T : Type) (e : Rel T) (rho : T -> T). 218 | 219 | Definition normalizing := 220 | forall x y, nf e x y -> exists n, y = iter n rho x. 221 | 222 | Definition cofinal := 223 | forall x y, star e x y -> exists n, star e y (iter n rho x). 224 | 225 | Lemma cofinal_normalizing : cofinal -> normalizing. 226 | Proof. move=> A x y [/A[n B] C]. exists n. exact: normal_star C. Qed. 227 | 228 | Definition triangle := forall x y, e x y -> e y (rho x). 229 | 230 | Lemma triangle_diamond : triangle -> diamond e. 231 | Proof. move=> A x y z exy exz. exists (rho x); exact: A. Qed. 232 | 233 | Hypothesis tri : triangle. 234 | 235 | Lemma triangle_monotone x y : e x y -> e (rho x) (rho y). 236 | Proof. by move/tri/tri. Qed. 237 | 238 | Lemma triangle_cofinal : cofinal. 239 | Proof. 240 | move=> x y. elim=> //=[|y' z A [n ih] B]. by exists 0. 241 | exists n.+1. apply: starES (tri B) _. rewrite iterS. 242 | apply: star_img ih => a b /triangle_monotone. exact: star1. 243 | Qed. 244 | 245 | End CoFinal. 246 | 247 | (** **** The Tait, Martin-Loef, Takahashi confluence proof method. *) 248 | 249 | Lemma cr_method T (e1 e2 : Rel T) (rho : T -> T) : 250 | e1 <=2 e2 -> e2 <=2 star e1 -> triangle e2 rho -> CR e1. 251 | Proof. 252 | move=> A B C. apply confluent_cr. 253 | have[D1 D2]: star e1 <=>2 star e2. exact: star_interpolation. 254 | have: confluent e2. apply: diamond_confluent. exact: triangle_diamond C. 255 | exact: confluent_stable. 256 | Qed. 257 | 258 | (** **** Computing normal forms *) 259 | 260 | Section ComputationN. 261 | Variables (T : Type) (e : Rel T) (rho : T -> T). 262 | Hypothesis norm : normalizing e rho. 263 | Hypothesis sound : forall x, star e x (rho x). 264 | Hypothesis classical : forall x, {reducible e x} + {normal e x}. 265 | 266 | Inductive accn (x : T) : Prop := 267 | | accnH : normal e x -> accn x 268 | | accnL : accn (rho x) -> accn x. 269 | Scheme accn_ind' := Induction for accn Sort Prop. 270 | 271 | Lemma nf_accn x y : nf e x y -> accn x. 272 | Proof. 273 | move=> A. case: (norm A) => n. case: A => _. move/accnH. 274 | elim: n y => [|n ih] y A /= B. by rewrite -B. 275 | apply: (ih (iter n rho x)) => //. apply: accnL. by rewrite -B. 276 | Qed. 277 | 278 | Lemma wn_accn x : wn e x -> accn x. 279 | Proof. 280 | move=> [y]. exact: nf_accn. 281 | Qed. 282 | 283 | Lemma sn_wn x : sn e x -> wn e x. 284 | Proof. 285 | elim=> {} x _ ih. case (classical x) => [[y exy]|A]. 286 | - case: (ih _ exy) => z [A B]. exists z. split=> //. exact: starES A. 287 | - exists x. by split. 288 | Qed. 289 | 290 | Lemma accn_inv x (H1 : accn x) (H2 : reducible e x) : accn (rho x). 291 | Proof. by case: H1. Defined. 292 | 293 | Fixpoint evaln x (H : accn x) : T := 294 | match classical x with 295 | | left a => evaln (accn_inv H a) 296 | | right _ => x 297 | end. 298 | 299 | Lemma evaln_sound x (H : accn x) : nf e x (evaln H). 300 | Proof. 301 | move: x H. apply: accn_ind'. 302 | - move=> x n /=. by case: (classical x). 303 | - move=> x a [A B] /=. case: (classical x) => //= _. 304 | split=>//. apply: star_trans A. exact: sound. 305 | Qed. 306 | 307 | Theorem evalnP x : ex (nf e x) -> sig (nf e x). 308 | Proof. 309 | move=> A. exists (evaln (wn_accn A)). exact: evaln_sound. 310 | Qed. 311 | 312 | End ComputationN. 313 | 314 | (* Local Variables: *) 315 | (* coq-load-path: (("." "Ssr")) *) 316 | (* End: *) 317 | -------------------------------------------------------------------------------- /examples/ssr/AutosubstSsr.v: -------------------------------------------------------------------------------- 1 | (** * Autosubst wrapper for ssreflect *) 2 | Require Export Autosubst.Autosubst_Basics. 3 | Require Export Autosubst.Autosubst_MMap. 4 | Require Export Autosubst.Autosubst_Classes. 5 | Require Export Autosubst.Autosubst_Tactics. 6 | Require Export Autosubst.Autosubst_Lemmas. 7 | Require Export Autosubst.Autosubst_Derive. 8 | From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq. 9 | From Coq Require Import ssrfun. 10 | 11 | Set Implicit Arguments. 12 | Unset Strict Implicit. 13 | Unset Printing Implicit Defensive. 14 | 15 | Section MMapInstances. 16 | 17 | Variable (A B C : Type). 18 | Variable (MMap_A_B : MMap A B). 19 | Variable (MMap_A_C : MMap A C). 20 | Variable (MMapLemmas_A_B : MMapLemmas A B). 21 | Variable (MMapLemmas_A_C : MMapLemmas A C). 22 | Variable (MMapExt_A_B : MMapExt A B). 23 | Variable (MMapExt_A_C : MMapExt A C). 24 | 25 | 26 | Global Instance MMap_option : MMap A (option B) := fun f => omap (mmap f). 27 | Global Instance MMapLemmas_option : MMapLemmas A (option B). derive. Qed. 28 | Global Instance MMapExt_option : MMapExt A (option B). derive. Defined. 29 | 30 | 31 | Global Instance MMap_pair : MMap A (B * C). derive. Defined. 32 | Global Instance MMapLemmas_pair : MMapLemmas A (B * C). derive. Qed. 33 | Global Instance MMapExt_pair : MMapExt A (B * C). derive. Defined. 34 | 35 | 36 | Global Instance mmap_seq : MMap A (seq B) := fun f => map (mmap f). 37 | Global Instance mmapLemmas_seq : MMapLemmas A (seq B). derive. Qed. 38 | Global Instance mmapExt_seq : MMapExt A (seq B). derive. Defined. 39 | 40 | 41 | Global Instance MMap_fun : MMap A (B -> C) := fun f g x => mmap f (g x). 42 | 43 | Global Instance MMapLemmas_fun : MMapLemmas A (B -> C). 44 | Proof. 45 | constructor; intros; f_ext; intros; [apply mmap_id|apply mmap_comp]. 46 | Qed. 47 | 48 | Global Instance MMapExt_fun : MMapExt A (B -> C). 49 | Proof. 50 | hnf. intros f g H h. f_ext. intro x. apply mmap_ext. exact H. 51 | Defined. 52 | 53 | End MMapInstances. 54 | 55 | (* Local Variables: *) 56 | (* coq-load-path: (("." "Ssr") ("../../theories" "Autosubst")) *) 57 | (* End: *) 58 | -------------------------------------------------------------------------------- /examples/ssr/BetaSubstitution.v: -------------------------------------------------------------------------------- 1 | (** * Correctness of Single Variable Substitutions *) 2 | From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq. 3 | Require Import Autosubst. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | 8 | (** Untyped Lambda Terms and Parallel Substitutions *) 9 | 10 | Inductive term := 11 | | Var (x : var) 12 | | App (s t : term) 13 | | Lam (s : {bind term}). 14 | 15 | Global Instance Ids_term : Ids term. derive. Defined. 16 | Global Instance Rename_term : Rename term. derive. Defined. 17 | Global Instance Subst_term : Subst term. derive. Defined. 18 | Global Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 19 | 20 | (** The optimized implementation of single variable substitutions *) 21 | 22 | Fixpoint lift_at (d k : nat) (s : term) : term := 23 | match s with 24 | | Var i => if i < d then Var i else Var (k + i) 25 | | App s t => App (lift_at d k s) (lift_at d k t) 26 | | Lam s => Lam (lift_at d.+1 k s) 27 | end. 28 | Notation lift := (lift_at 0). 29 | 30 | Fixpoint sbst_at (d : nat) (t s : term) : term := 31 | match s with 32 | | Var x => if x < d then Var x else if x == d then lift d t else Var x.-1 33 | | App s1 s2 => App (sbst_at d t s1) (sbst_at d t s2) 34 | | Lam s => Lam (sbst_at d.+1 t s) 35 | end. 36 | Notation sbst := (sbst_at 0). 37 | 38 | (** Soundness proof *) 39 | 40 | Lemma lift_at_sound d k s : 41 | lift_at d k s = s.[upn d (ren (+k))]. 42 | Proof. 43 | elim: s d => /=[x|s ihs t iht|s ih] d. 44 | - elim: d x => //= d ih [|x] //. rewrite iterate_S; asimpl. 45 | by rewrite -ih (fun_if (subst (ren (+1)))). 46 | - by rewrite ihs iht. 47 | - by rewrite ih. 48 | Qed. 49 | 50 | Lemma lift_sound k s : 51 | lift k s = s.[ren (+k)]. 52 | Proof. 53 | exact: lift_at_sound. 54 | Qed. 55 | 56 | Lemma upnP n sigma x : 57 | upn n sigma x = 58 | if x < n then Var x else (sigma (x - n)).[ren (+n)]. 59 | Proof. 60 | case: ifPn. 61 | - elim: x n =>[|x ih][|n]//=/ih e. rewrite iterate_S. asimpl. by rewrite e. 62 | - rewrite -leqNgt. elim: x n => [|x ih][|n]; try autosubst. by case: n. 63 | move=>/ih e. rewrite iterate_S. asimpl. rewrite e. autosubst. 64 | Qed. 65 | 66 | Lemma sbst_at_sound d t s : 67 | sbst_at d t s = s.[upn d (t .: ids)]. 68 | Proof. 69 | elim: s d => /=[x|s1 ih1 s2 ih2|s ih] d. 70 | - rewrite lift_sound. rewrite upnP. case: ifPn => //=. rewrite -leqNgt => le. 71 | case: ifP => [/eqP->|/eqP/eqP]. by rewrite subnn. rewrite neq_ltn =>/orP[|{le}]//. 72 | move=> /leq_trans/(_ le). by rewrite ltnn. rewrite -subn_gt0 => p. 73 | move: (p) => /ltn_predK<-/=. rewrite/ids/Ids_term. f_equal. 74 | case: x p => //= n p. rewrite subSKn plusE subnKC //. by rewrite subn_gt0 in p. 75 | - by rewrite ih1 ih2. 76 | - by rewrite ih. 77 | Qed. 78 | 79 | Lemma sbst_sound t s : 80 | sbst t s = s.[t/]. 81 | Proof. 82 | exact: sbst_at_sound. 83 | Qed. 84 | -------------------------------------------------------------------------------- /examples/ssr/CR.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq. 2 | From Coq Require Import ssrfun. 3 | Require Import AutosubstSsr ARS. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | (** **** Untyped Lambda Calculus *) 10 | 11 | Inductive term : Type := 12 | | Var (x : var) 13 | | App (s t : term) 14 | | Lam (s : {bind term}). 15 | 16 | Global Instance Ids_term : Ids term. derive. Defined. 17 | Global Instance Rename_term : Rename term. derive. Defined. 18 | Global Instance Subst_term : Subst term. derive. Defined. 19 | Global Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 20 | 21 | (** **** One-Step Reduction *) 22 | 23 | Inductive step : term -> term -> Prop := 24 | | step_beta s t : 25 | step (App (Lam s) t) s.[t/] 26 | | step_appL s1 s2 t : 27 | step s1 s2 -> step (App s1 t) (App s2 t) 28 | | step_appR s t1 t2 : 29 | step t1 t2 -> step (App s t1) (App s t2) 30 | | step_lam s1 s2 : 31 | step s1 s2 -> step (Lam s1) (Lam s2). 32 | 33 | Notation red := (star step). 34 | Notation "s === t" := (conv step s t) (at level 50). 35 | 36 | (* 37 | Lemma step_ebeta (s t u : term) : s.[t/] = u -> step (App (Lam s) t) u. 38 | Proof. move<-. exact: step_beta. Qed. 39 | 40 | Lemma step_subst sigma s t : step s t -> step s.[sigma] t.[sigma]. 41 | Proof. 42 | move=> st. elim: st sigma => /={s t}; eauto using step. 43 | move=> s t sigma. apply: step_ebeta. by autosubst. 44 | Qed. 45 | *) 46 | 47 | (** **** Many-Step Reduction *) 48 | 49 | Lemma red_app s1 s2 t1 t2 : 50 | red s1 s2 -> red t1 t2 -> red (App s1 t1) (App s2 t2). 51 | Proof. 52 | move=> A B. apply: (star_trans (App s2 t1)). 53 | - apply: (star_hom (App^~ t1)) A => x y. exact: step_appL. 54 | - apply: star_hom B => x y. exact: step_appR. 55 | Qed. 56 | 57 | Lemma red_lam s1 s2 : red s1 s2 -> red (Lam s1) (Lam s2). 58 | Proof. apply: star_hom => x y. exact: step_lam. Qed. 59 | 60 | Global Hint Resolve red_app red_lam : red_congr. 61 | 62 | (** **** Church-Rosser theorem *) 63 | 64 | Inductive pstep : term -> term -> Prop := 65 | | pstep_beta (s1 s2 t1 t2 : term) : 66 | pstep s1 s2 -> pstep t1 t2 -> pstep (App (Lam s1) t1) s2.[t2/] 67 | | pstep_var (x : var) : 68 | pstep (Var x) (Var x) 69 | | pstep_app (s1 s2 t1 t2 : term) : 70 | pstep s1 s2 -> pstep t1 t2 -> pstep (App s1 t1) (App s2 t2) 71 | | pstep_lam (s1 s2 : term) : 72 | pstep s1 s2 -> pstep (Lam s1) (Lam s2). 73 | 74 | Definition psstep (sigma tau : var -> term) := 75 | forall x, pstep (sigma x) (tau x). 76 | 77 | Fixpoint rho (s : term) : term := 78 | match s with 79 | | App (Lam s) t => (rho s).[rho t/] 80 | | App s t => App (rho s) (rho t) 81 | | Lam s => Lam (rho s) 82 | | x => x 83 | end. 84 | 85 | Lemma pstep_ebeta s1 s2 t1 t2 u : 86 | s2.[t2/] = u -> pstep s1 s2 -> pstep t1 t2 -> pstep (App (Lam s1) t1) u. 87 | Proof. move<-. exact: pstep_beta. Qed. 88 | 89 | Lemma pstep_refl s : pstep s s. 90 | Proof. elim: s; eauto using pstep. Qed. 91 | Global Hint Resolve pstep_refl : core. 92 | 93 | Lemma step_pstep s t : step s t -> pstep s t. 94 | Proof. elim; eauto using pstep. Qed. 95 | 96 | Lemma pstep_red s t : pstep s t -> red s t. 97 | Proof with eauto with red_congr. 98 | elim=> {s t} //=... move=> s1 s2 t1 t2 _ A _ B. 99 | apply: (star_trans (App (Lam s2) t2))... exact/star1/step_beta. 100 | Qed. 101 | 102 | Lemma pstep_subst sigma s t : 103 | pstep s t -> pstep s.[sigma] t.[sigma]. 104 | Proof with eauto using pstep. 105 | move=> A. elim: A sigma => /=... move=> s1 s2 t1 t2 _ A _ B sigma. 106 | eapply pstep_ebeta... by autosubst. 107 | Qed. 108 | 109 | Lemma psstep_up sigma tau : 110 | psstep sigma tau -> psstep (up sigma) (up tau). 111 | Proof. 112 | move=> A [|n] //=; asimpl. apply: pstep_subst. exact: A. 113 | Qed. 114 | 115 | Lemma pstep_compat sigma tau s t : 116 | psstep sigma tau -> pstep s t -> pstep s.[sigma] t.[tau]. 117 | Proof with eauto using pstep, psstep_up. 118 | move=> A B. elim: B sigma tau A; asimpl... 119 | move=> s1 s2 t1 t2 _ A _ B sigma tau C. 120 | apply: (@pstep_ebeta _ (s2.[up tau]) _ (t2.[tau])); asimpl... 121 | Qed. 122 | 123 | Lemma pstep_compat_beta s1 s2 t1 t2 : 124 | pstep s1 s2 -> pstep t1 t2 -> pstep s1.[t1/] s2.[t2/]. 125 | Proof. 126 | move=> A B. by apply: pstep_compat A => -[|]. 127 | Qed. 128 | 129 | Lemma rho_triangle : triangle pstep rho. 130 | Proof with eauto using pstep. 131 | move=> s t. elim=> {s t} //=... 132 | - move=> s1 s2 t1 t2 _ A _ B. exact: pstep_compat_beta. 133 | - move=> s1 s2 t1 t2 A ih1 _ ih2. case: s1 A ih1 => //=... 134 | move=> s A ih1. inv A. inv ih1... 135 | Qed. 136 | 137 | Theorem church_rosser : 138 | forall s t, s === t -> joinable red s t. 139 | Proof. 140 | apply: (cr_method (e2 := pstep) (rho := rho)). 141 | exact: step_pstep. exact: pstep_red. exact: rho_triangle. 142 | Qed. 143 | -------------------------------------------------------------------------------- /examples/ssr/Context.v: -------------------------------------------------------------------------------- 1 | (** * Context 2 | 3 | Support for dependent contexts with the right reduction behaviour. *) 4 | From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq. 5 | Require Import AutosubstSsr. 6 | 7 | Definition get {T} `{Ids T} (Gamma : seq T) (n : var) : T := 8 | nth (ids 0) Gamma n. 9 | Arguments get {T _} Gamma n. 10 | 11 | Fixpoint dget {T} `{Ids T} `{Subst T} (Gamma : list T) (n : var) {struct n} : T := 12 | match Gamma, n with 13 | | [::], _ => ids 0 14 | | A :: _, 0 => A.[ren (+1)] 15 | | _ :: Gamma, n.+1 => (dget Gamma n).[ren (+1)] 16 | end. 17 | Arguments dget {T _ _} Gamma n. 18 | 19 | Lemma get_map {T} `{Ids T} (f : T -> T) Gamma n : 20 | n < size Gamma -> get (map f Gamma) n = f (get Gamma n). 21 | Proof. exact: nth_map. Qed. 22 | 23 | (* Local Variables: *) 24 | (* coq-load-path: (("." "Ssr")) *) 25 | (* End: *) 26 | -------------------------------------------------------------------------------- /examples/ssr/Makefile: -------------------------------------------------------------------------------- 1 | COQMAKEFILE := Makefile.coq 2 | COQMAKE := +$(MAKE) -f $(COQMAKEFILE) 3 | 4 | LIB := ../../theories 5 | VS := $(wildcard *.v) 6 | 7 | all: $(COQMAKEFILE) 8 | +$(MAKE) -f $(COQMAKEFILE) all 9 | 10 | $(COQMAKEFILE): Makefile $(VS) 11 | coq_makefile -R $(LIB) Autosubst $(VS) -R . Ssr -o $(COQMAKEFILE) 12 | 13 | clean: $(COQMAKEFILE) 14 | -$(COQMAKE) clean 15 | rm -f $(COQMAKEFILE) 16 | 17 | .PHONY: all clean 18 | -------------------------------------------------------------------------------- /examples/ssr/POPLmark.v: -------------------------------------------------------------------------------- 1 | (** * POPLmark Part 1a + 2a 2 | 3 | The #POPLmark# 4 | challenge is a set of benchmark problems to evaluate approaches to the 5 | formalization of syntactic theories. We solve parts 1a and 2a, that is, 6 | progress and preservation of System F with subtyping. 7 | 8 | The formalization in this file does not follow the paper proofs as closely, 9 | and in particular does not contain well-formedness assumptions. 10 | *) 11 | 12 | From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq. 13 | Require Import AutosubstSsr Context. 14 | 15 | (** **** Syntax *) 16 | 17 | Inductive type : Type := 18 | | TyVar (x : var) 19 | | Top 20 | | Arr (A1 A2 : type) 21 | | All (A1 : type) (A2 : {bind type}). 22 | 23 | Inductive term := 24 | | TeVar (x : var) 25 | | Abs (A : type) (s : {bind term}) 26 | | App (s t : term) 27 | | TAbs (A : type) (s : {bind type in term}) 28 | | TApp (s : term) (A : type). 29 | 30 | (** **** Substitutions *) 31 | 32 | Global Instance Ids_type : Ids type. derive. Defined. 33 | Global Instance Rename_type : Rename type. derive. Defined. 34 | Global Instance Subst_type : Subst type. derive. Defined. 35 | Global Instance SubstLemmas_type : SubstLemmas type. derive. Qed. 36 | Global Instance HSubst_term : HSubst type term. derive. Defined. 37 | Global Instance Ids_term : Ids term. derive. Defined. 38 | Global Instance Rename_term : Rename term. derive. Defined. 39 | Global Instance Subst_term : Subst term. derive. Defined. 40 | Global Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed. 41 | Global Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed. 42 | Global Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 43 | 44 | (** **** Subtyping *) 45 | 46 | Notation "Gamma `_ x" := (dget Gamma x) (at level 2). 47 | Notation "Gamma ``_ x" := (get Gamma x) (at level 3, x at level 2, 48 | left associativity, format "Gamma ``_ x"). 49 | 50 | Reserved Notation "'SUB' Gamma |- A <: B" 51 | (at level 68, A at level 99, no associativity). 52 | Inductive sub (Gamma : list type) : type -> type -> Prop := 53 | | sub_top A : 54 | SUB Gamma |- A <: Top 55 | | sub_var_refl x : 56 | SUB Gamma |- TyVar x <: TyVar x 57 | | sub_var_trans x A : 58 | x < size Gamma -> SUB Gamma |- Gamma`_x <: A -> SUB Gamma |- TyVar x <: A 59 | | sub_fun A1 A2 B1 B2 : 60 | SUB Gamma |- B1 <: A1 -> SUB Gamma |- A2 <: B2 -> 61 | SUB Gamma |- Arr A1 A2 <: Arr B1 B2 62 | | sub_all A1 A2 B1 B2 : 63 | SUB Gamma |- B1 <: A1 -> SUB (B1 :: Gamma) |- A2 <: B2 -> 64 | SUB Gamma |- All A1 A2 <: All B1 B2 65 | where "'SUB' Gamma |- A <: B" := (sub Gamma A B). 66 | 67 | Lemma sub_refl Gamma A : SUB Gamma |- A <: A. 68 | Proof. elim: A Gamma; eauto using sub. Qed. 69 | Global Hint Resolve sub_refl : core. 70 | 71 | Lemma sub_ren Gamma Delta xi A B : 72 | (forall x, x < size Gamma -> xi x < size Delta) -> 73 | (forall x, x < size Gamma -> Delta`_(xi x) = (Gamma`_x).[ren xi]) -> 74 | SUB Gamma |- A <: B -> SUB Delta |- A.[ren xi] <: B.[ren xi]. 75 | Proof. 76 | move=> sub eqn ty. elim: ty Delta xi sub eqn => {A B} Gamma //=; 77 | eauto using sub. 78 | - move=> x A lt _ ih Delta xi sub eqn. apply: sub_var_trans. exact: sub. 79 | rewrite eqn //. exact: ih. 80 | - move=> A1 A2 B1 B2 _ ih1 _ ih2 Delta xi sub eqn. apply: sub_all. 81 | exact: ih1. asimpl. apply: ih2. by move=> [|x /sub]. 82 | move=> [_|x /eqn/=->]; autosubst. 83 | Qed. 84 | 85 | Lemma sub_weak Gamma A B C : 86 | SUB Gamma |- A <: B -> SUB (C :: Gamma) |- A.[ren (+1)] <: B.[ren (+1)]. 87 | Proof. exact: sub_ren. Qed. 88 | 89 | Definition transitivity_at (B : type) := forall Gamma A C xi, 90 | SUB Gamma |- A <: B.[ren xi] -> SUB Gamma |- B.[ren xi] <: C -> 91 | SUB Gamma |- A <: C. 92 | 93 | Lemma transitivity_proj Gamma A B C : 94 | transitivity_at B -> 95 | SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C. 96 | Proof. move=> /(_ Gamma A C id). autosubst. Qed. 97 | Global Hint Resolve transitivity_proj : core. 98 | 99 | Lemma transitivity_ren B xi : transitivity_at B -> transitivity_at B.[ren xi]. 100 | Proof. move=> h Gamma A C zeta. asimpl. exact: h. Qed. 101 | 102 | Lemma sub_narrow_t Gamma Delta A B : 103 | (forall x, x < size Gamma -> x < size Delta) -> 104 | (forall x, x < size Gamma -> SUB Delta |- Delta`_x <: Gamma`_x) -> 105 | (forall x, x < size Gamma -> 106 | Delta`_x = Gamma`_x \/ transitivity_at (Gamma`_x)) -> 107 | SUB Gamma |- A <: B -> SUB Delta |- A <: B. 108 | Proof with eauto using sub. 109 | move=> h1 h2 h3 ty. elim: ty Delta h1 h2 h3 => {Gamma A B} /=... 110 | - move=> Gamma x A lt _ ih Delta h1 h2 h3. apply: sub_var_trans... 111 | case: (h3 x lt) => [->|]... 112 | - move=> Gamma A1 A2 B1 B2 _ ih1 _ ih2 Delta h1 h2 h3. apply: sub_all... 113 | apply: ih2 => [[|x /h1]|[|x /h2/sub_weak]|[_|x /h3[|]]] //=... 114 | move=>->... move=> tr. right. exact: transitivity_ren. 115 | Qed. 116 | 117 | Definition is_var (A : type) : bool := if A is TyVar _ then true else false. 118 | 119 | Lemma sub_trans_snoc Gamma B C : 120 | (forall A, ~~is_var A -> 121 | SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C) -> 122 | forall A, SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C. 123 | Proof with eauto using sub. 124 | move=> h A ty. elim: ty C h =>{Gamma A B}... move=> Gamma A C h1 h2. inv h2... 125 | Qed. 126 | 127 | Lemma sub_trans_t B : transitivity_at B. 128 | Proof with eauto using sub. 129 | elim: B => [x||B1 ih1 B2 ih2|B1 ih1 B2 ih2] Gamma A C xi; asimpl... 130 | - apply: sub_trans_snoc A => A e ty. by inv ty. 131 | - move=> t1 t2. inv t2... 132 | - apply: sub_trans_snoc A => A e ty1 ty2. inv ty1 => //. inv ty2... 133 | - apply: sub_trans_snoc A => A e ty1 ty2. inv ty1 => //. inv ty2... 134 | apply: sub_all... eapply ih2... move: H3. apply: sub_narrow_t... 135 | + case=> //= _. exact: sub_weak. 136 | + move=> [|x] _... right => /=. asimpl. exact: transitivity_ren. 137 | Qed. 138 | 139 | Corollary sub_trans Gamma A B C : 140 | SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C. 141 | Proof. move: (sub_trans_t B); eauto. Qed. 142 | 143 | Corollary sub_narrow Gamma A B C1 C2 : 144 | SUB Gamma |- C1 <: C2 -> SUB C2 :: Gamma |- A <: B -> 145 | SUB C1 :: Gamma |- A <: B. 146 | Proof. 147 | move=> ty. apply: sub_narrow_t => //. 148 | - case=> //= _. exact: sub_weak. 149 | - move=> [_/=|x]; eauto. right. apply: transitivity_ren. exact: sub_trans_t. 150 | Qed. 151 | 152 | Lemma sub_subst Gamma Delta A B sigma : 153 | (forall x, x < size Gamma -> SUB Delta |- sigma x <: (Gamma`_x).[sigma]) -> 154 | SUB Gamma |- A <: B -> SUB Delta |- A.[sigma] <: B.[sigma]. 155 | Proof with eauto using sub. 156 | move=> h ty. elim: ty Delta sigma h => {A B} Gamma... 157 | - move=> x A lt _ ih Delta sigma h /=. apply: sub_trans (h _ lt) _. exact: ih. 158 | - move=> A1 A2 B1 B2 _ ih1 _ ih2 Delta sigma h /=. apply: sub_all... 159 | apply: ih2 => -[_|x /h/sub_weak]. apply: sub_var_trans => //. autosubst. 160 | autosubst. 161 | Qed. 162 | 163 | (** **** Typing *) 164 | 165 | Reserved Notation "'TY' Delta ; Gamma |- A : B" 166 | (at level 68, A at level 99, no associativity, 167 | format "'TY' Delta ; Gamma |- A : B"). 168 | Inductive ty (Delta Gamma : list type) : term -> type -> Prop := 169 | | ty_var x : 170 | x < size Gamma -> 171 | TY Delta;Gamma |- TeVar x : Gamma``_x 172 | | ty_abs A B s : 173 | TY Delta;A::Gamma |- s : B -> 174 | TY Delta;Gamma |- Abs A s : Arr A B 175 | | ty_app A B s t: 176 | TY Delta;Gamma |- s : Arr A B -> TY Delta;Gamma |- t : A -> 177 | TY Delta;Gamma |- App s t : B 178 | | ty_tabs A B s : 179 | TY A::Delta;Gamma..[ren (+1)] |- s : B -> 180 | TY Delta;Gamma |- TAbs A s : All A B 181 | | ty_tapp A B C s : 182 | TY Delta;Gamma |- s : All A B -> SUB Delta |- C <: A -> 183 | TY Delta;Gamma |- TApp s C : B.[C/] 184 | | ty_sub A B s : 185 | TY Delta;Gamma |- s : A -> SUB Delta |- A <: B -> 186 | TY Delta;Gamma |- s : B 187 | where "'TY' Delta ; Gamma |- s : A" := (ty Delta Gamma s A). 188 | 189 | Definition value (s : term) : bool := 190 | match s with Abs _ _ | TAbs _ _ => true | _ => false end. 191 | 192 | Reserved Notation "'EV' s => t" 193 | (at level 68, s at level 80, no associativity, format "'EV' s => t"). 194 | Inductive eval : term -> term -> Prop := 195 | | E_AppAbs A s t : EV App (Abs A s) t => s.[t/] 196 | | E_TAppTAbs A s B : EV TApp (TAbs A s) B => s.|[B/] 197 | | E_AppFun s s' t : 198 | EV s => s' -> 199 | EV App s t => App s' t 200 | | E_AppArg s s' v: 201 | EV s => s' -> value v -> 202 | EV App v s => App v s' 203 | | E_TypeFun s s' A : 204 | EV s => s' -> 205 | EV TApp s A => TApp s' A 206 | where "'EV' s => t" := (eval s t). 207 | 208 | Lemma ty_evar Delta Gamma x A : 209 | A = Gamma``_x -> x < size Gamma -> TY Delta;Gamma |- TeVar x : A. 210 | Proof. move->. exact: ty_var. Qed. 211 | 212 | Lemma ty_etapp Delta Gamma A B C D s : 213 | D = B.[C/] -> 214 | TY Delta;Gamma |- s : All A B -> SUB Delta |- C <: A -> 215 | TY Delta;Gamma |- TApp s C : D. 216 | Proof. move->. exact: ty_tapp. Qed. 217 | 218 | (** **** Preservation *) 219 | 220 | Lemma ty_ren Delta Gamma1 Gamma2 s A xi : 221 | (forall x, x < size Gamma1 -> xi x < size Gamma2) -> 222 | (forall x, x < size Gamma1 -> Gamma2``_(xi x) = Gamma1``_x) -> 223 | TY Delta;Gamma1 |- s : A -> TY Delta;Gamma2 |- s.[ren xi] : A. 224 | Proof with eauto using ty. 225 | move=> h1 h2 ty. elim: ty Gamma2 xi h1 h2 => {Delta Gamma1 s A} /=... 226 | - move=> Delta Gamma1 x lt Gamma2 xi h1 h2. rewrite -h2 //. apply: ty_var... 227 | - move=> Delta Gamma1 A B s _ ih Gamma2 xi h1 h2. asimpl. apply: ty_abs. 228 | by apply: ih => [[|x/h1]|[|x/h2]]. 229 | - move=> Delta Gamma1 A B s _ ih Gamma2 xi h1 h2. apply: ty_tabs. 230 | apply: ih => x. by rewrite !size_map => /h1. rewrite !size_map => lt. 231 | rewrite !get_map ?h2 //. exact: h1. 232 | Qed. 233 | 234 | Lemma ty_weak Delta Gamma s A B : 235 | TY Delta;Gamma |- s : A -> TY Delta; B :: Gamma |- s.[ren (+1)] : A. 236 | Proof. exact: ty_ren. Qed. 237 | 238 | Lemma ty_hsubst Delta1 Delta2 Gamma s A sigma : 239 | (forall x, x < size Delta1 -> SUB Delta2 |- sigma x <: (Delta1`_x).[sigma]) -> 240 | TY Delta1;Gamma |- s : A -> TY Delta2;Gamma..[sigma] |- s.|[sigma] :A.[sigma]. 241 | Proof with eauto using ty. 242 | move=> h ty. elim: ty Delta2 sigma h => {Delta1 Gamma s A}/=... 243 | - move=> Delta1 Gamma x lt Delta2 sigma h. apply: ty_evar. by rewrite get_map. 244 | by rewrite size_map. 245 | - move=> Delta1 Gamma A B s _ ih Delta2 sigma h. apply: ty_tabs. 246 | specialize (ih (A.[sigma] :: Delta2) (up sigma)). move: ih. asimpl. 247 | apply. move=> [_|x/h/sub_weak] /=. apply: sub_var_trans => //. autosubst. 248 | autosubst. 249 | - move=> Delta1 Gamma A B C s _ ih sub Delta2 sigma h. asimpl. 250 | eapply ty_etapp. 2: { by eapply ih. } autosubst. exact: sub_subst sub. 251 | - move=> Delta1 Gamma A B s _ ih sub Delta2 sigma h. 252 | eapply ty_sub. by eapply ih. exact: sub_subst sub. 253 | Qed. 254 | 255 | Lemma ty_tweak Delta Gamma s A B : 256 | TY Delta;Gamma |- s : A -> 257 | TY B :: Delta; Gamma..[ren (+1)] |- s.|[ren (+1)] : A.[ren (+1)]. 258 | Proof. apply: ty_hsubst => x /= lt. exact: sub_var_trans. Qed. 259 | 260 | Lemma ty_subst Delta Gamma1 Gamma2 s A sigma : 261 | (forall x, x < size Gamma1 -> TY Delta;Gamma2 |- sigma x : Gamma1``_x) -> 262 | TY Delta;Gamma1 |- s : A -> TY Delta;Gamma2 |- s.[sigma] : A. 263 | Proof with eauto using ty. 264 | move=> h ty. elim: ty Gamma2 sigma h => {Delta Gamma1 s A}/=... 265 | - move=> Delta Gamma1 A B s _ ih Gamma2 sigma h /=. apply: ty_abs. 266 | apply: ih. move=> [_|x/h/ty_weak]... autosubst. 267 | - move=> Delta Gamma1 A B s _ ih Gamma2 sigma h. apply: ty_tabs. apply: ih. 268 | move=> x. rewrite size_map => lt. rewrite get_map //=. exact/ty_tweak/h. 269 | Qed. 270 | 271 | Lemma ty_narrow Delta Gamma s A B1 B2 : 272 | TY Delta;B2::Gamma |- s : A -> SUB Delta |- B1 <: B2 -> 273 | TY Delta;B1::Gamma |- s : A. 274 | Proof. 275 | move=> ty sub. rewrite -[s]subst_id. apply: ty_subst ty => -[_/=|x lt]; 276 | [apply: ty_sub sub|]; exact: ty_var. 277 | Qed. 278 | 279 | Lemma ty_beta Delta Gamma s t A B : 280 | TY Delta;Gamma |- t : A -> TY Delta;A::Gamma |- s : B -> 281 | TY Delta;Gamma |- s.[t/] : B. 282 | Proof. 283 | move=> ty. apply: ty_subst => -[|n lt] //=. exact: ty_var. 284 | Qed. 285 | 286 | Lemma ty_narrowT Delta Gamma s A B1 B2 : 287 | TY B2::Delta;Gamma |- s : A -> SUB Delta |- B1 <: B2 -> 288 | TY B1::Delta;Gamma |- s : A. 289 | Proof. 290 | move=> ty sub. cut (TY B1::Delta;Gamma..[ids] |- s.|[ids] : A.[ids]). 291 | autosubst. apply: ty_hsubst ty => -[_|x lt]; asimpl. 292 | apply: sub_var_trans => //=. exact: sub_weak. exact: sub_var_trans. 293 | Qed. 294 | 295 | Lemma ty_betaT Delta Gamma s A B C : 296 | SUB Delta |- C <: A -> TY A :: Delta;Gamma..[ren (+1)] |- s : B -> 297 | TY Delta;Gamma |- s.|[C/] : B.[C/]. 298 | Proof. 299 | move=> subt ty. 300 | cut (TY Delta;Gamma..[ren(+1)]..[C/] |- s.|[C/] : B.[C/]). autosubst. 301 | apply: ty_hsubst ty => -[_|x lt]; asimpl => //. exact: sub_var_trans. 302 | Qed. 303 | 304 | Lemma ty_inv_abs' Delta Gamma A A' B T s : 305 | TY Delta;Gamma |- Abs A s : T -> SUB Delta |- T <: Arr A' B -> 306 | TY Delta;A'::Gamma |- s : B. 307 | Proof. 308 | move e:(Abs A s) => t ty. elim: ty A A' B s e => {Delta Gamma t T} //. 309 | - move=> Delta Gamma A B s h _ A' A'' B' s' [e1 e2]. subst => sub. inv sub. 310 | apply: ty_narrow H2. exact: ty_sub h _. 311 | - move=> Delta Gamma A B s _ ih sub1 A' A'' B' s' eqn sub2. apply: ih eqn _. 312 | eapply (sub_trans _ _ _ _ sub1 sub2). 313 | Qed. 314 | 315 | Lemma ty_inv_abs Delta Gamma A A' B s : 316 | TY Delta;Gamma |- Abs A s : Arr A' B -> TY Delta;A'::Gamma |- s : B. 317 | Proof. move=> ty. apply: ty_inv_abs' ty _. eapply sub_refl. Qed. 318 | 319 | Lemma ty_inv_tabs' Delta Gamma A A' B T s : 320 | TY Delta;Gamma |- TAbs A s : T -> SUB Delta |- T <: All A' B -> 321 | TY A'::Delta;Gamma..[ren(+1)] |- s : B. 322 | Proof. 323 | move e:(TAbs A s) => t ty. elim: ty A A' B s e => {Delta Gamma t T} //. 324 | - move=> Delta Gamma A B s ty _ A' A'' B' s' [e1 e2] sub. subst. inv sub. 325 | apply: ty_sub H4. exact: ty_narrowT ty _. 326 | - move=> Delta Gamma A B s _ ih sub1 A' A'' B' s' e sub2. apply: ih e _. 327 | exact: sub_trans sub1 sub2. 328 | Qed. 329 | 330 | Lemma ty_inv_tabs Delta Gamma A A' B s : 331 | TY Delta;Gamma |- TAbs A s : All A' B -> 332 | TY A'::Delta;Gamma..[ren(+1)] |- s : B. 333 | Proof. move=> ty. exact: ty_inv_tabs' ty _. Qed. 334 | 335 | Theorem preservation Delta Gamma s t A : 336 | TY Delta;Gamma |- s : A -> EV s => t -> TY Delta;Gamma |- t : A. 337 | Proof with eauto using ty. 338 | move=> ty. elim: ty t => {Delta Gamma s A}... 339 | - move=> Delta Gamma x _ t ev. by inv ev. 340 | - move=> Delta Gamma A B s _ i t ev. by inv ev. 341 | - move=> Delta Gamma A B s t ty1 ih1 ty2 ih2 u ev. inv ev... 342 | move: ty1 => /ty_inv_abs. exact: ty_beta. 343 | - move=> Delta Gamma A B s _ _ t ev. by inv ev. 344 | - move=> Delta Gamma A B C s ty ih sub t ev. inv ev. 345 | + move: ty => /ty_inv_tabs. exact: ty_betaT. 346 | + apply: ty_tapp sub. exact: ih. 347 | Qed. 348 | 349 | (** **** Progress *) 350 | 351 | Definition is_abs s := if s is Abs _ _ then true else false. 352 | Definition is_tabs s := if s is TAbs _ _ then true else false. 353 | 354 | Lemma canonical_arr' Delta Gamma s T A B : 355 | TY Delta;Gamma |- s : T -> SUB Delta |- T <: Arr A B -> value s -> is_abs s. 356 | Proof. 357 | move=> ty. elim: ty A B => //= {Gamma s T} Delta Gamma A B s. 358 | - move=> ty _ A' B' sub. by inv sub. 359 | - move=> _ ih /sub_trans h A' B' /h. exact: ih. 360 | Qed. 361 | 362 | Lemma canonical_arr Delta Gamma s A B : 363 | TY Delta;Gamma |- s : Arr A B -> value s -> is_abs s. 364 | Proof. 365 | move=> ty. apply: canonical_arr' ty (sub_refl _ _). 366 | Qed. 367 | 368 | Lemma canonical_all' Delta Gamma s T A B : 369 | TY Delta;Gamma |- s : T -> SUB Delta |- T <: All A B -> value s -> is_tabs s. 370 | Proof. 371 | move=> ty. elim: ty A B => //= {Gamma s T} Delta Gamma A B s. 372 | - move=> _ _ A' B' sub. by inv sub. 373 | - move=> _ ih /sub_trans h A' B' /h. exact: ih. 374 | Qed. 375 | 376 | Lemma canonical_all Delta Gamma s A B : 377 | TY Delta;Gamma |- s : All A B -> value s -> is_tabs s. 378 | Proof. 379 | move=> ty. apply: canonical_all' ty (sub_refl _ _). 380 | Qed. 381 | 382 | Lemma ev_progress' Delta Gamma s A : 383 | TY Delta;Gamma |- s : A -> Gamma = [::] -> value s \/ exists t, EV s => t. 384 | Proof with eauto using eval. 385 | elim=> {Delta Gamma s A} /=; try solve [intuition]. 386 | - move=> _ Gamma x lt eqn. by subst. 387 | - move=> Delta Gamma A B s t ty1 ih1 _ ih2 eqn. right. 388 | case: (ih1 eqn) => {ih1} [vs|[s' h1]]... 389 | case: (ih2 eqn) => {ih2 eqn} [vt|[t' h2]]... 390 | case: s {ty1 vs} (canonical_arr _ _ _ _ _ ty1 vs) => //... 391 | - move=> Delta Gamma A B C s ty ih sub eqn. right. 392 | case: (ih eqn) => {ih eqn}[vs|[s' h]]... 393 | case: s {ty vs} (canonical_all _ _ _ _ _ ty vs) => //... 394 | Qed. 395 | 396 | Theorem ev_progress s A: 397 | TY nil;nil |- s : A -> value s \/ exists t, EV s => t. 398 | Proof. move=> ty. exact: ev_progress' ty _. Qed. 399 | 400 | (* Local Variables: *) 401 | (* coq-load-path: (("." "Ssr") ("../../theories" "Autosubst")) *) 402 | (* End: *) 403 | -------------------------------------------------------------------------------- /examples/ssr/SystemF_CBV.v: -------------------------------------------------------------------------------- 1 | (** * Normalization of Call-By-Value System F *) 2 | 3 | From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq. 4 | Require Import AutosubstSsr Context. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | (** **** Definitions *) 11 | 12 | Inductive type : Type := 13 | | TyVar (x : var) 14 | | Arr (A B : type) 15 | | All (A : {bind type}). 16 | 17 | Inductive term := 18 | | TeVar (x : var) 19 | | Abs (A : type) (s : {bind term}) 20 | | App (s t : term) 21 | | TAbs (s : {bind type in term}) 22 | | TApp (s : term) (A : type). 23 | 24 | (** **** Substitution Lemmas *) 25 | 26 | Global Instance Ids_type : Ids type. derive. Defined. 27 | Global Instance Rename_type : Rename type. derive. Defined. 28 | Global Instance Subst_type : Subst type. derive. Defined. 29 | 30 | Global Instance SubstLemmas_type : SubstLemmas type. derive. Qed. 31 | 32 | Global Instance HSubst_term : HSubst type term. derive. Defined. 33 | 34 | Global Instance Ids_term : Ids term. derive. Defined. 35 | Global Instance Rename_term : Rename term. derive. Defined. 36 | Global Instance Subst_term : Subst term. derive. Defined. 37 | 38 | Global Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed. 39 | Global Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed. 40 | 41 | Global Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 42 | 43 | (** **** Call-by value reduction *) 44 | 45 | Inductive eval : term -> term -> Prop := 46 | | eval_beta (A : type) (s t u1 u2 v : term) : 47 | eval s (Abs A u1) -> eval t u2 -> eval u1.[u2/] v -> eval (App s t) v 48 | | eval_tbeta (B : type) (s A v : term) : 49 | eval s (TAbs A) -> eval A.|[B/] v -> eval (TApp s B) v 50 | | eval_abs (A : type) (s : term) : 51 | eval (Abs A s) (Abs A s) 52 | | eval_tabs (A : term) : 53 | eval (TAbs A) (TAbs A). 54 | Global Hint Resolve eval_abs eval_tabs : core. 55 | 56 | (** **** Syntactic typing *) 57 | 58 | Definition ctx := seq type. 59 | Local Notation "Gamma `_ i" := (get Gamma i) (at level 2). 60 | 61 | Inductive has_type (Gamma : ctx) : term -> type -> Prop := 62 | | ty_var (x : var) : 63 | x < size Gamma -> has_type Gamma (TeVar x) Gamma`_x 64 | | ty_abs (A B : type) (s : term) : 65 | has_type (A :: Gamma) s B -> 66 | has_type Gamma (Abs A s) (Arr A B) 67 | | ty_app (A B : type) (s t : term) : 68 | has_type Gamma s (Arr A B) -> 69 | has_type Gamma t A -> 70 | has_type Gamma (App s t) B 71 | | ty_tabs (A : type) (s : term) : 72 | has_type Gamma..[ren (+1)] s A -> 73 | has_type Gamma (TAbs s) (All A) 74 | | ty_tapp (A B : type) (s : term) : 75 | has_type Gamma s (All A) -> 76 | has_type Gamma (TApp s B) A.[B/]. 77 | 78 | (** **** Semantic typing *) 79 | 80 | Definition L (P : term -> Prop) (s : term) := 81 | exists2 v, eval s v & P v. 82 | 83 | Fixpoint V (A : type) (rho : var -> term -> Prop) (v : term) {struct A} : Prop := 84 | match A with 85 | | TyVar X => eval v v /\ rho X v 86 | | Arr A B => exists A' : type, exists2 s : term, v = Abs A' s & 87 | forall u, V A rho u -> L (V B rho) s.[u/] 88 | | All A => exists2 s : term, v = TAbs s & 89 | forall i (B : type), L (V A (i .: rho)) s.|[B/] 90 | end. 91 | Notation E A rho := (L (V A rho)). 92 | 93 | Lemma V_value A rho v : V A rho v -> eval v v. 94 | Proof. by elim: A => [x[]|A _ B _/=[A'[s->]]|A _/=[s->]]. Qed. 95 | Global Hint Resolve V_value : core. 96 | 97 | Lemma V_to_E A rho v : V A rho v -> E A rho v. 98 | Proof. exists v; eauto. Qed. 99 | Global Hint Resolve V_to_E : core. 100 | 101 | Lemma eq_V A rho1 rho2 v : 102 | (forall X v, eval v v -> (rho1 X v <-> rho2 X v)) -> V A rho1 v -> V A rho2 v. 103 | Proof. 104 | elim: A rho1 rho2 v => //=. 105 | - move=> x rho1 rho2 v eqn [ev /eqn]. by intuition. 106 | - move=> A ih1 B ih2 rho1 rho2 v eqn [A' [s -> h]]. exists A'. 107 | exists s=>// u /ih1/h[]. by move=> X w; split; apply eqn. 108 | move=> w ev /ih2 ih. by exists w; eauto. 109 | - move=> A ih rho1 rho2 v eqn [s->h]. exists s => // P B. 110 | case: (h P B) => u ev /ih va. exists u => //. apply: va => -[|X] //=. 111 | exact: eqn. 112 | Qed. 113 | 114 | Lemma V_ren A rho s xi : 115 | V A.[ren xi] rho s <-> V A (xi >>> rho) s. 116 | Proof. 117 | elim: A rho s xi => //=. 118 | - move=> A ih1 B ih2 rho v xi. split=> -[A'[s->h]]; 119 | (do 2 eexists) => // t /ih1/h[u ev]/ih2 ih; by exists u. 120 | - move=> A ih rho s xi; asimpl. 121 | split=> -[s' -> h]; eexists => //; asimpl=> P B; move: {h} (h P B) => [v ev]. 122 | + move=> /ih {} ih. exists v => //. by asimpl in ih. 123 | + move=> h. exists v => //. apply/ih. autosubst. 124 | Qed. 125 | 126 | Lemma E_ren A rho s xi : 127 | E A.[ren xi] rho s <-> E A (xi >>> rho) s. 128 | Proof. 129 | split=> -[v ev /V_ren h]; by exists v. 130 | Qed. 131 | 132 | Lemma V_subst A rho v sigma : 133 | V A.[sigma] rho v <-> V A (fun x => V (sigma x) rho) v. 134 | Proof. 135 | elim: A rho v sigma. 136 | - move=> x rho v sigma /=. split; intuition eauto. 137 | - move=> A ih1 B ih2 rho v sigma /=. split=> -[A' [s->h]]; 138 | (do 2 eexists) => // t /ih1/h[u ev]/ih2 ih; by exists u. 139 | - move=> A ih rho v sigma. split; 140 | asimpl; move=> [s->{v}h]; eexists=> [//|P B]. 141 | + move: (h P B) => [v ev /ih hv]. exists v => //. 142 | apply: eq_V hv => -[|X] //= u. by intuition. move=> _. asimpl. exact: V_ren. 143 | + move: (h P B) => [v ev hv]. exists v => //. apply/ih. 144 | apply: eq_V hv => -[|X] //= u. by intuition. asimpl. 145 | split => [p|/V_ren//]. by apply/V_ren. 146 | Qed. 147 | 148 | Definition VG (Gamma : ctx) (rho : var -> term -> Prop) (sigma : var -> term) := 149 | forall x, x < size Gamma -> E Gamma`_x rho (sigma x). 150 | 151 | Theorem soundness Gamma s A : 152 | has_type Gamma s A -> 153 | forall delta sigma rho, VG Gamma rho sigma -> E A rho s.|[delta].[sigma]. 154 | Proof. 155 | elim=> {Gamma s A} [Gamma x xe|Gamma A B s _ ih|Gamma A B s t _ ih1 _ ih2| 156 | Gamma A s _ ih|Gamma A B s _ ih] delta sigma rho l. 157 | - exact: l. 158 | - eexists; first by autosubst. (do 2 eexists)=> [//|t vt]. asimpl. 159 | apply: ih=> -[_/=|x/l//]. exact: V_to_E. 160 | - case: (ih1 delta _ _ l) => {ih1} /= v ev1 [A' [u eq ih1]]; subst v. 161 | case: (ih2 delta _ _ l) => {ih2} v ev2 ih2. 162 | case: (ih1 _ ih2) => {ih1} w ev3 ih1. exists w => //. 163 | exact: eval_beta ev1 ev2 ev3. 164 | - apply: V_to_E. eexists=> [//=|P B]. asimpl. apply: ih => x /=. 165 | rewrite size_map => wf. rewrite get_map //. apply/E_ren. exact: l. 166 | - move: (ih delta _ _ l) => [v ev1 {ih} /=[s' eq ih]]; subst v. 167 | specialize (ih (V B rho) B.[delta]). move: ih => [v ev2 ih]. exists v. 168 | exact: eval_tbeta ev1 ev2. apply/V_subst. apply: eq_V ih => -[|x] //=. 169 | by intuition. 170 | Qed. 171 | 172 | (** **** Applications *) 173 | 174 | Definition nilA : var -> term -> Prop := fun _ _ => False. 175 | 176 | Corollary soundness_nil s A : 177 | has_type [::] s A -> E A nilA s. 178 | Proof. 179 | move=> h. cut (E A nilA s.|[ids].[ids]). autosubst. exact: (soundness h). 180 | Qed. 181 | 182 | Corollary normalization s A : 183 | has_type [::] s A -> exists v, eval s v. 184 | Proof. 185 | move=> /soundness_nil[v hv] _. by exists v. 186 | Qed. 187 | 188 | Corollary consistency s : 189 | ~has_type [::] s (All (TyVar 0)). 190 | Proof. 191 | move=> /soundness_nil[v _ /= [t {s v} _ /(_ (fun _ => False) (TyVar 0))]]. 192 | by move=> [s {t} _ []]. 193 | Qed. 194 | 195 | (* Local Variables: *) 196 | (* coq-load-path: (("." "Ssr")) *) 197 | (* End: *) 198 | -------------------------------------------------------------------------------- /examples/ssr/SystemF_SN.v: -------------------------------------------------------------------------------- 1 | (** * Strong Normalization of System F *) 2 | 3 | From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq. 4 | From Coq Require Import ssrfun. 5 | Require Import AutosubstSsr ARS Context. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | (** **** Definitions *) 12 | 13 | Inductive type : Type := 14 | | TyVar (x : var) 15 | | Arr (A B : type) 16 | | All (A : {bind type}). 17 | 18 | Inductive term := 19 | | TeVar (x : var) 20 | | Abs (A : type) (s : {bind term}) 21 | | App (s t : term) 22 | | TAbs (s : {bind type in term}) 23 | | TApp (s : term) (A : type). 24 | 25 | (** **** Substitution Lemmas *) 26 | 27 | Global Instance Ids_type : Ids type. derive. Defined. 28 | Global Instance Rename_type : Rename type. derive. Defined. 29 | Global Instance Subst_type : Subst type. derive. Defined. 30 | 31 | Global Instance SubstLemmas_type : SubstLemmas type. derive. Qed. 32 | 33 | Global Instance HSubst_term : HSubst type term. derive. Defined. 34 | 35 | Global Instance Ids_term : Ids term. derive. Defined. 36 | Global Instance Rename_term : Rename term. derive. Defined. 37 | Global Instance Subst_term : Subst term. derive. Defined. 38 | 39 | Global Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed. 40 | Global Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed. 41 | 42 | Global Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 43 | 44 | (** **** One-Step Reduction *) 45 | 46 | Inductive step : term -> term -> Prop := 47 | | step_beta (A : type) (s t : term) : 48 | step (App (Abs A s) t) s.[t/] 49 | | step_inst (A : type) (s : term) : 50 | step (TApp (TAbs s) A) s.|[A/] 51 | | step_appL s1 s2 t : 52 | step s1 s2 -> step (App s1 t) (App s2 t) 53 | | step_appR s t1 t2 : 54 | step t1 t2 -> step (App s t1) (App s t2) 55 | | step_abs A s1 s2 : 56 | step s1 s2 -> step (Abs A s1) (Abs A s2) 57 | | step_tapp A s1 s2 : 58 | step s1 s2 -> step (TApp s1 A) (TApp s2 A) 59 | | step_tabs s1 s2 : 60 | step s1 s2 -> step (TAbs s1) (TAbs s2). 61 | 62 | Lemma step_ebeta A s t u : u = s.[t/] -> step (App (Abs A s) t) u. 63 | Proof. move->. exact: step_beta. Qed. 64 | 65 | Lemma step_einst A s t : t = s.|[A/] -> step (TApp (TAbs s) A) t. 66 | Proof. move->. exact: step_inst. Qed. 67 | 68 | Lemma step_substf theta sigma s t : 69 | step s t -> step s.|[theta].[sigma] t.|[theta].[sigma]. 70 | Proof. 71 | move=> st. elim: st sigma theta => {s t}; asimpl; eauto using step. 72 | - move=> A s t sigma theta. apply: step_ebeta. by autosubst. 73 | - move=> A s sigma theta. apply: step_einst. by autosubst. 74 | Qed. 75 | 76 | Lemma step_subst sigma s t : step s t -> step s.[sigma] t.[sigma]. 77 | Proof. move=> h. apply (step_substf ids sigma) in h. by asimpl in h. Qed. 78 | 79 | Lemma step_hsubst theta s t : step s t -> step s.|[theta] t.|[theta]. 80 | Proof. move=> h. apply (step_substf theta ids) in h. by asimpl in h. Qed. 81 | 82 | (** **** Many-Step Reduction *) 83 | 84 | Definition red := star step. 85 | 86 | Definition sred sigma tau := 87 | forall x : var, red (sigma x) (tau x). 88 | 89 | Lemma red_app s1 s2 t1 t2 : 90 | red s1 s2 -> red t1 t2 -> red (App s1 t1) (App s2 t2). 91 | Proof. 92 | move=> A B. apply: (star_trans (App s2 t1)). 93 | - apply: (star_hom (App^~ t1)) A => x y. exact: step_appL. 94 | - apply: star_hom B => x y. exact: step_appR. 95 | Qed. 96 | 97 | Lemma red_abs A s1 s2 : red s1 s2 -> red (Abs A s1) (Abs A s2). 98 | Proof. apply: star_hom => x y. exact: step_abs. Qed. 99 | 100 | Lemma red_tapp A s1 s2 : red s1 s2 -> red (TApp s1 A) (TApp s2 A). 101 | Proof. apply: (star_hom (TApp^~A)) => x y. exact: step_tapp. Qed. 102 | 103 | Lemma red_tabs s1 s2 : red s1 s2 -> red (TAbs s1) (TAbs s2). 104 | Proof. apply: star_hom => x y. exact: step_tabs. Qed. 105 | 106 | Lemma red_subst sigma s t : red s t -> red s.[sigma] t.[sigma]. 107 | Proof. apply: star_hom => x y. exact: step_subst. Qed. 108 | 109 | Lemma red_hsubst theta s t : red s t -> red s.|[theta] t.|[theta]. 110 | Proof. apply: star_hom => x y. exact: step_hsubst. Qed. 111 | 112 | Lemma sred_up sigma tau : sred sigma tau -> sred (up sigma) (up tau). 113 | Proof. move=> A [|n] //=. asimpl. apply/red_subst/A. Qed. 114 | 115 | Lemma sred_hup sigma tau theta : 116 | sred sigma tau -> sred (sigma >>| theta) (tau >>| theta). 117 | Proof. move=> A n /=. apply/red_hsubst/A. Qed. 118 | 119 | Global Hint Resolve red_app red_abs red_tapp red_tabs sred_up sred_hup : red_congr. 120 | 121 | Lemma red_compat sigma tau s : 122 | sred sigma tau -> red s.[sigma] s.[tau]. 123 | Proof. 124 | elim: s sigma tau; intros; asimpl; eauto with red_congr. 125 | Qed. 126 | 127 | Lemma red_beta s t1 t2 : step t1 t2 -> red s.[t1/] s.[t2/]. 128 | Proof. move=> h. apply: red_compat => -[|n]/=; [exact: star1|exact: starR]. Qed. 129 | 130 | (** **** Syntactic typing *) 131 | 132 | Definition ctx := seq type. 133 | Local Notation "Gamma `_ i" := (get Gamma i) (at level 2). 134 | 135 | Inductive has_type (Gamma : ctx) : term -> type -> Prop := 136 | | ty_var (x : var) : 137 | x < size Gamma -> has_type Gamma (TeVar x) Gamma`_x 138 | | ty_abs (A B : type) (s : term) : 139 | has_type (A :: Gamma) s B -> 140 | has_type Gamma (Abs A s) (Arr A B) 141 | | ty_app (A B : type) (s t : term) : 142 | has_type Gamma s (Arr A B) -> 143 | has_type Gamma t A -> 144 | has_type Gamma (App s t) B 145 | | ty_tabs (A : type) (s : term) : 146 | has_type Gamma..[ren (+1)] s A -> 147 | has_type Gamma (TAbs s) (All A) 148 | | ty_tapp (A B : type) (s : term) : 149 | has_type Gamma s (All A) -> 150 | has_type Gamma (TApp s B) A.[B/]. 151 | 152 | (* Strong Normalization *) 153 | 154 | Notation sn := (sn step). 155 | 156 | Lemma sn_closed t s : sn (App s t) -> sn s. 157 | Proof. apply: (sn_preimage (h := App^~t)) => x y. exact: step_appL. Qed. 158 | 159 | Lemma sn_tclosed A s : sn (TApp s A) -> sn s. 160 | Proof. apply: (sn_preimage (h := TApp^~A)) => x y. exact: step_tapp. Qed. 161 | 162 | Lemma sn_subst sigma s : sn s.[sigma] -> sn s. 163 | Proof. apply: sn_preimage => x y. exact: step_subst. Qed. 164 | 165 | Lemma sn_hsubst theta s : sn s.|[theta] -> sn s. 166 | Proof. apply: sn_preimage => x y. exact: step_hsubst. Qed. 167 | 168 | (* The Reducibility Candidates/Logical Predicate*) 169 | 170 | Definition cand := term -> Prop. 171 | 172 | Definition neutral (s : term) : bool := 173 | match s with 174 | | Abs _ _ | TAbs _ => false 175 | | _ => true 176 | end. 177 | 178 | Record reducible (P : cand) : Prop := { 179 | p_sn : forall s, P s -> sn s; 180 | p_cl : forall s t, P s -> step s t -> P t; 181 | p_nc : forall s, neutral s -> (forall t, step s t -> P t) -> P s 182 | }. 183 | 184 | Fixpoint L (T : type) (rho : nat -> cand) : cand := 185 | match T with 186 | | TyVar x => rho x 187 | | Arr A B => fun s => forall t, L A rho t -> L B rho (App s t) 188 | | All A => fun s => forall P B, reducible P -> L A (P .: rho) (TApp s B) 189 | end. 190 | 191 | Definition EL E (rho : nat -> cand) (sigma : var -> term) : Prop := 192 | forall x, x < size E -> L E`_x rho (sigma x). 193 | 194 | Definition admissible (rho : nat -> cand) := 195 | forall x, reducible (rho x). 196 | 197 | (* Facts about reducible sets. *) 198 | 199 | Lemma reducible_sn : reducible sn. 200 | Proof. constructor; eauto using ARS.sn. by move=> s t [f] /f. Qed. 201 | Global Hint Resolve reducible_sn : core. 202 | 203 | Lemma reducible_var P x : reducible P -> P (TeVar x). 204 | Proof. move/p_nc. apply=> // t st. inv st. Qed. 205 | 206 | Lemma ad_cons P rho : 207 | reducible P -> admissible rho -> admissible (P .: rho). 208 | Proof. by move=> H1 H2 [|i] //=. Qed. 209 | 210 | Lemma L_reducible T rho : 211 | admissible rho -> reducible (L T rho). 212 | Proof with eauto using step. 213 | elim: T rho => /=[i|A ih1 B ih2|A ih] rho safe... 214 | - constructor. 215 | + move=> s h. apply: (@sn_closed (TeVar 0)). apply: (p_sn (P := L B rho))... 216 | eapply h. eapply reducible_var; eauto. 217 | + move=> s t h st u la. apply: (p_cl _ (s := App s u))... 218 | + move=> s ns h t la. have snt := p_sn (ih1 _ safe) la. 219 | elim: snt la => {} t _ ih3 la. apply: p_nc... move=> v st. inv st=> //... 220 | apply: ih3 => //. exact: (p_cl (ih1 _ safe)) la _. 221 | - constructor. 222 | + move=> s /(_ sn (TyVar 0) reducible_sn)/p_sn/sn_tclosed; apply. 223 | by apply/ih/ad_cons... 224 | + move=> s t h st P B rep. apply: p_cl (step_tapp B st)... 225 | by apply/ih/ad_cons. 226 | + move=> s ns h P B rep. apply ih... exact: ad_cons. 227 | move=> t st. inv st => //... 228 | Qed. 229 | 230 | Corollary L_sn A rho s : admissible rho -> L A rho s -> sn s. 231 | Proof. move=> /L_reducible/p_sn. apply. Qed. 232 | 233 | Corollary L_cl T rho s t : admissible rho -> L T rho s -> step s t -> L T rho t. 234 | Proof. move=> /L_reducible/p_cl. apply. Qed. 235 | 236 | Corollary L_nc T rho s : 237 | admissible rho -> neutral s -> (forall t, step s t -> L T rho t) -> L T rho s. 238 | Proof. move=> /L_reducible/p_nc. apply. Qed. 239 | 240 | Corollary L_var T rho x : admissible rho -> L T rho (TeVar x). 241 | Proof. move=> /L_nc. apply=> // t st. inv st. Qed. 242 | 243 | Corollary L_cl_star T rho s t : 244 | admissible rho -> L T rho s -> red s t -> L T rho t. 245 | Proof. move=> /L_cl cl H st. elim: st H; eauto. Qed. 246 | 247 | (* Closure under beta expansion. *) 248 | 249 | Lemma beta_expansion A B rho s t : 250 | admissible rho -> sn t -> L A rho s.[t/] -> 251 | L A rho (App (Abs B s) t). 252 | Proof with eauto. 253 | move=> ad snt h. have sns := sn_subst (L_sn ad h). 254 | elim: sns t snt h => {} s sns ih1 t. elim=> {} t snt ih2 h. 255 | apply: L_nc => // u st. inv st => //. 256 | - inv H2. apply: ih1 => //. apply: L_cl ad h _. exact: step_subst. 257 | - apply: ih2 => //. apply: L_cl_star ad h _. exact: red_beta. 258 | Qed. 259 | 260 | Lemma inst_expansion A B rho s : 261 | admissible rho -> L A rho s.|[B/] -> L A rho (TApp (TAbs s) B). 262 | Proof. 263 | move=> ad h. have sns := sn_hsubst (L_sn ad h). elim: sns h. 264 | move=> {} s _ ih h. apply: L_nc => // t st. inv st => //. 265 | inv H2 => //. apply: ih => //. apply: L_cl ad h _. exact: step_hsubst. 266 | Qed. 267 | 268 | (* The type substitution lemma. *) 269 | 270 | Lemma extend_ext (rho tau : nat -> cand) : 271 | (forall i s, rho i s <-> tau i s) -> 272 | (forall P i s, (P .: rho) i s <-> (P .: tau) i s). 273 | Proof. by move=>h P[]/=. Qed. 274 | 275 | Lemma L_ext T rho tau : 276 | (forall i s, rho i s <-> tau i s) -> (forall s, L T rho s <-> L T tau s). 277 | Proof. 278 | elim: T rho tau => //=[T1 IH1 T2 IH2|T IH] rho tau E s. 279 | - split=> H1 t H2. 280 | + rewrite -(IH2 _ _ E). apply: H1. by rewrite (IH1 _ _ E). 281 | + rewrite (IH2 _ _ E). apply: H1. by rewrite -(IH1 _ _ E). 282 | - move: E => /extend_ext E. split=> H P B /H. 283 | + move=> /(_ B). by rewrite (IH _ _ (E P)). 284 | + move=> /(_ B). by rewrite -(IH _ _ (E P)). 285 | Qed. 286 | 287 | Lemma L_ren A rho xi s : 288 | L A.[ren xi] rho s <-> L A (xi >>> rho) s. 289 | Proof with intuition. 290 | elim: A rho xi s => [x|A ih1 B ih2|A ih] rho xi s; asimpl => //. 291 | - split=> h1 t h2. rewrite -ih2. apply: h1. by rewrite ih1. 292 | rewrite ih2. apply: h1. by rewrite -ih1. 293 | - split=> h P B r. move: (h _ B r). rewrite ih. apply L_ext. by case. 294 | rewrite ih. asimpl. exact: h. 295 | Qed. 296 | 297 | Lemma L_weaken A P rho s : L A.[ren (+1)] (P .: rho) s <-> L A rho s. 298 | Proof. exact: L_ren. Qed. 299 | 300 | Lemma L_subst A rho sigma s : 301 | L A.[sigma] rho s <-> L A (fun i => L (sigma i) rho) s. 302 | Proof. 303 | elim: A rho sigma s => [x|A ih1 B ih2|A ih] rho sigma s; asimpl=>//. 304 | - split=> h1 t h2. rewrite -ih2. apply: h1. by rewrite ih1. 305 | rewrite ih2. apply h1. by rewrite -ih1. 306 | - split=> h P B /(h _ B); rewrite ih; apply L_ext => -[|x] //= t; asimpl; 307 | by rewrite L_weaken. 308 | Qed. 309 | 310 | (* The fundamental theorem. *) 311 | 312 | Theorem soundness Gamma s A : 313 | has_type Gamma s A -> forall rho theta sigma, 314 | admissible rho -> EL Gamma rho sigma -> L A rho s.|[theta].[sigma]. 315 | Proof with eauto using L_sn, ad_cons. 316 | elim=> {Gamma s A} [|Gamma A B s _ ih||Gamma A s _ ih|Gamma A B s _ /=ih] 317 | rho theta sigma ad el; asimpl... 318 | - move=> t h. apply: beta_expansion... asimpl. apply: ih... by case. 319 | - move=> P B h. apply: inst_expansion... asimpl. apply: ih... move=> x. 320 | rewrite size_map => lt. rewrite get_map // L_weaken... 321 | - rewrite L_subst. specialize (ih _ theta sigma ad el (L B rho) B.[theta]). 322 | have/ih: reducible (L B rho). exact: L_reducible. apply L_ext. by case. 323 | Qed. 324 | 325 | Lemma rho_id : admissible (fun _ => sn). 326 | Proof. move=> x /=. exact: reducible_sn. Qed. 327 | 328 | Corollary type_L E s T rho : has_type E s T -> admissible rho -> L T rho s. 329 | Proof. 330 | move=> ty ad. move: (@soundness E s T ty rho) => h. 331 | specialize (h ids ids ad). asimpl in h. apply: h => x B. exact: L_var. 332 | Qed. 333 | 334 | Corollary strong_normalization E s T : has_type E s T -> sn s. 335 | Proof. move=>/type_L/(_ rho_id)/L_sn. apply. exact: rho_id. Qed. 336 | 337 | (* Local Variables: *) 338 | (* coq-load-path: (("." "Ssr")) *) 339 | (* End: *) 340 | -------------------------------------------------------------------------------- /examples/ssr/pred_CC_omega.v: -------------------------------------------------------------------------------- 1 | (** * Predicative CC omega: Type Preservation and Confluence 2 | *) 3 | 4 | From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq. 5 | From Coq Require Import ssrfun. 6 | Require Import AutosubstSsr ARS Context. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | (** **** Curry-style type theory with a hierarchy of predicative universes. *) 13 | 14 | Inductive term : Type := 15 | | Var (x : var) 16 | | Sort (n : nat) 17 | | App (s t : term) 18 | | Lam (s : {bind term}) 19 | | Prod (s : term) (t : {bind term}). 20 | 21 | Global Instance Ids_term : Ids term. derive. Defined. 22 | Global Instance Rename_term : Rename term. derive. Defined. 23 | Global Instance Subst_term : Subst term. derive. Defined. 24 | Global Instance substLemmas_term : SubstLemmas term. derive. Qed. 25 | 26 | (** **** One-Step Reduction *) 27 | 28 | Inductive step : term -> term -> Prop := 29 | | step_beta s t u : 30 | u = s.[t/] -> step (App (Lam s) t) u 31 | | step_appL s1 s2 t : 32 | step s1 s2 -> step (App s1 t) (App s2 t) 33 | | step_appR s t1 t2 : 34 | step t1 t2 -> step (App s t1) (App s t2) 35 | | step_lam s1 s2 : 36 | step s1 s2 -> step (Lam s1) (Lam s2) 37 | | step_prodL A1 A2 B : 38 | step A1 A2 -> step (Prod A1 B) (Prod A2 B) 39 | | step_prodR A B1 B2 : 40 | step B1 B2 -> step (Prod A B1) (Prod A B2). 41 | 42 | Notation red := (star step). 43 | Notation "s === t" := (conv step s t) (at level 50). 44 | 45 | Definition sred sigma tau := 46 | forall x : var, red (sigma x) (tau x). 47 | 48 | Lemma step_subst sigma s t : step s t -> step s.[sigma] t.[sigma]. 49 | Proof. 50 | move=> st. elim: st sigma => /={s t}; eauto using step. 51 | move=> s t u -> sigma; apply: step_beta; by autosubst. 52 | Qed. 53 | 54 | (** **** Many-Step Reduction *) 55 | 56 | Lemma red_app s1 s2 t1 t2 : 57 | red s1 s2 -> red t1 t2 -> red (App s1 t1) (App s2 t2). 58 | Proof. 59 | move=> A B. apply: (star_trans (App s2 t1)). 60 | - apply: (star_hom (App^~ t1)) A => x y. exact: step_appL. 61 | - apply: star_hom B => x y. exact: step_appR. 62 | Qed. 63 | 64 | Lemma red_lam s1 s2 : red s1 s2 -> red (Lam s1) (Lam s2). 65 | Proof. apply: star_hom => x y. exact: step_lam. Qed. 66 | 67 | Lemma red_prod s1 s2 t1 t2 : 68 | red s1 s2 -> red t1 t2 -> red (Prod s1 t1) (Prod s2 t2). 69 | Proof. 70 | move=> A B. apply: (star_trans (Prod s2 t1)). 71 | - apply: (star_hom (Prod^~ t1)) A => x y. exact: step_prodL. 72 | - apply: star_hom B => x y. exact: step_prodR. 73 | Qed. 74 | 75 | Lemma red_subst sigma s t : red s t -> red s.[sigma] t.[sigma]. 76 | Proof. apply: star_hom. exact: step_subst. Qed. 77 | 78 | Lemma sred_up sigma tau : sred sigma tau -> sred (up sigma) (up tau). 79 | Proof. move=> A [|n] //=. asimpl. apply: red_subst. exact: A. Qed. 80 | 81 | Global Hint Resolve red_app red_lam red_prod sred_up : red_congr. 82 | 83 | Lemma red_compat sigma tau s : sred sigma tau -> red s.[sigma] s.[tau]. 84 | Proof. elim: s sigma tau => *; asimpl; eauto with red_congr. Qed. 85 | 86 | (** **** Conversion *) 87 | 88 | Definition sconv (sigma tau : var -> term) := 89 | forall x, sigma x === tau x. 90 | 91 | Lemma conv_app s1 s2 t1 t2 : 92 | s1 === s2 -> t1 === t2 -> App s1 t1 === App s2 t2. 93 | Proof. 94 | move=> A B. apply: (conv_trans (App s2 t1)). 95 | - apply: (conv_hom (App^~ t1)) A => x y. exact: step_appL. 96 | - apply: conv_hom B => x y. exact: step_appR. 97 | Qed. 98 | 99 | Lemma conv_lam s1 s2 : s1 === s2 -> Lam s1 === Lam s2. 100 | Proof. apply: conv_hom => x y. exact: step_lam. Qed. 101 | 102 | Lemma conv_prod s1 s2 t1 t2 : 103 | s1 === s2 -> t1 === t2 -> Prod s1 t1 === Prod s2 t2. 104 | Proof. 105 | move=> A B. apply: (conv_trans (Prod s2 t1)). 106 | - apply: (conv_hom (Prod^~ t1)) A => x y. exact: step_prodL. 107 | - apply: conv_hom B => x y. exact: step_prodR. 108 | Qed. 109 | 110 | Lemma conv_subst sigma s t : s === t -> s.[sigma] === t.[sigma]. 111 | Proof. apply: conv_hom. exact: step_subst. Qed. 112 | 113 | Lemma sconv_up sigma tau : sconv sigma tau -> sconv (up sigma) (up tau). 114 | Proof. move=> A [|x] //=. asimpl. exact: conv_subst. Qed. 115 | 116 | Lemma conv_compat sigma tau s : 117 | sconv sigma tau -> s.[sigma] === s.[tau]. 118 | Proof. 119 | elim: s sigma tau => *; asimpl; eauto using 120 | conv_app, conv_lam, conv_prod, sconv_up. 121 | Qed. 122 | 123 | Lemma conv_beta s t1 t2 : t1 === t2 -> s.[t1/] === s.[t2/]. 124 | Proof. move=> c. by apply: conv_compat => -[]. Qed. 125 | 126 | (** **** Church-Rosser theorem *) 127 | 128 | Inductive pstep : term -> term -> Prop := 129 | | pstep_beta s1 s2 t1 t2 u : 130 | u = s2.[t2/] -> 131 | pstep s1 s2 -> pstep t1 t2 -> pstep (App (Lam s1) t1) u 132 | | pstep_var x : pstep (Var x) (Var x) 133 | | pstep_sort n : pstep (Sort n) (Sort n) 134 | | pstep_app s1 s2 t1 t2 : 135 | pstep s1 s2 -> pstep t1 t2 -> pstep (App s1 t1) (App s2 t2) 136 | | pstep_lam s1 s2 : 137 | pstep s1 s2 -> pstep (Lam s1) (Lam s2) 138 | | pstep_prod s1 s2 t1 t2 : 139 | pstep s1 s2 -> pstep t1 t2 -> pstep (Prod s1 t1) (Prod s2 t2). 140 | 141 | Definition psstep (sigma tau : var -> term) := 142 | forall x, pstep (sigma x) (tau x). 143 | 144 | Fixpoint rho (s : term) : term := 145 | match s with 146 | | App (Lam s) t => (rho s).[rho t/] 147 | | App s t => App (rho s) (rho t) 148 | | Lam s => Lam (rho s) 149 | | Prod A B => Prod (rho A) (rho B) 150 | | x => x 151 | end. 152 | 153 | Lemma pstep_refl s : pstep s s. 154 | Proof. elim: s; eauto using pstep. Qed. 155 | Global Hint Resolve pstep_refl : core. 156 | 157 | Lemma step_pstep s t : step s t -> pstep s t. 158 | Proof. elim; eauto using pstep. Qed. 159 | 160 | Lemma pstep_red s t : pstep s t -> red s t. 161 | Proof. 162 | elim=> {s t} //=; eauto with red_congr. 163 | move=> s1 s2 t1 t2 u -> {u} _ A _ B. eapply starES. by econstructor. 164 | apply: (star_trans (s2.[t1.:Var])). exact: red_subst. 165 | by apply: red_compat => -[|]. 166 | Qed. 167 | 168 | Lemma pstep_subst sigma s t : 169 | pstep s t -> pstep s.[sigma] t.[sigma]. 170 | Proof. 171 | move=> A. elim: A sigma => /=; eauto using pstep. 172 | move=> s1 s2 t1 t2 u -> _ A _ B sigma. eapply pstep_beta; eauto. by autosubst. 173 | Qed. 174 | 175 | Lemma psstep_up sigma tau : 176 | psstep sigma tau -> psstep (up sigma) (up tau). 177 | Proof. 178 | move=> A [|n] //=. asimpl. apply: pstep_subst. exact: A. 179 | Qed. 180 | 181 | Lemma pstep_compat sigma tau s t : 182 | psstep sigma tau -> pstep s t -> pstep s.[sigma] t.[tau]. 183 | Proof with eauto using pstep, psstep_up. 184 | move=> A B. elim: B sigma tau A; asimpl... 185 | move=> s1 s2 t1 t2 u -> _ A _ B sigma tau C. 186 | apply: (@pstep_beta _ (s2.[up tau]) _ (t2.[tau])); asimpl... 187 | Qed. 188 | 189 | Lemma pstep_compat_beta s1 s2 t1 t2 : 190 | pstep s1 s2 -> pstep t1 t2 -> pstep s1.[t1/] s2.[t2/]. 191 | Proof. 192 | move=> A B. by apply: pstep_compat A => -[|]. 193 | Qed. 194 | 195 | Lemma rho_triangle : triangle pstep rho. 196 | Proof with eauto using pstep. 197 | move=> s t. elim=> {s t} //=... 198 | - move=> s1 s2 t1 t2 u -> {u} _ A _ B. exact: pstep_compat_beta. 199 | - move=> s1 s2 t1 t2 A ih1 _ ih2. case: s1 A ih1 => //=... 200 | move=> s A ih1. inv A. inv ih1... 201 | Qed. 202 | 203 | Theorem church_rosser : 204 | CR step. 205 | Proof. 206 | apply: (cr_method (e2 := pstep) (rho := rho)). 207 | exact: step_pstep. exact: pstep_red. exact: rho_triangle. 208 | Qed. 209 | Global Hint Resolve church_rosser : core. 210 | 211 | (** **** Reduction behaviour *) 212 | 213 | Lemma normal_step_sort n : normal step (Sort n). 214 | Proof. move=> [s st]. inv st. Qed. 215 | Global Hint Resolve normal_step_sort : core. 216 | 217 | CoInductive RedProdSpec A1 B1 : term -> Prop := 218 | | RedProdSpecI A2 B2 : red A1 A2 -> red B1 B2 -> RedProdSpec A1 B1 (Prod A2 B2). 219 | 220 | Lemma red_prod_inv A1 B1 C : 221 | red (Prod A1 B1) C -> RedProdSpec A1 B1 C. 222 | Proof. 223 | elim=> {C} [|C D _ [A2 B2]]. 224 | - by constructor. 225 | - move=> ra12 rb12 st. inv st; constructor; eauto using star. 226 | Qed. 227 | 228 | Lemma inj_sort n m : Sort n === Sort m -> n = m. 229 | Proof. 230 | move=> A. suff: (Sort n = Sort m) => [[//]|]. 231 | eapply cr_conv_normal => //; done. 232 | Qed. 233 | 234 | Lemma inj_prod A1 A2 B1 B2 : 235 | Prod A1 B1 === Prod A2 B2 -> A1 === A2 /\ B1 === B2. 236 | Proof. 237 | move=>/church_rosser[z /red_prod_inv s1 /red_prod_inv s2]. 238 | inv s1; inv s2; split; eauto using join_conv. 239 | Qed. 240 | 241 | Lemma conv_prod_sort A B n : 242 | ~(Prod A B === Sort n). 243 | Proof. 244 | move=> h. apply cr_star_normal in h => //. apply red_prod_inv in h. inv h. 245 | Qed. 246 | 247 | (** **** Cumulativity / Subtyping relation *) 248 | 249 | Inductive sub1 : term ->term -> Prop := 250 | | sub1_refl A : sub1 A A 251 | | sub1_sort n m : n <= m -> sub1 (Sort n) (Sort m) 252 | | sub1_prod A B1 B2 : sub1 B1 B2 -> sub1 (Prod A B1) (Prod A B2). 253 | 254 | CoInductive sub (A B : term) : Prop := 255 | | SubI A' B' : sub1 A' B' -> A === A' -> B' === B -> sub A B. 256 | Infix "<:" := sub (at level 50, no associativity). 257 | 258 | Lemma sub1_sub A B : sub1 A B -> sub A B. move=> /SubI. exact. Qed. 259 | Lemma sub1_conv B A C : sub1 A B -> B === C -> A <: C. move=>/SubI. exact. Qed. 260 | Lemma conv_sub1 B A C : A === B -> sub1 B C -> A <: C. move=>c/SubI. exact. Qed. 261 | 262 | Lemma conv_sub A B : A === B -> A <: B. 263 | Proof. move/conv_sub1. apply. exact: sub1_refl. Qed. 264 | 265 | Lemma sub_refl A : A <: A. 266 | Proof. apply: sub1_sub. exact: sub1_refl. Qed. 267 | Global Hint Resolve sub_refl : core. 268 | 269 | Lemma sub_sort n m : n <= m -> Sort n <: Sort m. 270 | Proof. move=> leq. exact/sub1_sub/sub1_sort. Qed. 271 | 272 | Lemma sub1_trans A B C D : 273 | sub1 A B -> B === C -> sub1 C D -> A <: D. 274 | Proof with eauto using sub1, sub1_sub, sub1_conv, conv_sub1. 275 | move=> sb. elim: sb C D => {A B} 276 | [A C D|n m leq C D conv sb|A B1 B2 sb1 ih C D conv sb2]... 277 | - inv sb... 278 | + apply: sub_sort. move: conv => /inj_sort eqn. subst. 279 | exact: leq_trans leq _. 280 | + exfalso. exact: conv_prod_sort (conv_sym conv). 281 | - inv sb2... 282 | + exfalso. exact: conv_prod_sort conv. 283 | + move: conv => /inj_prod[conv1 conv2]. 284 | move: (ih _ _ conv2 H) => {ih} sub. inv sub. 285 | eapply SubI. eapply sub1_prod... eapply conv_prod... exact: conv_prod. 286 | Qed. 287 | 288 | Lemma sub_trans B A C : 289 | A <: B -> B <: C -> A <: C. 290 | Proof. 291 | move=> [A' B' s1 c1 c2] [B'' C' s2 c3 c4]. move: (conv_trans _ c2 c3) => h. 292 | case: (sub1_trans s1 h s2) => A0 B0 s3 c5 c6. apply: (SubI s3). 293 | exact: conv_trans c5. exact: conv_trans c4. 294 | Qed. 295 | 296 | Lemma sub_prod_inv A1 A2 B1 B2 : 297 | Prod A1 B1 <: Prod A2 B2 -> A1 === A2 /\ B1 <: B2. 298 | Proof. 299 | move=> [A' B' []]. 300 | - move=> C c1 c2. have{c1 c2}/inj_prod[c1 c2]: Prod A1 B1 === Prod A2 B2. 301 | exact: conv_trans c2. 302 | split=>//. exact: conv_sub. 303 | - by move=> n _ _ /conv_prod_sort[]. 304 | - move=> A C1 C2 sb /inj_prod[c1 c2] /inj_prod[c3 c4]. split. 305 | exact: conv_trans c3. exact: SubI sb c2 c4. 306 | Qed. 307 | 308 | Lemma sub1_subst sigma A B : sub1 A B -> sub1 A.[sigma] B.[sigma]. 309 | Proof. move=> s. elim: s sigma => /=; eauto using sub1. Qed. 310 | 311 | Lemma sub_subst sigma A B : A <: B -> A.[sigma] <: B.[sigma]. 312 | Proof. move=> [A' B' /sub1_subst]; eauto using sub, conv_subst. Qed. 313 | 314 | (** **** Typing *) 315 | 316 | Notation "Gamma `_ i" := (dget Gamma i) (at level 2). 317 | 318 | Reserved Notation "[ Gamma |- ]". 319 | Reserved Notation "[ Gamma |- s :- A ]". 320 | 321 | Inductive has_type : list term -> term -> term -> Prop := 322 | | ty_var Gamma x : 323 | x < size Gamma -> 324 | [ Gamma |- Var x :- Gamma`_x ] 325 | | ty_sort Gamma n : 326 | [ Gamma |- Sort n :- Sort n.+1 ] 327 | | ty_app Gamma A B s t : 328 | [ Gamma |- s :- Prod A B ] -> 329 | [ Gamma |- t :- A ] -> 330 | [ Gamma |- App s t :- B.[t/] ] 331 | | ty_lam Gamma A B s n : 332 | [ Gamma |- A :- Sort n ] -> 333 | [ A :: Gamma |- s :- B ] -> 334 | [ Gamma |- Lam s :- Prod A B ] 335 | | ty_prod Gamma A B n : 336 | [ Gamma |- A :- Sort n ] -> 337 | [ A :: Gamma |- B :- Sort n ] -> 338 | [ Gamma |- Prod A B :- Sort n ] 339 | | ty_sub Gamma n A B s : 340 | A <: B -> 341 | [ Gamma |- B :- Sort n ] -> 342 | [ Gamma |- s :- A ] -> 343 | [ Gamma |- s :- B ] 344 | where "[ Gamma |- s :- A ]" := (has_type Gamma s A). 345 | 346 | Inductive context_ok : list term -> Prop := 347 | | ctx_nil : 348 | [ [::] |- ] 349 | | ctx_ncons Gamma A n : 350 | [ Gamma |- A :- Sort n ] -> 351 | [ Gamma |- ] -> 352 | [ A :: Gamma |- ] 353 | where "[ Gamma |- ]" := (context_ok Gamma). 354 | 355 | Lemma ty_evar Gamma (A : term) (x : var) : 356 | A = Gamma`_x -> x < size Gamma -> [ Gamma |- Var x :- A ]. 357 | Proof. move->. exact: ty_var. Qed. 358 | 359 | Lemma ty_eapp Gamma (A B C s t : term) : 360 | C = B.[t/] -> 361 | [ Gamma |- s :- Prod A B ] -> [ Gamma |- t :- A ] -> 362 | [ Gamma |- App s t :- C ]. 363 | Proof. move=>->. exact: ty_app. Qed. 364 | 365 | (* Type well-formedness *) 366 | 367 | Notation "[ Gamma |- s ]" := (exists n, [ Gamma |- s :- Sort n ]). 368 | 369 | Lemma ty_sort_wf Gamma n : [ Gamma |- Sort n ]. 370 | Proof. exists n.+1. exact: ty_sort. Qed. 371 | Global Hint Resolve ty_sort_wf ty_sort : core. 372 | 373 | Lemma ty_prod_wf Gamma A B : 374 | [ Gamma |- A ] -> [ A :: Gamma |- B ] -> [ Gamma |- Prod A B ]. 375 | Proof. 376 | move=> [n tp1] [m tp2]. exists (maxn n m). apply: ty_prod. 377 | - eapply (ty_sub (A := Sort n)); eauto. eapply sub_sort. exact: leq_maxl. 378 | - eapply (ty_sub (A := Sort m)); eauto. apply: sub_sort. exact: leq_maxr. 379 | Qed. 380 | 381 | (* Substitution Lemma *) 382 | 383 | Notation "[ Delta |- sigma -| Gamma ]" := 384 | (forall x, x < size Gamma -> [ Delta |- sigma x :- (Gamma`_x).[(sigma : _ -> _)] ]). 385 | 386 | Lemma ty_renaming xi Gamma Delta s A : 387 | [ Gamma |- s :- A ] -> 388 | (forall x, x < size Gamma -> xi x < size Delta) -> 389 | (forall x, x < size Gamma -> (Gamma`_x).[ren xi] = Delta`_(xi x)) -> 390 | [ Delta |- s.[ren xi] :- A.[ren xi] ]. 391 | Proof. 392 | move=> tp. elim: tp xi Delta => {Gamma s A} /= 393 | [Gamma x si|Gamma n|Gamma A B s t _ ih1 _ ih2| 394 | Gamma A B s n _ ih1 _ ih2|Gamma A B n _ ih1 _ ih2| 395 | Gamma n A B s sub _ ih1 _ ih2] 396 | xi Delta subctx eqn //=. 397 | - rewrite eqn //. apply: ty_var. exact: subctx. 398 | - apply: (@ty_eapp _ A.[ren xi] B.[up (ren xi)]). autosubst. 399 | exact: ih1. exact: ih2. 400 | - eapply ty_lam. by eapply ih1. asimpl. apply: ih2. 401 | + by move=> [//|x /subctx]. 402 | + by move=> [_|x /eqn/=<-]; autosubst. 403 | - apply: ty_prod. exact: ih1. asimpl. apply: ih2. 404 | + by move=> [//|x /subctx]. 405 | + by move=> [_|x /eqn/=<-]; autosubst. 406 | - apply: (@ty_sub _ n A.[ren xi] B.[ren xi]). exact: sub_subst. 407 | exact: ih1. exact: ih2. 408 | Qed. 409 | 410 | Lemma weakening Gamma s A B : 411 | [ Gamma |- s :- A ] -> [ B :: Gamma |- s.[ren (+1)] :- A.[ren (+1)] ]. 412 | Proof. move=> /ty_renaming. exact. Qed. 413 | 414 | Lemma eweakening Gamma s s' A A' B : 415 | s' = s.[ren (+1)] -> A' = A.[ren (+1)] -> 416 | [ Gamma |- s :- A ] -> [ B :: Gamma |- s' :- A' ]. 417 | Proof. move=>->->. exact: weakening. Qed. 418 | 419 | Lemma ty_ok Gamma : 420 | [ Gamma |- ] -> forall x, x < size Gamma -> [ Gamma |- Gamma`_x ]. 421 | Proof. 422 | elim=> // {} Gamma A n tp _ ih [_|x /ih [{tp} n tp]]; 423 | exists n; exact: weakening tp. 424 | Qed. 425 | 426 | Lemma sty_up sigma Gamma Delta A : 427 | [ Delta |- sigma -| Gamma ] -> 428 | [ A.[sigma] :: Delta |- up sigma -| A :: Gamma ]. 429 | Proof. 430 | move=> stp [_//|x /stp tp] /=. apply: ty_evar => //=. autosubst. 431 | apply: eweakening tp; autosubst. 432 | Qed. 433 | 434 | Lemma ty_subst sigma Gamma Delta s A : 435 | [ Delta |- sigma -| Gamma ] -> [ Gamma |- s :- A ] -> 436 | [ Delta |- s.[sigma] :- A.[sigma] ]. 437 | Proof. 438 | move=> stp tp. elim: tp sigma Delta stp => {Gamma s A} /= 439 | [Gamma x si|Gamma n|Gamma A B s t _ ih1 _ ih2| 440 | Gamma A B s n _ ih1 _ ih2|Gamma A B n _ ih1 _ ih2| 441 | Gamma n A B s sub _ ih1 _ ih2] sigma Delta stp //=. 442 | - exact: stp. 443 | - apply: (@ty_eapp _ A.[sigma] B.[up sigma]). autosubst. 444 | exact: ih1. exact: ih2. 445 | - eapply ty_lam. by eapply ih1. apply: ih2. exact: sty_up. 446 | - apply: ty_prod. exact: ih1. apply ih2. exact: sty_up. 447 | - apply: (@ty_sub _ n A.[sigma] B.[sigma]). exact: sub_subst. 448 | exact: ih1. exact: ih2. 449 | Qed. 450 | 451 | Lemma ty_cut Gamma s t A B : 452 | [ A :: Gamma |- s :- B ] -> [ Gamma |- t :- A ] -> 453 | [ Gamma |- s.[t/] :- B.[t/] ]. 454 | Proof. 455 | move=> /ty_subst h tp. apply: h => -[_|x leq]; asimpl => //. exact: ty_var. 456 | Qed. 457 | 458 | Lemma ty_ctx_conv Gamma s A B C n : 459 | [ A :: Gamma |- s :- C ] -> B === A -> [ Gamma |- A :- Sort n ] -> 460 | [ B :: Gamma |- s :- C ]. 461 | Proof. 462 | move=> tp1 conv tp2. cut ([ B :: Gamma |- s.[ids] :- C.[ids] ]). autosubst. 463 | apply: ty_subst tp1. move=> [_|x //=]. asimpl. eapply ty_sub. 464 | eapply conv_sub. eapply (conv_subst _ conv). 465 | apply: eweakening tp2 => //. eapply ty_var => //. 466 | move=> le. asimpl. exact: ty_var. 467 | Qed. 468 | 469 | (* Inversion Lemmas *) 470 | 471 | Lemma ty_prod_invX Gamma A B n u : 472 | [ Gamma |- Prod A B :- u ] -> u <: Sort n -> 473 | [ Gamma |- A :- Sort n ] /\ [ A :: Gamma |- B :- Sort n ]. 474 | Proof. 475 | move e:(Prod A B) => s tp. elim: tp A B e n => //{Gamma s u} 476 | [Gamma A B n tp1 _ tp2 _ A' B' [->->] 477 | |Gamma n s A B sub1 _ _ tp ih A' B' e] m sub2. 478 | - eauto using ty_sub. 479 | - subst. apply: ih => //. exact: sub_trans sub1 sub2. 480 | Qed. 481 | 482 | Lemma ty_prod_inv Gamma A B n : 483 | [ Gamma |- Prod A B :- Sort n ] -> 484 | [ Gamma |- A :- Sort n ] /\ [ A :: Gamma |- B :- Sort n ]. 485 | Proof. move=> h. exact: (ty_prod_invX h). Qed. 486 | 487 | Lemma ty_lam_invX Gamma s A B C : 488 | [ Gamma |- Lam s :- C ] -> 489 | (C <: Prod A B /\ [ A :: Gamma |- B ]) \/ Prod A B = C -> 490 | [ A :: Gamma |- s :- B ]. 491 | Proof. 492 | move e:(Lam s) => t tp. elim: tp A B s e => // {Gamma t C}. 493 | - move=> Gamma A B s n tp1 _ tp2 _ A' B' s' [->] [|[->->//]]. 494 | move=> [/sub_prod_inv[con sub] [m tp3]]. apply: ty_sub sub tp3 _. 495 | apply: ty_ctx_conv tp2 _ tp1. exact: conv_sym. 496 | - move=>Gamma n A B s sub1 tp1 ih1 tp2 ih2 A' B' t eqn1 [[sub2 [m tp3]]|eqn2]; 497 | subst; apply: ih2 => //; left; split => //. 498 | + exact: sub_trans sub1 sub2. by exists m. 499 | + exists n. by move: tp1 => /ty_prod_inv[]. 500 | Qed. 501 | 502 | Lemma ty_lam_inv Gamma s A B : 503 | [ Gamma |- Lam s :- Prod A B ] -> [ A :: Gamma |- s :- B ]. 504 | Proof. move=> tp. apply: ty_lam_invX tp _. by right. Qed. 505 | 506 | (* Main Result *) 507 | 508 | Lemma propagation Gamma s A : 509 | [ Gamma |- s :- A ] -> [ Gamma |- ] -> [ Gamma |- A ]. 510 | Proof. 511 | elim=> {Gamma s A} /= 512 | [Gamma x si /ty_ok||Gamma A B _ t _ ih tp _ ok|Gamma A B s n tp _ _ ih ok| 513 | |Gamma n A B s _ tp _ _ _ _] //. 514 | - exact. 515 | - move: (ih ok) => [n {ih ok} /ty_prod_inv[_ ih]]. 516 | exists n. exact: ty_cut ih tp. 517 | - apply: ty_prod_wf. by exists n. apply: ih. exact: ctx_ncons tp ok. 518 | - by exists n. 519 | Qed. 520 | 521 | Lemma subject_reduction Gamma s A : 522 | [ Gamma |- ] -> [ Gamma |- s :- A ] -> 523 | forall t, step s t -> [ Gamma |- t :- A ]. 524 | Proof. 525 | move=> wf tp. elim: tp wf => {Gamma s A}. 526 | - move=> Gamma x _ wf t st. by inv st. 527 | - move=> Gamma n wf t st. by inv st. 528 | - move=> Gamma A B s t tp1 ih1 tp2 ih2 wf u st. inv st. 529 | + apply ty_lam_inv in tp1. exact: ty_cut tp1 tp2. 530 | + apply: ty_app tp2. exact: ih1. 531 | + move: (tp1) => /propagation/(_ wf)[m]/ty_prod_inv[_ tp3]. 532 | eapply ty_sub; last first. eapply ty_app. eassumption. exact: ih2. 533 | move: (ty_cut tp3 tp2) => /= h. apply h. apply: conv_sub. 534 | apply: conv_beta. exact: conv1i. 535 | - move=> Gamma A B s n tp1 ih1 tp2 ih2 wf t st. inv st. 536 | apply: ty_lam (tp1) _. apply: ih2 => //. apply: ctx_ncons tp1 wf. 537 | - move=> Gamma A B n tp1 ih1 tp2 ih2 wf t st. inv st. 538 | + apply: ty_prod. exact: ih1. eapply (ty_ctx_conv tp2). 539 | exact: conv1i. eassumption. 540 | + apply: ty_prod => //. apply: ih2 => //. exact: ctx_ncons tp1 wf. 541 | - move=> Gamma s A B n tp1 ih1 con tp2 ih2 wf t st. 542 | apply: ty_sub tp1 ih1 _. exact: ih2. 543 | Qed. 544 | 545 | (* Local Variables: *) 546 | (* coq-load-path: (("." "Ssr") ("../../theories" "Autosubst")) *) 547 | (* End: *) 548 | -------------------------------------------------------------------------------- /manual.tex: -------------------------------------------------------------------------------- 1 | \documentclass{scrartcl} 2 | 3 | \usepackage[utf8]{inputenc} 4 | \usepackage[T1]{fontenc} 5 | \usepackage{xspace} 6 | 7 | \usepackage{hyperref} 8 | \usepackage{enumitem} 9 | \usepackage{colonequals} 10 | \usepackage{stmaryrd} 11 | \usepackage{tikz} 12 | \usepackage{amsmath} 13 | 14 | \usepackage{todonotes} 15 | 16 | % style adjustments 17 | 18 | \renewcommand{\arraystretch}{1.5} 19 | 20 | % Manual Macros 21 | \def\changemargin#1#2{} 22 | \newcommand{\faq}[2]{\vspace{\topsep}\noindent\textbf{#1}\\\vspace{-\topsep}\begin{itemize}[nolistsep]\item[]{#2}\end{itemize}} 23 | 24 | 25 | % Operations and Names 26 | 27 | \newcommand{\Autosubst}{\textsc{Autosubst}\xspace} 28 | 29 | \newcommand{\up}{\ensuremath{{}\mathop{\!\Uparrow\!}{}}} 30 | \newcommand{\lift}{\text{\tiny\raisebox{0.15em}+\!\small{1}}}%\ensuremath{{}\mathop{\!\uparrow\!}{}}} 31 | \newcommand{\scons}{\ensuremath{\coloncolon}} 32 | \newcommand{\scomp}{\,\textrm{\guillemotright}\,} 33 | \newcommand{\id}{\textsf{id}} 34 | \newcommand{\subst}[1]{[#1]} 35 | 36 | % remember TikZ positions. 37 | \newcommand{\tmark}[1]{ 38 | \tikz[remember picture, baseline, inner xsep=0, inner ysep=0.2em]{ \node [anchor=base] (#1) {\vphantom{M}}; 39 | }}% 40 | 41 | % general stuff 42 | 43 | \newcommand{\stackl}[2]{\vtop{\hbox{\strut#1}\hbox{\strut#2}}} 44 | \newcommand{\stackc}[2]{\vtop{\setbox0\hbox{\strut #1}\copy0\hbox to\wd0{\hss\strut #2\hss}}} 45 | \newcommand{\stackr}[2]{\vtop{\setbox0\hbox{\strut #1}\copy0\hbox to\wd0{\hss\strut #2}}} 46 | 47 | 48 | % References 49 | 50 | \bibliographystyle{plain} 51 | \newcommand{\sref}[1]{{\tiny[#1]}} 52 | 53 | % Lambda-terms 54 | 55 | \newcommand{\ldot}{.\,} 56 | \newcommand{\lam}[2][l0]{\lambda #2\!\tmark{#1}\,.\,} 57 | \newcommand{\dlam}[1][l0]{\lambda\!\tmark{#1}\,\,} 58 | \newcommand{\ind}[2][l0]{ 59 | \tikz[remember picture, baseline=(i.base), inner xsep=0, inner ysep=0.2em]\node(i){$#2$}; 60 | \tikz[remember picture, overlay]{ 61 | \draw[->] (i.north) to[bend right] (#1.north);}} 62 | \newcommand{\indb}[2][l0]{ 63 | \tikz[remember picture, baseline=(i.base), inner xsep=0, inner ysep=0.2em]\node(i){$#2$}; 64 | \tikz[remember picture, overlay]{ 65 | \draw[->] (i.south) to[bend left] (#1.south);}} 66 | 67 | 68 | % listings 69 | 70 | \usepackage{listings} 71 | 72 | \newcommand*{\lstitem}[1]{ 73 | \setbox0\hbox{\lstinline{#1}} 74 | \item[\usebox0] 75 | % \item[\hbox{\lstinline{#1}}] 76 | \hfill \\ 77 | } 78 | 79 | \newcommand{\lst}{\lstinline} 80 | \lstdefinelanguage{Coq}% 81 | {morekeywords={Variable,Inductive,CoInductive,Fixpoint,CoFixpoint,% 82 | Definition,Lemma,Theorem,Axiom,Local,Save,Grammar,Syntax,Intro,% 83 | Trivial,Qed,Intros,Symmetry,Simpl,Rewrite,Apply,Elim,Assumption,% 84 | Left,Cut,Case,Auto,Unfold,Exact,Right,Hypothesis,Pattern,Destruct,% 85 | Constructor,Defined,Fix,Record,Proof,Induction,Hints,Exists,let,in,% 86 | Parameter,Split,Red,Reflexivity,Transitivity,if,then,else,Opaque,% 87 | Transparent,Inversion,Absurd,Generalize,Mutual,Cases,of,end,Analyze,% 88 | AutoRewrite,Functional,Scheme,params,Refine,using,Discriminate,Try,% 89 | Require,Load,Import,Scope,Set,Open,Section,End,match,with,Ltac,% 90 | Instance,% 91 | bind,as,% 92 | % , exists, forall 93 | },% 94 | sensitive, % 95 | morecomment=[n]{(*}{*)},% 96 | morestring=[d]",% 97 | literate={=>}{{$\Rightarrow$}}1 {>->}{{$\rightarrowtail$}}2{->}{{$\rightarrow$}}1 98 | {\/\\}{{$\wedge$}}1 99 | {|-}{{$\vdash$}}1 100 | {\\\/}{{$\vee$}}1 101 | {~}{{$\sim$}}1 102 | {exists}{{$\exists\!\!$}}1 103 | {forall}{{$\forall\!\!$}}1 104 | {sigma}{{$\sigma$}}1 105 | {theta}{{$\theta$}}1 106 | {tau}{{$\tau$}}1 107 | {rho}{{$\rho$}}1 108 | {xi}{{$\xi$}}1 109 | {exi}{exi}3 % insufficient patch to print reflexivity correctly 110 | {zeta}{{$\zeta$}}1 111 | {Gamma}{{$\Gamma$}}1 112 | {Delta}{{$\Delta$}}1 113 | {\\rhd}{{$\rhd$}}1 114 | %{>>}{\scomp}1 115 | %{<>}{{$\neq$}}1 indeed... no. 116 | }[keywords,comments,strings]% 117 | 118 | \lstset{ 119 | basicstyle=\ttfamily, 120 | keywordstyle=\bfseries\color{blue} 121 | } 122 | \lstset{language=Coq} 123 | \lstset{columns=fullflexible, keepspaces} 124 | 125 | \begin{document} 126 | 127 | \title{Autosubst Manual} 128 | \date{\today} 129 | \maketitle 130 | 131 | \begin{abstract} 132 | Formalizing syntactic theories with variable binders is not easy. We present Autosubst, a library for the Coq proof assistant to automate this process. Given an inductive definition of syntactic objects in de Bruijn representation augmented with binding annotations, Autosubst synthesizes the parallel substitution operation and automatically proves the basic lemmas about substitutions. Our core contribution is an automation tactic that computes a normal form for Coq expressions containing substitutions. This allows to solve equations between such terms. This makes the usage of substitution lemmas unnecessary. The tactic is based on our current work on a decision procedure for the equational theory of an extension of the sigma-calculus by Abadi et. al. The library is completely written in Coq and uses Ltac to synthesize the substitution operation. 133 | \end{abstract} 134 | 135 | \section{Tutorial} 136 | \label{sec:Tutorial} 137 | 138 | We start by importing the \Autosubst library. 139 | \begin{lstlisting} 140 | From Autosubst Require Import Autosubst. 141 | \end{lstlisting} 142 | 143 | Using de~Bruijn Syntax in Coq, the untyped lambda calculus is usually defined as shown \autoref{fig:naive-ulc-term-def}. 144 | \begin{figure} 145 | \begin{minipage}{0.45\textwidth} 146 | \centering 147 | \begin{lstlisting} 148 | Inductive term : Type := 149 | | Var (x : nat) 150 | | App (s t : term) 151 | | Lam (s : term). 152 | \end{lstlisting} 153 | \caption{Usual term definition with de~Bruijn indices} 154 | \label{fig:naive-ulc-term-def} 155 | \end{minipage} 156 | \hfill 157 | \begin{minipage}{0.45\textwidth} 158 | \begin{lstlisting} 159 | Inductive term : Type := 160 | | Var (x : var) 161 | | App (s t : term) 162 | | Lam (s : {bind term}). 163 | \end{lstlisting} 164 | \caption{Term definition for \Autosubst} 165 | \label{fig:autosubst-ulc-term-def} 166 | \end{minipage} 167 | \end{figure} 168 | Using \Autosubst, we can automatically generate the substitution operation. 169 | To do so, we annotate the positions of binders in the term type, since de~Bruijn indices are interpreted differently if occuring below a binder. The annotated definition is shown in \autoref{fig:autosubst-ulc-term-def}. 170 | We write \lst${bind term}$ instead of \lst$term$ for the argument type of a constructor to indicate that this constructor serves as a binder for the argument. 171 | The type \lst${bind term}$ is definitionally equal to \lst$term$ and just serves as a tag interpreted while generating the substitution operation. 172 | We also need to tag the constructor that builds variables. We do so by specifying the type of its single argument as \lst$var$, which is definitionally equal to \lst$nat$. 173 | 174 | Using this definition of term, we can generate the substitution operation \lst@subst@ by declaring an instance of the \lst$Subst$ type class using our custom tactic \lst$derive$. This is comparable to the usage of deriving-clauses in Haskell. 175 | We also need to define instances for the two auxiliary type classes \lst$Ids$ and \lst$Rename$, which define the functions \lst$ids$ and \lst$rename$. 176 | The function \lst$rename$ is only needed for technical reasons\footnote{The function rename applies a renaming \lst@var -> var@ to a term. Since it is possible to give a direct structurally recursive definition of \lst@rename@, we use \lst@rename@ to give a structurally recursive definition of \lst@subst@. By simplifying \lst@subst@ and afterwards unfolding \lst@up@, it is possible to stumble upon an occurrence of \lst@rename@. We try to prevent this by eagerly replacing \lst@rename xi@ with \lst@subst (ren xi)@ in our automation and simplification tactics.} and is mostly hidden from the interface. 177 | The function \lst$ids$ is the identity substitution, which is identical to the variable constructor. 178 | \begin{lstlisting} 179 | Instance Ids_term : Ids term. derive. Defined. 180 | Instance Rename_term : Rename term. derive. Defined. 181 | Instance Subst_term : Subst term. derive. Defined. 182 | \end{lstlisting} 183 | 184 | We can now use the pre-defined generic notations to call the just created substitution operation for \lst$term$. Given substitutions \lst$sigma$ and \lst$tau$, that is, values of type \lst$var -> term$, we can now write \lst$s.[sigma]$ for the application of \lst$sigma$ to the term \lst$s$ and \lst$sigma >> tau$ for the composition of \lst$sigma$ and \lst$tau$. 185 | The notation \lst$s.[sigma]$ stands for \lst$subst sigma s$. 186 | The notation \lst$sigma >> tau$ is equal to \lst$sigma >>> subst tau$, where \lst$>>>$ is function composition, i.e., \lst$(f >>> g) x = g(f(x))$. 187 | 188 | Next, we generate the corresponding substitution lemmas by deriving an instance of the \lst$SubstLemmas$ type class. 189 | \begin{figure} 190 | \begin{lstlisting} 191 | subst_comp s sigma tau : s.[sigma].[tau] = s.[sigma >> tau] 192 | subst_id s : s.[ids] = s 193 | id_subst x sigma : (ids x).[sigma] = sigma x 194 | rename_subst xi s : rename xi s = s.[ren xi] 195 | \end{lstlisting} 196 | \caption{Substitution Lemmas in \lst$SubstLemmas$} 197 | \label{fig:SubstLemmas} 198 | \end{figure} 199 | It contains the lemmas depiced in \autoref{fig:SubstLemmas}. 200 | The lemma \lst$subst_comp$ states that instead of applying two substitutions in sequence, you can apply the composition of the two. This property is essential and surprisingly difficult to show if done manually. 201 | The lemma \lst$rename_subst$ is needed to eliminate occurrences of the renaming function \lst$rename$. Renaming can be expressed with ordinary substitutions using the function \lst$ren$ which lifts a function on variables \lst$var -> var$ to a substitution \lst$var -> term$. It is defined as \lst$ren xi := xi >>> ids$. 202 | \begin{lstlisting} 203 | Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 204 | \end{lstlisting} 205 | 206 | 207 | This was all the boilerplate code needed to start using the library. 208 | Let us explore the behavior of substitution on some examples. 209 | All variables are replaced by the respective value of the substitution. The term \lst$(Var x).[sigma]$ simplifies to \lst$sigma x$. 210 | Substitution is extended to application homomorphically. 211 | The term \lst$(App s t).[sigma]$ simplifies to \lst$App s.[sigma] t.[sigma]$. 212 | When going below a binder, the substitution is changed accordingly. 213 | The term \lst$(Lam s).[sigma]$ simplifies to \lst$Lam s.[up sigma]$. 214 | The substitution \lst$up sigma$ is equal to \lst$Var 0 .: (sigma >> ren (+1))$ where \lst$(+1)$ is the renaming increasing every variable by one and \lst$.:$ is the stream-cons operator. 215 | For \lst$a : X$ and \lst$f : var -> X$, the expression \lst$a .: f$ has type \lst$var -> X$ and satisfies the following equations. 216 | \begin{align*} 217 | \text{\lst$(a .: f) 0$} &= \text{\lst$a$} \\ 218 | \text{\lst$(a .: f) (S n)$} &= \text{\lst$f n$} 219 | \end{align*} 220 | So \lst$up sigma$ leaves \lst$0$ unchanged and for a variable \lst$S x$, it yields \lst$(sigma x).[ren(+1)]$ to account for the fact that below the binder, the free variables are shifted by 1. 221 | 222 | \subsection*{Substitutivity} 223 | \label{sec:substitutivity} 224 | 225 | Let us start to use the term language. 226 | We can define the reduction relation of the untyped lambda calculus as follows. 227 | \begin{lstlisting} 228 | Inductive step : term -> term -> Prop := 229 | | Step_Beta s s' t : s' = s.[t .: ids] -> step (App (Lam s) t) s' 230 | | Step_App1 s s' t: step s s' -> step (App s t) (App s' t) 231 | | Step_App2 s t t': step t t' -> step (App s t) (App s t') 232 | | Step_Lam s s' : step s s' -> step (Lam s) (Lam s'). 233 | \end{lstlisting} 234 | The most interesting rule is \lst$Step_Beta$, which expresses beta reduction using the stream-cons operator. 235 | That is, the term \lst$s.[t .: ids]$ is \lst$s$ where the index \lst$0$ is replaced by \lst$t$ and all other indices are reduced by one. 236 | Also note that the rule \lst$Step_Beta$ contains a superfluous equation to make it applicable in more situations. 237 | 238 | 239 | Now let us show a property of the reduction relation, the fact that it is closed under substitutions. 240 | \begin{lstlisting} 241 | Lemma step_subst s s' : step s s' -> forall sigma, step s.[sigma] s'.[sigma]. 242 | Proof. induction 1; constructor; subst; now asimpl. Qed. 243 | \end{lstlisting} 244 | The tactic \lst$asimpl$ simplifies expressions containing substitutions using a powerful rewriting system. This suffices to make all the subgoals trivial. The equational subgoal 245 | \begin{center} 246 | \lst$s1.[up sigma].[t.[sigma] .: ids] = s1.[t .: ids].[sigma]$ 247 | \end{center} 248 | created by the application of the constructor \lst$Step_Beta$ gives a good impression of the power of \lst$asimpl$. Both sides of the equation are simplified to \lst$s1.[t.[sigma] .: sigma]$. 249 | 250 | \subsection*{Type Preservation} 251 | \label{sec:preservation} 252 | 253 | We conclude the tutorial with a proof of type preservation for the simply typed lambda calculus. This example shows how to prove structural properties of a typing relation. 254 | 255 | First, we need simple types. We define a base type \lst$Base$ and an arrow type \lst$Arr A B$ for functions from \lst$A$ to \lst$B$. 256 | \begin{lstlisting} 257 | Inductive type := 258 | | Base 259 | | Arr (A B : type). 260 | \end{lstlisting} 261 | Then, we can define the typing judgment. 262 | \begin{lstlisting} 263 | Inductive ty (Gamma : var -> type) : term -> type -> Prop := 264 | | Ty_Var x A : Gamma x = A -> 265 | ty Gamma (Var x) A 266 | | Ty_Lam s A B : ty (A .: Gamma) s B -> 267 | ty Gamma (Lam s) (Arr A B) 268 | | Ty_App s t A B : ty Gamma s (Arr A B) -> ty Gamma t A -> 269 | ty Gamma (App s t) B. 270 | \end{lstlisting} 271 | We use infinite contexts. This allows us to encode contexts as functions of type \lst$var -> type$, which coincides with the type of substitutions. Thus we can reuse the operations and tactics of \Autosubst for contexts. 272 | 273 | Usually, a type preservation proof starts with a weakening lemma for the typing relation, which states that you can add a binding to the context. 274 | In de~Bruijn formalizations, it is usually stated with an operation that adds a single binding at an arbitrary position in the context. 275 | Using parallel substitutions, we can generalize this to all contexts that can be obtained by reinterpreting the indices. This avoids ugly shiftings in the lemma statement. Moreover, this single lemma subsumes weakening, contraction and exchange. 276 | \begin{lstlisting} 277 | Lemma ty_ren Gamma s A: ty Gamma s A -> forall Delta xi, 278 | Gamma = (xi >>> Delta) -> 279 | ty Delta s.[ren xi] A. 280 | Proof. 281 | induction 1; intros; subst; asimpl; econstructor; eauto. 282 | - eapply IHty. autosubst. 283 | Qed. 284 | \end{lstlisting} 285 | For case of typing a lambda expression, the application of \lst@autosubst@ solves the following equation between contexts. 286 | \begin{center} 287 | \lst$ A .: xi >>> Delta = (0 .: xi >>> (+1)) >>> A .: Delta$ 288 | \end{center} 289 | This also happens to be a good example for the somewhat complex but efficient precedence of \lst$.:$ and the composition operators. Altough both have the same\footnote{Technically, this is not directly possible with the Coq notation mechanism. However, you can achieve the same effect by giving \lst$.:$ a lower precedence level (that is, higher precedence) and its right argument the same level as the composition operators. It would be simpler to give everything right associativity, but this does not work for heterogeneous substitutions.} precedence level, the composition operators are left-associative while \lst$.:$ is right associative. So the given equation is equivalent to the following. 290 | \begin{center} 291 | \lst$ A .: (xi >>> Delta) = (0 .: (xi >>> (+1))) >>> (A .: Delta)$ 292 | \end{center} 293 | Unfortunately, Coq 8.4 contains a bug such that the right-hand side is printed without parentheses, although this would be parsed as the ill-typed term 294 | \begin{center} 295 | \lst$0 .: ((xi >>> (+1)) >>> (A .: Delta))$. 296 | \end{center} 297 | 298 | By generalizing \lst@ty_ren@ to substitutions, we obtain that we preserve typing if we replace variables by terms of the same type. 299 | \begin{lstlisting} 300 | Lemma ty_subst Gamma s A: ty Gamma s A -> forall sigma Delta, 301 | (forall x, ty Delta (sigma x) (Gamma x)) -> 302 | ty Delta s.[sigma] A. 303 | Proof. 304 | induction 1; intros; subst; asimpl; eauto using ty. 305 | - econstructor. eapply IHty. 306 | intros [|]; asimpl; eauto using ty, ty_ren. 307 | Qed. 308 | \end{lstlisting} 309 | Again, the only non-trivial subgoal is the typing of a lambda expression. Applying the inductive hypothesis yields the following subgoal. 310 | \begin{center} 311 | \lst$forall x : var, ty (scons A Delta) (up sigma x) (scons A Gamma x)$ 312 | \end{center} 313 | We solve it by destructing \lst$x$ with \lst$intros [|]$ and simplifying the resulting terms with \lst$asimpl$, which makes them match \lst$Ty_Var$ and \lst$ty_ren$, respectively. 314 | 315 | To show type preservation of the simply typed lambda calculus, we use \lst@ty_subst@ to justify the typing of the result of the beta reduction. 316 | The tactic \lst$ainv$ performs \lst$inversion$ on all hypothesis where this does not produce more than one subgoal. 317 | \begin{lstlisting} 318 | Lemma ty_pres Gamma s A : ty Gamma s A -> forall s', 319 | step s s' -> 320 | ty Gamma s' A. 321 | Proof. 322 | induction 1; intros s' H_step; asimpl; 323 | inversion H_step; ainv; eauto using ty. 324 | - eapply ty_subst; try eassumption. 325 | intros [|]; simpl; eauto using ty. 326 | Qed. 327 | \end{lstlisting} 328 | Again, we need to destruct the universally quantified variable in the premise of \lst$ty_subst$. 329 | 330 | This tutorial only covered the basic aspects of \Autosubst. For examples of how to use \Autosubst for many-sorted syntax with heterogeneous substitutions or with dependent contexts, please refer to the case studies distributed with \Autosubst. 331 | 332 | \section{Reference Manual} 333 | \label{sec:manual} 334 | 335 | \subsection{Defining the Syntax} 336 | \label{sec:defining-syntax} 337 | 338 | To start using \Autosubst, you first have to define an inductive type of terms with de~Bruijn indices. 339 | This should be a simple inductive definition without dependent types. 340 | There must be at most one constructor for variables, aka de~Bruijn indices. It must have a single argument of type \lst$var$, which is a type synonym for \lst$nat$. 341 | If a constructor acts as a binder for a variable of the term type \lst$T$ in a constructor argument of type \lst$U$, then \lst$U$ has to be replaced by \lst${bind T in U}$. 342 | We can write \lst${bind T}$ instead of \lst${bind T in T}$. 343 | \autoref{fig:term-type-example} shows how this looks for the two-sorted syntax of System F. 344 | \begin{figure} 345 | \centering 346 | \begin{lstlisting} 347 | Inductive type : Type := 348 | | TyVar (x : var) 349 | | Arr (A B : type) 350 | | All (A : {bind type}). 351 | 352 | Inductive term := 353 | | TeVar (x : var) 354 | | Abs (A : type) (s : {bind term}) 355 | | App (s t : term) 356 | | TAbs (s : {bind type in term}) 357 | | TApp (s : term) (A : type). 358 | \end{lstlisting} 359 | \caption{Declaration of the syntax of System F} 360 | \label{fig:term-type-example} 361 | \end{figure} 362 | 363 | \subsection{Generating the Operations} 364 | \label{sec:gener-oper} 365 | 366 | We need to generate the substitution operations for the used term types and the corresponding lemmas. 367 | This is done with instance declarations for the corresponding typeclass instances and the tactic \lst$derive$, which is defined as \lst$trivial with derive$ and we have collected a tactic for every typeclass in the hint database \lst$derive$. The operations are summarized in \autoref{tab:derived-ops} and the corresponding lemmas in \autoref{tab:derived-lemmas}. 368 | \begin{table} 369 | \centering 370 | \begin{tabular}{l l l l} 371 | Typeclass & Function & Notation & Type \\\hline\noalign{\vspace{0.5em}} 372 | 373 | \lst$Ids term$ & \lst$ids x$ & & \lst$var -> term$ \\ 374 | \lst$Rename term$ & \lst$rename xi s$ & & \stackr{\lst$(var -> var) ->$}{\lst$term -> term$} \\ 375 | \lst$Subst term$ & \lst$subst sigma s$ & \lst$s.[sigma]$ & \stackr{\lst$(var -> term) ->$}{\lst$term -> term$} \\ 376 | \lst$HSubst term1 term2$ & \lst$hsubst sigma s$ & \lst$s.|[sigma]$ & \stackr{\lst$(var -> term1) ->$}{\lst$term2 -> term2$} 377 | \end{tabular} 378 | \caption{Operations that can be generated with \Autosubst} 379 | \label{tab:derived-ops} 380 | \end{table} 381 | \begin{table} 382 | \centering 383 | \begin{tabular}{l l} 384 | Typeclass & Contained Lemmas \\\hline\noalign{\vspace{0.5em}} 385 | 386 | \lst$SubstLemmas term$ & 387 | \vtop{\hbox{\strut \lst$rename xi s = s.[ren xi]$,\quad \lst$s.[ids] = s$,} 388 | \hbox{\strut\lst$(ids x).[sigma] = sigma x$,\quad \lst$s.[sigma].[tau] = s.[sigma >> tau]$}} \\ 389 | \lst$HSubstLemmas term1 term2$ & 390 | \vtop{\hbox{\strut\lst$s.|[ids] = s$,\quad \lst$(ids x).|[sigma] = ids x$,} 391 | \hbox{\strut \lst$s.|[sigma].|[tau] = s.|[sigma >> tau]$}} \\ 392 | \lst$SubstHSubstComp term1 term2$ & \lst$s.[sigma].|[tau] = s.|[tau].[sigma >>| tau]$ 393 | \end{tabular} 394 | \caption{Lemmas that can be generated with \Autosubst} 395 | \label{tab:derived-lemmas} 396 | \end{table} 397 | 398 | For example, the syntax of System F needs the declarations shown in \autoref{fig:derive-example}. 399 | \begin{figure} 400 | \centering 401 | \begin{lstlisting} 402 | Instance Ids_type : Ids type. derive. Defined. 403 | Instance Rename_type : Rename type. derive. Defined. 404 | Instance Subst_type : Subst type. derive. Defined. 405 | 406 | Instance SubstLemmas_type : SubstLemmas type. derive. Qed. 407 | 408 | Instance HSubst_term : HSubst type term. derive. Defined. 409 | 410 | Instance Ids_term : Ids term. derive. Defined. 411 | Instance Rename_term : Rename term. derive. Defined. 412 | Instance Subst_term : Subst term. derive. Defined. 413 | 414 | Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed. 415 | Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed. 416 | 417 | Instance SubstLemmas_term : SubstLemmas term. derive. Qed. 418 | \end{lstlisting} 419 | \caption{Declarations to derive the operations and lemmas for System F} 420 | \label{fig:derive-example} 421 | \end{figure} 422 | It is important to build the instances in the right order because they depend on each other. 423 | We summarize the dependencies between the type class instances in \autoref{tab:decl-order}. 424 | \begin{table} 425 | \centering 426 | \begin{tabular}{l l} 427 | Typeclass & Required Prior Declarations \\\hline\noalign{\vspace{0.5em}} 428 | 429 | \lst$Ids term$ & none \\ 430 | 431 | \lst$Rename term$ & none \\ 432 | 433 | \lst$Subst term$ & \vtop{ 434 | \hbox{\strut 435 | \lst$Rename term$, 436 | } 437 | \hbox{\strut 438 | \lst$HSubst term' term$ 439 | } 440 | \hbox{\strut 441 | \quad if \lst$term$ contains \lst${bind term' in term}$ 442 | } 443 | } \\ 444 | 445 | \lst$HSubst term1 term2$ & \vtop{ 446 | \hbox{\strut 447 | \lst$Subst term1$, 448 | } 449 | \hbox{\strut 450 | \lst$HSubst term3 term4$ 451 | } 452 | \hbox{\strut 453 | \quad if \lst$term2$ contains \lst${bind term3 in term4}$, 454 | } 455 | \hbox{\strut 456 | \lst$HSubst term1 term3$ 457 | } 458 | \hbox{\strut 459 | \quad if \lst$term2$ contains \lst$term3$ 460 | } 461 | } \\ 462 | 463 | \lst$SubstLemmas term$ & \vtop{ 464 | \hbox{\strut 465 | \lst$Ids term$, 466 | } 467 | \hbox{\strut 468 | \lst$Subst term$, 469 | } 470 | \hbox{\strut 471 | \lst$HSubstLemmas term1 term2$ 472 | } 473 | \hbox{\strut 474 | and \lst$SubstHSubstComp term1 term2$ 475 | } 476 | \hbox{\strut 477 | \quad if \lst$Subst term$ requires \lst$HSubst term1 term2$ 478 | }} \\ 479 | 480 | 481 | \lst$HSubstLemmas term1 term2$ & 482 | \vtop{ 483 | \hbox{\strut 484 | \lst$HSubst term1 term2$, 485 | }\hbox{\strut 486 | \lst$SubstLemmas term1$ 487 | } 488 | } 489 | 490 | \end{tabular} 491 | \caption{Required Declaration Order of the Typeclass Instances} 492 | \label{tab:decl-order} 493 | \end{table} 494 | 495 | \subsection{Defined Operations} 496 | \label{sec:pred-oper} 497 | 498 | \Autosubst defines a number of operations, some of which depend on the generated operations. 499 | They are important not only because they are useful in statements, but more importantly because our custom tactics incorporate facts about them. They are summarized in \autoref{tab:defined-ops}. 500 | 501 | \begin{table} 502 | \centering 503 | \lstset{boxpos=t, aboveskip=0em, belowskip=0em} 504 | \begin{tabular}{l l l r} 505 | Name & Notation & Definition & Type \\\hline\noalign{\vspace{0.5em}} 506 | 507 | \lst$funcomp$ & \lst$f >>> g$ & \lst$fun x => g(f x)$ & \stackr{\lst$forall A B C : Type, (A -> B) ->$}{\stackr{\lst$(B -> C) ->$}{\lst$A -> C$}} \\\noalign{\vspace{-1em}} 508 | \begin{lstlisting} 509 | scons 510 | \end{lstlisting} 511 | & \begin{lstlisting} 512 | a .: f 513 | \end{lstlisting} 514 | &\begin{lstlisting} 515 | fun x => 516 | match x with 517 | | 0 => a 518 | | S x' => f x' 519 | end 520 | \end{lstlisting} 521 | & 522 | \begin{lstlisting} 523 | forall X : Type, X -> 524 | (var -> X) -> 525 | var -> X 526 | \end{lstlisting} \\ 527 | \lst$scomp$ & \lst$sigma >> tau$& \lst$sigma >>> subst tau$ & 528 | \stackr{\lst$(var -> term) ->$}{\stackr{\lst$(var -> term) ->$}{\lst$var -> term$}} \\ 529 | \lst$hcomp$ & \lst$sigma >>| theta$& \lst$sigma >>> hsubst theta$ & 530 | \stackr{\lst$(var -> term1) ->$}{\stackr{\lst$(var -> term2) ->$}{\lst$var -> term1$}} \\ 531 | \lst$ren$ & \lst$ren xi$ & \lst$xi >>> ids$ & \stackr{\lst$(var -> var) ->$}{\lst$var -> term$} \\ 532 | \lst$lift$ & \lst$(+ n)$ & \lst$fun x => n + x$ & \stackr{\lst$var ->$}{\lst$var -> var$} \\ 533 | \lst$up$ & \lst$up sigma$ & \lst$ids 0 .: sigma >> ren(+1)$ & \stackr{\lst$(var -> term) ->$}{\lst$var -> term$} 534 | \end{tabular} 535 | \caption{Defined Primitives of \Autosubst} 536 | \label{tab:defined-ops} 537 | \end{table} 538 | 539 | \subsection{The Automation Tactics} 540 | \label{sec:lstautosubst-tactic} 541 | 542 | Autosubst defines two automation tactics: \lst$asimpl$ and \lst$autosubst$. 543 | 544 | \faq{\lst$asimpl$}{Normalizes the claim.} 545 | \faq{\lst$asimpl in H$}{Normalizes the hypothesis \lst$H$.} 546 | \faq{\lst$asimpl in *$}{Normalizes the claim and all hypothesis.} 547 | \faq{\lst$autosubst$}{Normalizes the claim and tries to solve the resulting equation.} 548 | \vspace{\topsep} 549 | 550 | Both of them normalize the goal using a convergent rewriting system. 551 | But while the interface and behavior of \lst$asimpl$ mimics \lst$simpl$, the closing tactic \lst$autosubst$ first normalizes an equational claim and then tries to prove it. 552 | The rewriting system is an extension of the $\sigma$-calculus by Abadi et. al. \cite{abadi1991}. 553 | Our goal is to solve all equations that hold without assumptions and are built using only our primitives, application and variables. At the moment, we hope to achieve this if \lst$(+n)$ is only used with a constant \lst$n$. We consider ever real-world example of an unsolvable such equation a bug and invite you to submit it. 554 | 555 | 556 | 557 | The normalization is done by interleaving the rewriting system with calls to \lst$simpl$ to incorporate the definitions of the derived operations. 558 | 559 | 560 | \section{Internals} 561 | \label{sec:internals} 562 | 563 | In the following, we describe technical challenges and how we solved them in Coq. 564 | 565 | \subsection{Normalizing Substitutions} 566 | \label{sec:norm-subst} 567 | 568 | To simplify terms containing substitutions, we use a rewriting system based on the convergent $\sigma$-calculus by Abadi et. al. \cite{abadi1991}. We extended it to variables for renamings, heterogeneous substitutions and to lifts \lst$(+n)$ that add an arbitrary natural number \lst$n$ instead of just 1. To keep the rewriting system small, we base it on function composition and a stream-cons that works on arbitrary streams. So first, we replace 569 | \begin{itemize} 570 | \item \lst$sigma >> tau$ with \lst$sigma >>> subst tau$ 571 | \item \lst$sigma >>| tau$ with \lst$sigma >>> hsubst tau$ 572 | \item \lst$ren xi$ with \lst$xi >>> ids$ 573 | \item \lst$up sigma$ with \lst$ids 0 .: sigma >>> subst ((+1) >>> ids)$. 574 | \end{itemize} 575 | and will undo these unfoldings in the end. 576 | Also, we make function composition right associative, which we also undo in the end. 577 | These tricks allow us to reason about \lst$(+n)$, \lst$.:$ and \lst$>>>$ separately from the proper substitution operations. 578 | 579 | \subsection{Reducible Recursive Type Class Instances} 580 | \label{sec:reduc-recurs-inst} 581 | 582 | We need the substitution operation to reduce and simplify because there is no other way how our automation tactics could learn about the behavior of substitution on custom term types. However, this is challenging since the substitution operations we derive are instances of a type class. We needed a number of tricks to make this work smoothly. 583 | \begin{itemize} 584 | \item We use singleton type classes. So a type class instance is just a definition of the recursive procedure and the type class function reduces to its instance argument. This is important for two reasons. 585 | First, the guardedness checker does not unfold the record projections used for non-singleton type classes. 586 | Second, when \lst$simpl$ reduces a definition bound to a \lst$fix$, it replaces all occurrences of this fix with the name of the definition afterwards. This also just works for singleton type classes. 587 | \item All recursive calls are formulated using the function of the type class with the procedure name bound in the \lst$fix$-term serving as the implicit instance argument. This way, the result of the reduction of a type class function contains again calls to this type class function. 588 | \item The Coq unification algorithm can perform unfoldings that are impossible with \lst$simpl$. This can lead to implicit instance arguments being unfolded. In turn, the type class inference can no longer infer instances depending on the unfolded instance. Apart from using \lst$simpl$ before using tactics that trigger unification like \lst$apply$ or \lst$constructor$, the only way to circumvent this is to revert the unfolding of instances. We automatically do this in all automation tactics by reinferring implicit instance arguments using \lst$exact _$. 589 | 590 | \end{itemize} 591 | 592 | \subsection{Generating the Operations Using Ltac} 593 | \label{sec:gener-ltac} 594 | 595 | We generate the renaming and substitution operations using Ltac. Since these are recursive functions, we use the tactics \lst$fix$ and \lst$destruct$. Consider the substitution operation for the term language from the tutorial. Our \lst$derive$ tactic constructs the following (proof) term. 596 | \begin{lstlisting} 597 | fix inst (sigma : var -> term) (s : term) {struct s} : term := 598 | match s as t return (annot term t) with 599 | | Var x => sigma x 600 | | App s1 s2 => App s1.[sigma] s2.[sigma] 601 | | Lam s0 => Lam s0.[up sigma] 602 | end 603 | \end{lstlisting} 604 | Apart from the return annotation, which is an artifact of our approach, this looks quite clean. However, the recursive call is hidden in the implicit instance argument to \lst$subst$. We can see it if we show all implicit arguments. 605 | \begin{lstlisting} 606 | fix inst (sigma : var -> term) (s : term) {struct s} : term := 607 | match s as t return (@annot Type term term t) with 608 | | Var x => sigma x 609 | | App s1 s2 => App (@subst term inst sigma s1) (@subst term inst sigma s2) 610 | | Lam s0 => Lam (@subst term inst (@up term Ids_term Rename_term sigma) s0) 611 | end 612 | \end{lstlisting} 613 | 614 | To construct this term with Ltac, we start with \lst$ fix inst 2$ to generate the \lst$fix$-term. Since we want to use the recursive identifier \lst$ident$ as a typeclass instance, we make it accessible to the instance inference by changing its type with 615 | \begin{lstlisting} 616 | change _ with (Subst term) in inst 617 | \end{lstlisting} 618 | 619 | Next, we need to construct the \lst$match$, which we can do with a \lst$destruct$. But then, the subgoals do not tell us the constructor of the current \lst$match$ case. 620 | We get this information by annotating the goal with \lst$s$ before calling \lst$destruct$. Then this annotation contains the current constructor with all its arguments after the \lst$destruct$. 621 | The function \lst$annot$, which is the identity on the first argument and ignores the second, allows us to perform the annotation. So we use the script \lst$intros xi s; change (annot term s); destruct s$ 622 | and then the claims of the subgoals are 623 | \begin{itemize} 624 | \item \lst$annot term (Var x)$ 625 | \item \lst$annot term (App s1 s2)$ 626 | \item \lst$annot term (Lam s0)$ 627 | \end{itemize} 628 | So in effect, we have gained access to the patterns of the \lst$match$. Using a recursive, value-producing tactic, we can fold over the applied constructor like a list and change every argument depending on its type. The types of the arguments happen to contain the binding annotations in the definition of \lst$term$, so we can use an Ltac-\lst$match$ to read them and apply substitutions to the arguments accordingly. The type class inference automatically inserts the recursive call and the guardedness checker is able to unfold \lst$subst$ to see the applied recursive call. 629 | 630 | \section{Best Practices} 631 | \label{sec:best-practices} 632 | 633 | 634 | 635 | \subsection{Extending the Automation} 636 | \label{sec:ext-auto} 637 | 638 | If you want to extend the automation to support equations for a new function, you should do the following. 639 | 640 | First, try to define the new function using function composition or other existing supported functions. 641 | If this is possible, then you should define it using the notation mechanism to prevent the supported functions from being hidden behind a defined name. Otherwise, you have to extend the built-in tactics \lst$autosubst_unfold$ and \lst$fold_comp$ to perform the unfolding and folding respectively. 642 | 643 | For example, if you want to lift a semantic interpretation to substitutions 644 | \begin{lstlisting} 645 | subst_interp : (var -> value) -> (var -> term) -> var -> value 646 | \end{lstlisting} 647 | then you should define 648 | \begin{lstlisting} 649 | Notation subst_interp rho sigma := sigma >>> interp rho. 650 | \end{lstlisting} 651 | This automatically adds some limited support. To get full support, you can add the required lemmas to the autorewrite database \lst$autosubst$, which is used by the tactics \lst$asimpl$ and \lst$autosubst$. 652 | 653 | 654 | \bibliography{bib} 655 | 656 | \end{document} 657 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | # When this file changes, run 'generate.sh' from 3 | # https://github.com/coq-community/templates to update the other files. 4 | fullname: Autosubst 5 | shortname: autosubst 6 | organization: coq-community 7 | community: true 8 | action: true 9 | doi: 10.1007/978-3-319-22102-1_24 10 | 11 | synopsis: >- 12 | Coq library for parallel de Bruijn substitutions 13 | 14 | description: |- 15 | Autosubst is a library for the Coq proof assistant which 16 | provides automation for formalizing syntactic theories with 17 | variable binders. Given an inductive definition of syntactic 18 | objects in de Bruijn representation augmented with binding 19 | annotations, Autosubst synthesizes the parallel substitution 20 | operation and automatically proves the basic lemmas about 21 | substitutions. 22 | 23 | publications: 24 | - pub_url: https://www.ps.uni-saarland.de/Publications/documents/SchaeferEtAl_2015_Autosubst_-Reasoning.pdf 25 | pub_title: 'Autosubst: Reasoning with de Bruijn Terms and Parallel Substitutions' 26 | pub_doi: 10.1007/978-3-319-22102-1_24 27 | 28 | authors: 29 | - name: Steven Schäfer 30 | initial: true 31 | - name: Tobias Tebbi 32 | initial: true 33 | 34 | maintainers: 35 | - name: Ralf Jung 36 | nickname: RalfJung 37 | - name: Dan Frumin 38 | nickname: co-dan 39 | 40 | opam-file-maintainer: palmskog@gmail.com 41 | 42 | opam-file-version: dev 43 | 44 | license: 45 | fullname: MIT License 46 | identifier: MIT 47 | 48 | supported_coq_versions: 49 | text: 8.14 or later 50 | opam: '{(>= "8.14" & < "8.21~") | (= "dev")}' 51 | 52 | tested_coq_opam_versions: 53 | - version: 'coq-dev' 54 | repo: 'mathcomp/mathcomp-dev' 55 | - version: '2.2.0-coq-8.19' 56 | repo: 'mathcomp/mathcomp' 57 | - version: '2.1.0-coq-8.18' 58 | repo: 'mathcomp/mathcomp' 59 | - version: '2.0.0-coq-8.17' 60 | repo: 'mathcomp/mathcomp' 61 | - version: '1.17.0-coq-8.17' 62 | repo: 'mathcomp/mathcomp' 63 | - version: '1.16.0-coq-8.17' 64 | repo: 'mathcomp/mathcomp' 65 | - version: '1.15.0-coq-8.16' 66 | repo: 'mathcomp/mathcomp' 67 | - version: '1.14.0-coq-8.15' 68 | repo: 'mathcomp/mathcomp' 69 | - version: '1.13.0-coq-8.15' 70 | repo: 'mathcomp/mathcomp' 71 | - version: '1.12.0-coq-8.14' 72 | repo: 'mathcomp/mathcomp' 73 | 74 | namespace: Autosubst 75 | 76 | keywords: 77 | - name: abstract syntax 78 | - name: binders 79 | - name: de Bruijn indices 80 | - name: substitution 81 | 82 | categories: 83 | - name: Computer Science/Lambda Calculi 84 | 85 | documentation: | 86 | To build the examples that do not need ssreflect, type 87 | ``` 88 | make examples-plain 89 | ``` 90 | 91 | The examples that depend on ssreflect are built with 92 | ``` 93 | make examples-ssr 94 | ``` 95 | 96 | To build the documentation (including all examples), type 97 | ``` 98 | make doc 99 | ``` 100 | 101 | You can use the file `doc/toc.html` to browse the documentation. 102 | 103 | ## Bug Reports 104 | 105 | Please submit bugs reports on https://github.com/coq-community/autosubst/issues 106 | --- 107 | -------------------------------------------------------------------------------- /theories/Autosubst.v: -------------------------------------------------------------------------------- 1 | Require Export Autosubst_Basics. 2 | Require Export Autosubst_MMap. 3 | Require Export Autosubst_Classes. 4 | Require Export Autosubst_Tactics. 5 | Require Export Autosubst_Lemmas. 6 | Require Export Autosubst_Derive. 7 | Require Export Autosubst_MMapInstances. 8 | 9 | (* Local Variables: *) 10 | (* coq-load-path: (("." "Autosubst")) *) 11 | (* End: *) 12 | -------------------------------------------------------------------------------- /theories/Autosubst_Basics.v: -------------------------------------------------------------------------------- 1 | 2 | (** 3 | Functions, Notations and Tactics that are useful, but not limited to 4 | substitutions. 5 | *) 6 | 7 | From Coq.Program Require Import Tactics. 8 | From Coq Require Import PeanoNat List FunctionalExtensionality. 9 | 10 | (** Annotate "a" with additional information. *) 11 | Definition annot {A B} (a : A) (b : B) : A := a. 12 | 13 | (** A variant of type of that is stable under import of ssreflect. *) 14 | Ltac typeof s := let T := type of s in T. 15 | 16 | (** Apply a tactic T in all assumptions. *) 17 | Tactic Notation "in_all" tactic(T) := 18 | repeat match goal with 19 | | [H : _ |- _] => first[T H; try revert H | revert H] 20 | end; intros. 21 | 22 | (** Shorthand for functional extensionality. *) 23 | Ltac f_ext := apply functional_extensionality. 24 | 25 | 26 | (** 27 | A variant of the Coq [fold] tactic that works with open terms. 28 | For example, [repeat open_fold (f _).] tries to undo [unfold f] for 29 | a defined function [f] with a single argument. 30 | *) 31 | Tactic Notation "open_fold" open_constr(s) := 32 | let s' := (eval red in s) in 33 | replace s' with s by reflexivity. 34 | 35 | Tactic Notation "open_fold" open_constr(s) "in" hyp(H) := 36 | let s' := (eval red in s) in 37 | replace s' with s in H by reflexivity. 38 | 39 | 40 | (** Wrapper for deriving type class instances. *) 41 | Ltac derive := trivial with derive; fail. 42 | 43 | (** Assert that type class instance exists.*) 44 | Ltac require_instance s := 45 | try (first[ 46 | assert s;[exact _|idtac] 47 | | fail 10 "The instance" s "is missing" 48 | ]; fail). 49 | 50 | (** 51 | General automation tactics. 52 | - "autorew": Tries to rewrite with any equation in the context. 53 | - "autorevert h": Reverts the assumption h along with all of its 54 | dependencies. 55 | - "inv h": Does an inversion on h and cleans up the goal. 56 | - "ainv": Inverts any assumptions where inv produces only a single 57 | non-trivial subgoal. Takes a tactic as an optional arguments which is 58 | used to solve trivial subgoals. Defaults to "ainv trivial". 59 | Subgoals 60 | - "ren H: T": Search the context for an assumption which matches the 61 | pattern T and renames it to H. 62 | - "renc H: T": Same as above, but tries to match a subterm against T. 63 | *) 64 | 65 | Ltac autorew := 66 | repeat match goal with 67 | | [H : _ = _ |- _] => rewrite H 68 | | [H : forall _, _ |- _] => progress rewrite H by now trivial 69 | end. 70 | 71 | Ltac autorevert x := 72 | try (match goal with 73 | | [y : ?Y |- ?claim] => 74 | try (match x with y => idtac end; fail 1); 75 | match goal with [z : _ |- _] => 76 | match claim with context[z] => 77 | first 78 | [ match Y with context[z] => revert y; autorevert x end 79 | | match y with z => revert y; autorevert x end] 80 | end 81 | end 82 | end). 83 | 84 | (** A variant of the do tactical that behaves like a limit to repeat *) 85 | Ltac do_try n t := 86 | match n with 0 => idtac | S ?n' => try (progress t; do_try n' t) end. 87 | Tactic Notation (at level 3) "do?" constr(n) tactic3(t) := do_try n t. 88 | 89 | Ltac clear_all := repeat match goal with H : _ |- _ => clear H end. 90 | Ltac is_trivial s := 91 | try (assert s; [clear_all; (now idtac || fail 1) | fail]). 92 | 93 | Ltac clean := 94 | (let T H := let s := typeof H in is_trivial s; clear H in 95 | in_all T); clear_dups. 96 | 97 | Ltac inv H := inversion H; try clear H; try subst. 98 | 99 | (* JK: IMPORTANT: This tactic appears to rely on the order in which hypothesis are tried during a match goal, and the default order in which hypotheses are matched appears to have changed from 8.5 to 8.6! the [reverse] keyword reinstates the old behaviour but it might be better to reimplement the tactic in a more predictable fashion! this would probably have a significant impact on existing code! *) 100 | Ltac ainv t := 101 | clean; 102 | do? 10 (idtac; match reverse goal with 103 | | H : ?s |- _ => 104 | progress((cut True; [inv H; t|]); 105 | [(intros _ || trivial) | now idtac ..]; clean) 106 | end). 107 | 108 | 109 | 110 | Tactic Notation "ainv" tactic(t) := ainv t. 111 | Tactic Notation "ainv" := ainv trivial. 112 | 113 | (** rename an assumption identified by its type *) 114 | 115 | Tactic Notation "ren" ident(H) ":" open_constr(T) := 116 | match goal with 117 | | [G : T |- _] => let T' := typeof G in unify T T'; rename G into H 118 | end. 119 | 120 | Tactic Notation "renc" ident(H) ":" open_constr(T) := 121 | match goal with 122 | | [G : context C [T] |- _] => 123 | let TG := typeof G in 124 | let CT := context C [T] in 125 | unify TG CT; 126 | rename G into H 127 | end. 128 | 129 | Tactic Notation "eassert" open_constr(T) := assert(T). 130 | Tactic Notation "epose" open_constr(T) := eassert _;[refine T | idtac]. 131 | 132 | (** 133 | The identity function, and tactics for replacing functions which are 134 | convertible to id with id. This is important for rewriting, where we 135 | can only match against terms syntactically. Using the tactic "fold_id" 136 | ensures that we do not miss functions which are merely convertible to 137 | "id". 138 | *) 139 | 140 | Definition id {A} (x : A) := x. 141 | Arguments id {A} x /. 142 | Global Hint Unfold id : core. 143 | 144 | Ltac fold_id := 145 | repeat match goal with 146 | | [|- context [?s]] => 147 | match s with (fun _ : ?T => _) => progress (change s with (@id T)) end 148 | end. 149 | 150 | Ltac fold_idH H := 151 | repeat match typeof H with 152 | | context[?s] => 153 | match s with 154 | (fun _ : ?T => _) => progress (change s with (@id T) in H) 155 | end 156 | end. 157 | 158 | Tactic Notation "fold_id" "in" ident(H) := fold_idH H. 159 | Tactic Notation "fold_id" "in" "*" := (in_all fold_idH); fold_id. 160 | 161 | (** Primitives *) 162 | 163 | (** A type synonym for natural numbers used as de Bruijn indices *) 164 | Definition var := nat. 165 | 166 | Definition iterate := fix iterate {A} (f : A -> A) n a := 167 | match n with 168 | | 0 => a 169 | | S n' => f(iterate f n' a) 170 | end. 171 | Arguments iterate {A} f n a : simpl never. 172 | 173 | (** ordinary function composition ... *) 174 | 175 | Definition funcomp {A B C : Type} (f : A -> B) (g : B -> C) x := g(f(x)). 176 | Arguments funcomp {A B C} f g x /. 177 | 178 | (** ... with reversed notation *) 179 | 180 | Declare Scope subst_scope. 181 | Delimit Scope subst_scope with subst. 182 | Open Scope subst_scope. 183 | 184 | Reserved Notation "sigma >> tau" (at level 56, left associativity). 185 | Notation "f >>> g" := (funcomp f g) 186 | (at level 56, left associativity) : subst_scope. 187 | 188 | (** 189 | The cons operation on streams represented as functions from natural numbers 190 | *) 191 | Definition scons {X : Type} (s : X) (sigma : var -> X) (x : var) : X := 192 | match x with S y => sigma y | _ => s end. 193 | Notation "s .: sigma" := (scons s sigma) (at level 55, sigma at level 56, right associativity) : subst_scope. 194 | 195 | (** A test and demonstration of the precedence rules, which effectively declare scons and 196 | funcomp at the same level, with scons being right associative and funcomp being left 197 | associative *) 198 | Local Definition parse_test := fun (f : var -> var) (sigma : var -> list var) => 199 | nil .: nil .: f >>> f >>> nil .: nil .: f >>> f >>> nil .: nil .: sigma. 200 | 201 | (* plus with different simplification behaviour *) 202 | Definition lift (x y : var) : var := plus x y. 203 | Arguments lift x y/. 204 | Notation "( + x )" := (lift x) (format "( + x )"). 205 | 206 | (* 207 | (* 208 | WIP: It is currently not clear what the right primitives for binders with 209 | variable arity should be. The two functions below may be useful. 210 | *) 211 | 212 | (** append a list to a stream *) 213 | Fixpoint sapp {X : Type} (l : list X) (sigma : nat -> X) : nat -> X := 214 | match l with nil => sigma | cons s l' => s .: sapp l' sigma end. 215 | Infix ".++" := sapp (at level 55, right associativity) : subst_scope. 216 | Arguments sapp {_} !l sigma / _. 217 | 218 | (** take a prefix from a stream *) 219 | Fixpoint take {X : Type} n (sigma : nat -> X) : list X := 220 | match n with 0 => nil | S n' => sigma 0 :: take n' ((+1) >>> sigma) end. 221 | *) 222 | 223 | (** Lemmas for working with the above primitives. *) 224 | 225 | Lemma id_comp {A B} (f : A -> B) : id >>> f = f. reflexivity. Qed. 226 | Lemma comp_id {A B} (f : A -> B) : f >>> id = f. reflexivity. Qed. 227 | Lemma compA {A B C D} (f : A -> B) (g : B -> C) (h : C -> D) : 228 | (f >>> g) >>> h = f >>> (g >>> h). 229 | Proof. reflexivity. Qed. 230 | 231 | Section LemmasForFun. 232 | 233 | Context {A B : Type}. 234 | Implicit Types (x : A) (f : var -> A) (g : A -> B) (n m : var). 235 | 236 | Lemma scons_comp x f g : (x .: f) >>> g = (g x) .: f >>> g. 237 | Proof. f_ext; let x := fresh in intros x; now destruct x. Qed. 238 | 239 | Lemma plusSn n m : S n + m = S (n + m). reflexivity. Qed. 240 | Lemma plusnS n m : n + S m = S (n + m). symmetry. apply plus_n_Sm. Qed. 241 | Lemma plusOn n : O + n = n. reflexivity. Qed. 242 | Lemma plusnO n : n + O = n. symmetry. apply plus_n_O. Qed. 243 | Lemma plusA n m k : n + (m + k) = (n + m) + k. apply Nat.add_assoc. Qed. 244 | 245 | Lemma scons_eta f n : f n .: (+S n) >>> f = (+n) >>> f. 246 | Proof. 247 | f_ext; intros [|m]; simpl; [now rewrite plusnO|now rewrite plusnS]. 248 | Qed. 249 | 250 | Lemma lift0 : (+0) = id. reflexivity. Qed. 251 | 252 | Lemma lift_scons x f n : (+S n) >>> (x .: f) = (+n) >>> f. 253 | Proof. reflexivity. Qed. 254 | 255 | Lemma lift_comp n m : (+n) >>> (+m) = (+m+n). 256 | Proof. f_ext; intros x; simpl. now rewrite plusA. Qed. 257 | 258 | Lemma lift_compR n m f : (+n) >>> ((+m) >>> f) = (+m+n) >>> f. 259 | Proof. now rewrite <- lift_comp. Qed. 260 | 261 | End LemmasForFun. 262 | 263 | Lemma lift_eta n : n .: (+S n) = (+ n). 264 | Proof. apply (scons_eta id). Qed. 265 | 266 | (** Automation for the above *) 267 | 268 | Ltac fsimpl := 269 | repeat match goal with 270 | | [|- context[id >>> ?f]] => change (id >>> f) with f 271 | | [|- context[?f >>> id]] => change (f >>> id) with f 272 | | [|- context[(?f >>> ?g) >>> ?h]] => 273 | change ((f >>> g) >>> h) with (f >>> (g >>> h)) 274 | | [|- context[(+0)]] => change (+0) with (@id var) 275 | | [|- context[0 + ?m]] => change (0 + m) with m 276 | | [|- context[?s S]] => change (s S) with (s (+1)) 277 | | [|- context[S ?n + ?m]] => change (S n + m) with (S (n + m)) 278 | | [|- context[(+S ?n) >>> (?x .: ?xr)]] => 279 | change ((+S n) >>> (x .: xr)) with ((+n) >>> xr) 280 | | [|- context[?x .: (+ S ?n) >>> ?f]] => 281 | change x with (f n); rewrite (@scons_eta _ f n) 282 | | _ => progress (rewrite ?scons_comp, ?plusnS, ?plusnO, ?plusA, 283 | ?lift_comp, ?lift_compR, ?lift_eta) 284 | end. 285 | 286 | Ltac fsimplH H := 287 | repeat match typeof H with 288 | | context[id >>> ?f] => change (id >>> f) with f in H 289 | | context[?f >>> id] => change (f >>> id) with f in H 290 | | context[(?f >>> ?g) >>> ?h] => 291 | change ((f >>> g) >>> h) with (f >>> (g >>> h)) in H 292 | | context[(+0)] => change (+0) with (@id var) in H 293 | | context[0 + ?m] => change (0 + m) with m in H 294 | | context[?s S] => change (s S) with (s (+1)) in H 295 | | context[S ?n + ?m] => change (S n + m) with (S (n + m)) in H 296 | | context[(+S ?n) >>> (?x .: ?xr)] => 297 | change ((+S n) >>> (x .: xr)) with ((+n) >>> xr) in H 298 | | context[?x .: (+ S ?n) >>> ?f] => 299 | change x with (f n) in H; rewrite (@scons_eta _ f n) in H 300 | | _ => progress (rewrite ?scons_comp, ?plusnS, ?plusnO, ?plusA, 301 | ?lift_comp, ?lift_compR, ?lift_eta in H) 302 | end. 303 | 304 | Tactic Notation "fsimpl" "in" ident(H) := fsimplH H. 305 | Tactic Notation "fsimpl" "in" "*" := (in_all fsimplH); fsimpl. 306 | 307 | (** Misc Lemmas *) 308 | 309 | Lemma iterate_S {A} (f : A -> A) n a : iterate f (S n) a = f (iterate f n a). 310 | Proof. reflexivity. Qed. 311 | 312 | Lemma iterate_0 {A} (f : A -> A) a : iterate f 0 a = a. 313 | Proof. reflexivity. Qed. 314 | 315 | Lemma iterate_Sr {A} (f : A -> A) n a : iterate f (S n) a = iterate f n (f a). 316 | Proof. 317 | revert a; induction n. reflexivity. intros a. 318 | rewrite !iterate_S, <- IHn. reflexivity. 319 | Qed. 320 | 321 | Lemma equal_f {X Y} {f g : X -> Y} a : f = g -> f a = g a. 322 | Proof. intros. now subst. Qed. 323 | 324 | (* Local Variables: *) 325 | (* coq-load-path: (("." "Autosubst")) *) 326 | (* End: *) 327 | -------------------------------------------------------------------------------- /theories/Autosubst_Classes.v: -------------------------------------------------------------------------------- 1 | 2 | (** Type classes and notations for substitutions. *) 3 | Require Import Autosubst_Basics Autosubst_MMap. 4 | 5 | (** 6 | [_bind] is used to annotate the position of binders in inductive 7 | definitions of syntactic objects 8 | *) 9 | Definition _bind (T1 : Type) (T2 : Type) (n : nat) := T2. 10 | Arguments _bind / T1 T2 n. 11 | 12 | Declare Scope bind_scope. 13 | Open Scope bind_scope. 14 | 15 | Notation "{ 'bind' n 'of' T1 'in' T2 }" := 16 | (_bind T1 T2 n) (at level 0, 17 | format "{ 'bind' n 'of' T1 'in' T2 }") : bind_scope. 18 | 19 | Notation "{ 'bind' n 'of' T }" := 20 | (_bind T T n) (at level 0, 21 | format "{ 'bind' n 'of' T }") : bind_scope. 22 | 23 | Notation "{ 'bind' T1 'in' T2 }" := 24 | (_bind T1 T2 1) (at level 0, 25 | format "{ 'bind' T1 'in' T2 }") : bind_scope. 26 | 27 | Notation "{ 'bind' T }" := 28 | (_bind T T 1) (at level 0, 29 | format "{ 'bind' T }") : bind_scope. 30 | 31 | (** 32 | Classes for the substitution operations. 33 | 34 | We use singleton classes to obtain the right reduction behaviour with simpl. 35 | This relies on the feature of simpl which folds fix-bodies. 36 | *) 37 | 38 | Class Ids (term : Type) := ids : var -> term. 39 | Class Rename (term : Type) := rename : (var -> var) -> term -> term. 40 | Class Subst (term : Type) := subst : (var -> term) -> term -> term. 41 | Class HSubst (inner outer : Type) := hsubst : (var -> inner) -> outer -> outer. 42 | 43 | Arguments ids {_ _} x : simpl never. 44 | Arguments rename {_ _} xi !s /. 45 | Arguments subst {_ _} sigma !s /. 46 | Arguments hsubst {_ _ _} sigma !s / . 47 | 48 | Definition scomp {A} `{Subst A} (f : var -> A) (g : var -> A) : var -> A 49 | := f >>> subst g. 50 | Arguments scomp {A _} f g x /. 51 | 52 | Notation "sigma >> tau" := (scomp sigma tau) 53 | (at level 56, left associativity) : subst_scope. 54 | 55 | Notation "s .[ sigma ]" := (subst sigma s) 56 | (at level 2, sigma at level 200, left associativity, 57 | format "s .[ sigma ]" ) : subst_scope. 58 | Notation "s .[ t /]" := (subst (t .: ids) s) 59 | (at level 2, t at level 200, left associativity, 60 | format "s .[ t /]") : subst_scope. 61 | Notation "s .[ t1 , t2 , .. , tn /]" := 62 | (subst (scons t1 (scons t2 .. (scons tn ids) .. )) s) 63 | (at level 2, left associativity, 64 | format "s '[ ' .[ t1 , '/' t2 , '/' .. , '/' tn /] ']'") : subst_scope. 65 | 66 | Notation "s ..[ sigma ]" := (mmap (subst sigma) s) 67 | (at level 2, sigma at level 200, left associativity, 68 | format "s ..[ sigma ]" ) : subst_scope. 69 | Notation "s ..[ t /]" := (mmap (subst (t .: ids)) s) 70 | (at level 2, t at level 200, left associativity, 71 | format "s ..[ t /]") : subst_scope. 72 | Notation "s ..[ t1 , t2 , .. , tn /]" := 73 | (mmap (subst (scons t1 (scons t2 .. (scons tn ids) .. ))) s) 74 | (at level 2, left associativity, 75 | format "s '[ ' ..[ t1 , '/' t2 , '/' .. , '/' tn /] ']'") : subst_scope. 76 | 77 | Definition hcomp {A B} `{HSubst A B} (f : var -> B) (g : var -> A) : var -> B 78 | := f >>> hsubst g. 79 | Arguments hcomp {A B _} f g x /. 80 | 81 | Notation "sigma >>| tau" := (hcomp sigma tau) 82 | (at level 56, left associativity) : subst_scope. 83 | 84 | Notation "s .|[ sigma ]" := (hsubst sigma s) 85 | (at level 2, sigma at level 200, left associativity, 86 | format "s .|[ sigma ]" ) : subst_scope. 87 | Notation "s .|[ t /]" := (hsubst (t .: ids) s) 88 | (at level 2, t at level 200, left associativity, 89 | format "s .|[ t /]") : subst_scope. 90 | Notation "s .|[ t1 , t2 , .. , tn /]" := 91 | (hsubst (scons t1 (scons t2 .. (scons tn ids) .. )) s) 92 | (at level 2, left associativity, 93 | format "s '[ ' .|[ t1 , '/' t2 , '/' .. , '/' tn /] ']'") : subst_scope. 94 | 95 | Notation "s ..|[ sigma ]" := (mmap (hsubst sigma) s) 96 | (at level 2, sigma at level 200, left associativity, 97 | format "s ..|[ sigma ]" ) : subst_scope. 98 | Notation "s ..|[ t /]" := (mmap (hsubst (t .: ids)) s) 99 | (at level 2, t at level 200, left associativity, 100 | format "s ..|[ t /]") : subst_scope. 101 | Notation "s ..|[ t1 , t2 , .. , tn /]" := 102 | (mmap (hsubst (scons t1 (scons t2 .. (scons tn ids) .. ))) s) 103 | (at level 2, left associativity, 104 | format "s '[ ' ..|[ t1 , '/' t2 , '/' .. , '/' tn /] ']'") : subst_scope. 105 | 106 | (** Coercion from renamings to substitutions. *) 107 | 108 | Definition ren {T} `{Ids T} (xi : var -> var) : var -> T := xi >>> ids. 109 | Arguments ren {T _} xi x /. 110 | 111 | (** Modify a substitution when going below a binder. *) 112 | 113 | Definition up {T} `{Ids T} `{Rename T} (sigma : var -> T) : var -> T := 114 | ids 0 .: sigma >>> rename (+1). 115 | Arguments up {T _ _} sigma x : simpl never. 116 | 117 | Notation upn := (iterate up). 118 | 119 | Definition upren (xi : var -> var) : (var -> var) := 0 .: xi >>> S. 120 | 121 | (** the essential substitution lemmas *) 122 | 123 | Class SubstLemmas (term : Type) {Ids_term : Ids term} 124 | {Rename_term : Rename term} {Subst_term : Subst term} := 125 | { 126 | rename_subst (xi : var -> var) (s : term) : 127 | rename xi s = s.[ren xi]; 128 | subst_id (s : term) : 129 | s.[ids] = s; 130 | id_subst (sigma : var -> term) (x : var) : 131 | (ids x).[sigma] = sigma x; 132 | subst_comp (sigma tau : var -> term) (s : term) : 133 | s.[sigma].[tau] = s.[sigma >> tau] 134 | }. 135 | 136 | Class HSubstLemmas (inner outer : Type) 137 | {Ids_inner : Ids inner} {Subst_inner : Subst inner} 138 | {Ids_outer : Ids outer} 139 | {HSubst_inner_outer : HSubst inner outer} := 140 | { 141 | hsubst_id (s : outer) : 142 | s.|[ids : var -> inner] = s; 143 | id_hsubst (theta : var -> inner) (x : var) : 144 | (ids x).|[theta] = (ids x); 145 | hsubst_comp (theta eta : var -> inner) (s : outer) : 146 | s.|[theta].|[eta] = s.|[theta >> eta] 147 | }. 148 | 149 | Class SubstHSubstComp (inner outer : Type) 150 | {Subst_outer : Subst outer} 151 | {HSubst_inner_outer : HSubst inner outer} := 152 | 153 | subst_hsubst_comp (sigma : var -> outer) (tau : var -> inner) (s : outer) : 154 | s.[sigma].|[tau] = s.|[tau].[sigma >>| tau]. 155 | 156 | Class HSubstHSubstComp (inner1 inner2 outer : Type) 157 | {HSubst_inner1_outer : HSubst inner1 outer} 158 | {HSubst_inner2_outer : HSubst inner2 outer} 159 | {HSubst_inner2_inner1 : HSubst inner2 inner1} := 160 | 161 | hsubst_hsubst_comp (sigma : var -> inner1) (tau : var -> inner2) (s : outer) : 162 | s.|[sigma].|[tau] = s.|[tau].|[sigma >>| tau]. 163 | 164 | Class HSubstHSubstInd (inner1 inner2 outer : Type) 165 | {HSubst_inner1_outer : HSubst inner1 outer} 166 | {HSubst_inner2_outer : HSubst inner2 outer} := 167 | 168 | hsubst_hsubst_ind (sigma : var -> inner1) (tau : var -> inner2) (s : outer) : 169 | s.|[sigma].|[tau] = s.|[tau].|[sigma]. 170 | 171 | (* Local Variables: *) 172 | (* coq-load-path: (("." "Autosubst")) *) 173 | (* End: *) 174 | -------------------------------------------------------------------------------- /theories/Autosubst_Derive.v: -------------------------------------------------------------------------------- 1 | (** Tactics to generate substitution operations and show the basic lemmas. *) 2 | Require Import Autosubst_Basics Autosubst_MMap Autosubst_Classes Autosubst_Tactics Autosubst_Lemmas. 3 | 4 | Ltac app_var := match goal with [ |- var] => assumption end. 5 | 6 | Ltac derive_Ids := intro; solve 7 | [ constructor 1; [app_var] | constructor 2; [app_var] 8 | | constructor 3; [app_var] | constructor 4; [app_var] 9 | | constructor 5; [app_var] | constructor 6; [app_var] 10 | | constructor 7; [app_var] | constructor 8; [app_var] 11 | | constructor 9; [app_var] | constructor 10; [app_var] 12 | | constructor 11; [app_var] | constructor 12; [app_var] 13 | | constructor 13; [app_var] | constructor 14; [app_var] 14 | | constructor 15; [app_var] | constructor 16; [app_var] 15 | | constructor 17; [app_var] | constructor 18; [app_var] 16 | | constructor 19; [app_var] | constructor 20; [app_var]]. 17 | Global Hint Extern 0 (Ids _) => derive_Ids : derive. 18 | 19 | Ltac derive_Rename := 20 | let inst := fresh "dummy" in (* hack/workaround *) 21 | match goal with [ |- Rename ?term ] => 22 | hnf; fix inst 2; change _ with (Rename term) in inst; 23 | intros xi s; change (annot term s); destruct s; 24 | match goal with 25 | | [ |- annot _ ?t ] => 26 | let rec map s := 27 | (match s with 28 | | ?s1 ?s2 => 29 | let s1 := map s1 in 30 | let T := typeof s2 in 31 | let s2 := 32 | match T with 33 | | term => constr:(rename xi s2) 34 | | var => constr:(xi s2) 35 | | _bind term _ 1 => constr:(rename (upren xi) s2) 36 | | _bind term _ ?n => 37 | constr:(rename (iterate upren n xi) s2) 38 | | context[_bind term _ 1] => 39 | constr:(mmap (rename (upren xi)) s2) 40 | | context[_bind term _ ?n] => 41 | constr:(mmap (rename (iterate upren n xi)) s2) 42 | | context[term] => constr:(mmap (rename xi) s2) 43 | | _ => s2 44 | end in 45 | constr:(s1 s2) 46 | | _ => s 47 | end) in 48 | let t := map t in exact t 49 | end 50 | end. 51 | Global Hint Extern 0 (Rename _) => derive_Rename : derive. 52 | 53 | Ltac has_var s := 54 | match s with 55 | | ?s1 ?s2 => 56 | match has_var s1 with 57 | | Some ?x => constr:(Some x) 58 | | _ => 59 | match typeof s2 with 60 | | var => constr:(Some s2) 61 | | _ => None 62 | end 63 | end 64 | | _ => None 65 | end. 66 | 67 | Ltac derive_Subst := 68 | let inst := fresh "dummy" in (* hack/workaround *) 69 | match goal with [ |- Subst ?term ] => 70 | require_instance (Rename term); 71 | hnf; fix inst 2; change _ with (Subst term) in inst; 72 | intros sigma s; change (annot term s); destruct s; 73 | match goal with 74 | | [ |- annot _ ?t ] => 75 | let rec map s := 76 | (match s with 77 | | ?s1 ?s2 => 78 | let s1 := map s1 in 79 | let T := typeof s2 in 80 | let s2 := 81 | match T with 82 | | term => constr:(subst sigma s2) 83 | | _bind term _ 1 => constr:(subst (up sigma) s2) 84 | | _bind term _ ?n => constr:(subst (upn n sigma) s2) 85 | | _bind ?hterm _ ?n => 86 | constr:(subst (sigma >>| (ren(+n) : var -> hterm)) s2) 87 | | context[_bind term _ 1] => 88 | constr:(mmap (subst (up sigma)) s2) 89 | | context[_bind term _ ?n] => 90 | constr:(mmap (subst (upn n sigma)) s2) 91 | | context[_bind ?hterm _ ?n] => 92 | constr:(mmap 93 | (subst (sigma >>| (ren(+n) : var -> hterm))) 94 | s2) 95 | | context[term] => constr:(mmap (subst sigma) s2) 96 | | _ => s2 97 | end in 98 | constr:(s1 s2) 99 | | _ => s 100 | end) in 101 | match has_var t with 102 | | Some ?x => exact (sigma x) 103 | | _ => let t := map t in exact t 104 | end 105 | end 106 | end. 107 | Global Hint Extern 0 (Subst _) => derive_Subst : derive. 108 | 109 | Ltac derive_HSubst := 110 | let inst := fresh "dummy" in (* hack/workaround *) 111 | match goal with [ |- HSubst ?inner ?outer ] => 112 | require_instance (Subst inner); 113 | hnf; fix inst 2; change _ with (HSubst inner outer) in inst; 114 | intros sigma s; change (annot outer s); destruct s; 115 | match goal with 116 | | [ |- annot _ ?t ] => 117 | let rec map s := 118 | (match s with 119 | | ?s1 ?s2 => 120 | let s1 := map s1 in 121 | let T := typeof s2 in 122 | let s2 := 123 | match T with 124 | | inner => constr:(subst sigma s2) 125 | | outer => constr:(hsubst sigma s2) 126 | | _bind inner outer 1 => constr:(hsubst (up sigma) s2) 127 | | _bind inner inner 1 => constr:(subst (up sigma) s2) 128 | | _bind inner outer ?n => 129 | constr:(hsubst (upn n sigma) s2) 130 | | _bind inner inner ?n => 131 | constr:(subst (upn n sigma) s2) 132 | | _bind _ outer _ => constr:(hsubst sigma s2) 133 | | _bind _ inner _ => constr:(subst sigma s2) 134 | | context[_bind inner outer 1] => 135 | constr:(mmap (hsubst (up sigma)) s2) 136 | | context[_bind inner inner 1] => 137 | constr:(mmap (subst (up sigma)) s2) 138 | | context[_bind inner outer ?n] => 139 | constr:(mmap (hsubst (upn n sigma)) s2) 140 | | context[_bind inner inner ?n] => 141 | constr:(mmap (subst (upn n sigma)) s2) 142 | | context[_bind _ outer _] => 143 | constr:(mmap (hsubst sigma) s2) 144 | | context[_bind _ inner _] => 145 | constr:(mmap (subst sigma) s2) 146 | | context[inner] => constr:(mmap (subst sigma) s2) 147 | | context[outer] => constr:(mmap (hsubst sigma) s2) 148 | | _ => s2 149 | end in 150 | constr:(s1 s2) 151 | | _ => s 152 | end) in 153 | let t := map t in exact t 154 | end 155 | end. 156 | Global Hint Extern 0 (HSubst _ _) => derive_HSubst : derive. 157 | 158 | Lemma mmap_id_ext {A B} {inst : MMap A B} `{@MMapLemmas A B inst} 159 | `{@MMapExt A B inst} (f : A -> A) (b : B) : 160 | (forall x, f x = x) -> mmap f b = b. 161 | Proof. intros E. rewrite (mmap_ext E). apply mmap_id. Defined. 162 | 163 | Lemma iter_fp {A} (f : A -> A) x : 164 | f x = x -> forall n, iterate f n x = x. 165 | Proof. 166 | intros E. induction n. reflexivity. now rewrite iterate_S, IHn. 167 | Qed. 168 | 169 | Lemma iter_param {A B} (f : A -> A) (g : B -> B) (h : A -> B) : 170 | (forall x, g (h x) = h (f x)) -> 171 | (forall x n, iterate g n (h x) = h (iterate f n x)). 172 | Proof. 173 | intros E x n. induction n. reflexivity. now rewrite !iterate_S, IHn, E. 174 | Qed. 175 | 176 | Section InternalLemmas. 177 | 178 | Context {term : Type} {Ids_term : Ids term} 179 | {Rename_term : Rename term} {Subst_term : Subst term}. 180 | 181 | Lemma up_upren_internal : 182 | (forall xi x, rename xi (ids x) = ids (xi x)) -> 183 | (forall xi : var -> var, up (ren xi) = ren (upren xi)). 184 | Proof. 185 | intros E xi. f_ext. intros [|x]. reflexivity. apply E. 186 | Qed. 187 | 188 | Lemma up_upren_n_internal : 189 | (forall xi, up (ren xi) = ren (upren xi)) -> 190 | (forall xi n, upn n (ren xi) = ren (iterate upren n xi)). 191 | Proof. 192 | apply (iter_param upren up (fun x => ren x)). 193 | Qed. 194 | 195 | Lemma up_id_internal : 196 | (forall xi x, rename xi (ids x) = ids (xi x)) -> 197 | up ids = ids :> (var -> term). 198 | Proof. 199 | intros h. f_ext. intros [|x]. reflexivity. apply h. 200 | Qed. 201 | 202 | Lemma up_id_n_internal : 203 | up ids = ids -> (forall n, upn n ids = ids). 204 | Proof. 205 | apply iter_fp. 206 | Qed. 207 | 208 | Lemma up_comp_ren_subst xi (sigma : var -> term) : 209 | up (xi >>> sigma) = upren xi >>> up sigma. 210 | Proof. f_ext. intros [|x]; reflexivity. Qed. 211 | 212 | Lemma up_comp_ren_subst_n xi (sigma : var -> term) n : 213 | upn n (xi >>> sigma) = iterate upren n xi >>> upn n sigma. 214 | Proof. 215 | induction n. reflexivity. rewrite !iterate_S, IHn. apply up_comp_ren_subst. 216 | Qed. 217 | 218 | Lemma up_comp_subst_ren_internal : 219 | (forall xi x, rename xi (ids x) = ids (xi x)) -> 220 | (forall xi s, rename xi s = s.[ren xi]) -> 221 | (forall xi sigma s, (rename xi s).[sigma] = s.[xi >>> sigma]) -> 222 | (forall sigma xi, up (sigma >>> rename xi) = up sigma >>> rename (upren xi)). 223 | Proof. 224 | intros h1 h2 h3 sigma xi. f_ext. intros [|x]. unfold up; simpl. 225 | now rewrite h1. unfold up. simpl. now rewrite h2, h3, h2, h3. 226 | Qed. 227 | 228 | Lemma up_comp_subst_ren_n_internal : 229 | (forall sigma xi, up (sigma >>> rename xi) = up sigma >>> rename (upren xi))-> 230 | (forall (sigma : var -> term) xi n, 231 | upn n (sigma >>> rename xi) = upn n sigma >>> rename (iterate upren n xi)). 232 | Proof. 233 | intros E sigma xi n. induction n. reflexivity. rewrite !iterate_S, IHn. 234 | apply E. 235 | Qed. 236 | 237 | Lemma up_comp_internal : 238 | (forall sigma x, (ids x).[sigma] = sigma x) -> 239 | (forall xi sigma s, (rename xi s).[sigma] = s.[xi >>> sigma]) -> 240 | (forall sigma xi s, rename xi s.[sigma] = s.[sigma >>> rename xi]) -> 241 | (forall sigma tau, up (sigma >> tau) = up sigma >> up tau). 242 | Proof. 243 | intros h1 h2 h3 sigma tau. f_ext. intros [|x]; unfold up; simpl. 244 | now rewrite h1. now rewrite h2, h3. 245 | Qed. 246 | 247 | Lemma up_comp_n_internal : 248 | (forall sigma tau, up (sigma >> tau) = up sigma >> up tau) -> 249 | (forall sigma tau n, 250 | upn n (sigma >> tau) = upn n sigma >> upn n tau). 251 | Proof. 252 | intros h sigam tau n. induction n. reflexivity. rewrite !iterate_S, IHn. 253 | apply h. 254 | Qed. 255 | 256 | End InternalLemmas. 257 | 258 | Section InternalLemmasHSubst. 259 | 260 | Context {inner : Type} {Ids_inner : Ids inner} 261 | {Rename_inner : Rename inner} {Subst_inner : Subst inner} 262 | {SubstLemmas_inner : SubstLemmas inner}. 263 | 264 | Context {outer : Type} {Ids_outer : Ids outer} 265 | {Rename_outer : Rename outer} {HSubst_inst : HSubst inner outer} 266 | {HSubstLemmas_inst : HSubstLemmas inner outer}. 267 | 268 | Implicit Types (sigma : var -> outer) (theta : var -> inner) (s : outer). 269 | 270 | Lemma up_hcomp_internal : 271 | (forall xi theta s, rename xi s.|[theta] = (rename xi s).|[theta]) -> 272 | (forall sigma theta, up (sigma >>| theta) = up sigma >>| theta). 273 | Proof. 274 | intros E sigma theta. f_ext. intros [|x]; unfold up; simpl. 275 | now rewrite id_hsubst. apply E. 276 | Qed. 277 | 278 | Lemma up_hcomp_n_internal : 279 | (forall sigma theta, up (sigma >>| theta) = up sigma >>| theta) -> 280 | forall sigma theta n, upn n (sigma >>| theta) = upn n sigma >>| theta. 281 | Proof. 282 | intros E sigma theta n. induction n. reflexivity. 283 | rewrite !iterate_S, IHn. apply E. 284 | Qed. 285 | 286 | Lemma hcomp_lift_n_internal sigma theta n : 287 | (sigma >>| theta) >>| ren (+n) = (sigma >>| ren (+n)) >>| upn n theta. 288 | Proof. 289 | f_ext. intros x; simpl. now rewrite !hsubst_comp, up_liftn. 290 | Qed. 291 | 292 | Lemma hcomp_lift_internal sigma theta : 293 | (sigma >>| theta) >>| ren (+1) = (sigma >>| ren (+1)) >>| up theta. 294 | Proof. apply hcomp_lift_n_internal. Qed. 295 | 296 | Context {Subst_outer : Subst outer} 297 | {SubstHSubstComp_inst : SubstHSubstComp inner outer}. 298 | 299 | Lemma hcomp_ren_internal sigma xi theta : 300 | (forall xi s, rename xi s = s.[ren xi]) -> 301 | (sigma >>> rename xi) >>| theta = (sigma >>| theta) >>> rename xi. 302 | Proof. 303 | intros E. f_ext. intros x. simpl. rewrite !E, subst_hsubst_comp. 304 | f_equal. f_ext. intros y. simpl. now rewrite id_hsubst. 305 | Qed. 306 | 307 | Lemma hcomp_dist_internal sigma tau theta : 308 | (sigma >> tau) >>| theta = (sigma >>| theta) >> (tau >>| theta). 309 | Proof. 310 | f_ext. intros x. simpl. apply subst_hsubst_comp. 311 | Qed. 312 | 313 | End InternalLemmasHSubst. 314 | 315 | Ltac derive_SubstLemmas := 316 | let ih := fresh "dummy" in (* hack/workaround *) 317 | match goal with 318 | [ |- @SubstLemmas ?term ?Ids_term ?Rename_term ?Subst_term] => 319 | let rename := constr:(@rename term Rename_term) in 320 | let subst := constr:(@subst term Subst_term) in 321 | let ids := constr:(@ids term Ids_term) in 322 | let up := constr:(@up term Ids_term Rename_term) in 323 | 324 | (* rename subst *) 325 | 326 | assert (rename_subst : 327 | forall xi (s : term), rename xi s = subst (ren xi) s) by ( 328 | assert (up_upren : 329 | forall xi, up (ren xi) = ren (upren xi)) by 330 | (apply up_upren_internal; reflexivity); 331 | assert (up_upren_n : 332 | forall xi n, upn n (ren xi) = ren (iterate upren n xi)) by 333 | (apply up_upren_n_internal, up_upren); 334 | fix ih 2; intros xi s; destruct s; try reflexivity; simpl; f_equal; 335 | try apply mmap_ext; intros; rewrite ?up_upren, ?up_upren_n; apply ih); 336 | 337 | (* subst id *) 338 | 339 | assert (subst_id : forall (s : term), subst ids s = id s) by ( 340 | assert (up_id : up ids = ids) by 341 | (apply up_id_internal; reflexivity); 342 | assert (up_id_n : forall n, upn n ids = ids) by 343 | (apply up_id_n_internal, up_id); 344 | fix ih 1; intros s; destruct s; simpl; f_equal; try reflexivity; 345 | rewrite ?up_id, ?up_id_n; try apply mmap_id_ext; intros; apply ih); 346 | 347 | (* subst comp *) 348 | 349 | assert (ren_subst_comp : 350 | forall xi sigma (s : term), (rename xi s).[sigma] = s.[xi >>> sigma]) by( 351 | fix ih 3; intros xi sigma s; destruct s; try reflexivity; simpl; f_equal; 352 | rewrite ?up_comp_ren_subst, ?up_comp_ren_subst_n, ?mmap_comp; 353 | try apply mmap_ext; intros; apply ih); 354 | 355 | assert (subst_ren_comp : forall sigma xi (s : term), 356 | rename xi s.[sigma] = s.[sigma >>> rename xi]) by ( 357 | assert (up_comp_subst_ren : 358 | forall sigma xi, up (sigma >>> rename xi) = up sigma >>>rename (upren xi)) 359 | by (apply up_comp_subst_ren_internal; [reflexivity| 360 | apply rename_subst| apply ren_subst_comp]); 361 | assert (up_comp_subst_ren_n : 362 | forall sigma xi n, upn n (sigma >>> rename xi) = upn n sigma >>> rename (iterate upren n xi)) 363 | by (apply up_comp_subst_ren_n_internal; apply up_comp_subst_ren); 364 | fix ih 3; intros sigma xi s; destruct s; try reflexivity; simpl; 365 | f_equal; rewrite ?up_comp_subst_ren, ?up_comp_subst_ren_n, ?mmap_comp; 366 | try (rewrite hcomp_ren_internal; [|apply rename_subst]); 367 | try apply mmap_ext; intros; apply ih); 368 | 369 | assert (subst_comp : 370 | forall sigma tau (s : term), s.[sigma].[tau] = s.[sigma >> tau]) by ( 371 | assert (up_comp : forall (sigma tau : var -> term), up (sigma >> tau) = up sigma >> up tau) 372 | by (apply up_comp_internal; [reflexivity|apply ren_subst_comp|apply subst_ren_comp]); 373 | assert (up_comp_n : forall sigma tau n, upn n (sigma >> tau) = upn n sigma >> upn n tau) 374 | by (apply up_comp_n_internal; apply up_comp); 375 | fix ih 3; intros sigma tau s; destruct s; try reflexivity; simpl; f_equal; 376 | rewrite ?up_comp, ?up_comp_n, ?mmap_comp, ?hcomp_dist_internal; 377 | try apply mmap_ext; intros; apply ih); 378 | 379 | constructor; hnf; 380 | [apply rename_subst|apply subst_id|reflexivity|apply subst_comp] 381 | end. 382 | Global Hint Extern 0 (SubstLemmas _) => derive_SubstLemmas : derive. 383 | 384 | Ltac derive_HSubstLemmas := 385 | let ih := fresh "dummy" in (* hack/workaround *) 386 | match goal with [|- HSubstLemmas ?inner ?outer ] => 387 | let ids := constr:(ids : var -> inner) in 388 | 389 | assert (hsubst_id : forall (s : outer), s.|[ids] = s) by ( 390 | fix ih 1; intros s; destruct s; try reflexivity; simpl; f_equal; 391 | rewrite ?up_id, ?up_id_n; try apply mmap_id_ext; intros; 392 | (apply subst_id || apply ih) 393 | ); 394 | 395 | assert (hsubst_comp : forall (theta eta : var -> inner) (s : outer), 396 | s.|[theta].|[eta] = s.|[theta >> eta]) 397 | by ( 398 | fix ih 3; intros sigma tau s; destruct s; try reflexivity; simpl; f_equal; 399 | rewrite <- ?up_comp, <- ?up_comp_n, ?mmap_comp; try apply mmap_ext; intros; 400 | (apply subst_comp || apply ih) 401 | ); 402 | 403 | constructor; hnf; [exact hsubst_id|reflexivity|exact hsubst_comp] 404 | end. 405 | Global Hint Extern 0 (HSubstLemmas _ _) => derive_HSubstLemmas : derive. 406 | 407 | Ltac derive_SubstHSubstComp := 408 | let ih := fresh "dummy" in (* hack/workaround *) 409 | match goal with [|- SubstHSubstComp ?inner ?outer ] => hnf; 410 | 411 | assert (ren_hsubst_comp : forall xi (theta : var -> inner) (s : outer), 412 | rename xi s.|[theta] = (rename xi s).|[theta] 413 | ) by ( 414 | fix ih 3; intros xi theta s; destruct s; try reflexivity; simpl; f_equal; 415 | rewrite ?mmap_comp; try apply mmap_ext; intros; simpl; apply ih 416 | ); 417 | 418 | assert (up_hcomp : forall (sigma : var -> outer) (theta : var -> inner), 419 | up (sigma >>| theta) = up sigma >>| theta 420 | ) by ( 421 | apply up_hcomp_internal; apply ren_hsubst_comp 422 | ); 423 | 424 | assert (up_hcomp_n : forall (sigma : var -> outer) (theta : var -> inner) n, 425 | upn n (sigma >>| theta) = upn n sigma >>| theta 426 | ) by ( 427 | apply up_hcomp_n_internal; apply up_hcomp 428 | ); 429 | 430 | fix ih 3; intros sigma tau s; destruct s; try reflexivity; simpl; f_equal; 431 | rewrite ?up_hcomp, ?up_hcomp_n, ?hcomp_lift_n_internal, ?mmap_comp; 432 | try apply mmap_ext; intros; apply ih 433 | end. 434 | Global Hint Extern 0 (SubstHSubstComp _ _) => derive_SubstHSubstComp : derive. 435 | 436 | (* Local Variables: *) 437 | (* coq-load-path: (("." "Autosubst")) *) 438 | (* End: *) 439 | -------------------------------------------------------------------------------- /theories/Autosubst_Lemmas.v: -------------------------------------------------------------------------------- 1 | (** Some useful lemmas about substitutions. *) 2 | Require Import Autosubst_Basics Autosubst_MMap Autosubst_Classes Autosubst_Tactics. 3 | 4 | Section SubstLemmas. 5 | 6 | Context {term : Type} {Ids_term : Ids term} 7 | {Rename_term : Rename term} {Subst_term : Subst term} 8 | {SubstLemmas_term : SubstLemmas term}. 9 | 10 | Lemma up_id : up ids = ids. 11 | Proof. autosubst. Qed. 12 | 13 | Lemma up_id_n n : upn n ids = ids. 14 | Proof. induction n; [reflexivity|rewrite !iterate_S, IHn]. exact up_id. Qed. 15 | 16 | Lemma lift0 : ren (+0) = ids. autosubst. Qed. 17 | 18 | Lemma up_lift1 sigma : ren (+1) >> up sigma = sigma >> ren (+1). 19 | Proof. autosubst. Qed. 20 | 21 | Lemma up_liftn sigma n : ren (+n) >> upn n sigma = sigma >> ren (+n). 22 | Proof. 23 | f_ext. intros x. simpl. rewrite id_subst. induction n. 24 | - autosubst. 25 | - rewrite !iterate_S, upE. simpl. rewrite IHn. autosubst. 26 | Qed. 27 | 28 | Lemma up_comp sigma tau : up sigma >> up tau = up (sigma >> tau). 29 | Proof. autosubst. Qed. 30 | 31 | Lemma up_comp_n sigma tau n : 32 | upn n sigma >> upn n tau = upn n (sigma >> tau). 33 | Proof. induction n; [reflexivity|now rewrite !iterate_S, <- IHn, up_comp]. Qed. 34 | 35 | Lemma ren_uncomp A xi zeta : A.[ren (xi >>> zeta)] = A.[ren xi].[ren zeta]. 36 | Proof. autosubst. Qed. 37 | 38 | Lemma renS s n : s.[ren (+S n)] = s.[ren (+n)].[ren (+1)]. 39 | Proof. autosubst. Qed. 40 | 41 | Lemma lift_inj (A B : term) : A.[ren(+1)] = B.[ren(+1)] -> A = B. 42 | Proof. 43 | intros H. apply (f_equal (subst (ren pred))) in H. asimpl in H. 44 | unfold funcomp, lift in H. now asimpl in H. 45 | Qed. 46 | 47 | Lemma lift_injn (A B : term) n : A.[ren(+n)] = B.[ren(+n)] -> A = B. 48 | Proof. 49 | induction n. autosubst. rewrite (@renS A), (@renS B). 50 | intros H. apply lift_inj in H. auto. 51 | Qed. 52 | 53 | End SubstLemmas. 54 | 55 | (* Local Variables: *) 56 | (* coq-load-path: (("." "Autosubst")) *) 57 | (* End: *) 58 | -------------------------------------------------------------------------------- /theories/Autosubst_MMap.v: -------------------------------------------------------------------------------- 1 | (** 2 | Apply a function to all instances of a type A occuring in a type B. 3 | This is used to implement term structures with containers, e.g. 4 | 5 | Inductive term := C (xs : list term) 6 | 7 | By default we provide mmap instances for option, list, pair and 8 | the codomain of a function. For additional inductive types, there is 9 | a derive tactic to generate new mmap instances. 10 | *) 11 | Require Import Autosubst_Basics. 12 | 13 | Class MMap (A B: Type) := mmap : (A -> A) -> B -> B. 14 | Arguments mmap {A B _} f !s /. 15 | 16 | (** 17 | Extensionality for mmap. This Lemma is uninteresting, as it is implied by 18 | functional extensionality. However, instances of this class should be 19 | transparent and take the proof of [[forall t, f t = gt]] as a non-recursive 20 | argument. This is sufficient to allow the fixpoint checker to lift proofs 21 | over mmap. 22 | *) 23 | Class MMapExt (A B : Type) `{MMap A B} := 24 | mmap_ext : forall f g, 25 | (forall t, f t = g t) -> forall s, mmap f s = mmap g s. 26 | Arguments mmap_ext {A B H' _ f g} H s : rename. (* JK-TODO: check how this affects existing code? *) 27 | 28 | Class MMapLemmas (A B : Type) `{MMap A B} := { 29 | mmap_id x : mmap id x = x; 30 | mmap_comp f g x : mmap f (mmap g x) = mmap (g >>> f) x 31 | }. 32 | 33 | (** MMap Lemmas *) 34 | 35 | Section LemmasForMMap. 36 | 37 | Context {A B : Type}. 38 | Context {MMap_Inst : MMap A B} {MMapLemmas_Inst : MMapLemmas A B}. 39 | 40 | Lemma mmap_idX : mmap id = id. 41 | Proof. f_ext. exact mmap_id. Qed. 42 | 43 | Lemma mmap_compX f g : mmap f >>> mmap g = mmap (f >>> g). 44 | Proof. f_ext. apply mmap_comp. Qed. 45 | 46 | Lemma mmap_compR {C} f g (h : _ -> C) : 47 | mmap f >>> mmap g >>> h = mmap (f >>> g) >>> h. 48 | Proof. now rewrite <- mmap_compX. Qed. 49 | 50 | End LemmasForMMap. 51 | 52 | (** Identity Instance *) 53 | 54 | Section MMapId. 55 | Context {A : Type}. 56 | Global Instance MMap_refl : MMap A A := id. 57 | Global Instance MMapLemmas_refl : MMapLemmas A A. now constructor. Qed. 58 | Global Instance MMapExt_refl : MMapExt A A. hnf. tauto. Defined. 59 | End MMapId. 60 | 61 | Arguments MMap_refl _ _ f /. 62 | 63 | Lemma mmap_id_instE {A} f : @mmap _ _ (@MMap_refl A) f = f. reflexivity. Qed. 64 | 65 | 66 | (** Constant Instance: mmap f x just ignores f and leaves x unchanged. 67 | This instance has low priority so that it is just used if there is 68 | no alternative. 69 | *) 70 | 71 | Section MMapConst. 72 | Context {A B: Type}. 73 | Global Instance MMap_const : MMap A B | 100 := fun _ => id. 74 | Global Instance MMapLemmas_const : MMapLemmas A A. now constructor. Qed. 75 | Global Instance MMapExt_const : MMapExt A A. hnf. tauto. Defined. 76 | End MMapConst. 77 | 78 | Arguments MMap_const _ _ f x /. 79 | 80 | Lemma mmap_const_instE {A B} f x : @mmap _ _ (@MMap_const A B) f x = x. reflexivity. Qed. 81 | 82 | 83 | (** Simplify mmap expressions *) 84 | 85 | Ltac mmap_typeclass_normalize := 86 | repeat match goal with 87 | | [|- context[@mmap ?A ?B _ ?f]] => 88 | let s := constr:(@mmap A B _ f) in progress change (@mmap A B _ f) with s 89 | end. 90 | 91 | Ltac mmap_typeclass_normalizeH H := 92 | repeat match typeof H with 93 | | context[@mmap ?A ?B _ ?f] => 94 | let s := constr:(@mmap A B _ f) in progress change (@mmap A B _ f) with s 95 | end. 96 | 97 | Global Hint Rewrite @mmap_id_instE @mmap_const_instE : mmap. 98 | Global Hint Rewrite @mmap_id @mmap_comp @mmap_idX @mmap_compX @mmap_compR 99 | using exact _ : mmap. 100 | 101 | Global Hint Rewrite @mmap_id_instE @mmap_const_instE : autosubst. 102 | Global Hint Rewrite @mmap_id @mmap_comp @mmap_idX @mmap_compX @mmap_compR 103 | using exact _ : autosubst. 104 | 105 | Ltac msimpl := 106 | mmap_typeclass_normalize; 107 | repeat first 108 | [ solve [trivial] 109 | | progress (simpl; autorewrite with mmap) 110 | | fold_id]. 111 | 112 | Ltac msimplH H := 113 | mmap_typeclass_normalizeH H; 114 | repeat first 115 | [ solve [trivial] 116 | | progress (simpl; autorewrite with mmap in H) 117 | | fold_id in H]. 118 | 119 | Tactic Notation "msimpl" "in" ident(H) := msimplH H. 120 | Tactic Notation "msimpl" "in" "*" := (in_all msimplH); msimpl. 121 | 122 | (** Deriving Instances *) 123 | 124 | Ltac derive_MMap := 125 | let map := fresh "dummy" in (* hack due to potential ltac bug ! *) 126 | hnf; match goal with [ |- (?A -> ?A) -> ?B -> ?B ] => 127 | intros f; fix map 1; intros xs; change (annot B xs); destruct xs; 128 | match goal with 129 | | [ |- annot _ ?ys ] => 130 | let rec tmap xs := 131 | (match xs with 132 | | ?s1 ?s2 => 133 | let s1 := tmap s1 in 134 | let T := typeof s2 in 135 | let s2 := 136 | match T with 137 | | A => constr:(f s2) 138 | | B => constr:(map s2) 139 | | _ => constr:(mmap f s2) 140 | end in 141 | constr:(s1 s2) 142 | | _ => xs 143 | end) in 144 | let ys := tmap ys in exact ys 145 | end 146 | end. 147 | Global Hint Extern 0 (MMap _ _) => derive_MMap : derive. 148 | 149 | Ltac derive_MMapLemmas := constructor; 150 | [ let x := fresh in intros x; induction x; simpl; f_equal; trivial; apply mmap_id 151 | | let x := fresh in intros ?? x; induction x; simpl; f_equal; trivial; apply mmap_comp ]. 152 | Global Hint Extern 0 (MMapLemmas _ _) => derive_MMapLemmas : derive. 153 | 154 | Ltac derive_MMapExt := 155 | intros ???; fix FIX 1; let x := fresh in intros x; destruct x; simpl; f_equal; auto using mmap_ext. 156 | Global Hint Extern 0 (MMapExt _ _) => derive_MMapExt : derive. 157 | 158 | (* Local Variables: *) 159 | (* coq-load-path: (("." "Autosubst")) *) 160 | (* End: *) 161 | -------------------------------------------------------------------------------- /theories/Autosubst_MMapInstances.v: -------------------------------------------------------------------------------- 1 | (** 2 | Default instances for mmap. 3 | For ssreflect, you might want to use the library versions instead. 4 | *) 5 | Require Import Autosubst_Basics Autosubst_MMap. 6 | 7 | Require List. 8 | 9 | Section MMapInstances. 10 | 11 | Variable (A B C : Type). 12 | Variable (MMap_A_B : MMap A B). 13 | Variable (MMap_A_C : MMap A C). 14 | Variable (MMapLemmas_A_B : MMapLemmas A B). 15 | Variable (MMapLemmas_A_C : MMapLemmas A C). 16 | Variable (MMapExt_A_B : MMapExt A B). 17 | Variable (MMapExt_A_C : MMapExt A C). 18 | 19 | Global Instance MMap_option : MMap A (option B). derive. Defined. 20 | Global Instance MMapLemmas_option : MMapLemmas A (option B). derive. Qed. 21 | Global Instance MMapExt_option : MMapExt A (option B). derive. Defined. 22 | 23 | Global Instance MMap_list : MMap A (list B). derive. Defined. 24 | Global Instance MMapLemmas_list : MMapLemmas A (list B). derive. Qed. 25 | Global Instance MMapExt_list : MMapExt A (list B). derive. Defined. 26 | 27 | Global Instance MMap_pair : MMap A (B * C). derive. Defined. 28 | Global Instance MMapLemmas_pair : MMapLemmas A (B * C). derive. Qed. 29 | Global Instance MMapExt_pair : MMapExt A (B * C). derive. Defined. 30 | 31 | Global Instance MMap_fun : MMap A (B -> C) := fun f g x => mmap f (g x). 32 | 33 | Global Instance MMapLemmas_fun : MMapLemmas A (B -> C). 34 | Proof. 35 | constructor; intros; f_ext; intros; [apply mmap_id|apply mmap_comp]. 36 | Qed. 37 | 38 | Global Instance MMapExt_fun : MMapExt A (B -> C). 39 | Proof. 40 | hnf. intros f g H h. f_ext. intro x. apply mmap_ext. exact H. 41 | Defined. 42 | 43 | End MMapInstances. 44 | 45 | (* Local Variables: *) 46 | (* coq-load-path: (("." "Autosubst")) *) 47 | (* End: *) 48 | -------------------------------------------------------------------------------- /theories/Autosubst_Tactics.v: -------------------------------------------------------------------------------- 1 | (** The main automation tactics. *) 2 | Require Import Autosubst_Basics Autosubst_MMap Autosubst_Classes. 3 | 4 | (** Derived substitution lemmas. *) 5 | 6 | Section LemmasForSubst. 7 | 8 | Context {term : Type} {Ids_term : Ids term} 9 | {Rename_term : Rename term} {Subst_term : Subst term} 10 | {SubstLemmas_term : SubstLemmas term}. 11 | 12 | Implicit Types (s t : term) (sigma tau theta : var -> term) (xi : var -> var). 13 | 14 | Lemma rename_substX xi : rename xi = subst (ren xi). 15 | Proof. f_ext. apply rename_subst. Qed. 16 | 17 | Lemma upX sigma : up sigma = ids 0 .: sigma >>> subst (ren (+1)). 18 | Proof. unfold up. now rewrite rename_substX. Qed. 19 | 20 | Lemma id_scompX sigma : ids >>> subst sigma = sigma. 21 | Proof. f_ext. apply id_subst. Qed. 22 | 23 | Lemma id_scompR {A} sigma (f : _ -> A) : 24 | ids >>> (subst sigma >>> f) = sigma >>> f. 25 | Proof. now rewrite <- compA, id_scompX. Qed. 26 | 27 | Lemma subst_idX : subst ids = id. 28 | Proof. f_ext. exact subst_id. Qed. 29 | 30 | Lemma subst_compI sigma tau s : 31 | s.[sigma].[tau] = s.[sigma >>> subst tau]. 32 | Proof. apply subst_comp. Qed. 33 | 34 | Lemma subst_compX sigma tau : 35 | subst sigma >>> subst tau = subst (sigma >>> subst tau). 36 | Proof. f_ext. apply subst_comp. Qed. 37 | 38 | Lemma subst_compR {A} sigma tau (f : _ -> A) : 39 | subst sigma >>> (subst tau >>> f) = subst (sigma >>> subst tau) >>> f. 40 | Proof. now rewrite <- subst_compX. Qed. 41 | 42 | Lemma fold_ren_cons (x : var) (xi : var -> var) : 43 | ids x .: ren xi = ren (x .: xi). 44 | Proof. unfold ren. now rewrite scons_comp. Qed. 45 | 46 | Lemma upE sigma : up sigma = ids 0 .: sigma >> ren (+1). 47 | Proof. apply upX. Qed. 48 | 49 | (* unfold upn *) 50 | 51 | Lemma upnSX n sigma : 52 | upn (S n) sigma = ids 0 .: upn n sigma >>> subst (ren (+1)). 53 | Proof. 54 | unfold iterate; now rewrite upX. 55 | Qed. 56 | 57 | Lemma upnSE n sigma : 58 | upn (S n) sigma = ids 0 .: upn n sigma >> ren (+1). 59 | Proof. 60 | now rewrite upnSX. 61 | Qed. 62 | 63 | Lemma upn0 sigma : upn 0 sigma = sigma. 64 | Proof. reflexivity. Qed. 65 | 66 | (* fold up *) 67 | 68 | Lemma fold_up k sigma : 69 | ids k .: sigma >> ren (+S k) = up sigma >> ren (+k). 70 | Proof. 71 | unfold scomp, ren. rewrite upX; fsimpl; rewrite id_subst, subst_compX; simpl; fsimpl. 72 | unfold ren. fsimpl. rewrite id_scompX. now fsimpl. 73 | Qed. 74 | 75 | Lemma fold_up0 sigma : 76 | sigma >> ren (+0) = sigma. 77 | Proof. 78 | unfold scomp, ren. fsimpl. now rewrite subst_idX. 79 | Qed. 80 | 81 | (* combine up *) 82 | 83 | Lemma fold_up_up sigma : up (up sigma) = upn 2 sigma. 84 | Proof. reflexivity. Qed. 85 | 86 | Lemma fold_up_upn n sigma : up (upn n sigma) = upn (S n) sigma. 87 | Proof. reflexivity. Qed. 88 | 89 | Lemma fold_upn_up n sigma : upn n (up sigma) = upn (S n) sigma. 90 | Proof. now rewrite iterate_Sr. Qed. 91 | 92 | End LemmasForSubst. 93 | 94 | (** Derived substitution lemmas for heterogeneous substitutions. *) 95 | 96 | Section LemmasForHSubst. 97 | 98 | Context {inner outer : Type}. 99 | 100 | Context {Ids_inner : Ids inner} {Rename_inner : Rename inner} 101 | {Subst_inner : Subst inner} {SubstLemmas_inner : SubstLemmas inner}. 102 | 103 | Context {Ids_outer : Ids outer} {Rename_outer : Rename outer} 104 | {Subst_outer : Subst outer} {SubstLemmas_outer : SubstLemmas outer}. 105 | 106 | Context {HSubst_inner_outer : HSubst inner outer}. 107 | Context {HSubstLemmas_inner_outer : HSubstLemmas inner outer}. 108 | Context {SubstHSubstComp_inner_outer : SubstHSubstComp inner outer}. 109 | 110 | Lemma id_hsubstX (sigma : var -> inner) : ids >>> hsubst sigma = ids. 111 | Proof. f_ext. apply id_hsubst. Qed. 112 | 113 | Lemma id_hsubstR {A} (f : _ -> A) (sigma : var -> inner) : 114 | ids >>> (hsubst sigma >>> f) = ids >>> f. 115 | Proof. now rewrite <- compA, id_hsubstX. Qed. 116 | 117 | Lemma hsubst_idX : hsubst ids = id. 118 | Proof. f_ext. exact hsubst_id. Qed. 119 | 120 | Lemma hsubst_compI sigma tau s : 121 | s.|[sigma].|[tau] = s.|[sigma >>> subst tau]. 122 | Proof. apply hsubst_comp. Qed. 123 | 124 | Lemma hsubst_compX sigma tau : 125 | hsubst sigma >>> hsubst tau = hsubst (sigma >>> subst tau). 126 | Proof. f_ext. apply hsubst_comp. Qed. 127 | 128 | Lemma hsubst_compR {A} sigma tau (f : _ -> A) : 129 | hsubst sigma >>> (hsubst tau >>> f) = hsubst (sigma >>> subst tau) >>> f. 130 | Proof. now rewrite <- hsubst_compX. Qed. 131 | 132 | Lemma scomp_hcompI sigma theta s : 133 | s.[sigma].|[theta] = s.|[theta].[sigma >>> hsubst theta]. 134 | Proof. apply subst_hsubst_comp. Qed. 135 | 136 | Lemma scomp_hcompX sigma theta : 137 | subst sigma >>> hsubst theta = hsubst theta >>> subst (sigma >>>hsubst theta). 138 | Proof. f_ext. apply subst_hsubst_comp. Qed. 139 | 140 | Lemma scomp_hcompR {A} sigma theta (f : _ -> A) : 141 | subst sigma >>> (hsubst theta >>> f) = 142 | hsubst theta >>> (subst (sigma >>> hsubst theta) >>> f). 143 | Proof. now rewrite <- compA, scomp_hcompX. Qed. 144 | 145 | End LemmasForHSubst. 146 | 147 | (** Normalize the goal state. *) 148 | 149 | Ltac autosubst_typeclass_normalize := 150 | mmap_typeclass_normalize; 151 | repeat match goal with 152 | | [|- context[ids ?x]] => 153 | let s := constr:(ids x) in progress change (ids x) with s 154 | | [|- context[ren ?xi]] => 155 | let s := constr:(ren xi) in progress change (ren xi) with s 156 | | [|- context[rename ?xi]] => 157 | let s := constr:(rename xi) in progress change (rename xi) with s 158 | | [|- context[subst ?sigma]] => 159 | let s := constr:(subst sigma) in progress change (subst sigma) with s 160 | | [|- context[hsubst ?sigma]] => 161 | let s := constr:(hsubst sigma) in progress change (hsubst sigma) with s 162 | end. 163 | 164 | Ltac autosubst_typeclass_normalizeH H := 165 | mmap_typeclass_normalizeH H; 166 | repeat match typeof H with 167 | | context[ids ?x] => 168 | let s := constr:(ids x) in progress change (ids x) with s in H 169 | | context[ren ?xi] => 170 | let s := constr:(ren xi) in progress change (ren xi) with s in H 171 | | context[rename ?xi] => 172 | let s := constr:(rename xi) in progress change (rename xi) with s in H 173 | | context[subst ?sigma] => 174 | let s := constr:(subst sigma) in progress change (subst sigma) with s in H 175 | | context[hsubst ?sigma] => 176 | let s := constr:(hsubst sigma) in progress change (hsubst sigma) with s in H 177 | end. 178 | 179 | Ltac autosubst_unfold_up := 180 | rewrite ?upX, ?upnSX; 181 | repeat match goal with 182 | | [|- context[upn 0 ?sigma]] => change (upn 0 sigma) with sigma 183 | end. 184 | 185 | Ltac autosubst_unfold_upH H := 186 | rewrite ?upX, ?upnSX in H; 187 | repeat match typeof H with 188 | | context[upn 0 ?sigma] => change (upn 0 sigma) with sigma 189 | end. 190 | 191 | Ltac autosubst_unfold := 192 | autosubst_typeclass_normalize; autosubst_unfold_up; 193 | rewrite ?rename_substX; unfold ren, scomp, hcomp, upren. 194 | 195 | Ltac autosubst_unfoldH H := 196 | autosubst_typeclass_normalizeH H; autosubst_unfold_upH H; 197 | rewrite ?rename_substX in H; unfold ren, scomp, hcomp, upren in H. 198 | 199 | (** Simplify results. *) 200 | 201 | Ltac fold_ren := 202 | repeat match goal with 203 | | [|- context[?xi >>> (@ids ?T _)]] => 204 | change (xi >>> (@ids T _)) with (@ren T _ xi) 205 | | [|- context[?xi >>> (@ids ?T _ >>> ?g)]] => 206 | change (xi >>> (@ids T _ >>> g)) with (@ren T _ xi >>> g) 207 | | [|- context[?xi >>> @ren ?T _ ?zeta]] => 208 | change (xi >>> @ren T _ zeta) with (@ren T _ (xi >>> zeta)) 209 | | [|- context[?xi >>> (@ren ?T _ ?zeta >>> ?g)]] => 210 | change (xi >>> (@ren T _ zeta >>> g)) with 211 | (@ren T _ (xi >>> zeta) >>> g) 212 | | [|- context [ids ?x .: ?sigma]] => 213 | first[ 214 | rewrite fold_ren_cons 215 | | replace (ids x .: ids) with (ren (x .: id)) 216 | by (symmetry; apply fold_ren_cons) 217 | ] 218 | end. 219 | 220 | Ltac fold_renH H := 221 | repeat match typeof H with 222 | | context[?xi >>> (@ids ?T _)] => 223 | change (xi >>> (@ids T _)) with (@ren T _ xi) in H 224 | | context[?xi >>> (@ids ?T _ >>> ?g)] => 225 | change (xi >>> (@ids T _ >>> g)) with (@ren T _ xi >>> g) in H 226 | | context[?xi >>> @ren ?T _ ?zeta] => 227 | change (xi >>> @ren T _ zeta) with (@ren T _ (xi >>> zeta)) in H 228 | | context[?xi >>> (@ren ?T _ ?zeta >>> ?g)] => 229 | change (xi >>> (@ren T _ zeta >>> g)) with 230 | (@ren T _ (xi >>> zeta) >>> g) in H 231 | | context [ids ?x .: ?sigma] => 232 | first[ 233 | rewrite fold_ren_cons in H 234 | | replace (ids x .: ids) with (ren (x .: id)) in H 235 | by (symmetry; apply fold_ren_cons) 236 | ] 237 | end. 238 | 239 | Ltac fold_comp := 240 | repeat match goal with 241 | | [|- context[?f >>> (?g >>> ?h)]] => 242 | change (f >>> (g >>> h)) with ((f >>> g) >>> h) 243 | | [|- context[?sigma >>> subst ?tau]] => 244 | change (sigma >>> subst tau) with (sigma >> tau) 245 | | [|- context[?sigma >>> hsubst ?tau]] => 246 | change (sigma >>> hsubst tau) with (sigma >>| tau) 247 | end. 248 | 249 | Ltac fold_compH H := 250 | repeat match typeof H with 251 | | context[?f >>> (?g >>> ?h)] => 252 | change (f >>> (g >>> h)) with ((f >>> g) >>> h) in H 253 | | context[?sigma >>> subst ?tau] => 254 | change (sigma >>> subst tau) with (sigma >> tau) in H 255 | | context[?sigma >>> hsubst ?tau] => 256 | change (sigma >>> hsubst tau) with (sigma >>| tau) in H 257 | end. 258 | 259 | Ltac fold_up := rewrite ?fold_up, ?fold_up0; 260 | repeat match goal with 261 | | [|- context[up (up ?sigma)]] => 262 | change (up (up sigma)) with (upn 2 sigma) 263 | | [|- context[up (upn ?n ?sigma)]] => 264 | change (up (upn n sigma)) with (upn (S n) sigma) 265 | | _ => rewrite fold_upn_up 266 | end; 267 | repeat open_fold (upren _). 268 | 269 | Ltac fold_upH H := rewrite ?fold_up, ?fold_up0 in H; 270 | repeat match typeof H with 271 | | context[up (up ?sigma)] => 272 | change (up (up sigma)) with (upn 2 sigma) in H 273 | | context[up (upn ?n ?sigma)] => 274 | change (up (upn n sigma)) with (upn (S n) sigma) in H 275 | | _ => rewrite fold_upn_up in H 276 | end; 277 | repeat open_fold (upren _) in H. 278 | 279 | (** Solve & Simplify goals involving substitutions. *) 280 | 281 | Ltac autosubst := 282 | cbn; trivial; autosubst_unfold; solve [repeat first 283 | [ solve [trivial] 284 | | progress ( 285 | cbn; unfold _bind, ren, scomp, hcomp; fsimpl; autosubst_unfold_up; 286 | autorewrite with autosubst; 287 | rewrite ?id_scompX, ?id_scompR, ?subst_idX, ?subst_compX, 288 | ?subst_compR, ?id_subst, ?subst_id, ?subst_compI, 289 | ?id_hsubstX, ?id_hsubstR, ?hsubst_idX, ?scomp_hcompX, 290 | ?scomp_hcompR, ?hsubst_compX, ?hsubst_compR, 291 | ?hsubst_id, ?id_hsubst, ?hsubst_compI, ?scomp_hcompI 292 | ) 293 | | match goal with [|- context[(_ .: _) ?x]] => 294 | match goal with [y : _ |- _ ] => unify y x; destruct x; simpl @scons end 295 | end 296 | | fold_id]]. 297 | 298 | Ltac asimpl := 299 | autorewrite with autosubst; 300 | cbn; autosubst_unfold; repeat first 301 | [ progress ( 302 | cbn; unfold _bind, ren, scomp, hcomp; fsimpl; autosubst_unfold_up; 303 | autorewrite with autosubst; 304 | rewrite ?id_scompX, ?id_scompR, ?subst_idX, ?subst_compX, 305 | ?subst_compR, ?id_subst, ?subst_id, ?subst_compI, 306 | ?id_hsubstX, ?id_hsubstR, ?hsubst_idX, ?scomp_hcompX, 307 | ?scomp_hcompR, ?hsubst_compX, ?hsubst_compR, 308 | ?hsubst_id, ?id_hsubst, ?hsubst_compI, ?scomp_hcompI 309 | ) 310 | | fold_id]; 311 | fold_ren; fold_comp; fold_up. 312 | 313 | Ltac asimplH H := 314 | autorewrite with autosubst in H; 315 | cbn in H; autosubst_unfoldH H; repeat first 316 | [ progress ( 317 | cbn in H; unfold _bind, ren, scomp, hcomp in H; fsimpl in H; 318 | autosubst_unfold_upH H; autorewrite with autosubst in H; 319 | rewrite ?id_scompX, ?id_scompR, ?subst_idX, ?subst_compX, 320 | ?subst_compR, ?id_subst, ?subst_id, ?subst_compI, 321 | ?id_hsubstX, ?id_hsubstR, ?hsubst_idX, ?scomp_hcompX, 322 | ?scomp_hcompR, ?hsubst_compX, ?hsubst_compR, 323 | ?hsubst_id, ?id_hsubst, ?hsubst_compI, ?scomp_hcompI in H 324 | ) 325 | | fold_id in H]; 326 | fold_renH H; fold_compH H; fold_upH H. 327 | 328 | Tactic Notation "asimpl" "in" ident(H) := asimplH H. 329 | Tactic Notation "asimpl" "in" "*" := (in_all asimplH); asimpl. 330 | 331 | (* Local Variables: *) 332 | (* coq-load-path: (("." "Autosubst")) *) 333 | (* End: *) 334 | -------------------------------------------------------------------------------- /theories/Makefile: -------------------------------------------------------------------------------- 1 | COQMAKEFILE := Makefile.coq 2 | COQMAKE := +$(MAKE) -f $(COQMAKEFILE) 3 | 4 | LIB := . 5 | VS := $(wildcard *.v) 6 | 7 | all: $(COQMAKEFILE) 8 | +$(MAKE) -f $(COQMAKEFILE) all 9 | 10 | $(COQMAKEFILE): Makefile $(VS) 11 | coq_makefile -R $(LIB) Autosubst $(VS) -o $(COQMAKEFILE) 12 | 13 | install: $(COQMAKEFILE) 14 | $(COQMAKE) install 15 | 16 | clean: $(COQMAKEFILE) 17 | -$(COQMAKE) clean 18 | rm -f $(COQMAKEFILE) 19 | 20 | .PHONY: all install clean 21 | --------------------------------------------------------------------------------