├── .gitignore ├── DDC ├── ARTIFACT-README.txt ├── Artifact.txt ├── Auxiliary.ott ├── Qualitative.ott ├── README.md ├── edinburgh.pdf ├── esop2022-paper111.pdf ├── spec.pdf └── src │ ├── CoqSrc.mk │ ├── Makefile │ ├── Qualitative_inf.full │ ├── Qualitative_inf.v │ ├── Qualitative_ott.v │ ├── _CoqProject │ ├── confluence.v │ ├── consist.v │ ├── defeq.v │ ├── erasure.v │ ├── geq.v │ ├── grade.v │ ├── grade_sig.v │ ├── labels.v │ ├── listproc.sty │ ├── metalib.v │ ├── narrowing.v │ ├── ottalt.sty │ ├── par.v │ ├── progress.v │ ├── pumping.v │ ├── sort_sig.v │ ├── spec.mng │ ├── spec.tex │ ├── strong_exists.v │ ├── subst.v │ ├── tactics.v │ ├── typing.patch │ ├── typing.v │ ├── typing_ctx_fv.v │ ├── uniq.v │ └── weakening.v ├── GraD ├── ARTIFACT.md ├── README.md ├── graded-haskell.opam ├── spec.pdf ├── src-def │ ├── CoqSrc.mk │ ├── Makefile │ ├── README.md │ ├── _CoqProject │ ├── beta.v │ ├── dctx.v │ ├── dctx_sub.v │ ├── dqtt.ott │ ├── dqtt.v │ ├── dqtt_inf.v │ ├── dqtt_ott.v │ ├── inversion.v │ ├── listproc.sty │ ├── metalib.v │ ├── ottalt.sty │ ├── semimodule.v │ ├── spec.pdf │ ├── spec.tex │ ├── structural.v │ ├── tactics.v │ ├── usage.v │ └── usage_sig.v └── src │ ├── CoqSrc.mk │ ├── Makefile │ ├── _CoqProject │ ├── beta.v │ ├── dctx.v │ ├── dctx_sub.v │ ├── dqtt.ott │ ├── dqtt.v │ ├── dqtt_inf.v │ ├── dqtt_ott.v │ ├── listproc.sty │ ├── metalib.v │ ├── ottalt.sty │ ├── semimodule.v │ ├── spec.tex │ ├── structural.v │ ├── tactics.v │ ├── usage.v │ └── usage_sig.v ├── LICENSE ├── README.md ├── ddc.pdf └── popl21-choudhury.pdf /.gitignore: -------------------------------------------------------------------------------- 1 | .*.aux 2 | .*.d 3 | *.a 4 | *.cma 5 | *.cmi 6 | *.cmo 7 | *.cmx 8 | *.cmxa 9 | *.cmxs 10 | *.glob 11 | *.ml.d 12 | *.ml4.d 13 | *.mli.d 14 | *.mllib.d 15 | *.mlpack.d 16 | *.native 17 | *.o 18 | *.v.d 19 | *.vio 20 | *.vo 21 | *.vok 22 | *.vos 23 | .coq-native/ 24 | .csdp.cache 25 | .lia.cache 26 | .nia.cache 27 | .nlia.cache 28 | .nra.cache 29 | csdp.cache 30 | lia.cache 31 | nia.cache 32 | nlia.cache 33 | nra.cache 34 | *~ 35 | *.aux 36 | *.log 37 | *-rules.tex 38 | *.conf 39 | *.v-e 40 | -------------------------------------------------------------------------------- /DDC/ARTIFACT-README.txt: -------------------------------------------------------------------------------- 1 | Artifact submission for ESOP 2022 paper 111 2 | ========================================== 3 | 4 | This artifact includes Coq proofs for the results claimed about DDC 5 | in [the submitted 6 | paper](https://github.com/sweirich/graded-haskell/blob/main/ddc.pdf) 7 | accepted to ESOP 2022. 8 | 9 | Getting Started Guide 10 | ===================== 11 | 12 | Download instructions 13 | --------------------- 14 | 15 | The artifact is available as a [VirtualBox](https://www.virtualbox.org/) available for download from 16 | 17 | https://drive.google.com/file/d/1r7fiVdKiPF-cHD29mhkF9iWC-Mwj4ZyP/view?usp=sharing 18 | 19 | After starting VirtualBox, the machine can be loaded via 20 | 21 | File > Import Appliance... 22 | 23 | 24 | Evaluation instructions 25 | ----------------------- 26 | 27 | Note: reviwers can use the following credentials for administrator access on 28 | the virtual machine. 29 | 30 | username: osboxes 31 | password: osboxes.org 32 | 33 | To use Coq to verify the claims, reviewers should import the provided virtual box 34 | file. 35 | 36 | Then, to compile the development, perform the following commands in a terminal window. 37 | 38 | cd ~ 39 | cd graded-haskell/DDC/src 40 | make clean 41 | make coq 42 | 43 | NOTE: On 2019 MacBook Pro, the entire development takes < 4 minutes to 44 | compile. 45 | 46 | A successful compilation should produce the following output. 47 | 48 | ``` 49 | { echo "-R . Qual " ; ls *.v ; } > _CoqProject && coq_makefile -arg '-w -variable-collision,-meta-collision,-require-in-module' -f _CoqProject -o CoqSrc.mk 50 | make[1]: Entering directory '/Users/sweirich/github/coq/graded-haskell/DDC/src' 51 | COQC grade_sig.v 52 | COQC sort_sig.v 53 | COQC Qualitative_ott.v 54 | COQC Qualitative_inf.v 55 | COQC metalib.v 56 | COQC tactics.v 57 | COQC labels.v 58 | COQC weakening.v 59 | COQC uniq.v 60 | COQC subst.v 61 | COQC grade.v 62 | COQC geq.v 63 | COQC defeq.v 64 | COQC par.v 65 | COQC confluence.v 66 | COQC consist.v 67 | COQC narrowing.v 68 | COQC pumping.v 69 | COQC typing_ctx_fv.v 70 | COQC typing.v 71 | COQC erasure.v 72 | COQC progress.v 73 | COQC strong_exists.v 74 | make[1]: Leaving directory '/Users/sweirich/github/coq/graded-haskell/DDC/src' 75 | ``` 76 | 77 | The source code for the artifact is available from the public github repository: 78 | https://github.com/sweirich/graded-haskell/tree/main/DDC 79 | 80 | 81 | Step-by-Step Instructions 82 | ========================= 83 | 84 | Complete claims made by the paper substantiated by this artifact 85 | ---------------------------------------------------------------- 86 | 87 | This artifact substantiates the results claimed in the paper as indicated by 88 | the footnotes. All results are proved about the DDC calculus, presented in 89 | Section 5. The language DDC^Top (Section 4) is an instance of DDC, 90 | so these results hold directly for that language as well. 91 | 92 | * System specification 93 | 94 | The full specification of the type system shown in Section 5 is in the file 95 | `Qualitative_ott.v`. This file has been mechanically generated from the Ott 96 | specification `Qualitative.ott` and then patched. For convenience, we 97 | also provide the file `spec.pdf` that contains a typeset version of the 98 | system, also generated from `Qualitative.ott`. 99 | 100 | Note: the DDC in the artifact includes *both* weak and strong sigma-types 101 | as primitive type forms. The file `strong_exists.v` shows that the rules 102 | for projection from strong sigmas are derivable from weak sigmas. Therefore, 103 | the paper only includes the specification of weak sigmas. 104 | 105 | * Key results 106 | 107 | The individual results can be found in the corresponding Coq files and theorem 108 | statements as directed by the paper's footnotes. (All Coq files are in the 109 | `src` subdirectory.) 110 | 111 | ** Section 3 112 | 113 | NOTE: the paper presents these lemmas about SDC, but our Coq proofs show that 114 | they also hold for DDC. Reveiwers found this confusing, so in our revision of the 115 | paper we will clarify. 116 | 117 | Lemma 5 (Typing implies grading) 118 | Lemma 6 (Equivalence) 119 | Lemma 7 (Indistinguishability under substitution) 120 | Theorem 1 (Non-interference) 121 | 122 | ** Section 5 123 | 124 | Theorem 8 (Consistency) 125 | Lemma 8 (Canonical Element) 126 | Lemma 9 (Erasure Indistinguishability) 127 | Lemma 10 (Erasure simulation) 128 | Lemma 11 (Narrowing) 129 | Lemma 12 (Weakening) 130 | Lemma 13 (Restricted Upgrading) 131 | Lemma 14 (Bounded by C) 132 | Lemma 15 (Subsumption) 133 | Lemma 16 (Substitution) 134 | Lemma 17 (Regularity) 135 | Lemma 18 (Preservation) 136 | Lemma 19 (Progress) 137 | 138 | ** New material 139 | 140 | The reviewers have requested more details about the decidability of type 141 | checking for certain instances of DDC. In support of the new claims, we will 142 | add the following theorem to the paper showing the equivalence of definitional 143 | equality and the joins relation. (The other direction of this lemma is 144 | already used to show consistency.) 145 | 146 | Lemma Joins_DefEq : 147 | forall S D A B, Joins S D A B -> DefEq S D A B. 148 | 149 | This lemma appears at the end of the file src/consist.v. 150 | 151 | 152 | * Parameters and Axioms made in Coq development 153 | 154 | The DDC system is parameterized in two ways: first by a lattics of dependency 155 | levels and then by the Sorts/Axioms/Rules as in a Pure Type system. These inputs 156 | are marked as parameters. 157 | 158 | - Abstract properties of the lattice (grade_sig.v) 159 | - Sorts, Axioms and Rules of the Pure Type System (sort_sig.v) as described at 160 | the beginning of Section 5. 161 | 162 | The proofs stated in the paper rely on minor axioms: 163 | 164 | - Two properties about variable renaming (strong_exists.v) 165 | - Lemmas about substitution generated by LNgen tool (Qualitative_inf.v) 166 | 167 | For the latter file, a version of the file that includes the full proofs of these 168 | lemmas is also available (Qualitative_inf.full). This file takes a few minutes 169 | to compile. If the reviewers would like to verify these assumptions, they can 170 | update the contents of the file Qualitative_inf.v with that of Qualitative_inf.full. 171 | 172 | Complete claims made by the paper NOT substantiated by this artifact 173 | ---------------------------------------------------------------- 174 | 175 | This artifact only includes results about the DDC language. Therefore, results 176 | about SDC or about a translation between languages have not been proved in Coq. 177 | These include the following results: 178 | 179 | * Section 3 180 | 181 | Lemmas 1-7, Theorem 1. Properties of SDC that are similar to analogous results for DDC. 182 | Theorems 2-4. Translation between DCC and SDC. 183 | 184 | * Section 4 185 | 186 | Theorems 5-7. Translation between SDC and DDC^Top. 187 | 188 | Additional artifact description 189 | ------------------------------- 190 | 191 | See the [README.md](https://github.com/sweirich/graded-haskell/tree/main/DDC/README.md) for the artifact site. 192 | 193 | Constructing the artifact from scratch 194 | -------------------------------------- 195 | 196 | The following commands will install all dependencies for the development from 197 | a fresh version of Ubuntu. 198 | 199 | - sudo apt install git-all 200 | - sudo add-apt-repository ppa:avsm/ppa 201 | - sudo apt update 202 | - sudo apt install make 203 | - sudo apt install gcc 204 | - sudo apt install opam 205 | - opam init 206 | - opam switch create 4.09.1 207 | - eval $(opam env --switch=4.01.1) 208 | - opam repo add coq-released https://coq.inria.fr/opam/released 209 | - opam pin coq 8.10.2 210 | - opam install ott 211 | - opam pin add coq-metalib https://github.com/plclub/metalib.git 212 | - git clone https://github.com/sweirich/graded-haskell.git 213 | - cd graded-haskell/DDC/src 214 | - make coq 215 | -------------------------------------------------------------------------------- /DDC/Artifact.txt: -------------------------------------------------------------------------------- 1 | https://drive.google.com/file/d/1r7fiVdKiPF-cHD29mhkF9iWC-Mwj4ZyP/view?usp=sharing 2 | MD5 (esop-2022-paper111.ova) = 4665df9799c436acb6cb131657838141 3 | -------------------------------------------------------------------------------- /DDC/Auxiliary.ott: -------------------------------------------------------------------------------- 1 | 2 | 3 | defns 4 | JTyping :: '' ::= 5 | 6 | defn 7 | W |-- psi a : A :: :: Typing :: 'T_' {{ com Typing }} 8 | by 9 | 10 | W |-- psi a : Sigma x :psi0 A . B 11 | (# W ++ x :psi0 \/ psi A #) |-- psi c : Pi y : phi B . (# C { (x psi0 , y) / z } #) 12 | W ++ z : top (Sigma x :psi0 A . B) |--> top C : type s 13 | ------------------------------------------------------------- :: LetPairC 14 | W |-- psi let (x psi0 , ) = a in c : C { a / z } 15 | 16 | W |-- psi a : A1 + A2 17 | W |-- psi b1 : Pi x :psi0 A1. (# B {inj1 x / z} #) 18 | W |-- psi b2 : Pi y :psi0 A2. (# B {inj2 y / z} #) 19 | psi0 <= psi 20 | ((CTime /\ W) ++ z :CTime A1 + A2) |-- CTime B : type s 21 | -------------------------------------------------------- :: CaseC 22 | W |-- psi case psi0 a of b1; b2 : B {a/z} 23 | -------------------------------------------------------------------------------- /DDC/README.md: -------------------------------------------------------------------------------- 1 | The [src](src/) directory includes a Coq specification of a dependently typed 2 | calculus with dependent functions, unit, products and sums. 3 | 4 | This development is also available via a virtual machine, available for download from [zenodo](https://zenodo.org/record/5903727#.YfqZGvXMLUI). 5 | 6 | System Specification 7 | -------------------- 8 | 9 | The full specification of the DDC type system is in the file 10 | [Qualitative_ott.v](src/Qualitative_ott.v). This file has been mechanically 11 | generated from the Ott specification in [Qualitative.ott](Qualitative.ott), 12 | but then slightly edited. For convenience, we also provide the file 13 | [spec.pdf](spec.pdf) that contains a typeset version of the system, also 14 | generated from the same specification file. 15 | 16 | Compilation Instructions 17 | ----------------------- 18 | 19 | This development has been tested with The Coq Proof Assistant, version 8.10.2 20 | 21 | To compile this code with Coq, you also need to install a copy of the Metalib 22 | library. This library is available from https://github.com/plclub/metalib at 23 | the coq8.10 tag. 24 | 25 | You can install these tools via opam (https://opam.ocaml.org/): 26 | 27 | opam switch create 4.09.1 28 | opam repo add coq-released https://coq.inria.fr/opam/released 29 | opam pin coq 8.10.2 30 | opam install ott 31 | opam pin add coq-metalib https://github.com/plclub/metalib.git 32 | 33 | Once Coq and metalib have been installed, the files can be compiled using 34 | 35 | cd src; make coq 36 | 37 | 38 | Contents 39 | -------- 40 | 41 | * System specification and utilities 42 | 43 | grade_sig.v - Abstract lattice of grades 44 | sort_sig.v - Abstract sorts, axioms, rules for PTS 45 | 46 | Qualitative_ott.v - Generated from Ott, using typing.patch 47 | Qualitative_inf.v - Generated from LNgen (axiomatized) 48 | Qualitative_inf_full.v - Generated from LNgen (full proofs) 49 | metalib.v - Potential additions to LNgen 50 | tactics.v - general proof machinery 51 | labels.v - Properties of context functions 52 | 53 | * Structural lemmas 54 | 55 | uniq.v - Judgements use uniq contexts 56 | narrowing.v - Narrowing lemmas 57 | weakening.v - Weakening lemmas 58 | pumping.v - Can raise context vars up to level of judgment 59 | subst.v - Substitution lemmas for Grade/GEq/DefEq/Par 60 | 61 | * Judgement specific lemmas 62 | 63 | grade.v - Step relation preserves Grade 64 | geq.v - Properties of CEq / GEq 65 | equivalence relation 66 | respects step (Main non-interference theorem) 67 | implies Grade 68 | defeq.v - Properties of DefEq 69 | implies grade 70 | contains GEq 71 | additional substitution lemmas 72 | 73 | * Preservation 74 | 75 | typing_ctx_fv.v - Free variables are in domain of typing judgement 76 | typing.v - Main Preservation lemma 77 | 78 | * Progress 79 | 80 | par.v - Properaties of Par relation 81 | confluence.v - Parallel reduction is confluent 82 | consist.v - Definitional Equality is consistent 83 | progress.v - Main Progress lemma 84 | 85 | * Other 86 | 87 | strong_exists.v - Derive projections of strong Sigmas from pattern matching 88 | [Caveat: two Axioms about variable renaming.] 89 | erasure.v - Justify using runtime irrelevance to erase terms 90 | 91 | 92 | 93 | 94 | -------------------------------------------------------------------------------- /DDC/edinburgh.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/graded-haskell/986ac74f0cb5d38c11307beb5b05e9eb2e0bd0ed/DDC/edinburgh.pdf -------------------------------------------------------------------------------- /DDC/esop2022-paper111.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/graded-haskell/986ac74f0cb5d38c11307beb5b05e9eb2e0bd0ed/DDC/esop2022-paper111.pdf -------------------------------------------------------------------------------- /DDC/spec.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/graded-haskell/986ac74f0cb5d38c11307beb5b05e9eb2e0bd0ed/DDC/spec.pdf -------------------------------------------------------------------------------- /DDC/src/Makefile: -------------------------------------------------------------------------------- 1 | OTT_SOURCE = Qualitative Auxiliary 2 | OTT_LOC = .. 3 | FILES = Qualitative_ott Qualitative_inf 4 | OTTFILES = $(foreach i, $(OTT_SOURCE), $(OTT_LOC)/$(i).ott) 5 | OTTIFLAGS = $(foreach i, $(OTT_SOURCE), -i $(OTT_LOC)/$(i).ott) -merge true 6 | OTTOFLAGS = -o Qualitative_ott.v 7 | 8 | 9 | all: coq 10 | 11 | ################ latex #################### 12 | 13 | SPEC = spec.mng 14 | SPECFILE = spec.tex 15 | RULESFILE = qualitative-rules.tex 16 | 17 | spec.pdf: $(SPEC) $(SPECFILE) 18 | ott $(OTTIFLAGS) \ 19 | -tex_wrap false -tex_show_meta false -tex_filter $(SPEC) $(SPECFILE) 20 | pdflatex -interaction nonstopmode $(SPECFILE) 21 | mv spec.pdf .. 22 | 23 | 24 | $(RULESFILE) : $(OTTFILES) 25 | ott $(OTTIFLAGS) -o $(RULESFILE) \ 26 | -tex_wrap false \ 27 | -tex_show_meta false 28 | 29 | %.tex: $(RULESFILE) %.mng Makefile 30 | ott $(OTTIFLAGS) \ 31 | -tex_wrap false \ 32 | -tex_show_meta false \ 33 | -tex_filter $*.mng $*.tex 34 | 35 | %.pdf : %.tex $(RULESFILE) 36 | latexmk -bibtex -pdf $*.tex 37 | 38 | 39 | 40 | ###################### COQ ############################## 41 | 42 | ## Paths to executables. Do not include options here. 43 | ## Modify these to suit your Coq installation, if necessary. 44 | 45 | COQC = coqc 46 | COQDEP = coqdep 47 | 48 | LIBNAME=Qual 49 | LNGEN=lngen 50 | 51 | ## Include directories, one per line. 52 | 53 | INCDIRS = \ 54 | . \ 55 | $(METALIBLOCATION) \ 56 | 57 | 58 | ## Library name used for the imports in Coq 59 | 60 | 61 | 62 | ## Name of the submakefile generated by coq_makefile 63 | COQMKFILENAME=CoqSrc.mk 64 | 65 | VFILES = $(foreach i, $(FILES), $(i).v) 66 | VOFILES = $(foreach i, $(FILES), $(i).vo) 67 | INCFLAGS = $(foreach i, $(INCDIRS), -I $(i)) 68 | 69 | .SECONDARY: $(VFILES) 70 | 71 | METALIBFILES= $(METALIBLOCATION)/*.v $(METALIBLOCATION)/Makefile $(METALIBLOCATION)/README.txt 72 | 73 | 74 | quick: $(COQMKFILENAME) 75 | @$(MAKE) -f CoqSrc.mk quick 76 | 77 | 78 | coq: $(COQMKFILENAME) $(VFILES) 79 | @$(MAKE) -f CoqSrc.mk 80 | 81 | 82 | %.vo: %.v 83 | @$(MAKE) -f CoqSrc.mk $*.vo 84 | 85 | 86 | %_ott.v: $(OTT_LOC)/%.ott typing.patch 87 | ott -i $(OTT_LOC)/Qualitative.ott $(OTTOFLAGS) -coq_lngen true -coq_expand_list_types true 88 | make PATCH_TYPING_$*_ott 89 | 90 | %_inf.v: $(OTT_LOC)/%.ott Makefile 91 | $(LNGEN) --coq-no-proofs --coq $*_inf.v --coq-ott $*_ott $(OTT_LOC)/$*.ott 92 | # make GRADE.FIX_$*_inf 93 | 94 | %_inf_proofs.v: $(OTT_LOC)/%.ott Makefile 95 | $(LNGEN) --coq $*_inf_proofs.v --coq-ott $*_ott $(OTT_LOC)/$*.ott 96 | 97 | 98 | $(COQMKFILENAME): Makefile $(shell ls *.v | grep -v _ott.v | grep -v _inf.v) 99 | { echo "-R . $(LIBNAME) " ; ls *.v ; } > _CoqProject && coq_makefile -arg '-w -variable-collision,-meta-collision,-require-in-module' -f _CoqProject -o $(COQMKFILENAME) 100 | 101 | 102 | coqclean: 103 | @rm -if *.v.d *.vo *.glob *.v-e *.vok *.vos *.conf *.v-e $(VOFILES) $(COQMKFILENAME) 104 | 105 | clean: coqclean 106 | @rm -f *~ 107 | @rm -f *.log *.aux *.fls *.fdb_latexmk 108 | 109 | # fix typing rules for LetPair and Case that cannot be expressed with Ott's locally nameless 110 | # backend 111 | PATCH_TYPING_%: 112 | patch -R $*.v < typing.patch 113 | 114 | # delete lines from _inf.v file corresponding to "grade". Need to update this 115 | # when .ott file is changed 116 | GRADE.FIX_%: 117 | sed '87,96d' $*.v | sed '18,41d' > __TMP__; mv __TMP__ $*.v 118 | -------------------------------------------------------------------------------- /DDC/src/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Qual 2 | Qualitative_inf.v 3 | Qualitative_ott.v 4 | confluence.v 5 | consist.v 6 | defeq.v 7 | erasure.v 8 | geq.v 9 | grade.v 10 | grade_sig.v 11 | labels.v 12 | metalib.v 13 | narrowing.v 14 | par.v 15 | progress.v 16 | pumping.v 17 | sort_sig.v 18 | strong_exists.v 19 | subst.v 20 | tactics.v 21 | typing.v 22 | typing_ctx_fv.v 23 | uniq.v 24 | weakening.v 25 | -------------------------------------------------------------------------------- /DDC/src/defeq.v: -------------------------------------------------------------------------------- 1 | Require Export Qual.metalib. 2 | Require Export Qual.grade. 3 | Require Export Qual.geq. 4 | 5 | Set Implicit Arguments. 6 | Open Scope grade_scope. 7 | 8 | 9 | Lemma CDefEq_DefEq_Grade : 10 | (forall P psi phi a b, CDefEq P psi phi a b -> CGrade P psi phi a /\ CGrade P psi phi b) /\ 11 | (forall P psi a b, DefEq P psi a b -> Grade P psi a /\ Grade P psi b). 12 | Proof. 13 | apply CDefEq_DefEq_mutual. 14 | all: intros; split; split_hyp; eauto. 15 | all: try solve [eauto using leq_join_r ]. 16 | all: try solve [repeat invert_Grade; subst; eauto]. 17 | all: try solve [fresh_apply_Grade x; auto; 18 | repeat spec x; split_hyp; eauto]. 19 | all: try solve [repeat invert_Grade; subst; 20 | pick fresh x; repeat spec x; 21 | eapply Grade_open; eauto using leq_join_r]. 22 | 23 | all: try solve [pick fresh x; 24 | repeat spec x; 25 | split_hyp; 26 | eapply Grade_open_irrel with (y := x); eauto]. 27 | 28 | Qed. 29 | 30 | Lemma DefEq_Grade : forall P psi a b, DefEq P psi a b -> Grade P psi a /\ Grade P psi b. 31 | Proof. apply CDefEq_DefEq_Grade. Qed. 32 | 33 | Lemma DefEq_Grade1 : forall {W psi a b}, DefEq W psi a b -> Grade W psi a. 34 | eapply DefEq_Grade; auto. Qed. 35 | Lemma DefEq_Grade2 : forall {W psi a b}, DefEq W psi a b -> Grade W psi b. 36 | eapply DefEq_Grade; auto. Qed. 37 | 38 | 39 | Lemma CEqGEq_DefEq : 40 | (forall P phi phi0 a b, CEq P phi phi0 a b -> CDefEq P phi phi0 a b) /\ 41 | (forall P phi a b, GEq P phi a b -> DefEq P phi a b). 42 | Proof. 43 | eapply CEq_GEq_mutual. 44 | all: intros; eauto 3. 45 | Qed. 46 | 47 | 48 | Lemma CDefEq_substitution1 : forall P2 x psi0 P1 psi a a1 a2, 49 | Grade (P2 ++ [(x, psi0)] ++ P1) psi a -> 50 | CDefEq P1 psi psi0 a1 a2 -> 51 | Grade (P2 ++ P1) psi (subst_tm_tm a1 x a). 52 | Proof. 53 | intros. 54 | inversion H0; subst. 55 | eapply Grade_substitution_same; eauto using DefEq_Grade1. 56 | eapply Grade_substitution_irrel; eauto using DefEq_lc1. 57 | Qed. 58 | 59 | Lemma CDefEq_substitution2 : forall P2 x psi0 P1 psi a a1 a2, 60 | Grade (P2 ++ [(x, psi0)] ++ P1) psi a -> 61 | CDefEq P1 psi psi0 a1 a2 -> 62 | Grade (P2 ++ P1) psi (subst_tm_tm a2 x a). 63 | Proof. 64 | intros. 65 | inversion H0; subst. 66 | eapply Grade_substitution_same; eauto using DefEq_Grade2. 67 | eapply Grade_substitution_irrel; eauto using DefEq_lc2. 68 | Qed. 69 | 70 | Parameter star : sort. 71 | 72 | Lemma DefEq_equality_substitution : (forall P phi b1 b2, 73 | DefEq P phi b1 b2 -> forall P1 x psi, 74 | P = [(x,psi)] ++ P1 75 | -> forall a1 a2, DefEq P1 phi a1 a2 76 | -> psi <= phi 77 | -> DefEq P1 phi (subst_tm_tm a1 x b1) (subst_tm_tm a2 x b2)). 78 | Proof. 79 | intros. 80 | subst. 81 | move: (DefEq_uniq H) => h. destruct_uniq. 82 | have RE: DefEq P1 phi (a_Pi psi (a_Type star) (close_tm_wrt_tm x b1)) 83 | (a_Pi psi (a_Type star) (close_tm_wrt_tm x b2)). 84 | + pick fresh y and apply Eq_Pi. eapply Eq_Refl; eauto. 85 | rewrite <- subst_tm_tm_spec. 86 | rewrite <- subst_tm_tm_spec. 87 | eapply DefEq_substitution_same with (P2 := nil) (P1 := [(y,phi)] ++ P1). 88 | 2: { simpl_env; eauto. } 89 | eapply DefEq_weakening_middle; eauto. 90 | eapply G_Var with (psi0:=phi); auto. reflexivity. 91 | + rewrite subst_tm_tm_spec. 92 | rewrite subst_tm_tm_spec. 93 | eapply Eq_PiSnd; eauto. 94 | Qed. 95 | 96 | Lemma DefEq_substitution_irrel2 : (forall P phi b1 b2, 97 | DefEq P phi b1 b2 -> forall P1 x psi, 98 | P = [(x,psi)] ++ P1 99 | -> not (psi <= phi) 100 | -> forall a1 a2, lc_tm a1 -> lc_tm a2 101 | -> DefEq P1 phi (subst_tm_tm a1 x b1) (subst_tm_tm a2 x b2)). 102 | Proof. 103 | intros. subst. 104 | move: (DefEq_uniq H) => u. destruct_uniq. 105 | rewrite subst_tm_tm_spec. 106 | rewrite subst_tm_tm_spec. 107 | pick fresh y and apply Eq_SubstIrrel; eauto 2. 108 | eapply (@DefEq_renaming x). repeat rewrite fv_tm_tm_close_tm_wrt_tm. fsetdec. 109 | repeat rewrite fv_tm_tm_close_tm_wrt_tm. fsetdec. 110 | rewrite open_tm_wrt_tm_close_tm_wrt_tm. 111 | rewrite open_tm_wrt_tm_close_tm_wrt_tm. 112 | auto. 113 | Qed. 114 | -------------------------------------------------------------------------------- /DDC/src/geq.v: -------------------------------------------------------------------------------- 1 | Require Export Qual.grade. 2 | 3 | Set Implicit Arguments. 4 | 5 | (* Notes: 6 | 7 | Consider P |- psi a ~~ b 8 | 9 | We need to have P |- psi a (GEq_Grade) so that we do lifting/equality 10 | substitution. We need to know which variables are relevant (those in P with 11 | grades <= psi) and which ones are not. 12 | 13 | Reflexivity requires P |- psi a 14 | 15 | Lifting: 16 | 17 | P, x:psi |- phi b 18 | P |- phi psi a1 ~ a2 19 | P |- phi b {a1/x} ~~ b {a2/x} 20 | *) 21 | 22 | 23 | (* relationship to grade *) 24 | 25 | 26 | Lemma CEq_GEq_Grade : 27 | (forall P phi phi0 a b, 28 | CEq P phi phi0 a b -> CGrade P phi phi0 a /\ CGrade P phi phi0 b) /\ 29 | (forall P phi a b, 30 | GEq P phi a b -> Grade P phi a /\ Grade P phi b). 31 | Proof. 32 | eapply CEq_GEq_mutual. 33 | all: intros; split_hyp; split; eauto using leq_join_r. 34 | all: try solve [fresh_apply_Grade x; eauto; 35 | repeat spec x; split_hyp; eauto]. 36 | Qed. 37 | 38 | Lemma GEq_Grade1 : 39 | (forall P phi a b, 40 | GEq P phi a b -> Grade P phi a). 41 | Proof. apply CEq_GEq_Grade. Qed. 42 | Lemma GEq_Grade2 : 43 | (forall P phi a b, 44 | GEq P phi a b -> Grade P phi b). 45 | Proof. apply CEq_GEq_Grade. Qed. 46 | 47 | (* ------------------------------ context stuff ----------------------- *) 48 | 49 | 50 | (* Graded/Guarded equality is an equivalence/congruence relation, closed under substitution and implies consistency. *) 51 | 52 | Lemma CEq_GEq_refl : (forall P phi psi a, CGrade P phi psi a -> CEq P phi psi a a) /\ 53 | (forall P phi a, Grade P phi a -> GEq P phi a a). 54 | Proof. 55 | apply CGrade_Grade_mutual. 56 | all: intros; eauto. 57 | Qed. 58 | 59 | Lemma GEq_refl : (forall P phi a, Grade P phi a -> GEq P phi a a). 60 | apply CEq_GEq_refl; auto. 61 | Qed. 62 | 63 | Lemma CEq_refl : forall P phi a psi, CGrade P phi psi a -> CEq P phi psi a a. 64 | Proof. 65 | destruct CEq_GEq_refl; auto. 66 | Qed. 67 | 68 | Lemma CEq_GEq_sym : 69 | (forall P phi phi0 a b, 70 | CEq P phi phi0 a b -> CEq P phi phi0 b a) /\ 71 | (forall P phi a b, 72 | GEq P phi a b -> GEq P phi b a). 73 | Proof. 74 | eapply CEq_GEq_mutual. 75 | all: intros; eauto. 76 | Qed. 77 | 78 | Lemma GEq_symmetry : (forall P phi a b, 79 | GEq P phi a b -> GEq P phi b a). 80 | Proof. apply CEq_GEq_sym. Qed. 81 | 82 | Lemma CEq_GEq_trans : 83 | (forall P phi phi0 a b, 84 | CEq P phi phi0 a b -> forall c, CEq P phi phi0 b c -> CEq P phi phi0 a c) /\ 85 | (forall P phi a b, 86 | GEq P phi a b -> forall c, GEq P phi b c -> GEq P phi a c). 87 | Proof. 88 | eapply CEq_GEq_mutual. 89 | all: intros; subst; eauto. 90 | all: try match goal with 91 | | [ H: GEq ?P ?ps (_ _ ) ?c |- _ ] => inversion H; subst; clear H end. 92 | all: eauto. 93 | 94 | all: try (fresh_apply_GEq x; eauto; repeat spec x). 95 | - (* leq *) 96 | inversion H0. subst. eauto. done. 97 | - (* nleq *) 98 | inversion H; subst. done. 99 | eapply CEq_Nleq; eauto. 100 | Qed. 101 | 102 | 103 | Lemma GEq_trans : forall P phi a b c, GEq P phi a b -> GEq P phi b c -> GEq P phi a c. 104 | Proof. 105 | intros. 106 | destruct CEq_GEq_trans. 107 | eapply H2; eauto. 108 | Qed. 109 | 110 | (* ------------------------------------------------------- *) 111 | 112 | (* 113 | b1 -> b2 114 | phi = phi .= 115 | b1' .-> b2' 116 | 117 | *) 118 | 119 | Lemma CEq_GEq_respects_Step : 120 | (forall P phi phi0 b1 b1', 121 | CEq P phi phi0 b1 b1' -> forall b2, Step b1 b2 -> 122 | exists b2', (phi0 <= phi -> Step b1' b2') /\ CEq P phi phi0 b2 b2') /\ 123 | (forall P phi b1 b1', 124 | GEq P phi b1 b1' -> forall b2, Step b1 b2 -> 125 | exists b2', Step b1' b2' /\ GEq P phi b2 b2'). 126 | Proof. 127 | eapply CEq_GEq_mutual. 128 | all: intros; subst; eauto. 129 | all: match goal with [ H : Step _ _ |- _ ] => inversion H; subst end. 130 | all: try 131 | let b2' := fresh in 132 | let ss' := fresh in 133 | let GE' := fresh in 134 | match goal with [ H : forall b3, Step ?b1 b3 -> _ , H2 : Step ?b1 ?a' |- _ ] => 135 | destruct (H _ H2) as [b2' [ss' GE']] ; clear H end. 136 | all: split_hyp. 137 | all: try solve [ 138 | eexists; split; 139 | econstructor; 140 | eauto 3 using CEq_refl, GEq_lc2, CEq_lc2, CEq_uniq]. 141 | (* all: try solve [ 142 | inversion g; subst; 143 | eexists; split; eauto using GEq_lc2, CEq_lc2]. *) 144 | all: try solve [ 145 | eexists; split; try (intro h; eauto; done); 146 | eapply CEq_Leq; eauto]. 147 | all: try solve [ 148 | eexists; split; try (intro h; done); 149 | eapply CEq_Nleq; eauto 3 using Step_lc2] . 150 | 151 | - (* beta *) 152 | inversion g. subst. 153 | pick fresh x. spec x. 154 | exists (open_tm_wrt_tm b0 a2). split. 155 | econstructor; eauto using GEq_lc2; eauto using CEq_lc2. 156 | eapply GEq_open; eauto. 157 | - (* LetPair beta *) 158 | inversion g. subst. 159 | pick fresh x. spec x. 160 | exists (a_App (open_tm_wrt_tm b2 a4) q_Bot b3). split. 161 | econstructor; eauto using GEq_lc2; eauto using CEq_lc2. 162 | econstructor; eauto. 163 | eapply GEq_open; eauto. 164 | eapply CEq_Leq; eauto using leq_Bot. 165 | - (* Proj1 beta *) 166 | inversion g. subst. 167 | exists a0. split. 168 | econstructor; eauto using GEq_lc2, CEq_lc2. 169 | inversion H9; subst; auto. done. 170 | - (* Proj2 beta *) 171 | inversion g; subst. 172 | eexists b0. split; auto; 173 | econstructor; eauto using GEq_lc2, CEq_lc2. 174 | - (* Case beta *) 175 | inversion g; subst. 176 | eexists (a_App b1' psi0 a1'). split; auto. 177 | eapply S_Case1Beta; eauto using GEq_lc2, CEq_lc2. 178 | - inversion g; subst. 179 | eexists (a_App b2' psi0 a2'). split; auto. 180 | eapply S_Case2Beta; eauto using GEq_lc2, CEq_lc2. 181 | Qed. 182 | 183 | -------------------------------------------------------------------------------- /DDC/src/grade.v: -------------------------------------------------------------------------------- 1 | (* -*- company-coq-initial-fold-state: bullets; -*- *) 2 | 3 | Require Export Qual.metalib. 4 | Require Export Qual.tactics. 5 | Require Export Qual.labels. 6 | Require Export Qual.weakening. 7 | Require Export Qual.subst. 8 | 9 | Set Implicit Arguments. 10 | Open Scope grade_scope. 11 | 12 | Ltac invert_CGrade a := 13 | match goal with 14 | [ H : CGrade ?P ?phi ?psi a |- _] => inversion H ; subst 15 | end. 16 | 17 | Lemma Step_Grade : forall a b, Step a b -> forall P phi, Grade P phi a -> Grade P phi b. 18 | Proof. 19 | intros a b S. induction S; intros. 20 | all: try match goal with 21 | [ H : Grade ?P ?phi ?b |- _ ] => inversion H ; clear H; subst end. 22 | all: intros; eauto. 23 | 24 | all: try solve [invert_Grade; subst; 25 | eauto using leq_join_r]. 26 | - (* Beta / AppRel *) 27 | invert_Grade; subst. 28 | pick fresh x; spec x. 29 | invert_CGrade b; auto. 30 | eapply Grade_open; eauto. 31 | eapply Grade_open_irrel; eauto. 32 | - (* SPair *) 33 | invert_Grade; invert_CGrade a1; subst; eauto; try done. 34 | - (* LetPair *) 35 | invert_Grade; subst; 36 | pick fresh x; spec x. 37 | eapply G_App; eauto using leq_Bot. 38 | invert_CGrade a1. 39 | eapply Grade_open; eauto. 40 | eapply Grade_open_irrel; eauto. 41 | Qed. 42 | 43 | -------------------------------------------------------------------------------- /DDC/src/grade_sig.v: -------------------------------------------------------------------------------- 1 | (* Parameterization of the grade lattice *) 2 | 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | Require Import ssreflect. 9 | 10 | Module Type GradeSig. 11 | 12 | Parameter grade : Set. 13 | 14 | Parameter q_Top : grade. 15 | Parameter q_Bot : grade. 16 | Parameter q_C : grade. 17 | 18 | Parameter q_R : grade. 19 | 20 | Parameter q_eqb : grade -> grade -> bool. 21 | Parameter q_leb : grade -> grade -> bool. 22 | Parameter q_join : grade -> grade -> grade. 23 | Parameter q_meet : grade -> grade -> grade. 24 | 25 | Parameter q_eq : grade -> grade. 26 | 27 | (* Equality *) 28 | Definition t := grade. 29 | Definition eq := @Logic.eq grade. 30 | Definition eqb := q_eqb. 31 | Parameter q_eq_dec : forall (A : grade) (B : grade), { A = B } + { not (A = B) }. 32 | Instance equ : @EqDec_eq grade := q_eq_dec. 33 | Parameter eqb_eq : forall (n m : grade), q_eqb n m = true <-> n = m. 34 | Definition eq_equiv : Equivalence (@Logic.eq grade) := eq_equivalence. 35 | Definition eq_dec := q_eq_dec. 36 | Include BackportEq. 37 | 38 | (* Order *) 39 | Definition leb := q_leb. 40 | Definition le n m := is_true (q_leb n m). 41 | Definition q_lt n m := is_true (q_leb n m) /\ n <> m. 42 | 43 | (* Size *) 44 | Definition size_grade : grade -> nat := fun _ => 1%nat. 45 | Lemma size_grade_min : forall q1, (1 <= size_grade q1). intros. unfold size_grade. auto. Qed. 46 | 47 | (* Notation *) 48 | Declare Scope grade_scope. 49 | Bind Scope grade_scope with grade. 50 | Local Open Scope grade_scope. 51 | 52 | Infix "=?" := q_eqb (at level 70) : grade_scope. 53 | Infix "<=?" := q_leb (at level 70) : grade_scope. 54 | Notation "q1 <= q2" := (is_true (q_leb q1 q2)) (at level 70) : grade_scope. 55 | Notation "q1 < q2" := (q_lt q1 q2) (at level 70) : grade_scope. 56 | Notation "x * y" := (q_join x y) : grade_scope. 57 | Notation "x + y " := (q_meet x y) : grade_scope. 58 | 59 | (* join and meet are commutative and associative *) 60 | Axiom join_assoc : forall a b c, a * (b * c) = (a * b) * c. 61 | Axiom join_comm : forall a b, a * b = b * a. 62 | Axiom meet_assoc : forall a b c, a + (b + c) = (a + b) + c. 63 | Axiom meet_comm : forall a b, a + b = b + a. 64 | 65 | (* absorption laws *) 66 | Axiom absorb_meet : forall a b, a * (a + b) = a. 67 | Axiom absorb_join : forall a b, a + (a * b) = a. 68 | 69 | (* join and meet are idempotent *) 70 | Axiom join_idem : forall a, a * a = a. 71 | Axiom meet_idem : forall psi, psi + psi = psi. 72 | 73 | (* bounded *) 74 | Axiom join_Top_r : forall a, a * q_Top = q_Top. 75 | Axiom meet_Bot_r : forall a, a + q_Bot = q_Bot. 76 | 77 | (* Everything is either below or above C, and you can tell which *) 78 | Axiom order_q_C_dec : forall q, { q <= q_C } + { q_C < q }. 79 | 80 | (* Pre order *) 81 | Axiom leb_leq : forall (n m : grade), (n <=? m) = true <-> n <= m. 82 | 83 | Axiom join_leq : forall a b, a <= b -> (a * b) = b. 84 | Axiom leq_join : forall a b, (a * b) = b -> a <= b. 85 | 86 | Axiom meet_leq : forall a b, a <= b -> (a + b) = a. 87 | Axiom leq_meet : forall a b, (a + b) = a -> a <= b. 88 | 89 | Lemma q_leb_refl : forall n, is_true (n <=? n). 90 | Proof. intro n. apply leq_join. rewrite join_idem. auto. Qed. 91 | 92 | Lemma q_leb_trans: forall m n p, is_true (n <=? m) -> is_true (m <=? p) -> is_true (n <=? p). 93 | Proof. intros. apply leq_join. apply join_leq in H. apply join_leq in H0. rewrite <- H0. 94 | rewrite join_assoc. rewrite -> H. auto. Qed. 95 | 96 | Instance le_preorder : PreOrder le. 97 | Proof. split. intro x. apply q_leb_refl. unfold Transitive. intros. eapply q_leb_trans; eauto. Qed. 98 | 99 | 100 | End GradeSig. 101 | 102 | Declare Module Grade : GradeSig. 103 | Export Grade. 104 | 105 | Hint Rewrite join_assoc join_Top_r join_idem : grade. 106 | 107 | Section GradeFacts. 108 | 109 | (* Properties about the lattice used in the development. *) 110 | 111 | Local Open Scope grade_scope. 112 | 113 | Lemma q_leb_antisym : forall a b, a <= b -> b <= a -> a = b. 114 | Proof. intros. apply join_leq in H. apply join_leq in H0. rewrite join_comm in H0. 115 | rewrite <- H. symmetry. auto. Qed. 116 | 117 | Lemma leq_Top : forall a, a <= q_Top. 118 | Proof. intros. apply leq_join. rewrite join_Top_r. auto. Qed. 119 | 120 | Lemma leq_Bot : forall a, q_Bot <= a. 121 | Proof. intros. apply leq_meet. rewrite meet_comm. rewrite meet_Bot_r. auto. Qed. 122 | 123 | Lemma leq_join_l : forall a b, a <= a * b. 124 | Proof. intros. apply leq_join. rewrite join_assoc. rewrite join_idem. auto. Qed. 125 | 126 | Lemma leq_join_r : forall a b, b <= a * b. 127 | Proof. intros. apply leq_join. rewrite join_comm. rewrite <- join_assoc. rewrite join_idem. auto. Qed. 128 | 129 | Lemma join_Top_l : forall a, q_Top * a = q_Top. 130 | Proof. intros. rewrite join_comm. apply join_Top_r. Qed. 131 | 132 | Lemma join_idem_l : forall (a b:grade), a * (a * b) = a * b. 133 | Proof. intros. rewrite join_assoc. rewrite join_idem. auto. Qed. 134 | 135 | Hint Rewrite join_idem_l join_Top_l : grade. 136 | 137 | Lemma po_join_l : forall a b c , a <= b -> a * c <= b * c. 138 | Proof. intros. apply leq_join. apply join_leq in H. 139 | rewrite join_assoc. 140 | replace (a * c * b * c) with (a * (c * b) * c). 2: autorewrite with grade; auto. 141 | rewrite (join_comm c). autorewrite with grade. 142 | rewrite <- join_assoc. rewrite join_idem. 143 | rewrite H. auto. Qed. 144 | 145 | Lemma po_join_r : forall a b c , a <= b -> c * a <= c * b. 146 | Proof. 147 | intros. apply leq_join. apply join_leq in H. 148 | rewrite (join_comm c a). rewrite join_assoc. 149 | replace (a * c * c * b) with (a * (c * c) * b). rewrite join_idem. 150 | rewrite <- join_assoc. rewrite (join_comm c b). rewrite join_assoc. 151 | rewrite H. auto. 152 | rewrite join_assoc. auto. 153 | Qed. 154 | 155 | Lemma join_lub : forall a b c, 156 | a <= c -> b <= c -> a * b <= c. 157 | Proof. 158 | intros. apply leq_join. apply join_leq in H. apply join_leq in H0. 159 | rewrite <- join_assoc. rewrite H0. auto. Qed. 160 | 161 | Lemma leq_meet_l : forall a b, a + b <= a. 162 | Proof. intros. apply leq_meet. rewrite (meet_comm a b). 163 | rewrite <- meet_assoc. 164 | rewrite meet_idem. auto. Qed. 165 | 166 | Lemma leq_meet_r : forall a b, a + b <= b. 167 | Proof. intros. apply leq_meet. 168 | rewrite <- meet_assoc. rewrite meet_idem. auto. Qed. 169 | 170 | Lemma po_meet_l : forall a b c , a <= b -> a + c <= b + c. 171 | Proof. 172 | intros. apply leq_meet. apply meet_leq in H. 173 | rewrite meet_assoc. 174 | replace (a + c + b + c) with (a + (c + b) + c). 175 | rewrite (meet_comm c b). rewrite meet_assoc. 176 | rewrite H. rewrite <- meet_assoc. rewrite meet_idem. auto. 177 | rewrite meet_assoc. auto. 178 | Qed. 179 | 180 | Lemma po_meet_r : forall a b c , a <= b -> c + a <= c + b. 181 | Proof. intros. rewrite meet_comm. rewrite (meet_comm c b). 182 | apply po_meet_l. auto. Qed. 183 | 184 | 185 | Lemma still_higher : forall a b, 186 | q_C < a -> b <= q_C -> q_C < a * b. 187 | Proof. 188 | intros. inversion H. 189 | apply join_leq in H0. apply join_leq in H1. 190 | split. 191 | - apply leq_join. 192 | rewrite join_assoc. rewrite H1. auto. 193 | - move => h. apply H2. apply q_leb_antisym. apply leq_join. auto. 194 | apply leq_join. 195 | rewrite <- H0. rewrite join_assoc. rewrite <- h. rewrite join_idem. 196 | symmetry. auto. 197 | Qed. 198 | 199 | Lemma meet_mult : forall {a b}, 200 | a <= q_C -> 201 | q_C + (b * a) = (q_C + b) * a. 202 | Proof. 203 | intros. 204 | destruct (order_q_C_dec b). 205 | + move: (meet_leq _ _ i) => h1. rewrite meet_comm in h1. rewrite h1. 206 | have LT: (a * b <= q_C). apply join_lub; auto. 207 | rewrite meet_comm. 208 | move: (meet_leq _ _ LT) => h2. rewrite join_comm in h2. rewrite h2. 209 | rewrite join_comm. auto. 210 | + inversion q. clear q. clear H1. 211 | move: (meet_leq _ _ H0) => h1. rewrite h1. 212 | have LT: (q_C <= a * b). 213 | transitivity (a * q_C). eapply leq_join_r. eapply po_join_r. auto. 214 | apply meet_leq in LT. rewrite join_comm in LT. rewrite LT. 215 | apply join_leq in H. rewrite <- H at 1. rewrite join_comm. auto. 216 | Qed. 217 | 218 | Lemma lt_not_leq : forall {psi psi0}, 219 | psi < psi0 -> ~ psi0 <= psi. 220 | Proof. 221 | intros psi psi0 H. inversion H. move=>h. apply H1. eapply q_leb_antisym; auto. Qed. 222 | 223 | Lemma not_leq_lower : forall {psi psi0 phi}, 224 | psi <= phi -> ~ psi0 <= phi -> ~ psi0 <= psi. 225 | Proof. 226 | intros. move=> h. apply H0. transitivity psi; auto. 227 | Qed. 228 | 229 | End GradeFacts. 230 | 231 | 232 | -------------------------------------------------------------------------------- /DDC/src/labels.v: -------------------------------------------------------------------------------- 1 | Require Export Metalib.Metatheory. 2 | Require Export Qual.Qualitative_ott. 3 | Require Export Qual.tactics. 4 | 5 | Local Open Scope grade_scope. 6 | 7 | Set Implicit Arguments. 8 | 9 | 10 | (* --------------- Context sub ---------------- *) 11 | 12 | 13 | Lemma P_sub_binds : forall P P' x psi, P_sub P' P -> binds x psi P -> exists psi', binds x psi' P' /\ psi' <= psi. 14 | Proof. intros. induction H; eauto. 15 | inversion H0. inversion H4. subst. eexists. eauto. 16 | destruct IHP_sub. eauto. split_hyp. eexists. split; eauto. 17 | Qed. 18 | 19 | #[export] Hint Constructors P_sub : core. 20 | Lemma P_sub_refl : forall P, uniq P -> P_sub P P. 21 | Proof. induction 1; econstructor; eauto. reflexivity. Qed. 22 | 23 | 24 | (* labels *) 25 | 26 | Lemma labels_app : forall W1 W2, labels (W1 ++ W2) = labels W1 ++ labels W2. 27 | Proof. induction W1; intros; simpl; auto. destruct a. destruct p. 28 | rewrite IHW1. eauto. 29 | Qed. 30 | 31 | Lemma labels_one : forall x psi0 A, labels [(x, (psi0, A))] = [(x,psi0)]. 32 | Proof. reflexivity. Qed. 33 | 34 | Lemma labels_dom : forall W, dom (labels W) = dom W. 35 | Proof. induction W; intros; simpl; auto. destruct a. destruct p. rewrite IHW. auto. Qed. 36 | 37 | Lemma labels_uniq : forall W, uniq W -> uniq (labels W). 38 | Proof. induction W; intros; simpl; auto. destruct a. destruct p. 39 | destruct_uniq. econstructor; eauto. rewrite labels_dom; eauto. Qed. 40 | 41 | Lemma binds_labels_1 : forall W x psi, binds x psi (labels W) -> exists A, binds x (psi, A) W. 42 | Proof. 43 | intros. induction W; intros; inversion H; try destruct a; try destruct p; subst. 44 | inversion H0. subst. eauto. 45 | destruct IHW. auto. eauto. Qed. 46 | Lemma binds_labels_2 : forall W x psi A, binds x (psi,A) W -> binds x psi (labels W). 47 | intros. unfold labels. 48 | eapply binds_map_2 with (f := (fun '(u,_) => u)) in H. auto. 49 | Qed. 50 | 51 | Lemma labels_subst_ctx : forall a x W1, labels (subst_ctx a x W1) = labels W1. 52 | Proof. 53 | intros. induction W1; intros. auto. 54 | try destruct a0; try destruct p; subst. simpl. 55 | f_equal. auto. 56 | Qed. 57 | 58 | #[export] Hint Rewrite labels_subst_ctx : rewr_list. 59 | #[export] Hint Rewrite labels_one : rewr_list. 60 | #[export] Hint Rewrite labels_app : rewr_list. 61 | #[export] Hint Rewrite labels_dom : rewr_dom. 62 | 63 | #[export] Hint Resolve labels_uniq : core. 64 | #[export] Hint Resolve binds_labels_2 : core. 65 | 66 | (* ctx_sub *) 67 | 68 | 69 | Lemma ctx_sub_labels : forall (W1 W2 : context), ctx_sub W2 W1 -> P_sub (labels W2) (labels W1). 70 | induction 1; intros; eauto. 71 | econstructor; eauto. 72 | Qed. 73 | 74 | Lemma ctx_sub_dom : forall (W1 W2 : context), ctx_sub W2 W1 -> dom W1 = dom W2. 75 | Proof. induction 1; eauto. simpl. f_equal. auto. Qed. 76 | 77 | 78 | 79 | Lemma ctx_sub_binds : forall {W W2 : context}, ctx_sub W2 W -> forall {x} {psi1:grade}{A}, 80 | binds x (psi1, A) W -> exists psi0 , (psi0 <= psi1) /\ binds x (psi0, A) W2. 81 | Proof. 82 | intros W W2 Sub. induction Sub; intros. inversion H. 83 | eapply binds_cons_1 in H3. 84 | move: H3 => [[? E] | b]. inversion E. subst. 85 | eexists. eauto. 86 | edestruct IHSub. eauto. 87 | split_hyp. 88 | exists x1. split; auto. 89 | Qed. 90 | 91 | Lemma dom_meet_ctx_l : forall {W}, dom (meet_ctx_l q_C W) = dom W. 92 | Proof. intros. induction W. simpl. auto. 93 | destruct a. destruct p. simpl. f_equal. auto. 94 | Qed. 95 | 96 | 97 | Lemma ctx_sub_meet_ctx_l : forall {G1 G2}, ctx_sub G1 G2 -> ctx_sub (meet_ctx_l q_C G1) (meet_ctx_l q_C G2). 98 | Proof. 99 | intros G1 G2 S. induction S. 100 | simpl. auto. 101 | simpl. simpl_env. 102 | econstructor; eauto. 103 | eapply po_meet_r. auto. 104 | all: try rewrite dom_meet_ctx_l; auto. 105 | Qed. 106 | 107 | Lemma ctx_sub_refl : forall W : context, uniq W -> ctx_sub W W. 108 | Proof. 109 | induction W; eauto. 110 | move => h. inversion h. 111 | destruct a. destruct a0. 112 | simpl_env. 113 | econstructor; eauto. 114 | reflexivity. 115 | Qed. 116 | 117 | Lemma ctx_sub_app : forall W1 W2 W1' W2', ctx_sub W1 W1' -> ctx_sub W2 W2' -> uniq (W1 ++ W2) -> ctx_sub (W1 ++ W2) (W1' ++ W2'). 118 | Proof. 119 | intros. 120 | induction H. simpl. auto. 121 | simpl_env. inversion H1. subst. 122 | econstructor; eauto. 123 | rewrite -> dom_app in *. 124 | erewrite ctx_sub_dom with (W2 := W2)(W1 := W2'); eauto. 125 | Qed. 126 | 127 | 128 | (* -------------------- *) 129 | 130 | Lemma meet_ctx_l_one : forall q x psi0 A, meet_ctx_l q [(x, (psi0, A))] = [(x, (q + psi0, A))]. intros; eauto. Qed. 131 | Lemma meet_ctx_l_app :forall W2 W1 q, meet_ctx_l q (W2 ++ W1) = meet_ctx_l q W2 ++ meet_ctx_l q W1. 132 | Proof. induction W2; simpl; eauto. destruct a. destruct p. intros. f_equal. eauto. Qed. 133 | Lemma meet_ctx_l_meet_ctx_l : forall W q, meet_ctx_l q (meet_ctx_l q W) = meet_ctx_l q W. 134 | Proof. induction W; simpl; eauto. destruct a. destruct p. intros. f_equal. 135 | rewrite meet_assoc. rewrite meet_idem. auto. auto. Qed. 136 | Lemma meet_ctx_l_subst_ctx : forall W q a x, meet_ctx_l q (subst_ctx a x W) = subst_ctx a x (meet_ctx_l q W). 137 | Proof. induction W; simpl; eauto. destruct a. destruct p. intros. f_equal. eauto. Qed. 138 | Lemma meet_ctx_l_uniq : forall W q, uniq W -> uniq (meet_ctx_l q W). intros. unfold meet_ctx_l. solve_uniq. Qed. 139 | 140 | Lemma meet_ctx_l_ctx_sub : forall W q, uniq W -> ctx_sub (meet_ctx_l q W) W. 141 | intros. induction W; simpl; eauto. destruct a. destruct p. 142 | destruct_uniq. econstructor; eauto. 143 | eapply leq_meet_r. unfold meet_ctx_l. auto. 144 | Qed. 145 | 146 | #[export] Hint Rewrite meet_ctx_l_meet_ctx_l : rewr_list. 147 | #[export] Hint Rewrite meet_ctx_l_one : rewr_list. 148 | #[export] Hint Rewrite meet_ctx_l_app : rewr_list. 149 | #[export] Hint Rewrite meet_ctx_l_subst_ctx : rewr_list. 150 | 151 | #[export] Hint Resolve meet_ctx_l_uniq : core. 152 | -------------------------------------------------------------------------------- /DDC/src/metalib.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Metalib.Metatheory. 3 | 4 | (* look for other places to use this tactic *) 5 | Ltac binds_mid_eq := 6 | match goal with [ H : binds ?x ?psi (?P2 ++ ?a ++ ?P) |- _ ] => 7 | apply binds_mid_eq in H; subst; try solve_uniq; clear H end. 8 | 9 | Lemma helper_uniq : forall {A} P2 x (psi0 psi1 : A) P1, uniq (P2 ++ x ~ psi0 ++ P1) -> uniq (P2 ++ x ~ psi1 ++ P1). 10 | Proof. 11 | intros. solve_uniq. 12 | Qed. 13 | 14 | (* ------- these should be added to the metatheory library ------------------------- *) 15 | 16 | (* If we have identified a variable in the middle of a uniq environment, 17 | it fixes the front and back. *) 18 | Lemma uniq_mid A x (a a':A) G1 : forall G2 G1' G2', 19 | uniq (G1 ++ (x ~ a) ++ G2) -> 20 | (G1 ++ x ~ a ++ G2) = (G1' ++ x ~ a' ++ G2') -> 21 | G1 = G1' /\ a = a' /\ G2 = G2'. 22 | Proof. 23 | induction G1. 24 | + intros. 25 | destruct G1'; inversion H0; simpl_env in *. auto. 26 | subst. destruct_uniq. fsetdec. 27 | + intros. 28 | destruct a0 as [y b]. 29 | simpl_env in *. 30 | destruct_uniq. 31 | have NE: not (y = x). fsetdec. 32 | destruct G1' as [|[z c]]. simpl_env in H0. inversion H0. done. 33 | inversion H0. subst. 34 | simpl_env in *. 35 | specialize (IHG1 G2 G1' G2'). 36 | destruct IHG1 as [E1 [E2 E3]]; auto. 37 | subst. auto. 38 | Qed. 39 | 40 | (* If x is in an environment, it is either in the front half or 41 | the back half. *) 42 | Lemma binds_split A x (a:A) G : binds x a G -> exists G1 G2, G = G2 ++ [(x, a)] ++ G1. 43 | Proof. 44 | move=>B. induction G. 45 | + inversion B. 46 | + destruct a0 as [y b]. 47 | apply binds_cons_1 in B. 48 | destruct B as [[E1 E2]|E]. subst. 49 | ++ exists G. exists nil. auto. 50 | ++ destruct (IHG E) as [G1 [G2 E2]]. 51 | subst. 52 | eexists. exists ((y ~ b) ++ G2). simpl_env. 53 | eauto. 54 | Qed. 55 | 56 | (* If we divide up a context containing a variable, it either appears in the 57 | front half or the back half *) 58 | Lemma ctx_align_eq A G1 G2 (x:atom) (a:A) G0 G3 : 59 | uniq (G2 ++ x ~ a ++ G1) -> 60 | G2 ++ x ~ a ++ G1 = G0 ++ G3 -> 61 | (exists G0' G0'', G0 = G0' ++ x ~ a ++ G0'' /\ G2 = G0' /\ G1 = G0'' ++ G3) \/ 62 | (exists G3' G3'', G3 = G3' ++ x ~ a ++ G3'' /\ G2 = G0 ++ G3' /\ G1 = G3''). 63 | Proof. 64 | intros U E. 65 | have B: binds x a (G0 ++ G3). { rewrite <- E. auto. } 66 | rewrite -> binds_app_iff in B. 67 | destruct B as [h1|h1]. 68 | + left. 69 | destruct (binds_split _ _ _ _ h1) as [G0'' [G0' E2]]. 70 | exists G0'. exists G0''. split. auto. 71 | subst. 72 | simpl_env in E. 73 | edestruct uniq_mid with (G1 := G2) (G1' := G0') 74 | (G2 := G1) (G2' := G0'' ++ G3); eauto. 75 | tauto. 76 | + right. 77 | destruct (binds_split _ _ _ _ h1) as [G0'' [G0' E2]]. 78 | exists G0'. exists G0''. split. auto. 79 | subst. 80 | edestruct uniq_mid with (G1 := G2) (G1' := G0 ++ G0') 81 | (G2 := G1) (G2' := G0''); simpl_env; eauto. 82 | tauto. 83 | Qed. 84 | -------------------------------------------------------------------------------- /DDC/src/narrowing.v: -------------------------------------------------------------------------------- 1 | Require Export Qual.metalib. 2 | Require Export Qual.tactics. 3 | Require Export Qual.labels. 4 | Require Export Qual.uniq. 5 | 6 | Set Implicit Arguments. 7 | Open Scope grade_scope. 8 | 9 | 10 | Lemma Grade_narrowing : (forall P psi phi a, CGrade P psi phi a -> forall P', P_sub P' P -> CGrade P' psi phi a) /\ 11 | (forall P psi a, Grade P psi a -> forall P', P_sub P' P -> Grade P' psi a). 12 | Proof. 13 | apply CGrade_Grade_mutual. 14 | all : intros; eauto using P_sub_uniq1. 15 | all: try solve [fresh_apply_Grade x; eauto; 16 | repeat spec x; 17 | match goal with [H2 : forall P', _ |- _ ] => eapply H2 end; 18 | econstructor; eauto; 19 | reflexivity]. 20 | - (* Var *) 21 | move: (P_sub_binds _ _ ltac:(eassumption) b) => [psi' [bb ss]]. 22 | eapply G_Var. 3 : { eauto. } eauto using P_sub_uniq1. 23 | transitivity psi0; auto. 24 | Qed. 25 | 26 | Lemma CEq_GEq_narrowing : 27 | (forall P phi phi0 a b, 28 | CEq P phi phi0 a b -> forall P', P_sub P' P -> CEq P' phi phi0 a b) /\ 29 | (forall P phi a b, 30 | GEq P phi a b -> forall P', P_sub P' P -> GEq P' phi a b). 31 | Proof. 32 | eapply CEq_GEq_mutual. 33 | all: intros; eauto using P_sub_uniq1. 34 | all: try solve [fresh_apply_GEq x; eauto; 35 | repeat spec x; 36 | match goal with [ H : forall P', P_sub P' ?P -> _ |- _] => eapply H end; 37 | econstructor; eauto; 38 | reflexivity] . 39 | - eapply P_sub_binds in b; eauto. 40 | destruct b as [psi' [b ss]]. 41 | eapply GEq_Var; eauto using P_sub_uniq1. 42 | transitivity psi0; auto. 43 | Qed. 44 | 45 | Lemma GEq_narrowing : forall P phi a b, 46 | GEq P phi a b -> forall P', P_sub P' P -> GEq P' phi a b. 47 | Proof. apply CEq_GEq_narrowing; eauto. Qed. 48 | 49 | Lemma DefEq_narrowing : 50 | (forall P phi psi a b, 51 | CDefEq P phi psi a b -> forall P', P_sub P' P -> CDefEq P' phi psi a b) /\ 52 | (forall P phi a b, 53 | DefEq P phi a b -> forall P', P_sub P' P -> DefEq P' phi a b). 54 | Proof. 55 | move: (Grade_narrowing) => [ _ gn]. 56 | eapply CDefEq_DefEq_mutual. 57 | all: intros P phi a b h. 58 | all: intros; eauto 3 using P_sub_uniq1. 59 | all: try solve [fresh_apply_DefEq x; auto; 60 | repeat spec x; 61 | match goal with [ H : forall P', P_sub P' ?P -> _ |- _] => eapply H end; 62 | econstructor; eauto; 63 | reflexivity]. 64 | 65 | all: try solve [pick fresh x and apply Eq_SubstIrrel; eauto 2; 66 | repeat spec x; 67 | match goal with [ H : forall P', P_sub P' ?P -> _ |- _] => eapply H end; 68 | econstructor; eauto; 69 | reflexivity]. 70 | 71 | eapply Eq_Trans; eauto. 72 | eapply Eq_Beta; eauto. 73 | eapply Eq_App; eauto. 74 | eapply Eq_PiSnd; eauto. 75 | eapply Eq_WSigmaSnd; eauto. 76 | eapply Eq_WPair; eauto. 77 | eapply Eq_SSigmaSnd; eauto. 78 | eapply Eq_SPair; eauto. 79 | eapply Eq_Sum; eauto. 80 | eapply Eq_Case; eauto. 81 | 82 | Qed. 83 | 84 | Lemma Par_narrowing : 85 | ( forall P1 psi phi a b, CPar P1 psi phi a b -> forall P2, P_sub P2 P1 -> CPar P2 psi phi a b) /\ 86 | forall P1 psi a b, Par P1 psi a b -> forall P2, P_sub P2 P1 -> Par P2 psi a b. 87 | Proof. 88 | move: (Grade_narrowing) => [_ gn]. 89 | apply CPar_Par_mutual. 90 | all: intros. 91 | all: eauto using Grade_narrowing, GEq_narrowing. 92 | all: try (fresh_apply_Par x; eauto; repeat spec x). 93 | all: try solve [eapply H2; econstructor; eauto; try reflexivity]. 94 | eapply CPar_Nleq; eauto using P_sub_uniq1. 95 | Qed. 96 | 97 | 98 | Lemma Typing_narrowing : forall psi a A W1, 99 | Typing W1 psi a A -> 100 | forall W2, ctx_sub W2 W1 -> 101 | Typing W2 psi a A. 102 | Proof with eauto using ctx_sub_meet_ctx_l. 103 | induction 1; intros... 104 | all: try move: (ctx_sub_uniq ltac:(eassumption) ltac:(eassumption)) => uu. 105 | all: eauto 3. 106 | all: try solve [ 107 | fresh_apply_Typing x; 108 | eauto using po_join_r, ctx_sub_meet_ctx_l; 109 | repeat spec x; 110 | eapply H4; 111 | econstructor; eauto; 112 | reflexivity ]. 113 | - (* conv *) 114 | have S: ctx_sub (meet_ctx_l q_C W2) (meet_ctx_l q_C W). eauto... 115 | move: (ctx_sub_labels S) => Eq. 116 | eapply T_Conv; eauto 2. 117 | eapply DefEq_narrowing; eauto. 118 | - (* Var *) 119 | move: (ctx_sub_binds ltac:(eauto) ltac:(eauto)) => [psi1 [h1 h2]]. 120 | eapply T_Var with (psi0 := psi1); eauto using ctx_sub_uniq. 121 | transitivity psi0; auto. 122 | - (* Pi *) 123 | fresh_apply_Typing x; 124 | eauto using po_join_r, ctx_sub_meet_ctx_l; 125 | repeat spec x. 126 | eapply H3; 127 | econstructor; eauto; 128 | reflexivity . 129 | - (* WPair *) 130 | eapply T_WPair... 131 | - (* WPairI *) 132 | eapply T_WPairIrrel... 133 | - (* LetPair *) 134 | fresh_apply_Typing x; 135 | eauto using po_join_r, ctx_sub_meet_ctx_l. 136 | + clear H2 H3. repeat spec x. eapply H2; econstructor; eauto. 137 | reflexivity. eapply ctx_sub_meet_ctx_l; auto. 138 | rewrite dom_meet_ctx_l. auto. 139 | rewrite dom_meet_ctx_l. auto. 140 | + move=> y Fry. 141 | clear H H0 H2. 142 | spec x. spec y. 143 | eapply H0. econstructor; eauto. reflexivity. 144 | - (* SPair *) 145 | eapply T_SPair... 146 | - (* case *) 147 | fresh_apply_Typing x; eauto using po_join_r, ctx_sub_meet_ctx_l. 148 | repeat spec x. 149 | eapply H2. 150 | econstructor; eauto; try reflexivity. 151 | eapply ctx_sub_meet_ctx_l; auto. 152 | rewrite dom_meet_ctx_l. auto. 153 | rewrite dom_meet_ctx_l. auto. 154 | Qed. 155 | -------------------------------------------------------------------------------- /DDC/src/ottalt.sty: -------------------------------------------------------------------------------- 1 | %% 2 | %% This is file `ottalt.sty', 3 | %% generated with the docstrip utility. 4 | %% 5 | %% The original source files were: 6 | %% 7 | %% ottalt.dtx (with options: `package') 8 | %% 9 | %% Copyright (C) 2011 by Jesse A. Tov 10 | %% 11 | %% This file may be distributed and/or modified under the conditions of the 12 | %% LaTeX Project Public License, either version 1.2 of this license or (at 13 | %% your option) any later version. The latest version of this license is 14 | %% in: 15 | %% 16 | %% http://www.latex-project.org/lppl.txt 17 | %% 18 | %% and version 1.2 or later is part of all distributions of LaTeX 19 | %% version 1999/12/01 or later. 20 | %% 21 | \NeedsTeXFormat{LaTeX2e}[1999/12/01] 22 | \ProvidesPackage{ottalt} 23 | [2013/03/14 v0.11 alternate Ott layout style] 24 | \RequirePackage{mathpartir} 25 | \RequirePackage{ifthen} 26 | \RequirePackage{keyval} 27 | \RequirePackage{listproc} 28 | \DeclareOption{implicitPremiseBreaks}{ 29 | \renewcommand\ottaltpremisesep{\\} 30 | \renewcommand\ottaltpremisebreak{\\} 31 | } 32 | \DeclareOption{lineBreakHack}{ 33 | \renewcommand\ottaltpremisesep{\mpr@andcr} 34 | \renewcommand\ottaltpremisebreak{\\\\} 35 | } 36 | \DeclareOption{implicitLineBreakHack}{ 37 | \renewcommand\ottaltpremisesep{\\} 38 | \renewcommand\ottaltpremisebreak{\\\\} 39 | } 40 | \DeclareOption{alternateNonterms}{ 41 | \let\ifnotalternateNonterms\@secondoftwo 42 | } 43 | \DeclareOption{supertabular}{ 44 | \ottalt@supertabulartrue 45 | } 46 | \newcommand\ottaltpremisesep{\\} 47 | \newcommand\ottaltpremisebreak{\\} 48 | \let\ifnotalternateNonterms\@firstoftwo 49 | \newif\ifottalt@supertabular 50 | \ProcessOptions 51 | \ifottalt@supertabular 52 | \RequirePackage{supertabular} 53 | \fi 54 | \newcommand\inputott[2][ott]{ 55 | \input{#2} 56 | \renewottcommands[#1] 57 | } 58 | \newcommand\ottaltcurrentprefix{ott} 59 | \newcommand\renewottcommands[1][ott]{ 60 | \renewcommand\ottaltcurrentprefix{#1} 61 | \def\renewottcomm@nd##1{ 62 | \expandafter\renewcommand\csname #1##1\endcsname 63 | } 64 | \renewottcomm@nd{drule}[4][]{ 65 | \def\ottalt@nextpremise{} 66 | \ottalt@premisetoks={ } 67 | ##2 68 | \expandafter\ottalt@inferrule\expandafter 69 | {\the\ottalt@premisetoks}{##3}{##4}{##1} 70 | } 71 | \renewottcomm@nd{premise}[1]{% 72 | \ottalt@premisetoks= 73 | \expandafter\expandafter\expandafter 74 | {\expandafter\the\expandafter\ottalt@premisetoks 75 | \ottalt@nextpremise##1} 76 | \ottalt@iflinebreakhack##1\ottlinebreakhack\ottalt@iflinebreakhack{ 77 | \let\ottalt@nextpremise\ottaltpremisebreak 78 | }{ 79 | \let\ottalt@nextpremise\ottaltpremisesep 80 | } 81 | } 82 | \renewottcomm@nd{usedrule}[1]{% 83 | \ifottalt@firstrule 84 | \ottalt@firstrulefalse 85 | \else 86 | %\and 87 | %% sigart.cls uses \and for the title and mangles it horribly 88 | %% so we cannot use it here. Instead, we drop down to what 89 | %% mathpartir wants to redefine the \and command to be anyways 90 | \mpr@andcr 91 | %%\quad 92 | \fi 93 | \ensuremath{##1} 94 | } 95 | \renewenvironment{#1defnblock}[3][] 96 | {\begin{drulepar}{##2}{##3}} 97 | {\end{drulepar}} 98 | \renewottcomm@nd{drulename}[1]{% 99 | \ottalt@replace@cs\ranchor\_-{}##1\\ 100 | } 101 | \renewottcomm@nd{prodline}[6]{ 102 | \ifthenelse{\equal{##3}{}}{ 103 | \\ & & $##1$ & $##2$ & & $##5$ & $##6$ 104 | }{} 105 | } 106 | \renewottcomm@nd{prodnewline}{\relax} 107 | \renewottcomm@nd{grammartabular}[1]{% 108 | \begin{ottaltgrammar}##1\end{ottaltgrammar}% 109 | } 110 | } 111 | \newcommand*\drule@h@lper[3]{% 112 | \expandafter\ifx\csname\ottaltcurrentprefix drule#3\endcsname\relax 113 | \PackageWarning{ottalt}{Unknown ott rule: #3}% 114 | \mbox{\textbf{(#2?)}}% 115 | \else 116 | \csname\ottaltcurrentprefix usedrule\endcsname 117 | {\csname\ottaltcurrentprefix drule#3\endcsname{#1}}% 118 | \fi 119 | } 120 | \newcommand*\nonterm@h@lper[1]{\csname\ottaltcurrentprefix#1\endcsname} 121 | \newcommand\rrefruletext{rule} 122 | \newcommand\Rrefruletext{\expandafter\MakeUppercase\rrefruletext} 123 | \newcommand\rrefrulestext{\rrefruletext s} 124 | \newcommand\Rrefrulestext{\Rrefruletext s} 125 | \newcommand\rrefstyle{\normalfont\scshape} 126 | \newcommand\ranchorstyle{\rrefstyle} 127 | \providecommand\wraparoundrref{\relax} 128 | \newcommand*\rref{% 129 | \@ifnextchar* 130 | {\rref@star} 131 | {\rref@with\rrefruletext\rrefrulestext}} 132 | \newcommand*\Rref{% 133 | \@ifnextchar* 134 | {\rref@star} 135 | {\rref@with\Rrefruletext\Rrefrulestext}} 136 | \newcommand*\rref@with[2]{\FormatList{#1~}{#2~}{\one@rref}} 137 | \newcommand*\rref@star[1]{\FormatList{}{}{\one@rref}} 138 | \newcommand*\@one@rref@nohyper[1]{\wraparoundrref{{\rrefstyle{#1}}}} 139 | \newcommand*\@ranchor@nohyper[1]{{\ranchorstyle{#1}}} 140 | \AtBeginDocument{ 141 | \ifcsname hypertarget\endcsname 142 | \newcommand*\one@rref[1]{% 143 | \hyperlink 144 | {ottalt:rule:\ottaltcurrentprefix:#1} 145 | {\@one@rref@nohyper{#1}}% 146 | } 147 | \newcommand*\ranchor[1]{% 148 | \hypertarget 149 | {ottalt:rule:\ottaltcurrentprefix:#1} 150 | {\@ranchor@nohyper{#1}}% 151 | } 152 | \else 153 | \newcommand\one@rref{\@one@rref@nohyper} 154 | \newcommand\ranchor{\@ranchor@nohyper} 155 | \fi 156 | } 157 | \newcommand*{\drules}[4][\relax]{% 158 | \begin{drulepar}[#1]{#2}{#3} 159 | \@for\@ottalt@each:=#4\do{% 160 | \expandafter\drule\expandafter{\@ottalt@each} 161 | } 162 | \end{drulepar}% 163 | } 164 | \newenvironment{drulepar}[3][\relax] 165 | {\begin{rulesection}[#1]{#2}{#3}% 166 | \begin{mathparpagebreakable}} 167 | {\end{mathparpagebreakable}% 168 | \end{rulesection}} 169 | \newenvironment{drulepar*}[3][\relax] 170 | {\begin{rulesection*}[#1]{#2}{#3}% 171 | \begin{mathparpagebreakable}} 172 | {\end{mathparpagebreakable}% 173 | \end{rulesection*}} 174 | \newenvironment{rulesection}[3][\relax] 175 | {\trivlist\item 176 | \ifx#1\relax\else\def\ottalt@rulesection@prefix{#1-}\fi 177 | \drulesectionhead{#2}{#3}% 178 | \nopagebreak[4]% 179 | \noindent} 180 | {\endtrivlist} 181 | \newenvironment{rulesection*}[3][\relax] 182 | {\trivlist\item 183 | \ifx#1\relax\else\def\ottalt@rulesection@prefix{#1-}\fi 184 | \drulesectionhead*{#2}{#3}% 185 | \nopagebreak[4]% 186 | \noindent} 187 | {\endtrivlist} 188 | \newcommand\ottalt@rulesection@prefix{} 189 | \newcommand*{\drulesectionhead}{% 190 | \@ifnextchar *{\drulesectionheadMany}{\drulesectionheadOne}% 191 | } 192 | \newcommand*{\drulesectionheadOne}[2]{% 193 | \FormatDruleSectionHead{#1}% 194 | \hfill\FormatDruleSectionHeadRight{#2}% 195 | \par 196 | } 197 | \newcommand*{\drulesectionheadMany}[3]{% 198 | {% 199 | \let\FormatListSepTwo\FormatDruleSepTwo 200 | \let\FormatListSepMore\FormatDruleSepMore 201 | \let\FormatListSepLast\FormatDruleSepLast 202 | \FormatList{}{}{\FormatDruleSectionHeads}{#2}% 203 | }% 204 | \hfill\FormatDruleSectionHeadRight{#3}% 205 | \par 206 | } 207 | \newcommand*\FormatDruleSepTwo{\,,~} 208 | \newcommand*\FormatDruleSepMore{\FormatDruleSepTwo} 209 | \newcommand*\FormatDruleSepLast{\FormatDruleSepTwo} 210 | \newcommand*\FormatDruleSectionHead[1]{\fbox{#1}} 211 | \newcommand*\FormatDruleSectionHeads[1]{\fbox{\strut#1}} 212 | \newcommand*\FormatDruleSectionHeadRight[1]{\emph{(#1)}} 213 | \newcommand*\drule[2][]{% 214 | \expandafter\drule@helper\expandafter{\ottalt@rulesection@prefix}{#1}{#2}% 215 | } 216 | \newcommand*\drule@helper[3]{% 217 | \ottalt@replace@cs{\drule@h@lper{#2}{#1#3}}-{XX}{}#1#3\\ 218 | } 219 | \newcommand\ottaltinferrule[4]{ 220 | \inferrule*[narrower=0.3,lab=#1,#2] 221 | {#3} 222 | {#4} 223 | } 224 | \newcommand\ottalt@inferrule[4]{ 225 | \ottaltinferrule{#3}{#4}{#1}{#2} 226 | } 227 | \newif\ifottalt@firstrule \ottalt@firstruletrue 228 | \newcommand{\ottalt@nextpremise}{\relax} 229 | \newtoks\ottalt@premisetoks 230 | \newcommand{\ottlinebreakhack}{\relax} 231 | \def\ottalt@iflinebreakhack#1\ottlinebreakhack #2\ottalt@iflinebreakhack{% 232 | \ifthenelse{\equal{#2}{}}\@secondoftwo\@firstoftwo 233 | } 234 | \newcommand\ottalt@replace@cs[5]{% 235 | \ifx\\#5\relax 236 | \def\ottalt@replace@cs@kont{#1{#4}}% 237 | \else 238 | \ifx#2#5\relax 239 | \def\ottalt@replace@cs@kont{\ottalt@replace@cs{#1}{#2}{#3}{#4#3}}% 240 | \else 241 | \def\ottalt@replace@cs@kont{\ottalt@replace@cs{#1}{#2}{#3}{#4#5}}% 242 | \fi 243 | \fi 244 | \ottalt@replace@cs@kont 245 | } 246 | \newcommand*\nonterms[2][8pt]{ 247 | \begin{ottaltgrammar}[#1] 248 | \@for\@ottalt@each:=#2\do{% 249 | \expandafter\nt\expandafter{\@ottalt@each} 250 | } 251 | \end{ottaltgrammar} 252 | } 253 | \newenvironment{ottaltgrammar}[1][8pt]{% 254 | \begingroup 255 | \trivlist\item 256 | \def\OTTALTNEWLINE{\\[#1]}% 257 | \def\nt##1{\OTTALTNEWLINE\relax\nonterm@h@lper{##1}\ignorespaces}% 258 | \newcommand\ottaltintertext[2]{% 259 | \multicolumn{8}{l}{% 260 | \begin{minipage}{##1}% 261 | ##2% 262 | \end{minipage}% 263 | }% 264 | }% 265 | \ifottalt@supertabular 266 | \begin{supertabular}{llcllllll} 267 | \else 268 | \begin{tabular}{llcllllll} 269 | \fi 270 | \let\OTTALTNEWLINE\relax 271 | \ignorespaces 272 | } 273 | {% 274 | \@ifundefined{ottafterlastrule}{\\}{\ottafterlastrule}% 275 | \ifottalt@supertabular 276 | \end{supertabular} 277 | \else 278 | \end{tabular} 279 | \fi 280 | \endtrivlist 281 | \endgroup 282 | \ignorespaces 283 | } 284 | \newcommand\newNTclass[2][\ifnotalternateNonterms]{ 285 | \expandafter\newcommand\csname new#2s\endcsname[4][]{ 286 | #1{ 287 | \expandafter\newcommand\csname ottalt@NT@#2@##2\endcsname{##1{##3}} 288 | }{ 289 | \expandafter\newcommand\csname ottalt@NT@#2@##2\endcsname{##4} 290 | } 291 | } 292 | \expandafter\newcommand\csname new#2\endcsname[3][]{ 293 | \csname new#2s\endcsname[##1]{##2}{##3}{##3} 294 | } 295 | \expandafter\newcommand\csname #2\endcsname[1]{% 296 | \csname ottalt@NT@#2@##1\endcsname 297 | } 298 | } 299 | \providecommand\@ifToif[1]{% 300 | #1\iftrue\iffalse 301 | } 302 | \providecommand\ifTo@if[1]{% 303 | #1% 304 | \expandafter\@firstoftwo 305 | \else 306 | \expandafter\@secondoftwo 307 | \fi 308 | } 309 | \newcommand\NTOVERLINE{\NTCAPTURE\overline} 310 | \newcommand\NTUNDERLINE{\NTCAPTURE\underline} 311 | \newcommand\NTTEXTCOLOR[1]{\NTCAPTURE{\textcolor{#1}}} 312 | \newcommand\NTCAPTURE[1]{\NTCAPTURELOW{\NTCAPTURE@FINISH{#1}}} 313 | \newcommand\NTCAPTURE@FINISH[4]{#1{#2_{#3}#4}} 314 | \newcommand\NTCAPTURELOW[2]{\NT@CAPTURE@LOOP{#1}{#2}\relax\relax} 315 | \newcommand\NT@CAPTURE@LOOP[4]{% 316 | \@ifnextchar _{% 317 | \NT@CAPTURE@SUB{#1}{#2}{#3}{#4}% 318 | }{\@ifnextchar '{% 319 | \NT@CAPTURE@PRIME{#1}{#2}{#3}{#4}% 320 | }{% 321 | {#1{#2}{#3}{#4}}% 322 | }}% 323 | } 324 | \def\NT@CAPTURE@SUB#1#2#3#4_#5{\NT@CAPTURE@LOOP{#1}{#2}{#3#5}{#4}} 325 | \def\NT@CAPTURE@PRIME#1#2#3#4'{\NT@CAPTURE@LOOP{#1}{#2}{#3}{#4'}} 326 | \endinput 327 | %% 328 | %% End of file `ottalt.sty'. 329 | -------------------------------------------------------------------------------- /DDC/src/progress.v: -------------------------------------------------------------------------------- 1 | Require Export Qual.tactics. 2 | Require Export Qual.typing. 3 | Require Export Qual.consist. 4 | 5 | Set Implicit Arguments. 6 | Open Scope grade_scope. 7 | 8 | Lemma Consistent_Type : forall s A0, 9 | Consistent (a_Type s) A0 -> ValueType A0 -> A0 = (a_Type s). 10 | Proof. 11 | intros s A0 C V. 12 | destruct A0; 13 | simpl in *; inversion C; inversion V. 14 | all: subst; auto. 15 | all: done. 16 | Qed. 17 | 18 | Ltac impossible_defeq := 19 | let h0 := fresh in 20 | let VT := fresh in 21 | let VT2 := fresh in 22 | match goal with 23 | [ E : DefEq ?nil ?q ?A ?B |- _ ] => 24 | pose h0:= E; clearbody h0; 25 | eapply DefEq_Consistent in h0; eauto; 26 | move: (DefEq_lc1 E) => l0; 27 | move: (DefEq_lc2 E) => l1; 28 | inversion l0; inversion l1; subst; 29 | have VT: ValueType A; eauto; 30 | have VT2 : ValueType B; eauto; 31 | inversion h0; subst; 32 | eauto; try done end. 33 | 34 | 35 | Lemma Canonical_Pi' : forall b psi psi0 B A1 A2, 36 | Typing nil psi b B -> 37 | DefEq nil q_C B (a_Pi psi0 A1 A2) -> Value b -> exists A0 a0, b = a_Abs psi0 A0 a0. 38 | Proof. intros b psi psi0 B A1 A2 T E V. 39 | dependent induction T. 40 | all: try solve 41 | [inversion V; match goal with [ H : ValueType ?a |- _ ] => inversion H end]. 42 | 43 | impossible_defeq. 44 | 45 | (* conversion case *) 46 | simpl in *; 47 | destruct IHT1; auto; 48 | try eapply Eq_Trans with (b := B); auto using Eq_Sym; 49 | eauto. 50 | 51 | all: impossible_defeq. 52 | Qed. 53 | 54 | Lemma Canonical_Pi : forall b psi psi0 A1 A2, 55 | Typing nil psi b (a_Pi psi0 A1 A2) -> 56 | Value b -> exists A0 a0, b = a_Abs psi0 A0 a0. 57 | Proof. 58 | intros. 59 | eapply Canonical_Pi' in H; auto. 60 | 2: { eapply Eq_Refl. 61 | replace nil with (labels nil). 2: auto. 62 | apply Typing_regularity in H; auto. destruct H. 63 | eapply Typing_Grade. 64 | replace nil with (meet_ctx_l q_C nil); eauto. 65 | } 66 | auto. 67 | Qed. 68 | 69 | Lemma Canonical_WSigma' : forall b psi psi0 B A1 A2, 70 | Typing nil psi b B -> 71 | DefEq nil q_C B (a_WSigma psi0 A1 A2) -> Value b -> exists a0 a1, b = a_WPair a0 psi0 a1. 72 | Proof. intros b psi psi0 B A1 A2 T E V. 73 | dependent induction T. 74 | all: try solve 75 | [inversion V; match goal with [ H : ValueType ?a |- _ ] => inversion H end]. 76 | 77 | impossible_defeq. 78 | 79 | (* conversion case *) 80 | simpl in *; 81 | destruct IHT1; auto; 82 | try eapply Eq_Trans with (b := B); auto using Eq_Sym; 83 | eauto. 84 | 85 | all: impossible_defeq. 86 | Qed. 87 | 88 | Lemma Canonical_WSigma : forall b psi psi0 A1 A2, 89 | Typing nil psi b (a_WSigma psi0 A1 A2) -> 90 | Value b -> exists a0 a1, b = a_WPair a0 psi0 a1. 91 | Proof. 92 | intros. 93 | eapply Canonical_WSigma' in H; auto. 94 | 2: { eapply Eq_Refl. 95 | replace nil with (labels nil). 2: auto. 96 | apply Typing_regularity in H; auto. destruct H. 97 | eapply Typing_Grade. 98 | replace nil with (meet_ctx_l q_C nil); eauto. 99 | } 100 | auto. 101 | Qed. 102 | 103 | Lemma Canonical_SSigma' : forall b psi psi0 B A1 A2, 104 | Typing nil psi b B -> 105 | DefEq nil q_C B (a_SSigma psi0 A1 A2) -> Value b -> exists a0 a1, b = a_SPair a0 psi0 a1. 106 | Proof. intros b psi psi0 B A1 A2 T E V. 107 | dependent induction T. 108 | all: try solve 109 | [inversion V; match goal with [ H : ValueType ?a |- _ ] => inversion H end]. 110 | 111 | impossible_defeq. 112 | 113 | (* conversion case *) 114 | simpl in *; 115 | destruct IHT1; auto; 116 | try eapply Eq_Trans with (b := B); auto using Eq_Sym; 117 | eauto. 118 | 119 | all: impossible_defeq. 120 | Qed. 121 | 122 | Lemma Canonical_SSigma : forall b psi psi0 A1 A2, 123 | Typing nil psi b (a_SSigma psi0 A1 A2) -> 124 | Value b -> exists a0 a1, b = a_SPair a0 psi0 a1. 125 | Proof. 126 | intros. 127 | eapply Canonical_SSigma' in H; auto. 128 | 2: { eapply Eq_Refl. 129 | replace nil with (labels nil). 2: auto. 130 | apply Typing_regularity in H; auto. destruct H. 131 | eapply Typing_Grade. 132 | replace nil with (meet_ctx_l q_C nil); eauto. 133 | } 134 | auto. 135 | Qed. 136 | 137 | Lemma Canonical_Sum' : forall b psi B A1 A2, 138 | Typing nil psi b B -> 139 | DefEq nil q_C B (a_Sum A1 A2) -> Value b -> exists a0, b = a_Inj1 a0 \/ b = a_Inj2 a0. 140 | Proof. intros b psi B A1 A2 T E V. 141 | dependent induction T. 142 | all: try solve 143 | [inversion V; match goal with [ H : ValueType ?a |- _ ] => inversion H end]. 144 | 145 | impossible_defeq. 146 | 147 | (* conversion case *) 148 | simpl in *; 149 | destruct IHT1; auto; 150 | try eapply Eq_Trans with (b := B); auto using Eq_Sym; 151 | eauto. 152 | 153 | all: impossible_defeq. 154 | Qed. 155 | 156 | Lemma Canonical_Sum : forall b psi A1 A2, 157 | Typing nil psi b (a_Sum A1 A2) -> 158 | Value b -> exists a0, b = a_Inj1 a0 \/ b = a_Inj2 a0. 159 | Proof. 160 | intros. 161 | eapply Canonical_Sum' in H; auto. 162 | eapply Eq_Refl. 163 | replace nil with (labels nil). 2: auto. 164 | apply Typing_regularity in H; auto. destruct H. 165 | eapply Typing_Grade. 166 | replace nil with (meet_ctx_l q_C nil); eauto. 167 | Qed. 168 | 169 | Lemma Typing_progress: 170 | forall psi a A, Typing nil psi a A -> (exists a', Step a a') \/ Value a. 171 | Proof. 172 | intros. 173 | move: (Typing_lc1 H) => LC. 174 | dependent induction H. 175 | all: try solve [right; eauto using Typing_lc1]. 176 | all: repeat match goal with [ H : _ ~= _ -> _ |- _ ] => specialize (H ltac:(reflexivity)) end. 177 | all: try solve [auto]. 178 | all: try solve [match goal with [H : binds _ _ _ |- _ ] => inversion H end]. 179 | 180 | all: inversion LC; subst. 181 | - (* Abs *) 182 | right. eauto. 183 | - (* AppRel *) 184 | left. 185 | destruct IHTyping1 as [[a' S]|V]; auto. 186 | + eauto. 187 | + move: (Canonical_Pi H V) => [A0 [a0 EQ]]. subst. 188 | inversion H4. 189 | eexists. 190 | eapply S_Beta; eauto. 191 | - (* AppIrrel *) 192 | left. 193 | destruct IHTyping1 as [[a' S]|V]; auto. 194 | + eauto. 195 | + move: (Canonical_Pi H V) => [A0 [a0 EQ]]. subst. 196 | inversion H4. 197 | eexists. 198 | eapply S_Beta; eauto. 199 | - (* LetPair *) 200 | left. 201 | destruct IHTyping as [[a' S]|V]; auto. 202 | + eexists. 203 | eapply S_LetPairCong; eauto. 204 | + move: (Canonical_WSigma H1 V) => [a0 [a1 EQ]]. subst. 205 | match goal with [ H6 : lc_tm (a_WPair _ _ _) |- _ ] => inversion H6 end. 206 | eexists. 207 | eapply S_LetPairBeta; eauto. 208 | - (* Proj1 *) 209 | left. 210 | destruct IHTyping as [[a' S]|V]; auto. 211 | + eexists. eauto. 212 | + move: (Canonical_SSigma H V) => [a0 [a1 EQ]]. subst. 213 | match goal with [ H6 : lc_tm (a_SPair _ _ _) |- _ ] => inversion H6 end. 214 | eexists. eauto. 215 | - (* Proj2 *) 216 | left. 217 | destruct IHTyping as [[a' S]|V]; auto. 218 | + eexists. eauto. 219 | + move: (Canonical_SSigma H V) => [a0 [a1 EQ]]. subst. 220 | match goal with [ H6 : lc_tm (a_SPair _ _ _) |- _ ] => inversion H6 end. 221 | eexists. eauto. 222 | - (* Case *) 223 | left. 224 | destruct IHTyping1 as [[a' S]|V]; auto. 225 | + eexists. eauto. 226 | + move: (Canonical_Sum H1 V) => [a0 [EQ1 | EQ2]]; 227 | subst. 228 | match goal with [ H6 : lc_tm (a_Inj1 _) |- _ ] => inversion H6 end. 229 | eexists. eauto. 230 | match goal with [ H6 : lc_tm (a_Inj2 _) |- _ ] => inversion H6 end. 231 | eexists. eauto. 232 | Qed. 233 | 234 | -------------------------------------------------------------------------------- /DDC/src/sort_sig.v: -------------------------------------------------------------------------------- 1 | Parameter sort : Set. 2 | Parameter axiom : sort -> sort -> Prop. 3 | Parameter rule_pi : sort -> sort -> sort -> Prop. 4 | Parameter rule_sig : sort -> sort -> sort -> Prop. 5 | 6 | Parameter star : sort. 7 | 8 | Definition size_sort (s:sort) := 1. 9 | 10 | Parameter sort_regularity : forall s1, exists s2, axiom s1 s2. 11 | -------------------------------------------------------------------------------- /DDC/src/spec.mng: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \usepackage{ottalt} 4 | \usepackage{mathpartir} 5 | \usepackage{supertabular} 6 | 7 | \usepackage{amsmath} 8 | \usepackage{amssymb} 9 | 10 | \usepackage{color} 11 | 12 | 13 | %% Show admissible premises in rules 14 | %% This should be false in main body of text and true in the appendix. 15 | \newif\ifadmissible 16 | \newcommand\suppress[1]{\ifadmissible{#1}\else{}\fi} 17 | \inputott{qualitative-rules} 18 | 19 | \title{System Specification} 20 | 21 | \admissiblefalse 22 | \begin{document} 23 | \maketitle 24 | 25 | This document is created directly from the definitions in the file 26 | {\texttt{Qualitative.ott}}, with minor modifications as listed below. 27 | 28 | This document is intended to specify, in a readable form, the subject of the 29 | proofs of the paper as well as explain the slight differences 30 | between this rendering, the paper, and the generated Coq files 31 | \texttt{Qualitative\_ott.v} and \texttt{Qualitative\_inf.v}. 32 | 33 | The reason for these slight differences is partly due to the restrictions of 34 | the Ott locally nameless backend and the LNgen theory generation tool. 35 | \begin{enumerate} 36 | \item All parts of the syntax must be defined concretely in the Ott source file. 37 | \item All bound variables need to be explicitly determined. 38 | \item All syntactic forms must bind at most one variable at a time. 39 | \end{enumerate} 40 | 41 | The first limitation is simply to accommodate through minor manual edits of 42 | the outputs of Ott and LNgen. These edits allow us, for example, to 43 | parameterize the development on an arbitrary semiring (see 44 | \texttt{grade\_sig.v}) instead of working with a specific, concrete semiring. 45 | 46 | The second limitation affects our generation of the typing rules for pattern 47 | matching elimination forms, i.e. \textsc{T-Case} and \textsc{T-LetPair} 48 | In these rules, we need to substitute in for the scrutinee 49 | $y$ the result type $B$. 50 | 51 | The third limitation causes difficulty for the formalization of the 52 | elimination rule for products. The usual pattern matching elimination 53 | syntactic form binds two variables, one for each component of the tuple. This 54 | is the form that is used in the submission. To accommodate Ott, in the 55 | mechanization we replace the pattern matching elimination form for $\Sigma$ 56 | types with a slightly more general, but less familiar, form. 57 | 58 | \section{System Specification} 59 | 60 | \subsection{Grammar} 61 | 62 | This language is parameterized over a lattics of grades, written $[[psi]]$, 63 | and a set of sorts, $[[s]]$, which at must be nonempty. 64 | 65 | \ottgrammartabular{ 66 | \otttm\ottinterrule 67 | \ottcontext\ottafterlastrule 68 | } 69 | 70 | \subsection{Operational semantics} 71 | 72 | \drules[ValueType]{}{Values that are types}{Type,Pi,WSigma,Sum,Unit} 73 | \drules[V]{}{Values}{ValueType,TmUnit,WPair,InjOne,InjTwo} 74 | 75 | \drules[S]{$[[|- a ~> a']]$}{Small-step operational semantics}{AppCong,Beta,CaseCong,CaseOneBeta,CaseTwoBeta, 76 | LetPairCong,LetPairBeta} 77 | 78 | \subsection{Definitional equality} 79 | 80 | \drules[CDefEq]{$[[P |- psi phi a == b]]$}{Conditional Definitional Equality}{Leq,Nleq} 81 | 82 | \drules[Eq]{$[[P |- psi a == b ]]$}{Definitional Equality}{Refl,Sym,Trans,SubstIrrel,Beta,Pi,Abs,App,PiFst,PiSnd, 83 | WSigma,WSigmaFst,WSigmaSnd,WPair,LetPair, 84 | Sum,SumFst,SumSnd,InjOne,InjTwo,Case,TyUnit,TmUnit} 85 | 86 | 87 | \drules[CG]{$[[P |- phi psi a]]$}{Conditional Grading}{Leq,Nleq} 88 | 89 | \drules[G]{$[[P |- phi a ]]$}{Grading}{Type,Var,Pi,Abs,App,WSigma,WPair,LetPair, 90 | Sum,InjOne,InjTwo,Case,TyUnit,TmUnit} 91 | 92 | \subsection{Type System} 93 | 94 | As in pure type systems, this type system is parameterized by a set of axioms 95 | ($[[axiom s1 s2]]$) and rules ($[[rule s1 s2 s3]]$) that govern the treatment 96 | of sorts. 97 | 98 | \drules[CT]{$[[W |--> psi a : A]]$}{Conditional Typing}{Leq,Top} 99 | 100 | \drules[T]{$[[W |-- psi a : A]]$}{Typing}{Type,Conv,Var,Pi,Abs,App,AppIrrel,WSigma,WPair,WPairIrrel,LetPairC, 101 | Sum,InjOne,InjTwo,CaseC,TmUnit,TyUnit} 102 | 103 | 104 | \subsection{Auxiliary Judgements} 105 | 106 | \drules[CEq]{$[[P |- psi psi0 a ~~ b]]$}{Conditional Graded Equality}{Leq,Nleq} 107 | \drules[GEq]{$[[P |- psi a ~~ b]]$}{Graded Syntactic Equality}{Type,Var,Pi,Abs,App,WSigma,WPair,LetPair,Sum,InjOne,InjTwo,Case,TyUnit,TmUnit} 108 | 109 | \drules[CPar]{$[[P |- psi psi0 a => b]]$}{Conditional Parallel Reduction}{Leq,Nleq} 110 | \drules[Par]{$[[P |- psi a => b ]]$}{Parallel reduction}{Refl,Pi,AppBeta,App,Abs,WSigma,WPair,WPairBeta,LetPair, 111 | Sum,InjOne,InjTwo,CaseBetaOne,CaseBetaTwo,Case} 112 | 113 | \drules[MP]{$[[P |- psi a =>* b ]]$}{Parallel reduction, reflexive transitive closure} 114 | {Refl,Step} 115 | \drules[]{$[[P |-psi a <=> b]]$}{Joinability} 116 | {join} 117 | 118 | 119 | \end{document} 120 | -------------------------------------------------------------------------------- /DDC/src/spec.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \usepackage{ottalt} 4 | \usepackage{mathpartir} 5 | \usepackage{supertabular} 6 | 7 | \usepackage{amsmath} 8 | \usepackage{amssymb} 9 | 10 | \usepackage{color} 11 | 12 | 13 | %% Show admissible premises in rules 14 | %% This should be false in main body of text and true in the appendix. 15 | \newif\ifadmissible 16 | \newcommand\suppress[1]{\ifadmissible{#1}\else{}\fi} 17 | \inputott{qualitative-rules} 18 | 19 | \title{System Specification} 20 | 21 | \admissiblefalse 22 | \begin{document} 23 | \maketitle 24 | 25 | This document is created directly from the definitions in the file 26 | {\texttt{Qualitative.ott}}, with minor modifications as listed below. 27 | 28 | This document is intended to specify, in a readable form, the subject of the 29 | proofs of the paper as well as explain the slight differences 30 | between this rendering, the paper, and the generated Coq files 31 | \texttt{Qualitative\_ott.v} and \texttt{Qualitative\_inf.v}. 32 | 33 | The reason for these slight differences is partly due to the restrictions of 34 | the Ott locally nameless backend and the LNgen theory generation tool. 35 | \begin{enumerate} 36 | \item All parts of the syntax must be defined concretely in the Ott source file. 37 | \item All bound variables need to be explicitly determined. 38 | \item All syntactic forms must bind at most one variable at a time. 39 | \end{enumerate} 40 | 41 | The first limitation is simply to accommodate through minor manual edits of 42 | the outputs of Ott and LNgen. These edits allow us, for example, to 43 | parameterize the development on an arbitrary semiring (see 44 | \texttt{grade\_sig.v}) instead of working with a specific, concrete semiring. 45 | 46 | The second limitation affects our generation of the typing rules for pattern 47 | matching elimination forms, i.e. \textsc{T-Case} and \textsc{T-LetPair} 48 | In these rules, we need to substitute in for the scrutinee 49 | $y$ the result type $B$. 50 | 51 | The third limitation causes difficulty for the formalization of the 52 | elimination rule for products. The usual pattern matching elimination 53 | syntactic form binds two variables, one for each component of the tuple. This 54 | is the form that is used in the submission. To accommodate Ott, in the 55 | mechanization we replace the pattern matching elimination form for $\Sigma$ 56 | types with a slightly more general, but less familiar, form. 57 | 58 | \section{System Specification} 59 | 60 | \subsection{Grammar} 61 | 62 | This language is parameterized over a lattics of grades, written $\ell$, 63 | and a set of sorts, $\ottnt{s}$, which at must be nonempty. 64 | 65 | \ottgrammartabular{ 66 | \otttm\ottinterrule 67 | \ottcontext\ottafterlastrule 68 | } 69 | 70 | \subsection{Operational semantics} 71 | 72 | \drules[ValueType]{}{Values that are types}{Type,Pi,WSigma,Sum,Unit} 73 | \drules[V]{}{Values}{ValueType,TmUnit,WPair,InjOne,InjTwo} 74 | 75 | \drules[S]{$ \ottnt{a} \leadsto \ottnt{a'} $}{Small-step operational semantics}{AppCong,Beta,CaseCong,CaseOneBeta,CaseTwoBeta, 76 | LetPairCong,LetPairBeta} 77 | 78 | \subsection{Definitional equality} 79 | 80 | \drules[CDefEq]{$ \Phi \vdash \ottnt{a} \equiv_{ \ell } \ottnt{b} $}{Conditional Definitional Equality}{Leq,Nleq} 81 | 82 | \drules[Eq]{$ \Phi \vdash \ottnt{a} \equiv_{ \ell } \ottnt{b} $}{Definitional Equality}{Refl,Sym,Trans,SubstIrrel,Beta,Pi,Abs,App,PiFst,PiSnd, 83 | WSigma,WSigmaFst,WSigmaSnd,WPair,LetPair, 84 | Sum,SumFst,SumSnd,InjOne,InjTwo,Case,TyUnit,TmUnit} 85 | 86 | 87 | \drules[CG]{$ \Phi \vdash_{ k }^{ \ell } \ottnt{a} $}{Conditional Grading}{Leq,Nleq} 88 | 89 | \drules[G]{$ \Phi \vdash_{ k } \ottnt{a} $}{Grading}{Type,Var,Pi,Abs,App,WSigma,WPair,LetPair, 90 | Sum,InjOne,InjTwo,Case,TyUnit,TmUnit} 91 | 92 | \subsection{Type System} 93 | 94 | As in pure type systems, this type system is parameterized by a set of axioms 95 | ($\ottkw{axiom} \, \ottnt{s_{{\mathrm{1}}}} \, \ottnt{s_{{\mathrm{2}}}}$) and rules ($\ottkw{rule} \, \ottnt{s_{{\mathrm{1}}}} \, \ottnt{s_{{\mathrm{2}}}} \, \ottnt{s_{{\mathrm{3}}}}$) that govern the treatment 96 | of sorts. 97 | 98 | \drules[CT]{$ \Omega \Vdash \ottnt{a} :^{ \ell } \ottnt{A} $}{Conditional Typing}{Leq,Top} 99 | 100 | \drules[T]{$ \Omega \vdash \ottnt{a} :^{ \ell } \ottnt{A} $}{Typing}{Type,Conv,Var,Pi,Abs,App,AppIrrel,WSigma,WPair,WPairIrrel,LetPairC, 101 | Sum,InjOne,InjTwo,CaseC,TmUnit,TyUnit} 102 | 103 | 104 | \subsection{Auxiliary Judgements} 105 | 106 | \drules[CEq]{$ \Phi \vdash^{ \ell_{{\mathrm{0}}} }_{ \ell } \ottnt{a} \sim \ottnt{b} $}{Conditional Graded Equality}{Leq,Nleq} 107 | \drules[GEq]{$ \Phi \vdash \ottnt{a} \sim_{ \ell } \ottnt{b} $}{Graded Syntactic Equality}{Type,Var,Pi,Abs,App,WSigma,WPair,LetPair,Sum,InjOne,InjTwo,Case,TyUnit,TmUnit} 108 | 109 | \drules[CPar]{$ \Phi \vdash^{ \ell_{{\mathrm{0}}} }_{ \ell } \ottnt{a} \Rightarrow \ottnt{b} $}{Conditional Parallel Reduction}{Leq,Nleq} 110 | \drules[Par]{$ \Phi \vdash \ottnt{a} \Rightarrow_{ \ell } \ottnt{b} $}{Parallel reduction}{Refl,Pi,AppBeta,App,Abs,WSigma,WPair,WPairBeta,LetPair, 111 | Sum,InjOne,InjTwo,CaseBetaOne,CaseBetaTwo,Case} 112 | 113 | \drules[MP]{$ \Phi \vdash \ottnt{a} \Rightarrow^{\ast} _{ \ell } \ottnt{b} $}{Parallel reduction, reflexive transitive closure} 114 | {Refl,Step} 115 | \drules[]{$ \Phi \vdash \ottnt{a} \Leftrightarrow _{ \ell } \ottnt{b} $}{Joinability} 116 | {join} 117 | 118 | 119 | \end{document} 120 | -------------------------------------------------------------------------------- /DDC/src/typing.patch: -------------------------------------------------------------------------------- 1 | 661,670c661,665 2 | < | T_LetPair : forall (L:vars) (W:context) (psi psi0:grade) (a c C B A:tm) (s:sort), 3 | < ( forall x , x \notin L -> 4 | < Typing ((x ~ (q_C, a_WSigma psi0 A B)) ++ meet_ctx_l q_C W) q_C (open_tm_wrt_tm C (a_Var_f x)) (a_Type s)) -> 5 | < Typing W psi a (a_WSigma psi0 A B) -> 6 | < ( forall x , x \notin L -> 7 | < forall y, y \notin L \u {{x}} -> 8 | < Typing ((x ~ ((q_join psi0 psi), A)) ++ W) psi (open_tm_wrt_tm c (a_Var_f x)) 9 | < (a_Pi q_Bot (open_tm_wrt_tm B (a_Var_f x)) 10 | < (close_tm_wrt_tm y (open_tm_wrt_tm C (a_WPair (a_Var_f x) psi0 (a_Var_f y)))))) -> 11 | < (Typing W psi (a_LetPair psi0 a c) (open_tm_wrt_tm C a)) 12 | --- 13 | > | T_LetPair : forall (L:vars) (W:context) (psi psi0:grade) (a c C B:tm) (s:sort) (A:tm) (phi:grade), 14 | > ( forall x , x \notin L -> Typing (meet_ctx_l q_C W ) q_C ( (a_Pi psi ( open_tm_wrt_tm B (a_Var_f x) ) C) ) (a_Type s) ) -> 15 | > Typing W psi a ( (a_WSigma psi0 A B) ) -> 16 | > ( forall x , x \notin L -> Typing ( ( x ~( (q_join psi0 psi ) , A )) ++ W ) psi ( open_tm_wrt_tm c (a_Var_f x) ) ( (a_Pi phi ( open_tm_wrt_tm B (a_Var_f x) ) C) ) ) -> 17 | > ( forall y , y \notin L -> Typing W psi (a_LetPair psi0 a c) ( open_tm_wrt_tm C (a_Var_f y) ) ) 18 | 702,703c697,698 19 | < | T_Case : forall (L:vars) (W:context) (psi psi0:grade) (a b1 b2 B:tm) (A1 A2 B1 B2:tm) s, 20 | < ( forall z, z \notin L -> Typing ( ( ( z ~( q_C , (a_Sum A1 A2) )) ++ ( (meet_ctx_l q_C W ) ) ) ) q_C (open_tm_wrt_tm B (a_Var_f z)) (a_Type s)) -> 21 | --- 22 | > | T_Case : forall (L:vars) (W:context) (psi psi0:grade) (a b1 b2 B:tm) (z:tmvar) (A1 A2:tm) (s:sort) (B1 B2:tm), 23 | > Typing ( ( ( z ~( q_C , (a_Sum A1 A2) )) ++ ( (meet_ctx_l q_C W ) ) ) ) q_C B (a_Type s) -> 24 | -------------------------------------------------------------------------------- /DDC/src/typing_ctx_fv.v: -------------------------------------------------------------------------------- 1 | Require Export Qual.grade. 2 | Require Export Qual.defeq. 3 | Require Export Qual.labels. 4 | 5 | Set Implicit Arguments. 6 | Open Scope grade_scope. 7 | 8 | 9 | Definition Ctx_Prop (W:context) := (forall x psi A, binds x (psi, A) W -> fv_tm_tm A [<=] dom W). 10 | 11 | Lemma Ctx_Prop_meet_ctx_l : forall W, Ctx_Prop W -> Ctx_Prop (meet_ctx_l q_C W). 12 | Proof. intros W. unfold Ctx_Prop. intros. 13 | unfold meet_ctx_l in H0. 14 | apply binds_map_3 in H0. destruct H0 as [[g B] hh]. split_hyp. 15 | rewrite -> dom_meet_ctx_l in *. invert_equality. eapply H. eauto. 16 | Qed. 17 | 18 | Lemma Ctx_Prop_cons : forall x q A W, fv_tm_tm A [<=] dom W -> Ctx_Prop W -> Ctx_Prop ([(x, (q, A))] ++ W). 19 | Proof. 20 | intros. 21 | unfold Ctx_Prop in *. 22 | intros. 23 | eapply binds_cons_1 in H1. destruct H1. split_hyp. invert_equality. 24 | simpl. rewrite H. fsetdec. 25 | simpl. rewrite H0; eauto. fsetdec. 26 | Qed. 27 | 28 | 29 | Lemma Typing_ctx_fv_helper : forall W psi a A, Typing W psi a A -> Ctx_Prop W -> fv_tm_tm a [<=] dom W /\ fv_tm_tm A [<=] dom W. 30 | Proof. 31 | intros W psi a A H CTX. induction H. 32 | all: split; simpl. 33 | all: simpl in *. 34 | all: try rewrite -> dom_meet_ctx_l in *. 35 | 36 | all: repeat match goal with [ H : Ctx_Prop _ -> _ |- _ ] => specialize (H ltac:(eauto using Ctx_Prop_meet_ctx_l)) end. 37 | all: split_hyp. 38 | all: try (move: (binds_In _ _ _ _ H1) => h; fsetdec). 39 | all: try solve [ unfold Ctx_Prop in CTX; eauto ]. 40 | 41 | 42 | all: try rewrite -> dom_meet_ctx_l in H1. 43 | all: try rewrite -> dom_meet_ctx_l in H2. 44 | all: try rewrite -> dom_meet_ctx_l in H3. 45 | all: try rewrite -> dom_meet_ctx_l in H4. 46 | all: try rewrite -> dom_meet_ctx_l in H5. 47 | all: try rewrite -> dom_meet_ctx_l in H6. 48 | all: try rewrite -> dom_meet_ctx_l in H7. 49 | 50 | all: try fsetdec. 51 | 52 | all: try solve [simpl in *; 53 | rewrite fv_tm_tm_open_tm_wrt_tm_upper; 54 | fsetdec]. 55 | 56 | all: try solve [simpl in *; 57 | try rewrite <- fv_tm_tm_open_tm_wrt_tm_lower in *; 58 | fsetdec]. 59 | 60 | all: pick fresh z. 61 | all: repeat spec z. 62 | all: pick fresh w. 63 | all: repeat spec w. 64 | all: move: (Ctx_Prop_meet_ctx_l CTX) => MCTX. 65 | all: try match goal with [H : Ctx_Prop ?C -> fv_tm_tm (open_tm_wrt_tm _ _) [<=] _ /\ _ |- _ ] => 66 | rewrite <- fv_tm_tm_open_tm_wrt_tm_lower in H end. 67 | all: have lemma: forall x A B, A [<=] add x B -> x `notin` A -> A [<=] B by clear; intros; fsetdec. 68 | 69 | - match goal with [ H4 : Ctx_Prop _ -> _ |- _ ] => specialize (H4 ltac:(eapply Ctx_Prop_cons; auto; try fsetdec)) end. 70 | split_hyp. 71 | move: (lemma z _ _ H0 ltac:(fsetdec)) => h. 72 | eapply AtomSetProperties.union_subset_3; auto. 73 | 74 | - match goal with [ H4 : Ctx_Prop _ -> _ |- _ ] => specialize (H4 ltac:(eapply Ctx_Prop_cons; auto; try fsetdec)) end. 75 | split_hyp. 76 | move: (lemma z _ _ H ltac:(fsetdec)) => h. 77 | eapply AtomSetProperties.union_subset_3; auto. 78 | fsetdec. 79 | 80 | - match goal with [ H4 : Ctx_Prop _ -> _ |- _ ] => specialize (H4 ltac:(eapply Ctx_Prop_cons; auto; try fsetdec)) end. 81 | split_hyp. 82 | move: (lemma z _ _ H0 ltac:(fsetdec)) => h. 83 | eapply AtomSetProperties.union_subset_3; auto. 84 | 85 | - specialize (H3 ltac:(eapply Ctx_Prop_cons; auto; try fsetdec)). 86 | split_hyp. 87 | move: (lemma z _ _ H3 ltac:(fsetdec)) => h. 88 | eapply AtomSetProperties.union_subset_3; auto. 89 | 90 | - destruct H2. 91 | eapply Ctx_Prop_cons; auto. simpl. rewrite dom_meet_ctx_l. auto. 92 | rewrite fv_tm_tm_open_tm_wrt_tm_upper. 93 | rewrite <- fv_tm_tm_open_tm_wrt_tm_lower in H2. 94 | rewrite dom_meet_ctx_l in H2. 95 | have FC: z `notin` fv_tm_tm C. clear Fr0. auto. 96 | move: (lemma z _ _ H2 FC) => h. 97 | clear Fr Fr0. fsetdec. 98 | 99 | - destruct H5. 100 | eapply Ctx_Prop_cons; auto. simpl. 101 | move: (lemma z _ _ H0 ltac:(fsetdec)) => h. 102 | eapply AtomSetProperties.union_subset_3; auto. 103 | 104 | - destruct H2. 105 | clear Fr0. 106 | eapply Ctx_Prop_cons; auto. simpl. rewrite dom_meet_ctx_l. auto. 107 | rewrite -> dom_meet_ctx_l in H. 108 | rewrite fv_tm_tm_open_tm_wrt_tm_upper. 109 | have FC: z `notin` fv_tm_tm B. clear Fr0. auto. 110 | move: (lemma z _ _ H FC) => h. 111 | eapply AtomSetProperties.union_subset_3; auto. 112 | 113 | Qed. 114 | 115 | Lemma Typing_ctx_fv_Ctx : forall W, Ctx W -> Ctx_Prop W. 116 | induction 1. unfold Ctx_Prop. intros. inversion H. 117 | eapply Ctx_Prop_cons. 118 | move: (Typing_ctx_fv_helper H0 (Ctx_Prop_meet_ctx_l IHCtx)) => ih. 119 | split_hyp. 120 | rewrite dom_meet_ctx_l in H2. auto. auto. 121 | Qed. 122 | 123 | Lemma Typing_ctx_fv : forall W psi a A, Typing W psi a A -> Ctx W -> fv_tm_tm a [<=] dom W /\ fv_tm_tm A [<=] dom W. 124 | Proof. 125 | intros. 126 | eapply Typing_ctx_fv_helper; eauto. 127 | eapply Typing_ctx_fv_Ctx; eauto. 128 | Qed. 129 | -------------------------------------------------------------------------------- /DDC/src/uniq.v: -------------------------------------------------------------------------------- 1 | Require Export Qual.metalib. 2 | Require Export Qual.tactics. 3 | Require Export Qual.labels. 4 | 5 | Set Implicit Arguments. 6 | Open Scope grade_scope. 7 | 8 | Lemma P_sub_uniq1 : forall P P', P_sub P P' -> uniq P. 9 | Proof. intros. induction H; eauto. Qed. 10 | 11 | Lemma P_sub_uniq2 : forall P P', P_sub P P' -> uniq P'. 12 | Proof. intros. induction H; eauto. Qed. 13 | 14 | Lemma ctx_sub_uniq : forall (W1 W2 : context), ctx_sub W2 W1 -> uniq W1 -> uniq W2. 15 | Proof. 16 | induction 1; intros; eauto. 17 | destruct_uniq. 18 | specialize (IHctx_sub ltac:(auto)). 19 | solve_uniq. 20 | Qed. 21 | 22 | Arguments ctx_sub_uniq {_} {_}. 23 | 24 | 25 | Lemma Grade_uniq : forall P psi a, Grade P psi a -> uniq P. 26 | Proof. intros; induction H; eauto. 27 | pick fresh x; repeat spec x. 28 | match goal with [ H2 : uniq ([_] ++ _) |- _ ] => inversion H2; auto end. 29 | Qed. 30 | 31 | Lemma CEq_GEq_uniq : 32 | (forall P phi phi0 a b, 33 | CEq P phi phi0 a b -> uniq P) /\ 34 | (forall P phi a b, 35 | GEq P phi a b -> uniq P). 36 | Proof. 37 | eapply CEq_GEq_mutual. 38 | all: intros; eauto. 39 | all: try (pick fresh x; spec x; solve_uniq). 40 | (* eauto using Grade_uniq. *) 41 | Qed. 42 | 43 | Lemma CEq_uniq : forall P phi phi0 a b, 44 | CEq P phi phi0 a b -> uniq P. 45 | Proof. eapply CEq_GEq_uniq. Qed. 46 | Lemma GEq_uniq : 47 | (forall P phi a b, 48 | GEq P phi a b -> uniq P). 49 | Proof. eapply CEq_GEq_uniq. Qed. 50 | 51 | Lemma DefEq_uniq : (forall P phi a b, 52 | DefEq P phi a b -> uniq P). 53 | Proof. 54 | induction 1. 55 | all: intros; eauto 3 using Grade_uniq. 56 | all: try pick fresh x; spec x; solve_uniq. 57 | Qed. 58 | 59 | Lemma Par_uniq : forall P psi a b, Par P psi a b -> uniq P. 60 | Proof. intros. induction H; eauto. eapply Grade_uniq; eauto. 61 | pick fresh x; spec x; solve_uniq. Qed. 62 | 63 | Lemma MultiPar_uniq : forall P psi a b, MultiPar P psi a b -> uniq P. 64 | Proof. induction 1; eauto using Grade_uniq. Qed. 65 | 66 | Lemma Typing_uniq : forall W psi a A, Typing W psi a A -> uniq W. 67 | Proof. induction 1; unfold join_ctx_l in *; eauto using uniq_map_1. Qed. 68 | -------------------------------------------------------------------------------- /DDC/src/weakening.v: -------------------------------------------------------------------------------- 1 | Require Export Qual.metalib. 2 | Require Export Qual.tactics. 3 | Require Export Qual.labels. 4 | 5 | Set Implicit Arguments. 6 | Open Scope grade_scope. 7 | 8 | (* Helps with specializing the IH for weakening proofs. *) 9 | Local Ltac weakening_ih := 10 | match goal with 11 | | [ H3 : forall P5 P4, [(?x, ?psi0)] ++ ?P2 ++ ?P1 = P4 ++ P5 -> _ |- _ ] 12 | => specialize (H3 P1 (x ~ psi0 ++ P2) ltac:(eauto) ltac:(simpl_env;auto)); simpl_env in H3 13 | end. 14 | 15 | Lemma CGrade_Grade_weakening_middle : (forall P psi psi0 b, 16 | CGrade P psi psi0 b -> forall P1 P2, P = P2 ++ P1 -> forall P3, 17 | uniq (P2 ++ P3 ++ P1) 18 | -> CGrade (P2 ++ P3 ++ P1) psi psi0 b) /\ (forall P psi b, 19 | Grade P psi b -> forall P1 P2, P = P2 ++ P1 -> forall P3, 20 | uniq (P2 ++ P3 ++ P1) 21 | -> Grade (P2 ++ P3 ++ P1) psi b). 22 | Proof. 23 | eapply CGrade_Grade_mutual. 24 | all: intros; eauto. 25 | all: try solve [subst; eapply G_Var; eauto]. 26 | 27 | all: try solve 28 | [subst; fresh_apply_Grade x; eauto; 29 | repeat spec x; 30 | weakening_ih; 31 | eauto]. 32 | Qed. 33 | 34 | Lemma Grade_weakening_middle : forall P1 P2 P3 psi b, 35 | Grade (P2 ++ P1) psi b -> uniq (P2 ++ P3 ++ P1) 36 | -> Grade (P2 ++ P3 ++ P1) psi b. 37 | Proof. 38 | intros. eapply CGrade_Grade_weakening_middle; eauto. Qed. 39 | 40 | Lemma Grade_weakening : forall P2 P1 psi b, 41 | Grade P1 psi b 42 | -> uniq (P2 ++ P1) 43 | -> Grade (P2 ++ P1) psi b. 44 | Proof. 45 | intros. 46 | eapply CGrade_Grade_weakening_middle with (P2 := nil); simpl_env; eauto. 47 | Qed. 48 | 49 | Ltac geq_weakening_ih := 50 | match goal with 51 | | [ H3 : forall P3 P4, [(?x, ?psi0)] ++ ?P2 ++ ?P1 = P4 ++ P3 -> _ |- _ ] 52 | => specialize (H3 P1 ([(x,psi0)] ++ P2) ltac:(eauto) _ ltac:(simpl_env;eauto)); simpl_env in H3 53 | end. 54 | 55 | Lemma CEq_GEq_weakening : 56 | (forall P phi phi0 a b, 57 | CEq P phi phi0 a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> CEq (P2 ++ P3 ++ P1) phi phi0 a b) /\ 58 | (forall P phi a b, 59 | GEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> GEq (P2 ++ P3 ++ P1) phi a b). 60 | Proof. 61 | eapply CEq_GEq_mutual. 62 | all: intros; eauto. 63 | all: try solve [subst; eapply GEq_Var; eauto]. 64 | all: try solve [subst; 65 | fresh_apply_GEq x; eauto; 66 | repeat spec x; 67 | geq_weakening_ih; 68 | eauto]. 69 | Qed. 70 | 71 | Lemma GEq_weakening_middle : (forall P phi a b, 72 | GEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> GEq (P2 ++ P3 ++ P1) phi a b). 73 | Proof. 74 | destruct CEq_GEq_weakening. 75 | auto. 76 | Qed. 77 | 78 | 79 | Lemma GEq_weakening : forall P phi b1 b2, 80 | GEq P phi b1 b2 -> forall P2, uniq (P2 ++ P) -> GEq (P2 ++ P) phi b1 b2. 81 | Proof. 82 | destruct CEq_GEq_weakening. 83 | intros. 84 | eapply H0 with (P2 := nil); eauto. 85 | Qed. 86 | 87 | Lemma CDefEq_DefEq_weakening_middle : 88 | (forall P phi psi a b, 89 | CDefEq P phi psi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> CDefEq (P2 ++ P3 ++ P1) phi psi a b) /\ 90 | (forall P phi a b, 91 | DefEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> DefEq (P2 ++ P3 ++ P1) phi a b). 92 | Proof. 93 | apply CDefEq_DefEq_mutual. 94 | all: intros; subst; eauto 3 using Grade_weakening_middle. 95 | all: try solve [subst; 96 | fresh_apply_DefEq x; auto; 97 | repeat spec x; 98 | geq_weakening_ih; 99 | eauto]. 100 | all: try solve [ 101 | pick fresh x and apply Eq_SubstIrrel; eauto 2; 102 | repeat spec x; 103 | geq_weakening_ih; 104 | eauto]. 105 | 106 | all: eauto 4 using Grade_weakening_middle. 107 | all: try (eapply Eq_Case; eauto 3 using Grade_weakening_middle). 108 | Qed. 109 | 110 | Lemma DefEq_weakening_middle : 111 | (forall P phi a b, 112 | DefEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> DefEq (P2 ++ P3 ++ P1) phi a b). 113 | Proof. 114 | intros. 115 | eapply CDefEq_DefEq_weakening_middle; eauto. 116 | Qed. 117 | 118 | Lemma DefEq_weakening : forall P phi b1 b2, 119 | DefEq P phi b1 b2 -> forall P2, uniq (P2 ++ P) -> DefEq (P2 ++ P) phi b1 b2. 120 | Proof. 121 | intros. 122 | eapply CDefEq_DefEq_weakening_middle with (P2 := nil); eauto. 123 | Qed. 124 | 125 | Lemma CPar_Par_weakening_middle : 126 | (forall G0 psi psi0 a b, CPar G0 psi psi0 a b -> 127 | forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) -> CPar (F ++ E ++ G) psi psi0 a b) /\ 128 | (forall G0 psi a b, Par G0 psi a b -> 129 | forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) -> Par (F ++ E ++ G) psi a b). 130 | Proof. 131 | apply CPar_Par_mutual. 132 | all: intros; subst; eauto 3 using Grade_weakening_middle. 133 | all: try solve [ 134 | subst; fresh_apply_Par x; auto; repeat spec x; 135 | match goal with 136 | | [ H3 : forall E F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G = F0 ++ G0 -> _ |- _ ] 137 | => specialize (H3 E ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto) ltac:(simpl_env;eauto)) ; 138 | simpl_env in H3 end; eauto]. 139 | 140 | all: eauto 5 using Grade_weakening_middle. 141 | Qed. 142 | 143 | Lemma Par_weakening_middle : 144 | forall G0 a psi b, Par G0 psi a b -> 145 | forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) -> Par (F ++ E ++ G) psi a b. 146 | Proof. 147 | intros. eapply CPar_Par_weakening_middle; eauto. 148 | Qed. 149 | 150 | 151 | Lemma Par_weakening : 152 | forall G a psi b, Par G psi a b -> 153 | forall E, uniq (E ++ G) -> Par (E ++ G) psi a b. 154 | Proof. 155 | intros. eapply Par_weakening_middle with (F := nil); eauto. 156 | Qed. 157 | 158 | 159 | Lemma Typing_weakening_middle : forall W2 W1 q b B, 160 | Typing (W2 ++ W1) q b B -> 161 | forall W, uniq (W2 ++ W ++ W1) -> 162 | Typing (W2 ++ W ++ W1) q b B. 163 | Proof. 164 | intros W2 W1 q b B h. dependent induction h. 165 | all: intros; subst; eauto 3 using DefEq_weakening_middle. 166 | all: have UL1: uniq (meet_ctx_l q_C W2 ++ meet_ctx_l q_C W ++ meet_ctx_l q_C W1) by 167 | unfold meet_ctx_l; solve_uniq. 168 | all: have UL2: uniq (labels (meet_ctx_l q_C W2) ++ labels (meet_ctx_l q_C W) ++ labels (meet_ctx_l q_C W1)) by 169 | unfold labels; solve_uniq. 170 | (* easy cases *) 171 | all: try solve [eapply T_App; eauto]. 172 | all: try solve [ 173 | eapply T_AppIrrel; simpl_env; eauto; 174 | eapply IHh2; simpl_env; eauto]. 175 | all: try solve [ 176 | eapply T_WPair; simpl_env; eauto; 177 | eapply IHh1; simpl_env; eauto]. 178 | all: try solve [ 179 | eapply T_WPairIrrel; simpl_env; eauto; 180 | try eapply IHh1; simpl_env; eauto; 181 | try eapply IHh2; simpl_env; eauto]. 182 | all: try solve [ 183 | eapply T_SPair; simpl_env; eauto; 184 | try eapply IHh1; simpl_env; eauto; 185 | try eapply IHh2; simpl_env; eauto]. 186 | all: try solve [ 187 | apply T_Sum; simpl_env; eauto; 188 | try eapply IHh1; simpl_env; eauto; 189 | try eapply IHh2; simpl_env; eauto]. 190 | all: try solve [ 191 | eapply T_Inj1; simpl_env; eauto; 192 | eapply IHh2; simpl_env; eauto]. 193 | all: try solve [ 194 | eapply T_Inj2; simpl_env; eauto; 195 | eapply IHh2; simpl_env; eauto]. 196 | all: try solve [eapply T_Eq; simpl_env; eauto]. 197 | 198 | (* conversion *) 199 | all: try match goal with [ H : DefEq _ _ _ _ |- _ ] => 200 | eapply T_Conv; eauto 3; 201 | simpl_env in *; 202 | try eapply DefEq_weakening_middle; eauto end. 203 | 204 | (* pi *) 205 | subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x; 206 | match goal with 207 | | [ H2 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ] 208 | => specialize (H2 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3)); 209 | simpl_env in H2; eauto 3; try eapply H2; try solve_uniq end. 210 | 211 | (* abs *) 212 | subst; fresh_apply_Typing x; simpl_env; try eapply IHh; simpl_env; eauto; repeat spec x; 213 | try match goal with 214 | | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ] 215 | => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3) W) ; 216 | simpl_env in H3 ; eauto 3; try eapply H3 end. 217 | 218 | (* wsigma *) 219 | subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x; 220 | match goal with 221 | | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ] 222 | => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3)) ; 223 | simpl_env in H3; eauto 3; try eapply H3; try solve_uniq end. 224 | 225 | (* letpair *) 226 | - subst; fresh_apply_Typing x. 227 | + clear H H1 H2 IHh. 228 | repeat spec x. simpl_env. 229 | match goal with 230 | | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ meet_ctx_l q_C (?F ++ ?G) ~= F0 ++ G0 -> _ |- _ ] 231 | => specialize (H3 ([(x,psi0)] ++ meet_ctx_l q_C F) (meet_ctx_l q_C G) ltac:(simpl_env;eauto 3) (meet_ctx_l q_C W)); 232 | simpl_env in H3; eapply H3 end. 233 | eapply uniq_cons_3; auto. repeat rewrite dom_app. repeat rewrite dom_meet_ctx_l. auto. 234 | + eapply IHh; auto. 235 | + move => y Fry. 236 | clear H H0 H1 IHh. 237 | spec x. spec y. 238 | specialize (H0 ([(x, (psi0 * psi,A))] ++ W2) W1 ltac:(simpl_env; auto) W). 239 | simpl_env in H0. eapply H0. solve_uniq. 240 | 241 | (* ssigma *) 242 | - subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x; 243 | match goal with 244 | | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ] 245 | => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3)) ; 246 | simpl_env in H3; eauto 3; try eapply H3; try solve_uniq end. 247 | - (* case *) 248 | fresh_apply_Typing x; auto. 249 | repeat spec x. 250 | simpl_env. 251 | match goal with 252 | | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ meet_ctx_l q_C (?F ++ ?G) ~= F0 ++ G0 -> _ |- _ ] 253 | => specialize (H3 ([(x,psi0)] ++ meet_ctx_l q_C F) (meet_ctx_l q_C G) ltac:(simpl_env;eauto 3) 254 | (meet_ctx_l q_C W)); 255 | simpl_env in H3 ; eapply H3 end. 256 | eapply uniq_cons_3; auto. repeat rewrite dom_app. repeat rewrite dom_meet_ctx_l. auto. 257 | Qed. 258 | 259 | Lemma Typing_weakening : forall W1 q b B, 260 | Typing W1 q b B -> 261 | forall W2, uniq (W2 ++ W1) -> 262 | Typing (W2 ++ W1) q b B. 263 | Proof. 264 | intros. 265 | eapply Typing_weakening_middle with (W2 := nil); simpl_env; eauto. 266 | Qed. 267 | 268 | -------------------------------------------------------------------------------- /GraD/ARTIFACT.md: -------------------------------------------------------------------------------- 1 | Artifact submission for POPL2021 paper 408 2 | ========================================== 3 | 4 | This repository includes Coq proofs for the results claimed in Section 6.2 5 | (Metatheory) of [this 6 | paper](https://github.com/sweirich/graded-haskell/blob/main/submitted-version.pdf), 7 | conditionally accepted to POPL 2021. 8 | 9 | Download, installation, and sanity-testing instructions 10 | --------------------------------------------------------- 11 | 12 | The artifact is available as a [VirtualBox](https://www.virtualbox.org/) available for download from 13 | 14 | http://www.seas.upenn.edu/~sweirich/popl21-paper408.ova 15 | 16 | After starting VirtualBox, the machine can be loaded via 17 | 18 | File > Import Appliance... 19 | 20 | The source code for the artifact is available from the public github repository: 21 | https://github.com/sweirich/graded-haskell 22 | 23 | Complete claims made by the paper substantiated by this artifact 24 | ---------------------------------------------------------------- 25 | 26 | This artifact substantiates the results claimed in Section 6.2 (Metatheory). 27 | No other results of the paper have been mechanically checked. 28 | 29 | For convenience, the [submitted version of the paper](https://github.com/sweirich/graded-haskell/blob/main/submitted-version.pdf) is available from the github repository. 30 | 31 | * Key results 32 | 33 | The individual results of this Section can be found in the corresponding Coq 34 | files and theorem statements. (All Coq files are in the `src` subdirectory.) 35 | 36 | Lemma 6.1 (Regularity) dqtt.v: Typing_regularity 37 | Lemma 6.2 (Substitution) structural.v: substitution 38 | Lemma 6.3 (Weakening) structural.v: weakening 39 | Theorem 6.4 (Preservation) dqtt.v: preservation 40 | Theorem 6.5 (Progress) dqtt.v: progress 41 | 42 | * System specification 43 | 44 | The full specification of the type system shown in Section 6.1 is in the file 45 | `dqtt_ott.v`. This file has been mechanically generated from the Ott 46 | specification `dqtt.ott`, but then slightly edited. For convenience, we also 47 | provide the file `spec.pdf` that contains a typeset version of the system, 48 | also generated from `dqtt.ott`. 49 | 50 | * Assumptions made in Coq development 51 | 52 | The axioms that our development relies on are in the files `usage_sig.v` 53 | and `beta.v`. The first file is an axiomatization of the partially-ordered 54 | semi-ring structure, as described in Section 2.1 of the paper. The second file 55 | describes the axiomatization of beta-equivalence as specified in Definition 56 | 7.1. 57 | 58 | Evaluation instructions 59 | ----------------------- 60 | 61 | To evaluate these claims, reviewers should import the provided virtual box 62 | file. Once the machine has been booted, a Terminal can be started 63 | using the icon at the top-left of the screen. 64 | 65 | Then, to compile the development, perform the following commands in a terminal window. 66 | 67 | cd ~ 68 | cd graded-haskell/src 69 | make clean 70 | make coq 71 | 72 | NOTE: to access the latest version of the artifact, reviewers may wish to do a `git pull` 73 | in the `graded-haskell` directory. 74 | 75 | NOTE: On 2019 MacBook Pro, the entire development takes < 4 minutes to 76 | compile. The file `dqtt_inf.v` (generated from LNgen) is the largest component 77 | of that time. 78 | 79 | Note: reviwers can use the following credentials for administrator access on 80 | the virtual machine. 81 | 82 | username: sweirich 83 | password: popl2021 84 | 85 | 86 | Additional artifact description 87 | ------------------------------- 88 | 89 | See the [README.md](https://github.com/sweirich/graded-haskell) for the artifact site. 90 | -------------------------------------------------------------------------------- /GraD/README.md: -------------------------------------------------------------------------------- 1 | A Graded Dependent Type System 2 | ============================== 3 | 4 | "A graded dependent type system with a usage-aware semantics", by 5 | Pritam Choudhury, Harley Eades III, Richard A. Eisenberg and Stephanie Weirich will appear in POPL 2021 and a preprint is available [here](https://github.com/sweirich/graded-haskell/blob/main/popl21-choudhury.pdf). 6 | 7 | The extended version of the paper is available from [arXiv](https://arxiv.org/abs/2011.04070). 8 | 9 | * Key results 10 | 11 | This repository includes Coq proofs for the results claimed in Section 7.2 of the 12 | paper. 13 | 14 | The individual results can be found in the corresponding Coq files and theorem 15 | statements. (All Coq files are in the `src` subdirectory.) 16 | 17 | Lemma 7.1 (Regularity) dqtt.v: Typing_regularity 18 | Lemma 7.2 (Substitution) structural.v: substitution 19 | Lemma 7.3 (Weakening) structural.v: weakening 20 | Theorem 7.4 (Preservation) dqtt.v: preservation 21 | Theorem 7.5 (Progress) dqtt.v: progress 22 | 23 | * System specification 24 | 25 | The full specification of the type system shown in Section 7.1 is in the file 26 | `dqtt_ott.v`. This file has been mechanically generated from the Ott 27 | specification `dqtt.ott`, but then slightly edited. For convenience, we also 28 | provide the file 29 | [spec.pdf](https://github.com/sweirich/graded-haskell/blob/main/spec.pdf) that 30 | contains a typeset version of the system, also generated from `dqtt.ott`. 31 | 32 | * Assumptions 33 | 34 | The axioms that our development relies on are in the files `usage_sig.v` 35 | and `beta.v`. The first file is an axiomatization of the partially-ordered 36 | semi-ring structure, as described in Section 2.1 of the paper. The second file 37 | describes the axiomatization of beta-equivalence as specified in Definition 38 | 9.1. 39 | 40 | * Version with definitions 41 | 42 | The directory `src-def` extends the system with definitions in the context as described in Section 8.1 of the paper and reproves Lemmas 7.1--7.5. It does not include any of the new results of that section (Lemmas 8.1--8.4). 43 | 44 | Installation and Compilation Instructions 45 | ------------------------------------------ 46 | 47 | This development has been tested with The Coq Proof Assistant, version 8.11.1 48 | (May 2020). 49 | 50 | To compile this code with Coq, you also need to install a copy of the Metalib 51 | library. This library is available from https://github.com/plclub/metalib 52 | at the `coq8.10` tag. 53 | 54 | The `src/` directory includes a Coq specification of a dependently typed 55 | calculus with type-in-type, dependent functions, unit, products and sums. 56 | 57 | Once Coq and metalib have been installed, the files in the `src/` directory 58 | can be compiled using 59 | 60 | make coq 61 | 62 | You may also be able to install via OPAM: 63 | 64 | opam switch create ./ OCAML_VERSION 65 | opam repo add coq-released https://coq.inria.fr/opam/released 66 | opam install coq coq-ott ott 67 | opam pin add coq-metalib https://github.com/plclub/metalib.git 68 | 69 | Contents 70 | -------- 71 | 72 | The files that make up the Coq development include: 73 | 74 | - dqtt.ott Specification of the entire system 75 | - dqtt_ott.v Generated definition (from Ott, modified by hand) 76 | - dqtt_inf.v Generated lemmas (from LNgen, modified by hand). 77 | - tactics.v General purpose tactics 78 | - metalib.v metalib additions 79 | 80 | - beta.v Axiomatization of beta-equivalence 81 | - usage_sig.v Axiomatization of partially-ordered semiring 82 | 83 | - usage.v Lemmas about working with usages and with graded contexts (language independent) 84 | - dctx.v 85 | - dctx_sub. v 86 | - semimodule.v 87 | 88 | - structural.v Substitution and Weakening (Lemmas 7.2 and 7.3) 89 | - dqtt.v Regularity, Preservation and Progress (Lemma 7.1, Theorems 7.4 and 7.5) 90 | 91 | 92 | Binding Representation 93 | ---------------------- 94 | This proof uses a Locally Nameless representation for binding, as supported by the [Ott locallynameless backend](https://fzn.fr/projects/ln_ott/) and [LNgen](https://repository.upenn.edu/cis_reports/933/) tools. 95 | 96 | For background on this binding representation, please see: 97 | * [Engineering Formal Metatheory](https://repository.upenn.edu/cis_papers/369/) 98 | * [DeepSpec Summer School 2017 Tutorial on Locally Nameless Representation](https://deepspec.org/event/dsss17/lecture_weirich.html) 99 | -------------------------------------------------------------------------------- /GraD/graded-haskell.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "graded-haskell" 3 | version: "0.1" 4 | synopsis: "Preservation and Progress for GraD language" 5 | description: """ 6 | Longer description 7 | """ 8 | maintainer: "Stephanie Weirich " 9 | authors: "Stephanie Weirich " 10 | license: "MIT" 11 | tags: "org:plclub" 12 | homepage: "https://github.com/sweirich/graded-haskell" 13 | bug-reports: "https://github.com/sweirich/graded-haskell/issues" 14 | dev-repo: "git+https://github.com/sweirich/graded-haskell/issues" 15 | depends: [ "coq" {>= "8.10"} "coq-metalib" { >= "coq8.10" } ] 16 | build: [ 17 | ["cd src"] 18 | [make] 19 | ] 20 | install: [make "install"] 21 | -------------------------------------------------------------------------------- /GraD/spec.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/graded-haskell/986ac74f0cb5d38c11307beb5b05e9eb2e0bd0ed/GraD/spec.pdf -------------------------------------------------------------------------------- /GraD/src-def/Makefile: -------------------------------------------------------------------------------- 1 | OTT_SOURCE = dqtt 2 | OTT_LOC = . 3 | FILES = dqtt_ott dqtt_inf 4 | OTTFILES = $(foreach i, qtt, $(OTT_LOC)/$(i).ott) 5 | OTTIFLAGS = $(foreach i, qtt, -i $(OTT_LOC)/$(i).ott) 6 | 7 | ################ latex #################### 8 | 9 | SPEC = dqtt.ott 10 | SPECFILE = spec.tex 11 | RULESFILE = dqtt-rules.tex 12 | 13 | spec.pdf: $(SPEC) $(SPECFILE) 14 | ott -o $(RULESFILE) \ 15 | -tex_wrap false \ 16 | -tex_show_meta false $(SPEC) 17 | pdflatex -interaction nonstopmode $(SPECFILE) 18 | 19 | $(RULESFILE): $(SPEC) 20 | ott $(OTTIFLAGS) -o $(RULESFILE) \ 21 | -tex_wrap false \ 22 | -tex_show_meta false 23 | 24 | %.tex: $(RULESFILE) %.mng Makefile 25 | ott $(OTTIFLAGS) \ 26 | -tex_wrap false \ 27 | -tex_show_meta false \ 28 | -tex_filter $*.mng $*.tex 29 | 30 | %.pdf : %.tex $(RULESFILE) 31 | latexmk -bibtex -pdf $*.tex 32 | 33 | 34 | ###################### COQ ############################## 35 | 36 | ## Paths to executables. Do not include options here. 37 | ## Modify these to suit your Coq installation, if necessary. 38 | 39 | COQC = coqc 40 | COQDEP = coqdep 41 | 42 | ## Include directories, one per line. 43 | 44 | INCDIRS = \ 45 | . \ 46 | ../metalib \ 47 | 48 | 49 | ## Library name used for the imports in Coq 50 | 51 | LIBNAME=Qtt 52 | METALIBLOCATION=../metalib 53 | LNGEN=lngen 54 | 55 | 56 | ## Name of the submakefile generated by coq_makefile 57 | COQMKFILENAME=CoqSrc.mk 58 | 59 | 60 | VFILES = $(foreach i, $(FILES), $(i).v) 61 | VOFILES = $(foreach i, $(FILES), $(i).vo) 62 | INCFLAGS = $(foreach i, $(INCDIRS), -I $(i)) 63 | 64 | .SECONDARY: $(VFILES) 65 | 66 | METALIBFILES= $(METALIBLOCATION)/*.v $(METALIBLOCATION)/Makefile $(METALIBLOCATION)/README.txt 67 | 68 | all: coq 69 | 70 | quick: $(COQMKFILENAME) 71 | @$(MAKE) -f CoqSrc.mk quick 72 | 73 | 74 | coq: $(COQMKFILENAME) $(VFILES) 75 | @$(MAKE) -f CoqSrc.mk 76 | 77 | 78 | %.vo: %.v 79 | @$(MAKE) -f CoqSrc.mk $*.vo 80 | 81 | 82 | %_inf_proofs.v: $(OTT_LOC)/%.ott Makefile 83 | $(LNGEN) --coq $*_inf_proofs.v --coq-ott $*_ott $(OTT_LOC)/$*.ott 84 | 85 | 86 | $(COQMKFILENAME): Makefile $(shell ls *.v | grep -v _ott.v | grep -v _inf.v) 87 | { echo "-R . $(LIBNAME) " ; ls *.v ; } > _CoqProject && coq_makefile -arg '-w -variable-collision,-meta-collision,-require-in-module' -f _CoqProject -o $(COQMKFILENAME) 88 | 89 | 90 | coqclean: 91 | @rm -if *.v.d *.vo *.glob *.v-e *.vok *.vos *.conf *.v-e $(VOFILES) $(COQMKFILENAME) 92 | 93 | clean: coqclean 94 | @rm -f *~ 95 | @rm -f *.log *.aux *.fls *.fdb_latexmk 96 | 97 | METALIB.FIX_%: 98 | sed -i -e 's/Metalib.Metatheory./Metalib.Metatheory. Require Export Metalib.LibLNgen. Require Export Qtt.usage_sig./g' $*.v 99 | sed '1d' $*.v > __TMP__; mv __TMP__ $*.v 100 | 101 | -------------------------------------------------------------------------------- /GraD/src-def/README.md: -------------------------------------------------------------------------------- 1 | System with Definitions 2 | ---------------------- 3 | 4 | This directory proves substitutions, weakening, regularity, preservation and progress for the system extended with definitions, as described in Section 8.1 of the POPL 2021 paper. 5 | 6 | This code is an extension of the language shown in the `src/` directory. It 7 | has not been evaluated by the POPL 2021 artifact evaluation committee. 8 | 9 | To compile this code with Coq, you also need to install a copy of the Metalib 10 | library. This library is available from https://github.com/plclub/metalib 11 | 12 | This is Coq specification of a dependently typed calculus with type-in-type, 13 | dependent functions, unit, products and sums. 14 | 15 | The files that make up the Coq development include: 16 | 17 | - dqtt.ott Specification of the entire system 18 | - dqtt_ott.v Generated definition (from Ott, modified by hand) 19 | - dqtt_inf.v Generated lemmas (from LNgen). 20 | - tactics.v General purpose tactics 21 | - metalib.v metalib additions 22 | 23 | - beta.v Axiomatization of beta-equivalence 24 | - usage_sig.v Axiomatization of partially-ordered semiring 25 | 26 | - usage.v Lemmas about working with usages and with graded contexts (language independent) 27 | - dctx.v 28 | - dctx_sub. v 29 | - semimodule.v 30 | 31 | - structural.v Substitution and Weakening 32 | - dqtt.v Regularity, Preservation and Progress 33 | 34 | 35 | -------------------------------------------------------------------------------- /GraD/src-def/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Qtt 2 | beta.v 3 | dctx.v 4 | dctx_sub.v 5 | dqtt.v 6 | dqtt_inf.v 7 | dqtt_ott.v 8 | inversion.v 9 | metalib.v 10 | semimodule.v 11 | structural.v 12 | tactics.v 13 | usage.v 14 | usage_sig.v 15 | -------------------------------------------------------------------------------- /GraD/src-def/beta.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Metalib.Metatheory. 3 | Require Import dqtt_ott. 4 | 5 | (* only for locally-closed terms *) 6 | Axiom Beta_lc1 : forall A B, Beta A B -> lc_tm A. 7 | Axiom Beta_lc2 : forall A B, Beta A B -> lc_tm B. 8 | 9 | 10 | Axiom B_Refl : forall (A:tm), 11 | lc_tm A -> 12 | Beta A A. 13 | 14 | Axiom B_Sym : forall (A B:tm), 15 | Beta B A -> 16 | Beta A B. 17 | Axiom B_Trans : forall (A B A1:tm), 18 | Beta A A1 -> 19 | Beta A1 B -> 20 | Beta A B. 21 | Axiom B_Step : forall (a a':tm), 22 | Step a a' -> 23 | Beta a a'. 24 | 25 | Hint Resolve B_Refl B_Sym B_Trans B_Step : core. 26 | 27 | Axiom subst_Beta1 : forall a0 x A B, lc_tm a0 -> Beta A B -> Beta (subst_tm_tm a0 x A) (subst_tm_tm a0 x B). 28 | Axiom subst_Beta2 : forall a0 a1 x B, lc_tm B -> Beta a0 a1 -> Beta (subst_tm_tm a0 x B) (subst_tm_tm a1 x B). 29 | Axiom subst_Beta : forall a0 a1 x A B, Beta a0 a1 -> Beta A B -> Beta (subst_tm_tm a0 x A) (subst_tm_tm a1 x B). 30 | 31 | Axiom invert_Beta_a_Pi0 : forall {q A B q0 A0 B0 }, Beta (a_Pi q A B) (a_Pi q0 A0 B0) -> q = q0. 32 | Axiom invert_Beta_a_Pi1 : forall {q A B q0 A0 B0 }, Beta (a_Pi q A B) (a_Pi q0 A0 B0) -> Beta A A0. 33 | Axiom invert_Beta_a_Pi2 : forall {q A B q0 A0 B0 }, Beta (a_Pi q A B) (a_Pi q0 A0 B0) -> 34 | forall x, x `notin` fv_tm_tm B \u fv_tm_tm B0 -> 35 | Beta (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm B0 (a_Var_f x)). 36 | 37 | Axiom invert_Beta_a_Sigma0 : forall {q A B q0 A0 B0 }, Beta (a_Sigma q A B) (a_Sigma q0 A0 B0) -> q = q0. 38 | Axiom invert_Beta_a_Sigma1 : forall {q A B q0 A0 B0 }, Beta (a_Sigma q A B) (a_Sigma q0 A0 B0) -> Beta A A0. 39 | Axiom invert_Beta_a_Sigma2 : forall {q A B q0 A0 B0 }, Beta (a_Sigma q A B) (a_Sigma q0 A0 B0) -> 40 | forall x, x `notin` fv_tm_tm B \u fv_tm_tm B0 -> 41 | Beta (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm B0 (a_Var_f x)). 42 | 43 | Axiom invert_Beta_a_With1 : forall {A B A0 B0 }, Beta (a_With A B) (a_With A0 B0) -> Beta A A0. 44 | Axiom invert_Beta_a_With2 : forall {A B A0 B0 }, Beta (a_With A B) (a_With A0 B0) -> 45 | forall x, x `notin` fv_tm_tm B \u fv_tm_tm B0 -> 46 | Beta (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm B0 (a_Var_f x)). 47 | 48 | 49 | Axiom invert_Beta_Box1 : forall {q1 q2 A B}, Beta (a_Box q1 A) (a_Box q2 B) -> Beta A B. 50 | Axiom invert_Beta_Box2 : forall {q1 q2 A B}, Beta (a_Box q1 A) (a_Box q2 B) -> q1 = q2. 51 | 52 | Axiom invert_Beta_Sum1 : forall {A1 B1 A2 B2}, Beta (a_Sum A1 B1) (a_Sum A2 B2) -> Beta A1 A2. 53 | Axiom invert_Beta_Sum2 : forall {A1 B1 A2 B2}, Beta (a_Sum A1 B1) (a_Sum A2 B2) -> Beta B1 B2. 54 | 55 | 56 | Inductive consistent : tm -> tm -> Prop := 57 | | con_Type : consistent a_Type a_Type 58 | | con_Unit : consistent a_TyUnit a_TyUnit 59 | | con_Pi : forall q A B q' A' B', consistent (a_Pi q A B) (a_Pi q' A' B') 60 | | con_Sigma : forall q A B q' A' B', consistent (a_Sigma q A B) (a_Sigma q' A' B') 61 | | con_With : forall A B A' B', consistent (a_With A B) (a_With A' B') 62 | | con_Box : forall q A A', consistent (a_Box q A) (a_Box q A') 63 | | con_Sum : forall A B A' B', consistent (a_Sum A B) (a_Sum A' B') 64 | | con_unit : consistent a_TmUnit a_TmUnit 65 | | con_lam : forall q A a A' a', consistent (a_Lam q A a) (a_Lam q A' a') 66 | | con_box : forall q q' a a', consistent (a_box q a) (a_box q' a') 67 | | con_tensor : forall A B A' B', consistent (a_Tensor A B) (a_Tensor A' B') 68 | | con_pair : forall A B A' B', consistent (a_Pair A B) (a_Pair A' B') 69 | | con_inj1 : forall a a', consistent (a_Inj1 a) (a_Inj1 a') 70 | | con_inj2 : forall a a', consistent (a_Inj2 a) (a_Inj2 a') 71 | | con_prj1 : forall a a', consistent (a_Prj1 a) (a_Prj1 a') 72 | | con_prj2 : forall a a', consistent (a_Prj2 a) (a_Prj2 a') 73 | 74 | . 75 | Hint Constructors consistent : core. 76 | 77 | Inductive ty : tm -> Prop := 78 | | ty_Type : ty a_Type 79 | | ty_Unit : ty a_TyUnit 80 | | ty_Pi : forall q A B, ty (a_Pi q A B) 81 | | ty_Sigma : forall q A B, ty (a_Sigma q A B) 82 | | ty_With : forall A B, ty (a_With A B) 83 | | ty_Box : forall q A, ty (a_Box q A) 84 | | ty_Sum : forall A B, ty (a_Sum A B) 85 | 86 | . 87 | 88 | Inductive value : tm -> Prop := 89 | | val_ty : forall t, ty t -> value t 90 | | val_unit : value a_TmUnit 91 | | val_lam : forall q A a, value (a_Lam q A a) 92 | | val_box : forall q a, value (a_box q a) 93 | | val_inj1 : forall a, value (a_Inj1 a) 94 | | val_inj2 : forall a, value (a_Inj2 a) 95 | | val_tensor : forall a b, value (a_Tensor a b) 96 | | val_pair : forall a b, value (a_Pair a b) 97 | . 98 | 99 | Hint Constructors ty value : core. 100 | 101 | Axiom Beta_consistent : forall A B, Beta A B -> value A -> value B -> consistent A B. 102 | -------------------------------------------------------------------------------- /GraD/src-def/dctx_sub.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Coq.Classes.EquivDec. 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | 9 | Require Import Qtt.tactics. 10 | Require Import Qtt.usage. 11 | Require Import Qtt.dctx. 12 | 13 | 14 | (* ----------------------------------------------------------------------- *) 15 | (** ** Lemmas about the context, reflecting the usage structure *) 16 | 17 | 18 | (* ----------------------------------------------------------------- *) 19 | (** *** ctx_sub properties *) 20 | 21 | Lemma ctx_sub_refl : forall {A} {D:list (atom * A)} {G}, ctx D G -> ctx_sub D G G. 22 | Proof. induction D; 23 | move => G1 h; inversion h; subst. auto. 24 | econstructor; auto. reflexivity. 25 | Qed. 26 | 27 | Lemma ctx_sub_trans : forall {A} {G2} {D:list(atom * A)} {G1 G3}, ctx_sub D G1 G2 -> ctx_sub D G2 G3 -> 28 | ctx_sub D G1 G3. 29 | Proof. 30 | move=> A G2 D. move: G2. 31 | induction D; intros; inversion H0; inversion H; subst; auto. 32 | invert_equality. 33 | econstructor; auto. 34 | transitivity q1; auto. 35 | eapply IHD; eauto. 36 | Qed. 37 | 38 | Instance cst : forall {A}{D:list (atom * A)}, Transitive (ctx_sub D). 39 | intros. eauto using ctx_sub_trans. 40 | Qed. 41 | 42 | (* Interactions with association lists *) 43 | 44 | Lemma dom_ctx_sub : forall {A} {D:list(atom*A)} {G1 G2}, ctx_sub D G1 G2 -> dom G1 = dom G2. 45 | Proof. move => A D G1 G2 h. induction h; simpl; auto. 46 | all: rewrite IHh. 47 | all: auto. 48 | Qed. 49 | 50 | Lemma uniq_ctx_sub : forall {A} {D:list(atom*A)}{ G1 G2}, ctx_sub D G1 G2 -> uniq G1 <-> uniq G2. 51 | Proof. 52 | move=> A D G1 G2 h. induction h; split; auto; 53 | move => h1; inversion h1; subst. 54 | + erewrite dom_ctx_sub in H5; eauto. 55 | econstructor; eauto. 56 | tauto. 57 | + erewrite <- dom_ctx_sub in H5; eauto. 58 | econstructor; eauto. 59 | tauto. 60 | Qed. 61 | 62 | Lemma ctx_sub_app {A} {D1 D2 : list (atom *A)}{G1 G2 G3 G4} : 63 | ctx_sub D1 G1 G2 -> ctx_sub D2 G3 G4 -> uniq (D1 ++ D2) -> 64 | ctx_sub (D1 ++ D2) (G1 ++ G3) (G2 ++ G4). 65 | Proof. 66 | induction 1. simpl. auto. 67 | all: intros h U; simpl_env; inversion U; subst. 68 | all: econstructor; eauto. 69 | Qed. 70 | 71 | (* decomposition *) 72 | 73 | Lemma split_ctx_sub {A}{D1:list (atom*A)} : forall {G G1 D2 G4 G2}, 74 | ctx D1 G -> ctx D1 G1 75 | -> ctx_sub (D1 ++ D2) (G ++ G4) (G1 ++ G2) 76 | -> ctx_sub D1 G G1 /\ ctx_sub D2 G4 G2. 77 | Proof. 78 | induction D1; intros. 79 | inversion H; inversion H0. 80 | subst. simpl in *. split; auto. 81 | inversion H; inversion H0; inversion H1. subst. 82 | simpl_env in *. 83 | repeat invert_equality. 84 | edestruct IHD1. 3: { eauto. } eclarify_ctx. eclarify_ctx. 85 | econstructor; eauto. 86 | Qed. 87 | 88 | 89 | Lemma ctx_sub_app_split_r {A} {D:list (atom*A)} : forall {G G0 G3}, 90 | ctx_sub D G (G0 ++ G3) -> 91 | exists D1 D2 G1 G2, G = G1 ++ G2 /\ D = D1 ++ D2 /\ ctx_sub D1 G1 G0 /\ ctx_sub D2 G2 G3. 92 | Proof. 93 | induction D. 94 | + intros G G0 G3 h. inversion h. exists nil. exists nil. 95 | exists nil. exists nil. 96 | repeat split; auto. 97 | destruct G0; destruct G3; simpl_env in *; inversion h. 98 | eauto. 99 | destruct G0; destruct G3; simpl_env in *; inversion h. 100 | eauto. 101 | + intros G G0 G3 h. 102 | destruct G0; simpl_env in *; inversion h; subst. 103 | - clear h. 104 | specialize (IHD G1 nil G2 ltac:(eauto)). 105 | move: IHD => [D1 [D2 [G1' [G2' [h1 [h2 [h3 h4]]]]]]]. 106 | inversion h3. subst. 107 | exists nil. 108 | exists (x ~ a0 ++ D2). 109 | exists nil. 110 | exists (x ~ (q1,a0) ++ G2'). 111 | simpl_env. split; auto. 112 | - clear h. 113 | specialize (IHD G1 G0 G3 ltac:(eauto)). 114 | move: IHD => [D1 [D2 [G1' [G2' [h1 [h2 [h3 h4]]]]]]]. 115 | exists (x ~ a0 ++ D1). 116 | exists D2. 117 | exists (x ~ (q1, a0) ++ G1'). 118 | exists G2'. 119 | subst. 120 | simpl_env. 121 | repeat split; auto. 122 | Qed. 123 | 124 | Lemma three_ctx_sub {A}{D:list(atom*A)} : forall {G1 x q1 s G2 G}, 125 | ctx_sub D (G1 ++ x ~ (q1, s) ++ G2) G -> 126 | exists D1, exists D2, exists G1', exists G2', exists q2, D = D1 ++ x ~ s ++ D2 /\ G = G1' ++ x ~ (q2, s) ++ G2' /\ 127 | ctx_sub D1 G1 G1' /\ (q1 <= q2) /\ ctx_sub D2 G2 G2'. 128 | Proof. 129 | induction D; intros. 130 | + match goal with [ H : ctx_sub _ _ _ |- _ ] => inversion H end. 131 | destruct G1; simpl in *; discriminate. 132 | + destruct G1 as [|[y B] G1']. 133 | ++ simpl in H. inversion H; subst. 134 | exists nil. eexists D. exists nil. exists G0. exists q2. simpl_env. auto. 135 | ++ inversion H. subst. 136 | simpl_env in *. 137 | specialize (IHD _ _ _ _ _ _ H7). 138 | move: IHD => [D1' [D2' [G1'' [G2'' [q2' [E1 [S1 [S2 [S3 S4]]]]]]]]]. 139 | subst. 140 | exists (y ~ a0 ++ D1'). eexists. 141 | exists (y ~ (q2, a0) ++ G1''). eexists. eexists. 142 | simpl_env. 143 | split; eauto. 144 | Qed. 145 | 146 | 147 | Ltac destruct_ctx_sub := 148 | let D1 := fresh "D" in 149 | let D2 := fresh "D" in 150 | let G1' := fresh "G" in 151 | let G2' := fresh "G" in 152 | let E1 := fresh "E" in 153 | let S1 := fresh "S" in 154 | let S2 := fresh "S" in 155 | let S3 := fresh "S" in 156 | let q2 := fresh "q" in 157 | match goal with 158 | | [H : ctx_sub ?D ?G (?G1 ++ ?G2) |- _ ] => 159 | apply ctx_sub_app_split_r in H; 160 | move: H => [D1 [D2 [G1' [G2' [E1 [S1 [S2 S3]]]]]]]; 161 | subst G 162 | | [H : ctx_sub ?D (?G1 ++ ?x ~ (?q,?A) ++ ?G2) ?G |- _ ] => 163 | apply three_ctx_sub in H; 164 | move: H => [D1 [D2 [G1' [G2' [q2 [E1 [S1 [S2 [S3 S4]]]]]]]]]; 165 | subst G 166 | | [ H : ctx_sub ?D ?G3 ([(?x, ?s)] ++ ?G2) |- _ ] => 167 | inversion H; subst; clear H 168 | | [ H : ctx_sub ?D ?G3 ([(?x, ?s)]) |- _ ] => 169 | inversion H; subst; clear H 170 | | [ H : ctx_sub ?D ?G3 nil |- _ ] => 171 | inversion H; subst; clear H 172 | end. 173 | -------------------------------------------------------------------------------- /GraD/src-def/metalib.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Metalib.Metatheory. 3 | 4 | (* ------- these should be added to the metatheory library ------------------------- *) 5 | 6 | (* If we have identified a variable in the middle of a uniq environment, 7 | it fixes the front and back. *) 8 | Lemma uniq_mid A x (a a':A) G1 : forall G2 G1' G2', 9 | uniq (G1 ++ (x ~ a) ++ G2) -> 10 | (G1 ++ x ~ a ++ G2) = (G1' ++ x ~ a' ++ G2') -> 11 | G1 = G1' /\ a = a' /\ G2 = G2'. 12 | Proof. 13 | induction G1. 14 | + intros. 15 | destruct G1'; inversion H0; simpl_env in *. auto. 16 | subst. destruct_uniq. fsetdec. 17 | + intros. 18 | destruct a0 as [y b]. 19 | simpl_env in *. 20 | destruct_uniq. 21 | have NE: not (y = x). fsetdec. 22 | destruct G1' as [|[z c]]. simpl_env in H0. inversion H0. done. 23 | inversion H0. subst. 24 | simpl_env in *. 25 | specialize (IHG1 G2 G1' G2'). 26 | destruct IHG1 as [E1 [E2 E3]]; auto. 27 | subst. auto. 28 | Qed. 29 | 30 | (* If x is in an environment, it is either in the front half or 31 | the back half. *) 32 | Lemma binds_split A x (a:A) G : binds x a G -> exists G1 G2, G = G2 ++ [(x, a)] ++ G1. 33 | Proof. 34 | move=>B. induction G. 35 | + inversion B. 36 | + destruct a0 as [y b]. 37 | apply binds_cons_1 in B. 38 | destruct B as [[E1 E2]|E]. subst. 39 | ++ exists G. exists nil. auto. 40 | ++ destruct (IHG E) as [G1 [G2 E2]]. 41 | subst. 42 | eexists. exists ((y ~ b) ++ G2). simpl_env. 43 | eauto. 44 | Qed. 45 | 46 | (* If we divide up a context containing a variable, it either appears in the 47 | front half or the back half *) 48 | Lemma ctx_align_eq A G1 G2 (x:atom) (a:A) G0 G3 : 49 | uniq (G2 ++ x ~ a ++ G1) -> 50 | G2 ++ x ~ a ++ G1 = G0 ++ G3 -> 51 | (exists G0' G0'', G0 = G0' ++ x ~ a ++ G0'' /\ G2 = G0' /\ G1 = G0'' ++ G3) \/ 52 | (exists G3' G3'', G3 = G3' ++ x ~ a ++ G3'' /\ G2 = G0 ++ G3' /\ G1 = G3''). 53 | Proof. 54 | intros U E. 55 | have B: binds x a (G0 ++ G3). { rewrite <- E. auto. } 56 | rewrite -> binds_app_iff in B. 57 | destruct B as [h1|h1]. 58 | + left. 59 | destruct (binds_split _ _ _ _ h1) as [G0'' [G0' E2]]. 60 | exists G0'. exists G0''. split. auto. 61 | subst. 62 | simpl_env in E. 63 | edestruct uniq_mid with (G1 := G2) (G1' := G0') 64 | (G2 := G1) (G2' := G0'' ++ G3); eauto. 65 | tauto. 66 | + right. 67 | destruct (binds_split _ _ _ _ h1) as [G0'' [G0' E2]]. 68 | exists G0'. exists G0''. split. auto. 69 | subst. 70 | edestruct uniq_mid with (G1 := G2) (G1' := G0 ++ G0') 71 | (G2 := G1) (G2' := G0''); simpl_env; eauto. 72 | tauto. 73 | Qed. 74 | -------------------------------------------------------------------------------- /GraD/src-def/ottalt.sty: -------------------------------------------------------------------------------- 1 | %% 2 | %% This is file `ottalt.sty', 3 | %% generated with the docstrip utility. 4 | %% 5 | %% The original source files were: 6 | %% 7 | %% ottalt.dtx (with options: `package') 8 | %% 9 | %% Copyright (C) 2011 by Jesse A. Tov 10 | %% 11 | %% This file may be distributed and/or modified under the conditions of the 12 | %% LaTeX Project Public License, either version 1.2 of this license or (at 13 | %% your option) any later version. The latest version of this license is 14 | %% in: 15 | %% 16 | %% http://www.latex-project.org/lppl.txt 17 | %% 18 | %% and version 1.2 or later is part of all distributions of LaTeX 19 | %% version 1999/12/01 or later. 20 | %% 21 | \NeedsTeXFormat{LaTeX2e}[1999/12/01] 22 | \ProvidesPackage{ottalt} 23 | [2013/03/14 v0.11 alternate Ott layout style] 24 | \RequirePackage{mathpartir} 25 | \RequirePackage{ifthen} 26 | \RequirePackage{keyval} 27 | \RequirePackage{listproc} 28 | \DeclareOption{implicitPremiseBreaks}{ 29 | \renewcommand\ottaltpremisesep{\\} 30 | \renewcommand\ottaltpremisebreak{\\} 31 | } 32 | \DeclareOption{lineBreakHack}{ 33 | \renewcommand\ottaltpremisesep{\mpr@andcr} 34 | \renewcommand\ottaltpremisebreak{\\\\} 35 | } 36 | \DeclareOption{implicitLineBreakHack}{ 37 | \renewcommand\ottaltpremisesep{\\} 38 | \renewcommand\ottaltpremisebreak{\\\\} 39 | } 40 | \DeclareOption{alternateNonterms}{ 41 | \let\ifnotalternateNonterms\@secondoftwo 42 | } 43 | \DeclareOption{supertabular}{ 44 | \ottalt@supertabulartrue 45 | } 46 | \newcommand\ottaltpremisesep{\\} 47 | \newcommand\ottaltpremisebreak{\\} 48 | \let\ifnotalternateNonterms\@firstoftwo 49 | \newif\ifottalt@supertabular 50 | \ProcessOptions 51 | \ifottalt@supertabular 52 | \RequirePackage{supertabular} 53 | \fi 54 | \newcommand\inputott[2][ott]{ 55 | \input{#2} 56 | \renewottcommands[#1] 57 | } 58 | \newcommand\ottaltcurrentprefix{ott} 59 | \newcommand\renewottcommands[1][ott]{ 60 | \renewcommand\ottaltcurrentprefix{#1} 61 | \def\renewottcomm@nd##1{ 62 | \expandafter\renewcommand\csname #1##1\endcsname 63 | } 64 | \renewottcomm@nd{drule}[4][]{ 65 | \def\ottalt@nextpremise{} 66 | \ottalt@premisetoks={ } 67 | ##2 68 | \expandafter\ottalt@inferrule\expandafter 69 | {\the\ottalt@premisetoks}{##3}{##4}{##1} 70 | } 71 | \renewottcomm@nd{premise}[1]{% 72 | \ottalt@premisetoks= 73 | \expandafter\expandafter\expandafter 74 | {\expandafter\the\expandafter\ottalt@premisetoks 75 | \ottalt@nextpremise##1} 76 | \ottalt@iflinebreakhack##1\ottlinebreakhack\ottalt@iflinebreakhack{ 77 | \let\ottalt@nextpremise\ottaltpremisebreak 78 | }{ 79 | \let\ottalt@nextpremise\ottaltpremisesep 80 | } 81 | } 82 | \renewottcomm@nd{usedrule}[1]{% 83 | \ifottalt@firstrule 84 | \ottalt@firstrulefalse 85 | \else 86 | %\and 87 | %% sigart.cls uses \and for the title and mangles it horribly 88 | %% so we cannot use it here. Instead, we drop down to what 89 | %% mathpartir wants to redefine the \and command to be anyways 90 | \mpr@andcr 91 | %%\quad 92 | \fi 93 | \ensuremath{##1} 94 | } 95 | \renewenvironment{#1defnblock}[3][] 96 | {\begin{drulepar}{##2}{##3}} 97 | {\end{drulepar}} 98 | \renewottcomm@nd{drulename}[1]{% 99 | \ottalt@replace@cs\ranchor\_-{}##1\\ 100 | } 101 | \renewottcomm@nd{prodline}[6]{ 102 | \ifthenelse{\equal{##3}{}}{ 103 | \\ & & $##1$ & $##2$ & & $##5$ & $##6$ 104 | }{} 105 | } 106 | \renewottcomm@nd{prodnewline}{\relax} 107 | \renewottcomm@nd{grammartabular}[1]{% 108 | \begin{ottaltgrammar}##1\end{ottaltgrammar}% 109 | } 110 | } 111 | \newcommand*\drule@h@lper[3]{% 112 | \expandafter\ifx\csname\ottaltcurrentprefix drule#3\endcsname\relax 113 | \PackageWarning{ottalt}{Unknown ott rule: #3}% 114 | \mbox{\textbf{(#2?)}}% 115 | \else 116 | \csname\ottaltcurrentprefix usedrule\endcsname 117 | {\csname\ottaltcurrentprefix drule#3\endcsname{#1}}% 118 | \fi 119 | } 120 | \newcommand*\nonterm@h@lper[1]{\csname\ottaltcurrentprefix#1\endcsname} 121 | \newcommand\rrefruletext{rule} 122 | \newcommand\Rrefruletext{\expandafter\MakeUppercase\rrefruletext} 123 | \newcommand\rrefrulestext{\rrefruletext s} 124 | \newcommand\Rrefrulestext{\Rrefruletext s} 125 | \newcommand\rrefstyle{\normalfont\scshape} 126 | \newcommand\ranchorstyle{\rrefstyle} 127 | \providecommand\wraparoundrref{\relax} 128 | \newcommand*\rref{% 129 | \@ifnextchar* 130 | {\rref@star} 131 | {\rref@with\rrefruletext\rrefrulestext}} 132 | \newcommand*\Rref{% 133 | \@ifnextchar* 134 | {\rref@star} 135 | {\rref@with\Rrefruletext\Rrefrulestext}} 136 | \newcommand*\rref@with[2]{\FormatList{#1~}{#2~}{\one@rref}} 137 | \newcommand*\rref@star[1]{\FormatList{}{}{\one@rref}} 138 | \newcommand*\@one@rref@nohyper[1]{\wraparoundrref{{\rrefstyle{#1}}}} 139 | \newcommand*\@ranchor@nohyper[1]{{\ranchorstyle{#1}}} 140 | \AtBeginDocument{ 141 | \ifcsname hypertarget\endcsname 142 | \newcommand*\one@rref[1]{% 143 | \hyperlink 144 | {ottalt:rule:\ottaltcurrentprefix:#1} 145 | {\@one@rref@nohyper{#1}}% 146 | } 147 | \newcommand*\ranchor[1]{% 148 | \hypertarget 149 | {ottalt:rule:\ottaltcurrentprefix:#1} 150 | {\@ranchor@nohyper{#1}}% 151 | } 152 | \else 153 | \newcommand\one@rref{\@one@rref@nohyper} 154 | \newcommand\ranchor{\@ranchor@nohyper} 155 | \fi 156 | } 157 | \newcommand*{\drules}[4][\relax]{% 158 | \begin{drulepar}[#1]{#2}{#3} 159 | \@for\@ottalt@each:=#4\do{% 160 | \expandafter\drule\expandafter{\@ottalt@each} 161 | } 162 | \end{drulepar}% 163 | } 164 | \newenvironment{drulepar}[3][\relax] 165 | {\begin{rulesection}[#1]{#2}{#3}% 166 | \begin{mathparpagebreakable}} 167 | {\end{mathparpagebreakable}% 168 | \end{rulesection}} 169 | \newenvironment{drulepar*}[3][\relax] 170 | {\begin{rulesection*}[#1]{#2}{#3}% 171 | \begin{mathparpagebreakable}} 172 | {\end{mathparpagebreakable}% 173 | \end{rulesection*}} 174 | \newenvironment{rulesection}[3][\relax] 175 | {\trivlist\item 176 | \ifx#1\relax\else\def\ottalt@rulesection@prefix{#1-}\fi 177 | \drulesectionhead{#2}{#3}% 178 | \nopagebreak[4]% 179 | \noindent} 180 | {\endtrivlist} 181 | \newenvironment{rulesection*}[3][\relax] 182 | {\trivlist\item 183 | \ifx#1\relax\else\def\ottalt@rulesection@prefix{#1-}\fi 184 | \drulesectionhead*{#2}{#3}% 185 | \nopagebreak[4]% 186 | \noindent} 187 | {\endtrivlist} 188 | \newcommand\ottalt@rulesection@prefix{} 189 | \newcommand*{\drulesectionhead}{% 190 | \@ifnextchar *{\drulesectionheadMany}{\drulesectionheadOne}% 191 | } 192 | \newcommand*{\drulesectionheadOne}[2]{% 193 | \FormatDruleSectionHead{#1}% 194 | \hfill\FormatDruleSectionHeadRight{#2}% 195 | \par 196 | } 197 | \newcommand*{\drulesectionheadMany}[3]{% 198 | {% 199 | \let\FormatListSepTwo\FormatDruleSepTwo 200 | \let\FormatListSepMore\FormatDruleSepMore 201 | \let\FormatListSepLast\FormatDruleSepLast 202 | \FormatList{}{}{\FormatDruleSectionHeads}{#2}% 203 | }% 204 | \hfill\FormatDruleSectionHeadRight{#3}% 205 | \par 206 | } 207 | \newcommand*\FormatDruleSepTwo{\,,~} 208 | \newcommand*\FormatDruleSepMore{\FormatDruleSepTwo} 209 | \newcommand*\FormatDruleSepLast{\FormatDruleSepTwo} 210 | \newcommand*\FormatDruleSectionHead[1]{\fbox{#1}} 211 | \newcommand*\FormatDruleSectionHeads[1]{\fbox{\strut#1}} 212 | \newcommand*\FormatDruleSectionHeadRight[1]{\emph{(#1)}} 213 | \newcommand*\drule[2][]{% 214 | \expandafter\drule@helper\expandafter{\ottalt@rulesection@prefix}{#1}{#2}% 215 | } 216 | \newcommand*\drule@helper[3]{% 217 | \ottalt@replace@cs{\drule@h@lper{#2}{#1#3}}-{XX}{}#1#3\\ 218 | } 219 | \newcommand\ottaltinferrule[4]{ 220 | \inferrule*[narrower=0.3,lab=#1,#2] 221 | {#3} 222 | {#4} 223 | } 224 | \newcommand\ottalt@inferrule[4]{ 225 | \ottaltinferrule{#3}{#4}{#1}{#2} 226 | } 227 | \newif\ifottalt@firstrule \ottalt@firstruletrue 228 | \newcommand{\ottalt@nextpremise}{\relax} 229 | \newtoks\ottalt@premisetoks 230 | \newcommand{\ottlinebreakhack}{\relax} 231 | \def\ottalt@iflinebreakhack#1\ottlinebreakhack #2\ottalt@iflinebreakhack{% 232 | \ifthenelse{\equal{#2}{}}\@secondoftwo\@firstoftwo 233 | } 234 | \newcommand\ottalt@replace@cs[5]{% 235 | \ifx\\#5\relax 236 | \def\ottalt@replace@cs@kont{#1{#4}}% 237 | \else 238 | \ifx#2#5\relax 239 | \def\ottalt@replace@cs@kont{\ottalt@replace@cs{#1}{#2}{#3}{#4#3}}% 240 | \else 241 | \def\ottalt@replace@cs@kont{\ottalt@replace@cs{#1}{#2}{#3}{#4#5}}% 242 | \fi 243 | \fi 244 | \ottalt@replace@cs@kont 245 | } 246 | \newcommand*\nonterms[2][8pt]{ 247 | \begin{ottaltgrammar}[#1] 248 | \@for\@ottalt@each:=#2\do{% 249 | \expandafter\nt\expandafter{\@ottalt@each} 250 | } 251 | \end{ottaltgrammar} 252 | } 253 | \newenvironment{ottaltgrammar}[1][8pt]{% 254 | \begingroup 255 | \trivlist\item 256 | \def\OTTALTNEWLINE{\\[#1]}% 257 | \def\nt##1{\OTTALTNEWLINE\relax\nonterm@h@lper{##1}\ignorespaces}% 258 | \newcommand\ottaltintertext[2]{% 259 | \multicolumn{8}{l}{% 260 | \begin{minipage}{##1}% 261 | ##2% 262 | \end{minipage}% 263 | }% 264 | }% 265 | \ifottalt@supertabular 266 | \begin{supertabular}{llcllllll} 267 | \else 268 | \begin{tabular}{llcllllll} 269 | \fi 270 | \let\OTTALTNEWLINE\relax 271 | \ignorespaces 272 | } 273 | {% 274 | \@ifundefined{ottafterlastrule}{\\}{\ottafterlastrule}% 275 | \ifottalt@supertabular 276 | \end{supertabular} 277 | \else 278 | \end{tabular} 279 | \fi 280 | \endtrivlist 281 | \endgroup 282 | \ignorespaces 283 | } 284 | \newcommand\newNTclass[2][\ifnotalternateNonterms]{ 285 | \expandafter\newcommand\csname new#2s\endcsname[4][]{ 286 | #1{ 287 | \expandafter\newcommand\csname ottalt@NT@#2@##2\endcsname{##1{##3}} 288 | }{ 289 | \expandafter\newcommand\csname ottalt@NT@#2@##2\endcsname{##4} 290 | } 291 | } 292 | \expandafter\newcommand\csname new#2\endcsname[3][]{ 293 | \csname new#2s\endcsname[##1]{##2}{##3}{##3} 294 | } 295 | \expandafter\newcommand\csname #2\endcsname[1]{% 296 | \csname ottalt@NT@#2@##1\endcsname 297 | } 298 | } 299 | \providecommand\@ifToif[1]{% 300 | #1\iftrue\iffalse 301 | } 302 | \providecommand\ifTo@if[1]{% 303 | #1% 304 | \expandafter\@firstoftwo 305 | \else 306 | \expandafter\@secondoftwo 307 | \fi 308 | } 309 | \newcommand\NTOVERLINE{\NTCAPTURE\overline} 310 | \newcommand\NTUNDERLINE{\NTCAPTURE\underline} 311 | \newcommand\NTTEXTCOLOR[1]{\NTCAPTURE{\textcolor{#1}}} 312 | \newcommand\NTCAPTURE[1]{\NTCAPTURELOW{\NTCAPTURE@FINISH{#1}}} 313 | \newcommand\NTCAPTURE@FINISH[4]{#1{#2_{#3}#4}} 314 | \newcommand\NTCAPTURELOW[2]{\NT@CAPTURE@LOOP{#1}{#2}\relax\relax} 315 | \newcommand\NT@CAPTURE@LOOP[4]{% 316 | \@ifnextchar _{% 317 | \NT@CAPTURE@SUB{#1}{#2}{#3}{#4}% 318 | }{\@ifnextchar '{% 319 | \NT@CAPTURE@PRIME{#1}{#2}{#3}{#4}% 320 | }{% 321 | {#1{#2}{#3}{#4}}% 322 | }}% 323 | } 324 | \def\NT@CAPTURE@SUB#1#2#3#4_#5{\NT@CAPTURE@LOOP{#1}{#2}{#3#5}{#4}} 325 | \def\NT@CAPTURE@PRIME#1#2#3#4'{\NT@CAPTURE@LOOP{#1}{#2}{#3}{#4'}} 326 | \endinput 327 | %% 328 | %% End of file `ottalt.sty'. 329 | -------------------------------------------------------------------------------- /GraD/src-def/semimodule.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Coq.Classes.EquivDec. 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | 9 | Require Import Qtt.tactics. 10 | Require Import Qtt.usage. 11 | Require Import Qtt.dctx. 12 | Require Import Qtt.dctx_sub. 13 | 14 | (* A Q-left semimodule is the definition of a carrier set M with commutative monoid structure (M,+,0) and left multiplication function. 15 | 16 | • for 𝑞1, 𝑞2 ∈ 𝑄 and 𝑚∈𝑀, we have (𝑞1 + 𝑞2) ⊙ 𝑚 = 𝑞1 ⊙ 𝑚 ⊕ 𝑞2 ⊙ 𝑚 [distrib2] 17 | • for 𝑞 ∈ 𝑄 and 𝑚1,𝑚2 ∈ 𝑀, we have, 𝑞 ⊙ (𝑚1 ⊕ 𝑚2) = 𝑞 ⊙ 𝑚1 ⊕ 𝑞 ⊙ 𝑚2 [distrib] 18 | •for 𝑞1, 𝑞2 ∈𝑄 and 𝑚∈𝑀,we have (𝑞1·𝑞2) ⊙ 𝑚 = 𝑞1 ⊙ (𝑞2 ⊙ 𝑚) [mul_assoc] 19 | • for 𝑚 ∈ 𝑀, we have 1 ⊙ 𝑚 = 𝑚 [mul_id] 20 | • for 𝑞 ∈ 𝑄 and 𝑚 ∈ 𝑀, we have 0 ⊙ 𝑚 = 𝑞 ⊙ 0 = 0. [mul_zero1, mul_zero2] 21 | 22 | A left 𝑄-semimodule 𝑀 is said to be partially-ordered iff there exists a partial order ≤𝑀 on 𝑀 such that the following properties hold. 23 | • for 𝑚1,𝑚2, 𝑚 ∈ 𝑀, if 𝑚1 ≤𝑀 𝑚2, then 𝑚 ⊕ 𝑚1 ≤𝑀 𝑚 ⊕ 𝑚2 [ctx_sub_ctx_plus] 24 | • for 𝑞 ∈ 𝑄 and 𝑚1,𝑚2 ∈ 𝑀, if 𝑚1 ≤𝑀 𝑚2, then 𝑞 ⊙ 𝑚1 ≤𝑀 𝑞 ⊙ 𝑚2 [po_semiring_context] 25 | • for 𝑞1,𝑞2 ∈𝑀 and 𝑚∈𝑀, if 𝑞1 ≤𝑞2, then 𝑞1 ⊙ 𝑚 ≤ 𝑀 𝑞2 ⊙ 𝑚. [ctx_sub_ctx_mul] 26 | *) 27 | 28 | (* Here we show that contexts form a module; uses ctx_plus, ctx_mul, and ctx_sub. *) 29 | 30 | (* We reorient some of these properties so that we can add them to rewr_list hint database. 31 | That way they will be automatically applied by the [simpl_env] tactic. *) 32 | 33 | 34 | Section CtxMod. 35 | 36 | Variables A:Type. 37 | 38 | (* First, ctx_plus with 0=(ctx_mul 0 G) is a commutative monoid. *) 39 | 40 | Lemma ctx_plus_0_l : forall (G:list(atom*(usage*A))), 41 | G = ctx_plus (ctx_mul 0 G) G. 42 | Proof. 43 | induction G; simpl. auto. 44 | destruct a as [x [q1 ?]]. 45 | simpl. 46 | ring_equal. 47 | auto. 48 | Qed. 49 | 50 | Lemma ctx_plus_0_r : forall (G:list(atom*(usage*A))), 51 | G = ctx_plus G (ctx_mul 0 G). 52 | Proof. 53 | induction G; simpl. auto. 54 | destruct a as [x [q1 ?]]. 55 | simpl. 56 | ring_equal. 57 | auto. 58 | Qed. 59 | 60 | (* if we add a pre-condition, we can generalize this identity. *) 61 | 62 | Lemma ctx_ctx_plus_0_l : forall {D:list(atom*A)} {G1 G2}, 63 | ctx D G1 -> 64 | ctx D G2 -> 65 | ctx_plus (ctx_mul 0 G1) G2 = G2. 66 | Proof. 67 | induction D; intros; destruct_ctx; simpl. auto. 68 | ring_equal. 69 | auto. 70 | Qed. 71 | 72 | Lemma ctx_ctx_plus_0_r : forall {D:list(atom*A)} {G1 G2}, 73 | ctx D G1 -> 74 | ctx D G2 -> 75 | ctx_plus G2 (ctx_mul 0 G1) = G2. 76 | Proof. 77 | induction D; intros; destruct_ctx; simpl. auto. 78 | ring_equal. 79 | auto. 80 | Qed. 81 | 82 | (* Associativity also has a precondition. *) 83 | 84 | Lemma ctx_plus_assoc : forall D (G1:list(atom*(usage*A))) G2 G3, 85 | ctx D G1 -> 86 | ctx D G2 -> 87 | ctx D G3 -> 88 | ctx_plus (ctx_plus G1 G2) G3 = ctx_plus G1 (ctx_plus G2 G3). 89 | Proof. 90 | induction D; intros; invert_ctx; simpl; auto. 91 | f_equal. f_equal. f_equal. ring_equal. 92 | eauto. 93 | Qed. 94 | 95 | 96 | Lemma ctx_plus_comm : 97 | forall D (G1:list(atom*(usage*A))) G2, ctx D G1 -> ctx D G2 -> ctx_plus G1 G2 = ctx_plus G2 G1. 98 | Proof. 99 | induction D; intros; invert_ctx. auto. 100 | simpl. 101 | f_equal. f_equal. rewrite qplus_comm. auto. 102 | rewrite IHD; auto. 103 | Qed. 104 | 105 | 106 | 107 | (* Next, the explicit module laws *) 108 | 109 | Lemma ctx_distrib2 q1 q2 (G:list(atom*(usage*A))) : forall (D:list(atom*A)) G1 G2, ctx D G1 -> ctx D G2 -> 110 | ctx_plus (ctx_mul q1 G) (ctx_mul q2 G) = ctx_mul (q1 + q2) G. 111 | Proof. 112 | induction G. intros. simpl. auto. 113 | intros. destruct a as [x [? ?]]. 114 | simpl. 115 | rewrite distr_l. 116 | f_equal. 117 | eauto. 118 | Qed. 119 | 120 | 121 | Lemma ctx_distrib1 r D (G1:list(atom*(usage*A))) : ctx D G1 -> forall G G2, ctx D G2 -> 122 | G = ctx_plus G1 G2 -> (ctx_mul r G) = ctx_plus (ctx_mul r G1) (ctx_mul r G2). 123 | Proof. 124 | induction 1; intros; invert_ctx. auto. 125 | simpl. 126 | rewrite distr_r. 127 | f_equal. 128 | auto. 129 | Qed. 130 | 131 | Lemma ctx_distrib {r D}{G1:list(atom*(usage*A))} G2 : ctx D G1 -> ctx D G2 -> 132 | ctx_mul r (ctx_plus G1 G2) = ctx_plus (ctx_mul r G1) (ctx_mul r G2). 133 | Proof. 134 | intros. 135 | eapply ctx_distrib1; eauto. 136 | Qed. 137 | 138 | 139 | Lemma ctx_mul_assoc q1 q2 {G:list(atom*(usage*A))} : ctx_mul q1 (ctx_mul q2 G) = ctx_mul (q1 * q2) G. 140 | Proof. 141 | induction G; simpl; try done. 142 | destruct a as [x [? ?]]. 143 | simpl. 144 | rewrite IHG. 145 | rewrite qmul_assoc. 146 | auto. 147 | Qed. 148 | 149 | Lemma ctx_mul_id : forall {G:list(atom*(usage*A))}, ctx_mul 1 G = G. 150 | Proof. 151 | induction G. auto. 152 | destruct a as [x [? ?]]. 153 | simpl. rewrite IHG. 154 | rewrite qmul_1_l. auto. 155 | Qed. 156 | 157 | (* The identities for multiplying by zero are a bit tricky. ctx_mul 0 G is defined to be zero, for any G. 158 | So the identities listed above are a bit trivial. 159 | *) 160 | 161 | (* This lemma says that all zeros are the same *) 162 | Lemma same_ctx : forall {D}{G1:list(atom*(usage*A))}, ctx D G1 -> forall G2, ctx D G2 -> ctx_mul 0 G1 = ctx_mul 0 G2. 163 | Proof. 164 | induction 1; intros; invert_ctx; simpl_env. auto. 165 | simpl. erewrite IHctx. 166 | repeat rewrite qmul_0_l. 167 | f_equal. 168 | auto. 169 | Qed. 170 | 171 | (* This is another variant of the same lemma *) 172 | Lemma ctx_mul_0_eq : forall {G1 G2:list(atom*(usage*A))}, ctx_mul 0 G1 = G2 -> ctx_mul 0 G2 = G2. 173 | Proof. 174 | intros G1. induction G1. 175 | - intros. destruct G2; inversion H. auto. 176 | - intros. simpl in H. destruct a. destruct p. simpl in H. 177 | destruct G2; inversion H. 178 | destruct p. destruct p. inversion H1. subst. clear H1. 179 | asimpl. rewrite ctx_mul_assoc. asimpl. auto. 180 | Qed. 181 | 182 | (* --------------- Partially-ordered semimodule ------------------- *) 183 | 184 | 185 | Lemma po_semiring_context {q}{D:list(atom*A)}{G1 G2} : 186 | ctx_sub D G1 G2 187 | -> ctx_sub D (ctx_mul q G1) (ctx_mul q G2). 188 | Proof. 189 | induction 1. simpl. auto. 190 | simpl. econstructor; auto. 191 | eapply po_semiring3. auto. 192 | Qed. 193 | 194 | 195 | 196 | Lemma ctx_sub_ctx_mul: forall {D} {G:list(atom*(usage*A))} {q3 q0}, q3 <= q0 -> ctx D G -> ctx_sub D (ctx_mul q3 G) (ctx_mul q0 G). 197 | Proof. induction 2. simpl. auto. 198 | econstructor; auto. apply po_semiring2. auto. 199 | Qed. 200 | 201 | 202 | 203 | Lemma ctx_sub_ctx_plus_aux: 204 | forall {D}{G3':list(atom*(usage*A))} {G3}, 205 | ctx_sub D G3' G3 -> forall G, ctx D G -> 206 | ctx_sub D (ctx_plus G3' G) (ctx_plus G3 G). 207 | Proof. 208 | induction 1; intros; invert_ctx; simpl; auto. 209 | econstructor; eauto. 210 | eapply qplus_sub_r; auto. 211 | Qed. 212 | 213 | Lemma ctx_sub_ctx_plus: forall {D:list (atom*A)}{G1 G1' G2 G2'}, 214 | ctx_sub D G1 G1' -> ctx_sub D G2 G2' -> 215 | ctx_sub D (ctx_plus G1 G2) (ctx_plus G1' G2'). 216 | Proof. 217 | intros. 218 | transitivity (ctx_plus G1 G2'). 219 | rewrite (@ctx_plus_comm D G1 G2); try eassumption. 220 | eapply ctx_sub_ctx1; eauto. 221 | eapply ctx_sub_ctx1; eauto. 222 | rewrite (@ctx_plus_comm D G1 G2'); try eassumption. 223 | eapply ctx_sub_ctx1; eauto. 224 | eapply ctx_sub_ctx2; eauto. 225 | eapply ctx_sub_ctx_plus_aux; eauto. 226 | eapply ctx_sub_ctx1; eauto. 227 | eapply ctx_sub_ctx_plus_aux; eauto. 228 | eapply ctx_sub_ctx2; eauto. 229 | Qed. 230 | 231 | 232 | (* --------------- Derived properties ------------------- *) 233 | 234 | 235 | Lemma ctx_plus_sub: forall {D1} {G1 G2' G2:list(atom*(usage*A))}, ctx D1 G1 -> 236 | G2' = ctx_mul 0 G2' -> 237 | ctx_sub D1 G2' G2 -> ctx_sub D1 G1 (ctx_plus G1 G2). 238 | Proof. 239 | induction D1; intros; invert_ctx; simpl; auto. 240 | inversion H1. auto. 241 | simpl_env in *. inversion H1. subst. simpl. 242 | unfold ctx_mul in H0. simpl_env in H0. inversion H0. 243 | econstructor. auto. eapply qplus_sub. rewrite H2 in H5. ring_simpl in H5. auto. 244 | eauto. auto. 245 | Qed. 246 | 247 | 248 | 249 | Lemma ctx_plus_swap: forall {D:list(atom*A)} a, 250 | ctx D a -> forall b c d, ctx D b -> 251 | ctx D c -> ctx D d -> 252 | ctx_plus (ctx_plus a b) (ctx_plus c d) = 253 | ctx_plus (ctx_plus a c) (ctx_plus b d). 254 | Proof. 255 | induction 1; intros; 256 | simpl in *. 257 | - inversion H. inversion H0. inversion H1. auto. 258 | - inversion H1. inversion H2. inversion H3. subst. 259 | asimpl. 260 | rewrite IHctx; try eclarify_ctx. 261 | f_equal. 262 | f_equal. 263 | f_equal. 264 | f_equal. 265 | f_equal. 266 | rewrite <- qplus_assoc. 267 | rewrite <- qplus_assoc. 268 | f_equal. 269 | rewrite qplus_comm. 270 | auto. 271 | Qed. 272 | 273 | 274 | 275 | Lemma ctx_plus_ctx_mul_0 : forall (G:list(atom*(usage*A))) G1 G2, G = ctx_plus (ctx_mul 0 G1) (ctx_mul 0 G2) -> 276 | G = ctx_mul 0 G. 277 | Proof. 278 | induction G; intros; simpl; auto. 279 | destruct a as [x [q ?]]. 280 | destruct G1 as [|[y [q1' ?]]]; 281 | destruct G2 as [|[z [q1 ?]]]; simpl in H; try inversion H. subst. clear H. 282 | simpl. repeat rewrite qmul_0_l. repeat rewrite qplus_0_l. 283 | repeat f_equal. 284 | eauto. 285 | Qed. 286 | 287 | 288 | End CtxMod. 289 | 290 | 291 | (* by adding these lemmas to the rewr_list hint database, it will be automatically 292 | applied by the [simpl_env] tactic. *) 293 | 294 | Hint Rewrite ctx_mul_id : rewr_list. 295 | Hint Rewrite ctx_mul_assoc : rewr_list. 296 | Hint Rewrite ctx_distrib2 : rewr_list. 297 | 298 | Hint Rewrite ctx_ctx_plus_0_l ctx_ctx_plus_0_r : rewr_list. 299 | -------------------------------------------------------------------------------- /GraD/src-def/spec.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/graded-haskell/986ac74f0cb5d38c11307beb5b05e9eb2e0bd0ed/GraD/src-def/spec.pdf -------------------------------------------------------------------------------- /GraD/src-def/spec.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \usepackage{ottalt} 4 | \usepackage{mathpartir} 5 | \usepackage{supertabular} 6 | 7 | \usepackage{amsmath} 8 | \usepackage{amssymb} 9 | 10 | \usepackage{color} 11 | 12 | 13 | %% Show admissible premises in rules 14 | %% This should be false in main body of text and true in the appendix. 15 | \newif\ifadmissible 16 | \newcommand\suppress[1]{\ifadmissible{#1}\else{}\fi} 17 | \inputott{dqtt-rules} 18 | 19 | \title{System Specification} 20 | 21 | \admissiblefalse 22 | \begin{document} 23 | \maketitle 24 | 25 | This document is created directly from the definitions in the file 26 | {\texttt{dqtt.ott}}, with minor modifications listed below. 27 | 28 | It is intended to specify, in a readable form, the syntactic type soundness 29 | proof. 30 | 31 | Note: there is one change here from the syntax shown in the paper. We replace 32 | the pattern matching elimination form for $\Sigma$ types with a slightly more 33 | general, but less familiar, form. 34 | 35 | The reason for this change is that the Ott and LNgen tools limit language 36 | specifications to single binding only. This prevents us from the usual 37 | definition of the pattern matching elimination form for 38 | $\Sigma$-types. Instead, we use an elimination form called ``spread'' of the 39 | form 40 | \[ 41 | \ottkw{spread}\, \ottnt{a} \, \ottkw{to}\, \ottmv{x} \, \ottkw{in}\, \ottnt{b} 42 | \] 43 | This syntactic form binds the variable $x$ (corresponding to the first 44 | component of the product) in the body $b$. The body $b$ must itself be a 45 | function, where the argument is the second component of the tuple. 46 | 47 | In other words, we can encode an elimination of an argument $a$ 48 | of type $ \Sigma \ottmv{x} \!\!:^ \ottnt{q} \!\! \ottnt{A} . \ottnt{B} $, that uses 49 | the usual pattern matching syntax 50 | \[ 51 | \ottkw{let}\, (\ottmv{x},\ottmv{y}) \,=\, \ottnt{a} \ \ottkw{in}\ \ottnt{b} 52 | \] 53 | 54 | by using the term 55 | \[ 56 | \ottkw{spread}\, \ottnt{a} \, \ottkw{to}\, \ottmv{x} \, \ottkw{in}\, \lambda \ottmv{y} \!:^ \ottnt{q} \! \ottnt{A} . \ottnt{b} 57 | \] 58 | 59 | \section{Grammar} 60 | 61 | \ottgrammartabular{ 62 | \ottusage\ottinterrule 63 | \otttm\ottinterrule 64 | \ottcontext\ottinterrule 65 | \ottD\ottafterlastrule 66 | } 67 | 68 | 69 | \section{Step relation} 70 | \ottdefnsJOp{} 71 | \section{Typing relation} 72 | 73 | Another issue with $\Sigma$ types is that Ott cannot express the complete 74 | typing rule for $\ottkw{spread}$. Therefore we need to modify the generate 75 | Coq definition to include the appropriate substitution. This document includes the 76 | corresponding change in the typeset rule \textsc{T-Spread}. 77 | 78 | \newcommand{\ottdruleTXXSpreadAlt}[1]{\ottdrule[#1]{% 79 | \ottpremise{\ottnt{A} \ottsym{=} \Sigma \ottmv{x} \!\!:^ \ottnt{q} \!\! \ottnt{A_{{\mathrm{1}}}} . \ottnt{A_{{\mathrm{2}}}} }% 80 | \ottpremise{ \Delta ; \Gamma_{{\mathrm{1}}} \vdash \ottnt{a} : \ottnt{A} }% 81 | \ottpremise{ \Delta , \ottmv{x} \!\!:\!\! \ottnt{A_{{\mathrm{1}}}} ; \Gamma_{{\mathrm{2}}} , \ottmv{x} \!\!:^{ \ottnt{q} }\!\! \ottnt{A_{{\mathrm{1}}}} \vdash \ottnt{b} : \Pi \ottmv{y} \!:^ \ottsym{1} \! \ottnt{A_{{\mathrm{2}}}} . \ottnt{B} \ottsym{\{} (\ottmv{x},\ottmv{y}) \ottsym{/} \ottmv{z} \ottsym{\}} }% 82 | \ottpremise{ \Delta , \ottmv{z} \!\!:\!\! \ottnt{A} ; \Gamma_{{\mathrm{3}}} , \ottmv{z} \!\!:^{ \ottnt{r} }\!\! \ottnt{A} \vdash \ottnt{B} : \ottkw{type} }% 83 | }{ 84 | \Delta ; \Gamma_{{\mathrm{1}}} \ottsym{+} \Gamma_{{\mathrm{2}}} \vdash \ottkw{spread}\, \ottnt{a} \, \ottkw{to}\, \ottmv{x} \, \ottkw{in}\, \ottnt{b} : \ottnt{B} \ottsym{\{} \ottnt{a} \ottsym{/} \ottmv{z} \ottsym{\}} }{% 85 | {\ottdrulename{T\_Spread}}{}% 86 | }} 87 | 88 | 89 | \begin{ottdefnblock}[#1]{$ \Delta ; \Gamma \vdash \ottnt{a} : \ottnt{A} $}{\ottcom{Typing}} 90 | \ottusedrule{\ottdruleTXXsub{}} 91 | \ottusedrule{\ottdruleTXXtype{}} 92 | \ottusedrule{\ottdruleTXXvar{}} 93 | \ottusedrule{\ottdruleTXXweak{}} 94 | \ottusedrule{\ottdruleTXXdef{}} 95 | \ottusedrule{\ottdruleTXXweakXXdef{}} 96 | \ottusedrule{\ottdruleTXXpi{}} 97 | \ottusedrule{\ottdruleTXXlam{}} 98 | \ottusedrule{\ottdruleTXXapp{}} 99 | \ottusedrule{\ottdruleTXXconv{}} 100 | \ottusedrule{\ottdruleTXXunit{}} 101 | \ottusedrule{\ottdruleTXXUnit{}} 102 | \ottusedrule{\ottdruleTXXUnitE{}} 103 | \ottusedrule{\ottdruleTXXBox{}} 104 | \ottusedrule{\ottdruleTXXbox{}} 105 | \ottusedrule{\ottdruleTXXletbox{}} 106 | \ottusedrule{\ottdruleTXXsum{}} 107 | \ottusedrule{\ottdruleTXXinjOne{}} 108 | \ottusedrule{\ottdruleTXXinjTwo{}} 109 | \ottusedrule{\ottdruleTXXcase{}} 110 | \ottusedrule{\ottdruleTXXSigma{}} 111 | \ottusedrule{\ottdruleTXXTensor{}} 112 | \ottusedrule{\ottdruleTXXSpreadAlt{}} 113 | \ottusedrule{\ottdruleTXXWith{}} 114 | \ottusedrule{\ottdruleTXXPair{}} 115 | \ottusedrule{\ottdruleTXXPrjOne{}} 116 | \ottusedrule{\ottdruleTXXPrjTwo{}} 117 | \end{ottdefnblock} 118 | 119 | 120 | 121 | 122 | \end{document} 123 | -------------------------------------------------------------------------------- /GraD/src-def/tactics.v: -------------------------------------------------------------------------------- 1 | Require Import Qtt.dqtt_ott. 2 | Require Import Qtt.dqtt_inf. 3 | 4 | Ltac gather_atoms ::= 5 | let A := gather_atoms_with (fun x : vars => x) in 6 | let B := gather_atoms_with (fun x : var => {{ x }}) in 7 | let C := gather_atoms_with (fun x : context => dom x) in 8 | let D := gather_atoms_with (fun x => fv_tm_tm x) in 9 | let E := gather_atoms_with (fun x : list (atom * sort) => dom x) in 10 | 11 | constr:(A \u B \u C \u D \u E). 12 | 13 | 14 | Ltac invert_equality := 15 | repeat match goal with 16 | | [H : (_,_) = (_,_) |- _ ] => inversion H; subst; clear H 17 | | [H : (_,_,_) = (_,_,_) |- _ ] => inversion H; subst; clear H 18 | | [H : (_,_,_,_) = (_,_,_,_) |- _ ] => inversion H; subst; clear H 19 | | [H : [_] ++ _ = [_] ++ _ |- _ ] => inversion H; subst; clear H 20 | | [H : ( _ :: _ ) = ( _ :: _ ) |- _ ] => inversion H; subst; clear H 21 | end. 22 | -------------------------------------------------------------------------------- /GraD/src-def/usage.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Coq.Classes.EquivDec. 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | 9 | Require Export usage_sig. 10 | 11 | (* ----------------------------------------------------------------- *) 12 | (* Lemmas about the usage pre-order / semi-ring. *) 13 | (* ----------------------------------------------------------------- *) 14 | 15 | Open Scope usage_scope. 16 | 17 | (* --------------- Derived lemmas below here. -------------------- *) 18 | 19 | Lemma usage_dec : forall x y, x =? y = true -> x = y. 20 | Proof. intros. rewrite -> eqb_eq in H. auto. Qed. 21 | 22 | (* --------------------------- *) 23 | 24 | Lemma qplus_0_r : forall x, x + 0 = x. 25 | Proof. 26 | intros. rewrite qplus_comm. rewrite qplus_0_l. auto. 27 | Qed. 28 | 29 | (* --------------------------- *) 30 | 31 | Lemma qplus_sub_r : forall u2 u u1, u1 <= u2 -> u1 + u <= u2 + u. 32 | Proof. 33 | intros; eapply po_semiring1; auto. 34 | Qed. 35 | 36 | Lemma qplus_sub_l : forall u2 u u1, u1 <= u2 -> u + u1 <= u + u2. 37 | Proof. 38 | intros; repeat rewrite (qplus_comm u). 39 | apply po_semiring1. auto. 40 | Qed. 41 | 42 | 43 | Lemma qplus_sub q1 q2 : 0 <= q2 -> q1 <= q1 + q2. 44 | Proof. 45 | intros. 46 | move: (po_semiring1 _ _ q1 H) => h. 47 | rewrite qplus_0_l in h. 48 | rewrite qplus_comm. 49 | auto. 50 | Qed. 51 | 52 | Lemma qmul_sub2 q1 q2 : 1 <= q2 -> q1 <= q1 * q2. 53 | Proof. 54 | move: (po_semiring3 1 q2 q1) => h. 55 | rewrite qmul_1_r in h. 56 | auto. 57 | Qed. 58 | 59 | Lemma qmul_sub_disposable : forall r q, 0 <= r -> 0 <= q * r. 60 | Proof. 61 | intros. 62 | move: (po_semiring3 _ _ q H) => h. 63 | rewrite qmul_0_r in h. 64 | auto. 65 | Qed. 66 | 67 | (* ----------------------------------------------------------------- *) 68 | (* Tactics and Hints *) 69 | (* ----------------------------------------------------------------- *) 70 | 71 | (* 72 | Add Ring usage_semi_ring : usage_semi_ring (decidable usage_dec). 73 | Hint Resolve usage_semi_ring : usage. 74 | *) 75 | 76 | Hint Rewrite qplus_0_l qplus_0_r qmul_0_l qmul_0_r qmul_1_l qmul_1_r qplus_assoc qmul_assoc distr_l distr_r : usage. 77 | 78 | Ltac ring_simpl := 79 | repeat autorewrite with usage. 80 | 81 | Tactic Notation "ring_simpl" "in" hyp(H) := 82 | repeat autorewrite with usage in H. 83 | 84 | Ltac ring_equal := 85 | repeat (ring_simpl; f_equal). 86 | 87 | Ltac asimpl := repeat (simpl; ring_simpl; simpl_env). 88 | 89 | Tactic Notation "asimpl" "in" hyp(H) := 90 | repeat (simpl in H; ring_simpl in H; simpl_env in H). 91 | 92 | 93 | (* ---------------------------------------------------------------- *) 94 | 95 | -------------------------------------------------------------------------------- /GraD/src-def/usage_sig.v: -------------------------------------------------------------------------------- 1 | (* Parameterization of the po-semiring *) 2 | 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | 9 | Module Type UsageSig. 10 | 11 | Parameter usage : Set. 12 | Parameter Irr : usage. 13 | Parameter Lin : usage. 14 | Parameter qeqb : usage -> usage -> bool. 15 | Parameter qleb : usage -> usage -> bool. 16 | Parameter qplus : usage -> usage -> usage. 17 | Parameter qmul : usage -> usage -> usage. 18 | 19 | (* Equality *) 20 | Definition t := usage. 21 | Definition eq := @Logic.eq usage. 22 | Definition eqb := qeqb. 23 | Parameter q_eq_dec : forall (A : usage) (B : usage), { A = B } + { not (A = B) }. 24 | Instance equ : @EqDec_eq usage := q_eq_dec. 25 | Parameter eqb_eq : forall (n m : usage), qeqb n m = true <-> n = m. 26 | Definition eq_equiv : Equivalence (@Logic.eq usage) := eq_equivalence. 27 | Definition eq_dec := q_eq_dec. 28 | Include BackportEq. 29 | 30 | (* Size *) 31 | Definition size_usage : usage -> nat := fun _ => 1%nat. 32 | Lemma size_usage_min : forall q1, (1 <= size_usage q1). intros. unfold size_usage. auto. Qed. 33 | 34 | (* Notation *) 35 | Declare Scope usage_scope. 36 | Bind Scope usage_scope with usage. 37 | Local Open Scope usage_scope. 38 | 39 | Infix "=?" := qeqb (at level 70) : usage_scope. 40 | Infix "<=?" := qleb (at level 70) : usage_scope. 41 | Notation "q1 <= q2" := (is_true (qleb q1 q2)) (at level 70) : usage_scope. 42 | Notation "0" := Irr : usage_scope. 43 | Notation "1" := Lin : usage_scope. 44 | Notation "x + y" := (qplus x y) : usage_scope. 45 | Notation "x * y " := (qmul x y) : usage_scope. 46 | 47 | (* (Semi-)ring *) 48 | Axiom qplus_0_l : forall x, 0 + x = x. 49 | Axiom qmul_0_l : forall x, 0 * x = 0. 50 | Axiom qplus_comm : forall (n m : usage), n + m = m + n. 51 | Axiom qplus_assoc : forall (n m p : usage), n + (m + p) = (n + m) + p. 52 | Axiom qmul_1_l : forall n, 1*n = n. 53 | (*Axiom qmul_comm : forall n m, n*m = m*n. *) 54 | Axiom qmul_assoc : forall n m p, n*(m*p) = (n*m)*p. 55 | Axiom distr_l : forall n m p, (n + m)*p = n*p + m*p. 56 | 57 | (* Cannot derive these if multiplication is not commutative *) 58 | Axiom qmul_0_r : forall x, x * 0 = 0. 59 | Axiom qmul_1_r : forall n, n*1 = n. 60 | Axiom distr_r : forall n m p, p * (n + m) = p * n + p * m. 61 | 62 | (* Partial order *) 63 | Definition leb := qleb. 64 | Definition le n m := is_true (qleb n m). 65 | Axiom leb_le : forall (n m : usage), (n <=? m) = true <-> n <= m. 66 | Axiom qleb_refl : forall n, is_true (n <=? n). 67 | Axiom qleb_trans: forall m n p, is_true (n <=? m) -> is_true (m <=? p) -> is_true (n <=? p). 68 | 69 | Instance le_preorder : PreOrder le. 70 | Proof. split. intro x. apply qleb_refl. unfold Transitive. intros. eapply qleb_trans; eauto. Qed. 71 | 72 | Axiom po_semiring1 : forall a b c , a <= b -> a + c <= b + c. 73 | Axiom po_semiring2 : forall a b c , a <= b -> a * c <= b * c. 74 | Axiom po_semiring3 : forall a b c , a <= b -> c * a <= c * b. 75 | 76 | End UsageSig. 77 | 78 | Declare Module Usage : UsageSig. 79 | Export Usage. 80 | 81 | 82 | (* Graded contexts, i.e. association lists that include annotated usage information *) 83 | 84 | Section UsageCtx. 85 | Variables A : Type. 86 | 87 | Local Open Scope usage_scope. 88 | 89 | 90 | Definition sort_mul (q: usage) (s : usage * A) : usage * A := 91 | match s with 92 | | (q1 , A) => (qmul q q1, A) 93 | end. 94 | 95 | Definition ctx_mul (q : usage) G := 96 | map (sort_mul q) G. 97 | 98 | 99 | Definition add_usage (q : usage) (D: list (var * A)) : list (var * (usage * A)) := 100 | map (fun x => (q, x)) D. 101 | 102 | Definition ungrade (G: list (var * (usage * A))) : list (var * A) := 103 | map snd G. 104 | 105 | Fixpoint ctx_plus (G1 G2 : list (var * (usage * A))) : list (var * (usage * A)) := 106 | match G1, G2 with 107 | | nil , nil => nil 108 | | cons (x , (q1 , A)) G1' , cons (_, (q2, _)) G2' => cons (x, (q1 + q2, A)) (ctx_plus G1' G2') 109 | | _ , _ => nil 110 | end. 111 | 112 | Inductive ctx : list (atom * A) -> list (atom * (usage * A)) -> Prop := 113 | | ctx_nil : 114 | ctx nil nil 115 | | ctx_cons : forall D (x:atom) G (q:usage) a, 116 | ctx D G -> 117 | ~ AtomSetImpl.In x (dom D) -> 118 | ctx (x ~ a ++ D ) (x ~ (q,a) ++ G). 119 | 120 | Inductive ctx_sub : list (atom * A) -> list (atom * (usage * A))-> list (atom * (usage * A)) -> Prop := 121 | | CS_Empty : ctx_sub nil nil nil 122 | | CS_ConsTm : forall D (x:atom) (a:A) G1 (q1:usage) G2 q2, 123 | ( q1 <= q2 ) -> 124 | ctx_sub D G1 G2 -> 125 | ~ AtomSetImpl.In x (dom D) -> 126 | ctx_sub (x ~ a ++ D) (x ~ (q1 ,a) ++ G1) (x ~ (q2,a) ++ G2). 127 | 128 | End UsageCtx. 129 | 130 | 131 | 132 | Section UsageList. 133 | Local Open Scope usage_scope. 134 | 135 | Fixpoint oplus (G1 G2 : list usage) : list usage := 136 | match G1, G2 with 137 | | nil , nil => nil 138 | | cons q1 G1' , cons q2 G2' => cons (q1 + q2) (oplus G1' G2') 139 | | _ , _ => nil 140 | end. 141 | 142 | Definition ozero {A} (G : list A) : list usage := 143 | List.map (fun _ => 0) G. 144 | 145 | Definition Qs {A} (h : list (atom * (usage * A))) : list usage := 146 | List.map (fun x => match x with | (_,(u, _)) => u end) h. 147 | 148 | Lemma Qs_app : forall {A} (h1 h2 : list (atom * (usage * A))), Qs (h1 ++ h2) = Qs h1 ++ Qs h2. 149 | Proof. 150 | intros. 151 | unfold Qs. 152 | rewrite List.map_app. 153 | auto. 154 | Qed. 155 | 156 | End UsageList. 157 | 158 | Arguments sort_mul {_}. 159 | Arguments ctx_mul {_}. 160 | Arguments ctx_plus {_}. 161 | Arguments ctx {_}. 162 | Arguments ctx_sub {_}. 163 | Arguments add_usage {_}. 164 | Arguments ungrade {_}. 165 | 166 | Hint Constructors ctx : core. 167 | Hint Constructors ctx_sub : core. 168 | 169 | 170 | -------------------------------------------------------------------------------- /GraD/src/Makefile: -------------------------------------------------------------------------------- 1 | OTT_SOURCE = dqtt 2 | OTT_LOC = . 3 | FILES = dqtt_ott dqtt_inf 4 | OTTFILES = $(foreach i, qtt, $(OTT_LOC)/$(i).ott) 5 | OTTIFLAGS = $(foreach i, qtt, -i $(OTT_LOC)/$(i).ott) 6 | 7 | ################ latex #################### 8 | 9 | SPEC = dqtt.ott 10 | SPECFILE = spec.tex 11 | RULESFILE = dqtt-rules.tex 12 | 13 | ../spec.pdf: $(SPEC) $(SPECFILE) 14 | ott -o $(RULESFILE) \ 15 | -tex_wrap false \ 16 | -tex_show_meta false $(SPEC) 17 | pdflatex -interaction nonstopmode $(SPECFILE) 18 | mv spec.pdf .. 19 | 20 | $(RULESFILE): $(SPEC) 21 | ott $(OTTIFLAGS) -o $(RULESFILE) \ 22 | -tex_wrap false \ 23 | -tex_show_meta false 24 | 25 | %.tex: $(RULESFILE) %.mng Makefile 26 | ott $(OTTIFLAGS) \ 27 | -tex_wrap false \ 28 | -tex_show_meta false \ 29 | -tex_filter $*.mng $*.tex 30 | 31 | %.pdf : %.tex $(RULESFILE) 32 | latexmk -bibtex -pdf $*.tex 33 | 34 | 35 | ###################### COQ ############################## 36 | 37 | ## Paths to executables. Do not include options here. 38 | ## Modify these to suit your Coq installation, if necessary. 39 | 40 | COQC = coqc 41 | COQDEP = coqdep 42 | 43 | ## Include directories, one per line. 44 | 45 | INCDIRS = \ 46 | . \ 47 | ../metalib \ 48 | 49 | 50 | ## Library name used for the imports in Coq 51 | 52 | LIBNAME=Qtt 53 | METALIBLOCATION=../metalib 54 | LNGEN=lngen 55 | 56 | 57 | ## Name of the submakefile generated by coq_makefile 58 | COQMKFILENAME=CoqSrc.mk 59 | 60 | 61 | VFILES = $(foreach i, $(FILES), $(i).v) 62 | VOFILES = $(foreach i, $(FILES), $(i).vo) 63 | INCFLAGS = $(foreach i, $(INCDIRS), -I $(i)) 64 | 65 | .SECONDARY: $(VFILES) 66 | 67 | METALIBFILES= $(METALIBLOCATION)/*.v $(METALIBLOCATION)/Makefile $(METALIBLOCATION)/README.txt 68 | 69 | all: coq 70 | 71 | quick: $(COQMKFILENAME) 72 | @$(MAKE) -f CoqSrc.mk quick 73 | 74 | 75 | coq: $(COQMKFILENAME) $(VFILES) 76 | @$(MAKE) -f CoqSrc.mk 77 | 78 | 79 | %.vo: %.v 80 | @$(MAKE) -f CoqSrc.mk $*.vo 81 | 82 | %_inf.v: $(OTT_LOC)/%.ott Makefile 83 | $(LNGEN) --coq $*_inf.v --coq-ott $*_ott $(OTT_LOC)/$*.ott 84 | 85 | 86 | $(COQMKFILENAME): Makefile $(shell ls *.v | grep -v _ott.v | grep -v _inf.v) 87 | { echo "-R . $(LIBNAME) " ; ls *.v ; } > _CoqProject && coq_makefile -arg '-w -variable-collision,-meta-collision,-require-in-module' -f _CoqProject -o $(COQMKFILENAME) 88 | 89 | 90 | coqclean: 91 | @rm -if *.v.d *.vo *.glob *.v-e *.vok *.vos *.conf *.v-e $(VOFILES) $(COQMKFILENAME) 92 | 93 | clean: coqclean 94 | @rm -f *~ 95 | @rm -f *.log *.aux *.fls *.fdb_latexmk 96 | 97 | 98 | -------------------------------------------------------------------------------- /GraD/src/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Qtt 2 | beta.v 3 | dctx.v 4 | dctx_sub.v 5 | dqtt.v 6 | dqtt_inf.v 7 | dqtt_ott.v 8 | metalib.v 9 | semimodule.v 10 | structural.v 11 | tactics.v 12 | usage.v 13 | usage_sig.v 14 | -------------------------------------------------------------------------------- /GraD/src/beta.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Metalib.Metatheory. 3 | Require Import dqtt_ott. 4 | 5 | (* only for locally-closed terms *) 6 | Axiom Beta_lc1 : forall A B, Beta A B -> lc_tm A. 7 | Axiom Beta_lc2 : forall A B, Beta A B -> lc_tm B. 8 | 9 | 10 | Axiom B_Refl : forall (A:tm), 11 | lc_tm A -> 12 | Beta A A. 13 | 14 | Axiom B_Sym : forall (A B:tm), 15 | Beta B A -> 16 | Beta A B. 17 | Axiom B_Trans : forall (A B A1:tm), 18 | Beta A A1 -> 19 | Beta A1 B -> 20 | Beta A B. 21 | Axiom B_Step : forall (a a':tm), 22 | Step a a' -> 23 | Beta a a'. 24 | 25 | Hint Resolve B_Refl B_Sym B_Trans B_Step : core. 26 | 27 | Axiom subst_Beta1 : forall a0 x A B, lc_tm a0 -> Beta A B -> Beta (subst_tm_tm a0 x A) (subst_tm_tm a0 x B). 28 | Axiom subst_Beta2 : forall a0 a1 x B, lc_tm B -> Beta a0 a1 -> Beta (subst_tm_tm a0 x B) (subst_tm_tm a1 x B). 29 | Axiom subst_Beta : forall a0 a1 x A B, Beta a0 a1 -> Beta A B -> Beta (subst_tm_tm a0 x A) (subst_tm_tm a1 x B). 30 | 31 | Axiom invert_Beta_a_Pi0 : forall {q A B q0 A0 B0 }, Beta (a_Pi q A B) (a_Pi q0 A0 B0) -> q = q0. 32 | Axiom invert_Beta_a_Pi1 : forall {q A B q0 A0 B0 }, Beta (a_Pi q A B) (a_Pi q0 A0 B0) -> Beta A A0. 33 | Axiom invert_Beta_a_Pi2 : forall {q A B q0 A0 B0 }, Beta (a_Pi q A B) (a_Pi q0 A0 B0) -> 34 | forall x, x `notin` fv_tm_tm B \u fv_tm_tm B0 -> 35 | Beta (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm B0 (a_Var_f x)). 36 | 37 | Axiom invert_Beta_a_Sigma0 : forall {q A B q0 A0 B0 }, Beta (a_Sigma q A B) (a_Sigma q0 A0 B0) -> q = q0. 38 | Axiom invert_Beta_a_Sigma1 : forall {q A B q0 A0 B0 }, Beta (a_Sigma q A B) (a_Sigma q0 A0 B0) -> Beta A A0. 39 | Axiom invert_Beta_a_Sigma2 : forall {q A B q0 A0 B0 }, Beta (a_Sigma q A B) (a_Sigma q0 A0 B0) -> 40 | forall x, x `notin` fv_tm_tm B \u fv_tm_tm B0 -> 41 | Beta (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm B0 (a_Var_f x)). 42 | 43 | 44 | Axiom invert_Beta_Box1 : forall {q1 q2 A B}, Beta (a_Box q1 A) (a_Box q2 B) -> Beta A B. 45 | Axiom invert_Beta_Box2 : forall {q1 q2 A B}, Beta (a_Box q1 A) (a_Box q2 B) -> q1 = q2. 46 | 47 | Axiom invert_Beta_Sum1 : forall {A1 B1 A2 B2}, Beta (a_Sum A1 B1) (a_Sum A2 B2) -> Beta A1 A2. 48 | Axiom invert_Beta_Sum2 : forall {A1 B1 A2 B2}, Beta (a_Sum A1 B1) (a_Sum A2 B2) -> Beta B1 B2. 49 | 50 | 51 | Inductive consistent : tm -> tm -> Prop := 52 | | con_Type : consistent a_Type a_Type 53 | | con_Unit : consistent a_TyUnit a_TyUnit 54 | | con_Pi : forall q A B q' A' B', consistent (a_Pi q A B) (a_Pi q' A' B') 55 | | con_Sigma : forall q A B q' A' B', consistent (a_Sigma q A B) (a_Sigma q' A' B') 56 | | con_Box : forall q A A', consistent (a_Box q A) (a_Box q A') 57 | | con_Sum : forall A B A' B', consistent (a_Sum A B) (a_Sum A' B') 58 | | con_unit : consistent a_TmUnit a_TmUnit 59 | | con_lam : forall q A a A' a', consistent (a_Lam q A a) (a_Lam q A' a') 60 | | con_box : forall q q' a a', consistent (a_box q a) (a_box q' a') 61 | | con_inj1 : forall a a', consistent (a_Inj1 a) (a_Inj1 a') 62 | | con_inj2 : forall a a', consistent (a_Inj2 a) (a_Inj2 a') 63 | . 64 | Hint Constructors consistent : core. 65 | 66 | Inductive ty : tm -> Prop := 67 | | ty_Type : ty a_Type 68 | | ty_Unit : ty a_TyUnit 69 | | ty_Pi : forall q A B, ty (a_Pi q A B) 70 | | ty_Sigma : forall q A B, ty (a_Sigma q A B) 71 | | ty_Box : forall q A, ty (a_Box q A) 72 | | ty_Sum : forall A B, ty (a_Sum A B) 73 | . 74 | 75 | Inductive value : tm -> Prop := 76 | | val_ty : forall t, ty t -> value t 77 | | val_unit : value a_TmUnit 78 | | val_lam : forall q A a, value (a_Lam q A a) 79 | | val_box : forall q a, value (a_box q a) 80 | | val_inj1 : forall a, value (a_Inj1 a) 81 | | val_inj2 : forall a, value (a_Inj2 a) 82 | | val_tensor : forall a b, value (a_Tensor a b) 83 | . 84 | Hint Constructors ty value : core. 85 | 86 | Axiom Beta_consistent : forall A B, Beta A B -> value A -> value B -> consistent A B. 87 | -------------------------------------------------------------------------------- /GraD/src/dctx_sub.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Coq.Classes.EquivDec. 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | 9 | Require Import Qtt.tactics. 10 | Require Import Qtt.usage. 11 | Require Import Qtt.dctx. 12 | 13 | 14 | (* ----------------------------------------------------------------------- *) 15 | (** ** Lemmas about the context, reflecting the usage structure *) 16 | 17 | 18 | (* ----------------------------------------------------------------- *) 19 | (** *** ctx_sub properties *) 20 | 21 | Lemma ctx_sub_refl : forall {A} {D:list (atom * A)} {G}, ctx D G -> ctx_sub D G G. 22 | Proof. induction D; 23 | move => G1 h; inversion h; subst. auto. 24 | econstructor; auto. reflexivity. 25 | Qed. 26 | 27 | Lemma ctx_sub_trans : forall {A} {G2} {D:list(atom * A)} {G1 G3}, ctx_sub D G1 G2 -> ctx_sub D G2 G3 -> 28 | ctx_sub D G1 G3. 29 | Proof. 30 | move=> A G2 D. move: G2. 31 | induction D; intros; inversion H0; inversion H; subst; auto. 32 | invert_equality. 33 | econstructor; auto. 34 | transitivity q1; auto. 35 | eapply IHD; eauto. 36 | Qed. 37 | 38 | Instance cst : forall {A}{D:list (atom * A)}, Transitive (ctx_sub D). 39 | intros. eauto using ctx_sub_trans. 40 | Qed. 41 | 42 | (* Interactions with association lists *) 43 | 44 | Lemma dom_ctx_sub : forall {A} {D:list(atom*A)} {G1 G2}, ctx_sub D G1 G2 -> dom G1 = dom G2. 45 | Proof. move => A D G1 G2 h. induction h; simpl; auto. 46 | all: rewrite IHh. 47 | all: auto. 48 | Qed. 49 | 50 | Lemma uniq_ctx_sub : forall {A} {D:list(atom*A)}{ G1 G2}, ctx_sub D G1 G2 -> uniq G1 <-> uniq G2. 51 | Proof. 52 | move=> A D G1 G2 h. induction h; split; auto; 53 | move => h1; inversion h1; subst. 54 | + erewrite dom_ctx_sub in H5; eauto. 55 | econstructor; eauto. 56 | tauto. 57 | + erewrite <- dom_ctx_sub in H5; eauto. 58 | econstructor; eauto. 59 | tauto. 60 | Qed. 61 | 62 | Lemma ctx_sub_app {A} {D1 D2 : list (atom *A)}{G1 G2 G3 G4} : 63 | ctx_sub D1 G1 G2 -> ctx_sub D2 G3 G4 -> uniq (D1 ++ D2) -> 64 | ctx_sub (D1 ++ D2) (G1 ++ G3) (G2 ++ G4). 65 | Proof. 66 | induction 1. simpl. auto. 67 | all: intros h U; simpl_env; inversion U; subst. 68 | all: econstructor; eauto. 69 | Qed. 70 | 71 | (* decomposition *) 72 | 73 | Lemma split_ctx_sub {A}{D1:list (atom*A)} : forall {G G1 D2 G4 G2}, 74 | ctx D1 G -> ctx D1 G1 75 | -> ctx_sub (D1 ++ D2) (G ++ G4) (G1 ++ G2) 76 | -> ctx_sub D1 G G1 /\ ctx_sub D2 G4 G2. 77 | Proof. 78 | induction D1; intros. 79 | inversion H; inversion H0. 80 | subst. simpl in *. split; auto. 81 | inversion H; inversion H0; inversion H1. subst. 82 | simpl_env in *. 83 | repeat invert_equality. 84 | edestruct IHD1. 3: { eauto. } eclarify_ctx. eclarify_ctx. 85 | econstructor; eauto. 86 | Qed. 87 | 88 | 89 | Lemma ctx_sub_app_split_r {A} {D:list (atom*A)} : forall {G G0 G3}, 90 | ctx_sub D G (G0 ++ G3) -> 91 | exists D1 D2 G1 G2, G = G1 ++ G2 /\ D = D1 ++ D2 /\ ctx_sub D1 G1 G0 /\ ctx_sub D2 G2 G3. 92 | Proof. 93 | induction D. 94 | + intros G G0 G3 h. inversion h. exists nil. exists nil. 95 | exists nil. exists nil. 96 | repeat split; auto. 97 | destruct G0; destruct G3; simpl_env in *; inversion h. 98 | eauto. 99 | destruct G0; destruct G3; simpl_env in *; inversion h. 100 | eauto. 101 | + intros G G0 G3 h. 102 | destruct G0; simpl_env in *; inversion h; subst. 103 | - clear h. 104 | specialize (IHD G1 nil G2 ltac:(eauto)). 105 | move: IHD => [D1 [D2 [G1' [G2' [h1 [h2 [h3 h4]]]]]]]. 106 | inversion h3. subst. 107 | exists nil. 108 | exists (x ~ a0 ++ D2). 109 | exists nil. 110 | exists (x ~ (q1,a0) ++ G2'). 111 | simpl_env. split; auto. 112 | - clear h. 113 | specialize (IHD G1 G0 G3 ltac:(eauto)). 114 | move: IHD => [D1 [D2 [G1' [G2' [h1 [h2 [h3 h4]]]]]]]. 115 | exists (x ~ a0 ++ D1). 116 | exists D2. 117 | exists (x ~ (q1, a0) ++ G1'). 118 | exists G2'. 119 | subst. 120 | simpl_env. 121 | repeat split; auto. 122 | Qed. 123 | 124 | Lemma three_ctx_sub {A}{D:list(atom*A)} : forall {G1 x q1 s G2 G}, 125 | ctx_sub D (G1 ++ x ~ (q1, s) ++ G2) G -> 126 | exists D1, exists D2, exists G1', exists G2', exists q2, D = D1 ++ x ~ s ++ D2 /\ G = G1' ++ x ~ (q2, s) ++ G2' /\ 127 | ctx_sub D1 G1 G1' /\ (q1 <= q2) /\ ctx_sub D2 G2 G2'. 128 | Proof. 129 | induction D; intros. 130 | + match goal with [ H : ctx_sub _ _ _ |- _ ] => inversion H end. 131 | destruct G1; simpl in *; discriminate. 132 | + destruct G1 as [|[y B] G1']. 133 | ++ simpl in H. inversion H; subst. 134 | exists nil. eexists D. exists nil. exists G0. exists q2. simpl_env. auto. 135 | ++ inversion H. subst. 136 | simpl_env in *. 137 | specialize (IHD _ _ _ _ _ _ H7). 138 | move: IHD => [D1' [D2' [G1'' [G2'' [q2' [E1 [S1 [S2 [S3 S4]]]]]]]]]. 139 | subst. 140 | exists (y ~ a0 ++ D1'). eexists. 141 | exists (y ~ (q2, a0) ++ G1''). eexists. eexists. 142 | simpl_env. 143 | split; eauto. 144 | Qed. 145 | 146 | 147 | Ltac destruct_ctx_sub := 148 | let D1 := fresh "D" in 149 | let D2 := fresh "D" in 150 | let G1' := fresh "G" in 151 | let G2' := fresh "G" in 152 | let E1 := fresh "E" in 153 | let S1 := fresh "S" in 154 | let S2 := fresh "S" in 155 | let S3 := fresh "S" in 156 | let q2 := fresh "q" in 157 | match goal with 158 | | [H : ctx_sub ?D ?G (?G1 ++ ?G2) |- _ ] => 159 | apply ctx_sub_app_split_r in H; 160 | move: H => [D1 [D2 [G1' [G2' [E1 [S1 [S2 S3]]]]]]]; 161 | subst G 162 | | [H : ctx_sub ?D (?G1 ++ ?x ~ (?q,?A) ++ ?G2) ?G |- _ ] => 163 | apply three_ctx_sub in H; 164 | move: H => [D1 [D2 [G1' [G2' [q2 [E1 [S1 [S2 [S3 S4]]]]]]]]]; 165 | subst G 166 | | [ H : ctx_sub ?D ?G3 ([(?x, ?s)] ++ ?G2) |- _ ] => 167 | inversion H; subst; clear H 168 | | [ H : ctx_sub ?D ?G3 ([(?x, ?s)]) |- _ ] => 169 | inversion H; subst; clear H 170 | | [ H : ctx_sub ?D ?G3 nil |- _ ] => 171 | inversion H; subst; clear H 172 | end. 173 | -------------------------------------------------------------------------------- /GraD/src/metalib.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Metalib.Metatheory. 3 | 4 | (* ------- these should be added to the metatheory library ------------------------- *) 5 | 6 | (* If we have identified a variable in the middle of a uniq environment, 7 | it fixes the front and back. *) 8 | Lemma uniq_mid A x (a a':A) G1 : forall G2 G1' G2', 9 | uniq (G1 ++ (x ~ a) ++ G2) -> 10 | (G1 ++ x ~ a ++ G2) = (G1' ++ x ~ a' ++ G2') -> 11 | G1 = G1' /\ a = a' /\ G2 = G2'. 12 | Proof. 13 | induction G1. 14 | + intros. 15 | destruct G1'; inversion H0; simpl_env in *. auto. 16 | subst. destruct_uniq. fsetdec. 17 | + intros. 18 | destruct a0 as [y b]. 19 | simpl_env in *. 20 | destruct_uniq. 21 | have NE: not (y = x). fsetdec. 22 | destruct G1' as [|[z c]]. simpl_env in H0. inversion H0. done. 23 | inversion H0. subst. 24 | simpl_env in *. 25 | specialize (IHG1 G2 G1' G2'). 26 | destruct IHG1 as [E1 [E2 E3]]; auto. 27 | subst. auto. 28 | Qed. 29 | 30 | (* If x is in an environment, it is either in the front half or 31 | the back half. *) 32 | Lemma binds_split A x (a:A) G : binds x a G -> exists G1 G2, G = G2 ++ [(x, a)] ++ G1. 33 | Proof. 34 | move=>B. induction G. 35 | + inversion B. 36 | + destruct a0 as [y b]. 37 | apply binds_cons_1 in B. 38 | destruct B as [[E1 E2]|E]. subst. 39 | ++ exists G. exists nil. auto. 40 | ++ destruct (IHG E) as [G1 [G2 E2]]. 41 | subst. 42 | eexists. exists ((y ~ b) ++ G2). simpl_env. 43 | eauto. 44 | Qed. 45 | 46 | (* If we divide up a context containing a variable, it either appears in the 47 | front half or the back half *) 48 | Lemma ctx_align_eq A G1 G2 (x:atom) (a:A) G0 G3 : 49 | uniq (G2 ++ x ~ a ++ G1) -> 50 | G2 ++ x ~ a ++ G1 = G0 ++ G3 -> 51 | (exists G0' G0'', G0 = G0' ++ x ~ a ++ G0'' /\ G2 = G0' /\ G1 = G0'' ++ G3) \/ 52 | (exists G3' G3'', G3 = G3' ++ x ~ a ++ G3'' /\ G2 = G0 ++ G3' /\ G1 = G3''). 53 | Proof. 54 | intros U E. 55 | have B: binds x a (G0 ++ G3). { rewrite <- E. auto. } 56 | rewrite -> binds_app_iff in B. 57 | destruct B as [h1|h1]. 58 | + left. 59 | destruct (binds_split _ _ _ _ h1) as [G0'' [G0' E2]]. 60 | exists G0'. exists G0''. split. auto. 61 | subst. 62 | simpl_env in E. 63 | edestruct uniq_mid with (G1 := G2) (G1' := G0') 64 | (G2 := G1) (G2' := G0'' ++ G3); eauto. 65 | tauto. 66 | + right. 67 | destruct (binds_split _ _ _ _ h1) as [G0'' [G0' E2]]. 68 | exists G0'. exists G0''. split. auto. 69 | subst. 70 | edestruct uniq_mid with (G1 := G2) (G1' := G0 ++ G0') 71 | (G2 := G1) (G2' := G0''); simpl_env; eauto. 72 | tauto. 73 | Qed. 74 | -------------------------------------------------------------------------------- /GraD/src/ottalt.sty: -------------------------------------------------------------------------------- 1 | %% 2 | %% This is file `ottalt.sty', 3 | %% generated with the docstrip utility. 4 | %% 5 | %% The original source files were: 6 | %% 7 | %% ottalt.dtx (with options: `package') 8 | %% 9 | %% Copyright (C) 2011 by Jesse A. Tov 10 | %% 11 | %% This file may be distributed and/or modified under the conditions of the 12 | %% LaTeX Project Public License, either version 1.2 of this license or (at 13 | %% your option) any later version. The latest version of this license is 14 | %% in: 15 | %% 16 | %% http://www.latex-project.org/lppl.txt 17 | %% 18 | %% and version 1.2 or later is part of all distributions of LaTeX 19 | %% version 1999/12/01 or later. 20 | %% 21 | \NeedsTeXFormat{LaTeX2e}[1999/12/01] 22 | \ProvidesPackage{ottalt} 23 | [2013/03/14 v0.11 alternate Ott layout style] 24 | \RequirePackage{mathpartir} 25 | \RequirePackage{ifthen} 26 | \RequirePackage{keyval} 27 | \RequirePackage{listproc} 28 | \DeclareOption{implicitPremiseBreaks}{ 29 | \renewcommand\ottaltpremisesep{\\} 30 | \renewcommand\ottaltpremisebreak{\\} 31 | } 32 | \DeclareOption{lineBreakHack}{ 33 | \renewcommand\ottaltpremisesep{\mpr@andcr} 34 | \renewcommand\ottaltpremisebreak{\\\\} 35 | } 36 | \DeclareOption{implicitLineBreakHack}{ 37 | \renewcommand\ottaltpremisesep{\\} 38 | \renewcommand\ottaltpremisebreak{\\\\} 39 | } 40 | \DeclareOption{alternateNonterms}{ 41 | \let\ifnotalternateNonterms\@secondoftwo 42 | } 43 | \DeclareOption{supertabular}{ 44 | \ottalt@supertabulartrue 45 | } 46 | \newcommand\ottaltpremisesep{\\} 47 | \newcommand\ottaltpremisebreak{\\} 48 | \let\ifnotalternateNonterms\@firstoftwo 49 | \newif\ifottalt@supertabular 50 | \ProcessOptions 51 | \ifottalt@supertabular 52 | \RequirePackage{supertabular} 53 | \fi 54 | \newcommand\inputott[2][ott]{ 55 | \input{#2} 56 | \renewottcommands[#1] 57 | } 58 | \newcommand\ottaltcurrentprefix{ott} 59 | \newcommand\renewottcommands[1][ott]{ 60 | \renewcommand\ottaltcurrentprefix{#1} 61 | \def\renewottcomm@nd##1{ 62 | \expandafter\renewcommand\csname #1##1\endcsname 63 | } 64 | \renewottcomm@nd{drule}[4][]{ 65 | \def\ottalt@nextpremise{} 66 | \ottalt@premisetoks={ } 67 | ##2 68 | \expandafter\ottalt@inferrule\expandafter 69 | {\the\ottalt@premisetoks}{##3}{##4}{##1} 70 | } 71 | \renewottcomm@nd{premise}[1]{% 72 | \ottalt@premisetoks= 73 | \expandafter\expandafter\expandafter 74 | {\expandafter\the\expandafter\ottalt@premisetoks 75 | \ottalt@nextpremise##1} 76 | \ottalt@iflinebreakhack##1\ottlinebreakhack\ottalt@iflinebreakhack{ 77 | \let\ottalt@nextpremise\ottaltpremisebreak 78 | }{ 79 | \let\ottalt@nextpremise\ottaltpremisesep 80 | } 81 | } 82 | \renewottcomm@nd{usedrule}[1]{% 83 | \ifottalt@firstrule 84 | \ottalt@firstrulefalse 85 | \else 86 | %\and 87 | %% sigart.cls uses \and for the title and mangles it horribly 88 | %% so we cannot use it here. Instead, we drop down to what 89 | %% mathpartir wants to redefine the \and command to be anyways 90 | \mpr@andcr 91 | %%\quad 92 | \fi 93 | \ensuremath{##1} 94 | } 95 | \renewenvironment{#1defnblock}[3][] 96 | {\begin{drulepar}{##2}{##3}} 97 | {\end{drulepar}} 98 | \renewottcomm@nd{drulename}[1]{% 99 | \ottalt@replace@cs\ranchor\_-{}##1\\ 100 | } 101 | \renewottcomm@nd{prodline}[6]{ 102 | \ifthenelse{\equal{##3}{}}{ 103 | \\ & & $##1$ & $##2$ & & $##5$ & $##6$ 104 | }{} 105 | } 106 | \renewottcomm@nd{prodnewline}{\relax} 107 | \renewottcomm@nd{grammartabular}[1]{% 108 | \begin{ottaltgrammar}##1\end{ottaltgrammar}% 109 | } 110 | } 111 | \newcommand*\drule@h@lper[3]{% 112 | \expandafter\ifx\csname\ottaltcurrentprefix drule#3\endcsname\relax 113 | \PackageWarning{ottalt}{Unknown ott rule: #3}% 114 | \mbox{\textbf{(#2?)}}% 115 | \else 116 | \csname\ottaltcurrentprefix usedrule\endcsname 117 | {\csname\ottaltcurrentprefix drule#3\endcsname{#1}}% 118 | \fi 119 | } 120 | \newcommand*\nonterm@h@lper[1]{\csname\ottaltcurrentprefix#1\endcsname} 121 | \newcommand\rrefruletext{rule} 122 | \newcommand\Rrefruletext{\expandafter\MakeUppercase\rrefruletext} 123 | \newcommand\rrefrulestext{\rrefruletext s} 124 | \newcommand\Rrefrulestext{\Rrefruletext s} 125 | \newcommand\rrefstyle{\normalfont\scshape} 126 | \newcommand\ranchorstyle{\rrefstyle} 127 | \providecommand\wraparoundrref{\relax} 128 | \newcommand*\rref{% 129 | \@ifnextchar* 130 | {\rref@star} 131 | {\rref@with\rrefruletext\rrefrulestext}} 132 | \newcommand*\Rref{% 133 | \@ifnextchar* 134 | {\rref@star} 135 | {\rref@with\Rrefruletext\Rrefrulestext}} 136 | \newcommand*\rref@with[2]{\FormatList{#1~}{#2~}{\one@rref}} 137 | \newcommand*\rref@star[1]{\FormatList{}{}{\one@rref}} 138 | \newcommand*\@one@rref@nohyper[1]{\wraparoundrref{{\rrefstyle{#1}}}} 139 | \newcommand*\@ranchor@nohyper[1]{{\ranchorstyle{#1}}} 140 | \AtBeginDocument{ 141 | \ifcsname hypertarget\endcsname 142 | \newcommand*\one@rref[1]{% 143 | \hyperlink 144 | {ottalt:rule:\ottaltcurrentprefix:#1} 145 | {\@one@rref@nohyper{#1}}% 146 | } 147 | \newcommand*\ranchor[1]{% 148 | \hypertarget 149 | {ottalt:rule:\ottaltcurrentprefix:#1} 150 | {\@ranchor@nohyper{#1}}% 151 | } 152 | \else 153 | \newcommand\one@rref{\@one@rref@nohyper} 154 | \newcommand\ranchor{\@ranchor@nohyper} 155 | \fi 156 | } 157 | \newcommand*{\drules}[4][\relax]{% 158 | \begin{drulepar}[#1]{#2}{#3} 159 | \@for\@ottalt@each:=#4\do{% 160 | \expandafter\drule\expandafter{\@ottalt@each} 161 | } 162 | \end{drulepar}% 163 | } 164 | \newenvironment{drulepar}[3][\relax] 165 | {\begin{rulesection}[#1]{#2}{#3}% 166 | \begin{mathparpagebreakable}} 167 | {\end{mathparpagebreakable}% 168 | \end{rulesection}} 169 | \newenvironment{drulepar*}[3][\relax] 170 | {\begin{rulesection*}[#1]{#2}{#3}% 171 | \begin{mathparpagebreakable}} 172 | {\end{mathparpagebreakable}% 173 | \end{rulesection*}} 174 | \newenvironment{rulesection}[3][\relax] 175 | {\trivlist\item 176 | \ifx#1\relax\else\def\ottalt@rulesection@prefix{#1-}\fi 177 | \drulesectionhead{#2}{#3}% 178 | \nopagebreak[4]% 179 | \noindent} 180 | {\endtrivlist} 181 | \newenvironment{rulesection*}[3][\relax] 182 | {\trivlist\item 183 | \ifx#1\relax\else\def\ottalt@rulesection@prefix{#1-}\fi 184 | \drulesectionhead*{#2}{#3}% 185 | \nopagebreak[4]% 186 | \noindent} 187 | {\endtrivlist} 188 | \newcommand\ottalt@rulesection@prefix{} 189 | \newcommand*{\drulesectionhead}{% 190 | \@ifnextchar *{\drulesectionheadMany}{\drulesectionheadOne}% 191 | } 192 | \newcommand*{\drulesectionheadOne}[2]{% 193 | \FormatDruleSectionHead{#1}% 194 | \hfill\FormatDruleSectionHeadRight{#2}% 195 | \par 196 | } 197 | \newcommand*{\drulesectionheadMany}[3]{% 198 | {% 199 | \let\FormatListSepTwo\FormatDruleSepTwo 200 | \let\FormatListSepMore\FormatDruleSepMore 201 | \let\FormatListSepLast\FormatDruleSepLast 202 | \FormatList{}{}{\FormatDruleSectionHeads}{#2}% 203 | }% 204 | \hfill\FormatDruleSectionHeadRight{#3}% 205 | \par 206 | } 207 | \newcommand*\FormatDruleSepTwo{\,,~} 208 | \newcommand*\FormatDruleSepMore{\FormatDruleSepTwo} 209 | \newcommand*\FormatDruleSepLast{\FormatDruleSepTwo} 210 | \newcommand*\FormatDruleSectionHead[1]{\fbox{#1}} 211 | \newcommand*\FormatDruleSectionHeads[1]{\fbox{\strut#1}} 212 | \newcommand*\FormatDruleSectionHeadRight[1]{\emph{(#1)}} 213 | \newcommand*\drule[2][]{% 214 | \expandafter\drule@helper\expandafter{\ottalt@rulesection@prefix}{#1}{#2}% 215 | } 216 | \newcommand*\drule@helper[3]{% 217 | \ottalt@replace@cs{\drule@h@lper{#2}{#1#3}}-{XX}{}#1#3\\ 218 | } 219 | \newcommand\ottaltinferrule[4]{ 220 | \inferrule*[narrower=0.3,lab=#1,#2] 221 | {#3} 222 | {#4} 223 | } 224 | \newcommand\ottalt@inferrule[4]{ 225 | \ottaltinferrule{#3}{#4}{#1}{#2} 226 | } 227 | \newif\ifottalt@firstrule \ottalt@firstruletrue 228 | \newcommand{\ottalt@nextpremise}{\relax} 229 | \newtoks\ottalt@premisetoks 230 | \newcommand{\ottlinebreakhack}{\relax} 231 | \def\ottalt@iflinebreakhack#1\ottlinebreakhack #2\ottalt@iflinebreakhack{% 232 | \ifthenelse{\equal{#2}{}}\@secondoftwo\@firstoftwo 233 | } 234 | \newcommand\ottalt@replace@cs[5]{% 235 | \ifx\\#5\relax 236 | \def\ottalt@replace@cs@kont{#1{#4}}% 237 | \else 238 | \ifx#2#5\relax 239 | \def\ottalt@replace@cs@kont{\ottalt@replace@cs{#1}{#2}{#3}{#4#3}}% 240 | \else 241 | \def\ottalt@replace@cs@kont{\ottalt@replace@cs{#1}{#2}{#3}{#4#5}}% 242 | \fi 243 | \fi 244 | \ottalt@replace@cs@kont 245 | } 246 | \newcommand*\nonterms[2][8pt]{ 247 | \begin{ottaltgrammar}[#1] 248 | \@for\@ottalt@each:=#2\do{% 249 | \expandafter\nt\expandafter{\@ottalt@each} 250 | } 251 | \end{ottaltgrammar} 252 | } 253 | \newenvironment{ottaltgrammar}[1][8pt]{% 254 | \begingroup 255 | \trivlist\item 256 | \def\OTTALTNEWLINE{\\[#1]}% 257 | \def\nt##1{\OTTALTNEWLINE\relax\nonterm@h@lper{##1}\ignorespaces}% 258 | \newcommand\ottaltintertext[2]{% 259 | \multicolumn{8}{l}{% 260 | \begin{minipage}{##1}% 261 | ##2% 262 | \end{minipage}% 263 | }% 264 | }% 265 | \ifottalt@supertabular 266 | \begin{supertabular}{llcllllll} 267 | \else 268 | \begin{tabular}{llcllllll} 269 | \fi 270 | \let\OTTALTNEWLINE\relax 271 | \ignorespaces 272 | } 273 | {% 274 | \@ifundefined{ottafterlastrule}{\\}{\ottafterlastrule}% 275 | \ifottalt@supertabular 276 | \end{supertabular} 277 | \else 278 | \end{tabular} 279 | \fi 280 | \endtrivlist 281 | \endgroup 282 | \ignorespaces 283 | } 284 | \newcommand\newNTclass[2][\ifnotalternateNonterms]{ 285 | \expandafter\newcommand\csname new#2s\endcsname[4][]{ 286 | #1{ 287 | \expandafter\newcommand\csname ottalt@NT@#2@##2\endcsname{##1{##3}} 288 | }{ 289 | \expandafter\newcommand\csname ottalt@NT@#2@##2\endcsname{##4} 290 | } 291 | } 292 | \expandafter\newcommand\csname new#2\endcsname[3][]{ 293 | \csname new#2s\endcsname[##1]{##2}{##3}{##3} 294 | } 295 | \expandafter\newcommand\csname #2\endcsname[1]{% 296 | \csname ottalt@NT@#2@##1\endcsname 297 | } 298 | } 299 | \providecommand\@ifToif[1]{% 300 | #1\iftrue\iffalse 301 | } 302 | \providecommand\ifTo@if[1]{% 303 | #1% 304 | \expandafter\@firstoftwo 305 | \else 306 | \expandafter\@secondoftwo 307 | \fi 308 | } 309 | \newcommand\NTOVERLINE{\NTCAPTURE\overline} 310 | \newcommand\NTUNDERLINE{\NTCAPTURE\underline} 311 | \newcommand\NTTEXTCOLOR[1]{\NTCAPTURE{\textcolor{#1}}} 312 | \newcommand\NTCAPTURE[1]{\NTCAPTURELOW{\NTCAPTURE@FINISH{#1}}} 313 | \newcommand\NTCAPTURE@FINISH[4]{#1{#2_{#3}#4}} 314 | \newcommand\NTCAPTURELOW[2]{\NT@CAPTURE@LOOP{#1}{#2}\relax\relax} 315 | \newcommand\NT@CAPTURE@LOOP[4]{% 316 | \@ifnextchar _{% 317 | \NT@CAPTURE@SUB{#1}{#2}{#3}{#4}% 318 | }{\@ifnextchar '{% 319 | \NT@CAPTURE@PRIME{#1}{#2}{#3}{#4}% 320 | }{% 321 | {#1{#2}{#3}{#4}}% 322 | }}% 323 | } 324 | \def\NT@CAPTURE@SUB#1#2#3#4_#5{\NT@CAPTURE@LOOP{#1}{#2}{#3#5}{#4}} 325 | \def\NT@CAPTURE@PRIME#1#2#3#4'{\NT@CAPTURE@LOOP{#1}{#2}{#3}{#4'}} 326 | \endinput 327 | %% 328 | %% End of file `ottalt.sty'. 329 | -------------------------------------------------------------------------------- /GraD/src/semimodule.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Coq.Classes.EquivDec. 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | 9 | Require Import Qtt.tactics. 10 | Require Import Qtt.usage. 11 | Require Import Qtt.dctx. 12 | Require Import Qtt.dctx_sub. 13 | 14 | (* A Q-left semimodule is the definition of a carrier set M with commutative monoid structure (M,+,0) and left multiplication function. 15 | 16 | • for 𝑞1, 𝑞2 ∈ 𝑄 and 𝑚∈𝑀, we have (𝑞1 + 𝑞2) ⊙ 𝑚 = 𝑞1 ⊙ 𝑚 ⊕ 𝑞2 ⊙ 𝑚 [distrib2] 17 | • for 𝑞 ∈ 𝑄 and 𝑚1,𝑚2 ∈ 𝑀, we have, 𝑞 ⊙ (𝑚1 ⊕ 𝑚2) = 𝑞 ⊙ 𝑚1 ⊕ 𝑞 ⊙ 𝑚2 [distrib] 18 | •for 𝑞1, 𝑞2 ∈𝑄 and 𝑚∈𝑀,we have (𝑞1·𝑞2) ⊙ 𝑚 = 𝑞1 ⊙ (𝑞2 ⊙ 𝑚) [mul_assoc] 19 | • for 𝑚 ∈ 𝑀, we have 1 ⊙ 𝑚 = 𝑚 [mul_id] 20 | • for 𝑞 ∈ 𝑄 and 𝑚 ∈ 𝑀, we have 0 ⊙ 𝑚 = 𝑞 ⊙ 0 = 0. [mul_zero1, mul_zero2] 21 | 22 | A left 𝑄-semimodule 𝑀 is said to be partially-ordered iff there exists a partial order ≤𝑀 on 𝑀 such that the following properties hold. 23 | • for 𝑚1,𝑚2, 𝑚 ∈ 𝑀, if 𝑚1 ≤𝑀 𝑚2, then 𝑚 ⊕ 𝑚1 ≤𝑀 𝑚 ⊕ 𝑚2 [ctx_sub_ctx_plus] 24 | • for 𝑞 ∈ 𝑄 and 𝑚1,𝑚2 ∈ 𝑀, if 𝑚1 ≤𝑀 𝑚2, then 𝑞 ⊙ 𝑚1 ≤𝑀 𝑞 ⊙ 𝑚2 [po_semiring_context] 25 | • for 𝑞1,𝑞2 ∈𝑀 and 𝑚∈𝑀, if 𝑞1 ≤𝑞2, then 𝑞1 ⊙ 𝑚 ≤ 𝑀 𝑞2 ⊙ 𝑚. [ctx_sub_ctx_mul] 26 | *) 27 | 28 | (* Here we show that contexts form a module; uses ctx_plus, ctx_mul, and ctx_sub. *) 29 | 30 | (* We reorient some of these properties so that we can add them to rewr_list hint database. 31 | That way they will be automatically applied by the [simpl_env] tactic. *) 32 | 33 | 34 | Section CtxMod. 35 | 36 | Variables A:Type. 37 | 38 | (* First, ctx_plus with 0=(ctx_mul 0 G) is a commutative monoid. *) 39 | 40 | Lemma ctx_plus_0_l : forall (G:list(atom*(usage*A))), 41 | G = ctx_plus (ctx_mul 0 G) G. 42 | Proof. 43 | induction G; simpl. auto. 44 | destruct a as [x [q1 ?]]. 45 | simpl. 46 | ring_equal. 47 | auto. 48 | Qed. 49 | 50 | Lemma ctx_plus_0_r : forall (G:list(atom*(usage*A))), 51 | G = ctx_plus G (ctx_mul 0 G). 52 | Proof. 53 | induction G; simpl. auto. 54 | destruct a as [x [q1 ?]]. 55 | simpl. 56 | ring_equal. 57 | auto. 58 | Qed. 59 | 60 | (* if we add a pre-condition, we can generalize this identity. *) 61 | 62 | Lemma ctx_ctx_plus_0_l : forall {D:list(atom*A)} {G1 G2}, 63 | ctx D G1 -> 64 | ctx D G2 -> 65 | ctx_plus (ctx_mul 0 G1) G2 = G2. 66 | Proof. 67 | induction D; intros; destruct_ctx; simpl. auto. 68 | ring_equal. 69 | auto. 70 | Qed. 71 | 72 | Lemma ctx_ctx_plus_0_r : forall {D:list(atom*A)} {G1 G2}, 73 | ctx D G1 -> 74 | ctx D G2 -> 75 | ctx_plus G2 (ctx_mul 0 G1) = G2. 76 | Proof. 77 | induction D; intros; destruct_ctx; simpl. auto. 78 | ring_equal. 79 | auto. 80 | Qed. 81 | 82 | (* Associativity also has a precondition. *) 83 | 84 | Lemma ctx_plus_assoc : forall D (G1:list(atom*(usage*A))) G2 G3, 85 | ctx D G1 -> 86 | ctx D G2 -> 87 | ctx D G3 -> 88 | ctx_plus (ctx_plus G1 G2) G3 = ctx_plus G1 (ctx_plus G2 G3). 89 | Proof. 90 | induction D; intros; invert_ctx; simpl; auto. 91 | f_equal. f_equal. f_equal. ring_equal. 92 | eauto. 93 | Qed. 94 | 95 | 96 | Lemma ctx_plus_comm : 97 | forall D (G1:list(atom*(usage*A))) G2, ctx D G1 -> ctx D G2 -> ctx_plus G1 G2 = ctx_plus G2 G1. 98 | Proof. 99 | induction D; intros; invert_ctx. auto. 100 | simpl. 101 | f_equal. f_equal. rewrite qplus_comm. auto. 102 | rewrite IHD; auto. 103 | Qed. 104 | 105 | 106 | 107 | (* Next, the explicit module laws *) 108 | 109 | Lemma ctx_distrib2 q1 q2 (G:list(atom*(usage*A))) : forall (D:list(atom*A)) G1 G2, ctx D G1 -> ctx D G2 -> 110 | ctx_plus (ctx_mul q1 G) (ctx_mul q2 G) = ctx_mul (q1 + q2) G. 111 | Proof. 112 | induction G. intros. simpl. auto. 113 | intros. destruct a as [x [? ?]]. 114 | simpl. 115 | rewrite distr_l. 116 | f_equal. 117 | eauto. 118 | Qed. 119 | 120 | 121 | Lemma ctx_distrib1 r D (G1:list(atom*(usage*A))) : ctx D G1 -> forall G G2, ctx D G2 -> 122 | G = ctx_plus G1 G2 -> (ctx_mul r G) = ctx_plus (ctx_mul r G1) (ctx_mul r G2). 123 | Proof. 124 | induction 1; intros; invert_ctx. auto. 125 | simpl. 126 | rewrite distr_r. 127 | f_equal. 128 | auto. 129 | Qed. 130 | 131 | Lemma ctx_distrib {r D}{G1:list(atom*(usage*A))} G2 : ctx D G1 -> ctx D G2 -> 132 | ctx_mul r (ctx_plus G1 G2) = ctx_plus (ctx_mul r G1) (ctx_mul r G2). 133 | Proof. 134 | intros. 135 | eapply ctx_distrib1; eauto. 136 | Qed. 137 | 138 | 139 | Lemma ctx_mul_assoc q1 q2 {G:list(atom*(usage*A))} : ctx_mul q1 (ctx_mul q2 G) = ctx_mul (q1 * q2) G. 140 | Proof. 141 | induction G; simpl; try done. 142 | destruct a as [x [? ?]]. 143 | simpl. 144 | rewrite IHG. 145 | rewrite qmul_assoc. 146 | auto. 147 | Qed. 148 | 149 | Lemma ctx_mul_id : forall {G:list(atom*(usage*A))}, ctx_mul 1 G = G. 150 | Proof. 151 | induction G. auto. 152 | destruct a as [x [? ?]]. 153 | simpl. rewrite IHG. 154 | rewrite qmul_1_l. auto. 155 | Qed. 156 | 157 | (* The identities for multiplying by zero are a bit tricky. ctx_mul 0 G is defined to be zero, for any G. 158 | So the identities listed above are a bit trivial. 159 | *) 160 | 161 | (* This lemma says that all zeros are the same *) 162 | Lemma same_ctx : forall {D}{G1:list(atom*(usage*A))}, ctx D G1 -> forall G2, ctx D G2 -> ctx_mul 0 G1 = ctx_mul 0 G2. 163 | Proof. 164 | induction 1; intros; invert_ctx; simpl_env. auto. 165 | simpl. erewrite IHctx. 166 | repeat rewrite qmul_0_l. 167 | f_equal. 168 | auto. 169 | Qed. 170 | 171 | (* This is another variant of the same lemma *) 172 | Lemma ctx_mul_0_eq : forall {G1 G2:list(atom*(usage*A))}, ctx_mul 0 G1 = G2 -> ctx_mul 0 G2 = G2. 173 | Proof. 174 | intros G1. induction G1. 175 | - intros. destruct G2; inversion H. auto. 176 | - intros. simpl in H. destruct a. destruct p. simpl in H. 177 | destruct G2; inversion H. 178 | destruct p. destruct p. inversion H1. subst. clear H1. 179 | asimpl. rewrite ctx_mul_assoc. asimpl. auto. 180 | Qed. 181 | 182 | (* --------------- Partially-ordered semimodule ------------------- *) 183 | 184 | 185 | Lemma po_semiring_context {q}{D:list(atom*A)}{G1 G2} : 186 | ctx_sub D G1 G2 187 | -> ctx_sub D (ctx_mul q G1) (ctx_mul q G2). 188 | Proof. 189 | induction 1. simpl. auto. 190 | simpl. econstructor; auto. 191 | eapply po_semiring3. auto. 192 | Qed. 193 | 194 | 195 | 196 | Lemma ctx_sub_ctx_mul: forall {D} {G:list(atom*(usage*A))} {q3 q0}, q3 <= q0 -> ctx D G -> ctx_sub D (ctx_mul q3 G) (ctx_mul q0 G). 197 | Proof. induction 2. simpl. auto. 198 | econstructor; auto. apply po_semiring2. auto. 199 | Qed. 200 | 201 | 202 | 203 | Lemma ctx_sub_ctx_plus_aux: 204 | forall {D}{G3':list(atom*(usage*A))} {G3}, 205 | ctx_sub D G3' G3 -> forall G, ctx D G -> 206 | ctx_sub D (ctx_plus G3' G) (ctx_plus G3 G). 207 | Proof. 208 | induction 1; intros; invert_ctx; simpl; auto. 209 | econstructor; eauto. 210 | eapply qplus_sub_r; auto. 211 | Qed. 212 | 213 | Lemma ctx_sub_ctx_plus: forall {D:list (atom*A)}{G1 G1' G2 G2'}, 214 | ctx_sub D G1 G1' -> ctx_sub D G2 G2' -> 215 | ctx_sub D (ctx_plus G1 G2) (ctx_plus G1' G2'). 216 | Proof. 217 | intros. 218 | transitivity (ctx_plus G1 G2'). 219 | rewrite (@ctx_plus_comm D G1 G2); try eassumption. 220 | eapply ctx_sub_ctx1; eauto. 221 | eapply ctx_sub_ctx1; eauto. 222 | rewrite (@ctx_plus_comm D G1 G2'); try eassumption. 223 | eapply ctx_sub_ctx1; eauto. 224 | eapply ctx_sub_ctx2; eauto. 225 | eapply ctx_sub_ctx_plus_aux; eauto. 226 | eapply ctx_sub_ctx1; eauto. 227 | eapply ctx_sub_ctx_plus_aux; eauto. 228 | eapply ctx_sub_ctx2; eauto. 229 | Qed. 230 | 231 | 232 | (* --------------- Derived properties ------------------- *) 233 | 234 | 235 | Lemma ctx_plus_sub: forall {D1} {G1 G2' G2:list(atom*(usage*A))}, ctx D1 G1 -> 236 | G2' = ctx_mul 0 G2' -> 237 | ctx_sub D1 G2' G2 -> ctx_sub D1 G1 (ctx_plus G1 G2). 238 | Proof. 239 | induction D1; intros; invert_ctx; simpl; auto. 240 | inversion H1. auto. 241 | simpl_env in *. inversion H1. subst. simpl. 242 | unfold ctx_mul in H0. simpl_env in H0. inversion H0. 243 | econstructor. auto. eapply qplus_sub. rewrite H2 in H5. ring_simpl in H5. auto. 244 | eauto. auto. 245 | Qed. 246 | 247 | 248 | 249 | Lemma ctx_plus_swap: forall {D:list(atom*A)} a, 250 | ctx D a -> forall b c d, ctx D b -> 251 | ctx D c -> ctx D d -> 252 | ctx_plus (ctx_plus a b) (ctx_plus c d) = 253 | ctx_plus (ctx_plus a c) (ctx_plus b d). 254 | Proof. 255 | induction 1; intros; 256 | simpl in *. 257 | - inversion H. inversion H0. inversion H1. auto. 258 | - inversion H1. inversion H2. inversion H3. subst. 259 | asimpl. 260 | rewrite IHctx; try eclarify_ctx. 261 | f_equal. 262 | f_equal. 263 | f_equal. 264 | f_equal. 265 | f_equal. 266 | rewrite <- qplus_assoc. 267 | rewrite <- qplus_assoc. 268 | f_equal. 269 | rewrite qplus_comm. 270 | auto. 271 | Qed. 272 | 273 | 274 | 275 | Lemma ctx_plus_ctx_mul_0 : forall (G:list(atom*(usage*A))) G1 G2, G = ctx_plus (ctx_mul 0 G1) (ctx_mul 0 G2) -> 276 | G = ctx_mul 0 G. 277 | Proof. 278 | induction G; intros; simpl; auto. 279 | destruct a as [x [q ?]]. 280 | destruct G1 as [|[y [q1' ?]]]; 281 | destruct G2 as [|[z [q1 ?]]]; simpl in H; try inversion H. subst. clear H. 282 | simpl. repeat rewrite qmul_0_l. repeat rewrite qplus_0_l. 283 | repeat f_equal. 284 | eauto. 285 | Qed. 286 | 287 | 288 | End CtxMod. 289 | 290 | 291 | (* by adding these lemmas to the rewr_list hint database, it will be automatically 292 | applied by the [simpl_env] tactic. *) 293 | 294 | Hint Rewrite ctx_mul_id : rewr_list. 295 | Hint Rewrite ctx_mul_assoc : rewr_list. 296 | Hint Rewrite ctx_distrib2 : rewr_list. 297 | 298 | Hint Rewrite ctx_ctx_plus_0_l ctx_ctx_plus_0_r : rewr_list. 299 | -------------------------------------------------------------------------------- /GraD/src/spec.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \usepackage{ottalt} 4 | \usepackage{mathpartir} 5 | \usepackage{supertabular} 6 | 7 | \usepackage{amsmath} 8 | \usepackage{amssymb} 9 | 10 | \usepackage{color} 11 | 12 | 13 | %% Show admissible premises in rules 14 | %% This should be false in main body of text and true in the appendix. 15 | \newif\ifadmissible 16 | \newcommand\suppress[1]{\ifadmissible{#1}\else{}\fi} 17 | \inputott{dqtt-rules} 18 | 19 | \title{System Specification} 20 | 21 | \admissiblefalse 22 | \begin{document} 23 | \maketitle 24 | 25 | This document is created directly from the definitions in the file 26 | {\texttt{dqtt.ott}}, with minor modifications as listed below. 27 | 28 | This document is intended to specify, in a readable form, the subject of the 29 | proofs in Section 7.2 of the POPL paper ``A Graded Dependent Type SYstem with 30 | a Usage-Aware Semantics'' as well as explain the slight differences between 31 | the ott source file ({\texttt{dqtt.ott}}), this rendering, the POPL publication, and the 32 | generated Coq files \texttt{dqtt\_ott.v} and \texttt{dqtt\_inf.v}. 33 | 34 | The reason for these slight differences is due to the restrictions of the Ott 35 | locally nameless backend and the LNgen theory generation tool. 36 | \begin{enumerate} 37 | \item All parts of the syntax must be defined concretely in the Ott source file. 38 | \item All bound variables need to be explicitly determined 39 | \item All syntactic forms must bind at most one variable at a time. 40 | \end{enumerate} 41 | 42 | The first limitation is simple to accommodate through minor manual edits of 43 | the outputs of Ott and LNgen. These edits allow us to parameterize the 44 | development on an arbitrary semiring (see \texttt{usage\_sig.v}) instead of 45 | working with a specific, concrete semiring. 46 | 47 | The second limitation affects our generation of the typing rules for pattern 48 | matching elimination forms, i.e. \textsc{T-UnitE}, \textsc{T-LetBox} and 49 | \textsc{T-Case}. In these rules, we need to substitute in for the scrutinee 50 | $y$ the result type $B$. Therefore, we need to inform Ott that $y$ should be 51 | bound in $B$. We do so with an additional annotation (written 52 | $\ottkw{@} \lambda y. B$) on the corresponding terms. For simplicity, in the 53 | paper, we elide this annotation. 54 | 55 | The third limitation causes difficulty for the formalization of the 56 | elimination rule for tensor products. The usual pattern matching elimination 57 | syntactic form binds two variables, one for each component of the tuple. This 58 | is the form that is used in the POPL publication. To accommodate Ott, in this 59 | version we replace the pattern matching elimination form for $\Sigma$ types 60 | with a slightly more general, but less familiar, form. 61 | 62 | We call this syntactic form ``spread'' and it has the following grammar. 63 | \[ 64 | \ottkw{spread}\, \ottnt{a} \, \ottkw{to}\, \ottmv{x} \, \ottkw{in}\, \ottnt{b}\, \ottkw{@}\, \ottnt{B} 65 | \] 66 | This syntactic form binds the variable $x$ (corresponding to the first 67 | component of the product) in the body $b$. The body $b$ must itself be a 68 | function, where the argument is the second component of the tuple. By 69 | refactoring in this way, we observe Ott's restriction to single binding. 70 | 71 | Using this syntax, we can encode an elimination of an argument $a$ 72 | of type $ \Sigma \ottmv{x} \!\!:^ \ottnt{q} \!\! \ottnt{A} . \ottnt{B} $, that uses 73 | the usual pattern matching syntax 74 | \[ 75 | \ottkw{let}\, (\ottmv{x},\ottmv{y}) \,=\, (\ottnt{a} : \Sigma \ottmv{x} \!\!:^ \ottnt{q} \!\! \ottnt{A} . \ottnt{B}) \ \ottkw{in}\ \ottnt{b} 76 | \] 77 | 78 | using the term 79 | \[ 80 | \ottkw{spread}\, \ottnt{a} \, \ottkw{to}\, \ottmv{x} \, \ottkw{in}\, \lambda \ottmv{y} \!:^ \ottnt{q} \! \ottnt{A} . \ottnt{b} 81 | \ottkw{@}\, \lambda \ottmv{y} \!\:^\ottnt{q}\! \ottnt{A} . \ottnt{B} 82 | \] 83 | 84 | Even though $\ottkw{spread}$ solves the issue with single binding in the 85 | syntax of the term, there is still the issue of generating its appropriate 86 | elimination rule via Ott. Unfortunately, Ott Ott cannot express the correct 87 | typing rule for $\ottkw{spread}$ because the typing rule requires a 88 | substitution for both variables. Therefore we modify the generated Coq 89 | definition to include the appropriate substitution. For clarity, this document 90 | includes the corresponding change in the typeset rule \textsc{T-Spread}. 91 | 92 | 93 | \section{Grammar} 94 | 95 | \ottgrammartabular{ 96 | \ottusage\ottinterrule 97 | \otttm\ottinterrule 98 | \ottcontext\ottinterrule 99 | \ottD\ottafterlastrule 100 | } 101 | 102 | 103 | \section{Step relation} 104 | \ottdefnsJOp{} 105 | \section{Typing relation} 106 | 107 | \newcommand{\ottdruleTXXSpreadAlt}[1]{\ottdrule[#1]{% 108 | \ottpremise{\ottnt{A} \ottsym{=} \Sigma \ottmv{x} \!\!:^ \ottnt{q} \!\! \ottnt{A_{{\mathrm{1}}}} . \ottnt{A_{{\mathrm{2}}}} }% 109 | \ottpremise{ \Delta ; \Gamma_{{\mathrm{1}}} \vdash \ottnt{a} : \ottnt{A} }% 110 | \ottpremise{ \Delta , \ottmv{x} \!\!:\!\! \ottnt{A_{{\mathrm{1}}}} ; \Gamma_{{\mathrm{2}}} , \ottmv{x} \!\!:^{ \ottnt{q} }\!\! \ottnt{A_{{\mathrm{1}}}} \vdash \ottnt{b} : \Pi \ottmv{y} \!:^ \ottsym{1} \! \ottnt{A_{{\mathrm{2}}}} . \ottnt{B} \ottsym{\{} (\ottmv{x},\ottmv{y}) \ottsym{/} \ottmv{z} \ottsym{\}} }% 111 | \ottpremise{ \Delta , \ottmv{z} \!\!:\!\! \ottnt{A} ; \Gamma_{{\mathrm{3}}} , \ottmv{z} \!\!:^{ \ottnt{r} }\!\! \ottnt{A} \vdash \ottnt{B} : \ottkw{type} }% 112 | }{ 113 | \Delta ; \Gamma_{{\mathrm{1}}} \ottsym{+} \Gamma_{{\mathrm{2}}} \vdash \ottkw{spread}\, \ottnt{a} \, \ottkw{to}\, \ottmv{x} \, \ottkw{in}\, \ottnt{b} : \ottnt{B} \ottsym{\{} \ottnt{a} \ottsym{/} \ottmv{z} \ottsym{\}} }{% 114 | {\ottdrulename{T\_Spread}}{}% 115 | }} 116 | 117 | 118 | \begin{ottdefnblock}[#1]{$ \Delta ; \Gamma \vdash \ottnt{a} : \ottnt{A} $}{\ottcom{Typing}} 119 | \ottusedrule{\ottdruleTXXsub{}} 120 | \ottusedrule{\ottdruleTXXtype{}} 121 | \ottusedrule{\ottdruleTXXvar{}} 122 | \ottusedrule{\ottdruleTXXweak{}} 123 | \ottusedrule{\ottdruleTXXpi{}} 124 | \ottusedrule{\ottdruleTXXlam{}} 125 | \ottusedrule{\ottdruleTXXapp{}} 126 | \ottusedrule{\ottdruleTXXconv{}} 127 | \ottusedrule{\ottdruleTXXunit{}} 128 | \ottusedrule{\ottdruleTXXUnit{}} 129 | \ottusedrule{\ottdruleTXXUnitE{}} 130 | \ottusedrule{\ottdruleTXXBox{}} 131 | \ottusedrule{\ottdruleTXXbox{}} 132 | \ottusedrule{\ottdruleTXXletbox{}} 133 | \ottusedrule{\ottdruleTXXsum{}} 134 | \ottusedrule{\ottdruleTXXinjOne{}} 135 | \ottusedrule{\ottdruleTXXinjTwo{}} 136 | \ottusedrule{\ottdruleTXXcase{}} 137 | \ottusedrule{\ottdruleTXXSigma{}} 138 | \ottusedrule{\ottdruleTXXTensor{}} 139 | \ottusedrule{\ottdruleTXXSpreadAlt{}} 140 | \end{ottdefnblock} 141 | 142 | 143 | 144 | 145 | \end{document} 146 | -------------------------------------------------------------------------------- /GraD/src/tactics.v: -------------------------------------------------------------------------------- 1 | Require Import Qtt.dqtt_ott. 2 | Require Import Qtt.dqtt_inf. 3 | 4 | Ltac gather_atoms ::= 5 | let A := gather_atoms_with (fun x : vars => x) in 6 | let B := gather_atoms_with (fun x : var => {{ x }}) in 7 | let C := gather_atoms_with (fun x : context => dom x) in 8 | let D := gather_atoms_with (fun x => fv_tm_tm x) in 9 | let E := gather_atoms_with (fun x : list (atom * sort) => dom x) in 10 | 11 | constr:(A \u B \u C \u D \u E). 12 | 13 | 14 | Ltac invert_equality := 15 | repeat match goal with 16 | | [H : (_,_) = (_,_) |- _ ] => inversion H; subst; clear H 17 | | [H : (_,_,_) = (_,_,_) |- _ ] => inversion H; subst; clear H 18 | | [H : (_,_,_,_) = (_,_,_,_) |- _ ] => inversion H; subst; clear H 19 | | [H : [_] ++ _ = [_] ++ _ |- _ ] => inversion H; subst; clear H 20 | | [H : ( _ :: _ ) = ( _ :: _ ) |- _ ] => inversion H; subst; clear H 21 | end. 22 | -------------------------------------------------------------------------------- /GraD/src/usage.v: -------------------------------------------------------------------------------- 1 | Require Import ssreflect. 2 | Require Import Coq.Classes.EquivDec. 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | 9 | Require Export usage_sig. 10 | 11 | (* ----------------------------------------------------------------- *) 12 | (* Lemmas about the usage pre-order / semi-ring. *) 13 | (* ----------------------------------------------------------------- *) 14 | 15 | Open Scope usage_scope. 16 | 17 | (* --------------- Derived lemmas below here. -------------------- *) 18 | 19 | Lemma usage_dec : forall x y, x =? y = true -> x = y. 20 | Proof. intros. rewrite -> eqb_eq in H. auto. Qed. 21 | 22 | (* --------------------------- *) 23 | 24 | Lemma qplus_0_r : forall x, x + 0 = x. 25 | Proof. 26 | intros. rewrite qplus_comm. rewrite qplus_0_l. auto. 27 | Qed. 28 | 29 | (* --------------------------- *) 30 | 31 | Lemma qplus_sub_r : forall u2 u u1, u1 <= u2 -> u1 + u <= u2 + u. 32 | Proof. 33 | intros; eapply po_semiring1; auto. 34 | Qed. 35 | 36 | Lemma qplus_sub_l : forall u2 u u1, u1 <= u2 -> u + u1 <= u + u2. 37 | Proof. 38 | intros; repeat rewrite (qplus_comm u). 39 | apply po_semiring1. auto. 40 | Qed. 41 | 42 | 43 | Lemma qplus_sub q1 q2 : 0 <= q2 -> q1 <= q1 + q2. 44 | Proof. 45 | intros. 46 | move: (po_semiring1 _ _ q1 H) => h. 47 | rewrite qplus_0_l in h. 48 | rewrite qplus_comm. 49 | auto. 50 | Qed. 51 | 52 | Lemma qmul_sub2 q1 q2 : 1 <= q2 -> q1 <= q1 * q2. 53 | Proof. 54 | move: (po_semiring3 1 q2 q1) => h. 55 | rewrite qmul_1_r in h. 56 | auto. 57 | Qed. 58 | 59 | Lemma qmul_sub_disposable : forall r q, 0 <= r -> 0 <= q * r. 60 | Proof. 61 | intros. 62 | move: (po_semiring3 _ _ q H) => h. 63 | rewrite qmul_0_r in h. 64 | auto. 65 | Qed. 66 | 67 | (* ----------------------------------------------------------------- *) 68 | (* Tactics and Hints *) 69 | (* ----------------------------------------------------------------- *) 70 | 71 | (* 72 | Add Ring usage_semi_ring : usage_semi_ring (decidable usage_dec). 73 | Hint Resolve usage_semi_ring : usage. 74 | *) 75 | 76 | Hint Rewrite qplus_0_l qplus_0_r qmul_0_l qmul_0_r qmul_1_l qmul_1_r qplus_assoc qmul_assoc distr_l distr_r : usage. 77 | 78 | Ltac ring_simpl := 79 | repeat autorewrite with usage. 80 | 81 | Tactic Notation "ring_simpl" "in" hyp(H) := 82 | repeat autorewrite with usage in H. 83 | 84 | Ltac ring_equal := 85 | repeat (ring_simpl; f_equal). 86 | 87 | Ltac asimpl := repeat (simpl; ring_simpl; simpl_env). 88 | 89 | Tactic Notation "asimpl" "in" hyp(H) := 90 | repeat (simpl in H; ring_simpl in H; simpl_env in H). 91 | 92 | 93 | (* ---------------------------------------------------------------- *) 94 | 95 | -------------------------------------------------------------------------------- /GraD/src/usage_sig.v: -------------------------------------------------------------------------------- 1 | (* Parameterization of the po-semiring *) 2 | 3 | Require Import Metalib.Metatheory. 4 | 5 | Require Import Coq.Structures.Orders. 6 | Require Import Coq.Bool.Sumbool. 7 | Require Import Coq.Program.Equality. 8 | 9 | Module Type UsageSig. 10 | 11 | Parameter usage : Set. 12 | Parameter Irr : usage. 13 | Parameter Lin : usage. 14 | Parameter qeqb : usage -> usage -> bool. 15 | Parameter qleb : usage -> usage -> bool. 16 | Parameter qplus : usage -> usage -> usage. 17 | Parameter qmul : usage -> usage -> usage. 18 | 19 | (* Equality *) 20 | Definition t := usage. 21 | Definition eq := @Logic.eq usage. 22 | Definition eqb := qeqb. 23 | Parameter q_eq_dec : forall (A : usage) (B : usage), { A = B } + { not (A = B) }. 24 | Instance equ : @EqDec_eq usage := q_eq_dec. 25 | Parameter eqb_eq : forall (n m : usage), qeqb n m = true <-> n = m. 26 | Definition eq_equiv : Equivalence (@Logic.eq usage) := eq_equivalence. 27 | Definition eq_dec := q_eq_dec. 28 | Include BackportEq. 29 | 30 | (* Size *) 31 | Definition size_usage : usage -> nat := fun _ => 1%nat. 32 | Lemma size_usage_min : forall q1, (1 <= size_usage q1). intros. unfold size_usage. auto. Qed. 33 | 34 | (* Notation *) 35 | Declare Scope usage_scope. 36 | Bind Scope usage_scope with usage. 37 | Local Open Scope usage_scope. 38 | 39 | Infix "=?" := qeqb (at level 70) : usage_scope. 40 | Infix "<=?" := qleb (at level 70) : usage_scope. 41 | Notation "q1 <= q2" := (is_true (qleb q1 q2)) (at level 70) : usage_scope. 42 | Notation "0" := Irr : usage_scope. 43 | Notation "1" := Lin : usage_scope. 44 | Notation "x + y" := (qplus x y) : usage_scope. 45 | Notation "x * y " := (qmul x y) : usage_scope. 46 | 47 | (* (Semi-)ring *) 48 | Axiom qplus_0_l : forall x, 0 + x = x. 49 | Axiom qmul_0_l : forall x, 0 * x = 0. 50 | Axiom qplus_comm : forall (n m : usage), n + m = m + n. 51 | Axiom qplus_assoc : forall (n m p : usage), n + (m + p) = (n + m) + p. 52 | Axiom qmul_1_l : forall n, 1*n = n. 53 | (*Axiom qmul_comm : forall n m, n*m = m*n. *) 54 | Axiom qmul_assoc : forall n m p, n*(m*p) = (n*m)*p. 55 | Axiom distr_l : forall n m p, (n + m)*p = n*p + m*p. 56 | 57 | (* Cannot derive these if multiplication is not commutative *) 58 | Axiom qmul_0_r : forall x, x * 0 = 0. 59 | Axiom qmul_1_r : forall n, n*1 = n. 60 | Axiom distr_r : forall n m p, p * (n + m) = p * n + p * m. 61 | 62 | (* Partial order *) 63 | Definition leb := qleb. 64 | Definition le n m := is_true (qleb n m). 65 | Axiom leb_le : forall (n m : usage), (n <=? m) = true <-> n <= m. 66 | Axiom qleb_refl : forall n, is_true (n <=? n). 67 | Axiom qleb_trans: forall m n p, is_true (n <=? m) -> is_true (m <=? p) -> is_true (n <=? p). 68 | 69 | Instance le_preorder : PreOrder le. 70 | Proof. split. intro x. apply qleb_refl. unfold Transitive. intros. eapply qleb_trans; eauto. Qed. 71 | 72 | Axiom po_semiring1 : forall a b c , a <= b -> a + c <= b + c. 73 | Axiom po_semiring2 : forall a b c , a <= b -> a * c <= b * c. 74 | Axiom po_semiring3 : forall a b c , a <= b -> c * a <= c * b. 75 | 76 | End UsageSig. 77 | 78 | Declare Module Usage : UsageSig. 79 | Export Usage. 80 | 81 | 82 | (* Graded contexts, i.e. association lists that include annotated usage information *) 83 | 84 | Section UsageCtx. 85 | Variables A : Type. 86 | 87 | Local Open Scope usage_scope. 88 | 89 | 90 | Definition sort_mul (q: usage) (s : usage * A) : usage * A := 91 | match s with 92 | | (q1 , A) => (qmul q q1, A) 93 | end. 94 | 95 | Definition ctx_mul (q : usage) G := 96 | map (sort_mul q) G. 97 | 98 | 99 | Definition add_usage (q : usage) (D: list (var * A)) : list (var * (usage * A)) := 100 | map (fun x => (q, x)) D. 101 | 102 | Definition ungrade (G: list (var * (usage * A))) : list (var * A) := 103 | map snd G. 104 | 105 | Fixpoint ctx_plus (G1 G2 : list (var * (usage * A))) : list (var * (usage * A)) := 106 | match G1, G2 with 107 | | nil , nil => nil 108 | | cons (x , (q1 , A)) G1' , cons (_, (q2, _)) G2' => cons (x, (q1 + q2, A)) (ctx_plus G1' G2') 109 | | _ , _ => nil 110 | end. 111 | 112 | Inductive ctx : list (atom * A) -> list (atom * (usage * A)) -> Prop := 113 | | ctx_nil : 114 | ctx nil nil 115 | | ctx_cons : forall D (x:atom) G (q:usage) a, 116 | ctx D G -> 117 | ~ AtomSetImpl.In x (dom D) -> 118 | ctx (x ~ a ++ D ) (x ~ (q,a) ++ G). 119 | 120 | Inductive ctx_sub : list (atom * A) -> list (atom * (usage * A))-> list (atom * (usage * A)) -> Prop := 121 | | CS_Empty : ctx_sub nil nil nil 122 | | CS_ConsTm : forall D (x:atom) (a:A) G1 (q1:usage) G2 q2, 123 | ( q1 <= q2 ) -> 124 | ctx_sub D G1 G2 -> 125 | ~ AtomSetImpl.In x (dom D) -> 126 | ctx_sub (x ~ a ++ D) (x ~ (q1 ,a) ++ G1) (x ~ (q2,a) ++ G2). 127 | 128 | End UsageCtx. 129 | 130 | 131 | 132 | Section UsageList. 133 | Local Open Scope usage_scope. 134 | 135 | Fixpoint oplus (G1 G2 : list usage) : list usage := 136 | match G1, G2 with 137 | | nil , nil => nil 138 | | cons q1 G1' , cons q2 G2' => cons (q1 + q2) (oplus G1' G2') 139 | | _ , _ => nil 140 | end. 141 | 142 | Definition ozero {A} (G : list A) : list usage := 143 | List.map (fun _ => 0) G. 144 | 145 | Definition Qs {A} (h : list (atom * (usage * A))) : list usage := 146 | List.map (fun x => match x with | (_,(u, _)) => u end) h. 147 | 148 | Lemma Qs_app : forall {A} (h1 h2 : list (atom * (usage * A))), Qs (h1 ++ h2) = Qs h1 ++ Qs h2. 149 | Proof. 150 | intros. 151 | unfold Qs. 152 | rewrite List.map_app. 153 | auto. 154 | Qed. 155 | 156 | End UsageList. 157 | 158 | Arguments sort_mul {_}. 159 | Arguments ctx_mul {_}. 160 | Arguments ctx_plus {_}. 161 | Arguments ctx {_}. 162 | Arguments ctx_sub {_}. 163 | Arguments add_usage {_}. 164 | Arguments ungrade {_}. 165 | 166 | Hint Constructors ctx : core. 167 | Hint Constructors ctx_sub : core. 168 | 169 | 170 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Stephanie Weirich 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Graded Haskell 2 | ============= 3 | 4 | This repository contains mechanizations for two dependently-typed languages 5 | with graded types --- i.e. type systems where each variable in the context is 6 | annotated by some label drawn from an algebraic structure. 7 | 8 | * DDC uses a lattice of dependency labels to track runtime and compiletime irrelevance 9 | * GraD uses a semiring of grades to track resource usage 10 | 11 | [DDC](DDC/) 12 | ----------- 13 | 14 | "A Dependent Dependency Calculus", paper by Pritam Choudhury, Harley Eades III, and Stephanie Weirich. 15 | Published in [ESOP 2022](https://etaps.org/2022/esop). The paper is part of the [open-access proceedings](https://link.springer.com/book/10.1007/978-3-030-99336-8) (with a local copy [here](DDC/esop2022-paper111.pdf)). 16 | 17 | Pritam's [ESOP 2022 video](https://www.youtube.com/watch?v=e_heE6IoN8Y) about this work (22 minutes). 18 | 19 | Stephanie's [Edinburgh seminar talk](DDC/edinburgh.pdf) (June 2022). 20 | 21 | The extended version of the paper, with the full appendix, is available from [arXiv](https://arxiv.org/abs/2201.11040). 22 | 23 | This [repository](DDC/) proves type soundness for DDC, including the 24 | consistency of a grade-indexed definitional equivalence. 25 | 26 | A [Virtual Box](https://zenodo.org/record/5903727#.YfqZGvXMLUI) containing the Coq proof 27 | scripts is archived on Zenodo. 28 | 29 | [GraD](GraD/) 30 | ------------- 31 | 32 | "A Graded Dependent Type System with a Usage-Aware Semantics", by Pritam 33 | Choudhury, Harley Eades III, Richard A. Eisenberg and Stephanie Weirich. 34 | Published in POPL 2021 and available 35 | [here](https://dl.acm.org/doi/10.1145/3434331) 36 | (with a local copy [here](https://github.com/sweirich/graded-haskell/blob/main/popl21-choudhury.pdf)). 37 | 38 | Pritam's [POPL 2021 video](https://www.youtube.com/watch?v=yrwtXrey7mE) about this work (30 minutes). 39 | 40 | The extended version of the paper is available from [arXiv](https://arxiv.org/abs/2011.04070). 41 | 42 | This [repository](GraD/src) proves type soundness for GraD, assuming the consistency of an 43 | unspecified definitional equivalence. 44 | 45 | The artifact has been [archived in the ACM digital library](https://dl.acm.org/do/10.1145/3410265/full/). 46 | 47 | A [Virtual Box](https://www.cis.upenn.edu/~sweirich/popl2021-paper408.ova) containing the Coq proof 48 | scripts is available. 49 | 50 | -------------------------------------------------------------------------------- /ddc.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/graded-haskell/986ac74f0cb5d38c11307beb5b05e9eb2e0bd0ed/ddc.pdf -------------------------------------------------------------------------------- /popl21-choudhury.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/graded-haskell/986ac74f0cb5d38c11307beb5b05e9eb2e0bd0ed/popl21-choudhury.pdf --------------------------------------------------------------------------------