(** * Software Foundations, Formally Benjamin C. Pierce Version of 11/27/2007 Before handing in this file with your homework solutions, please fill in the names of all members of your group: Also, please tell us roughly how many person-hours you spent on this assignment (i.e., if you worked in a group, give us the SUM of the number of hours spent by each person individually). Any thoughts or comments on this assignment? *) (* ---------------------------------------------------------------------- *) Require Export lec1617. (* ====================================================================== *) (* A missing lemma about numbers that's needed in the proofs below *) Lemma eqnat_n_n' : forall n n' : nat, n <> n' -> eqnat n n' = no. Proof. intros n n' H. unfold not in H. remember (eqnat n n') as e. destruct e. CASE "yes (contradictory)". apply eq_symm in Heqe. apply eqnat_yes in Heqe. apply H in Heqe. solve by inversion. CASE "no". reflexivity. Qed. (* ====================================================================== *) (* The [contradiction] tactic *) (* Coq offers many tactics that provide useful shortcuts in situations that are possible -- but a little awkward -- to handle using just the basic tactics we've seen. One such situation that comes up often in the proofs we've been doing is where the context contains both [P] and [~P] (where [P] is some proposition) and we want Coq to notice that these are contradictory and finish proving the current goal. For example: *) Lemma contradiction_example : forall P Q : Prop, P -> ~ P -> Q. Proof. intros P Q H1 H2. unfold not in H2. apply H2 in H1. inversion H1. Qed. (* The [contradiction] tactic does this in one step: it examines the context and, if it finds both [P] and [~P] for any [P], immediately solves the current goal. *) Lemma contradiction_example' : forall P Q : Prop, P -> ~ P -> Q. Proof. intros P Q H1 H2. contradiction. Qed. (* ====================================================================== *) (* More on Coq automation *) Module AutomationExamples. Export SimplyTypedLambdaCalculus. (* ---------------------------------------------------------------------- *) (* [eapply] and [eassumption] *) (* Here is a very simple property of evaluation. *) Lemma evalmany__evalmany_app : forall t1 t1' t2, evalmany t1 t1' -> evalmany (t1 @ t2) (t1' @ t2). Proof. intros t1 t1' t2 H. induction H. CASE "refl". apply rtc'_refl. CASE "step". apply rtc'_step with (y := y @ t2). apply E_App1. assumption. assumption. Qed. (* Notice that, in the [apply] step, we need to explicitly name the "intermediate term" [y]. Sometimes this is good documentation and/or good mental hygiene -- it helps us think about what we are doing -- but often it is just annoying. The [eapply] tactic works just like [apply] except that, in situations where [apply] would fail with a message about uninstantiated metavariables, [eapply] turns these uninstantiated variables into "existential variables" -- placeholders for terms that will be resolved by other constraints that we encounter later in the proof. Similarly, the [eassumption] tactic is just like [assumption] (which, you'll recall, is a variant of [apply]), except that it is willing to work with assumptions involving existential variables. *) Lemma evalmany__evalmany_app' : forall t1 t1' t2, evalmany t1 t1' -> evalmany (t1 @ t2) (t1' @ t2). Proof. intros t1 t1' t2 H. induction H. CASE "refl". apply rtc'_refl. CASE "step". eapply rtc'_step. (* <---- note omitted "witness" *) apply E_App1. eassumption. assumption. Qed. (* The [eapply] tactic is particularly useful for working with existential quantifiers. If the goal is an existentially quantified statement, [eapply ex_intro] converts the witness into an existential variable. *) Lemma eapply_example_2 : forall t1 t1' t2, eval t1 t1' -> exists t', eval (t1 @ t2) t'. Proof. intros t1 t1' t2 H. eapply ex_intro. apply E_App1. eassumption. Qed. (* ---------------------------------------------------------------------- *) (* [auto] and [eauto] *) (* The [auto] tactic solves goals that are solvable by any combination of - [intros] - [apply] (used on some local hypothesis) - [reflexivity] Using [auto] is always "safe" in the sense that it will never fail and will never change the proof state: either it completely solves the current goal, or it does nothing. Here is a (rather contrived) example: *) Lemma auto_example_1 : forall P Q R S T U : Prop, (P -> Q) -> (P -> R) -> (T -> R) -> (S -> T -> U) -> ((P->Q) -> (P->S)) -> T -> P -> U. Proof. auto. Qed. (* By default, [auto] considers just the hypotheses in the current context. But we can also give it a list of lemmas and constructors to consider in addition to these, by writing [auto using ...]. *) Lemma auto_example_2 : forall t t' t'', eval t t' -> eval t' t'' -> (forall u, eval t t' -> eval t' u -> evalmany t u) -> eval t' t \/ t = t /\ evalmany t t''. Proof. auto using conj, or_introl, or_intror. Qed. (* There are some constructors and lemmas that are applied very often in proofs. We can tell [auto] to *always* consider these, instead of mentioning them explicitly each time. This is accomplished by writing Hint Resolve l. where [l] is a top-level lemma theorem, or a constructor of an inductively defined proposition (i.e., anything whose type is an implication). As a shorthand, we can write Hint Constructors c. to tell Coq to add *all* of the constructors from the inductive definition of [c] to the database used by [auto]. It is also sometimes necessary to add Hint Unfold d. where [d] is a defined symbol, so that [auto] knows to expand uses of [d] and enable further possibilities for applying lemmas that it knows about. *) Hint Constructors and. Hint Constructors or. Lemma auto_example_3 : forall t t' t'', eval t t' -> eval t' t'' -> (forall u, eval t t' -> eval t' u -> evalmany t u) -> eval t' t \/ t = t /\ evalmany t t''. Proof. auto. Qed. (* The [eauto] tactic works just like [auto], except that it uses [eapply] instead of [apply]. *) Lemma evalmany__evalmany_app'' : forall t1 t1' t2, evalmany t1 t1' -> evalmany (t1 @ t2) (t1' @ t2). Proof. intros t1 t1' t2 H. induction H. CASE "refl". apply rtc'_refl. CASE "step". eauto using rtc'_step, E_App1. Qed. (* Warning: It is easy to overuse [auto] and [eauto] and wind up with proofs that are impossible to understand later. For example, this version is probably a step too far: *) Lemma evalmany__evalmany_app''' : forall t1 t1' t2, evalmany t1 t1' -> evalmany (t1 @ t2) (t1' @ t2). Proof. intros t1 t1' t2 H. induction H; eauto using rtc'_refl, rtc'_step, E_App1. Qed. End AutomationExamples. (* ====================================================================== *) (* STLC with products *) Module STLCWithProducts. (* Our functional programming examples have made frequent use of PAIRS of values. The type of such pairs is called a PRODUCT TYPE. Let's now see how to add pairs and product types to our simply typed lambda-calculus. We won't bother proving anything about this language. Instead, we'll go on and look at the generalization of products to RECORDS, which are n-ary products with labeled fields. We'll prove all the standard properties for the more general system. *) Inductive ty : Set := | ty_base : nat -> ty | ty_arrow : ty -> ty -> ty | ty_prod : ty -> ty -> ty. Inductive tm : Set := | tm_var : nat -> tm | tm_app : tm -> tm -> tm | tm_abs : nat -> ty -> tm -> tm | tm_pair : tm -> tm -> tm | tm_proj1 : tm -> tm | tm_proj2 : tm -> tm. Notation A := (ty_base one). Notation B := (ty_base two). Notation C := (ty_base three). Notation "S --> T" := (ty_arrow S T) (at level 20, right associativity). Notation "[[ S , T ]]" := (ty_prod S T) (at level 21, right associativity). (* Note that I've changed the notation a little from the earlier presentation of STLC: we write ~ instead of \in. This version seems a little lighter and easier on the eyes. *) Notation "! n" := (tm_var n) (at level 39). Notation "\ x ~ T , t" := (tm_abs x T t) (at level 42). Notation "r @ s" := (tm_app r s) (at level 40, left associativity). Notation "[| r , s |]" := (tm_pair r s). Notation "r #1" := (tm_proj1 r) (at level 41). Notation "r #2" := (tm_proj2 r) (at level 41). Module Examples. Notation x := (S (S (S (S (S O))))). Notation y := (S (S (S (S (S (S O)))))). Notation z := (S (S (S (S (S (S (S O))))))). Definition nat_in_tm : nat -> tm := tm_var. Coercion nat_in_tm : nat >-> tm. Check ( [| x , y |] #1 ). End Examples. Reserved Notation "{ x |-> s } t" (at level 17). Fixpoint subst (x:nat) (s:tm) (t:tm) {struct t} : tm := match t with | !y => if eqnat x y then s else t | \y~T, t1 => if eqnat x y then t else \y~T, {x |-> s}t1 | t1 @ t2 => ({x |-> s}t1) @ ({x |-> s}t2) | [| t1 , t2 |] => [| {x |-> s}t1, {x |-> s}t2 |] | t #1 => ({x |-> s}t) #1 | t #2 => ({x |-> s}t) #2 end where "{ x |-> s } t" := (subst x s t). Inductive value : tm -> Prop := | v_abs : forall x T t, value (\x~T, t) | v_pair : forall t1 t2, value t1 -> value t2 -> value [| t1, t2 |]. Inductive eval : tm -> tm -> Prop := | E_AppAbs : forall x T t12 v2, value v2 -> eval ((\x~T, t12) @ v2) ({x |-> v2} t12) | E_App1 : forall t1 t1' t2, eval t1 t1' -> eval (t1 @ t2) (t1' @ t2) | E_App2 : forall v1 t2 t2', value v1 -> eval t2 t2' -> eval (v1 @ t2) (v1 @ t2') | E_PairBeta1 : forall t1 t2, value t1 -> value t2 -> eval ([|t1,t2|] #1) t1 | E_PairBeta2 : forall t1 t2, value t1 -> value t2 -> eval ([|t1,t2|] #2) t2 | E_Proj1 : forall t t', eval t t' -> eval (t #1) (t' #1) | E_Proj2 : forall t t', eval t t' -> eval (t #2) (t' #2) | E_Pair1 : forall t1 t1' t2, eval t1 t1' -> eval [|t1,t2|] [|t1',t2|] | E_Pair2 : forall t1 t2 t2', value t1 -> eval t2 t2' -> eval [|t1,t2|] [|t1,t2'|]. Notation context := (alist ty). Reserved Notation "Gamma |- t ~ T" (at level 69). Inductive typing : context -> tm -> ty -> Prop := | T_Var : forall Gamma x T, binds _ x T Gamma -> Gamma |- (!x) ~ T | T_Abs : forall Gamma x T1 T2 t, [(x,T1)] ++ Gamma |- t ~ T2 -> Gamma |- (\x~T1, t) ~ T1-->T2 | T_App : forall S T Gamma t1 t2, Gamma |- t1 ~ (S-->T) -> Gamma |- t2 ~ S -> Gamma |- (t1 @ t2) ~ T | T_Pair : forall Gamma t1 t2 T1 T2, Gamma |- t1 ~ T1 -> Gamma |- t2 ~ T2 -> Gamma |- [|t1,t2|] ~ [[T1,T2]] | T_Proj1 : forall Gamma t T1 T2, Gamma |- t ~ [[T1,T2]] -> Gamma |- t #1 ~ T1 | T_Proj2 : forall Gamma t T1 T2, Gamma |- t ~ [[T1,T2]] -> Gamma |- t #2 ~ T2 where "Gamma |- t ~ T" := (typing Gamma t T). End STLCWithProducts. (* ====================================================================== *) (* STLC with records *) Module STLCWithRecords. (* ---------------------------------------------------------------------- *) (* Syntax *) (* The most obvious way to generalize products to records would be this: *) Module FirstTry. Inductive ty : Set := | ty_base : nat -> ty | ty_arrow : ty -> ty -> ty | ty_rcd : (alist ty) -> ty. (* Unfortunately, we encounter here a limitation in Coq: this type does not automatically get the induction principle we expect -- the IH in the ty_rcd case doesn't give us any information about the [ty] elements of the list, making it useless for the proofs we want to do. *) Check ty_ind. (* It is *possible* to prove a better induction principle by hand, but the details are not pretty. *) End FirstTry. (* Fortunately, there is a different way of formalizing records that is, in some ways, even simpler and more natural: instead of using the existing [list] type, we can essentially include its constructors ("nil" and "cons") in the syntax of types: *) Inductive ty : Set := | ty_base : nat -> ty | ty_arrow : ty -> ty -> ty | ty_rcd_nil : ty | ty_rcd_cons : nat -> ty -> ty -> ty. (* The constructor [ty_rcd_nil] represents the EMPTY RECORD TYPE (i.e., the type whose only inhabitant is the empty record). The type [ty_rcd_cons k T1 T2] describes records whose first field is called [k] and has type [T1] and whose remaining fields are described by [T2]. *) (* Similarly, at the level of terms, we have constructors [tm_rcd_nil] -- the empty record -- and [tm_rcd_cons], which adds a single field at the front of another record. The [tm_rcd_proj] constructor generalizes the constructors [tm_proj1] and [tm_proj2] from the formalization of products -- i.e., [tm_rcd_proj t k] is pronounced "project the field named [k] from record [t]." *) Inductive tm : Set := | tm_var : nat -> tm | tm_app : tm -> tm -> tm | tm_abs : nat -> ty -> tm -> tm | tm_rcd_nil : tm | tm_rcd_cons : nat -> tm -> tm -> tm | tm_proj : tm -> nat -> tm. Tactic Notation "tm_cases" tactic(first) tactic(c) := first; [ c "tm_var" | c "tm_app" | c "tm_abs" | c "tm_rcd_nil" | c "tm_rcd_cons" | c "tm_proj" ]. Notation A := (ty_base one). Notation B := (ty_base two). Notation C := (ty_base three). Notation "S --> T" := (ty_arrow S T) (at level 20, right associativity). Notation "[[ ]]" := (ty_rcd_nil). Notation "[[ l1 ~ T1 ; T2 ]]" := (ty_rcd_cons l1 T1 T2). Notation "! n" := (tm_var n) (at level 39). Notation "\ x ~ T , t" := (tm_abs x T t) (at level 42). Notation "r @ s" := (tm_app r s) (at level 40, left associativity). Notation "r # s" := (tm_proj r s) (at level 41). Notation "[| |]" := (tm_rcd_nil). Notation "[| l1 == t1 ; t2 |]" := (tm_rcd_cons l1 t1 t2). (* Convenient abbreviations for multi-field record types and terms *) Notation "[[ l1 ~ T1 ]]" := ( [[ l1~T1; [[]] ]]). Notation "[[ l1 ~ T1 , l2 ~ T2 ]]" := ( [[ l1~T1; [[l2~T2]] ]]). Notation "[[ l1 ~ T1 , l2 ~ T2 , l3 ~ T3 ]]" := ( [[ l1~T1; [[l2~T2,l3~T3]] ]]). Notation "[| l1 == T1 |]" := ([| l1==T1; [||] |]). Notation "[| l1 == T1 , l2 == T2 |]" := ([| l1==T1; [|l2==T2|] |]). Notation "[| l1 == T1 , l2 == T2 , l3 == T3 |]" := ([| l1==T1; [|l2==T2,l3==T3|] |]). (* For example, the expression [[ x1~A, x2~B, x3~C ]] abbreviates [[ x1~A ; [[ x2~B ; [[ x3~C ; [[]] ]] ]] ]] i.e.: ty_rcd_cons x1 A (ty_rcd_cons x2 B (ty_rcd_cons x3 C ty_rcd_nil)) *) (* Note that we can write some programs in this language that we cannot write in languages with "ordinary records". For example, this term \x:[[k:A]], [| l==(\y:B,y); x |] describes a function that takes a record and adds a single field to it. We can also write "monstrous" terms like [| l==(\y:B,y); (\z:B,z) |] where the "tail" of a record is not a record. Such terms will be excluded by the typing rules. *) (* ---------------------------------------------------------------------- *) (* Operational semantics *) Reserved Notation "{ x |-> s } t" (at level 17). Fixpoint subst (x:nat) (s:tm) (t:tm) {struct t} : tm := match t with | !y => if eqnat x y then s else t | \y~T, t1 => if eqnat x y then t else \y~T, {x |-> s}t1 | t1 @ t2 => ({x |-> s}t1) @ ({x |-> s}t2) | [||] => [||] | [| l==t1; t2 |] => [| l=={x |-> s}t1; {x |-> s}t2 |] | t # k => ({x |-> s}t) # k end where "{ x |-> s } t" := (subst x s t). Inductive value : tm -> Prop := | v_abs : forall x T t, value (\x~T, t) | v_rcd_nil : value [||] | v_rcd_cons : forall l t1 t2, value t1 -> value t2 -> value [| l==t1; t2|]. Inductive eval : tm -> tm -> Prop := | E_AppAbs : forall x T t12 v2, value v2 -> eval ((\x~T, t12) @ v2) ({x |-> v2} t12) | E_App1 : forall t1 t1' t2, eval t1 t1' -> eval (t1 @ t2) (t1' @ t2) | E_App2 : forall v1 t2 t2', value v1 -> eval t2 t2' -> eval (v1 @ t2) (v1 @ t2') | E_Rcdcons1 : forall k t1 t1' t2, eval t1 t1' -> eval [|k==t1;t2|] [|k==t1';t2|] | E_Rcdcons2 : forall k t1 t2 t2', value t1 -> eval t2 t2' -> eval [|k==t1;t2|] [|k==t1;t2'|] | E_ProjRcdcons1 : forall k t1 t2, value t1 -> value t2 -> eval ([|k==t1;t2|] # k) t1 | E_ProjRcdcons2 : forall k k' t1 t2, value t1 -> value t2 -> k <> k' -> eval ([|k'==t1;t2|] # k) (t2 # k) | E_Proj : forall k t t', eval t t' -> eval (t # k) (t' # k). Tactic Notation "eval_cases" tactic(first) tactic(c) := first; [ c "E_AppAbs" | c "E_App1" | c "E_App2" | | c "E_Rcdcons1" | c "E_Rcdcons2" | c "E_ProjRcdcons1" | c "E_ProjRcdcons2" | c "E_Proj"]. Notation evalmany := (refl_trans_closure' _ eval). Inductive appears_free_in : nat -> tm -> Prop := | afi_var : forall x, appears_free_in x (! x) | afi_app1 : forall x t1 t2, appears_free_in x t1 -> appears_free_in x (t1 @ t2) | afi_app2 : forall x t1 t2, appears_free_in x t2 -> appears_free_in x (t1 @ t2) | afi_abs : forall x y T t1, eqnat x y = no -> appears_free_in x t1 -> appears_free_in x (\y~T, t1) | afi_rcdcons1 : forall x k t1 t2, appears_free_in x t1 -> appears_free_in x [|k==t1;t2|] | afi_rcdcons2 : forall x k t1 t2, appears_free_in x t2 -> appears_free_in x [|k==t1;t2|]. Definition closed (t:tm) := forall x, ~ appears_free_in x t. (* ---------------------------------------------------------------------- *) (* Typing *) Notation context := (alist ty). Definition empty : context := nil _. (* Generalizing our abstract syntax from records (from alists to the nil/cons presentation) introduces the possibility of writing strange terms like this [| l==x; (\y:A,y) |] where the "tail" of a record value is not actually a record value! To make sure that our typing rules exclude such "monsters," we need to be able to look at a type and check that it is a "proper record type" consisting only of ty_rcd_nil and ty_rcd_cons constructors. (To see why this is needed, imagine dropping the [record_type] premise below and note that the above term would then be typable!) *) Inductive record_type : ty -> Prop := | rt_nil : record_type [[]] | rt_cons : forall k T1 T2, record_type T2 -> record_type [[k~T1;T2]]. Fixpoint ty_rcd_lookup (k:nat) (t:ty) {struct t} : option ty := match t with | ty_rcd_cons k' T' t' => if eqnat k k' then Some _ T' else ty_rcd_lookup k t' | _ => None _ end. Definition ty_rcd_binds (k:nat) (Tk:ty) (T:ty) := ty_rcd_lookup k T = Some _ Tk. Reserved Notation "Gamma |- t ~ T" (at level 69). Inductive typing : context -> tm -> ty -> Prop := | T_Var : forall Gamma x T, binds _ x T Gamma -> Gamma |- (!x) ~ T | T_Abs : forall Gamma x T1 T2 t, [(x,T1)] ++ Gamma |- t ~ T2 -> Gamma |- (\x~T1, t) ~ T1-->T2 | T_App : forall S T Gamma t1 t2, Gamma |- t1 ~ (S-->T) -> Gamma |- t2 ~ S -> Gamma |- (t1 @ t2) ~ T | T_Rcdnil : forall Gamma, Gamma |- [||] ~ ty_rcd_nil | T_Rcdcons : forall Gamma k t1 t2 T1 T2, Gamma |- t1 ~ T1 -> Gamma |- t2 ~ T2 -> record_type T2 -> Gamma |- [|k==t1;t2|] ~ [[k~T1;T2]] | T_Proj : forall Gamma k Tk t T, Gamma |- t ~ T -> record_type T -> ty_rcd_binds k Tk T -> Gamma |- t # k ~ Tk where "Gamma |- t ~ T" := (typing Gamma t T). Tactic Notation "typing_cases" tactic(first) tactic(c) := first; [ c "T_Var" | c "T_Abs" | c "T_App" | c "T_Rcdnil" | c "T_Rcdcons" | c "T_Proj" ]. (* ---------------------------------------------------------------------- *) (* Examples *) Module Examples. Notation l := (S (S (S O))). Notation k := (S (S (S (S O)))). Notation x := (S (S (S (S (S O))))). Notation y := (S (S (S (S (S (S O)))))). Notation z := (S (S (S (S (S (S (S O))))))). Notation r := (S (S (S (S (S (S (S (S O)))))))). Notation s := (S (S (S (S (S (S (S (S (S O))))))))). Definition nat_in_tm : nat -> tm := tm_var. Coercion nat_in_tm : nat >-> tm. Check ( [[ ]] ). Check ( [[ l ~ A ]] ). Check ( [[ l ~ A; A ]] ). Check ( [[ l ~ A, k ~ B ]] ). Check ( [[ l ~ A, k ~ B, l ~ C ]] ). Check ( [| |] ). Check ( [| l == x |] ). Check ( [| l == x; x |] ). Check ( [| l == x, k == y |] ). Check ( [| l == x, k == y, l == z |] ). Lemma typing_example : forall t, [(t,A)] |- (\r~[[x~A]], r # x) @ [|x==t|] ~ A. Proof. intros t. apply T_App with (S:=[[x~A]]). apply T_Abs. apply T_Proj with (T:=[[x~A]]). apply T_Var. unfold binds. reflexivity. apply rt_cons. apply rt_nil. unfold ty_rcd_binds. reflexivity. apply T_Rcdcons. apply T_Var. unfold binds. simpl. rewrite eqnat_n_n. reflexivity. apply T_Rcdnil. apply rt_nil. Qed. Lemma typing_example_2 : empty |- (\r~[[x~A-->A,y~B-->B]], r # y) @ [|x==(\z~A,z),y==(\z~B,z)|] ~ B-->B. Proof. (* Feel free to use the automation features described above in this proof. However, if you are not confident about how the type system works, you may want to carry out the proof first using the basic features (apply instead of eapply, in particular) and then compress it using automation. *) (* SOLUTION *) eapply T_App. apply T_Abs. eapply T_Proj. apply T_Var. unfold binds. simpl. reflexivity. apply rt_cons. apply rt_cons. apply rt_nil. unfold ty_rcd_binds. simpl. reflexivity. apply T_Rcdcons. apply T_Abs. apply T_Var. unfold binds. simpl. reflexivity. apply T_Rcdcons. apply T_Abs. apply T_Var. unfold binds. simpl. reflexivity. apply T_Rcdnil. apply rt_nil. apply rt_cons. apply rt_nil. Qed. Lemma typing_example_3 : exists T, empty |- (\r~[[x~A-->A]], [|y==(\z~B,z); r|]) @ [|x==(\z~A,z)|] ~ T. Proof. (* Before starting to prove this lemma (or the one above!), make sure you understand what it is saying. (To test whether you understand it, put it aside, do something else for five minutes, and try to write it out from scratch without looking.) *) (* SOLUTION *) eapply ex_intro. eapply T_App. apply T_Abs. eapply T_Rcdcons. apply T_Abs. apply T_Var. unfold binds. simpl. reflexivity. apply T_Var. unfold binds. simpl. reflexivity. apply rt_cons. apply rt_nil. apply T_Rcdcons. apply T_Abs. apply T_Var. unfold binds. simpl. reflexivity. apply T_Rcdnil. apply rt_nil. Qed. Lemma typing_nonexample : forall t, ~ exists T, [(t,A)] |- (\r~[[x~A]], r # x) @ [|x==t, y==t|] ~ T. Proof. intros t C. destruct C. inversion H. subst. clear H. inversion H5. subst. clear H5. clear H8. inversion H4. inversion H1. rewrite eqnat_n_n in H6. inversion H6. subst. clear H1. clear H6. inversion H7. subst. clear H7. clear H9. inversion H8. subst. inversion H3. Qed. End Examples. (* ---------------------------------------------------------------------- *) (* Properties of typing *) Lemma drop_duplicate_binding : forall Gamma x U t T, Gamma ++ [(x,U)] |- t ~ T -> (exists V, binds _ x V Gamma) -> Gamma |- t ~ T. Proof. intros Gamma x U t. generalize dependent Gamma. (tm_cases (induction t) CASE); intros Gamma T H B; inversion H; subst. CASE "tm_var". apply T_Var. remember (eqnat n x) as eq. destruct eq. SCASE "x = n". apply eq_symm in Heqeq. assert (n = x). apply eqnat_yes. assumption. subst n. unfold binds. unfold binds in H2. unfold binds in B. inversion B. assert (lookup ty x (Gamma ++ [(x, U)]) = Some _ witness). apply shadowed_binding with (v:=U). assumption. rewrite -> H2 in H1. inversion H1. subst. assumption. SCASE "x <> n". unfold binds. apply not_last_binding with (j:=x)(v:=U). apply eq_symm. assumption. unfold binds in H2. assumption. CASE "tm_app". apply T_App with (S:=S). apply IHt1. assumption. assumption. apply IHt2. assumption. assumption. CASE "tm_abs". apply T_Abs. apply IHt. simpl. assumption. unfold binds. simpl. remember (eqnat x n) as E. destruct E. SCASE "x = x0". apply ex_intro with (witness := t). reflexivity. SCASE "x <> x0". unfold binds in B. assumption. CASE "tm_rcd_nil". apply T_Rcdnil. CASE "tm_rcd_cons". apply T_Rcdcons. apply IHt1. assumption. assumption. apply IHt2. assumption. assumption. assumption. CASE "tm_proj". apply T_Proj with (T:=T0). apply IHt. assumption. assumption. assumption. assumption. Qed. Lemma drop_duplicate_binding' : forall Gamma x U t T, Gamma ++ [(x,U)] |- t ~ T -> (exists V, binds _ x V Gamma) -> Gamma |- t ~ T. Proof. (* Re-do this proof using Coq's automation features to make the arguments as concise as possible, while remaining readable. (Use your own taste to decide when the proofs are concise enough, remembering that "shorter is not always better"!) *) (* SOLUTION *) intros Gamma x U t. generalize dependent Gamma. (tm_cases (induction t) CASE); intros Gamma T H B; inversion H; subst. CASE "tm_var". apply T_Var. remember (eqnat n x) as eq. destruct eq. SCASE "x = n". apply eq_symm in Heqeq. assert (n = x). apply eqnat_yes. assumption. subst n. unfold binds. unfold binds in H2. unfold binds in B. inversion B. assert (lookup ty x (Gamma ++ [(x, U)]) = Some _ witness). apply shadowed_binding with (v:=U). assumption. rewrite -> H2 in H1. inversion H1. auto. SCASE "x <> n". unfold binds. apply not_last_binding with (j:=x)(v:=U). auto. auto. CASE "tm_app". apply T_App with (S:=S); auto. CASE "tm_abs". apply T_Abs. apply IHt. auto. unfold binds. simpl. remember (eqnat x n) as E. destruct E. SCASE "x = x0". eapply ex_intro. auto. SCASE "x <> x0". auto. CASE "tm_rcd_nil". apply T_Rcdnil. CASE "tm_rcd_cons". apply T_Rcdcons; auto. CASE "tm_proj". eapply T_Proj; eauto. Qed. Lemma weakening_preserves_typing : forall Gamma x U t T, Gamma |- t ~ T -> Gamma ++ [(x,U)] |- t ~ T. Proof. intros Gamma x U t T H. typing_cases (induction H) CASE. CASE "T_Var". apply T_Var. unfold binds. apply found_before. unfold binds in H. assumption. CASE "T_Abs". apply T_Abs. simpl in IHtyping. assumption. CASE "T_App". apply T_App with (S := S). assumption. assumption. CASE "T_Rcdnil". apply T_Rcdnil. CASE "T_Rcdcons". apply T_Rcdcons. assumption. assumption. assumption. CASE "T_Proj". apply T_Proj with (T:=T). assumption. assumption. assumption. Qed. Hint Unfold binds. Lemma weakening_preserves_typing' : forall Gamma x U t T, Gamma |- t ~ T -> Gamma ++ [(x,U)] |- t ~ T. Proof. (* Compress this proof using Coq's automation features. *) (* SOLUTION *) intros Gamma x U t T H. typing_cases (induction H) CASE. CASE "T_Var". auto using T_Var, found_before. CASE "T_Abs". auto using T_Abs. CASE "T_App". eauto 6 using T_App. CASE "T_Rcdnil". auto using T_Rcdnil. CASE "T_Rcdcons". auto using T_Rcdcons. CASE "T_Proj". eauto 6 using T_Proj. Qed. Lemma weakening_empty_preserves_typing : forall Gamma t T, empty |- t ~ T -> Gamma |- t ~ T. Proof. intros Gamma t T H. assert (forall Delta, reverse _ Delta |- t ~ T). CASE "Pf of assertion". induction Delta. SCASE "Delta empty". assumption. SCASE "Delta cons". simpl. destruct x. assert ( snoc _ (reverse _ Delta) (n,t0) = (reverse _ Delta) ++ [(n,t0)]). apply snoc_append. rewrite -> H0. apply weakening_preserves_typing. assumption. assert (reverse _ (reverse _ Gamma) = Gamma). apply reverse_reverse. rewrite <- H1. apply H0. Qed. Lemma weakening_empty_preserves_typing' : forall Gamma t T, empty |- t ~ T -> Gamma |- t ~ T. Proof. (* Compress this proof using Coq's automation features. *) (* SOLUTION *) intros Gamma t T H. assert (forall Delta, reverse _ Delta |- t ~ T). CASE "Pf of assertion". induction Delta. SCASE "Delta empty". auto. SCASE "Delta cons". simpl. destruct x. assert ( snoc _ (reverse _ Delta) (n,t0) = (reverse _ Delta) ++ [(n,t0)]). apply snoc_append. rewrite -> H0. auto using weakening_preserves_typing. assert (reverse _ (reverse _ Gamma) = Gamma). apply reverse_reverse. rewrite <- H1. auto. Qed. Lemma substitution_preserves_typing : forall Gamma x U v t S, Gamma ++ [(x,U)] |- t ~ S -> empty |- v ~ U -> not_bound_in _ x Gamma -> Gamma |- {x|->v}t ~ S. Proof. intros Gamma x U v t S Ht Hv. generalize dependent Gamma. generalize dependent S. (tm_cases (induction t) CASE); intros S Gamma H N; inversion H; subst; simpl. CASE "tm_var". remember (eqnat x n) as test. destruct test. SCASE "x = n". apply eq_symm in Heqtest. apply eqnat_yes in Heqtest. subst n. assert (lookup ty x (Gamma ++ [(x, U)]) = Some _ U). SSCASE "Proof of assertion". apply last_binding. assumption. unfold binds in H2. rewrite -> H0 in H2. inversion H2. subst U. apply weakening_empty_preserves_typing. assumption. SCASE "x <> x0". apply T_Var. unfold binds. apply not_last_binding with (j:=x)(v:=U). apply eqnat_symm. apply eq_symm. assumption. unfold binds in H2. assumption. CASE "tm_app". apply T_App with (S:=S0). apply IHt1. assumption. assumption. apply IHt2. assumption. assumption. CASE "tm_abs". rename t into T1. simpl. remember (eqnat x n) as test. destruct test. SCASE "x = n". apply eq_symm in Heqtest. apply eqnat_yes in Heqtest. subst n. apply T_Abs. apply drop_duplicate_binding with (x:=x)(U:=U). assumption. unfold binds. simpl. assert (eqnat x x = yes). apply eqnat_n_n. rewrite -> H0. apply ex_intro with (witness := T1). reflexivity. SCASE "x <> x0". apply T_Abs. apply IHt. simpl. assumption. unfold not_bound_in. simpl. apply eq_symm in Heqtest. rewrite Heqtest. assumption. CASE "tm_rcd_nil". apply T_Rcdnil. (* SOLUTION *) CASE "tm_rcd_cons". apply T_Rcdcons. apply IHt1. assumption. assumption. apply IHt2. assumption. assumption. assumption. CASE "tm_proj". apply T_Proj with (T:=T). apply IHt. assumption. assumption. assumption. assumption. Qed. Lemma substitution_preserves_typing' : forall Gamma x U v t S, Gamma ++ [(x,U)] |- t ~ S -> empty |- v ~ U -> not_bound_in _ x Gamma -> Gamma |- {x|->v}t ~ S. Proof. (* Compress this proof using Coq's automation features. *) (* SOLUTION *) intros Gamma x U v t S Ht Hv. generalize dependent Gamma. generalize dependent S. (tm_cases (induction t) CASE); intros S Gamma H N; inversion H; subst; simpl. CASE "tm_var". remember (eqnat x n) as test. destruct test. SCASE "x = n". apply eq_symm in Heqtest. apply eqnat_yes in Heqtest. subst n. assert (lookup ty x (Gamma ++ [(x, U)]) = Some _ U). SSCASE "Proof of assertion". apply last_binding. assumption. unfold binds in H2. rewrite -> H0 in H2. inversion H2. subst U. apply weakening_empty_preserves_typing. assumption. SCASE "x <> x0". apply T_Var. unfold binds. apply not_last_binding with (j:=x)(v:=U). apply eqnat_symm. apply eq_symm. assumption. unfold binds in H2. assumption. CASE "tm_app". apply T_App with (S:=S0); auto. CASE "tm_abs". rename t into T1. simpl. remember (eqnat x n) as test. destruct test. SCASE "x = n". apply eq_symm in Heqtest. apply eqnat_yes in Heqtest. subst n. apply T_Abs. apply drop_duplicate_binding with (x:=x)(U:=U). assumption. unfold binds. simpl. assert (eqnat x x = yes). apply eqnat_n_n. rewrite -> H0. apply ex_intro with (witness := T1). reflexivity. SCASE "x <> x0". apply T_Abs. apply IHt. simpl. assumption. unfold not_bound_in. simpl. apply eq_symm in Heqtest. rewrite Heqtest. assumption. CASE "tm_rcd_nil". apply T_Rcdnil. CASE "tm_rcd_cons". apply T_Rcdcons; auto. CASE "tm_proj". eapply T_Proj; eauto. Qed. Theorem preservation : forall t t' T, empty |- t ~ T -> eval t t' -> empty |- t' ~ T. Proof. remember empty as Gamma. intros t t' T Hty He. generalize dependent t'. (typing_cases (induction Hty) CASE); intros t' He; inversion He; subst. CASE "T_App". SCASE "E_AppAbs". inversion Hty1. subst. assert ((nil _) ++ (nil _) |- {x |-> t2}t12 ~ T) as Ht12. SSCASE "Proof of assertion". apply substitution_preserves_typing with (U:=S). simpl. assumption. assert (not_bound_in ty x (nil _)). SSSCASE "Pf of subassertion". apply empty_alist_binds_nothing. simpl. assumption. simpl. apply empty_alist_binds_nothing. assumption. CASE "T_App". SCASE "E_App1". apply T_App with (S:=S). apply IHHty1. reflexivity. assumption. assumption. CASE "T_App". SCASE "E_App2". apply T_App with (S:=S). assumption. apply IHHty2. reflexivity. assumption. (* SOLUTION *) CASE "T_Rcdcons". SCASE "E_Rcdcons1". apply T_Rcdcons. apply IHHty1. reflexivity. assumption. assumption. assumption. SCASE "E_Rcdcons2". apply T_Rcdcons. assumption. apply IHHty2. reflexivity. assumption. assumption. CASE "T_Proj". SCASE "E_ProjRcdcons1". inversion Hty; subst. unfold ty_rcd_binds in H0. simpl in H0. rewrite eqnat_n_n in H0. inversion H0. subst. assumption. SCASE "E_ProjRcdcons2". inversion Hty; subst. unfold ty_rcd_binds in H0. simpl in H0. assert (eqnat k k' = no). apply eqnat_n_n'. assumption. rewrite H1 in H0. apply T_Proj with (T:=T2). assumption. assumption. assumption. SCASE "E_Proj". apply T_Proj with (T:=T). apply IHHty. reflexivity. assumption. assumption. assumption. Qed. Theorem preservation' : forall t t' T, empty |- t ~ T -> eval t t' -> empty |- t' ~ T. Proof. (* Compress this proof using Coq's automation features. *) (* SOLUTION *) remember empty as Gamma. intros t t' T Hty He. generalize dependent t'. (typing_cases (induction Hty) CASE); intros t' He; inversion He; subst. CASE "T_App". SCASE "E_AppAbs". inversion Hty1. subst. assert ((nil _) ++ (nil _) |- {x |-> t2}t12 ~ T) as Ht12. SSCASE "Proof of assertion". apply substitution_preserves_typing with (U:=S); auto. assert (not_bound_in ty x (nil _)). SSSCASE "Pf of subassertion". apply empty_alist_binds_nothing. auto. auto. CASE "T_App". SCASE "E_App1". apply T_App with (S:=S); auto. CASE "T_App". SCASE "E_App2". apply T_App with (S:=S); auto. CASE "T_Rcdcons". SCASE "E_Rcdcons1"; auto using T_Rcdcons. SCASE "E_Rcdcons2"; auto using T_Rcdcons. CASE "T_Proj". SCASE "E_ProjRcdcons1". inversion Hty; subst. unfold ty_rcd_binds in H0. simpl in H0. rewrite eqnat_n_n in H0. inversion H0. subst. assumption. SCASE "E_ProjRcdcons2". inversion Hty; subst. unfold ty_rcd_binds in H0. simpl in H0. assert (eqnat k k' = no). apply eqnat_n_n'. assumption. rewrite H1 in H0. eapply T_Proj; eassumption. SCASE "E_Proj". eapply T_Proj; eauto. Qed. (* The progress theorem for STLC in Lecture 17 included a premise that the term [t] being evaluated was closed. Actually, this premise follows from the fact that [t] is typable in the empty context... *) Lemma typable_in_empty_context__closed : forall t T, empty |- t ~ T -> closed t. Proof. (* SOLUTION *) (* Generalize the property to get an IH we can use. *) assert (forall Gamma t T x, Gamma |- t ~ T -> not_bound_in _ x Gamma -> ~ appears_free_in x t) as LEMMA. CASE "Pf of main assertion". intros Gamma t T x H N. (typing_cases (induction H) SCASE); intros C; inversion C; subst. SCASE "T_Var". unfold binds in H. unfold not_bound_in in N. rewrite -> N in H. solve by inversion. SCASE "T_Abs". assert (~ appears_free_in x t). SSCASE "Pf of assertion". apply IHtyping. unfold not_bound_in. simpl. rewrite H3. unfold not_bound_in in N. assumption. contradiction. SCASE "T_App". (* with x appearing free in t1 *) assert (~ appears_free_in x t1). SSCASE "Pf of assertion". auto. contradiction. SCASE "T_App". (* with x appearing free in t2 *) assert (~ appears_free_in x t2). SSCASE "Pf of assertion". auto. contradiction. SCASE "T_Rcdcons". (* with x appearing free in t1 *) assert (~ appears_free_in x t1). SSCASE "Pf of assertion". auto. contradiction. SCASE "T_Rcdcons". (* with x appearing free in t2 *) assert (~ appears_free_in x t2). SSCASE "Pf of assertion". auto. contradiction. intros t T H. unfold closed. intros x. apply LEMMA with (Gamma:=empty)(T:=T). assumption. unfold empty. apply empty_alist_binds_nothing. Qed. Theorem progress : forall t T, empty |- t ~ T -> value t \/ exists t', eval t t'. Proof. intros t T Hty. remember empty as Gamma. (typing_cases (induction Hty) (CASE)); subst. CASE "T_Var". solve by inversion. CASE "T_Abs". apply or_introl. apply v_abs. CASE "T_App". assert (value t1 \/ (exists t' : tm, eval t1 t')) as IH1. apply IHHty1. reflexivity. assert (value t2 \/ (exists t' : tm, eval t2 t')) as IH2. apply IHHty2. reflexivity. apply or_intror. inversion IH1. SCASE "t1 value". inversion IH2; subst. SSCASE "t1 value / t2 value". inversion H. subst. apply ex_intro with (witness := {x |-> t2} t). apply E_AppAbs. assumption. subst. solve by inversion. subst. solve by inversion. SSCASE "t1 value / t2 steps". inversion H0. apply ex_intro with (witness := tm_app t1 witness). apply E_App2. assumption. assumption. SCASE "t1 steps". inversion H. apply ex_intro with (witness := tm_app witness t2). apply E_App1. assumption. CASE "T_Rcdnil". apply or_introl. apply v_rcd_nil. (* The cases for T_Rcdcons and T_Proj are left for you to fill in. Here is a sketch of the T_Proj case: - We must show that [t # k] either is a value or can take a step. By the IH, there are two possibilities: either [t] itself it a value, or it can take a step. -- If [t] is a value, then by inversion it must be an abstraction, a nil-record, or a cons-record. The first two cases are contradictory (the premises of T_Sub tell us that [t] must have at least the field [k]). In the third case, there are two possibilities: -- If the first field of [t] is labeled [k], then the rule E_ProjRcdcons1 applies, and [t#k] can take a step. -- If the first field of [t] is *not* labeled [k], then the rule E_ProjRcdcons2 applies, and again [t#k] can take a step. -- If [t] can take a step, then by T_Proj [t#k] can take the same step. *) (* SOLUTION *) CASE "T_Rcdcons". assert (value t1 \/ (exists t' : tm, eval t1 t')) as IH1. apply IHHty1. reflexivity. assert (value t2 \/ (exists t' : tm, eval t2 t')) as IH2. apply IHHty2. reflexivity. inversion IH1. SCASE "t1 value". inversion IH2; subst. SSCASE "t1 value / t2 value". apply or_introl. apply v_rcd_cons. assumption. assumption. SSCASE "t1 value / t2 steps". apply or_intror. inversion H1. apply ex_intro with (witness := [|k==t1;witness|]). apply E_Rcdcons2. assumption. assumption. SCASE "t1 steps". apply or_intror. inversion H0. apply ex_intro with (witness := [|k==witness;t2|]). apply E_Rcdcons1. assumption. CASE "T_Proj". apply or_intror. assert (value t \/ (exists t' : tm, eval t t')) as IH. apply IHHty. reflexivity. clear IHHty. inversion IH. SCASE "t is a value". inversion H1; subst. SSCASE "t is an abstraction (contradictory)". inversion Hty; subst. inversion H. SSCASE "t is an empty record (contradictory)". inversion Hty; subst. inversion H0. SSCASE "t is a record cons (interesting case)". inversion Hty; subst. inversion H0. remember (eqnat k l) as r. destruct r. SSSCASE "head label". apply eq_symm in Heqr. apply eqnat_yes in Heqr. subst. apply ex_intro with (witness := t1). apply E_ProjRcdcons1; assumption. SSSCASE "another label". apply eq_symm in Heqr. apply eqnat_no in Heqr. apply ex_intro with (witness := t2 # k). apply E_ProjRcdcons2; assumption. SCASE "t steps to some t'". inversion H1. apply ex_intro with (witness := witness # k). apply E_Proj. assumption. Qed. Theorem progress' : forall t T, empty |- t ~ T -> value t \/ exists t', eval t t'. Proof. (* Compress this proof using Coq's automation features. *) (* SOLUTION *) intros t T Hty. remember empty as Gamma. (typing_cases (induction Hty) (CASE)); subst. CASE "T_Var". solve by inversion. CASE "T_Abs". apply or_introl. apply v_abs. CASE "T_App". assert (value t1 \/ (exists t' : tm, eval t1 t')) as IH1. auto. assert (value t2 \/ (exists t' : tm, eval t2 t')) as IH2. auto. apply or_intror. inversion IH1. SCASE "t1 value". inversion IH2; subst. SSCASE "t1 value / t2 value". inversion H. subst. apply ex_intro with (witness := {x |-> t2} t). auto using E_AppAbs. subst. solve by inversion. subst. solve by inversion. SSCASE "t1 value / t2 steps". inversion H0. eauto using ex_intro, E_App2. SCASE "t1 steps". inversion H. eauto using ex_intro, E_App1. CASE "T_Rcdnil". apply or_introl. apply v_rcd_nil. (* SOLUTION *) CASE "T_Rcdcons". assert (value t1 \/ (exists t' : tm, eval t1 t')) as IH1. auto. assert (value t2 \/ (exists t' : tm, eval t2 t')) as IH2. auto. inversion IH1. SCASE "t1 value". inversion IH2; subst. SSCASE "t1 value / t2 value". auto using or_introl, v_rcd_cons. SSCASE "t1 value / t2 steps". apply or_intror. inversion H1. eauto using ex_intro, E_Rcdcons2. SCASE "t1 steps". apply or_intror. inversion H0. eauto using ex_intro, E_Rcdcons1. CASE "T_Proj". apply or_intror. assert (value t \/ (exists t' : tm, eval t t')) as IH. auto. inversion IH. SCASE "t is a value". inversion H1; subst. SSCASE "t is an abstraction (contradictory)". inversion Hty; subst. inversion H. SSCASE "t is an empty record (contradictory)". inversion Hty; subst. inversion H0. SSCASE "t is a record cons (interesting case)". inversion Hty; subst. inversion H0. remember (eqnat k l) as r. destruct r. SSSCASE "head label". apply eq_symm in Heqr. apply eqnat_yes in Heqr. subst. eauto using ex_intro, E_ProjRcdcons1. SSSCASE "another label". apply eq_symm in Heqr. apply eqnat_no in Heqr. eauto using ex_intro, E_ProjRcdcons2. SCASE "t steps to some t'". inversion H1. eauto using ex_intro, E_Proj. Qed. End STLCWithRecords.