├── .gitignore ├── LICENSE ├── Makefile ├── README ├── _CoqProject ├── description ├── doc ├── coqincoq.ps.gz └── proof-checker.ps.gz ├── tests ├── Extract.v ├── Makefile ├── newman.coc └── top.ml └── theories ├── Can.v ├── Class.v ├── Consistency.v ├── Conv.v ├── Conv_Dec.v ├── ETypes.v ├── Equiv.v ├── Ered.v ├── Expr.v ├── ImpVar.v ├── Infer.v ├── Int_stab.v ├── Int_term.v ├── Int_typ.v ├── ListType.v ├── Machine.v ├── MlTypes.v ├── MyList.v ├── Names.v ├── Strong_Norm.v ├── Termes.v └── Types.v /.gitignore: -------------------------------------------------------------------------------- 1 | .lia.cache 2 | Makefile.coq 3 | Makefile.coq.conf 4 | .Makefile.coq.d 5 | tests/coc 6 | tests/core.ml* 7 | tests/*.o 8 | tests/*.cmx 9 | tests/*.cmi 10 | theories/*.aux 11 | theories/*.glob 12 | theories/*.vo 13 | theories/*.vos 14 | theories/*.vok 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: Makefile.coq 2 | +make -f Makefile.coq all 3 | 4 | clean: Makefile.coq 5 | +make -f Makefile.coq clean 6 | +make -C tests clean 7 | rm -f Makefile.coq 8 | 9 | Makefile.coq: _CoqProject 10 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 11 | 12 | test: theories/Machine.vo 13 | +make -C tests all 14 | 15 | _CoqProject: ; 16 | 17 | %: Makefile.coq 18 | +make -f Makefile.coq $@ 19 | 20 | .PHONY: all clean test 21 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | 2 | Contribution Rocq/COC 3 | ===================== 4 | 5 | This directory contains: 6 | 7 | - A formalization in Coq of the metatheory of the Calculus of 8 | Constructions and the interface of a standalone proof-checker 9 | based on this type system. 10 | - The proof-checker, produced by extraction. 11 | 12 | Author & Date: Bruno Barras 13 | INRIA-Rocquencourt 14 | October 1997 15 | E-mail : Bruno.Barras@inria.fr 16 | WWW : http://pauillac.inria.fr/~barras 17 | 18 | Installation procedure: 19 | ----------------------- 20 | 21 | To get this contribution compiled, type 22 | 23 | make 24 | 25 | or 26 | 27 | make opt 28 | 29 | It will compile all the proofs and perform the extraction. Then, it will 30 | compile the proof-checker (called coc). As an example, the file newman.coc 31 | is checked with coc. 32 | 33 | 34 | Description: 35 | ------------ 36 | 37 | The essential step of the formal verification of a proof-checker 38 | such as Coq is the verification of its kernel: a type-checker for the 39 | Calculus of Inductive Constructions (CIC) which is its underlying 40 | formalism. The present work is a first small-scale attempt on a 41 | significative fragment of CIC: the Calculus of Constructions (CC) 42 | designed by Huet and Coquand in 1985. It is defined with De Bruijn 43 | indices notation. The whole metatheory of this calculus is proved in 44 | the following order: 45 | 46 | - Confluence of beta-reduction 47 | - Inversion lemma 48 | - Thinning lemma 49 | - Subsitution lemma 50 | - Type Correctness 51 | - Subject Reduction 52 | - Strong Normalisation 53 | - Decidability of Type Inference and Type Checking 54 | 55 | From the latter proof, we extract a certified Objective Caml 56 | program, which performs type inference (or type-checking) for an 57 | arbitrary typing judgement in CC. Integrating this program in a larger 58 | system, including a parser and pretty-printer, we obtain a stand-alone 59 | proof-checker, called Coc, for the Calculus of Constructions. As an 60 | example, the formal proof of Newman's lemma, build with Coq, can be 61 | re-verified by Coc with reasonable performance. 62 | 63 | Upon this kernel, we formalized the interface of a small 64 | proof-checker, based on the type-checking functions above, but it 65 | seems the ideas can generalize to other type systems, as far as they 66 | are based on the proofs-as-terms principle. We suppose that the 67 | metatheory of the corresponding type system is proved (up to type 68 | decidability). We specify and certify the toplevel loop, the system 69 | invariant, and the error messages. 70 | 71 | 72 | Further information on this contribution: 73 | ----------------------------------------- 74 | 75 | A first description of the proofs can be found as an INRIA technical 76 | report (in french), number 3026, october 1996. 77 | 78 | The current updated version was described in a paper (see 79 | coqincoq.ps.gz). It also describes the strong normalization proof. 80 | 81 | Last, the proof-checker was formalized in another paper included in 82 | this contribution. See ./proof-checker.ps.gz 83 | 84 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories CoqInCoq 2 | 3 | # List of vernac files to compile 4 | theories/MyList.v 5 | theories/ListType.v 6 | theories/Names.v 7 | theories/MlTypes.v 8 | theories/Termes.v 9 | theories/Conv.v 10 | theories/Types.v 11 | theories/Conv_Dec.v 12 | theories/Class.v 13 | theories/Can.v 14 | theories/Int_term.v 15 | theories/Int_typ.v 16 | theories/Int_stab.v 17 | theories/Strong_Norm.v 18 | theories/Consistency.v 19 | theories/Infer.v 20 | theories/Expr.v 21 | theories/Machine.v 22 | theories/Ered.v 23 | theories/ETypes.v 24 | theories/Equiv.v 25 | -------------------------------------------------------------------------------- /description: -------------------------------------------------------------------------------- 1 | Name: CoqInCoq 2 | Title: A formalisation of the Calculus of Construction 3 | Author: Bruno Barras 4 | Institution: INRIA Rocquencourt 5 | Description: 6 | Keywords: calculus of constructions 7 | Category: Mathematics/Logic/Type theory 8 | Category: Miscellaneous/Extracted Programs/Type checking unification and normalization 9 | -------------------------------------------------------------------------------- /doc/coqincoq.ps.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rocq-archive/coq-in-coq/15804c9d1d5cf7a70cd32c315e7b87cfa815402e/doc/coqincoq.ps.gz -------------------------------------------------------------------------------- /doc/proof-checker.ps.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rocq-archive/coq-in-coq/15804c9d1d5cf7a70cd32c315e7b87cfa815402e/doc/proof-checker.ps.gz -------------------------------------------------------------------------------- /tests/Extract.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Termes. 19 | Require Import Conv. 20 | Require Import Types. 21 | Require Import Conv_Dec. 22 | Require Import Infer. 23 | Require Import Names. 24 | Require Import Expr. 25 | Require Import Machine. 26 | Require Extraction. 27 | 28 | Extract Inductive bool => "bool" [ "true" "false" ]. 29 | Extract Inductive sumbool => "bool" [ "true" "false" ]. 30 | Extract Inductive sumor => "option" [ "Some" "None" ]. 31 | 32 | (* integers *) 33 | 34 | Extract Inlined Constant ml_int => "int". 35 | Extract Constant ml_eq_int => "(=)". 36 | Extract Constant ml_zero => "0". 37 | Extract Constant ml_int_case => "function 0 -> None | n -> Some (pred n)". 38 | Extract Inlined Constant ml_succ => "succ". 39 | 40 | (* strings *) 41 | 42 | Extract Inlined Constant ml_string => "string". 43 | Extract Constant ml_eq_string => "(=)". 44 | Extract Constant ml_x_int => "fun n -> ""x"" ^ (string_of_int n)". 45 | 46 | Extraction 47 | NoInline list_index is_free_var check_typ red_to_sort red_to_prod exec_axiom 48 | glob_ctx glob_names empty_state name_dec find_free_var synthesis 49 | interp_command transl_message transl_error interp_ast. 50 | 51 | Extraction "core.ml" is_free_var empty_state interp_ast. 52 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLFIND ?= ocamlfind 2 | OCAMLOPTC ?= "$(OCAMLFIND)" opt 3 | 4 | all: coc 5 | 6 | coc: core.ml core.mli top.ml newman.coc 7 | $(OCAMLOPTC) -c core.mli 8 | $(OCAMLOPTC) -c core.ml 9 | $(OCAMLOPTC) -c -pp "camlp4o" top.ml 10 | $(OCAMLOPTC) -o coc core.cmx top.cmx 11 | @echo '***** test: checking the proof of the Newman lemma *****' 12 | ./coc < newman.coc 13 | @echo '******************** End of test ***********************' 14 | 15 | clean: 16 | rm -f core.ml core.mli *.cmx *.cmi *.o 17 | 18 | # Building core.ml : we do not want an Extract.vo to be produced 19 | core.ml core.mli: Extract.v 20 | $(COQBIN)coqtop -R ../theories CoqInCoq -batch -load-vernac-source Extract.v 21 | 22 | .PHONY: all clean 23 | -------------------------------------------------------------------------------- /tests/newman.coc: -------------------------------------------------------------------------------- 1 | 2 | Axiom A : Set. 3 | Axiom R : A->A->Prop. 4 | 5 | 6 | (* Axioms to encode definitions *) 7 | 8 | Axiom Rstar:A->A->Prop. 9 | Axiom unfold_Rstar: (P:(A->A->Prop)->Prop) 10 | (P [x,y:A](P0:A->A->Prop) 11 | ((u:A)(P0 u u)) 12 | ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y)) 13 | ->(P Rstar). 14 | 15 | Axiom Rstar':A->A->Prop. 16 | Axiom unfold_Rstar': (P:(A->A->Prop)->Prop) 17 | (P [x,y:A](P:A->A->Prop) 18 | (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y)) 19 | ->(P Rstar'). 20 | 21 | Axiom coherence: A->A->Prop. 22 | Axiom unfold_coherence: (P:(A->A->Prop)->Prop) 23 | (P [x:A][y:A](P:Prop)((z:A)(Rstar x z)->(Rstar y z)->P)->P) 24 | ->(P coherence). 25 | 26 | 27 | 28 | (* The main hypotheses of Newman's Lemma *) 29 | 30 | Axiom Hyp1:(x:A)(P:A->Prop)((y:A)((z:A)(R y z)->(P z))->(P y))->(P x). 31 | Axiom Hyp2:(x:A)(y:A)(z:A)(R x y)->(R x z)->(coherence y z). 32 | 33 | 34 | (* Checking the proof *) 35 | 36 | Check 37 | 38 | let Rstar_reflexive: (x:A)(Rstar x x) 39 | := [x:A](unfold_Rstar [P:A->A->Prop](P x x) 40 | [P0:A->A->Prop] 41 | [H:(u:A)(P0 u u)] 42 | [_:(u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w)](H x)) 43 | in 44 | 45 | let Rstar_R: (x:A)(y:A)(z:A)(R x y)->(Rstar y z)->(Rstar x z) 46 | := [x,y,z:A][t1:(R x y)] 47 | (unfold_Rstar [P:A->A->Prop](P y z)->(P x z) 48 | [t2:(P0:A->A->Prop) 49 | ((u:A)(P0 u u)) 50 | ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 y z)] 51 | [P:A->A->Prop][h1:(u:A)(P u u)] 52 | [h2:(u:A)(v:A)(w:A)(R u v)->(P v w)->(P u w)] 53 | (h2 x y z t1 (t2 [a,a0:A](P a a0) h1 h2))) 54 | in 55 | 56 | let Rstar_transitive: (x:A)(y:A)(z:A)(Rstar x y)->(Rstar y z)->(Rstar x z) 57 | := [x,y,z:A](unfold_Rstar [P:A->A->Prop](P x y)->(Rstar y z)->(Rstar x z) 58 | [h:(P0:A->A->Prop) 59 | ((u:A)(P0 u u)) 60 | ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y)] 61 | (h [a,a0:A](Rstar a0 z)->(Rstar a z) [u:A][H:(Rstar u z)]H 62 | [u,v,w:A][t1:(R u v)][t2:(Rstar w z)->(Rstar v z)] 63 | [t3:(Rstar w z)](Rstar_R u v z t1 (t2 t3)))) 64 | in 65 | 66 | let Rstar'_reflexive: (x:A)(Rstar' x x) 67 | := [x:A](unfold_Rstar' [P:A->A->Prop](P x x) 68 | [P:A->A->Prop][H:(P x x)][_:(u:A)(R x u)->(Rstar u x)->(P x x)]H) 69 | in 70 | 71 | let Rstar'_R: (x:A)(y:A)(z:A)(R x z)->(Rstar z y)->(Rstar' x y) 72 | := [x,y,z:A][t1:(R x z)][t2:(Rstar z y)] 73 | (unfold_Rstar' [P:A->A->Prop](P x y) 74 | [P:A->A->Prop] 75 | [_:(P x x)][h2:(u:A)(R x u)->(Rstar u y)->(P x y)](h2 z t1 t2)) 76 | in 77 | 78 | let Rstar'_Rstar: (x:A)(y:A)(Rstar' x y)->(Rstar x y) 79 | := [x,y:A](unfold_Rstar' [P:A->A->Prop](P x y)->(Rstar x y) 80 | [h:(P:A->A->Prop) 81 | (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y)] 82 | (h [a,a0:A](Rstar a a0) (Rstar_reflexive x) [u:A](Rstar_R x u y))) 83 | in 84 | 85 | let Rstar_Rstar': (x:A)(y:A)(Rstar x y)->(Rstar' x y) 86 | := [x,y:A](unfold_Rstar [P:A->A->Prop](P x y)->(Rstar' x y) 87 | [h:(P0:A->A->Prop) 88 | ((u:A)(P0 u u)) 89 | ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y)] 90 | (h Rstar' [u:A](Rstar'_reflexive u) 91 | [u,v,w:A][h1:(R u v)] 92 | [h2:(Rstar' v w)](Rstar'_R u w v h1 (Rstar'_Rstar v w h2)))) 93 | in 94 | 95 | let coherence_intro : (x:A)(y:A)(z:A)(Rstar x z)->(Rstar y z) 96 | ->(coherence x y) 97 | := [x,y,z:A][H:(Rstar x z)][H0:(Rstar y z)] 98 | (unfold_coherence [P:A->A->Prop](P x y) 99 | [P:Prop][H1:(z0:A)(Rstar x z0)->(Rstar y z0)->P](H1 z H H0)) 100 | in 101 | 102 | let Rstar_coherence : (x:A)(y:A)(Rstar x y)->(coherence x y) 103 | := [x,y:A][h:(Rstar x y)](coherence_intro x y y h (Rstar_reflexive y)) 104 | in 105 | 106 | let coherence_sym: (x:A)(y:A)(coherence x y)->(coherence y x) 107 | := [x,y:A](unfold_coherence [P:A->A->Prop](P x y)->(P y x) 108 | [H:(P:Prop)((z:A)(Rstar x z)->(Rstar y z)->P)->P][P:Prop] 109 | [H0:(z:A)(Rstar y z)->(Rstar x z)->P] 110 | (H P [z:A][H1:(Rstar x z)][H2:(Rstar y z)](H0 z H2 H1))) 111 | in 112 | 113 | let Diagram: 114 | (x:A)((u:A)(R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)) 115 | ->(y,z,u:A)(R x u)->(Rstar u y) 116 | ->(v:A)(R x v)->(Rstar v z)->(coherence y z) 117 | := [x:A][hyp_ind:(u:A) 118 | (R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)] 119 | [y,z,u:A][t1:(R x u)][t2:(Rstar u y)][v:A][u1:(R x v)][u2:(Rstar v z)] 120 | (unfold_coherence 121 | [P:A->A->Prop] 122 | ((x0,y0,z0:A)(R x0 y0)->(R x0 z0)->(P y0 z0)) 123 | ->((u0:A)(R x u0) 124 | ->(y0,z0:A)(Rstar u0 y0)->(Rstar u0 z0)->(P y0 z0)) 125 | ->(coherence y z) 126 | [Hyp0:(x0,y0,z0:A)(R x0 y0)->(R x0 z0) 127 | ->(P:Prop)((z1:A)(Rstar y0 z1)->(Rstar z0 z1)->P)->P] 128 | [hyp_ind0:(u0:A)(R x u0)->(y0,z0:A)(Rstar u0 y0)->(Rstar u0 z0) 129 | ->(P:Prop)((z1:A)(Rstar y0 z1)->(Rstar z0 z1)->P)->P] 130 | (Hyp0 x u v t1 u1 (coherence y z) 131 | [z0:A][H:(Rstar u z0)][H0:(Rstar v z0)] 132 | (hyp_ind0 u t1 y z0 t2 H (coherence y z) 133 | [z1:A][H1:(Rstar y z1)][H2:(Rstar z0 z1)] 134 | (hyp_ind0 v u1 z z1 u2 135 | (Rstar_transitive v z0 z1 H0 H2) 136 | (coherence y z) 137 | [z2:A][H3:(Rstar z z2)][H4:(Rstar z1 z2)] 138 | (unfold_coherence [P:A->A->Prop](P y z) 139 | [P:Prop] 140 | [H5:(z3:A)(Rstar y z3)->(Rstar z z3)->P] 141 | (H5 z2 142 | (Rstar_transitive y z1 z2 H1 H4) H3))))) 143 | Hyp2 hyp_ind) 144 | in 145 | 146 | let caseRxy: 147 | (x:A)((u:A)(R x u)->(y,z:A)(Rstar u y)->(Rstar u z)->(coherence y z)) 148 | ->(y,z:A)(Rstar x y)->(Rstar x z) 149 | ->(u:A)(R x u)->(Rstar u y)->(coherence y z) 150 | := [x:A][hyp_ind:(u:A) 151 | (R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)] 152 | [y,z:A][h1:(Rstar x y)][h2:(Rstar x z)][u:A][t1:(R x u)][t2:(Rstar u y)] 153 | (unfold_Rstar' [P:A->A->Prop](P x z)->(coherence y z) 154 | [hyp_:(P:A->A->Prop)(P x x) 155 | ->((u0:A)(R x u0)->(Rstar u0 z)->(P x z))->(P x z)] 156 | (hyp_ [_:A][a:A](coherence y a) 157 | (coherence_sym x y (Rstar_coherence x y h1)) 158 | (Diagram x hyp_ind y z u t1 t2)) 159 | (Rstar_Rstar' x z h2)) 160 | in 161 | 162 | let Ind_proof : 163 | (x:A)((u:A)(R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)) 164 | ->(y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z) 165 | := [x:A][hyp_ind:(u:A) 166 | (R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)] 167 | [y,z:A][h1:(Rstar x y)][h2:(Rstar x z)] 168 | (unfold_Rstar' [P:A->A->Prop](P x y)->(coherence y z) 169 | [hyp_:(P:A->A->Prop) 170 | (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y)] 171 | (hyp_ [_:A][a:A](coherence a z) (Rstar_coherence x z h2) 172 | (caseRxy x hyp_ind y z h1 h2)) 173 | (Rstar_Rstar' x y h1)) 174 | in 175 | 176 | [x:A](Hyp1 x 177 | [x:A](y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z) Ind_proof) 178 | 179 | : (x:A)(y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z). 180 | 181 | (* Prints "Correct" if the proof is OK *) 182 | 183 | -------------------------------------------------------------------------------- /tests/top.ml: -------------------------------------------------------------------------------- 1 | open Genlex 2 | open Core 3 | 4 | (*> lexer *) 5 | let string_of_token = function 6 | Kwd k -> k 7 | | Ident i -> i 8 | | Int i -> string_of_int i 9 | | Float f -> string_of_float f 10 | | String s -> s 11 | | Char c -> String.make 1 c 12 | ;; 13 | 14 | let lexer= 15 | make_lexer 16 | ["Set"; "Prop"; "Kind"; 17 | "["; "]"; "("; ")"; ":"; "->"; "let"; "in"; "_"; ","; 18 | ":="; "Quit";"Axiom";"Infer";"Check";"Delete";"List";"."] 19 | ;; 20 | 21 | (*> parser *) 22 | let rec parse_star p = parser 23 | [< x = p; l = (parse_star p) >] -> x::l 24 | | [< >] -> [] 25 | ;; 26 | 27 | let anon_var = parser 28 | [< 'Kwd "_" >] -> "_" 29 | | [< 'Ident x >] -> x 30 | ;; 31 | 32 | let virg_an_var = parser 33 | [< 'Kwd "," ; x = anon_var (*, ^ (|_)*) >] -> x 34 | ;; 35 | 36 | let lident = parser 37 | [< x = anon_var; l = (parse_star virg_an_var) >] -> x::l 38 | ;; 39 | 40 | let parse_atom = parser 41 | [< 'Kwd "Prop" >] -> SRT Prop 42 | | [< 'Kwd "Set" >] -> SRT Set 43 | | [< 'Kwd "Kind" >] -> SRT Kind 44 | | [< 'Ident x >] -> REF x 45 | ;; 46 | 47 | let rec parse_expr = parser 48 | [< 'Kwd "["; 49 | l = lident (*[ ^ *); 50 | 'Kwd ":" (*[ * ^ (,|:)*); 51 | typ = parse_expr (*[ ... : ^ *); 52 | 'Kwd "]" (*[ ... : ^ ]*); 53 | trm = parse_expr (*[ ... ] ^ *) 54 | >] -> List.fold_right (fun x t->ABS (x,typ,t)) l trm 55 | 56 | | [< 'Kwd "let"; 57 | x = anon_var (*let ^ *); 58 | 'Kwd ":" (*let ^ :*); 59 | typ = parse_expr (*let : ^ *); 60 | 'Kwd ":=" (*let : ^ :=*); 61 | arg = parse_expr (*let ... := ^ *); 62 | 'Kwd "in" (*let ... := ^ in*); 63 | trm = parse_expr (*let ... in ^ *) 64 | >] -> APP (ABS (x,typ,trm), arg) 65 | 66 | | [< 'Kwd "(" ; r = parse_expr1 (*( ^ (|)*) >] -> r 67 | 68 | | [< at = parse_atom; r = (parse_expr2 at) >] -> r 69 | 70 | and parse_expr1 = parser 71 | [< 'Kwd "_"; r = (parse_end_pi ["_"]) >] -> r 72 | 73 | | [< 'Ident x; r = (parse_expr3 x) >] -> r 74 | 75 | | [< t1 = parse_expr; 76 | l = (parse_star parse_expr); 77 | 'Kwd ")" (*( * ^ )*); 78 | r = (parse_expr2 (List.fold_left (fun t a->APP (t,a)) t1 l)) 79 | >] -> r 80 | 81 | and parse_expr2 at = parser 82 | [< 'Kwd "->"; 83 | t = parse_expr (*( ) -> ^ *) 84 | >] -> PROD ("_",at,t) 85 | 86 | | [< >] -> at 87 | 88 | and parse_expr3 x = parser 89 | [< 'Kwd ","; 90 | y = anon_var (*( , ^ (|_)*); 91 | r = (parse_end_pi [x;y]) 92 | >] -> r 93 | 94 | | [< 'Kwd ":"; 95 | typ = parse_expr (*( : ^ *); 96 | 'Kwd ")" (*( : ^ )*); 97 | trm = parse_expr (*( ... ) ^ *) 98 | >] -> PROD(x,typ,trm) 99 | 100 | | [< 'Kwd "->"; 101 | t = parse_expr (*( -> ^ *); 102 | l = (parse_star parse_expr) (*( -> ^ *); 103 | 'Kwd ")" (*( * ^ )*); 104 | str 105 | >] -> parse_expr2 (List.fold_left (fun t a->APP(t,a)) 106 | (PROD ("_",(REF x),t)) l) str 107 | 108 | | [< l = (parse_star parse_expr); 109 | 'Kwd ")" (*( * ^ )*); 110 | str 111 | >] -> parse_expr2 (List.fold_left (fun t a->APP(t,a)) (REF x) l) str 112 | 113 | and parse_end_pi lb = parser 114 | [< l = (parse_star virg_an_var); 115 | 'Kwd ":" (*( * ^ :*); 116 | typ = parse_expr (*( * : ^ *); 117 | 'Kwd ")" (*( * : ^ )*); 118 | trm = parse_expr (*( ... ) ^ *) 119 | >] -> List.fold_right (fun x t->PROD(x,typ,t)) (lb@l) trm 120 | ;; 121 | 122 | 123 | let prompt () = print_string "\nCoc < "; flush stdout;; 124 | 125 | let parse_ast strm = 126 | prompt(); 127 | match strm with parser 128 | [< 'Kwd "Infer"; 129 | e = parse_expr (*Infer ^ *) 130 | >] -> AST_INFER e 131 | 132 | | [< 'Kwd "Axiom"; 133 | 'Ident x (*Axiom ^ *); 134 | 'Kwd ":" (*Axiom ^ :*); 135 | e = parse_expr (*Axiom : ^ *) 136 | >] -> AST_AXIOM(x,e) 137 | 138 | | [< 'Kwd "Check"; 139 | e1 = parse_expr (*Check ^ *); 140 | 'Kwd ":" (*Check ^ :*); 141 | e2 = parse_expr (*Check : ^ *) 142 | >] -> AST_CHECK(e1,e2) 143 | 144 | | [< 'Kwd "Delete" >] -> AST_DELETE 145 | 146 | | [< 'Kwd "List" >] -> AST_LIST 147 | 148 | | [< 'Kwd "Quit" >] -> AST_QUIT 149 | ;; 150 | 151 | 152 | (*> affichage *) 153 | let string_of_sort = function 154 | Kind -> "Kind" 155 | | Prop -> "Prop" 156 | | Set -> "Set" 157 | ;; 158 | 159 | let rec string_of_expr = function 160 | SRT s -> string_of_sort s 161 | | REF x -> x 162 | | ABS (x,tt,t) -> "["^x^":"^(string_of_expr tt)^"]"^(string_of_expr t) 163 | | APP (u,v) -> "("^(string_of_app u)^" "^(string_of_expr v)^")" 164 | | PROD (x,tt,u) -> 165 | (match is_free_var x u with 166 | true -> "("^x^":"^(string_of_expr tt)^")"^(string_of_expr u) 167 | | false -> (string_of_arrow tt)^"->"^(string_of_expr u)) 168 | 169 | and string_of_app = function 170 | APP (u,v) -> (string_of_app u)^" "^(string_of_expr v) 171 | | t -> string_of_expr t 172 | 173 | and string_of_arrow = function 174 | ABS (x0,x1,x2) -> "("^(string_of_expr (ABS (x0,x1,x2)))^")" 175 | | PROD (x0,x1,x2) -> "("^(string_of_expr (PROD (x0,x1,x2)))^")" 176 | | t -> string_of_expr t 177 | ;; 178 | 179 | let print_expr e = print_string (string_of_expr e);; 180 | 181 | 182 | let rec print_names = function 183 | Nil -> () 184 | | Cons (x,l) -> 185 | print_names l; 186 | print_string (x^" ") 187 | ;; 188 | 189 | (* 190 | let rec print_terms = function 191 | Nil -> () 192 | | Cons(t,l) -> 193 | print_string "x. : "; 194 | print_term t; 195 | print_newline(); 196 | print_terms l 197 | ;; 198 | 199 | let print_local_ctx = function 200 | Nil -> print_newline() 201 | | l -> 202 | print_endline "Dans le contexte:"; 203 | print_terms l 204 | ;; 205 | *) 206 | 207 | let print_message = function 208 | Pnew_axiom x -> 209 | print_endline (x^" admis.") 210 | | Pinfered_type e -> 211 | print_string "Type infere: "; 212 | print_expr e; 213 | print_newline() 214 | | Pcorrect -> 215 | print_endline "Correct." 216 | | Pcontext_listing l -> 217 | print_string "Axiomes: "; 218 | print_names l; 219 | print_newline() 220 | | Pdelete_axiom x -> 221 | print_endline (x^" supprime.") 222 | | Pexiting -> 223 | print_endline "\nAu revoir..."; exit 0 224 | ;; 225 | 226 | let rec print_type_err = function 227 | Punder (x,e,err) -> 228 | print_string x; 229 | print_string " : "; 230 | print_expr e; 231 | print_newline(); 232 | print_type_err err 233 | | Pexpected_type(m,at,et) -> 234 | print_string "Le terme "; 235 | print_expr m; 236 | print_string " a le type "; 237 | print_expr at; 238 | print_string " mais est utilise avec le type "; 239 | print_expr et; 240 | print_endline "." 241 | | Pkind_ill_typed -> 242 | print_endline "Kind est mal type." 243 | | Pdb_error n -> 244 | print_string "Variable de de Bruijn #"; 245 | print_int (int_of_nat n); 246 | print_endline " libre." 247 | | Plambda_kind t -> 248 | print_string "Le terme "; 249 | print_expr t; 250 | print_endline " est une abstraction sur une kind." 251 | | Pnot_a_type(m,t) -> 252 | print_string "Le type de "; 253 | print_expr m; 254 | print_string ", qui est "; 255 | print_expr t; 256 | print_endline " ne se reduit pas vers une sorte." 257 | | Pnot_a_fun(m,t) -> 258 | print_string "Le type de "; 259 | print_expr m; 260 | print_string ", qui est "; 261 | print_expr t; 262 | print_endline " ne se reduit pas vers un produit." 263 | | Papply_err(u,tu,v,tv) -> 264 | print_string "Le terme "; 265 | print_expr u; 266 | print_string " de type "; 267 | print_expr tu; 268 | print_string " ne peut etre applique a "; 269 | print_expr v; 270 | print_string " qui a pour type "; 271 | print_expr tv; 272 | print_endline "." 273 | ;; 274 | 275 | let print_type_error err = 276 | begin 277 | match err with 278 | Punder _ -> 279 | print_endline "Dans le contexte:"; 280 | | _ -> () 281 | end; 282 | print_type_err err 283 | ;; 284 | 285 | 286 | let print_error = function 287 | Punbound_vars l -> 288 | print_string "Variables inconnues: [ "; 289 | print_names l; 290 | print_endline "]." 291 | | Pname_clash x -> 292 | print_endline ("Nom "^x^" deja utilise.") 293 | | Ptype_error te -> 294 | print_type_error te 295 | | Pcannot_delete -> 296 | print_endline "Contexte deja vide." 297 | ;; 298 | 299 | 300 | 301 | (*> encapsulation de l'etat *) 302 | let update_state = 303 | let state = ref empty_state in 304 | (fun ast -> 305 | match (interp_ast !state ast) with 306 | Inl(Pair(ns,msg)) -> 307 | print_message msg; 308 | state := ns 309 | | Inr err -> 310 | print_string "Erreur: "; 311 | print_error err) 312 | ;; 313 | 314 | 315 | (*> boucle toplevel *) 316 | 317 | 318 | let rec discarder stk strm = 319 | let head_tok = 320 | try 321 | match strm with parser 322 | | [< 't >] -> Some t 323 | | [< >] -> None 324 | with 325 | Stream.Error s when (* lexer error *) 326 | (String.sub s 0 17) = "Illegal character" 327 | -> Some (Char s.[18]) 328 | in 329 | match head_tok with 330 | Some (Kwd ".") -> List.rev ((Kwd ".")::stk) 331 | | Some tok -> discarder (tok::stk) strm 332 | | None -> [] 333 | ;; 334 | 335 | let skip_til_dot err_msg strm = 336 | let toklst = discarder [] strm in 337 | if toklst <> [] then 338 | begin 339 | print_string "\nDiscarding "; 340 | List.iter 341 | (fun tok -> print_string ((string_of_token tok)^" ")) toklst 342 | end; 343 | print_string "\nErreur de syntaxe: "; 344 | print_endline err_msg 345 | ;; 346 | 347 | let rec parse_strm strm = 348 | try 349 | match strm with parser 350 | [< ast = parse_ast; 'Kwd "." (* ^ .*); strm >] -> 351 | [< 'ast; parse_strm strm >] 352 | | [< _ = Stream.empty >] -> [< >] 353 | with 354 | Stream.Failure -> 355 | skip_til_dot "^ " strm; 356 | parse_strm strm 357 | | Stream.Error s -> 358 | skip_til_dot s strm; 359 | parse_strm strm 360 | ;; 361 | 362 | let go () = 363 | let ast_strm = parse_strm (lexer (Stream.of_channel stdin)) in 364 | Stream.iter update_state ast_strm; 365 | print_endline "EOF!"; 366 | flush stdout 367 | ;; 368 | 369 | go();; 370 | -------------------------------------------------------------------------------- /theories/Can.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Termes. 19 | Require Import Conv. 20 | Require Import Types. 21 | Require Import Class. 22 | 23 | (* schemes of reducibility: functions on sets of terms *) 24 | 25 | Fixpoint Can (K : skel) : Type := 26 | match K with 27 | | PROP => term -> Prop 28 | | PROD s1 s2 => Can s1 -> Can s2 29 | end. 30 | 31 | 32 | (* equality on schemes *) 33 | 34 | Definition eq_cand (X Y : term -> Prop) : Prop := 35 | forall t : term, X t <-> Y t. 36 | 37 | 38 | Hint Unfold eq_cand: coc. 39 | 40 | Fixpoint eq_can (s : skel) : Can s -> Can s -> Prop := 41 | match s as s0 return (Can s0 -> Can s0 -> Prop) with 42 | | PROP => eq_cand 43 | | PROD s1 s2 => 44 | fun C1 C2 : Can (PROD s1 s2) => 45 | forall X1 X2 : Can s1, 46 | eq_can s1 X1 X2 -> 47 | eq_can s1 X1 X1 -> eq_can s1 X2 X2 -> eq_can s2 (C1 X1) (C2 X2) 48 | end. 49 | 50 | Hint Unfold iff: coc. 51 | 52 | 53 | 54 | Lemma eq_can_sym : 55 | forall (s : skel) (X Y : Can s), eq_can s X Y -> eq_can s Y X. 56 | simple induction s; simpl in |- *; intros; auto with coc core arith datatypes. 57 | unfold eq_cand in |- *; intros. 58 | elim H with t; auto with coc core arith datatypes. 59 | Qed. 60 | 61 | Lemma eq_can_trans : 62 | forall (s : skel) (a b c : Can s), 63 | eq_can s a b -> eq_can s b b -> eq_can s b c -> eq_can s a c. 64 | simple induction s; simpl in |- *; intros. 65 | unfold eq_cand in |- *; intros. 66 | elim H with t; elim H1 with t; auto with coc core arith datatypes. 67 | 68 | apply H0 with (b X1); auto with coc core arith datatypes. 69 | Qed. 70 | 71 | 72 | Lemma eq_cand_incl : 73 | forall (t : term) (X Y : Can PROP), eq_can PROP X Y -> X t -> Y t. 74 | intros. 75 | elim H with t; auto with coc core arith datatypes. 76 | Qed. 77 | 78 | 79 | 80 | (* Higher order candidates of reducibility *) 81 | 82 | Definition neutral (t : term) : Prop := forall u v : term, t <> Abs u v. 83 | 84 | Record is_cand (X : term -> Prop) : Prop := 85 | {incl_sn : forall t : term, X t -> sn t; 86 | clos_red : forall t : term, X t -> forall u : term, red1 t u -> X u; 87 | clos_exp : 88 | forall t : term, neutral t -> (forall u : term, red1 t u -> X u) -> X t}. 89 | 90 | 91 | 92 | Lemma var_in_cand : 93 | forall (n : nat) (X : term -> Prop), is_cand X -> X (Ref n). 94 | intros. 95 | apply (clos_exp X); auto with coc core arith datatypes. 96 | unfold neutral in |- *; intros; discriminate. 97 | 98 | intros. 99 | inversion H0. 100 | Qed. 101 | 102 | 103 | Lemma clos_red_star : 104 | forall R : term -> Prop, 105 | is_cand R -> forall a b : term, R a -> red a b -> R b. 106 | simple induction 3; intros; auto with coc core arith datatypes. 107 | apply (clos_red R) with P; auto with coc core arith datatypes. 108 | Qed. 109 | 110 | 111 | Lemma cand_sat : 112 | forall X : term -> Prop, 113 | is_cand X -> 114 | forall T : term, 115 | sn T -> 116 | forall u : term, 117 | sn u -> forall m : term, X (subst u m) -> X (App (Abs T m) u). 118 | unfold sn in |- *. 119 | simple induction 2. 120 | simple induction 3. 121 | intros. 122 | generalize H6. 123 | cut (sn m); [intros H'; elim H' | ]; intros. 124 | apply (clos_exp X); intros; auto with coc core arith datatypes. 125 | red in |- *; intros; discriminate. 126 | 127 | inversion_clear H10; auto with coc core arith datatypes. 128 | inversion_clear H11. 129 | apply H2; auto with coc core arith datatypes. 130 | apply Acc_intro; auto with coc core arith datatypes. 131 | 132 | apply H8; auto with coc core arith datatypes. 133 | apply (clos_red X) with (subst x0 x1); auto with coc core arith datatypes. 134 | unfold subst in |- *; auto with coc core arith datatypes. 135 | 136 | apply H5; auto with coc core arith datatypes. 137 | apply clos_red_star with (subst x0 x1); auto with coc core arith datatypes. 138 | unfold subst in |- *; auto with coc core arith datatypes. 139 | 140 | apply sn_subst with x0. 141 | apply (incl_sn X); auto with coc core arith datatypes. 142 | Qed. 143 | 144 | 145 | 146 | Fixpoint is_can (s : skel) : Can s -> Prop := 147 | match s as s0 return (Can s0 -> Prop) with 148 | | PROP => fun X : term -> Prop => is_cand X 149 | | PROD s1 s2 => 150 | fun C : Can s1 -> Can s2 => 151 | forall X : Can s1, is_can s1 X -> eq_can s1 X X -> is_can s2 (C X) 152 | end. 153 | 154 | 155 | Lemma is_can_prop : forall X : term -> Prop, is_can PROP X -> is_cand X. 156 | auto with coc core arith datatypes. 157 | Qed. 158 | 159 | Hint Resolve is_can_prop: coc. 160 | 161 | 162 | 163 | 164 | (* Default Candidates *) 165 | 166 | Fixpoint default_can (s : skel) : Can s := 167 | match s as ss return (Can ss) with 168 | | PROP => sn 169 | | PROD s1 s2 => fun _ : Can s1 => default_can s2 170 | end. 171 | 172 | 173 | Lemma cand_sn : is_cand sn. 174 | apply Build_is_cand; intros; auto with coc core arith datatypes. 175 | 176 | apply sn_red_sn with t; auto with coc core arith datatypes. 177 | 178 | red in |- *; apply Acc_intro; auto with coc core arith datatypes. 179 | Qed. 180 | 181 | Hint Resolve cand_sn: coc. 182 | 183 | 184 | Lemma def_can_cr : forall s : skel, is_can s (default_can s). 185 | simple induction s; simpl in |- *; intros; auto with coc core arith datatypes. 186 | Qed. 187 | 188 | 189 | Lemma def_inv : forall s : skel, eq_can s (default_can s) (default_can s). 190 | simple induction s; simpl in |- *; intros; auto with coc core arith datatypes. 191 | Qed. 192 | 193 | 194 | Hint Resolve def_inv def_can_cr: coc. 195 | 196 | 197 | 198 | Definition Pi (s : skel) (X : term -> Prop) (F : Can (PROD s PROP)) 199 | (t : term) : Prop := 200 | forall u : term, 201 | X u -> forall C : Can s, is_can s C -> eq_can s C C -> F C (App t u). 202 | 203 | 204 | Lemma eq_can_Pi : 205 | forall (s : skel) (X Y : term -> Prop) (F1 F2 : Can (PROD s PROP)), 206 | eq_can PROP X Y -> 207 | eq_can (PROD s PROP) F1 F2 -> eq_can PROP (Pi s X F1) (Pi s Y F2). 208 | simpl in |- *; intros; unfold iff, Pi in |- *. 209 | split; intros. 210 | elim H0 with C C (App t u); elim H with u; auto with coc core arith datatypes. 211 | 212 | elim H0 with C C (App t u); elim H with u; auto with coc core arith datatypes. 213 | Qed. 214 | 215 | 216 | 217 | Lemma is_can_Pi : 218 | forall (s : skel) (X : term -> Prop), 219 | is_cand X -> 220 | forall F : Can (PROD s PROP), is_can (PROD s PROP) F -> is_cand (Pi s X F). 221 | simpl in |- *; unfold Pi in |- *; intros. 222 | apply Build_is_cand; intros. 223 | apply subterm_sn with (App t (Ref 0)); auto with coc core arith datatypes. 224 | apply (incl_sn (F (default_can s))); auto with coc core arith datatypes. 225 | apply H1; auto with coc core arith datatypes. 226 | apply (var_in_cand 0 X); auto with coc core arith datatypes. 227 | 228 | apply (clos_red (F C)) with (App t u0); auto with coc core arith datatypes. 229 | 230 | apply (clos_exp (F C)); auto with coc core arith datatypes. 231 | red in |- *; intros; discriminate. 232 | 233 | generalize H3. 234 | cut (sn u). 235 | simple induction 1; intros. 236 | generalize H1. 237 | inversion_clear H10; intros; auto with coc core arith datatypes. 238 | elim H10 with T M; auto with coc core arith datatypes. 239 | 240 | apply (clos_exp (F C)); intros; auto with coc core arith datatypes. 241 | red in |- *; intros; discriminate. 242 | 243 | apply H8 with N2; auto with coc core arith datatypes. 244 | apply (clos_red X) with x; auto with coc core arith datatypes. 245 | 246 | apply (incl_sn X); auto with coc core arith datatypes. 247 | Qed. 248 | 249 | 250 | 251 | Lemma Abs_sound : 252 | forall (A : term -> Prop) (s : skel) (F : Can s -> term -> Prop) 253 | (T m : term), 254 | is_can PROP A -> 255 | is_can (PROD s PROP) F -> 256 | (forall n : term, 257 | A n -> forall C : Can s, is_can s C -> eq_can s C C -> F C (subst n m)) -> 258 | sn T -> Pi s A F (Abs T m). 259 | unfold Pi in |- *; simpl in |- *; intros. 260 | cut (is_cand (F C)); intros; auto with coc core arith datatypes. 261 | apply (clos_exp (F C)); intros; auto with coc core arith datatypes. 262 | red in |- *; intros; discriminate. 263 | 264 | apply clos_red with (App (Abs T m) u); auto with coc core arith datatypes. 265 | apply (cand_sat (F C)); auto with coc core arith datatypes. 266 | apply (incl_sn A); auto with coc core arith datatypes. 267 | Qed. 268 | 269 | 270 | 271 | -------------------------------------------------------------------------------- /theories/Consistency.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Termes. 19 | Require Import Types. 20 | Require Import Conv. 21 | Require Import Conv_Dec. 22 | Require Import Strong_Norm. 23 | 24 | Require Import Lia. 25 | 26 | Fixpoint applist (l : list term) : term -> term := 27 | fun t => 28 | match l with 29 | | nil => t 30 | | arg :: args => App (applist args t) arg 31 | end. 32 | 33 | Lemma applist_assoc : 34 | forall t e e', applist (e ++ e') t = applist e (applist e' t). 35 | simple induction e; simpl in |- *; intros; auto. 36 | rewrite H; trivial. 37 | Qed. 38 | 39 | Lemma inv_typ_applist_head : 40 | forall e t l T, typ e (applist l t) T -> exists U : _, typ e t U. 41 | Proof. 42 | simple induction l; simpl in |- *; intros. 43 | split with T; trivial. 44 | 45 | apply inv_typ_app with (1 := H0); intros. 46 | eauto. 47 | Qed. 48 | 49 | 50 | 51 | Definition is_atom (e : env) t := 52 | exists2 n : _, n < length e & (exists l : _, t = applist l (Ref n)). 53 | 54 | Lemma sort_not_atom : forall e s, ~ is_atom e (Srt s). 55 | intros e s (n, lt_n, ([| t l], eq_atom)); discriminate eq_atom. 56 | Qed. 57 | 58 | Lemma prod_not_atom : forall e T M, ~ is_atom e (Prod T M). 59 | intros e T M (n, lt_n, ([| t l], eq_atom)); discriminate eq_atom. 60 | Qed. 61 | 62 | Lemma is_atom_app : forall e a b, is_atom e a -> is_atom e (App a b). 63 | intros e a b (n, lt_n, (l, eq_atom)). 64 | rewrite eq_atom. 65 | split with n; trivial. 66 | split with (b :: l); trivial. 67 | Qed. 68 | 69 | Lemma atom_reduction : forall e t u, red t u -> is_atom e t -> is_atom e u. 70 | simple induction 1; intros; trivial. 71 | generalize (H1 H3); clear H1 H3. 72 | intros (n, lt_n, (l, eq_atom)). 73 | rewrite eq_atom in H2. 74 | split with n; trivial. 75 | generalize N H2; clear N H2 eq_atom H0. 76 | elim l; simpl in |- *; intros. 77 | inversion H2. 78 | 79 | inversion H2. 80 | apply False_ind. 81 | generalize H3. 82 | case l0; simpl in |- *; try intros tt ll; discriminate. 83 | 84 | elim H0 with (1 := H5); intros. 85 | rewrite H6. 86 | split with (a :: x); reflexivity. 87 | 88 | split with (N2 :: l0); reflexivity. 89 | Qed. 90 | 91 | 92 | Lemma conv_sort_atom : forall (s : sort) e u, is_atom e u -> ~ conv (Srt s) u. 93 | Proof. 94 | red in |- *; intros. 95 | elim church_rosser with (1 := H0); intros. 96 | rewrite <- red_normal with (1 := H1) in H2. 97 | specialize atom_reduction with (1 := H2) (2 := H). 98 | apply sort_not_atom. 99 | 100 | red in |- *; red in |- *; intros. 101 | inversion H3. 102 | Qed. 103 | 104 | Lemma conv_prod_atom : forall a b e u, is_atom e u -> ~ conv (Prod a b) u. 105 | red in |- *; intros. 106 | elim church_rosser with (1 := H0); intros. 107 | apply red_prod_prod with (1 := H1); intros. 108 | rewrite H3 in H2. 109 | specialize atom_reduction with (1 := H2) (2 := H). 110 | apply prod_not_atom. 111 | Qed. 112 | 113 | 114 | (* Normal proofs of products are either atomic proofs or an abstraction *) 115 | Lemma prod_inhabitants : 116 | forall e t u, 117 | typ e t u -> 118 | forall a b, 119 | conv u (Prod a b) -> 120 | normal t -> is_atom e t \/ (exists a' : _, (exists m : _, t = Abs a' m)). 121 | Proof. 122 | simple induction 1; intros; eauto. 123 | elim conv_sort_prod with (1 := H1). 124 | 125 | elim conv_sort_prod with (1 := H1). 126 | 127 | left. 128 | exists v. 129 | inversion_clear H1. 130 | elim H5; intros; simpl in |- *; auto with arith. 131 | 132 | exists (nil (A:=term)); simpl in |- *; auto. 133 | 134 | left. 135 | apply is_atom_app. 136 | elim H3 with V Ur; intros; auto with coc. 137 | inversion_clear H6. 138 | inversion_clear H7. 139 | rewrite H6 in H5. 140 | elim H5 with (subst v x0); auto with coc. 141 | 142 | red in |- *; red in |- *; intros. 143 | elim H5 with (App u1 v); auto with coc. 144 | 145 | elim conv_sort_prod with (1 := H4). 146 | 147 | apply H1 with a b; auto. 148 | apply trans_conv_conv with V; auto. 149 | Qed. 150 | 151 | Definition hnf_proofs (e : env) (t : term) : Prop := 152 | match t with 153 | | App _ _ => is_atom e t 154 | | _ => True 155 | end. 156 | 157 | (* The head of an application of a well-typed term in normal form must 158 | be a variable *) 159 | Lemma hnf_proofs_sound : 160 | forall e t T, typ e t T -> normal t -> hnf_proofs e t. 161 | simple induction 1; simpl in |- *; intros; auto. 162 | apply is_atom_app. 163 | elim prod_inhabitants with (1 := H2) (a := V) (b := Ur); intros; 164 | auto with coc. 165 | inversion_clear H5. 166 | inversion_clear H6. 167 | rewrite H5 in H4. 168 | elim H4 with (subst v x0); auto with coc. 169 | 170 | red in |- *; red in |- *; intros. 171 | elim H4 with (App u0 v); auto with coc. 172 | Qed. 173 | 174 | (* Normal proofs of atomic types are atomic terms *) 175 | Lemma atom_inhabitants : 176 | forall e t u u', 177 | typ e t u -> conv u u' -> is_atom e u' -> hnf_proofs e t -> is_atom e t. 178 | simple induction 1; simpl in |- *; intros; auto. 179 | elim conv_sort_atom with (1 := H2) (2 := H1). 180 | 181 | elim conv_sort_atom with (1 := H2) (2 := H1). 182 | 183 | split with v. 184 | inversion_clear H1. 185 | elim H6; simpl in |- *; auto with arith. 186 | 187 | split with (nil (A:=term)); auto. 188 | 189 | elim conv_prod_atom with (1 := H7) (2 := H6). 190 | 191 | elim conv_sort_atom with (1 := H5) (2 := H4). 192 | 193 | apply H1; auto. 194 | apply trans_conv_conv with V; auto with coc. 195 | Qed. 196 | 197 | (* The absurd proposition: False := (P:Prop)P *) 198 | Definition absurd_prop := Prod (Srt prop) (Ref 0). 199 | 200 | (* False has no proof in normal form *) 201 | Lemma coc_consistency_nf : forall t, normal t -> ~ typ nil t absurd_prop. 202 | Proof. 203 | unfold absurd_prop in |- *. 204 | red in |- *; intros. 205 | elim prod_inhabitants with (1 := H0) (a := Srt prop) (b := Ref 0) (3 := H); 206 | auto with coc. 207 | (* Case 1: t atomic impossible because context is empty *) 208 | intros. 209 | inversion_clear H1. 210 | inversion H2. 211 | 212 | (* Case 2: t is an abstraction (Abs ty M) *) 213 | intros (ty, (M, eq_abs)). 214 | rewrite eq_abs in H0. 215 | apply inv_typ_abs with (1 := H0); intros. 216 | specialize inv_conv_prod_l with (1 := H4); intro conv_ty. 217 | specialize inv_conv_prod_r with (1 := H4); intro conv_P. 218 | clear H0 H4 H3 H1. 219 | (* Then M is an atomic proof *) 220 | cut (is_atom (ty :: nil) M). 221 | intros (n, lt_n, (l, eq_atom)). 222 | simpl in lt_n. 223 | generalize eq_atom. 224 | clear eq_atom. 225 | replace n with 0; try lia. 226 | rewrite <- (rev_involutive l). 227 | case (rev l); simpl in |- *; intros; rewrite eq_atom in H2. 228 | (* Case 2.1: the head var of M is not applied *) 229 | apply inv_typ_ref with (1 := H2). 230 | intros U itm_U. 231 | inversion_clear itm_U. 232 | intro conv_T. 233 | (* Impossible because var has type prop instead of (Ref O) *) 234 | cut (Ref 0 = Srt prop); try discriminate. 235 | apply nf_uniqueness. 236 | apply trans_conv_conv with T; auto with coc. 237 | apply trans_conv_conv with (lift 1 ty); auto with coc. 238 | change (conv (lift_rec 1 ty 0) (lift_rec 1 (Srt prop) 0)) in |- *. 239 | apply conv_conv_lift; auto with coc. 240 | 241 | red in |- *; red in |- *; intros r red_n; inversion red_n. 242 | 243 | red in |- *; red in |- *; intros r red_n; inversion red_n. 244 | 245 | (* Case 2.2: the head var of M is applied *) 246 | rewrite applist_assoc in H2. 247 | simpl in H2. 248 | elim inv_typ_applist_head with (1 := H2); intros. 249 | clear H2 eq_atom. 250 | apply inv_typ_app with (1 := H0); intros. 251 | apply inv_typ_ref with (1 := H1); intros. 252 | (* Impossible because head var has type prop and cannot be applied *) 253 | apply conv_sort_prod with prop V Ur. 254 | apply trans_conv_conv with (lift 1 U); auto with coc. 255 | apply sym_conv. 256 | change (conv (lift_rec 1 U 0) (lift_rec 1 (Srt prop) 0)) in |- *. 257 | inversion_clear H4. 258 | apply conv_conv_lift; auto with coc. 259 | 260 | (* Proof of M atomic *) 261 | apply atom_inhabitants with (1 := H2) (2 := conv_P). 262 | split with 0; simpl in |- *; auto with arith; split with (nil (A:=term)); 263 | trivial. 264 | 265 | apply hnf_proofs_sound with (1 := H2). 266 | rewrite eq_abs in H. 267 | red in |- *; red in |- *; intros. 268 | elim H with (Abs ty u); auto with coc. 269 | Qed. 270 | 271 | 272 | 273 | (* The absurd proposition has no proof in the empty context *) 274 | Theorem coc_consistency : forall t, ~ typ nil t absurd_prop. 275 | Proof. 276 | red in |- *; intros. 277 | elim compute_nf with t; intros. 278 | specialize subject_reduction with (1 := p) (2 := H). 279 | apply coc_consistency_nf; trivial. 280 | 281 | apply str_norm with (1 := H). 282 | Qed. 283 | -------------------------------------------------------------------------------- /theories/Conv.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Termes. 19 | 20 | Implicit Types i k m n p : nat. 21 | Implicit Type s : sort. 22 | Implicit Types A B M N T t u v : term. 23 | 24 | Section Church_Rosser. 25 | 26 | Definition str_confluent (R : term -> term -> Prop) := 27 | commut _ R (transp _ R). 28 | 29 | Lemma str_confluence_par_red1 : str_confluent par_red1. 30 | red in |- *; red in |- *. 31 | simple induction 1; intros. 32 | inversion_clear H4. 33 | elim H1 with M'0; auto with coc core arith sets; intros. 34 | elim H3 with N'0; auto with coc core arith sets; intros. 35 | exists (subst x1 x0); unfold subst in |- *; auto with coc core arith sets. 36 | 37 | inversion_clear H5. 38 | elim H1 with M'1; auto with coc core arith sets; intros. 39 | elim H3 with N'0; auto with coc core arith sets; intros. 40 | exists (subst x1 x0); auto with coc core arith sets; unfold subst in |- *; 41 | auto with coc core arith sets. 42 | 43 | inversion_clear H0. 44 | exists (Srt s); auto with coc core arith sets. 45 | 46 | inversion_clear H0. 47 | exists (Ref n); auto with coc core arith sets. 48 | 49 | inversion_clear H4. 50 | elim H1 with M'0; auto with coc core arith sets; intros. 51 | elim H3 with T'0; auto with coc core arith sets; intros. 52 | exists (Abs x1 x0); auto with coc core arith sets. 53 | 54 | generalize H0 H1. 55 | clear H0 H1. 56 | inversion_clear H4. 57 | intro. 58 | inversion_clear H4. 59 | intros. 60 | elim H4 with (Abs T M'0); auto with coc core arith sets; intros. 61 | elim H3 with N'0; auto with coc core arith sets; intros. 62 | apply inv_par_red_abs with T' M'1 x0; intros; auto with coc core arith sets. 63 | generalize H7 H8. 64 | rewrite H11. 65 | clear H7 H8; intros. 66 | inversion_clear H7. 67 | inversion_clear H8. 68 | exists (subst x1 U'); auto with coc core arith sets. 69 | unfold subst in |- *; auto with coc core arith sets. 70 | 71 | intros. 72 | elim H5 with M'0; auto with coc core arith sets; intros. 73 | elim H3 with N'0; auto with coc core arith sets; intros. 74 | exists (App x0 x1); auto with coc core arith sets. 75 | 76 | intros. 77 | inversion_clear H4. 78 | elim H1 with M'0; auto with coc core arith sets; intros. 79 | elim H3 with N'0; auto with coc core arith sets; intros. 80 | exists (Prod x0 x1); auto with coc core arith sets. 81 | Qed. 82 | 83 | 84 | Lemma strip_lemma : commut _ par_red (transp _ par_red1). 85 | unfold commut, par_red in |- *; simple induction 1; intros. 86 | elim str_confluence_par_red1 with z x0 y0; auto with coc core arith sets; 87 | intros. 88 | exists x1; auto with coc core arith sets. 89 | 90 | elim H1 with z0; auto with coc core arith sets; intros. 91 | elim H3 with x1; intros; auto with coc core arith sets. 92 | exists x2; auto with coc core arith sets. 93 | apply t_trans with x1; auto with coc core arith sets. 94 | Qed. 95 | 96 | 97 | Lemma confluence_par_red : str_confluent par_red. 98 | red in |- *; red in |- *. 99 | simple induction 1; intros. 100 | elim strip_lemma with z x0 y0; intros; auto with coc core arith sets. 101 | exists x1; auto with coc core arith sets. 102 | 103 | elim H1 with z0; intros; auto with coc core arith sets. 104 | elim H3 with x1; intros; auto with coc core arith sets. 105 | exists x2; auto with coc core arith sets. 106 | red in |- *. 107 | apply t_trans with x1; auto with coc core arith sets. 108 | Qed. 109 | 110 | 111 | Lemma confluence_red : str_confluent red. 112 | red in |- *; red in |- *. 113 | intros. 114 | elim confluence_par_red with x y z; auto with coc core arith sets; intros. 115 | exists x0; auto with coc core arith sets. 116 | Qed. 117 | 118 | 119 | Theorem church_rosser : 120 | forall u v, conv u v -> ex2 (fun t => red u t) (fun t => red v t). 121 | simple induction 1; intros. 122 | exists u; auto with coc core arith sets. 123 | 124 | elim H1; intros. 125 | elim confluence_red with x P N; auto with coc core arith sets; intros. 126 | exists x0; auto with coc core arith sets. 127 | apply trans_red_red with x; auto with coc core arith sets. 128 | 129 | elim H1; intros. 130 | exists x; auto with coc core arith sets. 131 | apply trans_red_red with P; auto with coc core arith sets. 132 | Qed. 133 | 134 | 135 | 136 | Lemma inv_conv_prod_l : 137 | forall a b c d : term, conv (Prod a c) (Prod b d) -> conv a b. 138 | intros. 139 | elim church_rosser with (Prod a c) (Prod b d); intros; 140 | auto with coc core arith sets. 141 | apply red_prod_prod with a c x; intros; auto with coc core arith sets. 142 | apply red_prod_prod with b d x; intros; auto with coc core arith sets. 143 | apply trans_conv_conv with a0; auto with coc core arith sets. 144 | apply sym_conv. 145 | generalize H2. 146 | rewrite H5; intro. 147 | injection H8. 148 | simple induction 2; auto with coc core arith sets. 149 | Qed. 150 | 151 | Lemma inv_conv_prod_r : 152 | forall a b c d : term, conv (Prod a c) (Prod b d) -> conv c d. 153 | intros. 154 | elim church_rosser with (Prod a c) (Prod b d); intros; 155 | auto with coc core arith sets. 156 | apply red_prod_prod with a c x; intros; auto with coc core arith sets. 157 | apply red_prod_prod with b d x; intros; auto with coc core arith sets. 158 | apply trans_conv_conv with b0; auto with coc core arith sets. 159 | apply sym_conv. 160 | generalize H2. 161 | rewrite H5; intro. 162 | injection H8. 163 | simple induction 1; auto with coc core arith sets. 164 | Qed. 165 | 166 | 167 | Lemma nf_uniqueness : forall u v, conv u v -> normal u -> normal v -> u = v. 168 | intros. 169 | elim church_rosser with u v; intros; auto with coc core arith sets. 170 | rewrite (red_normal u x); auto with coc core arith sets. 171 | elim red_normal with v x; auto with coc core arith sets. 172 | Qed. 173 | 174 | 175 | Lemma conv_sort : forall s1 s2, conv (Srt s1) (Srt s2) -> s1 = s2. 176 | intros. 177 | cut (Srt s1 = Srt s2); intros. 178 | injection H0; auto with coc core arith sets. 179 | 180 | apply nf_uniqueness; auto with coc core arith sets. 181 | red in |- *; red in |- *; intros. 182 | inversion_clear H0. 183 | 184 | red in |- *; red in |- *; intros. 185 | inversion_clear H0. 186 | Qed. 187 | 188 | 189 | Lemma conv_kind_prop : ~ conv (Srt kind) (Srt prop). 190 | red in |- *; intro. 191 | absurd (kind = prop). 192 | discriminate. 193 | 194 | apply conv_sort; auto with coc core arith sets. 195 | Qed. 196 | 197 | 198 | Lemma conv_sort_prod : forall s t u, ~ conv (Srt s) (Prod t u). 199 | red in |- *; intros. 200 | elim church_rosser with (Srt s) (Prod t u); auto with coc core arith sets. 201 | do 2 intro. 202 | elim red_normal with (Srt s) x; auto with coc core arith sets. 203 | intro. 204 | apply red_prod_prod with t u (Srt s); auto with coc core arith sets; intros. 205 | discriminate H2. 206 | 207 | red in |- *; red in |- *; intros. 208 | inversion_clear H1. 209 | Qed. 210 | 211 | 212 | End Church_Rosser. -------------------------------------------------------------------------------- /theories/Conv_Dec.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Peano_dec. 19 | Require Import Transitive_Closure. 20 | Require Import Union. 21 | Require Import Termes. 22 | Require Import Conv. 23 | 24 | Definition ord_norm1 := union _ subterm (transp _ red1). 25 | Definition ord_norm := clos_trans _ ord_norm1. 26 | 27 | Hint Unfold ord_norm1 ord_norm: coc. 28 | 29 | 30 | Lemma subterm_ord_norm : forall a b : term, subterm a b -> ord_norm a b. 31 | auto 10 with coc sets. 32 | Qed. 33 | 34 | Hint Resolve subterm_ord_norm: coc. 35 | 36 | 37 | Lemma red_red1_ord_norm : 38 | forall a b : term, red a b -> forall c : term, red1 b c -> ord_norm c a. 39 | red in |- *. 40 | simple induction 1; intros; auto with coc sets. 41 | apply t_trans with N; auto with coc sets. 42 | Qed. 43 | 44 | 45 | 46 | Lemma wf_subterm : well_founded subterm. 47 | red in |- *. 48 | simple induction a; intros; apply Acc_intro; intros. 49 | inversion_clear H; inversion_clear H0. 50 | 51 | inversion_clear H; inversion_clear H0. 52 | 53 | inversion_clear H1; inversion_clear H2; auto with coc sets. 54 | 55 | inversion_clear H1; inversion_clear H2; auto with coc sets. 56 | 57 | inversion_clear H1; inversion_clear H2; auto with coc sets. 58 | Qed. 59 | 60 | 61 | Lemma wf_ord_norm1 : forall t : term, sn t -> Acc ord_norm1 t. 62 | unfold ord_norm1 in |- *. 63 | intros. 64 | apply Acc_union; auto with coc sets. 65 | exact commut_red1_subterm. 66 | 67 | intros. 68 | apply wf_subterm. 69 | Qed. 70 | 71 | 72 | Theorem wf_ord_norm : forall t : term, sn t -> Acc ord_norm t. 73 | unfold ord_norm in |- *. 74 | intros. 75 | apply Acc_clos_trans. 76 | apply wf_ord_norm1; auto with coc sets. 77 | Qed. 78 | 79 | 80 | 81 | 82 | Definition norm_body (a : term) (norm : term -> term) := 83 | match a with 84 | | Srt s => Srt s 85 | | Ref n => Ref n 86 | | Abs T t => Abs (norm T) (norm t) 87 | | App u v => 88 | match norm u return term with 89 | | Abs _ b => norm (subst (norm v) b) 90 | | t => App t (norm v) 91 | end 92 | | Prod T U => Prod (norm T) (norm U) 93 | end. 94 | 95 | Definition compute_nf : 96 | forall t : term, sn t -> {u : term | red t u & normal u}. 97 | Proof. 98 | intros. 99 | cut (Acc ord_norm t); [intros _H'; elim _H' |]. 100 | clear _H' H t. 101 | intros [s| n| T t| u v| T U] _ norm_rec. 102 | exists (Srt s); auto with coc. 103 | red in |- *; red in |- *; intros. 104 | inversion_clear H. 105 | 106 | exists (Ref n); auto with coc. 107 | red in |- *; red in |- *; intros. 108 | inversion_clear H. 109 | 110 | elim norm_rec with T; auto with coc; intros T' redT nT. 111 | elim norm_rec with t; auto with coc; intros t' redt nt. 112 | exists (Abs T' t'); auto with coc. 113 | red in |- *; red in |- *; intros. 114 | inversion_clear H. 115 | elim nT with M'; trivial. 116 | elim nt with M'; trivial. 117 | 118 | elim norm_rec with v; auto with coc; intros v' redv nv. 119 | elim norm_rec with u; auto with coc. 120 | intros [s| n| T t| a b| T U] redu nu. 121 | exists (App (Srt s) v'); auto with coc. 122 | red in |- *; red in |- *; intros. 123 | inversion_clear H. 124 | inversion_clear H0. 125 | elim nv with N2; trivial. 126 | 127 | exists (App (Ref n) v'); auto with coc. 128 | red in |- *; red in |- *; intros. 129 | inversion_clear H. 130 | inversion_clear H0. 131 | elim nv with N2; trivial. 132 | 133 | elim norm_rec with (subst v' t). 134 | intros t' redt nt. 135 | exists t'; trivial. 136 | apply trans_red_red with (subst v' t); auto with coc. 137 | apply trans_red with (App (Abs T t) v'); auto with coc. 138 | 139 | apply red_red1_ord_norm with (App (Abs T t) v'); auto with coc. 140 | 141 | exists (App (App a b) v'); auto with coc. 142 | red in |- *; red in |- *; intros. 143 | inversion_clear H. 144 | elim nu with N1; trivial. 145 | elim nv with N2; trivial. 146 | 147 | exists (App (Prod T U) v'); auto with coc. 148 | red in |- *; red in |- *; intros. 149 | inversion_clear H. 150 | elim nu with N1; trivial. 151 | elim nv with N2; trivial. 152 | 153 | elim norm_rec with T; auto with coc; intros T' redT nT. 154 | elim norm_rec with U; auto with coc; intros U' redU nU. 155 | exists (Prod T' U'); auto with coc. 156 | red in |- *; red in |- *; intros. 157 | inversion_clear H. 158 | elim nT with N1; trivial. 159 | elim nU with N2; trivial. 160 | 161 | apply wf_ord_norm; auto with coc. 162 | Defined. 163 | 164 | Definition eqterm : forall u v : term, {u = v} + {u <> v}. 165 | Proof. 166 | decide equality. 167 | decide equality. 168 | apply eq_nat_dec. 169 | Defined. 170 | 171 | 172 | 173 | Definition is_conv : 174 | forall u v : term, sn u -> sn v -> {conv u v} + {~ conv u v}. 175 | Proof. 176 | intros u v snu snv. 177 | elim compute_nf with (1 := snu); intros u' redu nu. 178 | elim compute_nf with (1 := snv); intros v' redv nv. 179 | elim eqterm with u' v'; [ intros same_nf | intros diff_nf ]. 180 | left. 181 | apply trans_conv_conv with u'; auto with coc. 182 | rewrite same_nf; apply sym_conv; auto with coc. 183 | 184 | right; red in |- *; intro; apply diff_nf. 185 | elim church_rosser with u' v'; auto with coc; intros. 186 | rewrite (red_normal u' x); auto with coc. 187 | rewrite (red_normal v' x); auto with coc. 188 | 189 | apply trans_conv_conv with v; auto with coc. 190 | apply trans_conv_conv with u; auto with coc. 191 | apply sym_conv; auto with coc. 192 | Defined. 193 | -------------------------------------------------------------------------------- /theories/ETypes.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | Require Import Termes. 18 | Require Import Conv. 19 | Require Import Ered. 20 | Require Export MyList. 21 | Require Import Types. 22 | 23 | 24 | Section Typage. 25 | 26 | Inductive Ewf : env -> Prop := 27 | | Ewf_nil : Ewf nil 28 | | Ewf_var : 29 | forall (e : env) (T : term) (s : sort), 30 | Etyp e T (Srt s) -> Ewf (T :: e) 31 | with Etyp : env -> term -> term -> Prop := 32 | | Etype_prop : forall e : env, Ewf e -> Etyp e (Srt prop) (Srt kind) 33 | | Etype_set : forall e : env, Ewf e -> Etyp e (Srt set) (Srt kind) 34 | | Etype_var : 35 | forall e : env, 36 | Ewf e -> 37 | forall (v : nat) (t : term), item_lift t e v -> Etyp e (Ref v) t 38 | | Etype_abs : 39 | forall (e : env) (T : term) (s1 : sort), 40 | Etyp e T (Srt s1) -> 41 | forall (M U : term) (s2 : sort), 42 | Etyp (T :: e) U (Srt s2) -> 43 | Etyp (T :: e) M U -> Etyp e (Abs T M) (Prod T U) 44 | | Etype_app : 45 | forall (e : env) (v V : term), 46 | Etyp e v V -> 47 | forall u Ur : term, 48 | Etyp e u (Prod V Ur) -> Etyp e (App u v) (subst v Ur) 49 | | Etype_prod : 50 | forall (e : env) (T : term) (s1 : sort), 51 | Etyp e T (Srt s1) -> 52 | forall (U : term) (s2 : sort), 53 | Etyp (T :: e) U (Srt s2) -> Etyp e (Prod T U) (Srt s2) 54 | | Etype_Econv : 55 | forall (e : env) (t U V : term), 56 | Etyp e t U -> 57 | Econv U V -> forall s : sort, Etyp e V (Srt s) -> Etyp e t V. 58 | 59 | Hint Resolve Ewf_nil Etype_prop Etype_set Etype_var: ecoc. 60 | 61 | 62 | Lemma typ_Etyp : forall (e : env) (a Ta : term), typ e a Ta -> Etyp e a Ta. 63 | fix typ_Etyp 4. 64 | intros. 65 | case H; intros. 66 | apply Etype_prop. 67 | case H0. 68 | apply Ewf_nil. 69 | 70 | intros; apply Ewf_var with s. 71 | apply typ_Etyp; trivial. 72 | 73 | apply Etype_set. 74 | case H0. 75 | apply Ewf_nil. 76 | 77 | intros; apply Ewf_var with s; auto. 78 | 79 | apply Etype_var. 80 | case H0. 81 | apply Ewf_nil. 82 | 83 | intros; apply Ewf_var with s. 84 | apply typ_Etyp; trivial. 85 | 86 | trivial. 87 | 88 | apply Etype_abs with s1 s2; auto. 89 | 90 | apply Etype_app with V; auto. 91 | 92 | apply Etype_prod with s1; auto. 93 | 94 | apply Etype_Econv with U s; auto. 95 | apply conv_Econv; trivial. 96 | Qed. 97 | 98 | Lemma Etype_prop_set : 99 | forall s : sort, 100 | is_prop s -> forall e : env, Ewf e -> Etyp e (Srt s) (Srt kind). 101 | simple destruct 1; intros; rewrite H0. 102 | apply Etype_prop; trivial. 103 | apply Etype_set; trivial. 104 | Qed. 105 | 106 | Lemma Etyp_free_db : 107 | forall (e : env) (t T : term), Etyp e t T -> free_db (length e) t. 108 | simple induction 1; intros; auto with coc ecoc core arith datatypes. 109 | inversion_clear H1. 110 | apply db_ref. 111 | elim H3; simpl in |- *; intros; auto with coc ecoc core arith datatypes. 112 | Qed. 113 | 114 | 115 | Lemma Etyp_Ewf : forall (e : env) (t T : term), Etyp e t T -> Ewf e. 116 | simple induction 1; auto with coc core arith datatypes. 117 | Qed. 118 | 119 | 120 | Lemma Ewf_sort : 121 | forall (n : nat) (e f : env), 122 | trunc _ (S n) e f -> 123 | Ewf e -> 124 | forall t : term, item _ t e n -> exists s : sort, Etyp f t (Srt s). 125 | simple induction n. 126 | do 3 intro. 127 | inversion_clear H. 128 | inversion_clear H0. 129 | intros. 130 | inversion_clear H0. 131 | inversion_clear H. 132 | exists s; auto with coc core arith datatypes. 133 | 134 | do 5 intro. 135 | inversion_clear H0. 136 | intros. 137 | inversion_clear H2. 138 | inversion_clear H0. 139 | elim H with e0 f t; intros; auto with coc core arith datatypes. 140 | exists x0; auto with coc core arith datatypes. 141 | 142 | apply Etyp_Ewf with x (Srt s); auto with coc core arith datatypes. 143 | Qed. 144 | 145 | 146 | 147 | Definition inv_Etype (P : Prop) (e : env) (t T : term) : Prop := 148 | match t with 149 | | Srt prop => Econv T (Srt kind) -> P 150 | | Srt set => Econv T (Srt kind) -> P 151 | | Srt kind => True 152 | | Ref n => forall x : term, item _ x e n -> Econv T (lift (S n) x) -> P 153 | | Abs A M => 154 | forall (s1 s2 : sort) (U : term), 155 | Etyp e A (Srt s1) -> 156 | Etyp (A :: e) M U -> 157 | Etyp (A :: e) U (Srt s2) -> Econv T (Prod A U) -> P 158 | | App u v => 159 | forall Ur V : term, 160 | Etyp e v V -> Etyp e u (Prod V Ur) -> Econv T (subst v Ur) -> P 161 | | Prod A B => 162 | forall s1 s2 : sort, 163 | Etyp e A (Srt s1) -> 164 | Etyp (A :: e) B (Srt s2) -> Econv T (Srt s2) -> P 165 | end. 166 | 167 | Lemma inv_Etype_Econv : 168 | forall (P : Prop) (e : env) (t U V : term), 169 | Econv U V -> inv_Etype P e t U -> inv_Etype P e t V. 170 | do 6 intro. 171 | cut (forall x : term, Econv V x -> Econv U x). 172 | intro. 173 | case t; simpl in |- *; intros. 174 | generalize H1. 175 | elim s; auto with coc ecoc core arith datatypes; intros. 176 | 177 | apply H1 with x; auto with coc core arith datatypes. 178 | 179 | apply H1 with s1 s2 U0; auto with coc core arith datatypes. 180 | 181 | apply H1 with Ur V0; auto with coc core arith datatypes. 182 | 183 | apply H1 with s1 s2; auto with coc core arith datatypes. 184 | 185 | intros; apply trans_Econv_Econv with V; auto with coc core arith datatypes. 186 | Qed. 187 | 188 | 189 | Theorem Etyp_inversion : 190 | forall (P : Prop) (e : env) (t T : term), 191 | Etyp e t T -> inv_Etype P e t T -> P. 192 | simple induction 1; simpl in |- *; intros. 193 | auto with coc ecoc core arith datatypes. 194 | 195 | auto with coc ecoc core arith datatypes. 196 | 197 | elim H1; intros. 198 | apply H2 with x; auto with coc ecoc core arith datatypes. 199 | rewrite H3; auto with coc ecoc core arith datatypes. 200 | 201 | apply H6 with s1 s2 U; auto with coc ecoc core arith datatypes. 202 | 203 | apply H4 with Ur V; auto with coc ecoc core arith datatypes. 204 | 205 | apply H4 with s1 s2; auto with coc ecoc core arith datatypes. 206 | 207 | apply H1. 208 | apply inv_Etype_Econv with V; auto with coc ecoc core arith datatypes. 209 | Qed. 210 | 211 | 212 | 213 | 214 | Lemma inv_Etyp_kind : forall (e : env) (t : term), ~ Etyp e (Srt kind) t. 215 | red in |- *; intros. 216 | apply Etyp_inversion with e (Srt kind) t; simpl in |- *; 217 | auto with coc ecoc core arith datatypes. 218 | Qed. 219 | 220 | Lemma inv_Etyp_prop : 221 | forall (e : env) (T : term), Etyp e (Srt prop) T -> Econv T (Srt kind). 222 | intros. 223 | apply Etyp_inversion with e (Srt prop) T; simpl in |- *; 224 | auto with ecoc coc core arith datatypes. 225 | Qed. 226 | 227 | Lemma inv_Etyp_set : 228 | forall (e : env) (T : term), Etyp e (Srt set) T -> Econv T (Srt kind). 229 | intros. 230 | apply Etyp_inversion with e (Srt set) T; simpl in |- *; 231 | auto with coc ecoc core arith datatypes. 232 | Qed. 233 | 234 | Lemma inv_Etyp_ref : 235 | forall (P : Prop) (e : env) (T : term) (n : nat), 236 | Etyp e (Ref n) T -> 237 | (forall U : term, item _ U e n -> Econv T (lift (S n) U) -> P) -> P. 238 | intros. 239 | apply Etyp_inversion with e (Ref n) T; simpl in |- *; intros; 240 | auto with coc ecoc core arith datatypes. 241 | apply H0 with x; auto with coc ecoc core arith datatypes. 242 | Qed. 243 | 244 | Lemma inv_Etyp_abs : 245 | forall (P : Prop) (e : env) (A M U : term), 246 | Etyp e (Abs A M) U -> 247 | (forall (s1 s2 : sort) (T : term), 248 | Etyp e A (Srt s1) -> 249 | Etyp (A :: e) M T -> Etyp (A :: e) T (Srt s2) -> Econv (Prod A T) U -> P) -> 250 | P. 251 | intros. 252 | apply Etyp_inversion with e (Abs A M) U; simpl in |- *; 253 | auto with coc ecoc core arith datatypes; intros. 254 | apply H0 with s1 s2 U0; auto with coc ecoc core arith datatypes. 255 | Qed. 256 | 257 | Lemma inv_Etyp_app : 258 | forall (P : Prop) (e : env) (u v T : term), 259 | Etyp e (App u v) T -> 260 | (forall V Ur : term, 261 | Etyp e u (Prod V Ur) -> Etyp e v V -> Econv T (subst v Ur) -> P) -> P. 262 | intros. 263 | apply Etyp_inversion with e (App u v) T; simpl in |- *; 264 | auto with coc ecoc core arith datatypes; intros. 265 | apply H0 with V Ur; auto with coc ecoc core arith datatypes. 266 | Qed. 267 | 268 | Lemma inv_Etyp_prod : 269 | forall (P : Prop) (e : env) (T U s : term), 270 | Etyp e (Prod T U) s -> 271 | (forall s1 s2 : sort, 272 | Etyp e T (Srt s1) -> Etyp (T :: e) U (Srt s2) -> Econv (Srt s2) s -> P) -> 273 | P. 274 | intros. 275 | apply Etyp_inversion with e (Prod T U) s; simpl in |- *; 276 | auto with coc ecoc core arith datatypes; intros. 277 | apply H0 with s1 s2; auto with coc ecoc core arith datatypes. 278 | Qed. 279 | 280 | 281 | 282 | 283 | Lemma Etyp_mem_kind : 284 | forall (e : env) (t T : term), mem_sort kind t -> ~ Etyp e t T. 285 | red in |- *; intros. 286 | apply Etyp_inversion with e t T; auto with coc core arith datatypes. 287 | generalize e T. 288 | clear H0. 289 | elim H; simpl in |- *; auto with coc core arith datatypes; intros. 290 | apply Etyp_inversion with e0 u (Srt s1); auto with coc core arith datatypes. 291 | 292 | apply Etyp_inversion with (u :: e0) v (Srt s2); 293 | auto with coc core arith datatypes. 294 | 295 | apply Etyp_inversion with e0 u (Srt s1); auto with coc core arith datatypes. 296 | 297 | apply Etyp_inversion with (u :: e0) v U; auto with coc core arith datatypes. 298 | 299 | apply Etyp_inversion with e0 u (Prod V Ur); 300 | auto with coc core arith datatypes. 301 | 302 | apply Etyp_inversion with e0 v V; auto with coc core arith datatypes. 303 | Qed. 304 | 305 | 306 | Lemma inv_Etyp_Econv_kind : 307 | forall (e : env) (t T : term), Econv t (Srt kind) -> ~ Etyp e t T. 308 | intros. 309 | apply Etyp_mem_kind. 310 | apply Ered_sort_mem. 311 | elim Econv_church_rosser with t (Srt kind); intros; 312 | auto with ecoc coc core arith datatypes. 313 | rewrite (Ered_Enormal (Srt kind) x); auto with ecoc coc core arith datatypes. 314 | red in |- *; red in |- *; intros. 315 | inversion_clear H2. 316 | Qed. 317 | 318 | End Typage. 319 | 320 | -------------------------------------------------------------------------------- /theories/Equiv.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | Require Import Termes. 18 | Require Import Conv. 19 | Require Import Ered. 20 | Require Import Types. 21 | Require Import ETypes. 22 | Require Import Conv_Dec. 23 | Require Import Strong_Norm. 24 | 25 | Definition is_lam (t : term) := 26 | exists T : term, (exists M : term, t = Abs T M). 27 | 28 | Lemma normal_normal_abs : 29 | forall T M : term, normal T -> normal M -> normal (Abs T M). 30 | intros; unfold normal, not in |- *; intros. 31 | inversion_clear H1. 32 | elim H with M'; auto with coc. 33 | elim H0 with M'; auto with coc. 34 | Qed. 35 | 36 | Lemma normal_normal_app : 37 | forall M N : term, normal M -> normal N -> ~ is_lam M -> normal (App M N). 38 | intros; unfold normal, not in |- *; intros. 39 | generalize H H1; clear H H1; inversion_clear H2. 40 | intros. 41 | apply H1. 42 | unfold is_lam in |- *; split with T; split with M0; trivial. 43 | intros H1; elim H1 with N1; auto with coc. 44 | elim H0 with N2; auto with coc. 45 | Qed. 46 | 47 | 48 | Lemma normal_normal_prod : 49 | forall T U : term, normal T -> normal U -> normal (Prod T U). 50 | intros; unfold normal, not in |- *; intros. 51 | inversion_clear H1. 52 | elim H with N1; auto with coc. 53 | elim H0 with N2; auto with coc. 54 | Qed. 55 | 56 | Hint Resolve normal_normal_abs normal_normal_app normal_normal_prod: ecoc. 57 | 58 | Lemma normal_abs_inv : 59 | forall T M : term, normal (Abs T M) -> normal T /\ normal M. 60 | unfold normal in |- *; intuition. 61 | apply H with (Abs u M); auto with coc. 62 | apply H with (Abs T u); auto with coc. 63 | Qed. 64 | 65 | Lemma normal_app_inv : 66 | forall M N : term, normal (App M N) -> normal M /\ normal N /\ ~ is_lam M. 67 | unfold normal in |- *; intuition. 68 | apply H with (App u N); auto with coc. 69 | apply H with (App M u); auto with coc. 70 | generalize H0; clear H0; unfold is_lam in |- *; intros (T, (x0, H0)). 71 | rewrite H0 in H; apply H with (subst N x0); auto with coc. 72 | Qed. 73 | 74 | Lemma normal_prod_inv : 75 | forall T U : term, normal (Prod T U) -> normal T /\ normal U. 76 | unfold normal in |- *; intuition. 77 | apply H with (Prod u U); auto with coc. 78 | apply H with (Prod T u); auto with coc. 79 | Qed. 80 | 81 | 82 | Inductive NF_Econv : term -> term -> Prop := 83 | | nf_var : forall n : nat, NF_Econv (Ref n) (Ref n) 84 | | nf_app : 85 | forall M M' N N' : term, 86 | NF_Econv M M' -> 87 | ~ is_lam M -> NF_Econv N N' -> NF_Econv (App M N) (App M' N') 88 | | nf_lam : 89 | forall T T' M M' : term, 90 | NF_Econv M M' -> 91 | normal T -> normal T' -> NF_Econv (Abs T M) (Abs T' M') 92 | | nf_sort : forall s : sort, NF_Econv (Srt s) (Srt s) 93 | | nf_prod : 94 | forall T T' U U' : term, 95 | NF_Econv T T' -> NF_Econv U U' -> NF_Econv (Prod T U) (Prod T' U'). 96 | 97 | Hint Resolve nf_var nf_app nf_lam nf_sort nf_prod: ecoc. 98 | 99 | Lemma normal_prop : normal (Srt prop). 100 | unfold normal, not in |- *; intros. 101 | inversion H. 102 | Qed. 103 | Hint Resolve normal_prop: ecoc. 104 | 105 | 106 | Lemma not_is_lam_Ered1 : 107 | forall M N : term, Ered1 M N -> normal M -> ~ is_lam M -> ~ is_lam N. 108 | simple induction 1; intros. 109 | elim H0 with (subst N0 M0); auto with coc. 110 | elim H1; unfold is_lam in |- *; split with T; split with M0; trivial. 111 | elim H3; unfold is_lam in |- *; split with M0; split with N0; trivial. 112 | elim H3; unfold is_lam in |- *; split with N0; split with M0; trivial. 113 | unfold not in |- *; unfold is_lam in |- *; intros (x, (x0, H4)); discriminate. 114 | unfold not in |- *; unfold is_lam in |- *; intros (x, (x0, H4)); discriminate. 115 | unfold not in |- *; unfold is_lam in |- *; intros (x, (x0, H4)); discriminate. 116 | unfold not in |- *; unfold is_lam in |- *; intros (x, (x0, H4)); discriminate. 117 | Qed. 118 | 119 | Hint Resolve not_is_lam_Ered1: ecoc. 120 | 121 | Lemma Ered1_normal_normal : 122 | forall M N : term, Ered1 M N -> normal M -> normal N. 123 | simple induction 1; intros. 124 | elim H0 with (subst N0 M0); auto with coc. 125 | elim (normal_abs_inv T M0 H0); auto with ecoc. 126 | elim (normal_abs_inv M0 N0 H2); auto with ecoc. 127 | elim (normal_abs_inv N0 M0 H2); auto with ecoc. 128 | elim (normal_app_inv M1 M2 H2); intros. 129 | elim H4; eauto with ecoc. 130 | elim (normal_app_inv M1 M2 H2); intros. 131 | elim H4; eauto with ecoc. 132 | elim (normal_prod_inv M1 M2 H2); auto with ecoc. 133 | elim (normal_prod_inv M1 M2 H2); auto with ecoc. 134 | Qed. 135 | 136 | Hint Resolve Ered1_normal_normal: ecoc. 137 | 138 | Lemma refl_NF_Econv : forall t : term, normal t -> NF_Econv t t. 139 | simple induction t; auto with ecoc; intros. 140 | elim (normal_abs_inv t0 t1 H1); auto with ecoc. 141 | elim (normal_app_inv t0 t1 H1); intros. 142 | elim H3; auto with ecoc. 143 | elim (normal_prod_inv t0 t1 H1); auto with ecoc. 144 | Qed. 145 | 146 | Hint Resolve refl_NF_Econv: ecoc. 147 | 148 | Lemma NF_Econv_not_is_lam : 149 | forall M N : term, NF_Econv M N -> ~ is_lam M -> ~ is_lam N. 150 | intros M N H; inversion_clear H; auto; intros. 151 | unfold is_lam, not in |- *; intros (x, (x0, H3)); discriminate. 152 | elim H; unfold is_lam in |- *; split with T; split with M0; trivial. 153 | unfold is_lam, not in |- *; intros (x, (x0, H3)); discriminate. 154 | Qed. 155 | 156 | Hint Resolve NF_Econv_not_is_lam: ecoc. 157 | 158 | Lemma sym_NF_Econv : forall M N : term, NF_Econv M N -> NF_Econv N M. 159 | simple induction 1; eauto with ecoc; eauto with ecoc. 160 | Qed. 161 | 162 | Hint Resolve sym_NF_Econv: ecoc. 163 | 164 | Lemma trans_NF_Econv_NF_Econv : 165 | forall M N : term, 166 | NF_Econv M N -> forall P : term, NF_Econv N P -> NF_Econv M P. 167 | simple induction 1; auto with ecoc; intros. 168 | inversion H5; auto with ecoc. 169 | inversion H4; auto with ecoc. 170 | inversion H4; auto with ecoc. 171 | Qed. 172 | 173 | Lemma Ered1_normal_NF_Econv : 174 | forall T T' : term, Ered1 T T' -> normal T -> NF_Econv T T'. 175 | simple induction 1; intros. 176 | elim H0 with (subst N M); auto with coc. 177 | elim (normal_abs_inv T0 M H0); intros. 178 | apply trans_NF_Econv_NF_Econv with (Abs (Srt prop) M); auto with ecoc. 179 | elim (normal_abs_inv M N H2); eauto with ecoc. 180 | elim (normal_abs_inv N M H2); eauto with ecoc. 181 | elim (normal_app_inv M1 M2 H2); intros. 182 | elim H4; eauto with ecoc. 183 | elim (normal_app_inv M1 M2 H2); intros. 184 | elim H4; eauto with ecoc. 185 | elim (normal_prod_inv M1 M2 H2); auto with ecoc. 186 | elim (normal_prod_inv M1 M2 H2); auto with ecoc. 187 | Qed. 188 | 189 | Hint Resolve Ered1_normal_NF_Econv: ecoc. 190 | 191 | Lemma Ered_normal_NF_Econv : 192 | forall T T' : term, Ered T T' -> normal T -> NF_Econv T T'. 193 | intros T T' H. 194 | pattern T in |- *. 195 | apply Ered1_Ered_ind with T'; auto with ecoc sets. 196 | intros. 197 | apply trans_NF_Econv_NF_Econv with R; eauto with ecoc. 198 | Qed. 199 | 200 | Hint Resolve Ered_normal_NF_Econv: ecoc. 201 | 202 | Lemma normal_Econv_NF_conv : 203 | forall T T' : term, Econv T T' -> normal T -> normal T' -> NF_Econv T T'. 204 | intros T T' H. 205 | elim Econv_church_rosser with T T'; auto with ecoc; intros. 206 | apply trans_NF_Econv_NF_Econv with x; eauto with ecoc. 207 | Qed. 208 | 209 | Hint Resolve normal_Econv_NF_conv: ecoc. 210 | 211 | 212 | Lemma NF_Econv_Econv : forall M N : term, NF_Econv M N -> Econv M N. 213 | simple induction 1; auto with ecoc. 214 | Qed. 215 | Hint Resolve NF_Econv_Econv: ecoc. 216 | 217 | Inductive equiv_env (P : term -> term -> Prop) : env -> env -> Prop := 218 | | EE_n : equiv_env P nil nil 219 | | EE_c : 220 | forall (t t' : term) (e e' : env), 221 | P t t' -> equiv_env P e e' -> equiv_env P (t :: e) (t' :: e'). 222 | 223 | Lemma equiv_env_item : 224 | forall (P : term -> term -> Prop) (n : nat) (e e' : env) (A B : term), 225 | item _ A e n -> item _ B e' n -> equiv_env P e e' -> P A B. 226 | intro P; simple induction n. 227 | intros e e' A B H; inversion_clear H. 228 | intros H; inversion_clear H; intros H; inversion H; trivial. 229 | 230 | intros n0 H e e' A B H0; inversion_clear H0. 231 | intros H0; inversion_clear H0; intros H0; inversion_clear H0; eauto. 232 | Qed. 233 | 234 | 235 | Lemma Etyp_NF_Econv_Econv : 236 | forall M M' : term, 237 | NF_Econv M M' -> 238 | ~ is_lam M -> 239 | forall (e e' : env) (A B : term), 240 | equiv_env Econv e e' -> Etyp e M A -> Etyp e' M' B -> Econv A B. 241 | 242 | simple induction 1; intros. 243 | apply inv_Etyp_ref with e A n; trivial; intros. 244 | apply inv_Etyp_ref with e' B n; trivial; intros. 245 | apply trans_Econv_Econv with (lift (S n) U); trivial. 246 | apply trans_Econv_Econv with (lift (S n) U0); auto with ecoc. 247 | unfold lift in |- *; apply Econv_Econv_lift. 248 | apply equiv_env_item with n e e'; trivial. 249 | 250 | apply inv_Etyp_app with e M0 N A; trivial. 251 | intros. 252 | apply inv_Etyp_app with e' M'0 N' B; trivial. 253 | intros. 254 | apply trans_Econv_Econv with (subst N Ur); trivial. 255 | apply sym_Econv; apply trans_Econv_Econv with (subst N' Ur0); trivial. 256 | unfold subst in |- *; apply Econv_Econv_subst. 257 | apply sym_Econv; apply NF_Econv_Econv; trivial. 258 | 259 | cut (Econv (Prod V Ur) (Prod V0 Ur0)). 260 | intros. 261 | apply sym_Econv. 262 | eapply inv_Econv_prod_r; eauto. 263 | 264 | apply H1 with e e'; trivial. 265 | 266 | elim H4; unfold is_lam in |- *; split with T; split with M0; trivial. 267 | 268 | generalize H2 H3; clear H2 H3; case s; intros. 269 | elim (inv_Etyp_kind e A H2). 270 | 271 | apply trans_Econv_Econv with (Srt kind). 272 | eapply inv_Etyp_prop; eauto. 273 | 274 | apply sym_Econv; eapply inv_Etyp_prop; eauto. 275 | 276 | apply trans_Econv_Econv with (Srt kind). 277 | eapply inv_Etyp_set; eauto. 278 | 279 | apply sym_Econv; eapply inv_Etyp_set; eauto. 280 | 281 | apply inv_Etyp_prod with e T U A; trivial; intros. 282 | apply inv_Etyp_prod with e' T' U' B; trivial; intros. 283 | apply trans_Econv_Econv with (Srt s2); auto with ecoc. 284 | apply trans_Econv_Econv with (Srt s3); auto with ecoc. 285 | apply H3 with (T :: e) (T' :: e'); trivial. 286 | unfold not, is_lam in |- *; intros (x, (x0, H14)). 287 | rewrite H14 in H9. 288 | apply inv_Etyp_abs with (T :: e) x x0 (Srt s2); trivial. 289 | intros. 290 | elim (Econv_sort_prod s2 x T0); auto with ecoc. 291 | 292 | constructor; auto with ecoc. 293 | Qed. 294 | 295 | Lemma refl_equiv_env : forall e : env, equiv_env Econv e e. 296 | simple induction e; constructor; auto with ecoc. 297 | Qed. 298 | Hint Resolve refl_equiv_env: ecoc. 299 | 300 | Lemma Econv_eq : 301 | forall (e : env) (a Ta : term), 302 | Etyp e a Ta -> 303 | forall b Tb : term, Etyp e b Tb -> NF_Econv a b -> Econv Ta Tb -> a = b. 304 | 305 | simple induction 1; intros. 306 | (* sort et var *) 307 | inversion H2; trivial. 308 | inversion H2; trivial. 309 | inversion H3; trivial. 310 | 311 | (* Abs *) 312 | inversion H7. 313 | rewrite <- H13 in H6. 314 | apply inv_Etyp_abs with e0 T' M' Tb; trivial. 315 | intros; cut (T = T'); intros. 316 | rewrite H19; cut (M = M'); intros. 317 | rewrite H20; trivial. 318 | apply H5 with T1; trivial. 319 | rewrite H19; trivial. 320 | apply inv_Econv_prod_r with T T'. 321 | apply trans_Econv_Econv with Tb; auto with ecoc. 322 | apply H1 with (Srt s0); trivial. 323 | apply normal_Econv_NF_conv; trivial. 324 | apply inv_Econv_prod_l with U T1. 325 | apply trans_Econv_Econv with Tb; auto with ecoc. 326 | cut (Econv T T'). 327 | intros; apply Etyp_NF_Econv_Econv with T T' e0 e0; auto with ecoc. 328 | unfold not, is_lam in |- *; intros (x, (x0, H20)). 329 | rewrite H20 in H0. 330 | apply inv_Etyp_abs with e0 x x0 (Srt s1); trivial. 331 | intros. 332 | elim (Econv_sort_prod s1 x T2); auto with ecoc. 333 | apply inv_Econv_prod_l with U T1. 334 | apply trans_Econv_Econv with Tb; auto with ecoc. 335 | 336 | (* App *) 337 | inversion H5. 338 | rewrite <- H11 in H4. 339 | apply inv_Etyp_app with e0 M' N' Tb; trivial. 340 | 341 | intros; cut (u = M'). 342 | intros; cut (v = N'). 343 | intros; rewrite H16; rewrite H17; trivial. 344 | 345 | apply H1 with V0; trivial. 346 | apply inv_Econv_prod_l with Ur Ur0. 347 | apply Etyp_NF_Econv_Econv with u M' e0 e0; auto with ecoc. 348 | 349 | apply H3 with (Prod V0 Ur0); trivial. 350 | apply Etyp_NF_Econv_Econv with u M' e0 e0; auto with ecoc. 351 | 352 | (* Prod *) 353 | inversion H5. 354 | rewrite <- H10 in H4. 355 | apply inv_Etyp_prod with e0 T' U' Tb; trivial. 356 | intros; cut (T = T'). 357 | intros; cut (U = U'). 358 | intros; rewrite H15; rewrite H16; trivial. 359 | 360 | apply H3 with (Srt s3); auto. 361 | rewrite H15; trivial. 362 | 363 | apply trans_Econv_Econv with Tb; auto with ecoc. 364 | 365 | apply H1 with (Srt s0); auto. 366 | apply Etyp_NF_Econv_Econv with T T' e0 e0; auto with ecoc. 367 | unfold not, is_lam in |- *; intros (x, (x0, H15)). 368 | rewrite H15 in H0. 369 | apply inv_Etyp_abs with e0 x x0 (Srt s1); trivial. 370 | intros. 371 | elim (Econv_sort_prod s1 x T1); auto with ecoc. 372 | 373 | (* Conv *) 374 | apply H1 with Tb; trivial. 375 | apply trans_Econv_Econv with V; auto with ecoc. 376 | Qed. 377 | 378 | 379 | Lemma typ_is_nf : 380 | forall (e : env) (a Ta : term), 381 | typ e a Ta -> exists a' : term, red a a' /\ normal a' /\ typ e a' Ta. 382 | intros. 383 | elim (compute_nf a). 384 | intros; split with x; intuition; trivial. 385 | apply subject_reduction with a; trivial. 386 | apply str_norm with e Ta; trivial. 387 | Qed. 388 | 389 | 390 | Lemma EConv_Conv : 391 | forall (e : env) (a b Ta Tb : term), 392 | typ e a Ta -> typ e b Tb -> Econv a b -> Econv Ta Tb -> conv a b. 393 | intros. 394 | generalize (typ_is_nf e a Ta H). 395 | generalize (typ_is_nf e b Tb H0). 396 | intros (x, H3) (x0, H4); intuition. 397 | cut (x = x0). 398 | intros. 399 | rewrite <- H7 in H3. 400 | apply trans_conv_conv with x; auto with coc. 401 | apply sym_conv; auto with coc. 402 | apply Econv_eq with e Tb Ta; auto with coc ecoc. 403 | apply typ_Etyp; trivial. 404 | apply typ_Etyp; trivial. 405 | apply normal_Econv_NF_conv; trivial. 406 | apply trans_Econv_Econv with b. 407 | apply sym_Econv; apply Ered_Econv; auto with ecoc. 408 | apply trans_Econv_Econv with a; auto with ecoc. 409 | apply Ered_Econv; auto with ecoc. 410 | Qed. 411 | 412 | Lemma typ_sort_Econv_Econv : 413 | forall (e : env) (V U : term) (r s : sort), 414 | typ e V (Srt s) -> typ e U (Srt r) -> Econv U V -> Econv (Srt s) (Srt r). 415 | intros. 416 | generalize (typ_is_nf e V (Srt s) H). 417 | generalize (typ_is_nf e U (Srt r) H0). 418 | intros (x, H2) (x0, H3); intuition. 419 | apply Etyp_NF_Econv_Econv with x0 x e e; eauto with ecoc. 420 | apply normal_Econv_NF_conv; auto with ecoc. 421 | apply trans_Econv_Econv with U; auto with ecoc. 422 | apply sym_Econv. 423 | apply trans_Econv_Econv with V; trivial. 424 | apply Ered_Econv; auto with ecoc. 425 | 426 | apply Ered_Econv; auto with ecoc. 427 | 428 | unfold not in |- *; unfold is_lam in |- *; intros (x1, (x2, H6)). 429 | rewrite H6 in H8. 430 | apply inv_Etyp_abs with e x1 x2 (Srt s); trivial. 431 | apply typ_Etyp; trivial. 432 | 433 | intros. 434 | elim (Econv_sort_prod s x1 T); auto with ecoc. 435 | 436 | apply typ_Etyp; trivial. 437 | 438 | apply typ_Etyp; trivial. 439 | Qed. 440 | 441 | 442 | Lemma Etyp_typ : forall (e : env) (M t : term), Etyp e M t -> typ e M t. 443 | fix Etyp_typ 4. 444 | intros. 445 | case H. 446 | intros; apply type_prop. 447 | case H0. 448 | apply wf_nil. 449 | intros; apply wf_var with s. 450 | apply Etyp_typ; trivial. 451 | intros; apply type_set. 452 | case H0. 453 | apply wf_nil. 454 | intros; apply wf_var with s. 455 | apply Etyp_typ; trivial. 456 | intros; apply type_var. 457 | case H0. 458 | apply wf_nil. 459 | intros; apply wf_var with s. 460 | apply Etyp_typ; trivial. 461 | trivial. 462 | intros. 463 | apply type_abs with s1 s2. 464 | apply Etyp_typ; trivial. 465 | apply Etyp_typ; trivial. 466 | apply Etyp_typ; trivial. 467 | intros; apply type_app with V. 468 | apply Etyp_typ; trivial. 469 | apply Etyp_typ; trivial. 470 | intros. 471 | apply type_prod with s1. 472 | apply Etyp_typ; trivial. 473 | apply Etyp_typ; trivial. 474 | intros. 475 | generalize (Etyp_typ e0 t0 U H0); intros. 476 | generalize (Etyp_typ e0 V (Srt s) H2); intros. 477 | generalize (type_case e0 t0 U H3). 478 | intros [(x, H5)| H6]. 479 | apply type_conv with U s; trivial. 480 | apply EConv_Conv with e0 (Srt x) (Srt s); trivial. 481 | apply typ_sort_Econv_Econv with e0 U V; auto with ecoc. 482 | rewrite H6 in H1. 483 | elim (inv_Etyp_Econv_kind e0 V (Srt s)); auto with ecoc. 484 | Qed. 485 | -------------------------------------------------------------------------------- /theories/Ered.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | Require Import Termes. 18 | Require Import Conv. 19 | 20 | Inductive Ered1 : term -> term -> Prop := 21 | | Ebeta : forall M N T : term, Ered1 (App (Abs T M) N) (subst N M) 22 | | Eabs : forall M T : term, Ered1 (Abs T M) (Abs (Srt prop) M) 23 | | Eabs_red_l : 24 | forall M M' : term, 25 | Ered1 M M' -> forall N : term, Ered1 (Abs M N) (Abs M' N) 26 | | Eabs_red_r : 27 | forall M M' : term, 28 | Ered1 M M' -> forall N : term, Ered1 (Abs N M) (Abs N M') 29 | | Eapp_red_l : 30 | forall M1 N1 : term, 31 | Ered1 M1 N1 -> forall M2 : term, Ered1 (App M1 M2) (App N1 M2) 32 | | Eapp_red_r : 33 | forall M2 N2 : term, 34 | Ered1 M2 N2 -> forall M1 : term, Ered1 (App M1 M2) (App M1 N2) 35 | | Eprod_red_l : 36 | forall M1 N1 : term, 37 | Ered1 M1 N1 -> forall M2 : term, Ered1 (Prod M1 M2) (Prod N1 M2) 38 | | Eprod_red_r : 39 | forall M2 N2 : term, 40 | Ered1 M2 N2 -> forall M1 : term, Ered1 (Prod M1 M2) (Prod M1 N2). 41 | 42 | Inductive Ered (M : term) : term -> Prop := 43 | | Erefl : Ered M M 44 | | Etrans_red : forall P N : term, Ered M P -> Ered1 P N -> Ered M N. 45 | 46 | Inductive Econv (M : term) : term -> Prop := 47 | | Erefl_conv : Econv M M 48 | | Etrans_conv_red : forall P N : term, Econv M P -> Ered1 P N -> Econv M N 49 | | Etrans_conv_exp : forall P N : term, Econv M P -> Ered1 N P -> Econv M N. 50 | 51 | Inductive Epar_red1 : term -> term -> Prop := 52 | | Epar_beta : 53 | forall M M' : term, 54 | Epar_red1 M M' -> 55 | forall N N' : term, 56 | Epar_red1 N N' -> 57 | forall T : term, Epar_red1 (App (Abs T M) N) (subst N' M') 58 | | Epar_abs : 59 | forall M M' : term, 60 | Epar_red1 M M' -> 61 | forall T : term, Epar_red1 (Abs T M) (Abs (Srt prop) M') 62 | | Esort_par_red : forall s : sort, Epar_red1 (Srt s) (Srt s) 63 | | Eref_par_red : forall n : nat, Epar_red1 (Ref n) (Ref n) 64 | | Eabs_par_red : 65 | forall M M' : term, 66 | Epar_red1 M M' -> 67 | forall T T' : term, Epar_red1 T T' -> Epar_red1 (Abs T M) (Abs T' M') 68 | | Eapp_par_red : 69 | forall M M' : term, 70 | Epar_red1 M M' -> 71 | forall N N' : term, Epar_red1 N N' -> Epar_red1 (App M N) (App M' N') 72 | | Eprod_par_red : 73 | forall M M' : term, 74 | Epar_red1 M M' -> 75 | forall N N' : term, Epar_red1 N N' -> Epar_red1 (Prod M N) (Prod M' N'). 76 | 77 | Definition Epar_red := clos_trans term Epar_red1. 78 | 79 | Definition Enormal (t : term) : Prop := forall u : term, ~ Ered1 t u. 80 | 81 | Hint Resolve Erefl Ebeta Eabs Eabs_red_l Eabs_red_r Eapp_red_l Eapp_red_r 82 | Eprod_red_l Eprod_red_r: ecoc. 83 | 84 | Hint Resolve Etrans_red: ecoc. 85 | Hint Resolve Erefl_conv Etrans_conv_red Etrans_conv_exp: ecoc. 86 | Hint Resolve Epar_beta Epar_abs Esort_par_red Eref_par_red Eabs_par_red 87 | Eapp_par_red Eprod_par_red: ecoc. 88 | 89 | (* normal -> E *) 90 | Lemma red1_Ered1 : forall M N : term, red1 M N -> Ered1 M N. 91 | simple induction 1; auto with ecoc. 92 | Qed. 93 | 94 | Hint Resolve red1_Ered1: ecoc. 95 | 96 | Lemma red_Ered : forall M N : term, red M N -> Ered M N. 97 | simple induction 1; eauto with ecoc. 98 | Qed. 99 | 100 | Hint Resolve red_Ered: ecoc. 101 | 102 | Lemma conv_Econv : forall M N : term, conv M N -> Econv M N. 103 | simple induction 1; eauto with ecoc. 104 | Qed. 105 | 106 | Hint Resolve conv_Econv: ecoc. 107 | 108 | (* Ered *) 109 | 110 | Lemma trans_Ered_Ered : forall M N P : term, Ered M N -> Ered N P -> Ered M P. 111 | intros. 112 | generalize H0 M H. 113 | simple induction 1; auto with ecoc coc core arith sets. 114 | intros; apply Etrans_red with P0; auto with ecoc coc core arith sets. 115 | Qed. 116 | 117 | (* Epar_red1 *) 118 | Lemma refl_Epar_red1 : forall M : term, Epar_red1 M M. 119 | simple induction M; auto with coc ecoc core arith sets. 120 | Qed. 121 | 122 | Hint Resolve refl_Epar_red1: ecoc. 123 | 124 | Lemma Epar_red1_Epar_red : forall M N : term, Epar_red1 M N -> Epar_red M N. 125 | intros; unfold Epar_red in |- *; apply t_trans with M; auto with ecoc sets. 126 | Qed. 127 | 128 | Hint Resolve Epar_red1_Epar_red: ecoc. 129 | 130 | Lemma Epar_red1_lift : 131 | forall (n : nat) (a b : term), 132 | Epar_red1 a b -> forall k : nat, Epar_red1 (lift_rec n a k) (lift_rec n b k). 133 | simple induction 1; simpl in |- *; eauto with coc ecoc core arith sets. 134 | intros. 135 | rewrite distr_lift_subst; auto with coc ecoc core arith sets. 136 | Qed. 137 | 138 | Hint Resolve Epar_red1_lift: ecoc. 139 | 140 | Lemma Epar_red1_subst : 141 | forall c d : term, 142 | Epar_red1 c d -> 143 | forall a b : term, 144 | Epar_red1 a b -> 145 | forall k : nat, Epar_red1 (subst_rec a c k) (subst_rec b d k). 146 | simple induction 1; simpl in |- *; eauto with coc ecoc core arith sets; 147 | intros. 148 | rewrite distr_subst; auto with coc ecoc core arith sets. 149 | 150 | elim (lt_eq_lt_dec k n); auto with coc ecoc core arith sets; intro a0. 151 | elim a0; intros; auto with coc ecoc core arith sets. 152 | unfold lift in |- *; auto with ecoc. 153 | Qed. 154 | 155 | Hint Resolve Epar_red1_subst: ecoc. 156 | 157 | Lemma inv_Epar_red_abs : 158 | forall (P : Prop) (T U x : term), 159 | Epar_red1 (Abs T U) x -> 160 | (forall T' U' : term, x = Abs T' U' -> Epar_red1 U U' -> P) -> P. 161 | do 5 intro. 162 | inversion_clear H; intros. 163 | apply H with (Srt prop) M'; auto with ecoc. 164 | apply H with T' M'; auto with ecoc. 165 | Qed. 166 | 167 | Lemma Ered1_Epar_red1 : forall M N : term, Ered1 M N -> Epar_red1 M N. 168 | simple induction 1; eauto with ecoc coc core arith sets; intros. 169 | Qed. 170 | 171 | Hint Resolve Ered1_Epar_red1: ecoc. 172 | 173 | Lemma Ered_Epar_red : forall M N : term, Ered M N -> Epar_red M N. 174 | red in |- *; simple induction 1; intros; auto with ecoc coc core arith sets. 175 | apply t_trans with P; auto with ecoc coc core arith sets. 176 | Qed. 177 | 178 | Lemma Ered_Ered_app : 179 | forall u u0 v v0 : term, 180 | Ered u u0 -> Ered v v0 -> Ered (App u v) (App u0 v0). 181 | simple induction 1. 182 | simple induction 1; intros; auto with ecoc coc core arith sets. 183 | apply Etrans_red with (App u P); auto with ecoc coc core arith sets. 184 | 185 | intros; apply Etrans_red with (App P v0); auto with ecoc coc core arith sets. 186 | Qed. 187 | 188 | 189 | Lemma Ered_Ered_abs : 190 | forall u u0 v v0 : term, 191 | Ered u u0 -> Ered v v0 -> Ered (Abs u v) (Abs u0 v0). 192 | simple induction 1. 193 | simple induction 1; intros; auto with ecoc coc core arith sets. 194 | apply Etrans_red with (Abs u P); auto with ecoc coc core arith sets. 195 | 196 | intros; apply Etrans_red with (Abs P v0); auto with ecoc coc core arith sets. 197 | Qed. 198 | 199 | 200 | Lemma Ered_Ered_prod : 201 | forall u u0 v v0 : term, 202 | Ered u u0 -> Ered v v0 -> Ered (Prod u v) (Prod u0 v0). 203 | simple induction 1. 204 | simple induction 1; intros; auto with ecoc coc core arith sets. 205 | apply Etrans_red with (Prod u P); auto with ecoc coc core arith sets. 206 | 207 | intros; apply Etrans_red with (Prod P v0); auto with ecoc coc core arith sets. 208 | Qed. 209 | 210 | Hint Resolve Ered_Ered_app Ered_Ered_abs Ered_Ered_prod: ecoc. 211 | 212 | Lemma Epar_red_Ered : forall M N : term, Epar_red M N -> Ered M N. 213 | simple induction 1. 214 | simple induction 1; intros; eauto with ecoc coc core arith sets. 215 | 216 | intros; apply trans_Ered_Ered with y; auto with ecoc coc core arith sets. 217 | Qed. 218 | 219 | Hint Resolve Ered_Epar_red Epar_red_Ered: ecoc. 220 | 221 | (* Ered1 *) 222 | Lemma Ered1_lift : 223 | forall u v : term, 224 | Ered1 u v -> forall n k : nat, Ered1 (lift_rec n u k) (lift_rec n v k). 225 | simple induction 1; simpl in |- *; intros; auto with ecoc coc core arith sets. 226 | rewrite distr_lift_subst; auto with ecoc coc core arith sets. 227 | Qed. 228 | 229 | Hint Resolve Ered1_lift: ecoc. 230 | 231 | 232 | Lemma Ered1_subst_r : 233 | forall t u : term, 234 | Ered1 t u -> 235 | forall (a : term) (k : nat), Ered1 (subst_rec a t k) (subst_rec a u k). 236 | simple induction 1; simpl in |- *; intros; auto with ecoc coc core arith sets. 237 | rewrite distr_subst; auto with ecoc coc core arith sets. 238 | Qed. 239 | 240 | 241 | Lemma Ered1_subst_l : 242 | forall (a t u : term) (k : nat), 243 | Ered1 t u -> Ered (subst_rec t a k) (subst_rec u a k). 244 | simple induction a; simpl in |- *; auto with ecoc coc core arith sets. 245 | intros. 246 | elim (lt_eq_lt_dec k n); 247 | [ intro a0 | intro b; auto with ecoc coc core arith sets ]. 248 | elim a0; auto with ecoc coc core arith sets. 249 | unfold lift in |- *; auto with ecoc coc core arith sets. 250 | Qed. 251 | 252 | Hint Resolve Ered1_subst_l Ered1_subst_r: ecoc. 253 | 254 | Lemma subst_rec_Ered1_r : 255 | forall N M M' : term, 256 | Ered1 M M' -> forall k : nat, Ered1 (subst_rec N M k) (subst_rec N M' k). 257 | simple induction 1; simpl in |- *; intros; auto with ecoc. 258 | rewrite distr_subst. 259 | auto with ecoc. 260 | Qed. 261 | 262 | Lemma subst_Ered1_r : 263 | forall N M M' : term, Ered1 M M' -> Ered1 (subst N M) (subst N M'). 264 | unfold subst in |- *; intros; apply subst_rec_Ered1_r; trivial. 265 | Qed. 266 | 267 | 268 | 269 | 270 | 271 | (* church_rosser *) 272 | Lemma str_confluence_Epar_red1 : str_confluent Epar_red1. 273 | red in |- *; red in |- *. 274 | simple induction 1; intros. 275 | inversion_clear H4. 276 | elim H1 with M'0; auto with ecoc coc core arith sets; intros. 277 | elim H3 with N'0; auto with ecoc coc core arith sets; intros. 278 | split with (subst x1 x0); unfold subst in |- *; 279 | auto with coc ecoc core arith sets. 280 | 281 | inversion_clear H5. 282 | elim H1 with M'1; auto with ecoc coc core arith sets; intros. 283 | elim H3 with N'0; auto with ecoc coc core arith sets; intros. 284 | split with (subst x1 x0); auto with ecoc coc core arith sets. 285 | unfold subst in |- *; auto with ecoc coc core arith sets. 286 | 287 | elim H1 with M'1; auto with ecoc coc core arith sets; intros. 288 | elim H3 with N'0; auto with ecoc coc core arith sets; intros. 289 | split with (subst x1 x0); auto with ecoc coc core arith sets. 290 | unfold subst in |- *; auto with ecoc coc core arith sets. 291 | 292 | inversion_clear H2. 293 | elim H1 with M'0; auto with ecoc coc core arith sets; intros. 294 | split with (Abs (Srt prop) x0); eauto with ecoc coc core arith sets; intros. 295 | 296 | elim H1 with M'0; auto with ecoc coc core arith sets; intros. 297 | split with (Abs (Srt prop) x0); eauto with ecoc coc core arith sets. 298 | 299 | inversion_clear H0. 300 | split with (Srt s); auto with ecoc coc core arith sets. 301 | 302 | inversion_clear H0. 303 | split with (Ref n); auto with ecoc coc core arith sets. 304 | 305 | inversion_clear H4. 306 | elim H1 with M'0; auto with ecoc coc core arith sets; intros. 307 | split with (Abs (Srt prop) x0); eauto with ecoc coc core arith sets. 308 | 309 | elim H1 with M'0; auto with ecoc coc core arith sets; intros. 310 | elim H3 with T'0; auto with ecoc coc core arith sets; intros. 311 | split with (Abs x1 x0); auto with ecoc coc core arith sets. 312 | 313 | generalize H0 H1. 314 | clear H0 H1. 315 | inversion_clear H4. 316 | intro. 317 | inversion_clear H4. 318 | intros. 319 | elim H4 with (Abs (Srt prop) M'0); auto with coc core arith sets; intros. 320 | elim H3 with N'0; auto with coc core arith sets; intros. 321 | apply inv_Epar_red_abs with (Srt prop) M'1 x0; intros; 322 | auto with coc core arith sets. 323 | rewrite H10 in H7; inversion_clear H7. 324 | split with (subst x1 U'); auto with ecoc sets. 325 | unfold subst in |- *; auto with ecoc coc core arith sets. 326 | 327 | split with (subst x1 U'); auto with ecoc sets. 328 | unfold subst in |- *; auto with ecoc coc core arith sets. 329 | 330 | auto with ecoc sets. 331 | 332 | intros. 333 | elim H3 with N'0; auto with ecoc sets; intros. 334 | elim H4 with (Abs T' M'0); auto with ecoc sets; intros. 335 | apply inv_Epar_red_abs with T' M'0 x1; intros; auto with coc core arith sets. 336 | rewrite H11 in H9; inversion_clear H9. 337 | split with (subst x0 U'); auto with ecoc sets. 338 | unfold subst in |- *; auto with ecoc coc core arith sets. 339 | 340 | split with (subst x0 U'); auto with ecoc sets. 341 | unfold subst in |- *; auto with ecoc coc core arith sets. 342 | 343 | intros. 344 | elim H5 with M'0; auto with ecoc sets; intros. 345 | elim H3 with N'0; auto with ecoc sets; intros. 346 | split with (App x0 x1); auto with ecoc sets. 347 | 348 | inversion_clear H4. 349 | elim H1 with M'0; auto with coc ecoc sets; intros. 350 | elim H3 with N'0; auto with coc ecoc sets; intros. 351 | split with (Prod x0 x1); auto with ecoc sets. 352 | Qed. 353 | 354 | Lemma strip_lemma_Epar_red1 : commut _ Epar_red (transp _ Epar_red1). 355 | unfold commut, Epar_red in |- *; simple induction 1; intros. 356 | elim str_confluence_Epar_red1 with z x0 y0; 357 | auto with ecoc coc core arith sets; intros. 358 | split with x1; auto with ecoc coc core arith sets. 359 | 360 | elim H1 with z0; auto with ecoc coc core arith sets; intros. 361 | elim H3 with x1; intros; auto with ecoc coc core arith sets. 362 | split with x2; auto with ecoc coc core arith sets. 363 | apply t_trans with x1; auto with ecoc coc core arith sets. 364 | Qed. 365 | 366 | Lemma confluence_Epar_red : str_confluent Epar_red. 367 | red in |- *; red in |- *. 368 | simple induction 1; intros. 369 | elim strip_lemma_Epar_red1 with z x0 y0; intros; 370 | auto with ecoc coc core arith sets. 371 | split with x1; auto with ecoc coc core arith sets. 372 | 373 | elim H1 with z0; intros; auto with ecoc coc core arith sets. 374 | elim H3 with x1; intros; auto with ecoc coc core arith sets. 375 | split with x2; auto with ecoc coc core arith sets. 376 | red in |- *; apply t_trans with x1; auto with ecoc coc core arith sets. 377 | Qed. 378 | 379 | Lemma confluence_Ered : str_confluent Ered. 380 | red in |- *; red in |- *. 381 | intros. 382 | elim confluence_Epar_red with x y z; auto with ecoc coc core arith sets; 383 | intros. 384 | exists x0; auto with ecoc coc core arith sets. 385 | Qed. 386 | 387 | Theorem Econv_church_rosser : 388 | forall u v : term, 389 | Econv u v -> ex2 (fun t : term => Ered u t) (fun t : term => Ered v t). 390 | simple induction 1; intros. 391 | exists u; auto with ecoc coc core arith sets. 392 | 393 | elim H1; intros. 394 | elim confluence_Ered with x P N; auto with ecoc coc core arith sets; intros. 395 | exists x0; auto with ecoc coc core arith sets. 396 | apply trans_Ered_Ered with x; auto with ecoc coc core arith sets. 397 | 398 | elim H1; intros. 399 | exists x; auto with ecoc coc core arith sets. 400 | apply trans_Ered_Ered with P; auto with ecoc coc core arith sets. 401 | Qed. 402 | 403 | (* Econv *) 404 | 405 | Lemma one_step_Econv_exp : forall M N : term, Ered1 M N -> Econv N M. 406 | intros. 407 | apply Etrans_conv_exp with N; auto with ecoc coc core arith sets. 408 | Qed. 409 | 410 | 411 | Lemma Ered_Econv : forall M N : term, Ered M N -> Econv M N. 412 | simple induction 1; auto with ecoc coc core arith sets. 413 | intros; apply Etrans_conv_red with P; auto with ecoc coc core arith sets. 414 | Qed. 415 | 416 | Hint Resolve one_step_Econv_exp Ered_Econv: coc. 417 | 418 | Lemma sym_Econv : forall M N : term, Econv M N -> Econv N M. 419 | simple induction 1; auto with ecoc coc core arith sets. 420 | simple induction 2; intros; auto with ecoc coc core arith sets. 421 | apply Etrans_conv_red with P0; auto with ecoc coc core arith sets. 422 | 423 | apply Etrans_conv_exp with P0; auto with ecoc coc core arith sets. 424 | 425 | simple induction 2; intros; auto with ecoc coc core arith sets. 426 | apply Etrans_conv_red with P0; auto with ecoc coc core arith sets. 427 | 428 | apply Etrans_conv_exp with P0; auto with ecoc coc core arith sets. 429 | Qed. 430 | 431 | Hint Immediate sym_Econv: coc. 432 | 433 | Lemma trans_Econv_Econv : 434 | forall M N P : term, Econv M N -> Econv N P -> Econv M P. 435 | intros. 436 | generalize M H; elim H0; intros; auto with ecoc coc core arith sets. 437 | apply Etrans_conv_red with P0; auto with ecoc coc core arith sets. 438 | apply Etrans_conv_exp with P0; auto with ecoc coc core arith sets. 439 | Qed. 440 | 441 | Lemma Econv_Econv_prod : 442 | forall a b c d : term, Econv a b -> Econv c d -> Econv (Prod a c) (Prod b d). 443 | intros. 444 | apply trans_Econv_Econv with (Prod a d). 445 | elim H0; intros; auto with ecoc coc core arith sets. 446 | apply Etrans_conv_red with (Prod a P); auto with ecoc coc core arith sets. 447 | 448 | apply Etrans_conv_exp with (Prod a P); auto with ecoc coc core arith sets. 449 | 450 | elim H; intros; auto with ecoc coc core arith sets. 451 | apply Etrans_conv_red with (Prod P d); auto with ecoc coc core arith sets. 452 | 453 | apply Etrans_conv_exp with (Prod P d); auto with ecoc coc core arith sets. 454 | Qed. 455 | 456 | Lemma Econv_Econv_app : 457 | forall a b c d : term, Econv a b -> Econv c d -> Econv (App a c) (App b d). 458 | intros. 459 | apply trans_Econv_Econv with (App a d). 460 | elim H0; intros; auto with ecoc coc core arith sets. 461 | apply Etrans_conv_red with (App a P); auto with ecoc coc core arith sets. 462 | 463 | apply Etrans_conv_exp with (App a P); auto with ecoc coc core arith sets. 464 | 465 | elim H; intros; auto with ecoc coc core arith sets. 466 | apply Etrans_conv_red with (App P d); auto with ecoc coc core arith sets. 467 | 468 | apply Etrans_conv_exp with (App P d); auto with ecoc coc core arith sets. 469 | Qed. 470 | 471 | Hint Resolve Econv_Econv_prod Econv_Econv_app: ecoc. 472 | 473 | Lemma Ered_Enormal : forall u v : term, Ered u v -> Enormal u -> u = v. 474 | simple induction 1; auto with ecoc coc core arith sets; intros. 475 | absurd (Ered1 u N); auto with ecoc coc core arith sets. 476 | absurd (Ered1 P N); auto with ecoc coc core arith sets. 477 | elim (H1 H3). 478 | unfold not in |- *; intro; apply (H3 N); auto with ecoc coc core arith sets. 479 | Qed. 480 | 481 | Lemma Ered_prod_prod : 482 | forall u v t : term, 483 | Ered (Prod u v) t -> 484 | forall P : Prop, 485 | (forall a b : term, t = Prod a b -> Ered u a -> Ered v b -> P) -> P. 486 | simple induction 1; intros. 487 | apply H0 with u v; auto with ecoc coc core arith sets. 488 | 489 | apply H1; intros. 490 | inversion_clear H4 in H2. 491 | inversion H2. 492 | apply H3 with N1 b; auto with ecoc coc core arith sets. 493 | apply Etrans_red with a; auto with ecoc coc core arith sets. 494 | 495 | apply H3 with a N2; auto with ecoc coc core arith sets. 496 | apply Etrans_red with b; auto with ecoc coc core arith sets. 497 | Qed. 498 | 499 | Lemma Econv_sort_prod : 500 | forall (s : sort) (t u : term), ~ Econv (Srt s) (Prod t u). 501 | red in |- *; intros. 502 | elim Econv_church_rosser with (Srt s) (Prod t u); 503 | auto with ecoc coc core arith sets. 504 | do 2 intro. 505 | elim Ered_Enormal with (Srt s) x; auto with ecoc coc core arith sets. 506 | intro. 507 | apply Ered_prod_prod with t u (Srt s); auto with ecoc coc core arith sets; 508 | intros. 509 | discriminate H2. 510 | 511 | red in |- *; red in |- *; intros. 512 | inversion_clear H1. 513 | Qed. 514 | 515 | Lemma Econv_abs : forall a b T : term, Econv a b -> Econv (Abs T a) (Abs T b). 516 | intros. 517 | elim H; intros; auto with ecoc coc core arith sets. 518 | apply Etrans_conv_red with (Abs T P); auto with ecoc coc core arith sets. 519 | apply Etrans_conv_exp with (Abs T P); auto with ecoc coc core arith sets. 520 | Qed. 521 | 522 | Hint Resolve Econv_abs: ecoc. 523 | 524 | Lemma Econv_Type_abs : 525 | forall a b T T' : term, Econv a b -> Econv (Abs T a) (Abs T' b). 526 | intros. 527 | apply trans_Econv_Econv with (Abs (Srt prop) a); eauto with ecoc. 528 | Qed. 529 | 530 | Hint Resolve Econv_Type_abs: ecoc. 531 | 532 | Lemma Econv_Econv_lift : 533 | forall (a b : term) (n k : nat), 534 | Econv a b -> Econv (lift_rec n a k) (lift_rec n b k). 535 | intros. 536 | elim H; intros; auto with ecoc coc core arith sets. 537 | apply Etrans_conv_red with (lift_rec n P k); 538 | auto with ecoc coc core arith sets. 539 | 540 | apply Etrans_conv_exp with (lift_rec n P k); 541 | auto with ecoc coc core arith sets. 542 | Qed. 543 | 544 | Lemma Econv_Econv_subst : 545 | forall (a b c d : term) (k : nat), 546 | Econv a b -> Econv c d -> Econv (subst_rec a c k) (subst_rec b d k). 547 | intros. 548 | apply trans_Econv_Econv with (subst_rec a d k). 549 | elim H0; intros; auto with ecoc coc core arith sets. 550 | apply Etrans_conv_red with (subst_rec a P k); 551 | auto with ecoc coc core arith sets. 552 | 553 | apply Etrans_conv_exp with (subst_rec a P k); 554 | auto with ecoc coc core arith sets. 555 | 556 | elim H; intros; auto with ecoc coc core arith sets. 557 | apply trans_Econv_Econv with (subst_rec P d k); 558 | auto with ecoc coc core arith sets. 559 | 560 | apply trans_Econv_Econv with (subst_rec P d k); 561 | auto with ecoc coc core arith sets. 562 | apply sym_Econv; auto with ecoc coc core arith sets. 563 | Qed. 564 | 565 | Lemma inv_Econv_prod_l : 566 | forall a b c d : term, Econv (Prod a c) (Prod b d) -> Econv a b. 567 | intros. 568 | elim Econv_church_rosser with (Prod a c) (Prod b d); intros; 569 | auto with ecoc coc core arith sets. 570 | apply Ered_prod_prod with a c x; intros; auto with ecoc coc core arith sets. 571 | apply Ered_prod_prod with b d x; intros; auto with ecoc coc core arith sets. 572 | apply trans_Econv_Econv with a0; auto with ecoc coc core arith sets. 573 | apply sym_Econv. 574 | generalize H2. 575 | rewrite H5; intro. 576 | injection H8. 577 | simple induction 2; auto with ecoc coc core arith sets. 578 | Qed. 579 | 580 | Lemma inv_Econv_prod_r : 581 | forall a b c d : term, Econv (Prod a c) (Prod b d) -> Econv c d. 582 | intros. 583 | elim Econv_church_rosser with (Prod a c) (Prod b d); intros; 584 | auto with ecoc coc core arith sets. 585 | apply Ered_prod_prod with a c x; intros; auto with ecoc coc core arith sets. 586 | apply Ered_prod_prod with b d x; intros; auto with ecoc coc core arith sets. 587 | apply trans_Econv_Econv with b0; auto with ecoc coc core arith sets. 588 | apply sym_Econv. 589 | generalize H2. 590 | rewrite H5; intro. 591 | injection H8. 592 | simple induction 1; auto with ecoc coc core arith sets. 593 | Qed. 594 | 595 | Hint Resolve sym_Econv trans_Econv_Econv Econv_Econv_prod Econv_Econv_lift 596 | Econv_Econv_subst: ecoc. 597 | 598 | Lemma Ered1_Ered_ind : 599 | forall (N : term) (P : term -> Prop), 600 | P N -> 601 | (forall M R : term, Ered1 M R -> Ered R N -> P R -> P M) -> 602 | forall M : term, Ered M N -> P M. 603 | cut 604 | (forall M N : term, 605 | Ered M N -> 606 | forall P : term -> Prop, 607 | P N -> (forall M R : term, Ered1 M R -> Ered R N -> P R -> P M) -> P M). 608 | intros. 609 | apply (H M N); auto with ecoc coc core arith sets. 610 | 611 | simple induction 1; intros; auto with ecoc coc core arith sets. 612 | apply H1; auto with ecoc coc core arith sets. 613 | apply H4 with N0; auto with ecoc coc core arith sets. 614 | 615 | intros. 616 | apply H4 with R; auto with ecoc coc core arith sets. 617 | apply Etrans_red with P; auto with ecoc coc core arith sets. 618 | Qed. 619 | 620 | 621 | Lemma inv_Ered_Abs : 622 | forall T U x : term, 623 | Ered (Abs T U) x -> exists T' : term, (exists U' : term, x = Abs T' U'). 624 | simple induction 1. 625 | split with T; split with U; trivial. 626 | intros P N H0 (T', (U', H1)) H2. 627 | rewrite H1 in H2. 628 | inversion H2. 629 | split with (Srt prop); split with U'; trivial. 630 | split with M'; split with U'; trivial. 631 | split with T'; split with M'; trivial. 632 | Qed. 633 | 634 | Lemma not_Ered_Abs_sort : 635 | forall (T M : term) (s : sort), ~ Ered (Abs T M) (Srt s). 636 | unfold not in |- *; intros. 637 | inversion H. 638 | generalize (inv_Ered_Abs T M P H0). 639 | intros (T', (U', H3)). 640 | rewrite H3 in H1; inversion H1. 641 | Qed. 642 | 643 | 644 | Lemma Ered1_sort_mem : 645 | forall (t : term) (s : sort), Ered1 t (Srt s) -> mem_sort s t. 646 | intros. 647 | inversion H. 648 | elim mem_sort_subst with M N 0 s; intros; auto with coc core arith sets. 649 | unfold subst in H2; rewrite H2. 650 | auto with coc. 651 | Qed. 652 | 653 | Inductive mem_sort2 (s : sort) : term -> Prop := 654 | | mem_eq2 : mem_sort2 s (Srt s) 655 | | mem_prod_l2 : forall u v : term, mem_sort2 s u -> mem_sort2 s (Prod u v) 656 | | mem_prod_r2 : forall u v : term, mem_sort2 s v -> mem_sort2 s (Prod u v) 657 | | mem_abs_r2 : forall u v : term, mem_sort2 s v -> mem_sort2 s (Abs u v) 658 | | mem_app_l2 : forall u v : term, mem_sort2 s u -> mem_sort2 s (App u v) 659 | | mem_app_r2 : forall u v : term, mem_sort2 s v -> mem_sort2 s (App u v). 660 | 661 | Hint Resolve mem_eq2 mem_prod_l2 mem_prod_r2 mem_abs_r2 mem_app_l2 662 | mem_app_r2: ecoc. 663 | 664 | Lemma mem_sort2_lift : 665 | forall (t : term) (n k : nat) (s : sort), 666 | mem_sort2 s (lift_rec n t k) -> mem_sort2 s t. 667 | simple induction t; simpl in |- *; intros; auto with ecoc coc core arith sets. 668 | generalize H; elim (le_gt_dec k n); intros; 669 | auto with ecoc coc core arith sets. 670 | inversion_clear H0. 671 | 672 | inversion_clear H1. 673 | apply mem_abs_r2; apply H0 with n (S k); auto with ecoc coc core arith sets. 674 | 675 | inversion_clear H1. 676 | apply mem_app_l2; apply H with n k; auto with ecoc coc core arith sets. 677 | 678 | apply mem_app_r2; apply H0 with n k; auto with ecoc coc core arith sets. 679 | 680 | inversion_clear H1. 681 | apply mem_prod_l2; apply H with n k; auto with ecoc coc core arith sets. 682 | 683 | apply mem_prod_r2; apply H0 with n (S k); auto with ecoc coc core arith sets. 684 | Qed. 685 | 686 | 687 | Lemma mem_sort2_subst : 688 | forall (b a : term) (n : nat) (s : sort), 689 | mem_sort2 s (subst_rec a b n) -> mem_sort2 s a \/ mem_sort2 s b. 690 | simple induction b; simpl in |- *; intros; auto with ecoc coc core arith sets. 691 | generalize H; elim (lt_eq_lt_dec n0 n); [ intro a0 | intro b0 ]. 692 | elim a0; intros. 693 | inversion_clear H0. 694 | 695 | left. 696 | apply mem_sort2_lift with n0 0; auto with ecoc coc core arith sets. 697 | 698 | intros. 699 | inversion_clear H0. 700 | 701 | inversion_clear H1. 702 | elim H0 with a (S n) s; auto with ecoc coc core arith sets. 703 | 704 | inversion_clear H1. 705 | elim H with a n s; auto with ecoc coc core arith sets. 706 | 707 | elim H0 with a n s; auto with ecoc coc core arith sets. 708 | 709 | inversion_clear H1. 710 | elim H with a n s; auto with ecoc coc core arith sets. 711 | 712 | elim H0 with a (S n) s; intros; auto with ecoc coc core arith sets. 713 | Qed. 714 | 715 | Lemma Ered_sort_mem2 : 716 | forall (t : term) (s : sort), Ered t (Srt s) -> mem_sort2 s t. 717 | intros. 718 | pattern t in |- *. 719 | apply Ered1_Ered_ind with (Srt s); auto with ecoc coc core arith sets. 720 | do 4 intro. 721 | elim H0; intros. 722 | elim mem_sort2_subst with M0 N 0 s; intros; 723 | auto with ecoc coc core arith sets. 724 | 725 | inversion H2; auto with ecoc. 726 | 727 | inversion H4; auto with ecoc. 728 | 729 | inversion H4; auto with ecoc. 730 | 731 | inversion H4; auto with ecoc. 732 | 733 | inversion H4; auto with ecoc. 734 | 735 | inversion H4; auto with ecoc. 736 | 737 | inversion H4; auto with ecoc. 738 | Qed. 739 | 740 | Lemma mem_sort2_mem_sort : 741 | forall (t : term) (s : sort), mem_sort2 s t -> mem_sort s t. 742 | simple induction 1; auto with coc. 743 | Qed. 744 | 745 | Lemma Ered_sort_mem : 746 | forall (t : term) (s : sort), Ered t (Srt s) -> mem_sort s t. 747 | intros; apply mem_sort2_mem_sort; apply Ered_sort_mem2; trivial. 748 | Qed. 749 | 750 | -------------------------------------------------------------------------------- /theories/Expr.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import MyList. 19 | Require Import Termes. 20 | Require Export Names. 21 | 22 | (* external level *) 23 | 24 | Inductive expr : Set := 25 | | SRT : sort -> expr 26 | | REF : name -> expr 27 | | ABS : name -> expr -> expr -> expr 28 | | APP : expr -> expr -> expr 29 | | PROD : name -> expr -> expr -> expr. 30 | 31 | 32 | Inductive expr_vars (x : name) : expr -> Prop := 33 | | ev_ref : expr_vars x (REF x) 34 | | ev_abs_l : 35 | forall (y : name) (T M : expr), 36 | expr_vars x T -> expr_vars x (ABS y T M) 37 | | ev_abs_r : 38 | forall (y : name) (T M : expr), 39 | x <> y -> expr_vars x M -> expr_vars x (ABS y T M) 40 | | ev_app_l : forall u v : expr, expr_vars x u -> expr_vars x (APP u v) 41 | | ev_app_r : forall u v : expr, expr_vars x v -> expr_vars x (APP u v) 42 | | ev_prod_l : 43 | forall (y : name) (T U : expr), 44 | expr_vars x T -> expr_vars x (PROD y T U) 45 | | ev_prod_r : 46 | forall (y : name) (T U : expr), 47 | x <> y -> expr_vars x U -> expr_vars x (PROD y T U). 48 | 49 | Hint Resolve ev_ref ev_abs_l ev_abs_r ev_app_l ev_app_r ev_prod_l 50 | ev_prod_r: coc. 51 | 52 | 53 | Definition is_free_var : 54 | forall (x : name) (e : expr), {expr_vars x e} + {~ expr_vars x e}. 55 | 56 | simple induction e. 57 | right; red in |- *; intros; inversion H. 58 | 59 | intro y; case (name_dec x y); intros; [ left | right ]. 60 | rewrite e0; auto with coc. 61 | red in |- *; intros A; inversion A; auto. 62 | 63 | intros y t H u H1. 64 | elim H; intros; 65 | [ idtac | elim (name_dec x y); intros; [ idtac | elim H1; intros ] ]; 66 | auto with coc; right; red in |- *; intros A; inversion A; 67 | auto. 68 | 69 | intros u H v H1. 70 | elim H; intros; [ idtac | elim H1; intros ]; auto with coc; right; 71 | red in |- *; intros A; inversion A; auto. 72 | 73 | intros y t H u H1. 74 | elim H; intros; 75 | [ idtac | elim (name_dec x y); intros; [ idtac | elim H1; intros ] ]; 76 | auto with coc; right; red in |- *; intros A; inversion A; 77 | auto. 78 | 79 | Defined. 80 | 81 | 82 | 83 | 84 | 85 | Inductive transl_name : list name -> name -> list name -> name -> Prop := 86 | | tr_nil : forall x : name, transl_name nil x nil x 87 | | tr_hd : 88 | forall (x y : name) (l1 l2 : list name), 89 | transl_name (x :: l1) x (y :: l2) y 90 | | tr_tl : 91 | forall (x x0 y y0 : name) (l1 l2 : list name), 92 | x <> x0 -> 93 | y <> y0 -> 94 | transl_name l1 x l2 y -> transl_name (x0 :: l1) x (y0 :: l2) y. 95 | 96 | 97 | Inductive alpha : list name -> expr -> list name -> expr -> Prop := 98 | | alp_srt : 99 | forall (l1 l2 : list name) (s : sort), alpha l1 (SRT s) l2 (SRT s) 100 | | alp_ref : 101 | forall (l1 l2 : list name) (x y : name), 102 | transl_name l1 x l2 y -> alpha l1 (REF x) l2 (REF y) 103 | | alp_abs : 104 | forall (l1 l2 : list name) (x y : name) (A A' M M' : expr), 105 | alpha l1 A l2 A' -> 106 | alpha (x :: l1) M (y :: l2) M' -> 107 | alpha l1 (ABS x A M) l2 (ABS y A' M') 108 | | alp_app : 109 | forall (l1 l2 : list name) (A A' M M' : expr), 110 | alpha l1 A l2 A' -> 111 | alpha l1 M l2 M' -> alpha l1 (APP A M) l2 (APP A' M') 112 | | alp_prod : 113 | forall (l1 l2 : list name) (x y : name) (A A' M M' : expr), 114 | alpha l1 A l2 A' -> 115 | alpha (x :: l1) M (y :: l2) M' -> 116 | alpha l1 (PROD x A M) l2 (PROD y A' M'). 117 | 118 | 119 | (* conversion *) 120 | Inductive term_expr_equiv : prt_names -> term -> expr -> Prop := 121 | | eqv_srt : 122 | forall (l : prt_names) (s : sort), term_expr_equiv l (Srt s) (SRT s) 123 | | eqv_ref : 124 | forall (l : prt_names) (x : name) (n : nat), 125 | first_item _ x l n -> term_expr_equiv l (Ref n) (REF x) 126 | | eqv_abs : 127 | forall (l : prt_names) (A M : term) (B N : expr) (x : name), 128 | term_expr_equiv l A B -> 129 | term_expr_equiv (x :: l) M N -> 130 | term_expr_equiv l (Abs A M) (ABS x B N) 131 | | eqv_app : 132 | forall (l : prt_names) (u v : term) (a b : expr), 133 | term_expr_equiv l u a -> 134 | term_expr_equiv l v b -> term_expr_equiv l (App u v) (APP a b) 135 | | eqv_prod : 136 | forall (l : prt_names) (A M : term) (B N : expr) (x : name), 137 | term_expr_equiv l A B -> 138 | term_expr_equiv (x :: l) M N -> 139 | term_expr_equiv l (Prod A M) (PROD x B N). 140 | 141 | 142 | 143 | Lemma equiv_free_db : 144 | forall (l : prt_names) (t : term) (e : expr), 145 | term_expr_equiv l t e -> free_db (length l) t. 146 | simple induction 1; simpl in |- *; intros; auto with coc core arith datatypes. 147 | apply db_ref. 148 | elim H0; simpl in |- *; auto with coc core arith datatypes. 149 | Qed. 150 | 151 | 152 | Lemma equiv_unique : 153 | forall (l : prt_names) (t : term) (e : expr), 154 | term_expr_equiv l t e -> forall u : term, term_expr_equiv l u e -> t = u. 155 | simple induction 1; intros. 156 | inversion_clear H0; auto with coc core arith datatypes. 157 | 158 | inversion_clear H1. 159 | elim first_item_unique with name x l0 n n0; 160 | auto with coc core arith datatypes. 161 | 162 | inversion_clear H4. 163 | elim H1 with A0; auto with coc core arith datatypes. 164 | elim H3 with M0; auto with coc core arith datatypes. 165 | 166 | inversion_clear H4. 167 | elim H1 with u1; auto with coc core arith datatypes. 168 | elim H3 with v0; auto with coc core arith datatypes. 169 | 170 | inversion_clear H4. 171 | elim H1 with A0; auto with coc core arith datatypes. 172 | elim H3 with M0; auto with coc core arith datatypes. 173 | Qed. 174 | 175 | 176 | 177 | Lemma unique_alpha : 178 | forall (l1 : prt_names) (t : term) (e : expr), 179 | term_expr_equiv l1 t e -> 180 | forall (l2 : prt_names) (f : expr), 181 | term_expr_equiv l2 t f -> alpha l1 e l2 f. 182 | simple induction 1; intros. 183 | inversion_clear H0. 184 | apply alp_srt. 185 | 186 | inversion_clear H1. 187 | apply alp_ref. 188 | generalize l2 H2. 189 | elim H0; intros. 190 | inversion_clear H1. 191 | apply tr_hd. 192 | 193 | inversion_clear H5. 194 | apply tr_tl; auto with coc core arith datatypes. 195 | 196 | inversion_clear H4. 197 | apply alp_abs; auto with coc core arith datatypes. 198 | 199 | inversion_clear H4. 200 | apply alp_app; auto with coc core arith datatypes. 201 | 202 | inversion_clear H4. 203 | apply alp_prod; auto with coc core arith datatypes. 204 | Qed. 205 | 206 | 207 | 208 | Definition expr_of_term : 209 | forall (t : term) (l : prt_names), 210 | name_unique l -> 211 | free_db (length l) t -> {e : expr | term_expr_equiv l t e}. 212 | simple induction t; intros. 213 | exists (SRT s). 214 | apply eqv_srt. 215 | 216 | elim (list_item _ l n); intros. 217 | inversion_clear a. 218 | exists (REF x). 219 | apply eqv_ref. 220 | apply name_unique_first; auto with coc core arith datatypes. 221 | 222 | exfalso. 223 | inversion_clear H0. 224 | generalize n b H1. 225 | elim l; simpl in |- *. 226 | intros. 227 | inversion_clear H0. 228 | 229 | simple destruct n0; intros. 230 | elim b0 with a; auto with coc core arith datatypes. 231 | 232 | apply H0 with n1; auto with coc core arith datatypes. 233 | red in |- *; intros. 234 | elim b0 with t0; auto with coc core arith datatypes. 235 | 236 | elim H with l; intros; auto with coc core arith datatypes. 237 | elim find_free_var with l; intros. 238 | elim H0 with (x0 :: l); intros. 239 | exists (ABS x0 x x1). 240 | apply eqv_abs; auto with coc core arith datatypes. 241 | 242 | apply fv_ext; auto with coc core arith datatypes. 243 | 244 | inversion_clear H2; auto with coc core arith datatypes. 245 | 246 | inversion_clear H2; auto with coc core arith datatypes. 247 | 248 | elim H with l; intros; auto with coc core arith datatypes. 249 | elim H0 with l; intros; auto with coc core arith datatypes. 250 | exists (APP x x0). 251 | apply eqv_app; auto with coc core arith datatypes. 252 | 253 | inversion_clear H2; auto with coc core arith datatypes. 254 | 255 | inversion_clear H2; auto with coc core arith datatypes. 256 | 257 | elim H with l; intros; auto with coc core arith datatypes. 258 | elim find_free_var with l; intros. 259 | elim H0 with (x0 :: l); intros. 260 | exists (PROD x0 x x1). 261 | apply eqv_prod; auto with coc core arith datatypes. 262 | 263 | apply fv_ext; auto with coc core arith datatypes. 264 | 265 | inversion_clear H2; auto with coc core arith datatypes. 266 | 267 | inversion_clear H2; auto with coc core arith datatypes. 268 | Defined. 269 | 270 | 271 | 272 | Definition undef_vars (e : expr) (def undef : prt_names) : Prop := 273 | list_disjoint _ def undef /\ 274 | (forall x : name, In _ x undef -> expr_vars x e). 275 | 276 | Lemma undef_vars_incl : 277 | forall (e : expr) (l u1 u2 : prt_names), 278 | incl _ u1 u2 -> undef_vars e l u2 -> undef_vars e l u1. 279 | unfold undef_vars in |- *; split. 280 | inversion_clear H0. 281 | red in |- *; simpl in |- *; intros. 282 | apply H1 with x; auto with coc core arith datatypes. 283 | 284 | inversion_clear H0; auto with coc core arith datatypes. 285 | Qed. 286 | 287 | 288 | 289 | Lemma undef_vars_abs : 290 | forall (x : name) (e1 e2 : expr) (l u1 u2 : prt_names), 291 | undef_vars e1 l u1 -> 292 | undef_vars e2 (x :: l) u2 -> undef_vars (ABS x e1 e2) l (u1 ++ u2). 293 | split; intros. 294 | inversion_clear H. 295 | inversion_clear H0. 296 | red in |- *; simpl in |- *; intros. 297 | elim In_app with name x0 u1 u2; intros; auto with coc core arith datatypes. 298 | apply H1 with x0; auto with coc core arith datatypes. 299 | 300 | apply H with x0; auto with coc core arith datatypes. 301 | 302 | inversion_clear H. 303 | inversion_clear H0. 304 | elim In_app with name x0 u1 u2; intros; auto with coc core arith datatypes. 305 | apply ev_abs_r; auto with coc core arith datatypes. 306 | red in |- *; intros. 307 | apply H with x0; auto with coc core arith datatypes. 308 | rewrite H5; auto with coc core arith datatypes. 309 | Qed. 310 | 311 | 312 | Lemma undef_vars_app : 313 | forall (e1 e2 : expr) (l u1 u2 : prt_names), 314 | undef_vars e1 l u1 -> 315 | undef_vars e2 l u2 -> undef_vars (APP e1 e2) l (u1 ++ u2). 316 | split; intros. 317 | inversion_clear H. 318 | inversion_clear H0. 319 | red in |- *; simpl in |- *; intros. 320 | elim In_app with name x u1 u2; intros; auto with coc core arith datatypes. 321 | apply H1 with x; auto with coc core arith datatypes. 322 | 323 | apply H with x; auto with coc core arith datatypes. 324 | 325 | inversion_clear H. 326 | inversion_clear H0. 327 | elim In_app with name x u1 u2; intros; auto with coc core arith datatypes. 328 | Qed. 329 | 330 | Lemma undef_vars_prod : 331 | forall (x : name) (e1 e2 : expr) (l u1 u2 : prt_names), 332 | undef_vars e1 l u1 -> 333 | undef_vars e2 (x :: l) u2 -> undef_vars (PROD x e1 e2) l (u1 ++ u2). 334 | split; intros. 335 | inversion_clear H. 336 | inversion_clear H0. 337 | red in |- *; simpl in |- *; intros. 338 | elim In_app with name x0 u1 u2; intros; auto with coc core arith datatypes. 339 | apply H1 with x0; auto with coc core arith datatypes. 340 | 341 | apply H with x0; auto with coc core arith datatypes. 342 | 343 | inversion_clear H. 344 | inversion_clear H0. 345 | elim In_app with name x0 u1 u2; intros; auto with coc core arith datatypes. 346 | apply ev_prod_r; auto with coc core arith datatypes. 347 | red in |- *; intros. 348 | apply H with x0; auto with coc core arith datatypes. 349 | rewrite H5; auto with coc core arith datatypes. 350 | Qed. 351 | 352 | 353 | 354 | Lemma equiv_no_undef : 355 | forall (l : prt_names) (t : term) (e : expr), 356 | term_expr_equiv l t e -> 357 | forall undef : prt_names, undef_vars e l undef -> undef = nil. 358 | simple induction 1; simple destruct undef; intros; 359 | auto with coc core arith datatypes. 360 | inversion_clear H0. 361 | cut (expr_vars n (SRT s)); intros; auto with coc core arith datatypes. 362 | inversion_clear H0. 363 | 364 | inversion_clear H1. 365 | elim H2 with n0; auto with coc core arith datatypes. 366 | cut (expr_vars n0 (REF x)); intros; auto with coc core arith datatypes. 367 | inversion_clear H1. 368 | elim H0; auto with coc core arith datatypes. 369 | 370 | inversion_clear H4. 371 | cut (expr_vars n (ABS x B N)); intros; auto with coc core arith datatypes. 372 | cut (n :: nil = nil); intros. 373 | discriminate H7. 374 | 375 | inversion_clear H4. 376 | apply H1. 377 | split; intros. 378 | red in |- *; simpl in |- *; intros. 379 | elim H5 with n; auto with coc core arith datatypes. 380 | generalize H4. 381 | inversion_clear H8; auto with coc core arith datatypes. 382 | inversion H9. 383 | 384 | generalize H7. 385 | inversion_clear H4; auto with coc core arith datatypes. 386 | inversion H8. 387 | 388 | apply H3. 389 | split; intros. 390 | red in |- *; simpl in |- *; intros. 391 | inversion H4. 392 | apply H7. 393 | elim H11. 394 | inversion_clear H9; auto with coc core arith datatypes. 395 | inversion H10. 396 | 397 | elim H5 with x0; auto with coc core arith datatypes. 398 | inversion_clear H9; auto with coc core arith datatypes. 399 | inversion H13. 400 | 401 | generalize H8. 402 | inversion_clear H4; auto with coc core arith datatypes. 403 | inversion H9. 404 | 405 | inversion_clear H4. 406 | cut (expr_vars n (APP a b)); intros; auto with coc core arith datatypes. 407 | cut (n :: nil = nil); intros. 408 | discriminate H7. 409 | 410 | inversion_clear H4. 411 | apply H1. 412 | split; intros. 413 | red in |- *; simpl in |- *; intros. 414 | elim H5 with n; auto with coc core arith datatypes. 415 | generalize H4. 416 | inversion_clear H8; auto with coc core arith datatypes. 417 | inversion H9. 418 | 419 | generalize H7. 420 | inversion_clear H4; auto with coc core arith datatypes. 421 | inversion H8. 422 | 423 | apply H3. 424 | split; intros. 425 | red in |- *; simpl in |- *; intros. 426 | elim H5 with n; auto with coc core arith datatypes. 427 | generalize H4. 428 | inversion_clear H8; auto with coc core arith datatypes. 429 | inversion H9. 430 | 431 | generalize H7. 432 | inversion_clear H4; auto with coc core arith datatypes. 433 | inversion H8. 434 | 435 | inversion_clear H4. 436 | cut (expr_vars n (PROD x B N)); intros; auto with coc core arith datatypes. 437 | cut (n :: nil = nil); intros. 438 | discriminate H7. 439 | 440 | inversion_clear H4. 441 | apply H1. 442 | split; intros. 443 | red in |- *; simpl in |- *; intros. 444 | elim H5 with n; auto with coc core arith datatypes. 445 | generalize H4. 446 | inversion_clear H8; auto with coc core arith datatypes. 447 | inversion H9. 448 | 449 | generalize H7. 450 | inversion_clear H4; auto with coc core arith datatypes. 451 | inversion H8. 452 | 453 | apply H3. 454 | split; intros. 455 | red in |- *; simpl in |- *; intros. 456 | inversion H4. 457 | apply H7. 458 | elim H11. 459 | inversion_clear H9; auto with coc core arith datatypes. 460 | inversion H10. 461 | 462 | elim H5 with x0; auto with coc core arith datatypes. 463 | inversion_clear H9; auto with coc core arith datatypes. 464 | inversion H13. 465 | 466 | generalize H8. 467 | inversion_clear H4; auto with coc core arith datatypes. 468 | inversion H9. 469 | Qed. 470 | 471 | 472 | Definition term_of_expr : 473 | forall (e : expr) (l : prt_names), 474 | {t : term | term_expr_equiv l t e} + 475 | {undef : prt_names | undef_vars e l undef & undef <> nil}. 476 | (*Realizer Fix term_of_expr 477 | {term_of_expr/1: expr->prt_names->(sum term prt_names) := 478 | [e:expr][l:prt_names]Cases e of 479 | (SRT s) => (inl term prt_names (Srt s)) 480 | | (REF x) => Cases (list_index name name_dec x l) of 481 | (inleft n) => (inl term prt_names (Ref n)) 482 | | inright => (inr term prt_names (cons x (nil name))) 483 | end 484 | | (ABS x e1 e2) => 485 | Cases (term_of_expr e1 l) (term_of_expr e2 (cons x l)) of 486 | (inl a) (inl m) => (inl term prt_names (Abs a m)) 487 | | (inr u1) (inr u2) => (inr term prt_names u1^u2) 488 | | (inr u) _ => (inr term prt_names u) 489 | | _ (inr u) => (inr term prt_names u) 490 | end 491 | | (APP e1 e2) => 492 | Cases (term_of_expr e1 l) (term_of_expr e2 l) of 493 | (inl u) (inl v) => (inl term prt_names (App u v)) 494 | | (inr u1) (inr u2) => (inr term prt_names u1^u2) 495 | | (inr u) _ => (inr term prt_names u) 496 | | _ (inr u) => (inr term prt_names u) 497 | end 498 | | (PROD x e1 e2) => 499 | Cases (term_of_expr e1 l) (term_of_expr e2 (cons x l)) of 500 | (inl a) (inl b) => (inl term prt_names (Prod a b)) 501 | | (inr u1) (inr u2) => (inr term prt_names u1^u2) 502 | | (inr u) _ => (inr term prt_names u) 503 | | _ (inr u) => (inr term prt_names u) 504 | end 505 | end}. 506 | *) 507 | simple induction e; intros. 508 | left. 509 | exists (Srt s). 510 | apply eqv_srt. 511 | 512 | elim (list_index _ name_dec n l); intros. 513 | left. 514 | inversion_clear a. 515 | exists (Ref x). 516 | apply eqv_ref; auto with coc core arith datatypes. 517 | 518 | right. 519 | exists (n :: nil). 520 | split. 521 | red in |- *; simpl in |- *; intros. 522 | generalize H. 523 | inversion_clear H0. 524 | intros. 525 | elim H0; intros; auto with coc core arith datatypes. 526 | 527 | inversion_clear H1. 528 | 529 | intros. 530 | inversion_clear H. 531 | apply ev_ref. 532 | 533 | inversion_clear H0. 534 | 535 | discriminate. 536 | 537 | elim H with l; intros. 538 | elim H0 with (n :: l); intros. 539 | left. 540 | inversion_clear a. 541 | inversion_clear a0. 542 | exists (Abs x x0). 543 | apply eqv_abs; auto with coc core arith datatypes. 544 | 545 | inversion_clear b. 546 | right. 547 | exists x. 548 | replace x with (nil ++ x); auto with coc core arith datatypes. 549 | apply undef_vars_abs; auto with coc core arith datatypes. 550 | split; intros. 551 | red in |- *; simpl in |- *; intros. 552 | inversion_clear H4. 553 | 554 | inversion_clear H3. 555 | 556 | auto with coc core arith datatypes. 557 | 558 | inversion_clear b. 559 | elim H0 with (n :: l); intros. 560 | right. 561 | exists x; auto with coc core arith datatypes. 562 | apply undef_vars_incl with (x ++ nil). 563 | red in |- *; simpl in |- *; intros. 564 | elim H3; simpl in |- *; auto with coc core arith datatypes. 565 | 566 | apply undef_vars_abs; auto with coc core arith datatypes. 567 | split; intros. 568 | red in |- *; simpl in |- *; intros. 569 | inversion_clear H4. 570 | 571 | inversion_clear H3. 572 | 573 | inversion_clear b. 574 | right. 575 | exists (x ++ x0); intros. 576 | apply undef_vars_abs; auto with coc core arith datatypes. 577 | 578 | generalize H2. 579 | case x; simpl in |- *; intros. 580 | elim H5; auto with coc core arith datatypes. 581 | 582 | discriminate. 583 | 584 | elim H with l; intros. 585 | elim H0 with l; intros. 586 | left. 587 | inversion_clear a. 588 | inversion_clear a0. 589 | exists (App x x0). 590 | apply eqv_app; auto with coc core arith datatypes. 591 | 592 | inversion_clear b. 593 | right. 594 | exists x. 595 | replace x with (nil ++ x); auto with coc core arith datatypes. 596 | apply undef_vars_app; auto with coc core arith datatypes. 597 | split; intros. 598 | red in |- *; simpl in |- *; intros. 599 | inversion H4. 600 | 601 | inversion H3. 602 | 603 | auto with coc core arith datatypes. 604 | 605 | inversion_clear b. 606 | elim H0 with l; intros. 607 | right. 608 | exists x; auto with coc core arith datatypes. 609 | apply undef_vars_incl with (x ++ nil). 610 | red in |- *; simpl in |- *; intros. 611 | elim H3; simpl in |- *; auto with coc core arith datatypes. 612 | 613 | apply undef_vars_app; auto with coc core arith datatypes. 614 | split; intros. 615 | red in |- *; simpl in |- *; intros. 616 | inversion_clear H4. 617 | 618 | inversion_clear H3. 619 | 620 | inversion_clear b. 621 | right. 622 | exists (x ++ x0); intros. 623 | apply undef_vars_app; auto with coc core arith datatypes. 624 | 625 | generalize H2. 626 | case x; simpl in |- *; intros. 627 | elim H5; auto with coc core arith datatypes. 628 | 629 | discriminate. 630 | 631 | elim H with l; intros. 632 | elim H0 with (n :: l); intros. 633 | left. 634 | inversion_clear a. 635 | inversion_clear a0. 636 | exists (Prod x x0). 637 | apply eqv_prod; auto with coc core arith datatypes. 638 | 639 | inversion_clear b. 640 | right. 641 | exists x. 642 | replace x with (nil ++ x); auto with coc core arith datatypes. 643 | apply undef_vars_prod; auto with coc core arith datatypes. 644 | split; intros. 645 | red in |- *; simpl in |- *; intros. 646 | inversion H4. 647 | 648 | inversion H3. 649 | 650 | auto with coc core arith datatypes. 651 | 652 | inversion_clear b. 653 | elim H0 with (n :: l); intros. 654 | right. 655 | exists x; auto with coc core arith datatypes. 656 | apply undef_vars_incl with (x ++ nil). 657 | red in |- *; simpl in |- *; intros. 658 | elim H3; simpl in |- *; auto with coc core arith datatypes. 659 | 660 | apply undef_vars_prod; auto with coc core arith datatypes. 661 | split; intros. 662 | red in |- *; simpl in |- *; intros. 663 | inversion H4. 664 | 665 | inversion H3. 666 | 667 | inversion_clear b. 668 | right. 669 | exists (x ++ x0); intros. 670 | apply undef_vars_prod; auto with coc core arith datatypes. 671 | 672 | generalize H2. 673 | case x; simpl in |- *; intros. 674 | elim H5; auto with coc core arith datatypes. 675 | 676 | discriminate. 677 | Defined. 678 | -------------------------------------------------------------------------------- /theories/ImpVar.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | Implicit Types i k m n p : nat. 18 | Implicit Type s : sort. 19 | Implicit Types A B M N T t u v : term. 20 | Implicit Types e f g : env. -------------------------------------------------------------------------------- /theories/Infer.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Termes. 19 | Require Import Conv. 20 | Require Import Types. 21 | Require Import Strong_Norm. 22 | Require Import Conv_Dec. 23 | 24 | Load "ImpVar". 25 | 26 | Definition red_to_sort : 27 | forall t, 28 | sn t -> {s : sort | red t (Srt s)} + {(forall s, ~ conv t (Srt s))}. 29 | intros t snt. 30 | elim compute_nf with (1 := snt); intros [s| n| T b| u v| T U] redt nt. 31 | left. 32 | exists s; trivial. 33 | 34 | right; red in |- *; intros. 35 | elim church_rosser with (Srt s) (Ref n); intros. 36 | generalize H0. 37 | elim (red_normal (Ref n) x); auto with coc; intros. 38 | apply red_sort_sort with s (Ref n); auto with coc. 39 | discriminate. 40 | 41 | apply trans_conv_conv with t; auto with coc. 42 | 43 | right; red in |- *; intros. 44 | elim church_rosser with (Srt s) (Abs T b); intros. 45 | generalize H0. 46 | elim (red_normal (Abs T b) x); auto with coc; intros. 47 | apply red_sort_sort with s (Abs T b); auto with coc. 48 | discriminate. 49 | 50 | apply trans_conv_conv with t; auto with coc. 51 | 52 | right; red in |- *; intros. 53 | elim church_rosser with (Srt s) (App u v); intros. 54 | generalize H0. 55 | elim (red_normal (App u v) x); auto with coc; intros. 56 | apply red_sort_sort with s (App u v); auto with coc. 57 | discriminate. 58 | 59 | apply trans_conv_conv with t; auto with coc. 60 | 61 | right; red in |- *; intros. 62 | elim church_rosser with (Srt s) (Prod T U); intros. 63 | generalize H0. 64 | elim (red_normal (Prod T U) x); auto with coc; intros. 65 | apply red_sort_sort with s (Prod T U); auto with coc. 66 | discriminate. 67 | 68 | apply trans_conv_conv with t; auto with coc. 69 | Defined. 70 | 71 | 72 | Definition red_to_prod : 73 | forall t, 74 | sn t -> 75 | {p : term * term | match p with 76 | | (u, v) => red t (Prod u v) 77 | end} + {(forall u v, ~ conv t (Prod u v))}. 78 | intros t snt. 79 | elim compute_nf with (1 := snt); intros [s| n| T b| u v| T U] redt nt. 80 | right; red in |- *; intros. 81 | elim church_rosser with (Prod u v) (Srt s); intros. 82 | generalize H0. 83 | elim (red_normal (Srt s) x); auto with coc; intros. 84 | apply red_prod_prod with u v (Srt s); auto with coc; intros. 85 | discriminate H3. 86 | 87 | apply trans_conv_conv with t; auto with coc. 88 | 89 | right; red in |- *; intros. 90 | elim church_rosser with (Prod u v) (Ref n); intros. 91 | generalize H0. 92 | elim (red_normal (Ref n) x); auto with coc; intros. 93 | apply red_prod_prod with u v (Ref n); auto with coc; intros. 94 | discriminate H3. 95 | 96 | apply trans_conv_conv with t; auto with coc. 97 | 98 | right; red in |- *; intros. 99 | elim church_rosser with (Prod u v) (Abs T b); intros. 100 | generalize H0. 101 | elim (red_normal (Abs T b) x); auto with coc; intros. 102 | apply red_prod_prod with u v (Abs T b); auto with coc; intros. 103 | discriminate H3. 104 | 105 | apply trans_conv_conv with t; auto with coc. 106 | 107 | right; red in |- *; intros. 108 | elim church_rosser with (Prod u0 v0) (App u v); intros. 109 | generalize H0. 110 | elim (red_normal (App u v) x); auto with coc; intros. 111 | apply red_prod_prod with u0 v0 (App u v); auto with coc; intros. 112 | discriminate H3. 113 | 114 | apply trans_conv_conv with t; auto with coc. 115 | 116 | left; exists (T, U); trivial. 117 | Defined. 118 | 119 | Section TypeChecker. 120 | 121 | 122 | Inductive type_error : Set := 123 | | Under : term -> type_error -> type_error 124 | | Expected_type : term -> term -> term -> type_error 125 | | Kind_ill_typed : type_error 126 | | Db_error : nat -> type_error 127 | | Lambda_kind : term -> type_error 128 | | Not_a_type : term -> term -> type_error 129 | | Not_a_fun : term -> term -> type_error 130 | | Apply_err : term -> term -> term -> term -> type_error. 131 | 132 | 133 | (* meaning of errors *) 134 | Inductive expln : env -> type_error -> Prop := 135 | | Exp_under : 136 | forall e t (err : type_error), 137 | expln (t :: e) err -> expln e (Under t err) 138 | | Exp_exp_type : 139 | forall e (m at_ et : term), 140 | typ e m at_ -> 141 | ~ typ e m et -> 142 | free_db (length e) et -> expln e (Expected_type m at_ et) 143 | | Exp_kind : 144 | forall e, 145 | wf e -> (forall t, ~ typ e (Srt kind) t) -> expln e Kind_ill_typed 146 | | Exp_db : forall e n, wf e -> length e <= n -> expln e (Db_error n) 147 | | Exp_lam_kind : 148 | forall e (m : term) t, 149 | typ (t :: e) m (Srt kind) -> expln e (Lambda_kind (Abs t m)) 150 | | Exp_type : 151 | forall e (m : term) t, 152 | typ e m t -> 153 | (forall s, ~ typ e m (Srt s)) -> expln e (Not_a_type m t) 154 | | Exp_fun : 155 | forall e (m : term) t, 156 | typ e m t -> 157 | (forall a b : term, ~ typ e m (Prod a b)) -> expln e (Not_a_fun m t) 158 | | Exp_appl_err : 159 | forall e u v (a b tv : term), 160 | typ e u (Prod a b) -> 161 | typ e v tv -> ~ typ e v a -> expln e (Apply_err u (Prod a b) v tv). 162 | 163 | Hint Resolve Exp_under Exp_exp_type Exp_kind Exp_db Exp_lam_kind Exp_type 164 | Exp_fun Exp_appl_err: coc. 165 | 166 | Lemma expln_wf : forall e (err : type_error), expln e err -> wf e. 167 | simple induction 1; intros; auto with coc arith. 168 | inversion_clear H1. 169 | apply typ_wf with t (Srt s); auto with coc arith. 170 | 171 | apply typ_wf with m at_; auto with coc arith. 172 | 173 | cut (wf (t :: e0)); intros. 174 | inversion_clear H1. 175 | apply typ_wf with t (Srt s); auto with coc arith. 176 | 177 | apply typ_wf with m (Srt kind); auto with coc arith. 178 | 179 | apply typ_wf with m t; auto with coc arith. 180 | 181 | apply typ_wf with m t; auto with coc arith. 182 | 183 | apply typ_wf with v tv; auto with coc arith. 184 | Qed. 185 | 186 | Inductive inf_error : term -> type_error -> Prop := 187 | | Infe_subt : 188 | forall (m n : term) (err : type_error), 189 | subt_nobind m n -> inf_error m err -> inf_error n err 190 | | Infe_under : 191 | forall (m n : term) T (err : type_error), 192 | subt_bind T m n -> inf_error m err -> inf_error n (Under T err) 193 | | Infe_kind : inf_error (Srt kind) Kind_ill_typed 194 | | Infe_db : forall n, inf_error (Ref n) (Db_error n) 195 | | Infe_lam_kind : forall M T, inf_error (Abs T M) (Lambda_kind (Abs T M)) 196 | | Infe_type_abs : 197 | forall (m n : term) t, inf_error (Abs m n) (Not_a_type m t) 198 | | Infe_fun : forall (m n : term) t, inf_error (App m n) (Not_a_fun m t) 199 | | Infe_appl_err : 200 | forall m n tf ta : term, inf_error (App m n) (Apply_err m tf n ta) 201 | | Infe_type_prod_l : 202 | forall (m n : term) t, inf_error (Prod m n) (Not_a_type m t) 203 | | Infe_type_prod_r : 204 | forall (m n : term) t, 205 | inf_error (Prod m n) (Under m (Not_a_type n t)). 206 | 207 | Hint Resolve Infe_kind Infe_db Infe_lam_kind Infe_type_abs Infe_fun 208 | Infe_appl_err Infe_type_prod_l Infe_type_prod_r: coc. 209 | 210 | 211 | Lemma inf_error_no_type : 212 | forall (m : term) (err : type_error), 213 | inf_error m err -> forall e, expln e err -> forall t, ~ typ e m t. 214 | simple induction 1; intros. 215 | inversion_clear H0; red in |- *; intros. 216 | apply inv_typ_abs with e m0 n0 t; intros; auto with coc arith. 217 | elim H2 with e (Srt s1); auto with coc arith. 218 | 219 | apply inv_typ_app with e m0 v t; intros; auto with coc arith. 220 | elim H2 with e (Prod V Ur); auto with coc arith. 221 | 222 | apply inv_typ_app with e u m0 t; intros; auto with coc arith. 223 | elim H2 with e V; auto with coc arith. 224 | 225 | apply inv_typ_prod with e m0 n0 t; intros; auto with coc arith. 226 | elim H2 with e (Srt s1); auto with coc arith. 227 | 228 | inversion_clear H3. 229 | inversion_clear H0; red in |- *; intros. 230 | apply inv_typ_abs with e T m0 t; intros; auto with coc arith. 231 | elim H2 with (T :: e) T0; auto with coc arith. 232 | 233 | apply inv_typ_prod with e T m0 t; intros; auto with coc arith. 234 | elim H2 with (T :: e) (Srt s2); auto with coc arith. 235 | 236 | inversion_clear H0; auto with coc arith. 237 | 238 | red in |- *; intros. 239 | apply inv_typ_ref with e t n; intros; auto with coc arith. 240 | inversion_clear H0. 241 | generalize H5. 242 | elim H2; simpl in |- *; intros; auto with coc arith. 243 | inversion_clear H0. 244 | 245 | inversion_clear H0. 246 | red in |- *; intros. 247 | apply inv_typ_abs with e T M t; intros; auto with coc arith. 248 | elim inv_typ_conv_kind with (T :: e) T0 (Srt s2); auto with coc arith. 249 | apply typ_unique with (T :: e) M; auto with coc arith. 250 | 251 | inversion_clear H0. 252 | red in |- *; intros. 253 | apply inv_typ_abs with e m0 n t0; intros; auto with coc arith. 254 | elim H2 with s1; auto with coc arith. 255 | 256 | inversion_clear H0. 257 | red in |- *; intros. 258 | apply inv_typ_app with e m0 n t0; intros; auto with coc arith. 259 | elim H2 with V Ur; auto with coc arith. 260 | 261 | inversion_clear H0. 262 | red in |- *; intros. 263 | apply inv_typ_app with e m0 n t; intros; auto with coc arith. 264 | elim type_case with e m0 (Prod a b); intros; auto with coc arith. 265 | inversion_clear H7. 266 | apply inv_typ_prod with e a b (Srt x); intros; auto with coc arith. 267 | apply H3. 268 | apply type_conv with V s1; auto with coc arith. 269 | apply inv_conv_prod_l with Ur b. 270 | apply typ_unique with e m0; auto with coc arith. 271 | 272 | discriminate H7. 273 | 274 | inversion_clear H0. 275 | red in |- *; intros. 276 | apply inv_typ_prod with e m0 n t0; intros; auto with coc arith. 277 | elim H2 with s1; auto with coc arith. 278 | 279 | inversion_clear H0. 280 | inversion_clear H1. 281 | red in |- *; intros. 282 | apply inv_typ_prod with e m0 n t0; intros; auto with coc arith. 283 | elim H2 with s2; auto with coc arith. 284 | Qed. 285 | 286 | 287 | Definition infer : 288 | forall e t, 289 | wf e -> 290 | {T : term | typ e t T} + 291 | {err : type_error | expln e err & inf_error t err}. 292 | (*Realizer [e:env][m:term] 293 | (Fix inf_rec {inf_rec/1: term->env->(sum term ty_err) := 294 | [m:term][e:env]Cases m of 295 | (Srt kind) => (fail (Ill_typed (Srt kind))) 296 | | (Srt prop) => (ok (Srt kind)) 297 | | (Ref n) => Cases (list_item term e n) of 298 | (inleft T) => (ok (lift (S n) T)) 299 | | _ => (fail (Ill_typed (Ref n))) 300 | end 301 | | (Abs t b) => Cases (inf_rec t e) of 302 | (inl T) => Cases (red_to_sort T) 303 | (inf_rec b (cons t e)) of 304 | (inleft _) (inl B) => if (eqterm (Srt kind) B) 305 | then (fail (Topsorted b)) 306 | else (ok (Prod t B)) 307 | | inright _ => (fail (Not_a_type t)) 308 | | (inleft _) (inr err) => (bind t err) 309 | end 310 | | (inr err) =>(inr term ? err) 311 | end 312 | | (App t b) => Cases (inf_rec t e) of 313 | (inl T) => Cases (red_to_prod T) of 314 | (inleft (V,Ur)) => Cases (inf_rec b e) of 315 | (inl B) => if (is_conv V B) 316 | then (ok (subst b Ur)) 317 | else (fail (Expected_type b B V)) 318 | | (inr err) => (inr term ? err) 319 | end 320 | | _ => (fail (Not_a_fun t T)) 321 | end 322 | | (inr err) => (inr term ? err) 323 | end 324 | | (Prod t b) => Cases (inf_rec t e) of 325 | (inl T) => Cases (red_to_sort T) 326 | (inf_rec b (cons t e)) of 327 | (inleft _) (inl B) => Cases (red_to_sort B) of 328 | (inleft s) => (ok (Srt s)) 329 | | _ =>(fail (Not_a_type b)) 330 | end 331 | | inright _ => (fail (Not_a_type t)) 332 | | (inleft _) (inr err) => (bind t err) 333 | end 334 | | (inr err) => (inr term ? err) 335 | end 336 | end} m e). 337 | *) 338 | do 2 intro. 339 | generalize t e. 340 | clear e t. 341 | fix infer 1. 342 | intros t e wfe. 343 | case t. 344 | simple destruct s. 345 | right. 346 | exists Kind_ill_typed; auto with coc arith. 347 | apply Exp_kind; intros; auto with coc arith. 348 | apply inv_typ_kind. 349 | 350 | left. 351 | exists (Srt kind). 352 | apply type_prop; auto with coc arith. 353 | 354 | left. 355 | exists (Srt kind). 356 | apply type_set; auto with coc arith. 357 | 358 | intros. 359 | generalize (list_item term e n); intros [(T, H0)| b]. 360 | left. 361 | exists (lift (S n) T). 362 | apply type_var; auto with coc arith. 363 | exists T; auto with coc arith. 364 | 365 | right. 366 | exists (Db_error n); auto with coc arith. 367 | apply Exp_db; auto with coc arith. 368 | generalize n b. 369 | elim e; simpl in |- *; auto with coc arith. 370 | simple destruct n0; intros. 371 | elim b0 with a; auto with coc arith. 372 | 373 | cut (length l <= n1); auto with coc arith. 374 | apply H. 375 | red in |- *; intros. 376 | elim b0 with t0; auto with coc arith. 377 | 378 | intros a b. 379 | elim (infer a e); trivial with coc arith. 380 | intros (T, ty_a). 381 | elim (red_to_sort T); trivial with coc arith. 382 | intros (s, srt_T). 383 | cut (wf (a :: e)); intros. 384 | elim (infer b (a :: e)); trivial with coc arith. 385 | intros (B, ty_b). 386 | elim (eqterm (Srt kind) B). 387 | intro eq_kind. 388 | right. 389 | exists (Lambda_kind (Abs a b)); auto with coc arith. 390 | apply Exp_lam_kind; auto with coc arith. 391 | rewrite eq_kind; auto with coc arith. 392 | 393 | intro not_kind. 394 | left. 395 | exists (Prod a B). 396 | elim type_case with (1 := ty_b). 397 | intros (s2, knd_b). 398 | apply type_abs with s s2; auto with coc arith. 399 | apply type_reduction with T; auto with coc arith. 400 | 401 | intros; elim not_kind; auto. 402 | 403 | intros (err, expl_err, inf_err). 404 | right. 405 | exists (Under a err); auto with coc arith. 406 | apply Infe_under with b; auto with coc arith. 407 | 408 | apply wf_var with s. 409 | apply type_reduction with T; auto with coc arith. 410 | 411 | intro not_type. 412 | right. 413 | exists (Not_a_type a T); auto with coc arith. 414 | apply Exp_type; auto with coc arith. 415 | red in |- *; intros. 416 | elim not_type with s. 417 | apply typ_unique with e a; auto with coc arith. 418 | 419 | apply type_sn with e a; auto with coc arith. 420 | 421 | intros (err, expl_err, inf_err). 422 | right. 423 | exists err; auto with coc arith. 424 | apply Infe_subt with a; auto with coc arith. 425 | 426 | intros u v. 427 | elim infer with u e; trivial with coc arith. 428 | intros (T, ty_u). 429 | elim red_to_prod with T. 430 | intros ((V, Ur), red_prod). 431 | cut (typ e u (Prod V Ur)); intros. 432 | elim infer with v e; trivial with coc arith. 433 | intros (B, ty_v). 434 | elim is_conv with V B. 435 | intros domain_conv. 436 | left. 437 | exists (subst v Ur). 438 | apply type_app with V; auto with coc arith. 439 | elim type_case with e u (Prod V Ur); auto with coc arith. 440 | intros (s, ty_prod). 441 | apply inv_typ_prod with (1 := ty_prod); auto with coc arith; intros. 442 | apply type_conv with B s1; auto with coc arith. 443 | 444 | intro not_prod; discriminate not_prod. 445 | 446 | intro dom_not_conv. 447 | right. 448 | exists (Apply_err u (Prod V Ur) v B); auto with coc arith. 449 | apply Exp_appl_err; auto with coc arith. 450 | red in |- *; intros. 451 | apply dom_not_conv. 452 | apply typ_unique with e v; auto with coc arith. 453 | 454 | apply subterm_sn with (Prod V Ur); auto with coc arith. 455 | apply sn_red_sn with T; auto with coc arith. 456 | apply type_sn with e u; auto with coc arith. 457 | 458 | apply type_sn with e v; auto with coc arith. 459 | 460 | intros (err, expl_err, inf_err). 461 | right. 462 | exists err; auto with coc arith. 463 | apply Infe_subt with v; auto with coc arith. 464 | 465 | apply type_reduction with T; auto with coc arith. 466 | 467 | intros not_prod. 468 | right. 469 | exists (Not_a_fun u T); auto with coc arith. 470 | apply Exp_fun; auto with coc arith. 471 | red in |- *; intros. 472 | elim not_prod with a b. 473 | apply typ_unique with e u; auto with coc arith. 474 | 475 | apply type_sn with e u; auto with coc arith. 476 | 477 | intros (err, expl_err, inf_err). 478 | right. 479 | exists err; auto with coc arith. 480 | apply Infe_subt with u; auto with coc arith. 481 | 482 | intros a b. 483 | elim infer with a e; trivial with coc arith. 484 | intros (T, ty_a). 485 | elim red_to_sort with T. 486 | intros (s, red_sort). 487 | cut (wf (a :: e)); intros. 488 | elim infer with b (a :: e); trivial with coc arith. 489 | intros (B, ty_b). 490 | elim red_to_sort with B. 491 | intros (s2, red_s2). 492 | left. 493 | exists (Srt s2). 494 | apply type_prod with s; auto with coc arith. 495 | apply type_reduction with T; auto with coc arith. 496 | 497 | apply type_reduction with B; auto with coc arith. 498 | 499 | intros b_not_type. 500 | right. 501 | exists (Under a (Not_a_type b B)); auto with coc arith. 502 | apply Exp_under; auto with coc arith. 503 | apply Exp_type; auto with coc arith. 504 | red in |- *; intros. 505 | elim b_not_type with s0. 506 | apply typ_unique with (a :: e) b; auto with coc arith. 507 | 508 | apply type_sn with (a :: e) b; auto with coc arith. 509 | 510 | intros (err, expl_err, inf_err). 511 | right. 512 | exists (Under a err); auto with coc arith. 513 | apply Infe_under with b; auto with coc arith. 514 | 515 | apply wf_var with s. 516 | apply type_reduction with T; auto with coc arith. 517 | 518 | intros a_not_type. 519 | right. 520 | exists (Not_a_type a T); auto with coc arith. 521 | apply Exp_type; auto with coc arith. 522 | red in |- *; intros. 523 | elim a_not_type with s. 524 | apply typ_unique with e a; auto with coc arith. 525 | 526 | apply type_sn with e a; auto with coc arith. 527 | 528 | intros (err, expl_err, inf_err). 529 | right. 530 | exists err; auto with coc arith. 531 | apply Infe_subt with a; auto with coc arith. 532 | Defined. 533 | 534 | 535 | 536 | Inductive chk_error (m : term) t : type_error -> Prop := 537 | | Chke_subj : 538 | forall err : type_error, inf_error m err -> chk_error m t err 539 | | Chke_type : 540 | forall err : type_error, 541 | inf_error t err -> t <> Srt kind -> chk_error m t err 542 | | Chke_exp : forall at_ : term, chk_error m t (Expected_type m at_ t). 543 | 544 | Hint Resolve Chke_subj Chke_type Chke_exp: coc. 545 | 546 | 547 | Lemma chk_error_no_type : 548 | forall e (m : term) t (err : type_error), 549 | chk_error m t err -> expln e err -> ~ typ e m t. 550 | simple destruct 1; intros. 551 | apply inf_error_no_type with err0; auto with coc arith. 552 | 553 | red in |- *; intros. 554 | elim type_case with e m t; intros; auto with coc arith. 555 | inversion_clear H4. 556 | elim inf_error_no_type with t err0 e (Srt x); auto with coc arith. 557 | 558 | inversion_clear H0; auto with coc arith. 559 | Qed. 560 | 561 | 562 | Definition check_typ : 563 | forall e t (tp : term), 564 | wf e -> 565 | {err : type_error | expln e err & chk_error t tp err} + {typ e t tp}. 566 | (* 567 | Realizer [e:env][t,tp:term] 568 | Cases (infer e t) (eqterm (Srt kind) tp) of 569 | (inl tp') inleft => if (eqterm (Srt kind) tp') 570 | then (inright type_error) 571 | else (inleft ? (fail t (nil ?) 572 | (Expected_type t tp' (Srt kind)))) 573 | | (inl tp') inright => Cases (infer e tp) of 574 | (inl k) => if (is_conv tp tp') 575 | then (inright type_error) 576 | else (inleft ? (fail t (nil ?) 577 | (Expected_type t tp' tp))) 578 | | (inr err) => (inleft type_error err) 579 | end 580 | | (inr err) _ => (inleft type_error err) 581 | end. 582 | *) 583 | intros. 584 | elim infer with e t; auto with coc arith. 585 | intros (tp', typ_t). 586 | elim eqterm with (Srt kind) tp. 587 | intros cast_kind. 588 | elim eqterm with (Srt kind) tp'. 589 | intros inf_kind. 590 | right. 591 | elim cast_kind; rewrite inf_kind; trivial. 592 | 593 | intros inf_not_kind. 594 | left. 595 | exists (Expected_type t tp' tp); auto with coc. 596 | apply Exp_exp_type; auto with coc arith. 597 | red in |- *; intros; apply inf_not_kind. 598 | symmetry in |- *. 599 | apply type_kind_not_conv with e t; auto with coc arith. 600 | rewrite cast_kind; trivial. 601 | 602 | elim cast_kind; auto with coc. 603 | 604 | intros cast_not_kind. 605 | elim infer with e tp; auto with coc. 606 | intros (k, ty_tp). 607 | elim is_conv with tp tp'. 608 | intros cast_ok. 609 | right. 610 | elim red_to_sort with k; auto with coc. 611 | intros (s, red_sort). 612 | apply type_conv with tp' s; auto with coc. 613 | apply type_reduction with k; auto with coc. 614 | 615 | intros not_sort. 616 | elim type_case with (1 := typ_t). 617 | intros (s, kind_inf). 618 | elim not_sort with s. 619 | apply typ_conv_conv with e tp tp'; auto with coc arith. 620 | 621 | intros is_kind. 622 | elim inv_typ_conv_kind with e tp k; auto with coc arith. 623 | elim is_kind; auto with coc arith. 624 | 625 | apply type_sn with e tp; auto with coc arith. 626 | 627 | intros cast_err. 628 | left. 629 | exists (Expected_type t tp' tp); auto with coc arith. 630 | apply Exp_exp_type; auto with coc arith. 631 | red in |- *; intros; apply cast_err; apply typ_unique with e t; 632 | auto with coc arith. 633 | 634 | apply typ_free_db with k; auto with coc arith. 635 | 636 | apply str_norm with e k; auto with coc arith. 637 | 638 | apply type_sn with e t; auto with coc arith. 639 | 640 | intros (err, expl_err, inf_err). 641 | left. 642 | exists err; auto with coc arith. 643 | 644 | intros (err, expl_err, inf_err). 645 | left. 646 | exists err; auto with coc arith. 647 | Defined. 648 | 649 | 650 | 651 | Inductive decl_error (m : term) : type_error -> Prop := 652 | | Decax_ill : 653 | forall err : type_error, inf_error m err -> decl_error m err 654 | | Decax_type : forall t, decl_error m (Not_a_type m t). 655 | 656 | Hint Resolve Decax_ill Decax_type: coc. 657 | 658 | 659 | Lemma decl_err_not_wf : 660 | forall e t (err : type_error), 661 | decl_error t err -> expln e err -> ~ wf (t :: e). 662 | red in |- *. 663 | simple destruct 1; intros. 664 | inversion_clear H2. 665 | elim inf_error_no_type with t err0 e (Srt s); auto with coc arith. 666 | 667 | inversion_clear H0. 668 | inversion_clear H1. 669 | elim H3 with s; auto with coc arith. 670 | Qed. 671 | 672 | 673 | Definition add_typ : 674 | forall e t, 675 | wf e -> 676 | {err : type_error | expln e err & decl_error t err} + {wf (t :: e)}. 677 | intros. 678 | elim infer with e t; auto with coc. 679 | intros (T, typ_t). 680 | elim red_to_sort with T. 681 | intros (s, red_sort). 682 | right. 683 | apply wf_var with s. 684 | apply type_reduction with T; auto with coc. 685 | 686 | intros not_sort. 687 | left. 688 | exists (Not_a_type t T); auto with coc. 689 | apply Exp_type; auto with coc. 690 | red in |- *; intros. 691 | elim not_sort with s. 692 | apply typ_unique with e t; auto with coc. 693 | 694 | apply type_sn with e t; auto with coc. 695 | 696 | intros (err, expl_err, inf_err). 697 | left. 698 | exists err; auto with coc arith. 699 | Defined. 700 | 701 | 702 | End TypeChecker. 703 | 704 | Section Decidabilite_typage. 705 | 706 | Lemma decide_wf : forall e, {wf e} + {~ wf e}. 707 | simple induction e; intros. 708 | left. 709 | apply wf_nil. 710 | 711 | elim H. 712 | intros wf_l. 713 | elim add_typ with l a; trivial. 714 | intros (err, expl_err, decl_err). 715 | right. 716 | apply decl_err_not_wf with (1 := decl_err) (2 := expl_err). 717 | 718 | left; trivial. 719 | 720 | intros not_wf_l. 721 | right; red in |- *; intros. 722 | apply not_wf_l. 723 | inversion_clear H0. 724 | apply typ_wf with (1 := H1). 725 | Qed. 726 | 727 | 728 | Lemma decide_typ : forall e t (tp : term), {typ e t tp} + {~ typ e t tp}. 729 | intros. 730 | elim decide_wf with e. 731 | intros wf_e. 732 | elim check_typ with e t tp; trivial. 733 | intros (err, expl_err, chk_err). 734 | right. 735 | apply chk_error_no_type with (1 := chk_err) (2 := expl_err). 736 | 737 | left; trivial. 738 | 739 | intros not_wf_e. 740 | right; red in |- *; intros. 741 | apply not_wf_e. 742 | apply typ_wf with (1 := H). 743 | Qed. 744 | 745 | End Decidabilite_typage. 746 | -------------------------------------------------------------------------------- /theories/Int_term.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Termes. 19 | 20 | Definition intt := nat -> term. 21 | 22 | Definition shift_intt (i : intt) (t : term) : intt := 23 | fun n : nat => match n with 24 | | O => t 25 | | S k => i k 26 | end. 27 | 28 | 29 | Fixpoint int_term (t : term) : intt -> nat -> term := 30 | fun (I : intt) (k : nat) => 31 | match t with 32 | | Srt s => Srt s 33 | | Ref n => 34 | match le_gt_dec k n with 35 | | left _ => lift k (I (n - k)) 36 | | right _ => Ref n 37 | end 38 | | Abs A t => Abs (int_term A I k) (int_term t I (S k)) 39 | | App u v => App (int_term u I k) (int_term v I k) 40 | | Prod A B => Prod (int_term A I k) (int_term B I (S k)) 41 | end. 42 | 43 | Opaque le_gt_dec. 44 | 45 | Lemma int_term_subst : 46 | forall (t : term) (it : intt) (k : nat) (x : term), 47 | subst_rec x (int_term t it (S k)) k = int_term t (shift_intt it x) k. 48 | simple induction t; simpl in |- *; intros; auto with coc core arith sets. 49 | elim (le_gt_dec (S k) n); intros. 50 | elim (le_gt_dec k n); intros. 51 | rewrite simpl_subst; auto with coc core arith sets. 52 | replace (n - k) with (S (n - S k)); auto with coc core arith sets. 53 | lia. 54 | 55 | elim (lt_eq_lt_dec k n); [ intro Hlt_eq | intro Hlt ]. 56 | elim Hlt_eq; clear Hlt_eq. lia. 57 | 58 | intros ?; subst. 59 | replace (n - n) with 0; auto with coc core arith sets. simpl. 60 | elim (le_gt_dec n n); [ intro Hle | intro Hgt ]; 61 | auto with coc core arith sets; try lia. 62 | elim (lt_eq_lt_dec n n); [|]; 63 | auto with coc core arith sets; try lia. 64 | intuition lia. 65 | elim (le_gt_dec k n); intros; auto with coc core arith sets; [lia|]. 66 | simpl. 67 | elim (lt_eq_lt_dec k n); try intuition lia. 68 | 69 | rewrite H; rewrite H0; auto with coc core arith sets. 70 | 71 | rewrite H; rewrite H0; auto with coc core arith sets. 72 | 73 | rewrite H; rewrite H0; auto with coc core arith sets. 74 | Qed. 75 | -------------------------------------------------------------------------------- /theories/Int_typ.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Termes. 19 | Require Import Conv. 20 | Require Import Types. 21 | Require Import Class. 22 | Require Import Can. 23 | 24 | (* Interpretations des variables de type *) 25 | 26 | Inductive Int_K : Type := 27 | | iK : forall s : skel, Can s -> Int_K 28 | | iT : Int_K. 29 | 30 | Definition intP := TList Int_K. 31 | 32 | 33 | Definition class_of_ik (ik : Int_K) := 34 | match ik with 35 | | iK s _ => Knd s 36 | | iT => Typ PROP 37 | end. 38 | 39 | 40 | 41 | Definition cls_of_int : intP -> cls := Tmap _ _ class_of_ik. 42 | 43 | 44 | Definition ext_ik (T : term) (ip : intP) (s : skel) 45 | (C : Can s) := 46 | match cl_term T (cls_of_int ip) with 47 | | Knd _ => iK s C 48 | | _ => iT 49 | end. 50 | 51 | 52 | Definition int_cons (T : term) (ip : intP) (s : skel) 53 | (C : Can s) := TCs _ (ext_ik T ip s C) ip. 54 | 55 | 56 | Definition def_cons (T : term) (I : intP) : intP := 57 | int_cons T I _ (default_can (cv_skel (cl_term T (cls_of_int I)))). 58 | 59 | 60 | 61 | 62 | Definition skel_int (t : term) (I : intP) := 63 | typ_skel (cl_term t (cls_of_int I)). 64 | 65 | 66 | Lemma ins_in_cls : 67 | forall (c : class) (y : Int_K) (k : nat) (ipe ipf : intP), 68 | class_of_ik y = c -> 69 | TIns Int_K y k ipe ipf -> TIns _ c k (cls_of_int ipe) (cls_of_int ipf). 70 | unfold cls_of_int in |- *. 71 | simple induction 1. 72 | simple induction 1; simpl in |- *; auto with coc core arith datatypes. 73 | Qed. 74 | 75 | 76 | 77 | Definition coerce_CR (s : skel) (i : Int_K) : Can s := 78 | match i with 79 | | iK si Ci => 80 | match EQ_skel si s with 81 | | left y => 82 | match y in (_ = x) return (Can x) with 83 | | refl_equal => Ci 84 | end 85 | | _ => default_can s 86 | end 87 | | _ => default_can s 88 | end. 89 | 90 | Lemma is_can_coerce : 91 | forall s s' C, is_can s C -> is_can s' (coerce_CR s' (iK s C)). 92 | Proof. 93 | simpl in |- *; intros. 94 | elim (EQ_skel s s'); intros; auto with coc. 95 | case a; trivial. 96 | Qed. 97 | 98 | Hint Resolve is_can_coerce: coc. 99 | 100 | 101 | Lemma extr_eq : 102 | forall (P : forall s : skel, Can s -> Prop) (s : skel) (c : Can s), 103 | P s c -> P s (coerce_CR s (iK s c)). 104 | Proof. 105 | intros. 106 | unfold coerce_CR in |- *. 107 | elim (EQ_skel s s). 108 | intro Heq. 109 | change 110 | ((fun s0 (e : s = s0) => 111 | P s0 match e in (_ = x) return (Can x) with 112 | | refl_equal => c 113 | end) s Heq) in |- *. 114 | case Heq; trivial. 115 | 116 | simple induction 1; auto with coc core arith datatypes. 117 | Qed. 118 | 119 | 120 | Lemma eq_can_extr : 121 | forall (s si : skel) (X Y : Can s), 122 | eq_can s X Y -> eq_can si (coerce_CR si (iK s X)) (coerce_CR si (iK s Y)). 123 | unfold coerce_CR in |- *. 124 | intros. 125 | elim (EQ_skel s si); auto with coc core arith datatypes. 126 | intro Heq; case Heq; auto with coc core arith datatypes. 127 | Qed. 128 | 129 | Hint Resolve eq_can_extr: coc. 130 | 131 | 132 | 133 | 134 | Inductive ik_eq : Int_K -> Int_K -> Prop := 135 | | eqi_K : 136 | forall (s : skel) (X Y : Can s), 137 | eq_can s X X -> 138 | eq_can s Y Y -> eq_can s X Y -> ik_eq (iK s X) (iK s Y) 139 | | eqi_T : ik_eq iT iT. 140 | 141 | Hint Resolve eqi_K eqi_T: coc. 142 | 143 | Lemma iki_K : 144 | forall (s : skel) (C : Can s), eq_can s C C -> ik_eq (iK s C) (iK s C). 145 | auto with coc core arith datatypes. 146 | Qed. 147 | 148 | Hint Resolve iki_K: coc. 149 | 150 | 151 | 152 | 153 | Definition int_eq_can : intP -> intP -> Prop := Tfor_all2 _ _ ik_eq. 154 | Definition int_inv (i : intP) := int_eq_can i i. 155 | 156 | Hint Unfold int_eq_can int_inv: coc. 157 | 158 | 159 | Lemma ins_int_inv : 160 | forall (e f : intP) (k : nat) (y : Int_K), 161 | TIns _ y k e f -> int_inv f -> int_inv e. 162 | unfold int_inv, int_eq_can in |- *. 163 | simple induction 1; intros; auto with coc core arith datatypes. 164 | inversion_clear H0; auto with coc core arith datatypes. 165 | 166 | inversion_clear H2; auto with coc core arith datatypes. 167 | Qed. 168 | 169 | 170 | Lemma int_inv_int_eq_can : forall i : intP, int_inv i -> int_eq_can i i. 171 | auto with coc core arith datatypes. 172 | Qed. 173 | 174 | Hint Resolve int_inv_int_eq_can: coc. 175 | 176 | 177 | 178 | Lemma int_eq_can_cls : 179 | forall i i' : intP, int_eq_can i i' -> cls_of_int i = cls_of_int i'. 180 | unfold cls_of_int in |- *. 181 | simple induction 1; simpl in |- *; intros; auto with coc core arith datatypes. 182 | inversion_clear H0; simpl in |- *; intros; elim H2; 183 | auto with coc core arith datatypes. 184 | Qed. 185 | 186 | 187 | Fixpoint int_typ (T : term) : intP -> forall s : skel, Can s := 188 | fun (ip : intP) (s : skel) => 189 | match T with 190 | | Srt _ => default_can s 191 | | Ref n => coerce_CR s (Tnth_def _ (iK PROP sn) ip n) 192 | | Abs A t => 193 | match cl_term A (cls_of_int ip) with 194 | | Knd _ => 195 | match s as x return (Can x) with 196 | | PROD s1 s2 => 197 | fun C : Can s1 => int_typ t (TCs _ (iK s1 C) ip) s2 198 | | PROP => default_can PROP 199 | end 200 | | Typ _ => int_typ t (def_cons A ip) s 201 | | _ => default_can s 202 | end 203 | | App u v => 204 | match cl_term v (cls_of_int ip) with 205 | | Trm => int_typ u ip s 206 | | Typ sv => int_typ u ip (PROD sv s) (int_typ v ip sv) 207 | | _ => default_can s 208 | end 209 | | Prod A B => 210 | match s as x return (Can x) with 211 | | PROP => 212 | let s := cv_skel (cl_term A (cls_of_int ip)) in 213 | Pi s (int_typ A ip PROP) 214 | (fun C => int_typ B (int_cons A ip s C) PROP) 215 | | PROD s1 s2 => default_can (PROD s1 s2) 216 | end 217 | end. 218 | -------------------------------------------------------------------------------- /theories/ListType.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | Require Import Arith. 19 | Require Import MyList. 20 | 21 | Section TListes. 22 | 23 | Variable A : Type. 24 | 25 | Inductive TList : Type := 26 | | TNl : TList 27 | | TCs : A -> TList -> TList. 28 | 29 | 30 | Fixpoint Tnth_def (d : A) (l : TList) {struct l} : 31 | nat -> A := 32 | fun n : nat => 33 | match l, n with 34 | | TNl, _ => d 35 | | TCs x _, O => x 36 | | TCs _ tl, S k => Tnth_def d tl k 37 | end. 38 | 39 | 40 | Inductive TIns (x : A) : nat -> TList -> TList -> Prop := 41 | | TIns_hd : forall l : TList, TIns x 0 l (TCs x l) 42 | | TIns_tl : 43 | forall (n : nat) (l il : TList) (y : A), 44 | TIns x n l il -> TIns x (S n) (TCs y l) (TCs y il). 45 | 46 | Hint Resolve TIns_hd TIns_tl: coc. 47 | 48 | Lemma Tins_le : 49 | forall (k : nat) (f g : TList) (d x : A), 50 | TIns x k f g -> 51 | forall n : nat, k <= n -> Tnth_def d f n = Tnth_def d g (S n). 52 | simple induction 1; auto with coc core arith datatypes. 53 | simple destruct n0; intros. 54 | inversion H2. 55 | 56 | simpl in |- *; auto with coc core arith datatypes. 57 | Qed. 58 | 59 | Lemma Tins_gt : 60 | forall (k : nat) (f g : TList) (d x : A), 61 | TIns x k f g -> forall n : nat, k > n -> Tnth_def d f n = Tnth_def d g n. 62 | simple induction 1; auto with coc core arith datatypes. 63 | intros. 64 | inversion_clear H0. 65 | 66 | simple destruct n0; intros. 67 | auto with coc core arith datatypes. 68 | 69 | simpl in |- *; auto with coc core arith datatypes. 70 | Qed. 71 | 72 | Lemma Tins_eq : 73 | forall (k : nat) (f g : TList) (d x : A), 74 | TIns x k f g -> Tnth_def d g k = x. 75 | simple induction 1; simpl in |- *; auto with coc core arith datatypes. 76 | Qed. 77 | 78 | 79 | Inductive TTrunc : nat -> TList -> TList -> Prop := 80 | | Ttr_O : forall e : TList, TTrunc 0 e e 81 | | Ttr_S : 82 | forall (k : nat) (e f : TList) (x : A), 83 | TTrunc k e f -> TTrunc (S k) (TCs x e) f. 84 | 85 | Hint Resolve Ttr_O Ttr_S: coc. 86 | 87 | Fixpoint TList_iter (B : Type) (f : A -> B -> B) 88 | (l : TList) {struct l} : B -> B := 89 | fun x : B => 90 | match l with 91 | | TNl => x 92 | | TCs hd tl => f hd (TList_iter _ f tl x) 93 | end. 94 | 95 | Inductive Tfor_all (P : A -> Prop) : TList -> Prop := 96 | | Tfa_nil : Tfor_all P TNl 97 | | Tfa_cs : 98 | forall (h : A) (t : TList), 99 | P h -> Tfor_all P t -> Tfor_all P (TCs h t). 100 | 101 | Inductive Tfor_all_fold (P : A -> TList -> Prop) : TList -> Prop := 102 | | Tfaf_nil : Tfor_all_fold P TNl 103 | | Tfaf_cs : 104 | forall (h : A) (t : TList), 105 | P h t -> Tfor_all_fold P t -> Tfor_all_fold P (TCs h t). 106 | 107 | End TListes. 108 | 109 | Hint Resolve TIns_hd TIns_tl Ttr_O Ttr_S: coc. 110 | Hint Resolve Tfa_nil Tfa_cs Tfaf_nil Tfaf_cs: coc. 111 | 112 | Fixpoint Tmap (A B : Type) (f : A -> B) (l : TList A) {struct l} : 113 | TList B := 114 | match l with 115 | | TNl => TNl B 116 | | TCs t tl => TCs _ (f t) (Tmap A B f tl) 117 | end. 118 | 119 | Fixpoint TSmap (A : Type) (B : Set) (f : A -> B) 120 | (l : TList A) {struct l} : list B := 121 | match l with 122 | | TNl => nil (A:=B) 123 | | TCs t tl => f t :: TSmap A B f tl 124 | end. 125 | 126 | 127 | Inductive Tfor_all2 (A B : Type) (P : A -> B -> Prop) : 128 | TList A -> TList B -> Prop := 129 | | Tfa2_nil : Tfor_all2 _ _ P (TNl _) (TNl _) 130 | | Tfa2_cs : 131 | forall (h1 : A) (h2 : B) (t1 : TList A) (t2 : TList B), 132 | P h1 h2 -> 133 | Tfor_all2 _ _ P t1 t2 -> Tfor_all2 _ _ P (TCs _ h1 t1) (TCs _ h2 t2). 134 | 135 | Hint Resolve Tfa2_nil Tfa2_cs: coc. -------------------------------------------------------------------------------- /theories/MlTypes.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | 18 | (* Formalisation of several Objective Caml basic types *) 19 | 20 | (* integers *) 21 | 22 | Parameter ml_int : Set. 23 | Parameter ml_eq_int : forall m n : ml_int, {m = n} + {m <> n}. 24 | Parameter ml_zero : ml_int. 25 | Parameter ml_succ : ml_int -> ml_int. 26 | 27 | Parameter ml_int_pred : forall m n : ml_int, ml_succ m = ml_succ n -> m = n. 28 | (* This axiom is wrong in practice: (ml_succ -1)=ml_zero *) 29 | Axiom dangerous_discr : forall n : ml_int, ml_zero <> ml_succ n. 30 | 31 | Parameter 32 | ml_int_case : 33 | forall n : ml_int, {m : ml_int | n = ml_succ m} + {n = ml_zero}. 34 | 35 | Fixpoint int_of_nat (n : nat) : ml_int := 36 | match n with 37 | | O => ml_zero 38 | | S k => ml_succ (int_of_nat k) 39 | end. 40 | 41 | Lemma dangerous_int_injection : 42 | forall i j : nat, int_of_nat i = int_of_nat j -> i = j. 43 | simple induction i; simple destruct j; simpl in |- *; intros; auto. 44 | elim dangerous_discr with (int_of_nat n); auto. 45 | 46 | elim dangerous_discr with (int_of_nat n); auto. 47 | 48 | elim H with n0; auto. 49 | apply ml_int_pred; auto. 50 | Qed. 51 | 52 | 53 | (* strings *) 54 | Parameter ml_string : Set. 55 | Parameter ml_eq_string : forall s1 s2 : ml_string, {s1 = s2} + {s1 <> s2}. 56 | 57 | (* will be realized by (fun n -> "x"^int_of_string n) *) 58 | Parameter ml_x_int : ml_int -> ml_string. 59 | Parameter 60 | ml_x_int_inj : forall m n : ml_int, ml_x_int m = ml_x_int n -> m = n. 61 | 62 | -------------------------------------------------------------------------------- /theories/MyList.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | Require Import Arith. 18 | Require Export List. 19 | 20 | Global Set Asymmetric Patterns. 21 | 22 | Section Listes. 23 | 24 | Variable A : Set. 25 | 26 | Let List := list A. 27 | 28 | 29 | Inductive In (x : A) : List -> Prop := 30 | | In_hd : forall l : List, In x (x :: l) 31 | | In_tl : forall (y : A) (l : List), In x l -> In x (y :: l). 32 | 33 | Hint Resolve In_hd In_tl: coc. 34 | 35 | 36 | Lemma In_app : 37 | forall (x : A) (l1 l2 : List), In x (l1 ++ l2) -> In x l1 \/ In x l2. 38 | simple induction l1; simpl in |- *; intros; 39 | auto with coc core arith datatypes. 40 | 41 | inversion_clear H0; auto with coc core arith datatypes. 42 | elim H with l2; auto with coc core arith datatypes. 43 | Qed. 44 | 45 | 46 | Definition incl (l1 l2 : List) : Prop := forall x : A, In x l1 -> In x l2. 47 | 48 | Hint Unfold incl: coc. 49 | 50 | 51 | Lemma incl_app_sym : forall l1 l2 : List, incl (l1 ++ l2) (l2 ++ l1). 52 | red in |- *; intros. 53 | elim In_app with x l1 l2; intros; auto with coc core arith datatypes. 54 | elim l2; simpl in |- *; auto with coc core arith datatypes. 55 | 56 | elim H0; simpl in |- *; auto with coc core arith datatypes. 57 | Qed. 58 | 59 | 60 | Inductive item (x : A) : List -> nat -> Prop := 61 | | item_hd : forall l : List, item x (x :: l) 0 62 | | item_tl : 63 | forall (l : List) (n : nat) (y : A), 64 | item x l n -> item x (y :: l) (S n). 65 | 66 | Lemma fun_item : 67 | forall (u v : A) (e : List) (n : nat), item u e n -> item v e n -> u = v. 68 | simple induction 1; intros. 69 | inversion_clear H0; auto with coc core arith datatypes. 70 | 71 | inversion_clear H2; auto with coc core arith datatypes. 72 | Qed. 73 | 74 | 75 | Fixpoint nth_def (d : A) (l : List) {struct l} : 76 | nat -> A := 77 | fun n : nat => 78 | match l, n with 79 | | nil, _ => d 80 | | x :: _, O => x 81 | | _ :: tl, S k => nth_def d tl k 82 | end. 83 | 84 | Lemma nth_sound : 85 | forall (x : A) (l : List) (n : nat), 86 | item x l n -> forall d : A, nth_def d l n = x. 87 | simple induction 1; simpl in |- *; auto with coc core arith datatypes. 88 | Qed. 89 | 90 | Lemma inv_nth_nl : forall (x : A) (n : nat), ~ item x nil n. 91 | unfold not in |- *; intros. 92 | inversion_clear H. 93 | Qed. 94 | 95 | Lemma inv_nth_cs : 96 | forall (x y : A) (l : List) (n : nat), item x (y :: l) (S n) -> item x l n. 97 | intros. 98 | inversion_clear H; auto with coc core arith datatypes. 99 | Qed. 100 | 101 | Inductive insert (x : A) : nat -> List -> List -> Prop := 102 | | insert_hd : forall l : List, insert x 0 l (x :: l) 103 | | insert_tl : 104 | forall (n : nat) (l il : List) (y : A), 105 | insert x n l il -> insert x (S n) (y :: l) (y :: il). 106 | 107 | 108 | Inductive trunc : nat -> List -> List -> Prop := 109 | | trunc_O : forall e : List, trunc 0 e e 110 | | trunc_S : 111 | forall (k : nat) (e f : List) (x : A), 112 | trunc k e f -> trunc (S k) (x :: e) f. 113 | 114 | Hint Resolve trunc_O trunc_S: coc. 115 | 116 | 117 | Lemma item_trunc : 118 | forall (n : nat) (e : List) (t : A), 119 | item t e n -> exists f : List, trunc (S n) e f. 120 | simple induction n; intros. 121 | inversion_clear H. 122 | exists l; auto with coc core arith datatypes. 123 | 124 | inversion_clear H0. 125 | elim H with l t; intros; auto with coc core arith datatypes. 126 | exists x; auto with coc core arith datatypes. 127 | Qed. 128 | 129 | 130 | Lemma ins_le : 131 | forall (k : nat) (f g : List) (d x : A), 132 | insert x k f g -> 133 | forall n : nat, k <= n -> nth_def d f n = nth_def d g (S n). 134 | simple induction 1; auto with coc core arith datatypes. 135 | simple destruct n0; intros. 136 | inversion_clear H2. 137 | 138 | simpl in |- *. 139 | auto with coc core arith datatypes. 140 | Qed. 141 | 142 | Lemma ins_gt : 143 | forall (k : nat) (f g : List) (d x : A), 144 | insert x k f g -> forall n : nat, k > n -> nth_def d f n = nth_def d g n. 145 | simple induction 1; auto with coc core arith datatypes. 146 | intros. 147 | inversion_clear H0. 148 | 149 | simple destruct n0; intros. 150 | auto with coc core arith datatypes. 151 | 152 | simpl in |- *; auto with coc core arith datatypes. 153 | Qed. 154 | 155 | Lemma ins_eq : 156 | forall (k : nat) (f g : List) (d x : A), 157 | insert x k f g -> nth_def d g k = x. 158 | simple induction 1; simpl in |- *; auto with coc core arith datatypes. 159 | Qed. 160 | 161 | 162 | 163 | 164 | Definition list_item : 165 | forall (e : List) (n : nat), 166 | {t : A | item t e n} + {(forall t : A, ~ item t e n)}. 167 | 168 | simple induction e. 169 | right. 170 | red in |- *; intros t H; inversion_clear H. 171 | intros h f itemf n. 172 | case n. 173 | left; exists h; constructor. 174 | intro k; case (itemf k). 175 | simple destruct 1; intro u; left; exists u; constructor; trivial. 176 | intros; right. 177 | red in |- *; intros. 178 | inversion_clear H. 179 | apply (n0 t); auto. 180 | Defined. 181 | 182 | 183 | 184 | 185 | Definition list_disjoint (l1 l2 : List) : Prop := 186 | forall x : A, In x l1 -> In x l2 -> False. 187 | 188 | 189 | 190 | 191 | Inductive first_item (x : A) : List -> nat -> Prop := 192 | | fit_hd : forall l : List, first_item x (x :: l) 0 193 | | fit_tl : 194 | forall (l : List) (y : A) (n : nat), 195 | first_item x l n -> x <> y -> first_item x (y :: l) (S n). 196 | 197 | Hint Resolve fit_hd fit_tl: coc. 198 | 199 | Lemma first_item_is_item : 200 | forall (x : A) (l : List) (n : nat), first_item x l n -> item x l n. 201 | simple induction 1; intros. 202 | apply item_hd. 203 | 204 | apply item_tl; trivial with coc core arith datatypes. 205 | Qed. 206 | 207 | Lemma first_item_unique : 208 | forall (x : A) (l : List) (n : nat), 209 | first_item x l n -> forall m : nat, first_item x l m -> m = n. 210 | simple induction 1; intros; auto with coc core arith datatypes. 211 | inversion_clear H0; auto with coc core arith datatypes. 212 | 213 | elim H2; auto with coc core arith datatypes. 214 | 215 | generalize H2. 216 | inversion_clear H3; intros. 217 | elim H3; auto with coc core arith datatypes. 218 | 219 | elim H1 with n1; auto with coc core arith datatypes. 220 | Qed. 221 | 222 | 223 | 224 | Hypothesis eq_dec : forall x y : A, {x = y} + {x <> y}. 225 | 226 | Definition list_index : 227 | forall (x : A) (l : List), {n : nat | first_item x l n} + {~ In x l}. 228 | 229 | refine 230 | (fix list_index (x : A) (l : List) {struct l} : 231 | {n : nat | first_item x l n} + {~ In x l} := 232 | match l return ({n : nat | first_item x l n} + {~ In x l}) with 233 | | nil => inright _ _ 234 | | y :: l1 => 235 | match eq_dec x y with 236 | | left found => inleft _ (exist _ 0 _) 237 | | right notfound => 238 | match list_index x l1 with 239 | | inleft (exist k in_tail) => inleft _ (exist _ (S k) _) 240 | | inright not_tail => inright _ _ 241 | end 242 | end 243 | end); auto with coc. 244 | 245 | red in |- *; intros. 246 | inversion H. 247 | 248 | elim found; auto with coc. 249 | 250 | red in |- *; intros; apply not_tail. 251 | inversion H; auto with coc. 252 | elim notfound; trivial. 253 | Defined. 254 | 255 | End Listes. 256 | 257 | Hint Resolve item_hd item_tl insert_hd insert_tl trunc_O trunc_S: coc. 258 | Hint Resolve In_hd In_tl fit_hd fit_tl trunc_O trunc_S: coc. 259 | Hint Unfold incl: coc. 260 | 261 | 262 | -------------------------------------------------------------------------------- /theories/Names.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | Require Import Arith. 18 | Require Import MyList. 19 | Require Import Lia. 20 | Require Export MlTypes. 21 | 22 | 23 | (* type des noms *) 24 | Definition name := ml_string. 25 | Definition prt_names := list name. 26 | 27 | Definition name_dec : forall x y : name, {x = y} + {x <> y} 28 | := ml_eq_string. 29 | 30 | Definition var_of_nat (n : nat) : name := ml_x_int (int_of_nat n). 31 | 32 | Lemma inj_var_of_nat : 33 | forall m n : nat, var_of_nat m = var_of_nat n -> m = n. 34 | unfold var_of_nat in |- *. 35 | intros. 36 | apply dangerous_int_injection. 37 | apply ml_x_int_inj; auto with coc core arith datatypes. 38 | Qed. 39 | 40 | 41 | 42 | 43 | Inductive ord_insert : list name -> list name -> Prop := 44 | oi_intro : 45 | forall (x : name) (n : nat) (l1 l2 : list name), 46 | insert _ x n l1 l2 -> ord_insert l1 l2. 47 | 48 | 49 | Lemma wf_oi : well_founded ord_insert. 50 | cut (forall (n : nat) (l : list name), length l = n -> Acc ord_insert l). 51 | red in |- *; intros. 52 | apply H with (length a); auto with coc core arith datatypes. 53 | 54 | simple induction n. 55 | simple destruct l; intros. 56 | apply Acc_intro; intros. 57 | inversion_clear H0. 58 | inversion_clear H1. 59 | 60 | discriminate H. 61 | 62 | simple destruct l; simpl in |- *; intros. 63 | discriminate H0. 64 | 65 | injection H0; intros. 66 | apply Acc_intro; intros. 67 | inversion_clear H2. 68 | apply H. 69 | cut (S (length y) = length (n1 :: l0)); intros. 70 | simpl in H2. 71 | injection H2; auto with coc core arith datatypes. 72 | elim H1; auto with coc core arith datatypes. 73 | 74 | elim H3; auto with coc core arith datatypes. 75 | intros. 76 | simpl in |- *. 77 | elim H4; auto with coc core arith datatypes. 78 | Qed. 79 | 80 | 81 | Definition rmv : 82 | forall (x : name) (l : prt_names), 83 | {l1 : prt_names | exists n : nat, insert _ x n l1 l} + {~ In _ x l}. 84 | (* 85 | Realizer Fix rmv {rmv/2: name->(list name)->(sumor (list name)) := 86 | [x,l]Cases l of 87 | nil => (inright ?) 88 | | (cons y l1) => Cases (name_dec x y) of 89 | left => (inleft ? l1) 90 | | right => Cases (rmv x l1) of 91 | (inleft v) => (inleft ? (cons ? y v)) 92 | | inright => (inright ?) 93 | end 94 | end 95 | end}. 96 | *) 97 | refine 98 | (fix rmv (x : name) (l : prt_names) {struct l} : 99 | {l1 : prt_names | exists n : nat, insert _ x n l1 l} + {~ In _ x l} := 100 | match 101 | l 102 | return 103 | ({l1 : prt_names | exists n : nat, insert _ x n l1 l} + {~ In _ x l}) 104 | with 105 | | nil => inright _ _ 106 | | y :: l1 => 107 | match name_dec x y with 108 | | left found => inleft _ (exist _ l1 _) 109 | | right notfound => 110 | match rmv x l1 with 111 | | inleft (exist v rmvd) => inleft _ (exist _ (y :: v) _) 112 | | inright notin => inright _ _ 113 | end 114 | end 115 | end). 116 | red in |- *; intros. 117 | inversion H. 118 | 119 | rewrite found. 120 | exists 0; trivial with coc. 121 | 122 | inversion_clear rmvd. 123 | exists (S x0); auto with coc core arith datatypes. 124 | 125 | red in |- *; intros; apply notin. 126 | inversion H; auto with coc core arith datatypes. 127 | elim notfound; trivial. 128 | Defined. 129 | 130 | 131 | 132 | Definition find_free : 133 | forall (l : prt_names) (n : nat), 134 | {m : nat | n <= m & ~ In _ (var_of_nat m) l}. 135 | (* 136 | Realizer nat>rec ffv :: :: { ord_insert } 137 | [l:prt_names][n:?]Cases (rmv (var_of_nat n) l) of 138 | (inleft l1) => (ffv l1 (S n)) 139 | | inright => n 140 | end. 141 | *) 142 | intro l. 143 | apply Acc_rec with (R := ord_insert) (x := l). 144 | 2: apply wf_oi. 145 | clear l. 146 | intros l acc_hyp ffv n. 147 | refine 148 | match rmv (var_of_nat n) l with 149 | | inleft (exist l1 rmvd as s) => 150 | match ffv l1 _ (S n) with 151 | | exist2 m m_le m_notin => exist2 _ _ m _ _ 152 | end 153 | | inright fresh => exist2 _ _ n _ _ 154 | end; auto with arith. 155 | inversion_clear rmvd. 156 | eapply oi_intro; eauto. 157 | 158 | red in |- *; intro. 159 | apply m_notin. 160 | inversion_clear rmvd. 161 | generalize H0; clear H0. 162 | cut (var_of_nat m <> var_of_nat n). 163 | generalize x l1. 164 | elim H; unfold var_of_nat in |- *; intros. 165 | inversion H1; auto with coc. 166 | elim H0; auto. 167 | 168 | inversion H3; auto with coc. 169 | constructor; eauto. 170 | 171 | red in |- *; intros. 172 | enough (m = n) by lia. 173 | revert H0; apply inj_var_of_nat. 174 | Defined. 175 | 176 | 177 | 178 | 179 | 180 | Definition find_free_var : forall l : prt_names, {x : name | ~ In _ x l}. 181 | (* 182 | Realizer [l](var_of_nat (find_free l O)). 183 | *) 184 | intros. 185 | elim (find_free l 0); intros; auto with coc. 186 | exists (var_of_nat x); trivial. 187 | Defined. 188 | 189 | 190 | Definition name_unique l := 191 | forall (m n : nat) (x : name), item _ x l m -> item _ x l n -> m = n. 192 | 193 | 194 | Lemma fv_ext : 195 | forall l : prt_names, 196 | name_unique l -> forall x : name, ~ In _ x l -> name_unique (x :: l). 197 | unfold name_unique in |- *; intros. 198 | generalize H2. 199 | inversion_clear H1; intros. 200 | inversion_clear H1; auto with coc core arith datatypes. 201 | elim H0. 202 | elim H3; auto with coc core arith datatypes. 203 | 204 | generalize H3. 205 | inversion_clear H1; intros. 206 | elim H0. 207 | elim H1; auto with coc core arith datatypes. 208 | 209 | elim H with n1 n0 x0; auto with coc core arith datatypes. 210 | Qed. 211 | 212 | 213 | Lemma name_unique_first : 214 | forall (x : name) (l : prt_names) (n : nat), 215 | item _ x l n -> name_unique l -> first_item _ x l n. 216 | simple induction 1; intros. 217 | auto with coc core arith datatypes. 218 | 219 | apply fit_tl; auto with coc core arith datatypes. 220 | apply H1. 221 | red in |- *; intros. 222 | cut (S m = S n1); intros. 223 | injection H5; auto with coc core arith datatypes. 224 | 225 | elim H2 with (S m) (S n1) x0; auto with coc core arith datatypes. 226 | 227 | red in |- *; intros. 228 | cut (0 = S n0); intros. 229 | discriminate H4. 230 | 231 | elim H2 with 0 (S n0) x; auto with coc core arith datatypes. 232 | rewrite H3; auto with coc core arith datatypes. 233 | Qed. 234 | -------------------------------------------------------------------------------- /theories/Strong_Norm.v: -------------------------------------------------------------------------------- 1 | (* This program is free software; you can redistribute it and/or *) 2 | (* modify it under the terms of the GNU Lesser General Public License *) 3 | (* as published by the Free Software Foundation; either version 2.1 *) 4 | (* of the License, or (at your option) any later version. *) 5 | (* *) 6 | (* This program is distributed in the hope that it will be useful, *) 7 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 8 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 9 | (* GNU General Public License for more details. *) 10 | (* *) 11 | (* You should have received a copy of the GNU Lesser General Public *) 12 | (* License along with this program; if not, write to the Free *) 13 | (* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) 14 | (* 02110-1301 USA *) 15 | 16 | 17 | Require Import Termes. 18 | Require Import Conv. 19 | Require Import Types. 20 | Require Import Class. 21 | Require Import Can. 22 | Require Import Int_term. 23 | Require Import Int_typ. 24 | Require Import Int_stab. 25 | Require Import PeanoNat. 26 | 27 | Load "ImpVar". 28 | 29 | Inductive trm_in_int : env -> intP -> intt -> Prop := 30 | | int_nil : forall itt : intt, trm_in_int nil (TNl _) itt 31 | | int_cs : 32 | forall e (ip : intP) (itt : intt), 33 | trm_in_int e ip itt -> 34 | forall (y : Int_K) t T, 35 | int_typ T ip PROP t -> 36 | trm_in_int (T :: e) (TCs _ y ip) (shift_intt itt t). 37 | 38 | Hint Resolve int_nil int_cs: coc. 39 | 40 | 41 | Record int_adapt e (ip : intP) (itt : intt) : Prop := 42 | {adapt_trm_in_int : trm_in_int e ip itt; 43 | int_can_adapt : can_adapt ip; 44 | adapt_class_equal : cls_of_int ip = class_env e}. 45 | 46 | 47 | 48 | Lemma int_sound : 49 | forall e t T, 50 | typ e t T -> 51 | forall (ip : intP) (it : intt), 52 | int_adapt e ip it -> int_typ T ip PROP (int_term t it 0). 53 | simple induction 1; simpl in |- *; intros. 54 | red in |- *; apply Acc_intro; intros. 55 | inversion_clear H2. 56 | 57 | red in |- *; apply Acc_intro; intros. 58 | inversion_clear H2. 59 | 60 | elim (le_gt_dec 0 v); [ intro Hle | intro Hgt ]. 61 | rewrite lift0. 62 | rewrite Nat.sub_0_r. 63 | elim H1; intros. 64 | rewrite H3. 65 | generalize ip it H2. 66 | clear H3 Hle H2 it ip H1 t0. 67 | elim H4. 68 | intros l ip it (in_interp, p, q); revert p q; 69 | (* Do not intro other fields *) 70 | inversion_clear in_interp; simpl in |- *; intros ip_can_adapted same_classes. 71 | apply eq_cand_incl with (int_typ x ip0 PROP); 72 | auto with coc core arith datatypes. 73 | unfold lift in |- *. 74 | apply lift_int_typ with y; auto with coc core arith datatypes. 75 | 76 | intros l n y H1 H2 ip it (in_interp, p, q); revert p q; inversion_clear in_interp; 77 | simpl in |- *; intros ip_can_adapted same_classes. 78 | simpl in |- *. 79 | rewrite simpl_lift. 80 | apply eq_cand_incl with (int_typ (lift (S n) x) ip0 PROP). 81 | unfold lift at 2 in |- *. 82 | apply lift_int_typ with y0; auto with coc core arith datatypes. 83 | 84 | apply H2. 85 | apply Build_int_adapt; auto with coc core arith datatypes. 86 | inversion_clear ip_can_adapted; auto with coc core arith datatypes. 87 | 88 | injection same_classes; auto with coc core arith datatypes. 89 | 90 | inversion_clear Hgt. 91 | 92 | elim H6; intros in_interp ip_can_adapted same_classes. 93 | apply Abs_sound; intros; auto with coc core arith datatypes. 94 | apply int_typ_cr; auto with coc core arith datatypes. 95 | 96 | simpl in |- *; intros. 97 | change 98 | (is_can PROP 99 | (int_typ U (int_cons T0 ip (cv_skel (cl_term T0 (cls_of_int ip))) X) 100 | PROP)) in |- *. 101 | apply int_typ_cr. 102 | unfold int_cons, ext_ik in |- *. 103 | generalize X H7 H8. 104 | elim (cl_term T0 (cls_of_int ip)); auto with coc core arith datatypes. 105 | 106 | unfold subst in |- *. 107 | rewrite int_term_subst; auto with coc core arith datatypes. 108 | apply H5. 109 | unfold int_cons, ext_ik in |- *. 110 | apply Build_int_adapt; auto with coc core arith datatypes. 111 | generalize C H8 H9. 112 | elim (cl_term T0 (cls_of_int ip)); auto with coc core arith datatypes. 113 | 114 | simpl in |- *. 115 | pattern (cls_of_int ip) at 1 in |- *. 116 | rewrite same_classes. 117 | unfold cls_of_int in |- *. 118 | pattern (cl_term T0 (class_env e0)) in |- *. 119 | apply class_typ_ord with s1; elim same_classes; simpl in |- *; 120 | auto with coc core arith datatypes. 121 | rewrite same_classes. 122 | elim skel_sound with e0 T0 (Srt s1); simpl in |- *; 123 | auto with coc core arith datatypes. 124 | elim same_classes; auto with coc core arith datatypes. 125 | 126 | apply H1 with ip; auto with coc core arith datatypes. 127 | 128 | elim H4; intros in_interp ip_can_adapted same_classes. 129 | elim type_case with e0 u (Prod V Ur); intros; 130 | auto with coc core arith datatypes. 131 | inversion_clear H5. 132 | apply inv_typ_prod with e0 V Ur (Srt x); auto with coc core arith datatypes; 133 | intros. 134 | apply 135 | eq_cand_incl 136 | with 137 | (int_typ Ur 138 | (int_cons V ip (cv_skel (cl_term V (cls_of_int ip))) (int_typ v ip _)) 139 | PROP). 140 | replace PROP with 141 | (skel_int Ur 142 | (int_cons V ip (cv_skel (cl_term V (cls_of_int ip))) 143 | (int_typ v ip (cv_skel (cl_term V (cls_of_int ip)))))). 144 | unfold subst, int_cons in |- *. 145 | apply 146 | subst_int_typ 147 | with 148 | ip 149 | (ext_ik V ip (cv_skel (cl_term V (cls_of_int ip))) 150 | (int_typ v ip (cv_skel (cl_term V (cls_of_int ip))))) 151 | (V :: e0) 152 | (Srt s2); auto with coc core arith datatypes. 153 | unfold ext_ik in |- *. 154 | rewrite same_classes. 155 | cut (cl_term v (cls_of_int ip) = cl_term v (class_env e0)). 156 | elim class_sound with e0 v V (Srt s1); intros; 157 | auto with coc core arith datatypes. 158 | 159 | elim same_classes; auto with coc core arith datatypes. 160 | 161 | simpl in |- *. 162 | unfold ext_ik in |- *. 163 | rewrite same_classes. 164 | unfold cls_of_int in |- *. 165 | apply class_typ_ord with s1; elim same_classes; simpl in |- *; 166 | auto with coc core arith datatypes. 167 | rewrite same_classes. 168 | elim skel_sound with e0 V (Srt s1); simpl in |- *; 169 | auto with coc core arith datatypes. 170 | elim same_classes; auto with coc core arith datatypes. 171 | 172 | unfold ext_ik in |- *. 173 | red in |- *; red in |- *; auto with coc core arith datatypes. 174 | apply Tfa2_cs; auto with coc core arith datatypes. 175 | elim (cl_term V (cls_of_int ip)); auto with coc core arith datatypes. 176 | 177 | change (int_inv ip) in |- *. 178 | apply adapt_int_inv; auto with coc core arith datatypes. 179 | 180 | replace 181 | (cls_of_int 182 | (TCs Int_K 183 | (ext_ik V ip (cv_skel (cl_term V (cls_of_int ip))) 184 | (int_typ v ip (cv_skel (cl_term V (cls_of_int ip))))) ip)) with 185 | (class_env (V :: e0)). 186 | apply class_typ_ord with s2; auto with coc core arith datatypes. 187 | discriminate. 188 | 189 | discriminate. 190 | 191 | simpl in |- *. 192 | unfold cls_of_int at 1, ext_ik in |- *. 193 | rewrite same_classes. 194 | pattern (cl_term V (class_env e0)) in |- *. 195 | apply class_typ_ord with s1; elim same_classes; simpl in |- *; 196 | auto with coc core arith datatypes. 197 | rewrite same_classes. 198 | elim skel_sound with e0 V (Srt s1); simpl in |- *; 199 | auto with coc core arith datatypes. 200 | elim same_classes; auto with coc core arith datatypes. 201 | 202 | unfold int_cons, skel_int in |- *. 203 | replace 204 | (cls_of_int 205 | (TCs Int_K 206 | (ext_ik V ip _ (int_typ v ip (cv_skel (cl_term V (cls_of_int ip))))) 207 | ip)) with (class_env (V :: e0)). 208 | elim skel_sound with (V :: e0) Ur (Srt s2); simpl in |- *; 209 | auto with coc core arith datatypes. 210 | 211 | simpl in |- *. 212 | unfold ext_ik in |- *. 213 | rewrite same_classes. 214 | unfold cls_of_int in |- *. 215 | elim class_sound with e0 v V (Srt s1); auto with coc core arith datatypes. 216 | simpl in |- *. 217 | elim same_classes; auto with coc core arith datatypes. 218 | 219 | simpl in |- *. 220 | elim same_classes; auto with coc core arith datatypes. 221 | 222 | unfold Pi in H3. 223 | apply H3; auto with coc core arith datatypes. 224 | apply int_typ_cr; auto with coc core arith datatypes. 225 | 226 | discriminate H5. 227 | 228 | apply sn_prod. 229 | apply H1 with ip; auto with coc core arith datatypes. 230 | 231 | apply sn_subst with (Ref 0). 232 | unfold subst in |- *. 233 | rewrite int_term_subst. 234 | elim H4; intros in_interp ip_can_adapted same_classes. 235 | apply H3 with (def_cons T0 ip). 236 | unfold def_cons, int_cons in |- *. 237 | apply Build_int_adapt. 238 | apply int_cs; auto with coc core arith datatypes. 239 | apply (var_in_cand 0 (int_typ T0 ip PROP)); 240 | auto with coc core arith datatypes. 241 | exact (int_typ_cr T0 ip ip_can_adapted PROP). 242 | 243 | red in |- *. 244 | apply Tfa_cs; auto with coc core arith datatypes. 245 | unfold ext_ik in |- *. 246 | elim (cl_term T0 (cls_of_int ip)); auto with coc core arith datatypes. 247 | 248 | unfold ext_ik in |- *. 249 | rewrite same_classes. 250 | unfold cls_of_int in |- *. 251 | simpl in |- *. 252 | pattern (cl_term T0 (class_env e0)) in |- *. 253 | apply class_typ_ord with s1; simpl in |- *; elim same_classes; 254 | auto with coc core arith datatypes. 255 | rewrite same_classes. 256 | elim skel_sound with e0 T0 (Srt s1); simpl in |- *; 257 | auto with coc core arith datatypes. 258 | elim same_classes; auto with coc core arith datatypes. 259 | 260 | cut (typ e0 U (Srt s)); auto with coc core arith datatypes. 261 | intros. 262 | apply eq_cand_incl with (int_typ U ip PROP); 263 | auto with coc core arith datatypes. 264 | replace PROP with (skel_int U ip). 265 | elim H5; intros in_interp ip_can_adapted same_classes. 266 | apply conv_int_typ with e0 (Srt s); auto with coc core arith datatypes. 267 | apply class_typ_ord with s; auto with coc core arith datatypes. 268 | discriminate. 269 | 270 | discriminate. 271 | 272 | unfold skel_int in |- *. 273 | elim H5; intros in_interp ip_can_adapted same_classes. 274 | rewrite same_classes. 275 | elim skel_sound with e0 U (Srt s); simpl in |- *; 276 | auto with coc core arith datatypes. 277 | 278 | elim type_case with e0 t0 U; intros; auto with coc core arith datatypes. 279 | inversion_clear H6. 280 | elim conv_sort with x s; auto with coc core arith datatypes. 281 | apply typ_conv_conv with e0 U V; auto with coc core arith datatypes. 282 | 283 | elim inv_typ_conv_kind with e0 V (Srt s); auto with coc core arith datatypes. 284 | elim H6; auto with coc core arith datatypes. 285 | Qed. 286 | 287 | 288 | 289 | 290 | Fixpoint def_intp e : intP := 291 | match e with 292 | | nil => TNl _ 293 | | t :: f => def_cons t (def_intp f) 294 | end. 295 | 296 | 297 | 298 | Fixpoint def_intt e : nat -> intt := 299 | fun k => 300 | match e with 301 | | nil => fun p => Ref (k + p) 302 | | _ :: f => shift_intt (def_intt f (S k)) (Ref k) 303 | end. 304 | 305 | 306 | Lemma def_intp_can : forall e, can_adapt (def_intp e). 307 | simple induction e; simpl in |- *; auto with coc core arith datatypes; intros. 308 | unfold def_cons, int_cons, ext_ik in |- *. 309 | elim (cl_term a (cls_of_int (def_intp l))); 310 | auto with coc core arith datatypes. 311 | Qed. 312 | 313 | 314 | Lemma def_adapt : 315 | forall e, wf e -> forall k, int_adapt e (def_intp e) (def_intt e k). 316 | simple induction e; simpl in |- *; intros. 317 | apply Build_int_adapt; auto with coc core arith datatypes. 318 | 319 | inversion_clear H0. 320 | cut (wf l); intros. 321 | elim H with (S k); trivial; intros in_interp ip_can_adapted same_classes. 322 | unfold def_cons, int_cons in |- *. 323 | apply Build_int_adapt; auto with coc core arith datatypes. 324 | apply int_cs; auto with coc core arith datatypes. 325 | apply (var_in_cand k (int_typ a (def_intp l) PROP)); 326 | auto with coc core arith datatypes. 327 | change (is_can PROP (int_typ a (def_intp l) PROP)) in |- *. 328 | apply int_typ_cr; auto with coc core arith datatypes. 329 | 330 | unfold ext_ik in |- *. 331 | rewrite same_classes. 332 | pattern (cl_term a (class_env l)) in |- *. 333 | apply class_typ_ord with s; auto with coc core arith datatypes. 334 | 335 | simpl in |- *. 336 | unfold ext_ik in |- *. 337 | rewrite same_classes. 338 | pattern (cl_term a (class_env l)) in |- *. 339 | apply class_typ_ord with s; unfold cls_of_int in |- *; elim same_classes; 340 | auto with coc core arith datatypes. 341 | simpl in |- *. 342 | rewrite same_classes. 343 | elim skel_sound with l a (Srt s); auto with coc core arith datatypes. 344 | simpl in |- *; auto with coc core arith datatypes. 345 | elim same_classes; auto with coc core arith datatypes. 346 | 347 | apply typ_wf with a (Srt s); auto with coc core arith datatypes. 348 | Qed. 349 | 350 | Hint Resolve def_intp_can def_adapt: coc. 351 | 352 | 353 | Lemma def_intt_id : forall n e k, def_intt e k n = Ref (k + n). 354 | simple induction n; simple destruct e; simpl in |- *; 355 | auto with coc core arith datatypes; intros. 356 | replace (k + 0) with k; auto with coc core arith datatypes. 357 | 358 | rewrite H. 359 | replace (k + S n0) with (S (k + n0)); auto with coc core arith datatypes. 360 | Qed. 361 | 362 | 363 | Lemma id_int_term : forall e t k, int_term t (def_intt e 0) k = t. 364 | simple induction t; simpl in |- *; intros; auto with coc core arith datatypes. 365 | elim (le_gt_dec k n); intros; auto with coc core arith datatypes. 366 | rewrite def_intt_id. 367 | simpl in |- *; unfold lift in |- *. 368 | rewrite lift_ref_ge; auto with coc core arith datatypes. 369 | 370 | 371 | rewrite H; rewrite H0; auto with coc core arith datatypes. 372 | 373 | rewrite H; rewrite H0; auto with coc core arith datatypes. 374 | 375 | rewrite H; rewrite H0; auto with coc core arith datatypes. 376 | Qed. 377 | 378 | 379 | 380 | 381 | Theorem str_norm : forall e t T, typ e t T -> sn t. 382 | intros. 383 | cut (is_can PROP (int_typ T (def_intp e) PROP)); 384 | auto with coc core arith datatypes. 385 | simpl in |- *; intros. 386 | cut (int_typ T (def_intp e) PROP t). 387 | elim H0; auto with coc core arith datatypes. 388 | 389 | elim id_int_term with e t 0. 390 | apply int_sound with e; auto with coc core arith datatypes. 391 | apply def_adapt. 392 | apply typ_wf with t T; auto with coc core arith datatypes. 393 | 394 | apply int_typ_cr; auto with coc core arith datatypes. 395 | Qed. 396 | 397 | 398 | 399 | Lemma type_sn : forall e t T, typ e t T -> sn T. 400 | intros. 401 | elim type_case with e t T; intros; auto with coc core arith datatypes. 402 | elim H0; intros. 403 | apply str_norm with e (Srt x); auto with coc core arith datatypes. 404 | 405 | rewrite H0. 406 | red in |- *; apply Acc_intro; intros. 407 | inversion_clear H1. 408 | Qed. 409 | --------------------------------------------------------------------------------