├── .gitignore ├── theories ├── Lambda │ ├── Translation.v │ ├── Thunking.v │ ├── BackToDS.v │ ├── MurthyCBN.v │ ├── ModifiedCBV.v │ └── ANF.v ├── SSA.v ├── Structural.v ├── Constructions.v ├── Simulation.v ├── FullAbstraction.v ├── Constructions │ ├── Confluence.v │ ├── Reduction.v │ ├── Normalization.v │ ├── Inversion.v │ ├── Calculus.v │ ├── Observational.v │ ├── Stratification.v │ ├── TypeSystem.v │ └── Conversion.v ├── Dependent.v ├── Contification.v ├── Interpreter.v ├── Standardization.v ├── Generic.v ├── Factorization.v ├── Syntax.v ├── Pi │ ├── Graph.v │ └── Interpretation.v ├── Prelude.v ├── Conservation.v ├── Transition.v └── Intuitionistic.v ├── .github └── workflows │ ├── coq-8.16.yml │ ├── coq-8.17.yml │ ├── coq-8.18.yml │ └── coq-8.19.2.yml ├── Makefile ├── LICENSE ├── _CoqProject └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | # .gitignore 2 | theories/**/*.aux 3 | theories/**/*.vo 4 | theories/**/*.vok 5 | theories/**/*.vos 6 | theories/**/*.glob 7 | CoqMakefile 8 | CoqMakefile.conf 9 | .CoqMakefile.d 10 | .lia.cache 11 | theories/Sketch*.v 12 | ICFP24.v 13 | ICFP24-output.txt 14 | # Sigma.v 15 | -------------------------------------------------------------------------------- /theories/Lambda/Translation.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | (* TODO: the purpose of this file is to make a common (module) abstraction for 6 | the CPS translations investigated. Ideally, they should contain proofs of 7 | simulation and computational adequacy. *) 8 | -------------------------------------------------------------------------------- /theories/Lambda/Thunking.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import List. 7 | Require Import Arith. 8 | Require Import Equality. 9 | Require Import Local.Prelude. 10 | Require Import Local.AbstractRewriting. 11 | Require Import Local.Substitution. 12 | Require Import Local.Lambda.Calculus. 13 | -------------------------------------------------------------------------------- /theories/SSA.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import List. 7 | Require Import Arith. 8 | Require Import Equality. 9 | Require Import Local.Prelude. 10 | Require Import Local.Substitution. 11 | Require Import Local.AbstractRewriting. 12 | Require Import Local.Syntax. 13 | Require Import Local.Intuitionistic. 14 | -------------------------------------------------------------------------------- /.github/workflows/coq-8.16.yml: -------------------------------------------------------------------------------- 1 | name: 8.16 2 | on: push 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | steps: 7 | - uses: actions/checkout@v3 8 | - uses: coq-community/docker-coq-action@v1.4.1 9 | with: 10 | coq_version: "8.16" 11 | ocaml_version: default 12 | before_script: | 13 | startGroup "Workaround permission issue" 14 | sudo chown -R coq:coq . 15 | endGroup 16 | script: | 17 | startGroup "Build project" 18 | make 19 | endGroup 20 | after_script: | 21 | startGroup "Revert permissions" 22 | sudo chown -R 1001:116 . 23 | endGroup 24 | -------------------------------------------------------------------------------- /.github/workflows/coq-8.17.yml: -------------------------------------------------------------------------------- 1 | name: 8.17 2 | on: push 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | steps: 7 | - uses: actions/checkout@v3 8 | - uses: coq-community/docker-coq-action@v1.4.1 9 | with: 10 | coq_version: "8.17" 11 | ocaml_version: default 12 | before_script: | 13 | startGroup "Workaround permission issue" 14 | sudo chown -R coq:coq . 15 | endGroup 16 | script: | 17 | startGroup "Build project" 18 | make 19 | endGroup 20 | after_script: | 21 | startGroup "Revert permissions" 22 | sudo chown -R 1001:116 . 23 | endGroup 24 | -------------------------------------------------------------------------------- /.github/workflows/coq-8.18.yml: -------------------------------------------------------------------------------- 1 | name: 8.18 2 | on: push 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | steps: 7 | - uses: actions/checkout@v3 8 | - uses: coq-community/docker-coq-action@v1.4.1 9 | with: 10 | coq_version: "8.18" 11 | ocaml_version: default 12 | before_script: | 13 | startGroup "Workaround permission issue" 14 | sudo chown -R coq:coq . 15 | endGroup 16 | script: | 17 | startGroup "Build project" 18 | make 19 | endGroup 20 | after_script: | 21 | startGroup "Revert permissions" 22 | sudo chown -R 1001:116 . 23 | endGroup 24 | -------------------------------------------------------------------------------- /.github/workflows/coq-8.19.2.yml: -------------------------------------------------------------------------------- 1 | name: 8.19.2 2 | on: push 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | steps: 7 | - uses: actions/checkout@v3 8 | - uses: coq-community/docker-coq-action@v1.4.1 9 | with: 10 | coq_version: "8.19.2" 11 | ocaml_version: default 12 | before_script: | 13 | startGroup "Workaround permission issue" 14 | sudo chown -R coq:coq . 15 | endGroup 16 | script: | 17 | startGroup "Build project" 18 | make 19 | endGroup 20 | after_script: | 21 | startGroup "Revert permissions" 22 | sudo chown -R 1001:116 . 23 | endGroup 24 | -------------------------------------------------------------------------------- /theories/Structural.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2023 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Relations. 6 | Require Import Local.Prelude. 7 | Require Import Local.Syntax. 8 | Require Import Local.AbstractRewriting. 9 | Require Import Local.Context. 10 | Require Import Local.Equational. 11 | Require Import Local.Reduction. 12 | Require Import Local.Confluence. 13 | Require Import Local.Conservation. 14 | 15 | Inductive struct: relation pseudoterm := 16 | | struct_float_left: 17 | FLOAT_LEFT struct 18 | | struct_float_right: 19 | FLOAT_RIGHT struct 20 | | struct_bind_left: 21 | LEFT struct 22 | | struct_bind_right: 23 | RIGHT struct. 24 | -------------------------------------------------------------------------------- /theories/Lambda/BackToDS.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Local.Prelude. 7 | Require Import Local.AbstractRewriting. 8 | Require Import Local.Substitution. 9 | Require Import Local.Lambda.Calculus. 10 | Require Import Local.Lambda.PlotkinCBN. 11 | Require Import Local.Lambda.PlotkinCBV. 12 | Require Local.Syntax. 13 | Require Local.Intuitionistic. 14 | 15 | Import ListNotations. 16 | 17 | Module CPS. 18 | Include Local.Syntax. 19 | Include Local.Intuitionistic. 20 | End CPS. 21 | 22 | Notation polarity := CPS.polarity. 23 | Notation consume := CPS.consume. 24 | Notation lift_var := CPS.lift_var. 25 | 26 | -------------------------------------------------------------------------------- /theories/Constructions.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Local.Constructions.Calculus. 6 | Require Local.Constructions.Conversion. 7 | Require Local.Constructions.Confluence. 8 | Require Local.Constructions.TypeSystem. 9 | Require Local.Constructions.Normalization. 10 | Require Local.Constructions.Inversion. 11 | Require Local.Constructions.Stratification. 12 | Require Local.Constructions.Reduction. 13 | Require Local.Constructions.Observational. 14 | 15 | Include Calculus. 16 | Include Conversion. 17 | Include Confluence. 18 | Include TypeSystem. 19 | Include Normalization. 20 | Include Inversion. 21 | Include Stratification. 22 | Include Reduction. 23 | Include Observational. -------------------------------------------------------------------------------- /theories/Simulation.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2023 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import Arith. 7 | Require Import Equality. 8 | Require Import Local.Prelude. 9 | Require Import Local.Syntax. 10 | Require Import Local.Context. 11 | (* TODO: remove this one. *) 12 | Require Import Local.Equational. 13 | Require Import Local.Reduction. 14 | Require Import Local.Metatheory. 15 | Require Import Local.AbstractRewriting. 16 | Require Import Local.Observational. 17 | Require Local.Lambda.CallByName. 18 | Require Local.Lambda.CallByValue. 19 | 20 | (* I should probably move the CPS translations and simulation results here. For 21 | now, they reside in the [CallByName.v] and [CallByValue.v] files. TODO: do 22 | this or delete this file. *) 23 | -------------------------------------------------------------------------------- /theories/FullAbstraction.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2022 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Local.Prelude. 6 | Require Import Local.Syntax. 7 | Require Import Local.Context. 8 | Require Import Local.Simulation. 9 | 10 | (* It is most probably not possible to achieve full abstraction as terms in the 11 | CPS-calculus are allowed to discard and duplicate continuations; a simple 12 | example using call/cc might be enough (there's something similar in one of 13 | Ahmed's papers). We might try to prove that 1) it's really not possible, and 14 | 2) that it is indeed possible if we restrict ourselves to the subset of terms 15 | that are free of control effects (which is actually a subcategory, as it is 16 | described by Thielecke). This restriction may be done syntactically. *) 17 | -------------------------------------------------------------------------------- /theories/Constructions/Confluence.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2024 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Local.Prelude. 6 | Require Import Local.AbstractRewriting. 7 | Require Import Local.Constructions.Calculus. 8 | Require Import Local.Constructions.Conversion. 9 | 10 | (* I can, of course, prove that this reduction relation is confluent. However, 11 | that will require a lot of code and a lot of time that I don't have at the 12 | moment. I might be tempted to come back here at some point and follow the 13 | procedure in the "Coq Coq Correct!" paper to actually prove this. *) 14 | 15 | Conjecture step_is_confluent: 16 | forall g, confluent (step g). 17 | 18 | Corollary step_is_church_rosser: 19 | forall g, 20 | church_rosser (step g). 21 | Proof. 22 | intros. 23 | apply confluence_implies_church_rosser. 24 | apply step_is_confluent. 25 | Qed. 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile taken from Coq documentation 2 | 3 | # KNOWNTARGETS will not be passed along to CoqMakefile 4 | KNOWNTARGETS := CoqMakefile 5 | 6 | # KNOWNFILES will not get implicit targets from the final rule, and so 7 | # depending on them won't invoke the submake 8 | # Warning: These files get declared as PHONY, so any targets depending 9 | # on them always get rebuilt 10 | KNOWNFILES := Makefile _CoqProject 11 | 12 | .DEFAULT_GOAL := invoke-coqmakefile 13 | 14 | CoqMakefile: Makefile _CoqProject 15 | $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile 16 | 17 | invoke-coqmakefile: CoqMakefile 18 | $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) 19 | 20 | .PHONY: invoke-coqmakefile $(KNOWNFILES) 21 | 22 | #################################################################### 23 | ## Your targets here ## 24 | #################################################################### 25 | 26 | # This should be the last rule, to handle any targets not declared above 27 | %: invoke-coqmakefile 28 | @true 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Paulo Torrens 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /theories/Constructions/Reduction.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Local.AbstractRewriting. 7 | Require Import Local.Constructions.Calculus. 8 | Require Import Local.Constructions.Conversion. 9 | Require Import Local.Constructions.TypeSystem. 10 | Require Import Local.Constructions.Normalization. 11 | 12 | Import ListNotations. 13 | 14 | (* 15 | It should be enough to use an evaluation context rather than an arbitrary one. 16 | 17 | (* Call-by-value evaluation contexts. *) 18 | Inductive evaluation_context: context -> Prop := 19 | | evaluation_context_hole: 20 | evaluation_context context_hole 21 | | evaluation_context_app_left: 22 | forall e f, 23 | evaluation_context e -> 24 | evaluation_context (context_app_left e f) 25 | | evaluation_context_app_right: 26 | forall v e, 27 | value v -> 28 | evaluation_context e -> 29 | evaluation_context (context_app_right v e) 30 | | evaluation_context_def_val: 31 | forall e t f, 32 | evaluation_context e -> 33 | evaluation_context (context_def_val e t f) 34 | | evaluation_context_def_body: 35 | forall v t f, 36 | value v -> 37 | evaluation_context f -> 38 | evaluation_context (context_def_body v t f). 39 | *) 40 | 41 | Axiom cbn: relation term. 42 | 43 | Definition eval: relation term := 44 | fun e v => 45 | rt(cbn) e v /\ value v. 46 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -Q theories Local 2 | 3 | theories/Prelude.v 4 | theories/AbstractRewriting.v 5 | theories/Substitution.v 6 | # Ignore for now... 7 | # theories/Generic.v 8 | theories/Syntax.v 9 | theories/Metatheory.v 10 | theories/Context.v 11 | theories/Equational.v 12 | theories/Reduction.v 13 | theories/Shrinking.v 14 | theories/Residuals.v 15 | theories/Confluence.v 16 | theories/Factorization.v 17 | # Ignore this for now... 18 | # theories/Standardization.v 19 | theories/Observational.v 20 | theories/Contification.v 21 | theories/Machine.v 22 | theories/Interpreter.v 23 | theories/Transition.v 24 | theories/TypeSystem.v 25 | theories/Conservation.v 26 | theories/Structural.v 27 | theories/Normalization.v 28 | theories/Lambda/Calculus.v 29 | theories/Lambda/Translation.v 30 | theories/Lambda/PlotkinCBN.v 31 | theories/Lambda/PlotkinCBV.v 32 | theories/Lambda/MurthyCBN.v 33 | theories/Lambda/Thunking.v 34 | theories/Lambda/ModifiedCBV.v 35 | theories/Lambda/Kennedy.v 36 | theories/Lambda/BackToDS.v 37 | theories/Lambda/ANF.v 38 | # The following file is temporary... 39 | theories/Lambda/Control.v 40 | # TODO: fix the following... 41 | # theories/Simulation.v 42 | # Ignore this for now... 43 | # theories/FullAbstraction.v 44 | theories/Intuitionistic.v 45 | theories/SSA.v 46 | theories/Pi/Graph.v 47 | theories/Pi/Calculus.v 48 | theories/Pi/Control.v 49 | theories/Pi/Interpretation.v 50 | theories/Constructions/Calculus.v 51 | theories/Constructions/Conversion.v 52 | theories/Constructions/Confluence.v 53 | theories/Constructions/TypeSystem.v 54 | theories/Constructions/Inversion.v 55 | theories/Constructions/Normalization.v 56 | theories/Constructions/Stratification.v 57 | theories/Constructions/Reduction.v 58 | theories/Constructions/Observational.v 59 | theories/Constructions.v 60 | theories/Dependent.v 61 | -------------------------------------------------------------------------------- /theories/Dependent.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Local.Prelude. 6 | Require Import Local.Substitution. 7 | Require Import Local.AbstractRewriting. 8 | Require Local.Constructions. 9 | Require Import Local.Syntax. 10 | Require Import Local.Intuitionistic. 11 | 12 | Module TT := Local.Constructions. 13 | 14 | (* Let's start with CBV; after that, lets split the file in two, of course. *) 15 | 16 | (* Example 1. *) 17 | 18 | Eval cbv in let f: (forall T: Type, T -> T) := 19 | fun (T: Type) (x: T) => 20 | x 21 | in fun (x: f Set bool) => 22 | f bool x. 23 | 24 | (* 25 | 26 | Consider a source term: 27 | 28 | |- 29 | (let f: (forall T: Type, T -> T) := 30 | fun (T: Type) (x: T) => 31 | x 32 | in fun (x: f Set bool) => 33 | f bool x) : bool -> bool 34 | 35 | 36 | How should this be CPS-translated? We notice we're using f both in type-level 37 | and in term-level! It's CBV translation (as CBV is the standard one) would be 38 | as follows: 39 | 40 | k: ~~(bool, ~bool) 41 | |-k 42 | k 43 | { f = 44 | k 45 | { v = 46 | k 47 | } 48 | } 49 | { k = 50 | k 51 | { v = 52 | [f nat x] 53 | } 54 | } 55 | 56 | *) 57 | 58 | (* -------------------------------------------------------------------------- *) 59 | 60 | Inductive cbv_cps: TT.typing_judgement -> pseudoterm -> Prop :=. 61 | -------------------------------------------------------------------------------- /theories/Contification.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2023 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Relations. 6 | Require Import Local.Prelude. 7 | Require Import Local.AbstractRewriting. 8 | Require Import Local.Syntax. 9 | Require Import Local.Context. 10 | Require Import Local.Metatheory. 11 | Require Import Local.Equational. 12 | (* TODO: I've defined not_free_context in the wrong file so fix this, please? *) 13 | Require Import Local.Reduction. 14 | Require Import Local.Machine. 15 | Require Import Local.Observational. 16 | 17 | (* 18 | The contification transformation, as presented by Kennedy: 19 | 20 | C[D[f x1 j, ..., f xn j]] { f = c } 21 | 22 | ->s (CONTI) 23 | 24 | C[D[f x1, ..., f xn] { f = c[j/k] }] 25 | 26 | In the above, D is a multi-hole context, it is minimal (or, alternatively, C 27 | is maximal in the left-hand side), and f is not free in C nor D. 28 | *) 29 | 30 | Definition CONTI (R: relation pseudoterm): Prop := 31 | forall h k (ts us: list pseudoterm) (b1 b2 c: pseudoterm), 32 | not_free_context 0 h -> 33 | drop k 1 ts us -> 34 | (* Of course this definition is still wrong. *) 35 | R void void. 36 | 37 | Inductive cont: relation pseudoterm := 38 | | cont_conti: 39 | CONTI cont 40 | | cont_bind_left: 41 | LEFT cont 42 | | cont_bind_right: 43 | RIGHT cont. 44 | 45 | Lemma sema_cont: 46 | inclusion cont sema. 47 | Proof. 48 | induction 1. 49 | - admit. 50 | - now apply sema_bind_left. 51 | - now apply sema_bind_right. 52 | Admitted. 53 | 54 | Lemma barb_cont: 55 | inclusion cont barb. 56 | Proof. 57 | intros b c ?. 58 | apply barb_sema. 59 | apply sema_cont. 60 | assumption. 61 | Qed. 62 | 63 | Theorem contification_is_sound: 64 | forall b c, 65 | cont b c -> 66 | machine_equiv b c. 67 | Proof. 68 | intros b c ?. 69 | apply machine_equiv_characterization. 70 | now apply barb_cont. 71 | Qed. 72 | -------------------------------------------------------------------------------- /theories/Interpreter.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2023 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Program. 6 | Require Import Equality. 7 | Require Import Local.Prelude. 8 | Require Import Local.Syntax. 9 | Require Import Local.Metatheory. 10 | Require Import Local.Context. 11 | Require Import Local.Machine. 12 | 13 | (* Since Kennedy's machine semantics is sound and complete, we should write a 14 | version of Appel's interpreter, which is the denotational semantics of his IR 15 | into ML, by using the partiality monad and prove it correct with regard to 16 | the machine semantics as well. This would allow us to extract an executable 17 | interpreter for the CPS-calculus which is verified to be correct. *) 18 | 19 | (* 20 | datatype dvalue = RECORD of dvalue list * nat 21 | | INT of int 22 | | REAL of real 23 | | FUNC of dvalue list -> 24 | (loc*(loc->dvalue)*(loc->int))-> 25 | answer 26 | | STRING of string 27 | | ... 28 | 29 | type env = CPS.var -> dvalue 30 | 31 | E : CPS.expr -> env -> store -> answe 32 | 33 | ... 34 | | E (CPS.APP(f,vl)) env = 35 | let val FUNC g = V env f 36 | in g (map (V env) vl) 37 | end 38 | | E (CPS.FIX(fl,e)) env = 39 | let fun h r1 (f,vl,b) = 40 | FUNC(fn al => E b (bindn(g r1,vl,al))) 41 | and g r = bindn(r, map #1 fl, map (h r) fl) 42 | in E e (g env) 43 | end 44 | ... 45 | 46 | fun bind(env:env, v:CPS.var, d) = 47 | fn w => if v=w then d else env w 48 | 49 | fun bindn(env, v::vl, d::dl) = bindn(bind(env,v,d),vl,dl) 50 | | bindn(env, nil, nil) = env 51 | 52 | *) 53 | 54 | Section Appel. 55 | 56 | Variable answer: Type. 57 | Variable carrier: Type. 58 | 59 | Hypothesis intro: (list carrier -> answer) -> carrier. 60 | Hypothesis elim: carrier -> (list carrier -> answer). 61 | 62 | Hypothesis beta: forall l x, elim (intro l) x = l x. 63 | Hypothesis eta: forall y, intro (elim y) = y. 64 | 65 | Notation env := (nat -> carrier). 66 | 67 | Notation var := { e | exists n, e = bound n }. 68 | 69 | Program Fixpoint get (g: env) (e: var): carrier := 70 | match e with 71 | | bound n => 72 | g n 73 | | _ => 74 | False_rect carrier _ 75 | end. 76 | 77 | Next Obligation. 78 | eapply n; auto. 79 | Defined. 80 | 81 | (* 82 | Program Fixpoint eval (e: pseudoterm) (g: env): answer := 83 | match e with 84 | | jump k xs => 85 | elim (get g k) (map (get g) xs) 86 | | _ => 87 | (* This case will be an absurd and will not be part of the code. *) 88 | _ 89 | end. 90 | 91 | let val FUNC g = V env f 92 | in g (map (V env) vl) 93 | end 94 | *) 95 | 96 | End Appel. 97 | -------------------------------------------------------------------------------- /theories/Constructions/Normalization.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Local.Prelude. 7 | Require Import Local.AbstractRewriting. 8 | Require Import Local.Constructions.Calculus. 9 | Require Import Local.Constructions.Conversion. 10 | Require Import Local.Constructions.TypeSystem. 11 | Require Import Local.Constructions.Inversion. 12 | 13 | Import ListNotations. 14 | 15 | (* We're dealing with a subset of Coq's theory inside of Coq. Although it might 16 | be possible that strong normalization for this is actually provable, at some 17 | point it would become hopeless because of the incompleteness theorem. Also, I 18 | do think that proving this (in a proof assistant) for a predicative hierarchy 19 | with an impredicative universe is still an open problem. So, we will merely 20 | conjecture that this system is strongly normalizing and go on, just like the 21 | people in the "Coq Coq Correct!" paper did. *) 22 | 23 | Conjecture strong_normalization: 24 | forall g e t, 25 | typing g e t conv -> SN (step g) e. 26 | 27 | (* For typeable terms, the normal form is computable. *) 28 | 29 | Lemma normal_form_is_decidable: 30 | forall g e t, 31 | typing g e t conv -> 32 | exists2 f, 33 | rt(step g) e f & normal (step g) f. 34 | Proof. 35 | intros. 36 | apply strong_normalization in H. 37 | induction H using SN_ind. 38 | destruct step_is_decidable with g x as [ (y, ?H) | ?H ]. 39 | - destruct H2 with y as (z, ?, ?). 40 | + now apply t_step. 41 | + exists z; eauto with cps. 42 | - exists x. 43 | + apply rt_refl. 44 | + intros y ?. 45 | now apply H0 with y. 46 | Qed. 47 | 48 | Definition bottom: term := 49 | pi iset (bound 0). 50 | 51 | Lemma bottom_typeable: 52 | forall R, 53 | typing [] bottom iset R. 54 | Proof. 55 | intros. 56 | repeat econstructor. 57 | - (* Use vm_compute to bypass opaque definitions. *) 58 | now vm_compute. 59 | - (* By definition, as set is impredicative. *) 60 | reflexivity. 61 | Qed. 62 | 63 | (* For this one, we'll follow the proof given by Coquand and Gallier in "A Proof 64 | Of Strong Normalization For The Theory Of Constructions Using A Kripe-Like 65 | Interpretation", as their Lemma 5.19. *) 66 | 67 | Corollary consistency: 68 | ~exists e, typing [] e bottom conv. 69 | Proof. 70 | (* Assume there's an e that is typeable as bottom. *) 71 | intros (e, ?). 72 | (* So there's a term in normal form that also is. *) 73 | assert (exists2 f, typing [] f bottom conv & normal (step []) f) as (f, ?, ?). 74 | - (* We calculate it from strong normalization and subject reduction. *) 75 | destruct normal_form_is_decidable with ([]: env) e bottom as (f, ?, ?). 76 | + assumption. 77 | + exists f; auto. 78 | now apply subject_reduction with e. 79 | - (* So, forget the non-normal one. *) 80 | clear e H; rename f into e. 81 | admit. 82 | Admitted. 83 | -------------------------------------------------------------------------------- /theories/Lambda/MurthyCBN.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import List. 7 | Require Import Arith. 8 | Require Import Equality. 9 | Require Import Local.Prelude. 10 | Require Import Local.AbstractRewriting. 11 | Require Import Local.Substitution. 12 | Require Import Local.Lambda.Calculus. 13 | 14 | (* 15 | This CPS translation for the "extensional" lambda-calculus appears in Murthy's 16 | "A computational analysis of Girard's translation and LC" paper, and is also 17 | adapted and presented in Thielecke's thesis. Murthy calls it a "truly CBN" 18 | translation; of course, it captures the idea that we're identifying terms up 19 | to HNF instead of WHNF as in the (standard) call-by-name translation. This 20 | also means this translation is expected to validate extensionality, i.e., the 21 | full eta law. 22 | 23 | The original translation is given as follows: 24 | 25 | [x] = x 26 | [\x.M] = [M][\h.k (\a.\k.a h)/x] (\b.k (\a.\k.k b)) 27 | [M N] = \k.[M] (\v.v [N] k) 28 | 29 | (Note the presence of substitution above! Of course, it's a beta-reduct.) 30 | 31 | The version into the CPS-calculus is given by Thielecke as follows: 32 | 33 | [x] = x(k) 34 | [\x.M] = let x(h) = 35 | let f(a, _) = a(h) in k(f) (a control effect?) 36 | in 37 | let k(b) = 38 | let f(_, k) = k(b) in k(f) 39 | in [M] 40 | [M N] = let k(f) = 41 | let v(k) = [N] 42 | in f(v, k) 43 | in [M] 44 | 45 | Can we prove this is computationally adequate as well? Looks like fun! 46 | 47 | For the translation of a beta-redex [(\x.M) N], we note that the abstraction 48 | does not immediately return its result using the current continuation, but 49 | rather, it defines the continuation for [M] by using it, and gives a thunk 50 | value for x also using it. When put in place, the term will reduce to: 51 | 52 | [(\x.M) N] = let x(k) = [N] in 53 | let k(v) = k(v) in (jumps to outer k!) 54 | [M] 55 | 56 | Oops! This looks close to the definition of a CBN let, but there's a nasty 57 | eta-redex there. Although this doesn't require floating as the CBV one does, 58 | it still prevents simple simulation by just jumps and garbage collection. We 59 | would expect, just as in the CBV case, that extending the notion of shrinking 60 | reduction will fix this. Yet, we may prove this by doing something similar to 61 | what has been done in the CBV simulation. 62 | 63 | We should be extra careful in verifying the properties for eta-redexes, tho. 64 | It doesn't seem like they hold by the equational theory! How does this relate 65 | to the observational theory? Is it a missing axiom that works in general, or 66 | something that only works due to the image of the CPS translation...? TODO: 67 | study this! And may the gods help me, I'm so tired... 68 | *) 69 | -------------------------------------------------------------------------------- /theories/Constructions/Inversion.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Equality. 7 | Require Import Local.Prelude. 8 | Require Import Local.AbstractRewriting. 9 | Require Import Local.Substitution. 10 | Require Import Local.Constructions.Calculus. 11 | Require Import Local.Constructions.Conversion. 12 | Require Import Local.Constructions.TypeSystem. 13 | Require Import Local.Constructions.Confluence. 14 | (* Require Import Local.Constructions.Normalization. *) 15 | 16 | (* TODO: why are we using conv here instead of any R? *) 17 | 18 | Lemma typing_type_inv: 19 | forall g n t, 20 | typing g (type n) t conv -> 21 | conv g t (type (1 + n)). 22 | Proof. 23 | repeat intro. 24 | dependent induction H. 25 | - apply conv_refl. 26 | - rename t0 into u. 27 | apply conv_trans with u. 28 | + now apply conv_sym. 29 | + now apply IHinfer1. 30 | Qed. 31 | 32 | Lemma typing_iset_inv: 33 | forall g t, 34 | typing g iset t conv -> 35 | conv g t (type 0). 36 | Proof. 37 | intros. 38 | dependent induction H. 39 | - apply conv_refl. 40 | - rename t0 into u. 41 | apply conv_trans with u. 42 | + now apply conv_sym. 43 | + now apply IHinfer1. 44 | Qed. 45 | 46 | Lemma typing_bound_inv: 47 | forall g n t, 48 | typing g (bound n) t conv -> 49 | exists2 x, 50 | item x g n & conv g t (lift (1 + n) 0 (snd x)). 51 | Proof. 52 | intros. 53 | dependent induction H. 54 | - clear IHinfer; destruct d. 55 | + eexists. 56 | * eassumption. 57 | * simpl. 58 | apply conv_refl. 59 | + eexists. 60 | * eassumption. 61 | * simpl. 62 | apply conv_refl. 63 | - clear IHinfer2. 64 | specialize (IHinfer1 _ _ _ eq_refl JMeq_refl) as (x, ?, ?). 65 | exists x. 66 | + assumption. 67 | + rename t0 into u. 68 | apply conv_trans with u. 69 | * now apply conv_sym. 70 | * assumption. 71 | Qed. 72 | 73 | Lemma typing_unique: 74 | forall g e t1, 75 | typing g e t1 conv -> 76 | forall t2, 77 | typing g e t2 conv -> 78 | (* TODO: use the subtyping relation on conv. *) 79 | conv g t1 t2. 80 | Proof. 81 | intros until 1. 82 | dependent induction H; intros. 83 | - clear IHinfer. 84 | apply typing_iset_inv in H0. 85 | now apply conv_sym. 86 | - clear IHinfer. 87 | apply typing_type_inv in H0. 88 | now apply conv_sym. 89 | - clear IHinfer. 90 | destruct typing_bound_inv with g n t2. 91 | + assumption. 92 | + assert (x = (d, t)) by now apply item_unique with g n. 93 | dependent destruction H4. 94 | simpl in H3. 95 | now apply conv_sym. 96 | - specialize (IHinfer1 _ _ _ eq_refl JMeq_refl). 97 | specialize (IHinfer2 _ _ _ eq_refl JMeq_refl). 98 | generalize dependent s2. 99 | generalize dependent s1. 100 | dependent induction H1; intros. 101 | + clear IHinfer1 IHinfer2. 102 | specialize (IHinfer0 _ H1_). 103 | specialize (IHinfer3 _ H1_0). 104 | admit. 105 | + clear IHinfer2. 106 | specialize (IHinfer1 _ _ _ _ eq_refl JMeq_refl). 107 | eapply conv_trans with t0; auto. 108 | - admit. 109 | - admit. 110 | - admit. 111 | - admit. 112 | - admit. 113 | - admit. 114 | - admit. 115 | - admit. 116 | - admit. 117 | - admit. 118 | - admit. 119 | - admit. 120 | - admit. 121 | - admit. 122 | - specialize (IHinfer1 _ _ _ eq_refl JMeq_refl _ H2). 123 | apply conv_trans with t. 124 | + now apply conv_sym. 125 | + assumption. 126 | Admitted. 127 | -------------------------------------------------------------------------------- /theories/Standardization.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2021 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import Arith. 7 | Require Import Equality. 8 | Require Import Local.Prelude. 9 | Require Import Local.Syntax. 10 | Require Import Local.Context. 11 | Require Import Local.AbstractRewriting. 12 | Require Import Local.Reduction. 13 | 14 | Fixpoint jump_count (e: pseudoterm): nat := 15 | match e with 16 | | jump k xs => 17 | 1 18 | | bind b ts c => 19 | jump_count b + jump_count c 20 | | _ => 21 | (* We don't really have a jump, but neither should we have this in a 22 | context, so pretend it has a positive count. *) 23 | 1 24 | end. 25 | 26 | Fixpoint left_jump_count (h: context): nat := 27 | match h with 28 | | context_hole => 29 | 0 30 | | context_left b ts c => 31 | left_jump_count b 32 | | context_right b ts c => 33 | jump_count b + left_jump_count c 34 | end. 35 | 36 | Lemma left_jump_count_zero_imply_static: 37 | forall h, 38 | left_jump_count h = 0 <-> static h. 39 | Proof. 40 | split. 41 | - induction h; simpl; intros. 42 | + constructor. 43 | + constructor; auto. 44 | + exfalso. 45 | clear IHh. 46 | induction b; simpl in H; lia. 47 | - induction 1; simpl. 48 | + reflexivity. 49 | + assumption. 50 | Qed. 51 | 52 | Inductive indexed_step: nat -> relation pseudoterm := 53 | | indexed_step_ctxjmp: 54 | forall h xs ts c, 55 | length xs = length ts -> 56 | indexed_step (left_jump_count h) 57 | (bind (h (jump #h xs)) ts c) 58 | (bind (h (apply_parameters xs 0 (lift (S #h) (length ts) c))) ts c) 59 | | indexed_step_bind_left: 60 | forall k b1 b2 ts c, 61 | indexed_step k b1 b2 -> 62 | indexed_step k (bind b1 ts c) (bind b2 ts c) 63 | | indexed_step_bind_right: 64 | forall k b ts c1 c2, 65 | indexed_step k c1 c2 -> 66 | indexed_step (jump_count b + k) (bind b ts c1) (bind b ts c2). 67 | 68 | Goal 69 | same_relation head (indexed_step 0). 70 | Proof. 71 | unfold same_relation, inclusion; split; intros. 72 | - destruct H. 73 | induction H0; simpl. 74 | + replace 0 with (left_jump_count h) at 1. 75 | * constructor. 76 | assumption. 77 | * apply left_jump_count_zero_imply_static. 78 | assumption. 79 | + apply indexed_step_bind_left. 80 | assumption. 81 | - dependent induction H. 82 | + apply head_longjmp with (r := context_hole). 83 | * apply left_jump_count_zero_imply_static. 84 | assumption. 85 | * constructor. 86 | * assumption. 87 | + apply head_bind_left; auto. 88 | + clear H IHindexed_step; exfalso. 89 | induction b; simpl in x; lia. 90 | Qed. 91 | 92 | Goal 93 | same_relation step (fun a b => exists k, indexed_step k a b). 94 | Proof. 95 | unfold same_relation, inclusion; split; intros. 96 | - induction H. 97 | + exists (left_jump_count h). 98 | constructor. 99 | assumption. 100 | + destruct IHstep as (k, ?). 101 | exists k. 102 | constructor. 103 | assumption. 104 | + destruct IHstep as (k, ?). 105 | exists (jump_count b + k). 106 | constructor. 107 | assumption. 108 | - destruct H as (k, ?). 109 | dependent induction H. 110 | + constructor. 111 | assumption. 112 | + constructor. 113 | assumption. 114 | + constructor. 115 | assumption. 116 | Qed. 117 | 118 | Definition internal_step a b: Prop := 119 | exists2 k, 120 | k > 0 & indexed_step k a b. 121 | 122 | Inductive standard_sequence: nat -> relation pseudoterm := 123 | | standard_sequence_refl: 124 | forall k e, 125 | standard_sequence k e e 126 | | standard_sequence_step: 127 | forall a b c k j, 128 | k <= j -> 129 | standard_sequence k a b -> 130 | indexed_step j b c -> 131 | standard_sequence j a c. 132 | 133 | Theorem standardization: 134 | forall a b, 135 | [a =>* b] -> 136 | exists k, 137 | standard_sequence k a b. 138 | Proof. 139 | admit. 140 | Admitted. 141 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The Calculus of Continuations 2 | 3 | My take on Thielecke's CPS-calculus, and variants hereof. 4 | 5 | I'm currently running against time to finish everything, and I'm pretty tired, 6 | but I'll get back in here to improve this documentation. 7 | 8 | ![Coq 8.16](https://github.com/takanuva/cps/actions/workflows/coq-8.16.yml/badge.svg) 9 | ![Coq 8.17](https://github.com/takanuva/cps/actions/workflows/coq-8.17.yml/badge.svg) 10 | ![Coq 8.18](https://github.com/takanuva/cps/actions/workflows/coq-8.18.yml/badge.svg) 11 | ![Coq 8.19.2](https://github.com/takanuva/cps/actions/workflows/coq-8.19.2.yml/badge.svg) 12 | 13 | # Summary of files 14 | 15 | A summary of the proof files, in order, and what they cover. I should surely 16 | come back here and improve this documentation at some point. This is but a 17 | sketch for the curious ones. 18 | 19 | The following files are somewhat self-contained and unrelated to the main goal: 20 | 21 | - [Prelude.v](theories/Prelude.v): random stuff needed throughout the 22 | formalization, such as tactics and some proofs about lists. 23 | - [AbstractRewriting.v](theories/AbstractRewriting.v): general definitions and 24 | proofs about abstract rewriting systems (including bisimulation) needed by 25 | other proofs. 26 | - [Substitution.v](theories/Substitution.v): an implementation of the 27 | sigma-calculus, as of now just an experiment to automate reasoning about 28 | substitutions in a de Bruijn setting. 29 | - [Lambda/Calculus.v](theories/Lambda/Calculus.v): some basic definitions about the lambda-calculus. 30 | 31 | Content about the CPS-calculus itself: 32 | 33 | - [Syntax.v](theories/Syntax.v): the syntax of the CPS calculus, along with 34 | declarations necessary for handling de Bruijn indexes and free variables. 35 | - [Metatheory.v](theories/Metatheory.v): most metatheory about de Bruijn 36 | variable handling. 37 | - [Context.v](theories/Context.v): definition of static and full contexts in the 38 | CPS calculus, along with the notion of a congruence. 39 | - [Equational.v](theories/Equational.v): definition of the equational theory 40 | (also called the axiomatic semantics) as originally studied, including 41 | admissible rules. 42 | - [Reduction.v](theories/Reduction.v): definition of the reduction semantics, 43 | including one-step and multi-step reduction, and convertibility congruence, 44 | showing they're sound with respect to the equational theory. 45 | - [Shrinking.v](theories/Shrinking.v): introduces the notion of a shrinking 46 | reduction along with tidying requirements for preserving confluence, 47 | factorization and normalization. 48 | - [Residuals.v](theories/Residuals.v): development of a theory of residuals and 49 | "terms with a mark", necessary for confluence, including the cube lemma. 50 | - [Confluence.v](theories/Confluence.v): definition of a notion of parallel 51 | reduction, including proofs of confluence and of the Church-Rosser property. 52 | - [Factorization.v](theories/Factorization.v): full reduction may be factorized, 53 | showing that we're always allowed to perform leftmost jumps first. 54 | - [Conservation.v](theories/Conservation.v): proof of conservation (uniform 55 | normalization) for jump reduction, and some of its corollaries. 56 | - [Structural.v](theories/Structural.v): proof of preservation of strong 57 | normalization for some notions of structural rules on jump development. 58 | - [Observational.v](theories/Observational.v): observational theory of the 59 | calculus, including observational congruence and barbed congruence. 60 | - [Machine.v](theories/Machine.v): big-step machine semantics, as given for 61 | compiler IRs, and it's equivalence to head reduction. 62 | - [Transition.v](theories/Transition.v): labelled transition semantics, and 63 | development on their soundness with regards to the other semantics. 64 | - [TypeSystem.v](theories/TypeSystem.v): definition of a simply typed type 65 | system for the CPS calculus, and admissibility of the structural rules for it. 66 | - [Normalization.v](theories/Normalization.v): proof of strong normalization for 67 | jumps and the full reduction relation, along with it logical consistency. 68 | - [Lambda/PlotkinCBN.v](theories/Lambda/PlotkinCBN.v): definitions for the 69 | call-by-name lambda-calculus, as defined by Plotkin, along with its CPS 70 | translation and proofs of simulation, adequacy and denotational soundness. 71 | - [Lambda/PlotkinCBV.v](theories/Lambda/PlotkinCBV.v): same as above, but for 72 | the call-by-value lambda-calculus. 73 | 74 | # TODO 75 | 76 | There's some work on other stuff, such as proving contification is sound and 77 | that Appel's interpreter is correct. I also gotta review the transition system, 78 | and actually make use of the sigma-calculus. We eventually want to prove 79 | standardization as well, following factorization. Also, there are some sketches 80 | about ANF and correctness of control operators in the translations. We should 81 | prove some other CPS translations (such as the one Kennedy uses). I want to 82 | mechanize Merro's results on the observational theory as well. May the gods help 83 | me. 84 | -------------------------------------------------------------------------------- /theories/Generic.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Program. 7 | Require Import Local.Prelude. 8 | Require Import Local.Substitution. 9 | 10 | (* 11 | WIP! WIP! WIP! WIP! WIP! WIP! WIP! 12 | 13 | The purpose of this file is to come up with a generic representation that we 14 | may use for the CPS-calculus' types, so that I can play with different type 15 | systems and still use the same representation. We're starting with the AACMM 16 | model, but we may deviate from that a bit (as the goals are different). 17 | 18 | Sources: 19 | - https://arxiv.org/pdf/1804.00119 20 | - https://gallais.github.io/pdf/icfp18.pdf 21 | *) 22 | 23 | Import ListNotations. 24 | 25 | Inductive Description (I: Type): Type := 26 | | branch (A: Type) (f: A -> Description I) 27 | | child (is: list I) (i: I) (d: Description I) 28 | | done (i: I). 29 | 30 | Fixpoint reindex {I J: Type} (g: I -> J) (d: Description I): Description J := 31 | match d with 32 | | branch _ A f => branch J A (fun a => reindex g (f a)) 33 | | child _ is i d => child J (map g is) (g i) (reindex g d) 34 | | done _ i => done J (g i) 35 | end. 36 | 37 | Section Interpretation. 38 | 39 | Variable I: Type. 40 | 41 | Definition iscoped: Type := 42 | I -> list I -> Type. 43 | 44 | Fixpoint interpret (d: Description I): (list I -> iscoped) -> iscoped := 45 | fun X i G => 46 | match d with 47 | | branch _ A d => { a: A & interpret (d a) X i G } 48 | | child _ is i d => X is i G * interpret d X i G 49 | | done _ j => i = j 50 | end%type. 51 | 52 | Definition adjust {A: Type} (f: A -> A) (T: A -> Type) (a: A): Type := 53 | T (f a). 54 | 55 | Definition scope: iscoped -> list I -> iscoped := 56 | fun T D i => 57 | adjust (fun G => D ++ G) (T i). 58 | 59 | (* Coq is not happy with this description! Positivity checker is too weak! *) 60 | 61 | (* Inductive Term (d: Description I): iscoped := 62 | | term_var: 63 | forall i is, 64 | nat -> Term d i is 65 | | term_con: 66 | forall i is, 67 | interpret d (scope (Term d)) i is -> Term d i is. *) 68 | 69 | End Interpretation. 70 | 71 | Axiom X: iscoped True. 72 | Definition S: list True -> iscoped True := scope True X. 73 | 74 | Definition UTLC: Description True := 75 | branch _ bool (fun b => 76 | if b then 77 | child _ [] I (child _ [] I (done _ I)) 78 | else 79 | child _ [I] I (done _ I)). 80 | 81 | Local Goal 82 | interpret True UTLC S I []. 83 | Proof. 84 | compute. 85 | exists true. 86 | admit. 87 | Admitted. 88 | 89 | (* 90 | 91 | Variant binder: Set := 92 | | bound 93 | | unbound. 94 | 95 | Definition vector (A: Type) (n: nat): Type := 96 | { xs: list A | length xs = n }. 97 | 98 | Program Definition vector_nil {A: Type}: vector A 0 := 99 | exist _ [] eq_refl. 100 | 101 | Definition Shape (n: nat) (k: nat): Type := 102 | vector (vector binder n) k. 103 | 104 | Section Syntax. 105 | 106 | Variable T: Type. 107 | 108 | Inductive Description: Prop := 109 | | desc_sg (f: T -> Description) 110 | | desc_node (n: nat) (k: nat) (s: Shape n k). 111 | 112 | Variable d: Description. 113 | 114 | Inductive Form: Type := 115 | | form_var: 116 | nat -> Form 117 | | form_const: 118 | Constructor d -> Form 119 | 120 | with Constructor: Description -> Type := 121 | | const_sg: 122 | forall x f, 123 | Constructor (f x) -> Constructor (desc_sg f) 124 | | const_node: 125 | forall n k s, 126 | list Form (* !!! *) -> Constructor (desc_node n k s). 127 | 128 | End Syntax. 129 | 130 | Section Example. 131 | 132 | Local Notation VB := (vector binder _). 133 | 134 | Local Program Definition APP_shape: Shape 0 2 := 135 | [[]: VB; []: VB]. 136 | 137 | Local Program Definition APP {T}: Description T := 138 | (* Zero introduced variables, two subterms. *) 139 | desc_node T 0 2 APP_shape. 140 | 141 | Local Program Definition ABS_shape: Shape 1 1 := 142 | [[bound]: VB]. 143 | 144 | Local Program Definition ABS {T}: Description T := 145 | (* One introduced variable, one subterm. *) 146 | desc_node T 1 1 ABS_shape. 147 | 148 | Local Program Definition UTLC_gen (b: bool): Description bool := 149 | if b then APP else ABS. 150 | 151 | Local Program Definition UTLC: Description bool := 152 | desc_sg bool UTLC_gen. 153 | 154 | Local Definition term: Type := 155 | Form bool UTLC. 156 | 157 | Arguments form_var {T} {d}. 158 | Arguments form_const {T} {d}. 159 | Arguments const_sg {T} {d} x {f}. 160 | Arguments const_node {T} {d} {n} {k} {s}. 161 | 162 | Local Program Definition var (n: nat): term := 163 | form_var n. 164 | 165 | Local Program Definition app (e: term) (f: term): term := 166 | form_const (const_sg false (const_node [e; f])). 167 | 168 | Local Program Definition abs (e: term): term := 169 | form_const (const_sg true (const_node [e])). 170 | 171 | Example identity: term := 172 | abs (var 0). 173 | 174 | End Example. 175 | 176 | *) 177 | -------------------------------------------------------------------------------- /theories/Factorization.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Relations. 6 | Require Import Local.Prelude. 7 | Require Import Local.Substitution. 8 | Require Import Local.Syntax. 9 | Require Import Local.Context. 10 | Require Import Local.AbstractRewriting. 11 | Require Import Local.Equational. 12 | Require Import Local.Reduction. 13 | Require Import Local.Residuals. 14 | Require Import Local.Confluence. 15 | 16 | Import ListNotations. 17 | 18 | (* The following method is present on the "Factorization and Normalization, 19 | Essentially" paper, and was hinted to me by dr. Accattoli through private 20 | communication. This seems way simpler than what I was trying to do. *) 21 | 22 | (* TODO: we have some unusual rules here... perhaps we should name them. *) 23 | 24 | Inductive inner: relation pseudoterm := 25 | | inner_nonstatic_ctxjmp: 26 | forall h xs ts c, 27 | nonstatic h -> 28 | length xs = length ts -> 29 | inner (bind (h (jump #h xs)) ts c) 30 | (bind 31 | (h (apply_parameters xs 0 (lift (S #h) (length ts) c))) 32 | ts c) 33 | | inner_bind_left: 34 | LEFT inner 35 | | inner_bind_right: 36 | forall b ts c1 c2, 37 | beta c1 c2 -> 38 | inner (bind b ts c1) (bind b ts c2). 39 | 40 | Lemma beta_inner: 41 | inclusion inner beta. 42 | Proof. 43 | induction 1; auto with cps. 44 | Qed. 45 | 46 | Global Hint Resolve beta_inner: cps. 47 | 48 | Lemma step_inner: 49 | inclusion inner step. 50 | Proof. 51 | auto with cps. 52 | Qed. 53 | 54 | Global Hint Resolve step_inner: cps. 55 | 56 | Inductive leftmost_marked: bool -> redexes -> Prop := 57 | | leftmost_marked_bound: 58 | forall n, 59 | leftmost_marked false (redexes_bound n) 60 | | leftmost_marked_type: 61 | forall x ts, 62 | leftmost_marked false (redexes_type x ts) 63 | | leftmost_marked_jump: 64 | forall r k xs, 65 | leftmost_marked r (redexes_jump r k xs) 66 | | leftmost_marked_bind: 67 | forall r b ts c, 68 | leftmost_marked r b -> 69 | leftmost_marked r (redexes_bind b ts c). 70 | 71 | Lemma leftmost_marked_mark: 72 | forall b, 73 | leftmost_marked false (mark b). 74 | Proof. 75 | induction b; simpl. 76 | - constructor. 77 | - constructor. 78 | - constructor. 79 | - now constructor. 80 | Qed. 81 | 82 | (* Notice that we are not assuming that parallel inner reduction has at least 83 | one mark as we do in the standard parallel reduction, mostly because there's 84 | no need to. We could, of course, do it anyways. *) 85 | 86 | Definition parallel_inner: relation pseudoterm := 87 | fun b c => 88 | exists2 r, 89 | residuals [] (mark b) r (mark c) & leftmost_marked false r. 90 | 91 | Lemma inner_parallel_inner: 92 | inclusion inner parallel_inner. 93 | Proof. 94 | induction 1. 95 | - (* Very similar to the [parallel_beta] lemma! *) 96 | exists (redexes_bind (mark_context h (redexes_jump true #h xs)) ts 97 | (mark c)); simpl. 98 | + constructor. 99 | * do 2 rewrite <- mark_context_is_sound; simpl. 100 | apply residuals_mark_context. 101 | rewrite mark_apply_parameters_is_sound. 102 | rewrite mark_lift_is_sound. 103 | rewrite <- H0. 104 | constructor. 105 | rewrite <- residuals_context_to_env_length. 106 | apply item_insert_head with (k := 0). 107 | constructor. 108 | * apply residuals_term. 109 | + (* Clearly true, as h is nonstatic! *) 110 | constructor; clear c. 111 | generalize (redexes_jump true #h xs) as c; intros. 112 | clear H0 xs ts. 113 | induction H using nonstatic_ind; simpl; intros. 114 | * constructor. 115 | apply leftmost_marked_mark. 116 | * now constructor. 117 | - destruct IHinner as (r, ?, ?). 118 | exists (redexes_bind r ts (mark c)); simpl. 119 | + constructor. 120 | * now apply residuals_tail with (g := []). 121 | * rewrite app_nil_r. 122 | apply residuals_term. 123 | + now constructor. 124 | - apply parallel_beta in H as (r, ?, ?). 125 | exists (redexes_bind (mark b) ts r); simpl. 126 | + constructor. 127 | * apply residuals_term. 128 | * now apply residuals_tail with (g := []). 129 | + constructor. 130 | apply leftmost_marked_mark. 131 | Qed. 132 | 133 | Local Hint Resolve inner_parallel_inner: cps. 134 | 135 | Lemma parallel_inner_rt_inner: 136 | inclusion parallel_inner rt(inner). 137 | Proof. 138 | admit. 139 | Admitted. 140 | 141 | Local Hint Resolve parallel_inner_rt_inner: cps. 142 | 143 | Lemma rt_inner_and_rt_parallel_inner_are_equivalent: 144 | same_relation rt(inner) rt(parallel_inner). 145 | Proof. 146 | split; induction 1; eauto with cps. 147 | Qed. 148 | 149 | Lemma macro_merge: 150 | inclusion (comp parallel_inner head) parallel. 151 | Proof. 152 | admit. 153 | Admitted. 154 | 155 | Lemma macro_split: 156 | inclusion parallel (comp rt(head) parallel_inner). 157 | Proof. 158 | admit. 159 | Admitted. 160 | 161 | (* TODO: move and generalize this (Accattoli's method) to the abstract rewriting 162 | file, and then just use it here. *) 163 | 164 | Theorem factorization: 165 | inclusion rt(beta) (comp rt(head) rt(inner)). 166 | Proof. 167 | assert (inclusion rt(union head parallel_inner) 168 | (comp rt(head) rt(parallel_inner))). 169 | - apply local_postponement. 170 | unfold postpones, inclusion; intros. 171 | destruct macro_split with x y as (z, ?, ?). 172 | + apply macro_merge; auto. 173 | + exists z; auto with cps. 174 | - unfold inclusion; intros. 175 | destruct H with x y as (z, ?, ?). 176 | + clear H. 177 | induction H0; eauto with cps. 178 | apply parallel_beta in H. 179 | apply macro_split in H. 180 | destruct H as (z, ?, ?). 181 | apply rt_trans with z. 182 | * clear H0 y. 183 | induction H; eauto with cps. 184 | * auto with cps. 185 | + apply rt_inner_and_rt_parallel_inner_are_equivalent in H2. 186 | eauto with cps. 187 | Qed. 188 | 189 | Corollary rt_beta_characterization: 190 | same_relation rt(beta) (comp rt(head) rt(inner)). 191 | Proof. 192 | split. 193 | - apply factorization. 194 | - intros x z ?. 195 | (* Clearly true. *) 196 | destruct H as (y, ?, ?). 197 | apply rt_trans with y. 198 | + clear H0 z. 199 | induction H; eauto with cps. 200 | + clear H x. 201 | induction H0; eauto with cps. 202 | Qed. 203 | -------------------------------------------------------------------------------- /theories/Lambda/ModifiedCBV.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | (* TODO: question, is Kennedy's translation (the tail-recursive version) really 6 | the same as Plotkin's CBV then administrative reductions (linear jumps)? I am 7 | starting to think that maybe there's need for some floating too... *) 8 | 9 | Require Import Lia. 10 | Require Import List. 11 | Require Import Local.Prelude. 12 | Require Import Local.AbstractRewriting. 13 | Require Import Local.Substitution. 14 | Require Import Local.Lambda.Calculus. 15 | Require Import Local.Lambda.PlotkinCBV. 16 | Require Local.Residuals. 17 | 18 | Import ListNotations. 19 | 20 | Section ModifiedCBV. 21 | 22 | Local Notation jump := Residuals.redexes_jump. 23 | Local Notation bind := Residuals.redexes_bind. 24 | Local Notation V := CPS.void. 25 | 26 | Local Notation VAR d n := 27 | (* [x] = k *) 28 | (jump d (var 0) [var (1 + n)]) (only parsing). 29 | 30 | Local Notation ABS d b t1 t2 := 31 | (* [\x.e] = k { f = [e] } *) 32 | (bind (jump d (var 1) [var 0]) [t1; t2] b) (only parsing). 33 | 34 | Local Notation APP b c t1 t2 := 35 | (* [e f] = [e] { k = [f] { k = f } } *) 36 | (bind b [t1] (bind c [t2] 37 | (jump false (var 1) [var 2; var 0]))) (only parsing). 38 | 39 | (* The modified CBV translation is just Plotkin's CBV translation, but instead 40 | it returns marked terms. We underline every jump to a current continuation 41 | whose content is defined and thus the jump may be performed. We define two 42 | versions by mutual induction (note the first argument, being a boolean), so 43 | that we may know whether the current continuation is defined or not. *) 44 | 45 | Inductive modified_cbv_cps: bool -> term -> Residuals.redexes -> Prop := 46 | | modified_cbv_cps_bound: 47 | forall d n, 48 | modified_cbv_cps d (var n) (VAR d n) 49 | | modified_cbv_cps_abstraction: 50 | forall d t e b, 51 | modified_cbv_cps false (lift 1 1 e) b -> 52 | modified_cbv_cps d (abstraction t e) (ABS d b CPS.void CPS.void) 53 | | modified_cbv_cps_application: 54 | forall d f x b c, 55 | modified_cbv_cps true (lift 1 0 f) b -> 56 | modified_cbv_cps true (lift 2 0 x) c -> 57 | modified_cbv_cps d (application f x) (APP b c CPS.void CPS.void) 58 | (* TODO: extend this translation for thunks. *). 59 | 60 | (* The modified CBV translation is merely Plotkin's translation, but we mark 61 | each jump to the current continuation which is a redex. *) 62 | 63 | Local Goal 64 | forall d e r, 65 | modified_cbv_cps d e r -> 66 | cbv_cps e (Residuals.unmark r). 67 | Proof. 68 | induction 1; intros; simpl. 69 | - constructor. 70 | - now constructor. 71 | - now constructor. 72 | Qed. 73 | 74 | Lemma modified_cbv_residuals_generalized: 75 | forall b e r, 76 | modified_cbv_cps b e r -> 77 | forall g, 78 | (if b then (* Not ideal to use a conditional here, but it works... *) 79 | exists2 s, 80 | item (Some (1, s)) g 0 & Residuals.redexes_count s = 0 81 | else 82 | True) -> 83 | exists2 t, 84 | Residuals.residuals g r r t & Residuals.redexes_count t = 0. 85 | Proof. 86 | induction 1; intros. 87 | - (* Are we performing this jump...? *) 88 | destruct d. 89 | + (* If we are, we know that it's defined: this was administrative. *) 90 | destruct H as (s, ?, ?). 91 | eexists. 92 | * constructor; simpl. 93 | eassumption. 94 | * simpl. 95 | rewrite Residuals.mark_unmark_is_sound with s by auto. 96 | rewrite <- Residuals.mark_lift_is_sound. 97 | rewrite <- Residuals.mark_apply_parameters_is_sound. 98 | apply Residuals.redexes_count_mark. 99 | + (* No jump will be performed, so no problem. *) 100 | eexists. 101 | * constructor. 102 | * reflexivity. 103 | - specialize (IHmodified_cbv_cps (None :: None :: g) ltac:(trivial)). 104 | destruct IHmodified_cbv_cps as (b', ?, ?). 105 | destruct d. 106 | + destruct H0 as (s, ?, ?). 107 | eexists; try constructor; simpl. 108 | * do 2 constructor; simpl. 109 | eassumption. 110 | * eassumption. 111 | * simpl. 112 | rewrite Residuals.mark_unmark_is_sound with s by auto. 113 | rewrite <- Residuals.mark_lift_is_sound. 114 | rewrite <- Residuals.mark_apply_parameters_is_sound. 115 | rewrite Residuals.redexes_count_mark. 116 | now simpl. 117 | + eexists; try constructor; simpl. 118 | * constructor. 119 | * eassumption. 120 | * simpl; lia. 121 | - (* The continuation given to c will be our anchor, which should be put in 122 | place, but that itself will not be performed as it represents a source 123 | redex. *) 124 | set (anchor := jump false (var 1) [var 2; var 0]). 125 | specialize (IHmodified_cbv_cps2 (Some (1, anchor) :: None :: g)). 126 | (* By induction, c is fine. *) 127 | edestruct IHmodified_cbv_cps2 as (c', ?, ?); intros. 128 | + eexists; eauto with cps. 129 | + (* The continuation given to b will be c (along with the anchor), which 130 | is expected to be performed. *) 131 | specialize (IHmodified_cbv_cps1 (Some (1, bind c' [V] anchor) :: g)). 132 | (* By induction, b is fine. *) 133 | edestruct IHmodified_cbv_cps1 as (b', ?, ?); intros. 134 | * eexists; eauto with cps. 135 | simpl; lia. 136 | * eexists; eauto with cps. 137 | (* None of these items have marks anymore. *) 138 | simpl; lia. 139 | Qed. 140 | 141 | Lemma modified_cbv_residuals: 142 | forall e r, 143 | modified_cbv_cps false e r -> 144 | exists2 s, 145 | Residuals.residuals [] r r s & Residuals.redexes_count s = 0. 146 | Proof. 147 | intros. 148 | apply modified_cbv_residuals_generalized with false e; intros. 149 | - assumption. 150 | - trivial. 151 | Qed. 152 | 153 | Lemma modified_cbv_regular: 154 | forall e r, 155 | modified_cbv_cps false e r -> 156 | Residuals.regular r. 157 | Proof. 158 | intros. 159 | destruct modified_cbv_residuals with e r as (s, ?, ?). 160 | - assumption. 161 | - now exists r, s. 162 | Qed. 163 | 164 | (* Main idea: do the CPS translation, take the residuals, and then perform 165 | exhaustive garbage collection to remove all the inlined contexts. NOTE: 166 | this will NOT work anymore once we introduce thunks and then we'll need be 167 | a bit smarter. TODO: I'll leave this task for future me. To do this in the 168 | proper way, we'll either actually perform garbage collection for the marked 169 | terms alone, OR we could use the notion of an intuitionistic term and show 170 | there are no unused continuations. Are unused thunks actually fine? TODO: 171 | check Danvy and Filinski's paper! *) 172 | 173 | Inductive optimal_cbv_cps: term -> Syntax.pseudoterm -> Prop := 174 | | optimal_cbv_cps_mk: 175 | forall e r b c, 176 | (* The toplevel continuation is not defined, hence false. *) 177 | modified_cbv_cps false e r -> 178 | (* This is expected to work on any context, so the empty one suffices, 179 | producing a term with no marks. *) 180 | Residuals.residuals [] r r (Residuals.mark b) -> 181 | (* Then just perform all garbage collection available. *) 182 | rt(Reduction.smol) b c -> 183 | normal Reduction.smol c -> 184 | optimal_cbv_cps e c. 185 | 186 | End ModifiedCBV. 187 | -------------------------------------------------------------------------------- /theories/Constructions/Calculus.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import Arith. 7 | Require Import Local.Prelude. 8 | Require Import Local.Substitution. 9 | 10 | Variant universe: Set := 11 | | iset 12 | | type (n: nat). 13 | 14 | Definition supremum (s1: universe) (s2: universe) := 15 | match s1, s2 with 16 | | _, iset => s1 17 | | iset, _ => s2 18 | | type n, type m => type (max n m) 19 | end. 20 | 21 | Definition sort_of_product (s1: universe) (s2: universe) := 22 | if s2 (* is iset *) then 23 | iset 24 | else 25 | supremum s1 s2. 26 | 27 | Inductive term: Set := 28 | (* Sorts. *) 29 | | sort (s: universe) 30 | (* Variables. *) 31 | | bound (n: nat) 32 | (* Products. *) 33 | | pi (t: term) (u: term) 34 | | abstraction (t: term) (e: term) 35 | | application (e: term) (f: term) 36 | | definition (e: term) (t: term) (f: term) 37 | (* Pairs. *) 38 | | sigma (t: term) (u: term) 39 | | pair (e: term) (f: term) (t: term) 40 | | proj1 (e: term) 41 | | proj2 (e: term) 42 | (* Booleans. *) 43 | | boolean 44 | | bool_tt 45 | | bool_ff 46 | | bool_if (e: term) (t: term) (f1: term) (f2: term) 47 | (* Thunks. *) 48 | | thunk (t: term) 49 | | delay (e: term) 50 | | force (e: term). 51 | 52 | Global Coercion sort: universe >-> term. 53 | 54 | Fixpoint traverse g k e: term := 55 | match e with 56 | | sort u => 57 | sort u 58 | | bound n => 59 | g k n 60 | | pi t u => 61 | pi (traverse g k t) (traverse g (S k) u) 62 | | abstraction t e => 63 | abstraction (traverse g k t) (traverse g (S k) e) 64 | | application e f => 65 | application (traverse g k e) (traverse g k f) 66 | | definition e t f => 67 | definition (traverse g k e) (traverse g k t) (traverse g (S k) f) 68 | | sigma t u => 69 | sigma (traverse g k t) (traverse g (S k) u) 70 | | pair e f t => 71 | pair (traverse g k e) (traverse g k f) (traverse g k t) 72 | | proj1 e => 73 | proj1 (traverse g k e) 74 | | proj2 e => 75 | proj2 (traverse g k e) 76 | | boolean => 77 | boolean 78 | | bool_tt => 79 | bool_tt 80 | | bool_ff => 81 | bool_ff 82 | | bool_if e t f1 f2 => 83 | let rec := traverse in 84 | bool_if (rec g k e) (rec g (S k) t) (rec g k f1) (rec g k f2) 85 | | thunk t => 86 | thunk (traverse g k t) 87 | | delay e => 88 | delay (traverse g k e) 89 | | force e => 90 | force (traverse g k e) 91 | end. 92 | 93 | Global Instance cc_dbVar: dbVar term := 94 | bound. 95 | 96 | Global Instance cc_dbTraverse: dbTraverse term term := 97 | traverse. 98 | 99 | Global Instance cc_dbVarLaws: dbVarLaws term. 100 | Proof. 101 | split; auto. 102 | Qed. 103 | 104 | Global Instance cc_dbTraverseLaws: dbTraverseLaws term term. 105 | Proof. 106 | split; unfold Substitution.traverse; intros. 107 | - generalize dependent k. 108 | induction x; simpl; auto; intros; 109 | f_equal; auto. 110 | - apply (H k (bound n)). 111 | - generalize dependent j. 112 | generalize dependent k. 113 | induction x; simpl; auto; intros; 114 | try now (f_equal; auto). 115 | + apply (H 0). 116 | + f_equal. 117 | * apply IHx1; intros. 118 | apply H. 119 | * apply IHx2; intros. 120 | replace (l + S k) with (S l + k) by lia. 121 | replace (l + S j) with (S l + j) by lia. 122 | apply H. 123 | + f_equal. 124 | * apply IHx1; intros. 125 | apply H. 126 | * apply IHx2; intros. 127 | replace (l + S k) with (S l + k) by lia. 128 | replace (l + S j) with (S l + j) by lia. 129 | apply H. 130 | + f_equal. 131 | * apply IHx1; intros. 132 | apply H. 133 | * apply IHx2; intros. 134 | apply H. 135 | * apply IHx3; intros. 136 | replace (l + S k) with (S l + k) by lia. 137 | replace (l + S j) with (S l + j) by lia. 138 | apply H. 139 | + f_equal. 140 | * apply IHx1; intros. 141 | apply H. 142 | * apply IHx2; intros. 143 | replace (l + S k) with (S l + k) by lia. 144 | replace (l + S j) with (S l + j) by lia. 145 | apply H. 146 | + f_equal. 147 | * apply IHx1; intros. 148 | apply H. 149 | * apply IHx2; intros. 150 | replace (l + S k) with (S l + k) by lia. 151 | replace (l + S j) with (S l + j) by lia. 152 | apply H. 153 | * apply IHx3; intros. 154 | apply H. 155 | * apply IHx4; intros. 156 | apply H. 157 | - generalize dependent k. 158 | induction x; simpl; intros; auto; 159 | f_equal; auto. 160 | Qed. 161 | 162 | Inductive context: Set := 163 | | context_hole 164 | | context_pi_type (t: context) (u: term) 165 | | context_pi_body (t: term) (u: context) 166 | | context_abs_type (t: context) (e: term) 167 | | context_abs_body (t: term) (e: context) 168 | | context_app_left (f: context) (e: term) 169 | | context_app_right (f: term) (e: context) 170 | | context_def_val (e: context) (t: term) (f: term) 171 | | context_def_type (e: term) (t: context) (f: term) 172 | | context_def_body (e: term) (t: term) (f: context) 173 | | context_sigma_type (t: context) (u: term) 174 | | context_sigma_body (t: term) (u: context) 175 | | context_pair_left (e: context) (f: term) (t: term) 176 | | context_pair_right (e: term) (f: context) (t: term) 177 | | context_pair_type (e: term) (f: term) (t: context) 178 | | context_proj1 (e: context) 179 | | context_proj2 (e: context) 180 | | context_if_term (e: context) (t: term) (f1: term) (f2: term) 181 | | context_if_type (e: term) (t: context) (f1: term) (f2: term) 182 | | context_if_then (e: term) (t: term) (f1: context) (f2: term) 183 | | context_if_else (e: term) (t: term) (f1: term) (f2: context) 184 | | context_thunk (t: context) 185 | | context_delay (e: context) 186 | | context_force (e: context). 187 | 188 | Fixpoint apply_context (h: context) (x: term): term := 189 | match h with 190 | | context_hole => 191 | x 192 | | context_pi_type t u => 193 | pi (apply_context t x) u 194 | | context_pi_body t u => 195 | pi t (apply_context u x) 196 | | context_abs_type t e => 197 | abstraction (apply_context t x) e 198 | | context_abs_body t e => 199 | abstraction t (apply_context e x) 200 | | context_app_left f e => 201 | application (apply_context f x) e 202 | | context_app_right f e => 203 | application f (apply_context e x) 204 | | context_def_val e t f => 205 | definition (apply_context e x) t f 206 | | context_def_type e t f => 207 | definition e (apply_context t x) f 208 | | context_def_body e t f => 209 | definition e t (apply_context f x) 210 | | context_sigma_type t u => 211 | sigma (apply_context t x) u 212 | | context_sigma_body t u => 213 | sigma t (apply_context u x) 214 | | context_pair_left e f t => 215 | pair (apply_context e x) f t 216 | | context_pair_right e f t => 217 | pair e (apply_context f x) t 218 | | context_pair_type e f t => 219 | pair e f (apply_context t x) 220 | | context_proj1 e => 221 | proj1 (apply_context e x) 222 | | context_proj2 e => 223 | proj2 (apply_context e x) 224 | | context_if_term e t f1 f2 => 225 | bool_if (apply_context e x) t f1 f2 226 | | context_if_type e t f1 f2 => 227 | bool_if e (apply_context t x) f1 f2 228 | | context_if_then e t f1 f2 => 229 | bool_if e t (apply_context f1 x) f2 230 | | context_if_else e t f1 f2 => 231 | bool_if e t f1 (apply_context f2 x) 232 | | context_thunk t => 233 | thunk (apply_context t x) 234 | | context_delay e => 235 | delay (apply_context e x) 236 | | context_force e => 237 | force (apply_context e x) 238 | end. 239 | 240 | Coercion apply_context: context >-> Funclass. 241 | 242 | Definition decl: Set := 243 | option term * term. 244 | 245 | Definition decl_var (t: term): decl := 246 | (None, t). 247 | 248 | Definition decl_def (e: term) (t: term): decl := 249 | (Some e, t). 250 | 251 | Definition env: Set := 252 | list decl. 253 | 254 | Inductive value: term -> Prop := 255 | | value_sort: 256 | forall s, 257 | value (sort s) 258 | | value_bound: 259 | forall n, 260 | value (bound n) 261 | | value_pi: 262 | forall t u, 263 | value (pi t u) 264 | | value_abstraction: 265 | forall t e, 266 | value (abstraction t e) 267 | | value_sigma: 268 | forall t u, 269 | value (sigma t u) 270 | | value_pair: 271 | forall e f t, 272 | value e -> 273 | value f -> 274 | value (pair e f t) 275 | | value_true: 276 | value bool_tt 277 | | value_false: 278 | value bool_ff 279 | (* TODO: thunks... *). 280 | 281 | Global Hint Constructors value: cps. 282 | -------------------------------------------------------------------------------- /theories/Syntax.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Arith. 7 | Require Import Equality. 8 | Require Import Local.Prelude. 9 | Require Import Local.AbstractRewriting. 10 | Require Import Local.Substitution. 11 | 12 | Import ListNotations. 13 | 14 | (** ** Syntax 15 | 16 | In the original formulation for this code, such as presented in the ICFP 24 17 | paper [...], we had types directly encoded in the syntax for terms. [...] *) 18 | 19 | Variant type_tag: Set := 20 | | VOID 21 | | BASE 22 | | NEGATION. 23 | 24 | (** [...]. *) 25 | 26 | Inductive pseudoterm: Set := 27 | | bound (n: nat) 28 | | type (x: type_tag) (xs: list pseudoterm) 29 | | jump (f: pseudoterm) (xs: list pseudoterm) 30 | | bind (b: pseudoterm) (ts: list pseudoterm) (c: pseudoterm). 31 | 32 | Coercion bound: nat >-> pseudoterm. 33 | 34 | Global Notation void := 35 | (type VOID []). 36 | 37 | Global Notation base := 38 | (type BASE []). 39 | 40 | Global Notation negation ts := 41 | (type NEGATION ts). 42 | 43 | (** A simple example. 44 | 45 | We use a lambda syntax to bind the name of free variables for illustration 46 | purposes. Notice that in the written syntax, the most recent term (index 0) 47 | is at the rightmost position, while in the abstract syntax we use here it's 48 | the leftmost one, so we always write lists (of types or terms) inverted. As 49 | such, [ex1] is equivalent to the following term: 50 | 51 | \j.\x.\y.\z. 52 | h@1 53 | { k = 54 | h@2 } 55 | { h = 56 | d@1 } 57 | *) 58 | 59 | Example ex1: pseudoterm := 60 | (bind (bind 61 | (jump 1 [bound 4; bound 0; bound 3]) 62 | [base; base] 63 | (jump 2 [bound 1; bound 6; bound 0])) 64 | [base; negation [base; base]; base] 65 | (jump 1 [bound 3; bound 0])). 66 | 67 | (** ... *) 68 | 69 | Lemma pseudoterm_deepind: 70 | forall P: pseudoterm -> Prop, 71 | forall f1: (forall n, P (bound n)), 72 | forall f2: (forall x ts, Forall P ts -> P (type x ts)), 73 | forall f3: (forall k xs, P k -> Forall P xs -> P (jump k xs)), 74 | forall f4: (forall b ts c, P b -> Forall P ts -> P c -> P (bind b ts c)), 75 | forall e, 76 | P e. 77 | Proof. 78 | do 5 intro. 79 | fix IH 1; destruct e. 80 | (* Case: bound. *) 81 | - apply f1. 82 | (* Case: type. *) 83 | - apply f2. 84 | induction xs. 85 | + constructor. 86 | + constructor; auto. 87 | (* Case: jump. *) 88 | - apply f3; auto. 89 | induction xs. 90 | + constructor. 91 | + constructor; auto. 92 | (* Case: bind. *) 93 | - apply f4; auto. 94 | induction ts. 95 | + constructor. 96 | + constructor; auto. 97 | Qed. 98 | 99 | (** Equality on pseudoterms (and pseudotypes) is decidable. *) 100 | 101 | Lemma pseudoterm_eq_dec: 102 | forall b c: pseudoterm, 103 | { b = c } + { b <> c }. 104 | Proof with try now (right; congruence). 105 | fix IH 1; intros. 106 | destruct b; destruct c... 107 | (* Case: bound. *) 108 | - destruct Nat.eq_dec with n n0... 109 | subst; now left. 110 | (* Case: type. *) 111 | - assert ({ x = x0 } + { x <> x0 }) as [ ? | ? ]... 112 | + decide equality. 113 | + assert ({ xs = xs0 } + { xs <> xs0 }) as [ ? | ? ]... 114 | * now apply list_eq_dec. 115 | * subst; now left. 116 | (* Case: jump. *) 117 | - destruct IH with b c... 118 | assert ({ xs = xs0 } + { xs <> xs0 }) as [ ? | ? ]... 119 | + now apply list_eq_dec. 120 | + subst; now left. 121 | (* Case: bind. *) 122 | - destruct IH with b1 c1... 123 | destruct IH with b2 c2... 124 | assert ({ ts = ts0 } + { ts <> ts0 }) as [ ? | ? ]... 125 | + now apply list_eq_dec. 126 | + subst; now left. 127 | Qed. 128 | 129 | (* TODO: do we actually need this anymore...? Try removing this definition! *) 130 | 131 | Definition traverse_list {T} f k: list T -> list T := 132 | fold_right (fun t ts => f (length ts + k) t :: ts) []. 133 | 134 | Definition type_binder x i := 135 | match x, i with 136 | | VOID, _ => 0 137 | | BASE, _ => 0 138 | | NEGATION, _ => i 139 | end. 140 | 141 | Definition traverse_type {T} x f k: list T -> list T := 142 | fold_right (fun t ts => f (type_binder x (length ts) + k) t :: ts) []. 143 | 144 | Local Goal 145 | forall {T} f k ts, 146 | @map T T (f k) ts = @traverse_type T BASE f k ts. 147 | Proof. 148 | auto. 149 | Qed. 150 | 151 | Local Goal 152 | forall {T} f k ts, 153 | @traverse_list T f k ts = @traverse_type T NEGATION f k ts. 154 | Proof. 155 | auto. 156 | Qed. 157 | 158 | Fixpoint traverse f k e: pseudoterm := 159 | match e with 160 | | bound n => 161 | f k n 162 | | type x ts => 163 | type x (traverse_type x (traverse f) k ts) 164 | | jump x xs => 165 | jump (traverse f k x) (map (traverse f k) xs) 166 | | bind b ts c => 167 | bind (traverse f (S k) b) (traverse_list (traverse f) k ts) 168 | (traverse f (k + length ts) c) 169 | end. 170 | 171 | Global Instance pseudoterm_dbVar: dbVar pseudoterm := 172 | bound. 173 | 174 | Global Instance pseudoterm_dbTraverse: dbTraverse pseudoterm pseudoterm := 175 | traverse. 176 | 177 | (* -------------------------------------------------------------------------- *) 178 | 179 | (* TODO: rename... or, appropriately, find a way for sigma to derive this. *) 180 | 181 | Lemma bound_var_equality_stuff: 182 | forall n, 183 | bound n = var n. 184 | Proof. 185 | auto. 186 | Qed. 187 | 188 | Lemma inst_distributes_over_type: 189 | forall s x ts, 190 | inst s (type x ts) = type x (traverse_type x s 0 ts). 191 | Proof. 192 | auto. 193 | Qed. 194 | 195 | Lemma inst_distributes_over_jump: 196 | forall s x xs, 197 | inst s (jump x xs) = jump (s 0 x) (smap s 0 xs). 198 | Proof. 199 | auto. 200 | Qed. 201 | 202 | Lemma inst_distributes_over_bind: 203 | forall s b ts c, 204 | inst s (bind b ts c) = bind (s 1 b) (bsmap s 0 ts) (s (length ts) c). 205 | Proof. 206 | auto. 207 | Qed. 208 | 209 | Global Hint Rewrite bound_var_equality_stuff using sigma_solver: sigma. 210 | Global Hint Rewrite inst_distributes_over_type using sigma_solver: sigma. 211 | Global Hint Rewrite inst_distributes_over_jump using sigma_solver: sigma. 212 | Global Hint Rewrite inst_distributes_over_bind using sigma_solver: sigma. 213 | 214 | (* -------------------------------------------------------------------------- *) 215 | 216 | Definition apply_parameters (ys: list pseudoterm): substitution := 217 | subst_app ys subst_ids. 218 | 219 | Definition switch_bindings: substitution := 220 | subst_app [bound 1; bound 0] (subst_lift 2). 221 | 222 | (* TODO: there's a "seq" fixpoint on Coq's List module. We should use it! *) 223 | 224 | Fixpoint sequence (i: nat) (n: nat): list pseudoterm := 225 | match n with 226 | | 0 => [] 227 | | S m => bound i :: sequence (1 + i) m 228 | end. 229 | 230 | Global Hint Unfold sequence: cps. 231 | 232 | Notation high_sequence := (sequence 1). 233 | Notation low_sequence := (sequence 0). 234 | 235 | Definition right_cycle (i: nat): substitution := 236 | subst_app (high_sequence i ++ [bound 0]) (subst_lift (S i)). 237 | 238 | Global Hint Unfold right_cycle: cps. 239 | 240 | Definition left_cycle i k e := 241 | subst (bound i) k (lift 1 (1 + i + k) e). 242 | 243 | Global Hint Unfold left_cycle: cps. 244 | 245 | Definition remove_binding k e: pseudoterm := 246 | subst (bound 0) k e. 247 | 248 | Inductive not_free: nat -> pseudoterm -> Prop := 249 | | not_free_bound: 250 | forall n m, 251 | n <> m -> not_free n m 252 | | not_free_type: 253 | forall x n ts, 254 | not_free_list x n ts -> 255 | not_free n (type x ts) 256 | | not_free_jump: 257 | forall n x ts, 258 | not_free n x -> 259 | Forall (not_free n) ts -> 260 | not_free n (jump x ts) 261 | | not_free_bind: 262 | forall n b ts c, 263 | not_free (S n) b -> 264 | not_free_list NEGATION n ts -> 265 | not_free (length ts + n) c -> 266 | not_free n (bind b ts c) 267 | 268 | (* Checks a list following a type binder descriptor. *) 269 | with not_free_list: type_tag -> nat -> list pseudoterm -> Prop := 270 | | not_free_list_nil: 271 | forall x n, 272 | not_free_list x n [] 273 | | not_free_list_cons: 274 | forall x n t ts, 275 | not_free (type_binder x (length ts) + n) t -> 276 | not_free_list x n ts -> 277 | not_free_list x n (t :: ts). 278 | 279 | Global Hint Constructors not_free: cps. 280 | Global Hint Constructors not_free_list: cps. 281 | 282 | Definition free n e: Prop := 283 | ~not_free n e. 284 | 285 | Global Hint Unfold free: cps. 286 | 287 | Inductive subterm: relation pseudoterm := 288 | | subterm_bind_left: 289 | forall b ts c, 290 | subterm b (bind b ts c) 291 | | subterm_bind_right: 292 | forall b ts c, 293 | subterm c (bind b ts c). 294 | 295 | Fixpoint size (c: pseudoterm): nat := 296 | match c with 297 | | bind b ts c => 298 | 1 + size b + size c 299 | | _ => 300 | 0 301 | end. 302 | -------------------------------------------------------------------------------- /theories/Lambda/ANF.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2023 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import Arith. 7 | Require Import Equality. 8 | Require Import Local.Prelude. 9 | Require Import Local.AbstractRewriting. 10 | Require Import Local.Substitution. 11 | Require Export Local.Lambda.Calculus. 12 | Require Export Local.Lambda.PlotkinCBV. 13 | 14 | (* The following comes from Sabry and Felleisen's "Reasoning About Programs in 15 | Continuation-Passing Style"... this is the set of A-reductions, which extends 16 | Plotkin's CBV calculus. We can compare the reduction rules from here to the 17 | companion paper, "The Essence of Compiling with Continuations". We expect a 18 | few things from here: (1) the simulation should extend to A, I hope, (2) that 19 | there should be a Galois connection between the CPS-calculus and the ANF 20 | calculus, so that we can reuse our operational semantics in there. 21 | 22 | Additionaly, we could prove the results from the above paper, as a treat. *) 23 | 24 | Inductive evaluation: context -> Prop := 25 | | evaluation_hole: 26 | evaluation context_hole 27 | | evaluation_application_left: 28 | forall f x, 29 | evaluation f -> 30 | evaluation (context_application_left f x) 31 | | evaluation_application_right: 32 | forall v x, 33 | evaluation x -> 34 | value v -> 35 | evaluation (context_application_right v x). 36 | 37 | Local Goal 38 | forall e1 e2, 39 | cbv e1 e2 -> 40 | forall h, 41 | evaluation h -> 42 | cbv (h e1) (h e2). 43 | Proof. 44 | induction 2; simpl. 45 | - assumption. 46 | - constructor. 47 | assumption. 48 | - constructor. 49 | + assumption. 50 | + assumption. 51 | Qed. 52 | 53 | Local Notation ABS := abstraction. 54 | Local Notation APP := application. 55 | 56 | (* Beware of de Bruijn math below. I wish there was a better way to do this. *) 57 | 58 | Inductive anf: relation term := 59 | (* Eta-v: \x.V x -> V, given x not free in V. *) 60 | | anf_etav: 61 | forall t V, 62 | value V -> 63 | not_free 0 V -> 64 | anf (ABS t (APP V 0)) V 65 | (* Beta-lift: E[(\x.M) N] -> (\x.E[M]) N, if x not free in E. This can be 66 | split in two cases, since allowing E to be just a hole would lead to a 67 | reflexive relation. *) 68 | | anf_beta_lift_left: 69 | (* Sigma-1: (\x.M) N L -> (\x.M L) N *) 70 | forall t M N L, 71 | anf (APP (APP (ABS t M) N) L) 72 | (APP (ABS t (APP M (lift 1 0 L))) N) 73 | | anf_beta_lift_right: 74 | (* Sigma-3: V ((\x.M) N) -> (\x.V M) N *) 75 | forall V t M N, 76 | value V -> 77 | anf (APP V (APP (ABS t M) N)) 78 | (APP (ABS t (APP (lift 1 0 V) M)) N) 79 | (* Beta-flat: E[M N L] -> (\x.E[x L]) (M N), if x not free in E, L. We are 80 | free to ignore E in here, because performing a beta-flat in here will then 81 | make a beta-lift redex, resulting in the expected term. *) 82 | | anf_beta_flat: 83 | forall t M N L, 84 | anf (APP (APP M N) L) 85 | (APP (ABS t (APP 0 (lift 1 0 L))) (APP M N)) 86 | (* Beta-id: (\x.x) M -> M. *) 87 | | anf_beta_id: 88 | forall t M, 89 | anf (APP (ABS t 0) M) M 90 | (* Beta-omega: (\x.E[y x]) M -> E[y M], if x not free in E[y]. Is there a way 91 | to factor this so that we don't need the E...? *) 92 | | anf_beta_omega: 93 | forall t E x y M, 94 | evaluation E -> 95 | x = context_bvars E -> 96 | y <> context_bvars E -> 97 | anf (APP (ABS t (context_lift 1 0 E (APP (lift 1 x (bound y)) x))) M) 98 | (E (APP y (lift x 0 M))). 99 | 100 | (* Count the number of applications on the left-hand side of an application. *) 101 | 102 | Fixpoint unnamed_subterms e: nat := 103 | match e with 104 | | bound _ => 105 | 0 106 | | abstraction _ b => 107 | unnamed_subterms b 108 | | application (application _ _ as f) x => 109 | 1 + unnamed_subterms f + unnamed_subterms x 110 | | application f x => 111 | unnamed_subterms f + unnamed_subterms x 112 | (* TODO: what about pairs and thunks? *) 113 | | _ => 114 | 0 115 | end. 116 | 117 | Lemma unnamed_subterms_lift: 118 | forall e i k, 119 | unnamed_subterms (lift i k e) = unnamed_subterms e. 120 | Proof. 121 | sigma. 122 | induction e; sigma; simpl; intros. 123 | - destruct (le_gt_dec k n); sigma; auto. 124 | - apply IHe. 125 | - rewrite IHe1, IHe2. 126 | destruct e1; simpl; auto. 127 | destruct (le_gt_dec k n); sigma; auto. 128 | - reflexivity. 129 | - reflexivity. 130 | Qed. 131 | 132 | Lemma unnamed_subterms_context_lift: 133 | forall h i k e, 134 | unnamed_subterms (context_lift i k h e) = unnamed_subterms (h e). 135 | Proof. 136 | induction h; simpl; intros. 137 | - reflexivity. 138 | - apply IHh. 139 | - rewrite unnamed_subterms_lift. 140 | rewrite IHh; destruct h; simpl; auto. 141 | - rewrite unnamed_subterms_lift. 142 | rewrite IHh; destruct f; simpl; auto. 143 | destruct (le_gt_dec k n); sigma; auto. 144 | - reflexivity. 145 | - reflexivity. 146 | Qed. 147 | 148 | Notation cmp a b := (a = b \/ a > b). 149 | 150 | Local Goal 151 | forall a b, 152 | anf a b -> 153 | cmp (unnamed_subterms a) (unnamed_subterms b). 154 | Proof. 155 | induction 1; intros. 156 | (* Case: eta-v. *) 157 | - left. 158 | destruct H; simpl; lia. 159 | (* Case: sigma-1. *) 160 | - destruct M; simpl. 161 | + right. 162 | rewrite unnamed_subterms_lift. 163 | lia. 164 | + right. 165 | rewrite unnamed_subterms_lift. 166 | lia. 167 | + (* Here it decreases! *) 168 | left. 169 | rewrite unnamed_subterms_lift. 170 | lia. 171 | + right. 172 | rewrite unnamed_subterms_lift. 173 | lia. 174 | + right. 175 | rewrite unnamed_subterms_lift. 176 | lia. 177 | (* Case: sigma-3. *) 178 | - left. 179 | destruct H; simpl. 180 | + auto. 181 | + rewrite unnamed_subterms_lift. 182 | sigma; simpl. 183 | lia. 184 | + auto. 185 | (* Case: beta-flat. *) 186 | - (* Here it decreases! *) 187 | right; simpl. 188 | rewrite unnamed_subterms_lift. 189 | lia. 190 | (* Case: beta-id. *) 191 | - left; simpl; auto. 192 | (* Case: beta-omega. *) 193 | - (* Aw crap... *) 194 | left; simpl. 195 | rewrite unnamed_subterms_context_lift. 196 | (* We don't actually care about beta in here... *) 197 | clear H0 H1. 198 | induction H; simpl. 199 | + rewrite unnamed_subterms_lift. 200 | destruct (le_gt_dec x y); simpl. 201 | * sigma; simpl. 202 | (* TODO: is there any way to simplify this step? *) 203 | replace (@inst term term _ _ _ (subst_lift x)) with 204 | (@lift term term _ _ x 0) by auto. 205 | now rewrite unnamed_subterms_lift. 206 | * sigma; simpl. 207 | (* TODO: is there any way to simplify this step? *) 208 | replace (@inst term term _ _ _ (subst_lift x)) with 209 | (@lift term term _ _ x 0) by auto. 210 | now rewrite unnamed_subterms_lift. 211 | + rewrite <- IHevaluation. 212 | (* I was not expecting this to work, but... hey! It did! *) 213 | destruct f; simpl; lia. 214 | + rewrite <- IHevaluation. 215 | destruct H0; simpl; lia. 216 | Qed. 217 | 218 | (* Count the number of beta redexes within applications. *) 219 | 220 | Definition is_beta e := 221 | match e with 222 | | application (abstraction _ _) _ => 223 | 1 224 | | _ => 225 | 0 226 | end. 227 | 228 | Lemma is_beta_lift: 229 | forall e i k, 230 | is_beta (lift i k e) = is_beta e. 231 | Proof. 232 | destruct e; simpl; intros. 233 | - destruct (le_gt_dec k n); sigma; auto. 234 | - reflexivity. 235 | - destruct e1; simpl; auto. 236 | destruct (le_gt_dec k n); sigma; auto. 237 | - reflexivity. 238 | - reflexivity. 239 | Qed. 240 | 241 | Fixpoint inner_computations e: nat := 242 | match e with 243 | | bound _ => 244 | 0 245 | | abstraction _ b => 246 | inner_computations b 247 | | application f x => 248 | is_beta f + is_beta x + inner_computations f + inner_computations x 249 | (* TODO: what about pairs and thunks? *) 250 | | _ => 251 | 0 252 | end. 253 | 254 | (* 255 | Rules 1, 5 and 6 decrease the term size, while not changing the number of 256 | inner lets nor the number of unnamed stuff. 257 | 258 | Rules 2 and 3 decrease the number of inner lets, while not changing the number 259 | of unnamed stuff. 260 | 261 | Rule 4 decreases the number of unnamed stuff. 262 | *) 263 | 264 | Local Goal 265 | forall e1 e2, 266 | anf e1 e2 -> 267 | rst(full) e1 e2. 268 | Proof. 269 | induction 1. 270 | - (* Ok, eta of course doesn't hold. *) 271 | admit. 272 | - eapply rst_trans. 273 | apply rst_step. 274 | apply full_application_left. 275 | apply full_beta. 276 | apply rst_sym. 277 | eapply rst_trans. 278 | apply rst_step. 279 | apply full_beta. 280 | simpl; sigma. 281 | eauto with cps. 282 | - eapply rst_trans. 283 | apply rst_step. 284 | apply full_application_right. 285 | apply full_beta. 286 | apply rst_sym. 287 | eapply rst_trans. 288 | apply rst_step. 289 | apply full_beta. 290 | simpl; sigma. 291 | eauto with cps. 292 | - apply rst_sym. 293 | eapply rst_trans. 294 | apply rst_step. 295 | apply full_beta. 296 | simpl; sigma. 297 | eauto with cps. 298 | - eapply rst_trans. 299 | apply rst_step. 300 | apply full_beta. 301 | simpl; sigma. 302 | eauto with cps. 303 | - eapply rst_trans. 304 | apply rst_step. 305 | apply full_beta. 306 | simpl. 307 | rewrite context_subst_is_sound. 308 | simpl. 309 | rewrite Nat.add_0_r. 310 | rewrite context_lift_bvars. 311 | rewrite <- H0. 312 | sigma. 313 | (* Of course! *) 314 | admit. 315 | Admitted. 316 | -------------------------------------------------------------------------------- /theories/Constructions/Observational.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Equality. 7 | Require Import Local.Prelude. 8 | Require Import Local.AbstractRewriting. 9 | Require Import Local.Substitution. 10 | Require Import Local.Constructions.Calculus. 11 | Require Import Local.Constructions.Conversion. 12 | Require Import Local.Constructions.TypeSystem. 13 | Require Import Local.Constructions.Normalization. 14 | Require Import Local.Constructions.Reduction. 15 | 16 | Import ListNotations. 17 | 18 | (* We can't properly define this relation the standard way as it would violate 19 | the strict positivity rule. Instead, we use a trick similar to Sangiorgi's 20 | definition of stratified strong bisimilarity (definition 2.2.10 on the "The 21 | pi-calculus: A Theory of Mobile Processes"). By induction on some natural 22 | number, we count how many times the (CONV) rule will be necessary; then we 23 | define that two terms are observationally equivalent if they are equivalent 24 | no matter for every possible number of steps we need. *) 25 | 26 | Fixpoint observational_approx (n: nat): env -> relation term := 27 | fun g e1 e2 => 28 | match n with 29 | | 0 => 30 | True 31 | | S m => 32 | forall (h: context) v, 33 | (* TODO: close over g! *) 34 | typing [] (h e1) boolean (observational_approx m) -> 35 | typing [] (h e2) boolean (observational_approx m) -> 36 | eval (h e1) v <-> eval (h e2) v 37 | end. 38 | 39 | Local Notation approx := observational_approx. 40 | 41 | Definition observational: env -> relation term := 42 | fun g e1 e2 => 43 | (* We take the intersection of all approximations! *) 44 | forall n, approx n g e1 e2. 45 | 46 | Lemma approx_unfold: 47 | forall n g e1 e2, 48 | approx (S n) g e1 e2 = 49 | (forall (h: context) v, 50 | typing [] (h e1) boolean (approx n) -> 51 | typing [] (h e2) boolean (approx n) -> 52 | eval (h e1) v <-> eval (h e2) v). 53 | Proof. 54 | auto. 55 | Qed. 56 | 57 | Lemma approx_refl: 58 | forall n g, 59 | reflexive (approx n g). 60 | Proof. 61 | induction n; intros. 62 | - easy. 63 | - unfold reflexive; intros. 64 | rewrite approx_unfold; intros. 65 | firstorder. 66 | Qed. 67 | 68 | Lemma approx_sym: 69 | forall n g, 70 | symmetric (approx n g). 71 | Proof. 72 | induction n; intros. 73 | - easy. 74 | - unfold symmetric; intros. 75 | rewrite approx_unfold in H |- *; intros. 76 | firstorder. 77 | Qed. 78 | 79 | Lemma observational_refl: 80 | forall g, 81 | reflexive (observational g). 82 | Proof. 83 | repeat intro. 84 | apply approx_refl. 85 | Qed. 86 | 87 | Lemma observational_sym: 88 | forall g, 89 | symmetric (observational g). 90 | Proof. 91 | repeat intro. 92 | now apply approx_sym. 93 | Qed. 94 | 95 | (* Goal 96 | forall n g, 97 | inclusion (approx n g) (approx (S n) g). 98 | Proof. 99 | unfold inclusion. 100 | admit. 101 | Admitted. *) 102 | 103 | Lemma observational_tt_ff: 104 | forall g, 105 | ~observational g bool_tt bool_ff. 106 | Proof. 107 | (* Assume the relation is degenerate; so [true ~ false]. *) 108 | repeat intro. 109 | (* For every approximation level, on every context, true and false return the 110 | same value after computation; we pick the empty context and the truth value 111 | for checking. *) 112 | specialize (H 1). 113 | unfold approx in H; simpl in H. 114 | specialize (H context_hole bool_tt). 115 | (* Now we observe... *) 116 | destruct H as (?, _); simpl. 117 | - (* True is typable, obviously. *) 118 | repeat constructor. 119 | - (* So is false. *) 120 | repeat constructor. 121 | - (* If [true] reduces to [true] (which is trivial), then [false] should also 122 | reduce to [true]: that's an absurd! *) 123 | simpl in H; destruct H. 124 | + (* Clearly... *) 125 | split; auto with cps. 126 | + (* TODO: properly define CBN and CBV. *) 127 | admit. 128 | Admitted. 129 | 130 | Theorem observational_is_consistent: 131 | forall g, 132 | ~(forall e1 e2, observational g e1 e2). 133 | Proof. 134 | repeat intro. 135 | (* Follows directly from the above: on any context, [true] and [false] are 136 | different values. *) 137 | now apply observational_tt_ff with g. 138 | Qed. 139 | 140 | Lemma approx_conv: 141 | forall n g e1 e2, 142 | conv g e1 e2 -> 143 | approx n g e1 e2. 144 | Proof. 145 | induction n; intros. 146 | - easy. 147 | - rewrite approx_unfold; split; intros. 148 | + (* Respecting variables, conv is a congruence. So if we close over g, 149 | we have that conv [] (h (g x)) (h (g y))... so if one evaluates to a 150 | boolean, by Church-Rosser, so does the other. Typing doesn't seem to 151 | be relevant here... *) 152 | admit. 153 | + (* Same as above. *) 154 | admit. 155 | Admitted. 156 | 157 | Lemma observational_conv: 158 | forall g, 159 | inclusion (conv g) (observational g). 160 | Proof. 161 | repeat intro. 162 | now apply approx_conv. 163 | Qed. 164 | 165 | Lemma observational_if: 166 | forall n g e1 e2, 167 | (forall (h: context) v, 168 | typing [] (h e1) boolean observational -> 169 | typing [] (h e2) boolean observational -> 170 | eval (h e1) v <-> eval (h e2) v) -> 171 | approx n g e1 e2. 172 | Proof. 173 | (* Hmmmm... *) 174 | admit. 175 | Admitted. 176 | 177 | Theorem observational_characterization: 178 | forall g e1 e2, 179 | observational g e1 e2 <-> 180 | (forall (h: context) v, 181 | typing [] (h e1) boolean observational -> 182 | typing [] (h e2) boolean observational -> 183 | eval (h e1) v <-> eval (h e2) v). 184 | Proof. 185 | (* This gives a characterization of the observational relation. This is indeed 186 | the definition we would have liked to give it, but defining it in this way 187 | would violate strict positivity rules. *) 188 | split; intros. 189 | - (* This is trivially so. From H, e1 and e2 are equivalent at level 1. *) 190 | specialize (H 1). 191 | rewrite approx_unfold in H. 192 | apply H. 193 | + (* Terms are always convertible if equivalent at level 0, so any typing 194 | derivation is enough. *) 195 | apply infer_subset with observational. 196 | * easy. 197 | * assumption. 198 | + (* Ditto. *) 199 | apply infer_subset with observational. 200 | * easy. 201 | * assumption. 202 | - (* This case is a bit trickier... see the documentation for it above. *) 203 | intro. 204 | now apply observational_if. 205 | Qed. 206 | 207 | Theorem observational_is_conservative: 208 | forall j, 209 | infer conv j -> 210 | infer observational j. 211 | Proof. 212 | intros. 213 | apply infer_subset with conv; intros. 214 | - apply observational_conv. 215 | - assumption. 216 | Qed. 217 | 218 | Lemma extensionality_if: 219 | forall g f1 f2 a b, 220 | typing g f1 (pi a b) conv -> 221 | typing g f2 (pi a b) conv -> 222 | (forall x, typing g x a conv -> 223 | observational g (application f1 x) (application f2 x)) -> 224 | observational g f1 f2. 225 | Proof. 226 | repeat intro. 227 | induction n; simpl; intros. 228 | - easy. 229 | - split; intros. 230 | + (* Ignore, for now, definitions inside the context [g], as the relation 231 | will need to be reworked to take care of that. In order to prove that 232 | pi types admit functional extensionality in the observational relation, 233 | we first check if the context [h] goes inside a binder. If it does, it 234 | means that [f1] plays no role in the computation itself, so neither 235 | will [f2] and thus we finish. If [f1] doesn't go into a binder, though, 236 | it will be used in the computation. We have now to find an equivalent 237 | applicative context for [h], i.e., a context [(([] e1) ...) en]. If the 238 | number of arguments is zero, this has to be the empty context, which is 239 | an absurd given that [f1] would be a boolean due to [H4] and it can 240 | never be a function as it is in [H]. If there are some arguments, we 241 | take the first one, [e1], and give it to [H1] to show that [f1 e1] and 242 | [f2 e2] are equivalent. If they are, so will be [f1 e1 ... en] and 243 | [f2 e1 ... en], which is our context. As it's equivalent to [h], this 244 | means [f1 ...] will return [v], and so will [f2 ...] as expected. *) 245 | admit. 246 | + (* Same as above. *) 247 | admit. 248 | Admitted. 249 | 250 | Lemma extensionality_only_if: 251 | forall g f1 f2 a b, 252 | typing g f1 (pi a b) conv -> 253 | typing g f2 (pi a b) conv -> 254 | observational g f1 f2 -> 255 | forall x, 256 | typing g x a conv -> 257 | observational g (application f1 x) (application f2 x). 258 | Proof. 259 | repeat intro. 260 | destruct n; simpl; intros. 261 | - easy. 262 | - specialize (H1 (S n)); simpl in H1. 263 | (* We need composition of contexts to finish this, but this is clearly true 264 | as we can supply [h (application [-] x)] to [H2] and get our goal. *) 265 | admit. 266 | Admitted. 267 | 268 | Theorem extensionality: 269 | forall g f1 f2 a b, 270 | typing g f1 (pi a b) conv -> 271 | typing g f2 (pi a b) conv -> 272 | observational g f1 f2 <-> 273 | (forall x, 274 | typing g x a conv -> 275 | observational g (application f1 x) (application f2 x)). 276 | Proof. 277 | split; intros. 278 | - now apply extensionality_only_if with a b. 279 | - now apply extensionality_if with a b. 280 | Qed. 281 | 282 | Lemma boolean_ex_falso: 283 | forall R e, 284 | typing [] e bottom R -> 285 | typing [] (application e boolean) boolean R. 286 | Proof. 287 | intros. 288 | eapply typing_app. 289 | - eassumption. 290 | - apply typing_bool. 291 | constructor. 292 | - (* TODO: sigma is missing some laws... *) 293 | vm_compute. 294 | reflexivity. 295 | Qed. 296 | 297 | Theorem observational_consistency: 298 | ~exists e, typing [] e bottom observational. 299 | Proof. 300 | (* Assume that false is derivable in the observational type system. *) 301 | intros (e, ?). 302 | (* So, easily, we can eliminate it to generate a boolean. *) 303 | apply boolean_ex_falso in H. 304 | (* ... *) 305 | admit. 306 | Admitted. 307 | -------------------------------------------------------------------------------- /theories/Pi/Graph.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2024 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Setoid. 7 | Require Import Relations. 8 | Require Import Equality. 9 | Set Implicit Arguments. 10 | 11 | (** This library is based on the paper "Algebraic Graphs with Class (Functional 12 | Pearl)" by Andrey Mokhov, and by his "algebraic-graphs" Haskell package, 13 | found at: https://hackage.haskell.org/package/algebraic-graphs/. *) 14 | 15 | Import ListNotations. 16 | 17 | Arguments reflexive {A}. 18 | Arguments symmetric {A}. 19 | Arguments transitive {A}. 20 | 21 | Section Algebraic. 22 | 23 | Inductive graph {V: Type}: Type := 24 | | empty: graph 25 | | vertex: V -> graph 26 | | overlay: graph -> graph -> graph 27 | | connect: graph -> graph -> graph. 28 | 29 | Global Arguments graph V: clear implicits. 30 | 31 | Inductive has_vertex {V}: graph V -> V -> Prop := 32 | | has_vertex_singleton: 33 | forall v, 34 | has_vertex (vertex v) v 35 | | has_vertex_overlay_left: 36 | forall g1 g2 v, 37 | has_vertex g1 v -> 38 | has_vertex (overlay g1 g2) v 39 | | has_vertex_overlay_right: 40 | forall g1 g2 v, 41 | has_vertex g2 v -> 42 | has_vertex (overlay g1 g2) v 43 | | has_vertex_connect_left: 44 | forall g1 g2 v, 45 | has_vertex g1 v -> 46 | has_vertex (connect g1 g2) v 47 | | has_vertex_connect_right: 48 | forall g1 g2 v, 49 | has_vertex g2 v -> 50 | has_vertex (connect g1 g2) v. 51 | 52 | Inductive has_edge {V}: graph V -> V -> V -> Prop := 53 | | has_edge_overlay_left: 54 | forall g1 g2 v1 v2, 55 | has_edge g1 v1 v2 -> 56 | has_edge (overlay g1 g2) v1 v2 57 | | has_edge_overlay_right: 58 | forall g1 g2 v1 v2, 59 | has_edge g2 v1 v2 -> 60 | has_edge (overlay g1 g2) v1 v2 61 | | has_edge_connect_left: 62 | forall g1 g2 v1 v2, 63 | has_edge g1 v1 v2 -> 64 | has_edge (connect g1 g2) v1 v2 65 | | has_edge_connect_right: 66 | forall g1 g2 v1 v2, 67 | has_edge g2 v1 v2 -> 68 | has_edge (connect g1 g2) v1 v2 69 | | has_edge_connect_product: 70 | forall g1 g2 v1 v2, 71 | has_vertex g1 v1 -> 72 | has_vertex g2 v2 -> 73 | has_edge (connect g1 g2) v1 v2. 74 | 75 | Lemma graph_vertex_from_edge_left: 76 | forall {V} (g: graph V) v1 v2, 77 | has_edge g v1 v2 -> 78 | has_vertex g v1. 79 | Proof. 80 | induction 1. 81 | - now apply has_vertex_overlay_left. 82 | - now apply has_vertex_overlay_right. 83 | - now apply has_vertex_connect_left. 84 | - now apply has_vertex_connect_right. 85 | - now apply has_vertex_connect_left. 86 | Qed. 87 | 88 | Lemma graph_vertex_from_edge_right: 89 | forall {V} (g: graph V) v1 v2, 90 | has_edge g v1 v2 -> 91 | has_vertex g v2. 92 | Proof. 93 | induction 1. 94 | - now apply has_vertex_overlay_left. 95 | - now apply has_vertex_overlay_right. 96 | - now apply has_vertex_connect_left. 97 | - now apply has_vertex_connect_right. 98 | - now apply has_vertex_connect_right. 99 | Qed. 100 | 101 | Structure isomorphic {V} (g1: graph V) (g2: graph V): Prop := { 102 | isomorphic_vertices: 103 | forall v, 104 | has_vertex g1 v <-> has_vertex g2 v; 105 | isomorphic_edges: 106 | forall v1 v2, 107 | has_edge g1 v1 v2 <-> has_edge g2 v1 v2 108 | }. 109 | 110 | Lemma isomorphic_refl: 111 | forall {V}, 112 | reflexive (@isomorphic V). 113 | Proof. 114 | constructor; split; auto. 115 | Qed. 116 | 117 | Lemma isomorphic_sym: 118 | forall {V}, 119 | symmetric (@isomorphic V). 120 | Proof. 121 | constructor; split; firstorder. 122 | Qed. 123 | 124 | Lemma isomorphic_trans: 125 | forall {V}, 126 | transitive (@isomorphic V). 127 | Proof. 128 | constructor; split; intros. 129 | - now apply H0, H. 130 | - now apply H, H0. 131 | - now apply H0, H. 132 | - now apply H, H0. 133 | Qed. 134 | 135 | Global Instance isomorphic_is_an_equivalence: 136 | forall {V}, 137 | Equivalence (@isomorphic V). 138 | Proof. 139 | constructor. 140 | - exact isomorphic_refl. 141 | - exact isomorphic_sym. 142 | - exact isomorphic_trans. 143 | Qed. 144 | 145 | Lemma overlay_is_commutative: 146 | forall {V} (g1 g2: graph V), 147 | isomorphic (overlay g1 g2) (overlay g2 g1). 148 | Proof. 149 | constructor; split; intros. 150 | - dependent destruction H. 151 | + now apply has_vertex_overlay_right. 152 | + now apply has_vertex_overlay_left. 153 | - dependent destruction H. 154 | + now apply has_vertex_overlay_right. 155 | + now apply has_vertex_overlay_left. 156 | - dependent destruction H. 157 | + now apply has_edge_overlay_right. 158 | + now apply has_edge_overlay_left. 159 | - dependent destruction H. 160 | + now apply has_edge_overlay_right. 161 | + now apply has_edge_overlay_left. 162 | Qed. 163 | 164 | Lemma overlay_is_associative: 165 | forall {V} (g1 g2 g3: graph V), 166 | isomorphic (overlay g1 (overlay g2 g3)) (overlay (overlay g1 g2) g3). 167 | Proof. 168 | constructor; split; intros. 169 | - dependent destruction H. 170 | + apply has_vertex_overlay_left. 171 | now apply has_vertex_overlay_left. 172 | + dependent destruction H. 173 | * apply has_vertex_overlay_left. 174 | now apply has_vertex_overlay_right. 175 | * now apply has_vertex_overlay_right. 176 | - dependent destruction H. 177 | + dependent destruction H. 178 | * now apply has_vertex_overlay_left. 179 | * apply has_vertex_overlay_right. 180 | now apply has_vertex_overlay_left. 181 | + apply has_vertex_overlay_right. 182 | now apply has_vertex_overlay_right. 183 | - dependent destruction H. 184 | + apply has_edge_overlay_left. 185 | now apply has_edge_overlay_left. 186 | + dependent destruction H. 187 | * apply has_edge_overlay_left. 188 | now apply has_edge_overlay_right. 189 | * now apply has_edge_overlay_right. 190 | - dependent destruction H. 191 | + dependent destruction H. 192 | * now apply has_edge_overlay_left. 193 | * apply has_edge_overlay_right. 194 | now apply has_edge_overlay_left. 195 | + apply has_edge_overlay_right. 196 | now apply has_edge_overlay_right. 197 | Qed. 198 | 199 | Definition edge {V} v1 v2: graph V := 200 | connect (vertex v1) (vertex v2). 201 | 202 | Definition edges {V} es: graph V := 203 | fold_right overlay empty (map (fun e => edge (fst e) (snd e)) es). 204 | 205 | Definition vertices {V} vs: graph V := 206 | fold_right overlay empty (map vertex vs). 207 | 208 | Definition clique {V} vs: graph V := 209 | fold_right connect empty (map vertex vs). 210 | 211 | Fixpoint graph_fold {V T} a x y z (g: graph V): T := 212 | match g with 213 | | empty => a 214 | | vertex v => x v 215 | | overlay g1 g2 => y (graph_fold a x y z g1) (graph_fold a x y z g2) 216 | | connect g1 g2 => z (graph_fold a x y z g1) (graph_fold a x y z g2) 217 | end. 218 | 219 | Definition graph_pure {V}: V -> graph V := 220 | vertex. 221 | 222 | Definition graph_bind {V W} (f: V -> graph W): graph V -> graph W := 223 | graph_fold empty f overlay connect. 224 | 225 | Definition graph_map {V W} f: graph V -> graph W := 226 | graph_bind (fun v => vertex (f v)). 227 | 228 | Definition graph_induce {V} (f: V -> bool): graph V -> graph V := 229 | let g v := 230 | if f v then 231 | vertex v 232 | else 233 | empty 234 | in graph_bind g. 235 | 236 | Lemma graph_induce_vertex_simpl: 237 | forall {V} (f: V -> bool) v, 238 | graph_induce f (vertex v) = if f v then vertex v else empty. 239 | Proof. 240 | auto. 241 | Qed. 242 | 243 | Lemma graph_induce_overlay_simpl: 244 | forall {V} (g1 g2: graph V) f, 245 | graph_induce f (overlay g1 g2) = 246 | overlay (graph_induce f g1) (graph_induce f g2). 247 | Proof. 248 | auto. 249 | Qed. 250 | 251 | Lemma graph_induce_connect_simpl: 252 | forall {V} (g1 g2: graph V) f, 253 | graph_induce f (connect g1 g2) = 254 | connect (graph_induce f g1) (graph_induce f g2). 255 | Proof. 256 | auto. 257 | Qed. 258 | 259 | Lemma graph_induce_reflects_vertex: 260 | forall {V} (g: graph V) f w, 261 | has_vertex (graph_induce f g) w -> 262 | has_vertex g w. 263 | Proof. 264 | induction g; intros. 265 | - exfalso. 266 | inversion H. 267 | - rewrite graph_induce_vertex_simpl in H. 268 | destruct (f v). 269 | + dependent destruction H. 270 | constructor. 271 | + exfalso. 272 | inversion H. 273 | - rewrite graph_induce_overlay_simpl in H. 274 | dependent destruction H. 275 | + apply has_vertex_overlay_left. 276 | now apply IHg1 with f. 277 | + apply has_vertex_overlay_right. 278 | now apply IHg2 with f. 279 | - rewrite graph_induce_connect_simpl in H. 280 | dependent destruction H. 281 | + apply has_vertex_connect_left. 282 | now apply IHg1 with f. 283 | + apply has_vertex_connect_right. 284 | now apply IHg2 with f. 285 | Qed. 286 | 287 | Lemma graph_induce_reflects_edge: 288 | forall {V} (g: graph V) f w1 w2, 289 | has_edge (graph_induce f g) w1 w2 -> 290 | has_edge g w1 w2. 291 | Proof. 292 | induction g; intros. 293 | - exfalso. 294 | inversion H. 295 | - exfalso. 296 | rewrite graph_induce_vertex_simpl in H. 297 | destruct (f v). 298 | + inversion H. 299 | + inversion H. 300 | - rewrite graph_induce_overlay_simpl in H. 301 | dependent destruction H. 302 | + apply has_edge_overlay_left. 303 | now apply IHg1 with f. 304 | + apply has_edge_overlay_right. 305 | now apply IHg2 with f. 306 | - rewrite graph_induce_connect_simpl in H. 307 | dependent destruction H. 308 | + apply has_edge_connect_left. 309 | now apply IHg1 with f. 310 | + apply has_edge_connect_right. 311 | now apply IHg2 with f. 312 | + apply has_edge_connect_product. 313 | * now apply graph_induce_reflects_vertex with f. 314 | * now apply graph_induce_reflects_vertex with f. 315 | Qed. 316 | 317 | End Algebraic. 318 | -------------------------------------------------------------------------------- /theories/Prelude.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2023 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Export List. 7 | Require Import Arith. 8 | Require Import Equality. 9 | Require Import Relations. 10 | Import ListNotations. 11 | 12 | (** To help proof automation, create a hint database. *) 13 | 14 | Create HintDb cps. 15 | 16 | (** A lot of proofs on pseudoterm lists may be solved by simple induction on the 17 | [Forall P] proposition over them, so we'll add a tactic for that. *) 18 | 19 | Tactic Notation "list" "induction" "over" hyp(H) := 20 | induction H; simpl; 21 | [ reflexivity 22 | | f_equal; auto ]. 23 | 24 | (** A predicate indicating an object is the nth element of a list. *) 25 | 26 | Inductive item {T} (e: T): list T -> nat -> Prop := 27 | | item_car: 28 | forall cdr, 29 | item e (e :: cdr) 0 30 | | item_cdr: 31 | forall car cdr n, 32 | item e cdr n -> item e (car :: cdr) (S n). 33 | 34 | Global Hint Constructors item: cps. 35 | 36 | Lemma item_ignore_head: 37 | forall {T} xs x ys k, 38 | k >= length xs -> 39 | @item T x (xs ++ ys) k -> @item T x ys (k - length xs). 40 | Proof. 41 | induction xs; intros. 42 | - simpl in H0 |- *. 43 | rewrite Nat.sub_0_r. 44 | assumption. 45 | - simpl in H, H0 |- *. 46 | destruct k. 47 | + exfalso. 48 | inversion H. 49 | + inversion_clear H0. 50 | apply IHxs; auto. 51 | lia. 52 | Qed. 53 | 54 | Lemma item_ignore_tail: 55 | forall {T} xs x ys k, 56 | length xs > k -> 57 | @item T x (xs ++ ys) k -> @item T x xs k. 58 | Proof. 59 | induction xs; intros. 60 | - inversion H. 61 | - simpl in H, H0 |- *. 62 | destruct k. 63 | + inversion_clear H0; auto. 64 | constructor. 65 | + inversion_clear H0. 66 | constructor. 67 | eapply IHxs; eauto. 68 | lia. 69 | Qed. 70 | 71 | Lemma item_insert_head: 72 | forall {T} xs ys x k, 73 | @item T x ys k -> @item T x (xs ++ ys) (k + length xs). 74 | Proof. 75 | induction xs; simpl; intros. 76 | - rewrite Nat.add_0_r. 77 | assumption. 78 | - replace (k + S (length xs)) with (S (k + length xs)); try lia. 79 | constructor; auto. 80 | Qed. 81 | 82 | Lemma item_insert_tail: 83 | forall {T} xs ys x k, 84 | @item T x xs k -> @item T x (xs ++ ys) k. 85 | Proof. 86 | induction 1. 87 | - constructor. 88 | - constructor; auto. 89 | Qed. 90 | 91 | Lemma item_valid_index: 92 | forall {T} x xs k, 93 | @item T x xs k -> 94 | k < length xs. 95 | Proof. 96 | induction 1; simpl; auto with arith. 97 | Qed. 98 | 99 | Global Hint Resolve item_valid_index: cps. 100 | 101 | Lemma item_exists: 102 | forall {T} xs k, 103 | k < length xs -> 104 | exists x, 105 | @item T x xs k. 106 | Proof. 107 | induction xs; intros. 108 | - inversion H. 109 | - destruct k. 110 | + exists a. 111 | constructor. 112 | + destruct IHxs with k. 113 | * simpl in H; lia. 114 | * exists x. 115 | constructor. 116 | assumption. 117 | Qed. 118 | 119 | Lemma item_repeat: 120 | forall {T} x y k p, 121 | @item T x (repeat y k) p -> 122 | x = y. 123 | Proof. 124 | induction k; intros. 125 | - inversion H. 126 | - destruct p. 127 | + inversion H; auto. 128 | + inversion H; eauto. 129 | Qed. 130 | 131 | Lemma nth_item: 132 | forall {T} x xs y k, 133 | @item T x xs k -> nth k xs y = x. 134 | Proof. 135 | induction 1; simpl. 136 | - reflexivity. 137 | - assumption. 138 | Qed. 139 | 140 | Lemma item_nth: 141 | forall {T} x xs y k, 142 | nth k xs y = x -> 143 | x <> y -> 144 | @item T x xs k. 145 | Proof. 146 | induction xs; intros. 147 | - destruct k; simpl in H; congruence. 148 | - destruct k; simpl in H. 149 | + rewrite H. 150 | constructor. 151 | + constructor. 152 | apply IHxs with y; auto. 153 | Qed. 154 | 155 | Lemma item_rev: 156 | forall {T} x xs k, 157 | @item T x xs k -> 158 | @item T x (rev xs) (length xs - S k). 159 | Proof. 160 | induction xs; simpl; intros. 161 | - inversion H. 162 | - destruct k. 163 | * dependent destruction H. 164 | replace (length xs - 0) with (0 + length xs); try lia. 165 | rewrite <- rev_length. 166 | apply item_insert_head. 167 | constructor. 168 | * dependent destruction H. 169 | apply item_insert_tail. 170 | apply IHxs; auto. 171 | Qed. 172 | 173 | Lemma item_unique: 174 | forall {T} x y xs k, 175 | @item T x xs k -> 176 | @item T y xs k -> 177 | x = y. 178 | Proof. 179 | induction 1; intros. 180 | - dependent destruction H. 181 | reflexivity. 182 | - dependent destruction H0. 183 | auto. 184 | Qed. 185 | 186 | Lemma Forall2_length: 187 | forall {A} {B} R xs ys, 188 | @Forall2 A B R xs ys -> 189 | length xs = length ys. 190 | Proof. 191 | induction 1; simpl; lia. 192 | Qed. 193 | 194 | (* -------------------------------------------------------------------------- *) 195 | 196 | Inductive insert {T}: list T -> nat -> relation (list T) := 197 | | insert_head: 198 | forall ts xs, 199 | insert ts 0 xs (ts ++ xs) 200 | | insert_tail: 201 | forall ts n x xs1 xs2, 202 | insert ts n xs1 xs2 -> 203 | insert ts (S n) (x :: xs1) (x :: xs2). 204 | 205 | Lemma insert_app: 206 | forall {T} ts k g h, 207 | @insert T ts k g h -> 208 | forall xs, 209 | @insert T ts (length xs + k) (xs ++ g) (xs ++ h). 210 | Proof. 211 | induction xs; simpl; intros. 212 | - assumption. 213 | - now constructor. 214 | Qed. 215 | 216 | Lemma item_insert_ge: 217 | forall {T} ts m g h, 218 | @insert T ts m g h -> 219 | forall n u, 220 | n >= m -> 221 | @item T u g n -> 222 | @item T u h (length ts + n). 223 | Proof. 224 | intros. 225 | rewrite Nat.add_comm. 226 | generalize dependent n. 227 | induction H; intros. 228 | - apply item_insert_head. 229 | assumption. 230 | - destruct n0 as [| m ]; try lia. 231 | dependent destruction H1. 232 | simpl; constructor. 233 | apply IHinsert; auto with arith. 234 | Qed. 235 | 236 | Lemma item_insert_ge_rev: 237 | forall {T} ts m g h, 238 | @insert T ts m g h -> 239 | forall n u, 240 | n >= m -> 241 | @item T u h (length ts + n) -> 242 | @item T u g n. 243 | Proof. 244 | intros. 245 | rewrite Nat.add_comm in H1. 246 | generalize dependent n. 247 | induction H; intros. 248 | - apply item_ignore_head in H1. 249 | + now replace (n + length ts - length ts) with n in H1 by lia. 250 | + lia. 251 | - destruct n0 as [| m ]; try lia. 252 | dependent destruction H1. 253 | simpl; constructor. 254 | apply IHinsert; auto with arith. 255 | Qed. 256 | 257 | Lemma item_insert_lt: 258 | forall {T} ts m g h, 259 | @insert T ts m g h -> 260 | forall n u, 261 | n < m -> 262 | @item T u g n -> 263 | @item T u h n. 264 | Proof. 265 | induction 1; intros. 266 | - inversion H. 267 | - destruct n0 as [| m ]. 268 | + dependent destruction H1. 269 | constructor. 270 | + dependent destruction H1. 271 | constructor. 272 | apply IHinsert; auto with arith. 273 | Qed. 274 | 275 | (* -------------------------------------------------------------------------- *) 276 | 277 | Inductive switch {T}: nat -> relation (list T) := 278 | | switch_head: 279 | forall x1 x2 xs, 280 | switch 0 (x1 :: x2 :: xs) (x2 :: x1 :: xs) 281 | | switch_tail: 282 | forall n x xs1 xs2, 283 | switch n xs1 xs2 -> switch (S n) (x :: xs1) (x :: xs2). 284 | 285 | Lemma switch_sym: 286 | forall {T} n g h, 287 | @switch T n g h -> @switch T n h g. 288 | Proof. 289 | induction 1; constructor; auto. 290 | Qed. 291 | 292 | Lemma switch_app: 293 | forall {T} n g h i, 294 | @switch T n h i -> 295 | @switch T (length g + n) (g ++ h) (g ++ i). 296 | Proof. 297 | induction g; simpl; intros. 298 | - assumption. 299 | - constructor; auto. 300 | Qed. 301 | 302 | Lemma Forall_switch: 303 | forall T P g, 304 | @Forall T P g -> 305 | forall n h, 306 | @switch T n g h -> 307 | @Forall T P h. 308 | Proof. 309 | induction 2; simpl. 310 | - dependent destruction H. 311 | dependent destruction H0. 312 | constructor; auto. 313 | - dependent destruction H. 314 | constructor; auto. 315 | Qed. 316 | 317 | (* -------------------------------------------------------------------------- *) 318 | 319 | Inductive join {T}: nat -> relation (list T) := 320 | | join_head: 321 | forall x xs, 322 | join 0 (x :: x :: xs) (x :: xs) 323 | | join_tail: 324 | forall n x xs1 xs2, 325 | join n xs1 xs2 -> 326 | join (S n) (x :: xs1) (x :: xs2). 327 | 328 | Lemma join_app: 329 | forall {T} n g h i, 330 | @join T n h i -> 331 | @join T (length g + n) (g ++ h) (g ++ i). 332 | Proof. 333 | induction g; simpl; intros. 334 | - assumption. 335 | - constructor; auto. 336 | Qed. 337 | 338 | (* -------------------------------------------------------------------------- *) 339 | 340 | Inductive drop {T}: nat -> nat -> relation (list T) := 341 | | drop_noop: 342 | forall xs, 343 | drop 0 0 xs xs 344 | | drop_head: 345 | forall n x xs1 xs2, 346 | drop 0 n xs1 xs2 -> 347 | drop 0 (S n) (x :: xs1) xs2 348 | | drop_tail: 349 | forall k n x xs1 xs2, 350 | drop k n xs1 xs2 -> 351 | drop (S k) n (x :: xs1) (x :: xs2). 352 | 353 | Lemma drop_app: 354 | forall {T} k n g h i, 355 | @drop T k n h i -> 356 | @drop T (length g + k) n (g ++ h) (g ++ i). 357 | Proof. 358 | induction g; simpl; intros. 359 | - assumption. 360 | - constructor; auto. 361 | Qed. 362 | 363 | (* -------------------------------------------------------------------------- *) 364 | 365 | Section SetoidFix. 366 | 367 | (* The code in this section is taken from coq-ext-lib and slightly adapted; 368 | the original is on GitHub: https://github.com/coq-community/coq-ext-lib. *) 369 | 370 | Variable A: Type. 371 | Variable R: A -> A -> Prop. 372 | Variable Rwf: well_founded R. 373 | Variable P: A -> Type. 374 | Variable F: forall x, (forall y, R y x -> P y) -> P x. 375 | Variable r: forall x, P x -> P x -> Prop. 376 | 377 | Hypothesis Hstep: 378 | forall x f g, 379 | (forall y p, r y (f y p) (g y p)) -> 380 | r x (@F x f) (@F x g). 381 | 382 | Lemma Fix_F_equiv_inv: 383 | forall x r' s', 384 | r x (Fix_F _ F r') (Fix_F _ F s'). 385 | Proof. 386 | intros. 387 | induction (Rwf x). 388 | rewrite <- (Fix_F_eq _ F r'). 389 | rewrite <- (Fix_F_eq _ F s'). 390 | apply Hstep; auto. 391 | Qed. 392 | 393 | Theorem Fix_equiv: 394 | forall x, 395 | r x (Fix Rwf P F x) (@F x (fun y _ => Fix Rwf P F y)). 396 | Proof. 397 | intros. 398 | unfold Fix. 399 | rewrite <- Fix_F_eq. 400 | apply Hstep; intros. 401 | apply Fix_F_equiv_inv. 402 | Qed. 403 | 404 | End SetoidFix. 405 | -------------------------------------------------------------------------------- /theories/Conservation.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Arith. 6 | Require Import Equality. 7 | Require Import Local.Prelude. 8 | Require Import Local.Syntax. 9 | Require Import Local.AbstractRewriting. 10 | Require Import Local.Context. 11 | Require Import Local.Equational. 12 | Require Import Local.Reduction. 13 | Require Import Local.Residuals. 14 | Require Import Local.Confluence. 15 | 16 | Import ListNotations. 17 | 18 | (* Anything that is a bisimulation on parallel reduction should preserve jump 19 | reduction. *) 20 | 21 | (* TODO: move this definition to [Prelude.v]! *) 22 | 23 | Notation const T x := 24 | (fun _: T => x). 25 | 26 | Definition equi: relation pseudoterm := 27 | strong_bisimilarity (const unit parallel). 28 | 29 | Global Hint Unfold equi: cps. 30 | 31 | Lemma beta_and_parallel_SN_coincide: 32 | forall c, 33 | SN beta c <-> SN parallel c. 34 | Proof. 35 | (* TODO: rewrite this proof by using a proper morphism! *) 36 | split; intros. 37 | - apply SN_R_t_R in H. 38 | apply SN_R_t_R. 39 | induction H; constructor; intros. 40 | apply H0. 41 | apply t_beta_and_t_parallel_coincide. 42 | assumption. 43 | - apply SN_R_t_R in H. 44 | apply SN_R_t_R. 45 | induction H; constructor; intros. 46 | apply H0. 47 | apply t_beta_and_t_parallel_coincide. 48 | assumption. 49 | Qed. 50 | 51 | Section Technique. 52 | 53 | Local Notation R := parallel. 54 | 55 | Variable S: relation pseudoterm. 56 | 57 | Hypothesis R_diagram1: 58 | diagram R S rt(S) R. 59 | 60 | Hypothesis R_diagram2: 61 | diagram R (transp S) rt(transp S) R. 62 | 63 | Local Lemma rst_S_is_bisimulation: 64 | strong_bisimulation (const unit R) rst(S). 65 | Proof. 66 | (* TODO: this lemma could use auxiliary stuff: symmetric simulation is a 67 | bisimulation, something about rt(transp R), etc... *) 68 | split; 69 | intros x y ?; 70 | [ apply clos_rst_rst1n_iff in H 71 | | apply clos_rst_rstn1_iff in H ]; 72 | induction H; 73 | intros w _ ?. 74 | - exists w; auto with cps. 75 | - destruct H. 76 | + destruct R_diagram1 with x w y as (p, ?, ?); auto. 77 | destruct IHclos_refl_sym_trans_1n with p as (q, ?, ?); try easy. 78 | exists q; eauto with cps. 79 | (* I'm not sure why eauto can't solve this one. *) 80 | eapply rst_trans; eauto. 81 | apply clos_rt_clos_rst; auto. 82 | + destruct R_diagram2 with x w y as (p, ?, ?); auto. 83 | destruct IHclos_refl_sym_trans_1n with p as (q, ?, ?); try easy. 84 | exists q; eauto with cps. 85 | eapply rst_trans; eauto. 86 | apply rst_sym, clos_rt_clos_rst. 87 | clear H1 H3 H4 H5; induction H2; eauto with cps. 88 | - exists w; auto with cps. 89 | - rename y0 into x. 90 | destruct H. 91 | + destruct R_diagram2 with z w x as (p, ?, ?); auto. 92 | destruct IHclos_refl_sym_trans_n1 with p as (q, ?, ?); try easy. 93 | exists q; eauto with cps. 94 | eapply rst_trans; eauto. 95 | (* TODO: again, make some lemmas... *) 96 | clear H1 H3 H4 H5. 97 | induction H2; eauto with cps. 98 | + destruct R_diagram1 with z w x as (p, ?, ?); auto. 99 | destruct IHclos_refl_sym_trans_n1 with p as (q, ?, ?); try easy. 100 | exists q; eauto with cps. 101 | eapply rst_trans; eauto. 102 | apply rst_sym, clos_rt_clos_rst. 103 | clear H1 H3 H4 H5; induction H2; eauto with cps. 104 | Qed. 105 | 106 | Local Lemma strong_normalization_module_equi: 107 | forall c, 108 | SN R c -> 109 | SN (modulo R equi) c. 110 | Proof. 111 | apply modulo_bisimulation_strong_normalization; try split. 112 | - apply strong_bisimilarity_refl. 113 | - apply strong_bisimilarity_trans. 114 | - apply strong_bisimilarity_sym. 115 | - destruct 1 as (X, (?, ?), ?); intros. 116 | destruct H with a b c; auto. 117 | exists x. 118 | + assumption. 119 | + exists X; auto. 120 | split; auto. 121 | - destruct 1 as (X, (?, ?), ?); intros. 122 | destruct H0 with a b c; auto. 123 | exists x. 124 | + assumption. 125 | + exists X; auto. 126 | split; auto. 127 | Qed. 128 | 129 | Local Lemma strong_normalization_module_relation: 130 | forall T, 131 | inclusion T equi -> 132 | forall c, 133 | SN R c -> 134 | SN (modulo R T) c. 135 | Proof. 136 | intros. 137 | apply SN_subset with (modulo R equi). 138 | - intros x w (y, (z, (?, (?, ?)))). 139 | exists y, z; repeat split. 140 | + apply H; auto. 141 | + assumption. 142 | + apply H; auto. 143 | - apply strong_normalization_module_equi. 144 | assumption. 145 | Qed. 146 | 147 | Lemma preservation_technique: 148 | forall b, 149 | SN beta b -> 150 | forall c, 151 | rst(S) b c -> SN beta c. 152 | Proof. 153 | intros. 154 | apply beta_and_parallel_SN_coincide in H. 155 | apply strong_normalization_module_relation with (T := rst(S)) in H. 156 | - eapply SN_subset with (R := modulo R rst(S)). 157 | + clear H H0 b c. 158 | intros b c ?. 159 | exists b, c; eauto with cps. 160 | + constructor; intros d (e, (f, (?, (?, ?)))). 161 | apply H. 162 | exists e, f; eauto with cps. 163 | - clear H H0 b c. 164 | intros b c ?. 165 | exists rst(S). 166 | + exact rst_S_is_bisimulation. 167 | + assumption. 168 | Qed. 169 | 170 | End Technique. 171 | 172 | (* Is jump reduction modulo strong parallel bisimilarity really valid? TODO: add 173 | some comments in here, of course. This seems a bit odd, as it should include 174 | the (DISTR) law, which can duplicate redexes... 175 | 176 | Edit: it IS valid, and it does NOT include the (DISTR) law. The issue is that 177 | using (DISTR) doesn't require us to join/split a reference. I gotta write 178 | some explanation about this. *) 179 | 180 | Local Goal 181 | forall c, 182 | SN beta c -> 183 | SN (modulo beta equi) c. 184 | Proof. 185 | intros. 186 | apply beta_and_parallel_SN_coincide in H. 187 | apply strong_normalization_module_equi in H. 188 | apply SN_subset with (R := modulo parallel equi). 189 | - clear H c; intros b e (c, (d, (?, (?, ?)))). 190 | exists c, d; eauto with cps. 191 | - assumption. 192 | Qed. 193 | 194 | (* -------------------------------------------------------------------------- *) 195 | 196 | (* This property is mentioned in Yoshida's paper for the pi-calculus, using the 197 | same reduction relation as we are. The proof dates back to Church, who first 198 | showed it, but she (on lemma B.3) refers to Barendregt's textbook (page 293, 199 | lemma 11.3.1), which contains his own version of the proof. We follow it in 200 | spirit. *) 201 | 202 | Lemma backwards_parallel_preservation: 203 | forall c, 204 | SN parallel c -> 205 | forall b, 206 | parallel b c -> SN parallel b. 207 | Proof. 208 | (* We follow by induction both on the maximal reduction length for c, as well 209 | as the maximal length for development in b. *) 210 | induction 1 using SN_ind; intros. 211 | rename x into c. 212 | destruct H0 as (r, ?, ?). 213 | remember (redexes_weight [] r) as n. 214 | generalize dependent r. 215 | generalize dependent b. 216 | induction n using lt_wf_ind; intros. 217 | dependent destruction Heqn. 218 | (* Now we can check the next move! *) 219 | constructor; intros d (p, ?, ?). 220 | fold (SN parallel). 221 | (* So, since parallel reduction is defined in terms of residuals, we can use 222 | the paving lemma to join back the reductions that lead to c and d. *) 223 | destruct paving with (mark b) r (mark c) p (mark d); eauto. 224 | (* As c has no marks (or d, of course), so the result shouldn't as well. *) 225 | assert (exists e, d0 = mark e) as (e, ?) by eauto with cps; subst. 226 | (* We proceed by case analysis on the number of marks in rp and pr. *) 227 | destruct (le_gt_dec (redexes_count rp) 0) as [ ?H | ?H ]; 228 | destruct (le_gt_dec (redexes_count pr) 0) as [ ?H | ?H ]. 229 | (* Case: r and p are the same. *) 230 | - (* We have reached a point where the terms were joined back, thus all the 231 | missing redexes were contracted. Since neither path requires any work, 232 | we conclude that c = d and we are done by our inductive hypothesis. *) 233 | assert (c = e) by eauto with arith cps; subst. 234 | assert (d = e) by eauto with arith cps; subst. 235 | assumption. 236 | (* Case: r is a strict subset of p. *) 237 | - (* Here c can move to d. So we performed all the missing redexes and a few 238 | more! As our hypothesis says that c is SN, we can finish already by doing 239 | the additional redexes alone. *) 240 | assert (d = e) by eauto with arith cps; subst. 241 | apply H; unfold transp. 242 | eauto with cps. 243 | (* Case: p is a strict subset of r. *) 244 | - (* Here we are performing some, but not all, of the missing redexes, and 245 | nothing more. We proceed by our second inductive hypothesis, as we will 246 | now need less work to develop all the missing redexes. We have enough 247 | information to state that p is a subset of r. *) 248 | assert (c = e) by eauto with arith cps; subst. 249 | apply H0 with (redexes_weight [] rp) rp; auto. 250 | (* Naturally, any partial development reduces the maximum number of steps 251 | required to develop the term. *) 252 | apply development_reduces_weight with p []. 253 | + (* Clearly, from H6 and H11. *) 254 | eapply subset_residuals_zero_marks; eauto with arith. 255 | + eauto with cps. 256 | + assumption. 257 | + constructor. 258 | (* Case: r and p are unrelated. *) 259 | - (* We need to move in both directions. So we follow by our first inductive 260 | hypothesis, as we're decreasing the maximum reduction length. *) 261 | apply H2 with e; eauto with cps. 262 | Qed. 263 | 264 | Lemma sn_beta_backwards_step: 265 | forall b c, 266 | beta b c -> 267 | SN beta c -> SN beta b. 268 | Proof. 269 | intros. 270 | apply beta_and_parallel_SN_coincide in H0. 271 | apply beta_and_parallel_SN_coincide. 272 | apply backwards_parallel_preservation with c. 273 | - assumption. 274 | - auto with cps. 275 | Qed. 276 | 277 | Theorem uniform_normalization: 278 | forall b, 279 | WN beta b <-> SN beta b. 280 | Proof. 281 | split; intros. 282 | (* Case: WN implies SN. *) 283 | - destruct H as (c, ?, ?). 284 | apply clos_rt_rt1n_iff in H. 285 | induction H. 286 | + constructor; intros. 287 | exfalso. 288 | now apply H0 with y. 289 | + apply sn_beta_backwards_step with y; auto. 290 | (* Case: WN implies SN. *) 291 | - apply sn_implies_wn; auto. 292 | apply beta_is_decidable. 293 | Qed. 294 | 295 | Corollary conservation: 296 | forall a, 297 | ~SN beta a -> 298 | forall b, 299 | beta a b -> ~SN beta b. 300 | Proof. 301 | intros a ? b ? ?. 302 | eapply H; clear H. 303 | apply uniform_normalization in H1. 304 | destruct H1 as (c, ?, ?). 305 | apply uniform_normalization. 306 | exists c; eauto with cps. 307 | Qed. 308 | -------------------------------------------------------------------------------- /theories/Constructions/Stratification.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Equality. 7 | Require Import Local.Prelude. 8 | Require Import Local.Substitution. 9 | Require Import Local.Constructions.Calculus. 10 | Require Import Local.Constructions.Conversion. 11 | Require Import Local.Constructions.TypeSystem. 12 | Require Import Local.Constructions.Inversion. 13 | 14 | Import ListNotations. 15 | 16 | (* Following "A New Extraction for Coq", we define a type scheme as something 17 | that necessarily becomes a type. For example, the term [Pi X: Type, X -> X] 18 | in Coq is a type scheme because it can't ever generate a term. On the other 19 | hand, [Pi X: Type, Pi x: X, x] is not a type scheme: it may generate a type, 20 | if applied, e.g., to [Prop], but it may generate a term, if applied, e.g., 21 | to [nat]. Of course, this distinction happens because of cumulativity, since 22 | there are no unique types anymore (or, rather, a universe of types may have 23 | both large and small types). 24 | 25 | Independent if we use cumulativity or not, we may check that there's a 26 | syntactic way to check for type schemes: their types are typeable by arities, 27 | as they are called in the MetaCoq project and the "Coq Coq Correct!" paper. 28 | We do not assume here that arities are well-typed (though they must be!). *) 29 | 30 | Inductive is_arity: term -> Prop := 31 | | is_arity_now: 32 | forall s, 33 | is_arity (sort s) 34 | | is_arity_pi: 35 | forall t u, 36 | is_arity u -> 37 | is_arity (pi t u) 38 | (* Note that this constructor will not appear in normal forms. *) 39 | | is_arity_def: 40 | forall v t u, 41 | (* We take [u] instead of [u[v/x]] in here as MetaCoq does it. *) 42 | is_arity u -> 43 | is_arity (definition v t u). 44 | 45 | Inductive type_scheme (R: typing_equivalence) (g: env): term -> Prop := 46 | | type_scheme_make: 47 | forall e t, 48 | typing g e t R -> 49 | is_arity t -> 50 | type_scheme R g e. 51 | 52 | Lemma type_scheme_sort: 53 | forall R g s, 54 | valid_env g R -> 55 | type_scheme R g (sort s). 56 | Proof. 57 | intros. 58 | destruct s. 59 | - apply type_scheme_make with (type 0). 60 | + now repeat constructor. 61 | + constructor. 62 | - apply type_scheme_make with (type (1 + n)). 63 | + now repeat constructor. 64 | + constructor. 65 | Qed. 66 | 67 | (* Goal 68 | type_scheme polymorphic_id_type. 69 | Proof. 70 | apply type_scheme_mk with [] (sort iset). 71 | - repeat econstructor. 72 | + now vm_compute. 73 | + now vm_compute. 74 | + now vm_compute. 75 | + now vm_compute. 76 | - constructor. 77 | Qed. 78 | 79 | Goal 80 | ~type_scheme polymorphic_id_term. 81 | Proof. 82 | intro. 83 | dependent destruction H. 84 | (* We need a few inversion lemmas... *) 85 | admit. 86 | Admitted. *) 87 | 88 | Lemma is_arity_is_dec: 89 | forall t, 90 | { is_arity t } + { ~is_arity t }. 91 | Proof. 92 | induction t. 93 | - left; constructor. 94 | - right; inversion 1. 95 | - destruct IHt2. 96 | + left; now constructor. 97 | + right; now inversion 1. 98 | - right; inversion 1. 99 | - right; inversion 1. 100 | - destruct IHt3. 101 | + left; now constructor. 102 | + right; now inversion 1. 103 | - right; inversion 1. 104 | - right; inversion 1. 105 | - right; inversion 1. 106 | - right; inversion 1. 107 | - right; inversion 1. 108 | - right; inversion 1. 109 | - right; inversion 1. 110 | - right; inversion 1. 111 | - right; inversion 1. 112 | - right; inversion 1. 113 | - right; inversion 1. 114 | Qed. 115 | 116 | Definition schemes_only (R: typing_equivalence) (g: env): Prop := 117 | forall d n, 118 | (* TODO: improve this definition. *) 119 | item d g n -> exists s, typing g (lift (S n) 0 (snd d)) (sort s) R. 120 | 121 | Definition well_sorted (R: typing_equivalence) (g: env) (t: term): Prop := 122 | schemes_only R g /\ type_scheme R g t. 123 | 124 | Theorem sorting: 125 | forall R j, 126 | infer R j -> 127 | match j with 128 | | valid_env g => schemes_only R g 129 | | typing g e t => well_sorted R g t 130 | end. 131 | Proof. 132 | induction 1; intros. 133 | (* Case: iset. *) 134 | - split; auto. 135 | exists (type 1). 136 | + now constructor. 137 | + constructor. 138 | (* Case: type. *) 139 | - split; auto. 140 | exists (type (2 + n)). 141 | + now constructor. 142 | + constructor. 143 | (* Case: bound. *) 144 | - subst; split; auto. 145 | destruct IHinfer with (d, t) n as (s, ?). 146 | + assumption. 147 | + econstructor. 148 | * eassumption. 149 | * constructor. 150 | (* Case: pi. *) 151 | - subst. 152 | destruct IHinfer1. 153 | destruct IHinfer2. 154 | split; auto. 155 | apply type_scheme_sort. 156 | apply valid_env_typing in H. 157 | assumption. 158 | (* Case: abstraction. *) 159 | - destruct IHinfer as (?H, ?H). 160 | split. 161 | + admit. 162 | + admit. 163 | (* Case: application. *) 164 | - (* Type schemes are stable under substitution according to "A New 165 | Extraction for Coq". *) 166 | admit. 167 | (* Case: definition. *) 168 | - (* Ditto. *) 169 | admit. 170 | (* Case: sigma. *) 171 | - admit. 172 | (* Case: pair. *) 173 | - admit. 174 | (* Case: projection 1. *) 175 | - admit. 176 | (* Case: projection 2. *) 177 | - admit. 178 | (* Case: bool. *) 179 | - admit. 180 | (* Case: true. *) 181 | - admit. 182 | (* Case: false. *) 183 | - admit. 184 | (* Case: if. *) 185 | - admit. 186 | (* Case: thunk. *) 187 | - admit. 188 | (* Case: delay. *) 189 | - admit. 190 | (* Case: force. *) 191 | - admit. 192 | (* Case: conv. *) 193 | - admit. 194 | (* Case: empty env. *) 195 | - repeat intro. 196 | exfalso. 197 | inversion H. 198 | (* Case: env var. *) 199 | - repeat intro. 200 | dependent destruction H0; simpl. 201 | + exists s. 202 | replace (sort s) with (lift 1 0 (sort s)) by now sigma. 203 | apply weakening. 204 | * assumption. 205 | * now apply valid_env_var with s. 206 | + destruct IHinfer. 207 | specialize (H1 d n H0) as (s2, ?). 208 | exists s2. 209 | replace (sort s2) with (lift 1 0 (sort s2)) by now sigma. 210 | replace (lift (S (S n)) 0 (snd d)) with (lift 1 0 (lift (S n) 0 (snd d))) 211 | by now sigma. 212 | apply weakening. 213 | * assumption. 214 | * now apply valid_env_var with s. 215 | (* Case: env def. *) 216 | - intros d n ?. 217 | destruct n. 218 | + dependent destruction H1; simpl. 219 | exists s. 220 | replace (sort s) with (lift 1 0 (sort s)) by now sigma. 221 | apply weakening. 222 | * assumption. 223 | * now apply valid_env_def with s. 224 | + dependent destruction H1. 225 | destruct IHinfer1. 226 | specialize (H2 d n H1) as (s2, ?). 227 | exists s2. 228 | replace (sort s2) with (lift 1 0 (sort s2)) by now sigma. 229 | replace (lift (S (S n)) 0 (snd d)) with (lift 1 0 (lift (S n) 0 (snd d))) 230 | by now sigma. 231 | apply weakening. 232 | * assumption. 233 | * now apply valid_env_def with s. 234 | Admitted. 235 | 236 | Corollary validity: 237 | forall R g e t, 238 | typing g e t R -> 239 | type_scheme R g t. 240 | Proof. 241 | intros. 242 | now apply sorting in H as (?H, ?H). 243 | Qed. 244 | 245 | (* Validity says that if [G |- e : t], then [t] is a type scheme, thus there is 246 | some arity [a] such that [G |- t : a]. As arities are products, this means 247 | that there is an [s] such [G |- a : s]... how can we decide what receives or 248 | not negations during the translation, specially if we allow comulativity? 249 | 250 | IDEA: can we "fix" this by not caring...? E.g., could we, instead of using a 251 | type such as [~(x: T, ~U)], simply use [Pi x: T.U]? Then we really don't have 252 | to translate anything... *) 253 | 254 | (* ---------------------------------------------------------------------------*) 255 | 256 | (* TODO: rewrite this. 257 | 258 | We follow the usual definition of syntactic classes for terms, types and 259 | kinds in the calculus of constructions. These syntactic classes give us an 260 | equivalent formulation of the syntax which is guaranteed by typing, as we 261 | shall verify. Most interestingly, terms can't be type schemes, but types and 262 | kinds need to be, which is quite convenient. We will promptly ignore the 263 | distinction between type variables and term variables. TODO: do we want the 264 | classification to live in Prop...? *) 265 | 266 | Variant class: Set := 267 | | class_kind 268 | | class_type 269 | | class_term. 270 | 271 | Inductive stratify: class -> term -> Prop := 272 | (* [Prop] *) 273 | | stratify_prop: 274 | stratify class_kind iset 275 | (* [Pi x: T.S] *) 276 | | stratify_pi_type_kind: 277 | forall t u, 278 | stratify class_type t -> 279 | stratify class_kind u -> 280 | stratify class_kind (pi t u) 281 | (* [Pi X: S.S] *) 282 | | stratify_pi_kind_kind: 283 | forall t u, 284 | stratify class_kind t -> 285 | stratify class_kind u -> 286 | stratify class_kind (pi t u) 287 | (* [X] *) 288 | | stratify_bound_type: 289 | forall n, 290 | stratify class_type (bound n) 291 | (* [Pi x: T.T] *) 292 | | stratify_pi_type_type: 293 | forall t u, 294 | stratify class_type t -> 295 | stratify class_type u -> 296 | stratify class_type (pi t u) 297 | (* [Pi X: S.T] *) 298 | | stratify_pi_kind_type: 299 | forall t u, 300 | stratify class_kind t -> 301 | stratify class_type u -> 302 | stratify class_type (pi t u) 303 | (* [\x: T.T] *) 304 | | stratify_abs_type_type: 305 | forall t u, 306 | stratify class_type t -> 307 | stratify class_type u -> 308 | stratify class_type (abstraction t u) 309 | (* [\X: S.T] *) 310 | | stratify_abs_sort_type: 311 | forall t u, 312 | stratify class_kind t -> 313 | stratify class_type u -> 314 | stratify class_type (abstraction t u) 315 | (* [T e] *) 316 | | stratify_app_type_term: 317 | forall t e, 318 | stratify class_type t -> 319 | stratify class_term e -> 320 | stratify class_type (application t e) 321 | (* [T T] *) 322 | | stratify_app_type_type: 323 | forall t u, 324 | stratify class_type t -> 325 | stratify class_type u -> 326 | stratify class_type (application t u) 327 | (* [x] *) 328 | | stratify_bound_term: 329 | forall n, 330 | stratify class_term (bound n) 331 | (* [\x: T.e] *) 332 | | stratify_abs_type_term: 333 | forall t e, 334 | stratify class_type t -> 335 | stratify class_term e -> 336 | stratify class_term (abstraction t e) 337 | (* [\X: S.e] *) 338 | | stratify_abs_sort_term: 339 | forall t e, 340 | stratify class_kind t -> 341 | stratify class_term e -> 342 | stratify class_term (abstraction t e) 343 | (* [e e] *) 344 | | stratify_app_term_term: 345 | forall e f, 346 | stratify class_term e -> 347 | stratify class_term f -> 348 | stratify class_term (application e f) 349 | (* [e T] *) 350 | | stratify_app_term_type: 351 | forall e t, 352 | stratify class_term e -> 353 | stratify class_type t -> 354 | stratify class_term (application e t). 355 | 356 | Global Coercion stratify: class >-> Funclass. 357 | -------------------------------------------------------------------------------- /theories/Pi/Interpretation.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import Arith. 7 | Require Import Relations. 8 | Require Import Equality. 9 | Require Import Local.Prelude. 10 | Require Import Local.Substitution. 11 | Require Import Local.Syntax. 12 | Require Import Local.Observational. 13 | Require Import Local.TypeSystem. 14 | Require Import Local.Pi.Graph. 15 | Require Import Local.Pi.Calculus. 16 | Require Import Local.Pi.Control. 17 | 18 | Global Hint Unfold env_edge: cps. 19 | Global Hint Resolve dual_is_involutive: cps. 20 | Global Hint Resolve channel_equals_double_dual: cps. 21 | 22 | Section Interpretation. 23 | 24 | (* We did not define base types in the typesystem for the pi-calculus, so we 25 | parametrize everything by some arbitrary interpretation for base types. *) 26 | Variable pi_base: type. 27 | 28 | (* Of course, since the type system requires types to be I/O alternating, so 29 | should be the case of anything that is taken to be the base type. *) 30 | Hypothesis pi_base_is_output: alternating O pi_base. 31 | 32 | (* The CPS-calculus is defined as higher-order, so we make a relation stating 33 | that a term is indeed some variable. *) 34 | Definition is_variable (k: pseudoterm) (n: nat): Prop := 35 | k = bound n. 36 | 37 | Inductive interpret_type: pseudoterm -> type -> Prop := 38 | | interpret_type_base: 39 | interpret_type base pi_base 40 | | interpret_type_negation: 41 | forall ts cs t, 42 | Forall2 interpret_type ts cs -> 43 | t = dual (channel I cs) -> 44 | interpret_type (negation ts) t. 45 | 46 | Inductive interpret: pseudoterm -> term -> Prop := 47 | | interpret_jump: 48 | forall x xs n ns, 49 | is_variable x n -> 50 | Forall2 is_variable xs ns -> 51 | interpret (jump x xs) (output n ns) 52 | | interpret_bind: 53 | forall b ts c p cs q q', 54 | interpret b p -> 55 | interpret c q -> 56 | Forall2 interpret_type ts cs -> 57 | q' = lift 1 (length cs) q -> 58 | interpret (bind b ts c) (local_env p cs q'). 59 | 60 | Local Notation pB := (pi_base). 61 | Local Notation cO cs := (channel O cs). 62 | Local Notation cI cs := (channel I cs). 63 | 64 | Local Goal 65 | (* TODO: give an example number here. *) 66 | let p := 67 | (* \j.\x.\y.\z. 68 | (\h)((\k)(h@1 69 | | !k@0(a, b).h@3) 70 | | !h@0(c, d, e).d@1) *) 71 | (restriction 72 | (cI [pB; cO [dual pB; dual pB]; pB]) 73 | (parallel 74 | (restriction 75 | (cI [pB; pB]) 76 | (parallel 77 | (output 1 [4; 0; 3]) 78 | (replication 0 79 | [pB; pB] 80 | (output 3 [1; 7; 0])))) 81 | (replication 0 82 | [pB; cO [dual pB; dual pB]; pB] 83 | (output 1 [4; 0])))) 84 | (* Check interpretation for example 1. *) 85 | in interpret Syntax.ex1 p. 86 | Proof. 87 | (* Holds trivially by construction. *) 88 | repeat econstructor. 89 | Qed. 90 | 91 | (* To be honest, it's amazing that this is true up to the same [k]; i.e., the 92 | same number of variables is introduced in head position for both CPS term 93 | and the resulting process for the interpretation. *) 94 | Local Goal 95 | forall b p, 96 | interpret b p -> 97 | forall k, 98 | converges b k <-> observable p k. 99 | Proof. 100 | induction 1; split; intros. 101 | - dependent destruction H1. 102 | unfold is_variable in H. 103 | dependent destruction H. 104 | constructor. 105 | - unfold is_variable in H. 106 | dependent destruction H. 107 | dependent destruction H1. 108 | constructor. 109 | - dependent destruction H3. 110 | apply observable_restriction. 111 | apply observable_parallel_left. 112 | now apply IHinterpret1. 113 | - unfold local_env in H3. 114 | dependent destruction H3. 115 | dependent destruction H3. 116 | + constructor. 117 | now apply IHinterpret1. 118 | + exfalso. 119 | inversion H3. 120 | Qed. 121 | 122 | Lemma interpret_generates_output: 123 | forall t c, 124 | interpret_type t c -> 125 | alternating O c. 126 | Proof. 127 | fix H 3. 128 | destruct 1. 129 | - apply pi_base_is_output. 130 | - subst; simpl. 131 | constructor. 132 | induction H0; simpl. 133 | + constructor. 134 | + constructor; auto. 135 | replace I with (inverse O) by auto. 136 | apply alternating_inverse_dual. 137 | now apply H with x. 138 | Qed. 139 | 140 | Lemma interpret_forall_generates_output: 141 | forall ts cs, 142 | Forall2 interpret_type ts cs -> 143 | Forall (alternating O) cs. 144 | Proof. 145 | induction 1; simpl. 146 | - constructor. 147 | - constructor; auto. 148 | now apply interpret_generates_output with x. 149 | Qed. 150 | 151 | Inductive interpret_env: list pseudoterm -> env -> Prop := 152 | | interpret_env_nil: 153 | interpret_env [] empty 154 | | interpret_env_cons: 155 | forall t ts c cs k, 156 | interpret_type t c -> 157 | interpret_env ts cs -> 158 | k = (length ts) -> 159 | interpret_env (t :: ts) (overlay cs (env_singleton k c)). 160 | 161 | Lemma interpret_env_is_wellformed: 162 | forall g a, 163 | interpret_env g a -> 164 | env_wellformed a. 165 | Proof. 166 | induction g; intros. 167 | - dependent destruction H. 168 | apply empty_is_wellformed. 169 | - dependent destruction H. 170 | (* We know that c won't appear in cs. There will be a similar case in the 171 | [Control.v] file, take the lemma from there once it's finished! *) 172 | admit. 173 | Admitted. 174 | 175 | Lemma interpret_env_length: 176 | forall g a, 177 | interpret_env g a -> 178 | length g = introduced_vars a. 179 | Proof. 180 | unfold introduced_vars. 181 | induction 1; simpl. 182 | - reflexivity. 183 | - simpl in IHinterpret_env. 184 | rewrite <- IHinterpret_env. 185 | rewrite H1; lia. 186 | Qed. 187 | 188 | Lemma interpret_env_extend: 189 | forall ts cs, 190 | Forall2 interpret_type ts cs -> 191 | forall g a, 192 | interpret_env g a -> 193 | interpret_env (ts ++ g) (env_extend a (length g) cs). 194 | Proof. 195 | induction 1; simpl; intros. 196 | - assumption. 197 | - constructor. 198 | + assumption. 199 | + now apply IHForall2. 200 | + rewrite app_length. 201 | erewrite Forall2_length with _ l l'. 202 | * reflexivity. 203 | * eassumption. 204 | Qed. 205 | 206 | Lemma local_environment_coherence: 207 | forall g, 208 | env_wellformed g -> 209 | has_output_mode g -> 210 | forall k, 211 | ~has_free_name g k -> 212 | forall t, 213 | alternating I t -> 214 | env_coherent 215 | (overlay g (env_singleton k (dual t))) 216 | (connect (env_singleton k t) g). 217 | Proof. 218 | constructor; intros. 219 | - admit. 220 | - unfold env_type in H3, H4. 221 | dependent destruction H3. 222 | + dependent destruction H4. 223 | * exfalso. 224 | dependent destruction H4. 225 | apply H1; now exists t1. 226 | * (* We have a unique output type, so [t1 = t2], and they compose. *) 227 | exists t1. 228 | rewrite env_wellformed_unique with g t2 t1 i; auto. 229 | apply H0 in H3. 230 | destruct t1; simpl in H3; subst. 231 | now apply type_composition_oo with ts. 232 | + dependent destruction H4. 233 | * dependent destruction H3. 234 | dependent destruction H4. 235 | (* Trivial since t2 is an input type. *) 236 | exists t2; destruct t2. 237 | dependent destruction H2; simpl. 238 | apply type_composition_oi with (map dual ts); 239 | eauto with cps. 240 | * exfalso. 241 | dependent destruction H3. 242 | apply H1; now exists t2. 243 | - intro x. 244 | constructor; intros. 245 | (* Trivially acyclic: all edges we have are from [k] to [|g|]! *) 246 | admit. 247 | Admitted. 248 | 249 | Lemma interpretation_preserves_typing: 250 | forall b p, 251 | interpret b p -> 252 | forall g a, 253 | TypeSystem.typing g b void -> 254 | interpret_env g a -> 255 | Control.typing O p a. 256 | Proof. 257 | induction 1; intros. 258 | - admit. 259 | - subst. 260 | dependent destruction H3. 261 | unfold local_env. 262 | eapply typing_iso. 263 | + apply typing_res. 264 | * eapply typing_par. 265 | --- apply IHinterpret1 with (g := negation ts :: g). 266 | +++ assumption. 267 | +++ constructor; eauto. 268 | econstructor; eauto. 269 | --- (* This lifting in q, which means that a continuation doesn't 270 | appear free in its own definition, is remarkably convenient in 271 | here. It arises by the translation, syntactically, and it is 272 | required by the type system! *) 273 | apply typing_in with (g := a). 274 | +++ eapply IHinterpret2. 275 | *** eassumption. 276 | *** rewrite <- interpret_env_length with g a by auto. 277 | now apply interpret_env_extend. 278 | +++ admit. 279 | +++ now apply interpret_forall_generates_output with ts. 280 | --- replace (1 + introduced_vars a - 0 - 1) with 281 | (introduced_vars a) by lia. 282 | rewrite interpret_env_length with g a by auto. 283 | (* This lift becomes a no-op! *) 284 | rewrite lifting_over_introduced_vars_is_noop by auto. 285 | admit. 286 | --- constructor. 287 | * constructor. 288 | now apply interpret_forall_generates_output with ts. 289 | * replace (1 + introduced_vars a - 0 - 1) with 290 | (introduced_vars a) by lia. 291 | (* We can simplify this a bit. *) 292 | rewrite lifting_over_introduced_vars_is_noop by auto. 293 | apply env_composition_vertex_inversion. 294 | admit. 295 | + replace (1 + introduced_vars a - 0 - 1) with (introduced_vars a) by lia. 296 | admit. 297 | Admitted. 298 | 299 | Lemma interpretation_reflects_typing: 300 | forall b p, 301 | interpret b p -> 302 | forall g a, 303 | Control.typing O p a -> 304 | interpret_env g a -> 305 | TypeSystem.typing g b void. 306 | Proof. 307 | (* TODO: I suspect we'll need an equivalent type system to make this work, 308 | where the typing rules follow the structure of the terms by subsuming 309 | both graph isomorphism and local weakening. Alternatively, this could be 310 | seem as an induction scheme for the original type system (indeed, I 311 | should define it as one). *) 312 | admit. 313 | Admitted. 314 | 315 | Theorem control_calculus_typing_correspondence: 316 | forall b p, 317 | interpret b p -> 318 | forall g a, 319 | interpret_env g a -> 320 | TypeSystem.typing g b void <-> Control.typing O p a. 321 | Proof. 322 | split; intros. 323 | - now apply interpretation_preserves_typing with b g. 324 | - now apply interpretation_reflects_typing with p a. 325 | Qed. 326 | 327 | End Interpretation. 328 | -------------------------------------------------------------------------------- /theories/Transition.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2022 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import Arith. 7 | Require Import List. 8 | Require Import Relations. 9 | Require Import Equality. 10 | Require Import Local.Prelude. 11 | Require Import Local.AbstractRewriting. 12 | Require Import Local.Substitution. 13 | Require Import Local.Syntax. 14 | Require Import Local.Metatheory. 15 | Require Import Local.Context. 16 | Require Import Local.Reduction. 17 | (* TODO: We take only converges from here; might wanna move it to Syntax. *) 18 | Require Import Local.Observational. 19 | 20 | (* This labelled transition semantics comes from Merro's paper, "On the 21 | Observational Theory of the CPS-calculus". We note that a label is either a 22 | silent action, tau, or an output action in the form of kM. Merro mentions 23 | that the transition system is necessarily higher-order (carrying the M) in 24 | order to preserve some properties, but this doesn't seem to be necessary, 25 | actually. TODO: remove the M term from the label. 26 | 27 | We note that we give a special purpose for the k de Bruijn index in here, as 28 | we are reserving it to be the name of the continuation to jump to. I.e., in 29 | an action kM, we're saying a term performs an action which may interact 30 | with the discriminating context [] { k = M }. *) 31 | 32 | Inductive label: Set := 33 | | label_tau 34 | | label_jmp (k: nat) (ts: list pseudoterm) (b: pseudoterm). 35 | 36 | Inductive transition: label -> relation pseudoterm := 37 | (* 38 | x \notin FV(a) 39 | --------------------------------------- (JMP) 40 | aM 41 | a ---------> M[b/x] { a = M } 42 | *) 43 | | transition_jmp: 44 | forall k xs ts c, 45 | length xs = length ts -> 46 | transition (label_jmp k ts c) (jump 0 xs) 47 | (bind 48 | (apply_parameters xs 0 (lift 1 (length ts) c)) ts c) 49 | 50 | (* 51 | aN 52 | M ---------> M' { a = N } a != b b \notin FV(N) 53 | ---------------------------------------------------------------- (CTX-JMP) 54 | aN 55 | M { b = O } ---------> M' { b = O } { a = N } 56 | *) 57 | | transition_ctx_jmp: 58 | forall k a b ts c us d, 59 | (* This lift was hinted by the "Proof-relevant pi-calculus" paper! *) 60 | transition 61 | (label_jmp k (traverse_list (lift 1) 0 ts) (lift 1 (length ts) c)) 62 | a 63 | (bind b (traverse_list (lift 1) 0 ts) (lift 1 (length ts) c)) -> 64 | transition 65 | (label_jmp k ts c) 66 | (bind (switch_bindings 0 a) us d) 67 | (bind (bind (switch_bindings 0 b) us d) ts c) 68 | 69 | (* 70 | aN 71 | M ---------> M' 72 | ---------------------------- (TAU) 73 | T 74 | M { a = N } -----> M' 75 | *) 76 | | transition_tau: 77 | forall k a b ts c, 78 | transition (label_jmp k ts c) a b -> 79 | transition label_tau (bind a ts c) b 80 | 81 | (* 82 | T 83 | M -----> M' 84 | ----------------------------------------- (CTX-TAU) 85 | T 86 | M { a = N } -----> M' { a = N } 87 | *) 88 | | transition_ctx_tau: 89 | forall a b ts c, 90 | transition label_tau a b -> 91 | transition label_tau (bind a ts c) (bind b ts c). 92 | 93 | Inductive transition_label_jmp_invariant (k: nat) ts c a b: Prop := 94 | transition_label_jmp_invariant_ctor 95 | (h: context) 96 | (H1: static h) 97 | (* H2: k = #h *) 98 | (xs: list pseudoterm) 99 | (H3: length xs = length ts) 100 | (H4: a = h (jump #h xs)) 101 | (H5: b = bind 102 | (h 103 | (apply_parameters xs 0 (lift (S #h) (length ts) c))) 104 | ts c). 105 | 106 | Lemma transition_jmp_preserves_invariant: 107 | forall k ts c a b, 108 | transition (label_jmp k ts c) a b -> 109 | transition_label_jmp_invariant k ts c a b. 110 | Proof. 111 | intros. 112 | dependent induction H. 113 | (* Case: transition_jmp. *) 114 | - apply transition_label_jmp_invariant_ctor with context_hole xs; simpl. 115 | + constructor. 116 | + assumption. 117 | + reflexivity. 118 | + reflexivity. 119 | (* Case: transition_ctx_jmp. *) 120 | - clear H. 121 | edestruct IHtransition; eauto. 122 | dependent destruction H5. 123 | (* This has all that we need. *) 124 | apply transition_label_jmp_invariant_ctor with 125 | (context_left (context_switch_bindings 0 h) us d) 126 | (map (switch_bindings #h) xs); simpl. 127 | + constructor. 128 | apply static_context_switch_bindings; auto. 129 | + rewrite traverse_list_length in H3. 130 | rewrite map_length. 131 | assumption. 132 | + rewrite context_switch_bindings_is_sound. 133 | rewrite Nat.add_0_r. 134 | f_equal; f_equal. 135 | rewrite switch_bindings_distributes_over_jump. 136 | f_equal. 137 | rewrite switch_bindings_bound_eq; auto. 138 | rewrite context_switch_bindings_bvars. 139 | reflexivity. 140 | + f_equal; f_equal. 141 | rewrite traverse_list_length. 142 | rewrite lift_lift_simplification; try lia. 143 | rewrite context_switch_bindings_is_sound. 144 | rewrite Nat.add_0_r. 145 | replace (S #h + 1) with (S (S #h)); try lia. 146 | f_equal; clear H1 d us. 147 | (* TODO: I'd like to prove this one with sigma! Can we try later? *) 148 | rewrite switch_bindings_behavior. 149 | rewrite right_cycle_characterization. 150 | rewrite lift_distributes_over_apply_parameters. 151 | simpl sequence. 152 | simpl app. 153 | rewrite apply_parameters_cons. 154 | rewrite apply_parameters_cons. 155 | rewrite apply_parameters_nil. 156 | rewrite subst_distributes_over_apply_parameters. 157 | rewrite map_map; f_equal. 158 | rewrite map_length. 159 | rewrite traverse_list_length in H3. 160 | rewrite context_switch_bindings_bvars. 161 | rewrite lift_lift_simplification by lia. 162 | simpl. 163 | rewrite subst_lift_simplification by lia. 164 | rewrite subst_distributes_over_apply_parameters. 165 | rewrite map_map. 166 | rewrite map_length. 167 | rewrite subst_lift_simplification by lia. 168 | erewrite map_ext; intros. 169 | * reflexivity. 170 | * rewrite switch_bindings_behavior. 171 | rewrite right_cycle_characterization. 172 | simpl sequence. 173 | simpl app. 174 | repeat rewrite apply_parameters_cons. 175 | rewrite apply_parameters_nil. 176 | reflexivity. 177 | Qed. 178 | 179 | Local Lemma transition_ctx_jmp_helper: 180 | forall k a b ts c us d e f g h, 181 | transition (label_jmp k e f) a (bind b e f) -> 182 | e = (traverse_list (lift 1) 0 ts) -> 183 | f = (lift 1 (length ts) c) -> 184 | g = (switch_bindings 0 a) -> 185 | h = (bind (switch_bindings 0 b) us d) -> 186 | transition (label_jmp k ts c) (bind g us d) (bind h ts c). 187 | Proof. 188 | intros until 5. 189 | generalize H; clear H. 190 | rewrite H0, H1, H2, H3. 191 | apply transition_ctx_jmp. 192 | Qed. 193 | 194 | Lemma transition_tau_longjmp: 195 | forall h, 196 | static h -> 197 | forall xs ts c, 198 | length xs = length ts -> 199 | transition label_tau (bind (h (jump #h xs)) ts c) 200 | (bind (h (apply_parameters xs 0 (lift (S #h) (length ts) c))) ts c). 201 | Proof. 202 | intros. 203 | (* We start by applying (TAU) to fix the binding. *) 204 | apply transition_tau with #h. 205 | generalize xs ts c H0; clear xs ts c H0. 206 | (* Our induction has to happen on #h, not h itself! *) 207 | assert (exists k, k = #h) as (k, ?H); eauto. 208 | generalize #h at 1 as n. 209 | replace #h with k; auto. 210 | generalize dependent h. 211 | (* Now we can proceed to prove it. *) 212 | induction k; intros. 213 | (* Case: zero. *) 214 | - (* Clearly we're at a hole! *) 215 | destruct H; try discriminate; simpl. 216 | (* Immediate jump! *) 217 | apply transition_jmp. 218 | assumption. 219 | (* Case: succ. *) 220 | - (* We clearly have a left context. *) 221 | destruct H; try discriminate. 222 | simpl in H0 |- *. 223 | (* We will apply a (CTX-JMP) here, but there's a lot of housekeeping. *) 224 | eapply transition_ctx_jmp_helper with 225 | (e := traverse_list (lift 1) 0 ts) 226 | (f := lift 1 (length ts) c). 227 | + apply IHk with 228 | (h := context_switch_bindings 0 h) 229 | (xs := map (switch_bindings #h) xs). 230 | * apply static_context_switch_bindings; auto. 231 | * rewrite context_switch_bindings_bvars; lia. 232 | * rewrite map_length. 233 | rewrite traverse_list_length. 234 | assumption. 235 | + reflexivity. 236 | + reflexivity. 237 | + rewrite context_switch_bindings_is_sound; simpl. 238 | rewrite context_switch_bindings_is_involutive. 239 | rewrite context_switch_bindings_bvars. 240 | rewrite Nat.add_0_r. 241 | rewrite switch_bindings_distributes_over_jump. 242 | rewrite switch_bindings_bound_eq; try lia. 243 | f_equal; f_equal. 244 | rewrite map_switch_bindings_is_involutive; auto. 245 | + f_equal. 246 | rewrite context_switch_bindings_is_sound. 247 | rewrite context_switch_bindings_is_involutive. 248 | rewrite context_switch_bindings_bvars. 249 | rewrite Nat.add_0_r. 250 | rewrite traverse_list_length. 251 | rewrite lift_lift_simplification; try lia. 252 | replace (S k + 1) with (S (S k)); try lia. 253 | replace k with #h; try lia. 254 | f_equal. 255 | (* Same as in the lemma above... TODO: move this property to its own lemma 256 | to avoid code duplication, and, if possible, try to prove it with the 257 | sigma tactic instead. *) 258 | rewrite switch_bindings_behavior. 259 | rewrite right_cycle_characterization. 260 | rewrite lift_distributes_over_apply_parameters. 261 | simpl sequence. 262 | simpl app. 263 | rewrite apply_parameters_cons. 264 | rewrite apply_parameters_cons. 265 | rewrite apply_parameters_nil. 266 | rewrite subst_distributes_over_apply_parameters. 267 | rewrite map_map; f_equal. 268 | repeat rewrite map_length. 269 | rewrite lift_lift_simplification by lia. 270 | simpl. 271 | rewrite subst_lift_simplification by lia. 272 | rewrite subst_distributes_over_apply_parameters. 273 | rewrite map_map. 274 | repeat rewrite map_length. 275 | rewrite subst_lift_simplification by lia. 276 | erewrite map_ext; intros. 277 | * rewrite map_switch_bindings_is_involutive. 278 | reflexivity. 279 | * rewrite switch_bindings_behavior. 280 | rewrite right_cycle_characterization. 281 | simpl sequence. 282 | simpl app. 283 | repeat rewrite apply_parameters_cons. 284 | rewrite apply_parameters_nil. 285 | reflexivity. 286 | Qed. 287 | 288 | Lemma transition_tau_head: 289 | forall a b, 290 | head a b -> transition label_tau a b. 291 | Proof. 292 | intros. 293 | destruct H. 294 | induction H0; simpl. 295 | - apply transition_tau_longjmp; auto. 296 | - apply transition_ctx_tau; auto. 297 | Qed. 298 | 299 | Lemma head_transition_tau: 300 | forall a b, 301 | transition label_tau a b -> head a b. 302 | Proof. 303 | intros. 304 | dependent induction H. 305 | (* Case: transition_tau. *) 306 | - clear IHtransition. 307 | edestruct transition_jmp_preserves_invariant; eauto. 308 | rewrite H4. 309 | rewrite H5. 310 | apply (head_longjmp h context_hole); auto with cps. 311 | (* Case: transition_tau_ctx. *) 312 | - apply head_bind_left. 313 | firstorder. 314 | Qed. 315 | 316 | Lemma converges_transition_jmp: 317 | forall k ts c a b, 318 | transition (label_jmp k ts c) a b -> 319 | converges a 0. 320 | Proof. 321 | intros. 322 | apply transition_jmp_preserves_invariant in H. 323 | dependent destruction H. 324 | dependent destruction H4. 325 | clear H3 H5 k. 326 | assert (exists k, k = #h + 0) as (k, ?); eauto. 327 | replace #h with k; try lia. 328 | generalize dependent k. 329 | generalize O as n. 330 | induction H1; simpl; intros. 331 | - destruct H. 332 | constructor. 333 | - constructor. 334 | apply IHstatic. 335 | lia. 336 | Qed. 337 | 338 | Theorem head_and_transition_tau_are_equivalent: 339 | (* Merro, lemma 2.4 (2). *) 340 | same_relation head (transition label_tau). 341 | Proof. 342 | split; intros. 343 | - exact transition_tau_head. 344 | - exact head_transition_tau. 345 | Qed. 346 | 347 | (* -------------------------------------------------------------------------- *) 348 | 349 | Lemma tau_eq_dec: 350 | forall l, 351 | { l = label_tau } + { l <> label_tau }. 352 | Proof. 353 | induction l. 354 | - left; reflexivity. 355 | - right; discriminate. 356 | Defined. 357 | 358 | Definition weak (l: label): relation pseudoterm := 359 | weak_transition transition tau_eq_dec l. 360 | 361 | Definition bisi: relation pseudoterm := 362 | bisimilarity transition tau_eq_dec. 363 | 364 | Lemma bisi_refl: 365 | reflexive bisi. 366 | Proof. 367 | apply bisimilarity_refl. 368 | Qed. 369 | 370 | Lemma bisi_sym: 371 | symmetric bisi. 372 | Proof. 373 | apply bisimilarity_sym. 374 | Qed. 375 | 376 | Lemma bisi_trans: 377 | transitive bisi. 378 | Proof. 379 | apply bisimilarity_trans. 380 | Qed. 381 | -------------------------------------------------------------------------------- /theories/Constructions/TypeSystem.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import List. 6 | Require Import Relations. 7 | Require Import Equality. 8 | Require Import Local.Prelude. 9 | Require Import Local.Substitution. 10 | Require Import Local.AbstractRewriting. 11 | Require Import Local.Constructions.Calculus. 12 | Require Import Local.Constructions.Conversion. 13 | 14 | Import ListNotations. 15 | 16 | Definition typing_equivalence: Type := 17 | env -> relation term. 18 | 19 | Section TypeSystem. 20 | 21 | Variant typing_judgement: Set := 22 | | valid_env (g: env) 23 | | typing (g: env) (e: term) (t: term). 24 | 25 | Variable R: typing_equivalence. 26 | 27 | Inductive infer: typing_judgement -> Prop := 28 | (* 29 | |- G 30 | ---------------------- 31 | G |- Set : Type 0 32 | *) 33 | | typing_iset: 34 | forall g, 35 | infer (valid_env g) -> 36 | infer (typing g iset (type 0)) 37 | (* 38 | |- G 39 | ---------------------- 40 | G |- Type n : Type (1 + n) 41 | *) 42 | | typing_type: 43 | forall g n, 44 | infer (valid_env g) -> 45 | infer (typing g (type n) (type (1 + n))) 46 | (* 47 | (x: T) or (x = e: T) in G 48 | ----------------------------- 49 | G |- x : T 50 | *) 51 | | typing_bound: 52 | forall g n d t u, 53 | infer (valid_env g) -> 54 | item (d, t) g n -> 55 | u = lift (1 + n) 0 t -> 56 | infer (typing g (bound n) u) 57 | (* 58 | G |- T : s1 G, x: T |- U : s2 59 | -------------------------------------- 60 | G |- Pi x: T.U : s1 o s2 61 | *) 62 | | typing_pi: 63 | (* Sort of products will deal with impredicativity for prop, and will get 64 | the right universe level otherwise. *) 65 | forall g t u s1 s2 s3, 66 | infer (typing g t (sort s1)) -> 67 | infer (typing (decl_var t :: g) u (sort s2)) -> 68 | s3 = sort_of_product s1 s2 -> 69 | infer (typing g (pi t u) s3) 70 | (* 71 | G, x: T |- e : U 72 | ---------------------------- 73 | G |- \x: T.e : Pi x: T.U 74 | *) 75 | | typing_abs: 76 | forall g t e u, 77 | infer (typing (decl_var t :: g) e u) -> 78 | infer (typing g (abstraction t e) (pi t u)) 79 | (* 80 | G |- f : Pi x: T.U G |- e : T 81 | ------------------------------------- 82 | G |- f e : U[e/x] 83 | *) 84 | | typing_app: 85 | forall g f e t u v, 86 | infer (typing g f (pi t u)) -> 87 | infer (typing g e t) -> 88 | v = subst e 0 u -> 89 | infer (typing g (application f e) v) 90 | (* 91 | G |- e : T G, x = e: T |- f : U 92 | --------------------------------------- 93 | G |- let x = e: T in f : U[e/x] 94 | *) 95 | | typing_def: 96 | forall g e f t u v, 97 | infer (typing g e t) -> 98 | infer (typing (decl_def e t :: g) f u) -> 99 | v = subst e 0 u -> 100 | infer (typing g (definition e t f) v) 101 | (* 102 | G |- T : s1 G, x: T |- U : s2 103 | ------------------------------------- 104 | G |- Sigma x: T.U : s1 & s2 105 | *) 106 | | typing_sigma: 107 | forall g t u s1 s2 s3, 108 | infer (typing g t (sort s1)) -> 109 | infer (typing (decl_var t :: g) u (sort s2)) -> 110 | s3 = supremum s1 s2 -> 111 | infer (typing g (sigma t u) s3) 112 | (* 113 | G |- e : T G |- f : U[e/x] 114 | ------------------------------------------------ 115 | G |- (e, f) as (Sigma x: T.U) : Sigma x: T.U 116 | *) 117 | | typing_pair: 118 | (* Notice we require the typing annotation in the pair to keep the type 119 | unique; this is similar to how it's encoded in Coq and how it was done 120 | by Luo. The "x" used in the hypothesis would come from there. *) 121 | forall g e f t u, 122 | infer (typing g e t) -> 123 | infer (typing g f (subst e 0 u)) -> 124 | infer (typing g (pair e f (sigma t u)) (sigma t u)) 125 | (* 126 | G |- e : Sigma x: T.U 127 | ------------------------- 128 | G |- proj1 e : T 129 | *) 130 | | typing_proj1: 131 | forall g e t u, 132 | infer (typing g e (sigma t u)) -> 133 | infer (typing g (proj1 e) t) 134 | (* 135 | G |- e : Sigma x: T.U 136 | ------------------------------- 137 | G |- proj2 e : U[proj1 e/x] 138 | *) 139 | | typing_proj2: 140 | forall g e t u, 141 | infer (typing g e (sigma t u)) -> 142 | infer (typing g (proj2 e) (subst (proj1 e) 0 u)) 143 | (* 144 | |- G 145 | ------------------- 146 | G |- bool: Set 147 | *) 148 | | typing_bool: 149 | forall g, 150 | infer (valid_env g) -> 151 | infer (typing g boolean (sort iset)) 152 | (* 153 | |- G 154 | ----------------- 155 | G |- tt: bool 156 | *) 157 | | typing_true: 158 | forall g, 159 | infer (valid_env g) -> 160 | infer (typing g bool_tt boolean) 161 | (* 162 | |- G 163 | ----------------- 164 | G |- ff: bool 165 | *) 166 | | typing_false: 167 | forall g, 168 | infer (valid_env g) -> 169 | infer (typing g bool_ff boolean) 170 | (* 171 | G |- e : bool G, x: bool |- T : s 172 | G |- f1 : T[true/x] G |- f2 : T[false/x] 173 | ---------------------------------------------------- 174 | G |- if e as x return T then f1 else f2 : T[e/x] 175 | *) 176 | | typing_if: 177 | forall g e t s f1 f2, 178 | infer (typing g e boolean) -> 179 | infer (typing (decl_var boolean :: g) t (sort s)) -> 180 | infer (typing g f1 (subst bool_tt 0 t)) -> 181 | infer (typing g f2 (subst bool_ff 0 t)) -> 182 | infer (typing g (bool_if e t f1 f2) (subst e 0 t)) 183 | (* 184 | G |- T : s 185 | ---------------- 186 | G |- : s 187 | *) 188 | | typing_thunk: 189 | forall g t s, 190 | infer (typing g t (sort s)) -> 191 | infer (typing g (thunk t) (sort s)) 192 | (* 193 | G |- e : T 194 | ------------------- 195 | G |- ?(e) : 196 | *) 197 | | typing_delay: 198 | forall g e t, 199 | infer (typing g e t) -> 200 | infer (typing g (delay e) (thunk t)) 201 | (* 202 | G |- e : 203 | ----------------- 204 | G |- !(e) : T 205 | *) 206 | | typing_force: 207 | forall g e t, 208 | infer (typing g e (thunk t)) -> 209 | infer (typing g (force e) t) 210 | (* 211 | G |- e : T G |- U : s G |- T R U 212 | -------------------------------------------- 213 | G |- e : U 214 | *) 215 | | typing_conv: 216 | forall g e t u s, 217 | infer (typing g e t) -> 218 | infer (typing g u (sort s)) -> 219 | R g t u -> 220 | infer (typing g e u) 221 | (* 222 | -------- 223 | |- . 224 | *) 225 | | valid_env_nil: 226 | infer (valid_env []) 227 | (* 228 | G |- T : s 229 | -------------- 230 | |- G, x: T 231 | *) 232 | | valid_env_var: 233 | forall g t s, 234 | infer (typing g t (sort s)) -> 235 | infer (valid_env (decl_var t :: g)) 236 | (* 237 | G |- e : T G |- T : s 238 | ----------------------------- 239 | |- G, x = e: T 240 | *) 241 | | valid_env_def: 242 | forall g e t s, 243 | infer (typing g e t) -> 244 | infer (typing g t (sort s)) -> 245 | infer (valid_env (decl_def e t :: g)). 246 | 247 | (* Coq term: [\X: Prop.\x: X.x]. *) 248 | Example polymorphic_id_term: term := 249 | abstraction (sort iset) (abstraction (bound 0) (bound 0)). 250 | 251 | (* Coq term: [Pi X: Prop.X -> X]. *) 252 | Example polymorphic_id_type: term := 253 | pi (sort iset) (pi (bound 0) (bound 1)). 254 | 255 | (* Let's check typeability. *) 256 | Local Goal 257 | infer (typing [] polymorphic_id_term polymorphic_id_type). 258 | Proof. 259 | repeat econstructor. 260 | (* Of course! *) 261 | now vm_compute. 262 | Qed. 263 | 264 | (* Are we safe with higher sigma types? *) 265 | Local Goal 266 | infer (typing [] (sigma iset (bound 0)) (type 0)). 267 | Proof. 268 | repeat econstructor. 269 | - now vm_compute. 270 | - now vm_compute. 271 | Qed. 272 | 273 | End TypeSystem. 274 | 275 | Definition lift_judgement (j: typing_judgement): typing_equivalence -> Prop := 276 | fun R => infer R j. 277 | 278 | Global Coercion lift_judgement: typing_judgement >-> Funclass. 279 | 280 | Definition get_environment (j: typing_judgement): env := 281 | match j with 282 | | valid_env g => g 283 | | typing g _ _ => g 284 | end. 285 | 286 | Lemma valid_env_infer: 287 | forall R j, 288 | infer R j -> 289 | valid_env (get_environment j) R. 290 | Proof. 291 | (* Because the case for definitions doesn't have a subterm with the same 292 | environment, we need to slightly generalize the inductive hypothesis to 293 | say that every tail is valid instead. *) 294 | intros. 295 | change (get_environment j) with (skipn 0 (get_environment j)). 296 | generalize O. 297 | (* Now we can proceed... *) 298 | induction H; simpl in *; intros; auto. 299 | (* Case: definition. *) 300 | - (* Now the trick is to decrease a bit more from the hypothesis. *) 301 | apply IHinfer with (n := 1 + n). 302 | (* Case: empty env. *) 303 | - destruct n. 304 | + constructor. 305 | + constructor. 306 | (* Case: env var. *) 307 | - destruct n; simpl. 308 | + now apply valid_env_var with s. 309 | + apply IHinfer. 310 | (* Case: env def. *) 311 | - destruct n; simpl. 312 | + now apply valid_env_def with s. 313 | + (* Either one of the hypotheses work... *) 314 | apply IHinfer1. 315 | Qed. 316 | 317 | Lemma valid_env_typing: 318 | forall R g e t, 319 | typing g e t R -> 320 | valid_env g R. 321 | Proof. 322 | intros. 323 | apply valid_env_infer in H. 324 | assumption. 325 | Qed. 326 | 327 | Lemma infer_subset: 328 | forall R S, 329 | (forall g, inclusion (R g) (S g)) -> 330 | forall j, 331 | infer R j -> 332 | infer S j. 333 | Proof. 334 | (* We simply reconstruct the proof tree, judgement by judgement. *) 335 | induction 2. 336 | (* Case: iset. *) 337 | - now apply typing_iset. 338 | (* Case: type. *) 339 | - now apply typing_type. 340 | (* Case: bound. *) 341 | - now apply typing_bound with d t. 342 | (* Case: pi. *) 343 | - now apply typing_pi with s1 s2. 344 | (* Case: abstraction. *) 345 | - now apply typing_abs. 346 | (* Case: application. *) 347 | - now apply typing_app with t u. 348 | (* Case: definition. *) 349 | - now apply typing_def with u. 350 | (* Case: sigma. *) 351 | - now apply typing_sigma with s1 s2. 352 | (* Case: pair. *) 353 | - now apply typing_pair. 354 | (* Case: projection 1. *) 355 | - now apply typing_proj1 with u. 356 | (* Case: projection 2. *) 357 | - now apply typing_proj2 with t. 358 | (* Case: bool. *) 359 | - now apply typing_bool. 360 | (* Case: true. *) 361 | - now apply typing_true. 362 | (* Case: false. *) 363 | - now apply typing_false. 364 | (* Case: if. *) 365 | - now apply typing_if with s. 366 | (* Case: thunk. *) 367 | - now apply typing_thunk. 368 | (* Case: delay. *) 369 | - now apply typing_delay. 370 | (* Case: force. *) 371 | - now apply typing_force. 372 | - (* The only difference in the structure is on the (CONV) rule, which will 373 | require us to show that [t] and [u] are still convertible under the new 374 | rule. *) 375 | apply typing_conv with t s. 376 | + assumption. 377 | + assumption. 378 | + now apply H. 379 | (* Case: empty env. *) 380 | - apply valid_env_nil. 381 | (* Case: env var. *) 382 | - now apply valid_env_var with s. 383 | (* Case: env def. *) 384 | - now apply valid_env_def with s. 385 | Qed. 386 | 387 | Conjecture weakening: 388 | (* TODO: prove this later! *) 389 | forall g e t R, 390 | typing g e t R -> 391 | forall d, 392 | valid_env (d :: g) R -> 393 | typing (d :: g) (lift 1 0 e) (lift 1 0 t) R. 394 | 395 | Conjecture subject_reduction: 396 | (* TODO: prove this later. TODO: generalize to other equivalences. *) 397 | forall g e t, 398 | typing g e t conv -> 399 | forall f, 400 | rt(step g) e f -> 401 | typing g f t conv. 402 | 403 | (* We want to check that the beta-lift rule from ANF is type-preserving. This is 404 | a generalization of the sigma-1 and sigma-3 reduction rules from [...]. 405 | 406 | TODO: move to its own file; test beta-flat et al. *) 407 | 408 | Inductive cbv_eval_context: context -> Prop := 409 | | cbv_eval_context_hole: 410 | cbv_eval_context context_hole 411 | | cbv_eval_context_app_left: 412 | forall h f, 413 | cbv_eval_context h -> 414 | cbv_eval_context (context_app_left h f) 415 | | cbv_eval_context_app_right: 416 | forall v h, 417 | value v -> 418 | cbv_eval_context h -> 419 | cbv_eval_context (context_app_right v h) 420 | (* TODO: remaining cases. *). 421 | 422 | (* TODO: need I say anything? *) 423 | 424 | Axiom context_lift: nat -> nat -> context -> context. 425 | 426 | Axiom context_lift_simpl1: 427 | forall i k, 428 | context_lift i k context_hole = context_hole. 429 | 430 | Axiom context_lift_simpl2: 431 | forall i k h f, 432 | context_lift i k (context_app_left h f) = 433 | context_app_left (context_lift i k h) (lift i k f). 434 | 435 | Axiom context_lift_simpl3: 436 | forall i k e h, 437 | context_lift i k (context_app_right e h) = 438 | context_app_right (lift i k e) (context_lift i k h). 439 | 440 | Lemma beta_lift: 441 | forall R h, 442 | cbv_eval_context h -> 443 | forall g t e f u, 444 | (* G |- E[(\x: t.e) f] : u *) 445 | typing g (h (application (abstraction t e) f)) u R -> 446 | (* G |- (\x: t.E[e]) f *) 447 | typing g (application (abstraction t (context_lift 1 0 h e)) f) u R. 448 | Proof. 449 | induction 1; intros. 450 | - simpl. 451 | rewrite context_lift_simpl1; simpl. 452 | assumption. 453 | - rewrite context_lift_simpl2; simpl in H0 |- *. 454 | (* We need inversion on H0 for this... *) 455 | admit. 456 | - rewrite context_lift_simpl3; simpl in H0 |- *. 457 | (* We need inversion on H1 as well... *) 458 | admit. 459 | Admitted. 460 | -------------------------------------------------------------------------------- /theories/Constructions/Conversion.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2024 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Relations. 6 | Require Import Equality. 7 | Require Import Local.Prelude. 8 | Require Import Local.AbstractRewriting. 9 | Require Import Local.Substitution. 10 | Require Import Local.Constructions.Calculus. 11 | 12 | Inductive step: env -> relation term := 13 | (* Beta reduction. *) 14 | | step_beta: 15 | forall g t e f, 16 | step g (application (abstraction t e) f) (subst f 0 e) 17 | (* Zeta reduction. *) 18 | | step_zeta: 19 | forall g e t f, 20 | step g (definition e t f) (subst e 0 f) 21 | (* Delta reduction. *) 22 | | step_delta: 23 | forall g t e n, 24 | item (decl_def e t) g n -> 25 | step g (bound n) (lift (1 + n) 0 e) 26 | (* Pi reductions. *) 27 | | step_pi1: 28 | forall g e f t, 29 | step g (proj1 (pair e f t)) e 30 | | step_pi2: 31 | forall g e f t, 32 | step g (proj2 (pair e f t)) f 33 | (* Iota reductions. *) 34 | | step_tt: 35 | forall g t f1 f2, 36 | step g (bool_if bool_tt t f1 f2) f1 37 | | step_ff: 38 | forall g t f1 f2, 39 | step g (bool_if bool_ff t f1 f2) f2 40 | (* Congruence closure... many rules! *) 41 | | step_pi_type: 42 | forall g t1 t2 u, 43 | step g t1 t2 -> 44 | step g (pi t1 u) (pi t2 u) 45 | | step_pi_body: 46 | forall g t u1 u2, 47 | step (decl_var t :: g) u1 u2 -> 48 | step g (pi t u1) (pi t u2) 49 | | step_abs_type: 50 | forall g t1 t2 e, 51 | step g t1 t2 -> 52 | step g (abstraction t1 e) (abstraction t2 e) 53 | | step_abs_body: 54 | forall g t e1 e2, 55 | step (decl_var t :: g) e1 e2 -> 56 | step g (abstraction t e1) (abstraction t e2) 57 | | step_app_left: 58 | forall g e1 e2 f, 59 | step g e1 e2 -> 60 | step g (application e1 f) (application e2 f) 61 | | step_app_right: 62 | forall g e f1 f2, 63 | step g f1 f2 -> 64 | step g (application e f1) (application e f2) 65 | | step_def_term: 66 | forall g e1 e2 t f, 67 | step g e1 e2 -> 68 | step g (definition e1 t f) (definition e2 t f) 69 | | step_def_type: 70 | forall g e t1 t2 f, 71 | step g t1 t2 -> 72 | step g (definition e t1 f) (definition e t2 f) 73 | | step_def_body: 74 | forall g e t f1 f2, 75 | step (decl_def e t :: g) f1 f2 -> 76 | step g (definition e t f1) (definition e t f2) 77 | | step_sigma_type: 78 | forall g t1 t2 u, 79 | step g t1 t2 -> 80 | step g (sigma t1 u) (sigma t2 u) 81 | | step_sigma_body: 82 | forall g t u1 u2, 83 | step (decl_var t :: g) u1 u2 -> 84 | step g (sigma t u1) (sigma t u2) 85 | | step_pair_left: 86 | forall g e1 e2 f t, 87 | step g e1 e2 -> 88 | step g (pair e1 f t) (pair e2 f t) 89 | | step_pair_right: 90 | forall g e f1 f2 t, 91 | step g f1 f2 -> 92 | step g (pair e f1 t) (pair e f2 t) 93 | | step_pair_type: 94 | forall g e f t1 t2, 95 | step g t1 t2 -> 96 | step g (pair e f t1) (pair e f t2) 97 | | step_proj1: 98 | forall g e1 e2, 99 | step g e1 e2 -> 100 | step g (proj1 e1) (proj1 e2) 101 | | step_proj2: 102 | forall g e1 e2, 103 | step g e1 e2 -> 104 | step g (proj2 e1) (proj2 e2) 105 | | step_if_term: 106 | forall g e1 e2 t f1 f2, 107 | step g e1 e2 -> 108 | step g (bool_if e1 t f1 f2) (bool_if e2 t f1 f2) 109 | | step_if_type: 110 | forall g e t1 t2 f1 f2, 111 | step (decl_var boolean :: g) t1 t2 -> 112 | step g (bool_if e t1 f1 f2) (bool_if e t2 f1 f2) 113 | | step_if_then: 114 | forall g e t f11 f12 f2, 115 | step g f11 f12 -> 116 | step g (bool_if e t f11 f2) (bool_if e t f12 f2) 117 | | step_if_else: 118 | forall g e t f1 f21 f22, 119 | step g f21 f22 -> 120 | step g (bool_if e t f1 f21) (bool_if e t f1 f22) 121 | | step_thunk: 122 | forall g t1 t2, 123 | step g t1 t2 -> 124 | step g (thunk t1) (thunk t2) 125 | | step_delay: 126 | forall g e1 e2, 127 | step g e1 e2 -> 128 | step g (delay e1) (delay e2) 129 | | step_force: 130 | forall g e1 e2, 131 | step g e1 e2 -> 132 | step g (force e1) (force e2). 133 | 134 | Global Hint Constructors step: cps. 135 | 136 | Lemma declaration_existance_is_decidable: 137 | forall g n, 138 | { e | exists t, item (decl_def e t) g n } + 139 | { ~exists e t, item (decl_def e t) g n }. 140 | Proof. 141 | induction g; intros. 142 | - right; intros (e, (t, ?)). 143 | inversion H. 144 | - destruct n. 145 | + clear IHg. 146 | destruct a. 147 | destruct o. 148 | * rename t0 into e. 149 | left. 150 | exists e, t. 151 | constructor. 152 | * right; intros (e, (u, ?)). 153 | inversion H. 154 | + destruct IHg with n. 155 | * left. 156 | destruct s as (e, ?H). 157 | exists e. 158 | destruct H as (t, ?H). 159 | exists t. 160 | constructor. 161 | assumption. 162 | * right; intros (e, (t, ?)). 163 | dependent destruction H. 164 | firstorder. 165 | Qed. 166 | 167 | Local Hint Extern 4 (~(_ = _)) => discriminate: cps. 168 | 169 | Lemma abstraction_is_decidable: 170 | forall P: term -> Type, 171 | forall f1: (forall t e, P (abstraction t e)), 172 | forall f2: (forall x, (forall t e, x <> abstraction t e) -> P x), 173 | forall x, 174 | P x. 175 | Proof. 176 | induction x; auto with cps. 177 | Qed. 178 | 179 | Lemma pair_is_decidable: 180 | forall P: term -> Type, 181 | forall f1: (forall t e f, P (pair t e f)), 182 | forall f2: (forall x, (forall t e f, x <> pair t e f) -> P x), 183 | forall x, 184 | P x. 185 | Proof. 186 | induction x; auto with cps. 187 | Qed. 188 | 189 | Lemma bool_value_is_decidable: 190 | forall P: term -> Type, 191 | forall f1: P bool_tt, 192 | forall f2: P bool_ff, 193 | forall f3: (forall x, x <> bool_tt -> x <> bool_ff -> P x), 194 | forall x, 195 | P x. 196 | Proof. 197 | induction x; auto with cps. 198 | Qed. 199 | 200 | (* Pick a reduct for a term, arbitrarily defined in a call-by-name order in a 201 | computationally relevant way, or return a proof that there is none. *) 202 | 203 | Lemma step_is_decidable: 204 | forall g e, 205 | { f | step g e f } + { normal (step g) e }. 206 | Proof with eauto with cps. 207 | intros. 208 | generalize dependent g. 209 | induction e; intros. 210 | (* Case: sort. *) 211 | - (* Sorts are atomics, of course. *) 212 | right; easy. 213 | (* Case: bound. *) 214 | - (* A variable can reduce if and only if the environment defines it. *) 215 | destruct declaration_existance_is_decidable with g n as [ (e, ?H) | ?H ]. 216 | + (* It does, so we have a delta reduction. *) 217 | left; eexists. 218 | destruct H as (t, ?H)... 219 | + (* There's no definition, so no reduction either. *) 220 | right; intros x ?. 221 | inversion H0; firstorder. 222 | (* Case: pi. *) 223 | - (* Check subterms, left to right. *) 224 | destruct IHe1 with g as [ (x, ?H) | ?H ]... 225 | destruct IHe2 with (decl_var e1 :: g) as [ (x, ?H) | ?H ]... 226 | (* We're in normal form. *) 227 | right; intros x ?. 228 | inversion H1; firstorder. 229 | (* Case: abstraction. *) 230 | - (* Check subterms, left to right. *) 231 | destruct IHe1 with g as [ (x, ?H) | ?H ]... 232 | destruct IHe2 with (decl_var e1 :: g) as [ (x, ?H) | ?H ]... 233 | (* We're in normal form. *) 234 | right; intros x ?. 235 | inversion H1; firstorder. 236 | (* Case: application. *) 237 | - (* In the standard reduction sequence, we reduce a redex as soon as it 238 | appears. So we'll check if we have a beta-redex right away. *) 239 | destruct e1 using abstraction_is_decidable... 240 | (* There's no beta-redex, check subterms. *) 241 | destruct IHe1 with g as [ (x, ?H) | ?H ]... 242 | destruct IHe2 with g as [ (x, ?H) | ?H ]... 243 | (* We're in normal form. *) 244 | right; intros x ?. 245 | inversion H2. 246 | + subst; now apply H with t e. 247 | + firstorder. 248 | + firstorder. 249 | (* Case: definition. *) 250 | - (* Easy. This is always a zeta-redex! *) 251 | left... 252 | (* Case: sigma. *) 253 | - (* Check subterms, left to right. *) 254 | destruct IHe1 with g as [ (x, ?H) | ?H ]... 255 | destruct IHe2 with (decl_var e1 :: g) as [ (x, ?H) | ?H ]... 256 | (* We're in normal form. *) 257 | right; intros x ?. 258 | inversion H1; firstorder. 259 | (* Case: pair. *) 260 | - (* Check subterms, left to right. *) 261 | destruct IHe1 with g as [ (x, ?H) | ?H ]... 262 | destruct IHe2 with g as [ (x, ?H) | ?H ]... 263 | destruct IHe3 with g as [ (x, ?H) | ?H ]... 264 | (* We're in normal form. *) 265 | right; intros x ?. 266 | inversion H2; firstorder. 267 | (* Case: proj1. *) 268 | - (* Do we have a pi-redex? *) 269 | destruct e using pair_is_decidable... 270 | (* Either our subterm has a redex, or we're in normal form. *) 271 | destruct IHe with g as [ (x, ?H) | ?H ]... 272 | right; intros x ?. 273 | inversion H1. 274 | + subst; now apply H with x f t. 275 | + firstorder. 276 | (* Case: proj2. *) 277 | - (* Exact same thing as the case for proj1 above. *) 278 | destruct e using pair_is_decidable... 279 | destruct IHe with g as [ (x, ?H) | ?H ]... 280 | right; intros x ?. 281 | inversion H1. 282 | + subst; rename e0 into e. 283 | now apply H with e x t. 284 | + firstorder. 285 | (* Case: boolean. *) 286 | - (* This is a const, so it's already in normal form. *) 287 | right; easy. 288 | (* Case: bool_tt. *) 289 | - (* Same as above. *) 290 | right; easy. 291 | (* Case: bool_ff. *) 292 | - (* Same as above too. *) 293 | right; easy. 294 | (* Case: bool_if. *) 295 | - (* We first check for the existence of an iota-redex in here... *) 296 | destruct e1 using bool_value_is_decidable... 297 | (* Check now for subterms... *) 298 | destruct IHe1 with g as [ (x, ?H) | ?H ]... 299 | destruct IHe2 with (decl_var boolean :: g) as [ (x, ?H) | ?H ]... 300 | destruct IHe3 with g as [ (x, ?H) | ?H ]... 301 | destruct IHe4 with g as [ (x, ?H) | ?H ]... 302 | (* The term is in normal form. *) 303 | right; intros x ?. 304 | inversion H5. 305 | + subst; contradiction. 306 | + subst; contradiction. 307 | + firstorder. 308 | + firstorder. 309 | + firstorder. 310 | + firstorder. 311 | (* Case: thunk. *) 312 | - destruct IHe with g as [ (x, ?H) | ?H ]... 313 | right; intros x ?. 314 | inversion H0. 315 | subst; rename e into t1. 316 | now apply H with t2. 317 | (* Case: delay. *) 318 | - destruct IHe with g as [ (x, ?H) | ?H ]... 319 | right; intros x ?. 320 | inversion H0. 321 | subst; rename e into e1. 322 | now apply H with e2. 323 | (* Case: force. *) 324 | - destruct IHe with g as [ (x, ?H) | ?H ]... 325 | right; intros x ?. 326 | inversion H0. 327 | subst; rename e into e1. 328 | now apply H with e2. 329 | Qed. 330 | 331 | (* This relation is mentioned in Coq's documentation and in Bowman's papers. 332 | 333 | The documentation doesn't seem to suggest this is a congruence relation, but, 334 | according to Coq's [kernel/conversion.ml], it should be. In their conversion 335 | procedure they convert arrays of terms to their weak-head normal form and 336 | then compare the leftmost item; if it's a pi, a lambda, a constructor or etc, 337 | equal in both sides, they keep going (e.g., in an application). So, at this 338 | point, if only one side is a lambda, or only one side is a primitive record, 339 | they try to eta expand as described (symmetrically, indeed). I believe that 340 | simply turning this relation into a congruence is enough to characterize this 341 | behavior, having the algorithm as a decision procedure, but then again we'd 342 | have to prove this. As we do not have arbitrary record types, we "specialize" 343 | the rules for the case of surjective pairing of sigma types. Remember that 344 | terms that are checked for convertibility by the typechecking algorithm are 345 | already expected to have the same type. *) 346 | 347 | Inductive conv: env -> relation term := 348 | (* Common reduct. *) 349 | | conv_join: 350 | forall g e1 e2 f, 351 | rt(step g) e1 f -> 352 | rt(step g) e2 f -> 353 | conv g e1 e2 354 | (* Eta-expansion for lambda, abstraction on the left. *) 355 | | conv_eta_left: 356 | forall g e1 e2 t f1 f2, 357 | rt(step g) e1 (abstraction t f1) -> 358 | rt(step g) e2 f2 -> 359 | conv (decl_var t :: g) f1 (application (lift 1 0 f2) (bound 0)) -> 360 | conv g e1 e2 361 | (* Eta-expansion for lambda, abstraction on the right. *) 362 | | conv_eta_right: 363 | forall g e1 e2 t f1 f2, 364 | rt(step g) e1 f1 -> 365 | rt(step g) e2 (abstraction t f2) -> 366 | conv (decl_var t :: g) (application (lift 1 0 f1) (bound 0)) f2 -> 367 | conv g e1 e2 368 | (* Surjective pairing, pair on the left. *) 369 | | conv_sur_left: 370 | forall g e1 p q t e2 f, 371 | rt(step g) e1 (pair p q t) -> 372 | rt(step g) e2 f -> 373 | conv g p (proj1 f) -> 374 | conv g q (proj2 f) -> 375 | conv g e1 e2 376 | (* Surjective pairing, pair on the right. *) 377 | | conv_sur_right: 378 | forall g e1 p q t e2 f, 379 | rt(step g) e1 f -> 380 | rt(step g) e2 (pair p q t) -> 381 | conv g (proj1 f) p -> 382 | conv g (proj2 f) q -> 383 | conv g e1 e2 384 | (* TODO: eta for thunks. *) 385 | (* TODO: add congruence rules. *). 386 | 387 | Global Hint Constructors conv: cps. 388 | 389 | Lemma conv_refl: 390 | forall g, 391 | reflexive (conv g). 392 | Proof. 393 | repeat intro. 394 | apply conv_join with x. 395 | - apply rt_refl. 396 | - apply rt_refl. 397 | Qed. 398 | 399 | Global Hint Resolve conv_refl: cps. 400 | 401 | Lemma conv_sym: 402 | forall g, 403 | symmetric (conv g). 404 | Proof. 405 | induction 1. 406 | - now apply conv_join with f. 407 | - eapply conv_eta_right; eauto with cps. 408 | - eapply conv_eta_left; eauto with cps. 409 | - eapply conv_sur_right; eauto with cps. 410 | - eapply conv_sur_left; eauto with cps. 411 | Qed. 412 | 413 | Global Hint Resolve conv_sym: cps. 414 | 415 | Lemma conv_trans: 416 | forall g, 417 | transitive (conv g). 418 | Proof. 419 | (* TODO: Bowman's paper says this is transitive, and, intuitively, I agree. 420 | I'm not really sure yet how to prove this, tho. I'll come back here later. 421 | *) 422 | Admitted. 423 | 424 | Global Hint Resolve conv_trans: cps. 425 | 426 | Lemma conv_context: 427 | forall (h: context) g e f, 428 | conv g e f -> 429 | conv g (h e) (h f). 430 | Proof. 431 | admit. 432 | Admitted. 433 | 434 | Lemma surjective_pairing: 435 | forall g e t, 436 | conv g (pair (proj1 e) (proj2 e) t) e. 437 | Proof. 438 | intros. 439 | eapply conv_sur_left. 440 | - apply rt_refl. 441 | - apply rt_refl. 442 | - apply conv_refl. 443 | - apply conv_refl. 444 | Qed. 445 | -------------------------------------------------------------------------------- /theories/Intuitionistic.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019--2025 - Paulo Torrens *) 3 | (******************************************************************************) 4 | 5 | Require Import Lia. 6 | Require Import List. 7 | Require Import Arith. 8 | Require Import Equality. 9 | Require Import Local.Prelude. 10 | Require Import Local.Substitution. 11 | Require Import Local.AbstractRewriting. 12 | Require Import Local.Syntax. 13 | Require Import Local.Context. 14 | Require Import Local.Reduction. 15 | 16 | Import ListNotations. 17 | 18 | Variant polarity: Set := 19 | | cartesian 20 | | linear 21 | | consumed. 22 | 23 | Definition consume: list polarity -> list polarity := 24 | map (fun x => 25 | match x with 26 | | cartesian => cartesian 27 | | linear => consumed 28 | | consumed => consumed 29 | end). 30 | 31 | Inductive lift_var (P: nat -> Prop): pseudoterm -> Prop := 32 | | lift_var_bound: 33 | forall n, 34 | P n -> 35 | lift_var P (bound n). 36 | 37 | (* Generalized from Kennedy's paper; this judgement implies that a CPS-calculus 38 | term behaves without control effects (read: no call/cc). TODO: generalize 39 | functions for multiple returns and branching (i.e., allow for products and 40 | coproducts), also for continuations appearing at any position (for, e.g., 41 | Fischer's translation). *) 42 | 43 | Inductive intuitionistic: list polarity -> pseudoterm -> Prop := 44 | (* 45 | k in D, xs in G 46 | ----------------- 47 | G; D |- k 48 | *) 49 | | intuitionistic_ret: 50 | forall g k xs, 51 | item linear g k -> 52 | Forall (lift_var (item cartesian g)) xs -> 53 | intuitionistic g (jump k xs) 54 | (* 55 | k in D, x, ys in G 56 | -------------------- 57 | G; D |- x 58 | *) 59 | | intuitionistic_app: 60 | forall g x k ys, 61 | item linear g k -> 62 | item cartesian g x -> 63 | Forall (lift_var (item cartesian g)) ys -> 64 | intuitionistic g (jump x (bound k :: ys)) 65 | (* 66 | G; D, k |- b G, ys; D |- c 67 | -------------------------------- 68 | G; D |- b { k = c } 69 | *) 70 | | intuitionistic_con: 71 | forall g b ts c, 72 | intuitionistic (linear :: g) b -> 73 | intuitionistic (repeat cartesian (length ts) ++ g) c -> 74 | intuitionistic g (bind b ts c) 75 | (* 76 | G, x; D |- b G, ys; k |- c 77 | -------------------------------- 78 | G; D |- b { x = c } 79 | *) 80 | | intuitionistic_fun: 81 | forall g b ts u tsu c, 82 | tsu = ts ++ [u] -> 83 | intuitionistic (cartesian :: g) b -> 84 | intuitionistic (linear :: repeat cartesian (length ts) ++ consume g) c -> 85 | intuitionistic g (bind b tsu c). 86 | 87 | Lemma intuitionistic_is_dec: 88 | forall b g, 89 | { intuitionistic g b } + { ~intuitionistic g b }. 90 | Proof. 91 | induction b; intros. 92 | (* Case: bound. *) 93 | - right. 94 | inversion 1. 95 | (* Case: type. *) 96 | - right. 97 | inversion 1. 98 | (* Case: jump. *) 99 | - (* Skip invalid cases... *) 100 | destruct b; try now (right; inversion 1). 101 | (* Are we jumping to a continuation or to a function...? *) 102 | admit. 103 | (* Case: bind. *) 104 | - (* This could be a local continuation or a closure definition. We note that 105 | those two things are mutually exclusive: if this is a local continuation 106 | then all the arguments must be cartesian and thus none of them may be 107 | used as a continuation; on the other hand, if this is a closure (like a 108 | thunk or a local function), then the only continuations will appear in 109 | the arguments and thus one of them must be used as a continuation. *) 110 | admit. 111 | Admitted. 112 | 113 | Theorem intuitionistic_requires_escape: 114 | forall g, 115 | ~In linear g -> 116 | forall b, 117 | ~intuitionistic g b. 118 | Proof. 119 | repeat intro. 120 | apply H; clear H. 121 | induction H0. 122 | (* Case: intuitionistic_ret. *) 123 | - clear H0 xs. 124 | induction H. 125 | + now left. 126 | + now right. 127 | (* Case: intuitionistic_app. *) 128 | - clear H0 H1 x ys. 129 | induction H. 130 | + now left. 131 | + now right. 132 | (* Case: intuitionistic_con. *) 133 | - (* Proceed by induction on the right. *) 134 | apply in_app_or in IHintuitionistic2 as [ ? | ? ]. 135 | + exfalso. 136 | apply repeat_spec in H. 137 | inversion H. 138 | + assumption. 139 | (* Case: intuitionistic_fun. *) 140 | - (* Proceed by induction on the left. *) 141 | destruct IHintuitionistic1 as [ ? | ? ]. 142 | + exfalso. 143 | inversion H0. 144 | + assumption. 145 | Qed. 146 | 147 | Lemma item_consume_cartesian_stable: 148 | forall g k, 149 | item cartesian g k -> 150 | item cartesian (consume g) k. 151 | Proof. 152 | induction g; intros. 153 | - inversion H. 154 | - dependent destruction H; simpl. 155 | + constructor. 156 | + constructor. 157 | now apply IHg. 158 | Qed. 159 | 160 | Lemma anchor_is_intuitionistic: 161 | forall g, 162 | item linear g 0 -> 163 | intuitionistic (cartesian :: cartesian :: g) (jump 1 [bound 2; bound 0]). 164 | Proof. 165 | intros. 166 | eapply intuitionistic_app with (ys := [_]); simpl. 167 | - now repeat constructor. 168 | - repeat constructor. 169 | - repeat constructor. 170 | Qed. 171 | 172 | (* TODO: move me, please! *) 173 | Lemma bsmap_app: 174 | forall s xs ys k, 175 | bsmap s k (xs ++ ys) = bsmap s (length ys + k) xs ++ bsmap s k ys. 176 | Proof. 177 | induction xs; simpl; intros. 178 | - reflexivity. 179 | - sigma; simpl. 180 | f_equal. 181 | + rewrite app_length. 182 | now rewrite Nat.add_assoc. 183 | + apply IHxs. 184 | Qed. 185 | 186 | Lemma consume_app: 187 | forall xs ys, 188 | consume (xs ++ ys) = consume xs ++ consume ys. 189 | Proof. 190 | induction xs; simpl; intros. 191 | - reflexivity. 192 | - f_equal. 193 | apply IHxs. 194 | Qed. 195 | 196 | Lemma insert_consume_eat: 197 | forall ps n xs ys, 198 | insert ps n xs ys -> 199 | insert (consume ps) n (consume xs) (consume ys). 200 | Proof. 201 | induction 1; intros. 202 | - rewrite consume_app. 203 | constructor. 204 | - simpl. 205 | now constructor. 206 | Qed. 207 | 208 | Lemma intuitionistic_step_gc: 209 | forall h b, 210 | intuitionistic h b -> 211 | forall k, 212 | not_free k b -> 213 | forall p g, 214 | insert [p] k g h -> 215 | intuitionistic g (remove_binding k b). 216 | Proof. 217 | (* Generalize our substitution a bit. *) 218 | unfold remove_binding; sigma. 219 | induction 1; intros. 220 | (* Case: intuitionistic_ret. *) 221 | - rename g0 into h, k0 into j. 222 | sigma. 223 | admit. 224 | (* Case: intuitionistic_app. *) 225 | - rename g0 into h, k0 into j. 226 | sigma. 227 | admit. 228 | (* Case: intuitionistic_con. *) 229 | - sigma. 230 | dependent destruction H1. 231 | apply intuitionistic_con. 232 | + apply IHintuitionistic1 with p. 233 | * assumption. 234 | * now constructor. 235 | + apply IHintuitionistic2 with p. 236 | * assumption. 237 | * rewrite bsmap_length. 238 | replace (length ts) with (length (repeat cartesian (length ts))) at 1 by 239 | apply repeat_length. 240 | now apply insert_app. 241 | (* Case: intuitionistic_fun. *) 242 | - sigma; subst. 243 | dependent destruction H2. 244 | eapply intuitionistic_fun. 245 | + rewrite bsmap_app; simpl. 246 | now sigma. 247 | + apply IHintuitionistic1 with p. 248 | * assumption. 249 | * now constructor. 250 | + sigma. 251 | eapply IHintuitionistic2. 252 | * assumption. 253 | * rewrite app_length; simpl. 254 | rewrite <- Nat.add_assoc. 255 | rewrite Nat.add_comm. 256 | simpl; constructor. 257 | replace (length ts) with (length (repeat cartesian (length ts))) at 1 by 258 | apply repeat_length. 259 | rewrite Nat.add_comm. 260 | apply insert_app. 261 | now apply insert_consume_eat with (ps := [p]). 262 | Admitted. 263 | 264 | Lemma intuitionistic_step: 265 | forall b c, 266 | step b c -> 267 | forall g, 268 | intuitionistic g b -> 269 | intuitionistic g c. 270 | Proof. 271 | induction 1; intros. 272 | (* Case: step_ctxjmp. *) 273 | - dependent destruction H0. 274 | + apply intuitionistic_con. 275 | * admit. 276 | * assumption. 277 | + rename ts0 into ts. 278 | apply intuitionistic_fun with ts u. 279 | * reflexivity. 280 | * admit. 281 | * assumption. 282 | (* Case: step_gc. *) 283 | - dependent destruction H0. 284 | + apply intuitionistic_step_gc with (linear :: g) linear. 285 | * assumption. 286 | * assumption. 287 | * constructor. 288 | + apply intuitionistic_step_gc with (cartesian :: g) cartesian. 289 | * assumption. 290 | * assumption. 291 | * constructor. 292 | (* Case: step_bind_left. *) 293 | - dependent destruction H0. 294 | + apply intuitionistic_con. 295 | * now apply IHstep. 296 | * assumption. 297 | + rename ts0 into ts. 298 | apply intuitionistic_fun with ts u. 299 | * reflexivity. 300 | * now apply IHstep. 301 | * assumption. 302 | (* Case: step_bind_right. *) 303 | - dependent destruction H0. 304 | + apply intuitionistic_con. 305 | * assumption. 306 | * now apply IHstep. 307 | + rename ts0 into ts. 308 | apply intuitionistic_fun with ts u. 309 | * reflexivity. 310 | * assumption. 311 | * now apply IHstep. 312 | Admitted. 313 | 314 | Require Import Local.Lambda.PlotkinCBV. 315 | 316 | Local Lemma technical1: 317 | forall g t e, 318 | (forall k, free k (abstraction t e) -> item cartesian (linear :: g) (S k)) -> 319 | forall k, 320 | free k (lift 1 1 e) -> 321 | item cartesian (cartesian :: consumed :: consume g) k. 322 | Proof. 323 | intros. 324 | (* Notice that if k is zero then this is trivial. *) 325 | destruct k. 326 | - constructor. 327 | - (* Now, k can't be zero as this contradicts H0. *) 328 | destruct k. 329 | + exfalso. 330 | apply H0. 331 | apply lifting_more_than_n_makes_not_free_n; auto. 332 | + (* For the general case, we can proceed by our hypothesis. *) 333 | do 2 constructor. 334 | apply item_consume_cartesian_stable. 335 | (* Proceed by steps, of course. *) 336 | assert (free k (abstraction t e)). 337 | * intro; apply H0; clear H0. 338 | dependent destruction H1. 339 | replace (S (S n)) with (n + 1 + 1) by lia. 340 | apply not_free_lift. 341 | now rewrite Nat.add_comm. 342 | * apply H in H1. 343 | now dependent destruction H1. 344 | Qed. 345 | 346 | Local Lemma technical2: 347 | forall g f x, 348 | (forall k, free k (application f x) -> item cartesian (linear :: g) (S k)) -> 349 | forall k, 350 | free k (lift 1 0 f) -> 351 | item cartesian (linear :: g) k. 352 | Proof. 353 | intros. 354 | (* Clearly, k can't ever be zero. *) 355 | destruct k. 356 | - exfalso. 357 | apply H0. 358 | apply lifting_more_than_n_makes_not_free_n; auto. 359 | - (* Proceed as the general case above. *) 360 | constructor. 361 | assert (free k (application f x)). 362 | + intro; apply H0; clear H0. 363 | dependent destruction H1. 364 | replace (S n) with (n + 1 + 0) by lia. 365 | apply not_free_lift. 366 | now rewrite Nat.add_comm. 367 | + apply H in H1. 368 | now dependent destruction H1. 369 | Qed. 370 | 371 | Local Lemma technical3: 372 | forall g f x, 373 | (forall k, free k (application f x) -> item cartesian (linear :: g) (S k)) -> 374 | forall k, 375 | free k (lift 2 0 x) -> 376 | forall p, 377 | item cartesian (cartesian :: p :: g) k. 378 | Proof. 379 | intros. 380 | (* Similar to the above, k can't possibly be zero. *) 381 | destruct k. 382 | - exfalso. 383 | apply H0. 384 | apply lifting_more_than_n_makes_not_free_n; auto with arith. 385 | - (* Yet again, k can't be zero. *) 386 | destruct k. 387 | + exfalso. 388 | apply H0. 389 | apply lifting_more_than_n_makes_not_free_n; auto. 390 | + (* Now, proceed once more by the general case as above. *) 391 | do 2 constructor. 392 | assert (free k (application f x)). 393 | * intro; apply H0; clear H0. 394 | dependent destruction H1. 395 | replace (S (S n)) with (n + 2 + 0) by lia. 396 | apply not_free_lift. 397 | now rewrite Nat.add_comm. 398 | * apply H in H1. 399 | now dependent destruction H1. 400 | Qed. 401 | 402 | Lemma plotkin_cbv_is_intuitionistic: 403 | forall e b, 404 | cbv_cps e b -> 405 | forall g, 406 | item linear g 0 -> 407 | (forall k, free k e -> item cartesian g (S k)) -> 408 | intuitionistic g b. 409 | Proof. 410 | induction 1; intros. 411 | (* Case: bound. *) 412 | - (* For variables, the CBV translation will return the value. *) 413 | apply intuitionistic_ret. 414 | + assumption. 415 | + repeat constructor. 416 | apply H0. 417 | now inversion 1. 418 | (* Case: abstraction. *) 419 | - (* Abstractions have a single variable in the lambda calculus, which will be 420 | followed by the current continuation in Plotkin's translation. So declare 421 | a function and immediately return it. *) 422 | eapply intuitionistic_fun with (ts := [_]). 423 | + reflexivity. 424 | + apply intuitionistic_ret. 425 | * now constructor. 426 | * repeat constructor. 427 | + simpl. 428 | (* Proceed by induction. *) 429 | apply IHcbv_cps; intros. 430 | * constructor. 431 | * dependent destruction H0. 432 | constructor; simpl. 433 | now apply technical1 with t e. 434 | (* Case: application. *) 435 | - (* For CBV, we execute the left-hand side, then execute the right-hand 436 | side, then apply the function properly. Sure. *) 437 | apply intuitionistic_con; simpl. 438 | + apply IHcbv_cps1; auto with cps; intros. 439 | dependent destruction H1. 440 | constructor; simpl. 441 | now apply technical2 with f x. 442 | + apply intuitionistic_con; simpl. 443 | * apply IHcbv_cps2; auto with cps; intros. 444 | dependent destruction H1. 445 | constructor; simpl. 446 | now apply technical3 with f x. 447 | * now apply anchor_is_intuitionistic. 448 | Qed. 449 | 450 | Theorem cbv_program_is_intuitionistic: 451 | forall e, 452 | closed e -> 453 | forall b, 454 | cbv_cps e b -> 455 | intuitionistic [linear] b. 456 | Proof. 457 | intros. 458 | apply plotkin_cbv_is_intuitionistic with e; intros. 459 | - assumption. 460 | - constructor. 461 | - exfalso. 462 | apply H1. 463 | apply H. 464 | Qed. 465 | 466 | Require Import Local.Lambda.PlotkinCBN. 467 | 468 | Lemma plotkin_cbn_is_intuitionistic: 469 | forall e b, 470 | cbn_cps e b -> 471 | forall g, 472 | item linear g 0 -> 473 | (forall k, free k e -> item cartesian g (S k)) -> 474 | intuitionistic g b. 475 | Proof. 476 | induction 1; intros. 477 | (* Case: bound. *) 478 | - (* For variables, the CBN translation will force the value. *) 479 | apply intuitionistic_app. 480 | + assumption. 481 | + apply H0. 482 | now inversion 1. 483 | + constructor. 484 | (* Case: abstraction. *) 485 | - (* Abstraction for the CBN case is exactly the same as in the CBV one. *) 486 | eapply intuitionistic_fun with (ts := [_]). 487 | + reflexivity. 488 | + apply intuitionistic_ret. 489 | * now constructor. 490 | * repeat constructor. 491 | + simpl. 492 | (* Proceed by induction. *) 493 | apply IHcbn_cps; intros. 494 | * constructor. 495 | * dependent destruction H0. 496 | constructor; simpl. 497 | now apply technical1 with t e. 498 | (* Case: application. *) 499 | - (* Things a little bit different in here from CBV; we do one continuation, 500 | then we do a thunk declaration, and we apply the anchor. *) 501 | apply intuitionistic_con; simpl. 502 | + apply IHcbn_cps1; auto with cps; intros. 503 | dependent destruction H1. 504 | constructor; simpl. 505 | now apply technical2 with f x. 506 | + (* Here the anchor is on the left. *) 507 | eapply intuitionistic_fun with (ts := []); simpl. 508 | * reflexivity. 509 | * now apply anchor_is_intuitionistic. 510 | * apply IHcbn_cps2; auto with cps; intros. 511 | dependent destruction H1. 512 | constructor; simpl. 513 | (* The third technicall lemma requires a tiny tweak in here too, since 514 | now the thunk can't proceed with older continuations. *) 515 | apply technical3 with f x; auto. 516 | intros j ?; constructor. 517 | apply item_consume_cartesian_stable. 518 | specialize (H2 _ H1). 519 | now dependent destruction H2. 520 | Qed. 521 | 522 | Theorem cbn_program_is_intuitionistic: 523 | forall e, 524 | closed e -> 525 | forall b, 526 | cbn_cps e b -> 527 | intuitionistic [linear] b. 528 | Proof. 529 | intros. 530 | apply plotkin_cbn_is_intuitionistic with e; intros. 531 | - assumption. 532 | - constructor. 533 | - exfalso. 534 | apply H1. 535 | apply H. 536 | Qed. 537 | --------------------------------------------------------------------------------