CS252r Midterm take home exam.

Please complete the exercises at the bottom of this file and turn in your modified source code by emailing it to greg@eecs.harvard.edu no later than class on Oct 21. You should primarily work alone, but can of course talk to anyone regarding questions about Coq.
Require Import Eqdep.
Require Import String.
Require Import List.
Require Import Omega.
Require Import Recdef.
Set Implicit Arguments.
Unset Automatic Introduction.
Local Open Scope string_scope.

Abstract Syntax

Definition var := string.

Inductive binop : Set := Plus_op | Minus_op | Eq_op.

Inductive exp : Set :=
| Var_e : var -> exp
| Lam_e : var -> exp -> exp
| App_e : exp -> exp -> exp
| Num_e : nat -> exp
| Binop_e : binop -> exp -> exp -> exp
| Bool_e : bool -> exp
| If_e : exp -> exp -> exp -> exp.

Inductive value : Set :=
| Lam_v : list (var * value) -> var -> exp -> value
| Num_v : nat -> value
| Bool_v : bool -> value.

| Value : value -> answer

Definition tvar := nat.
Inductive type : Set :=
| Tvar_t : tvar -> type
| Nat_t : type
| Bool_t : type
| Arrow_t : type -> type -> type.

Environments

Definition env_t(A:Type) := list (var * A).
Fixpoint lookup A (env:env_t A) (x:var) : option A :=
match env with
| nil => None
| (y,v)::env' => if string_dec x y then Some v else lookup env' x
end.

Expression Typing

Reserved Notation "G |-- e ; t" (at level 80).

Inductive hasType : env_t type -> exp -> type -> Prop :=
| Var_ht : forall G x t,
lookup G x = Some t ->
G |-- Var_e x ; t
| Lam_ht : forall G x e t1 t2,
((x,t1)::G) |-- e ; t2 ->
G |-- Lam_e x e ; Arrow_t t1 t2
| App_ht : forall G e1 e2 t1 t2,
G |-- e1 ; (Arrow_t t1 t2) ->
G |-- e2 ; t1 ->
G |-- App_e e1 e2 ; t2
| Num_ht : forall G n,
G |-- Num_e n ; Nat_t
| Binop_ht : forall G b e1 e2,
G |-- e1 ; Nat_t ->
G |-- e2 ; Nat_t ->
G |-- Binop_e b e1 e2 ; match b with | Eq_op => Bool_t | _ => Nat_t end
| Bool_ht : forall G b,
G |-- Bool_e b ; Bool_t
| If_ht : forall G e1 e2 e3 t,
G |-- e1 ; Bool_t ->
G |-- e2 ; t ->
G |-- e3 ; t ->
G |-- If_e e1 e2 e3 ; t
where "G |-- e ; t" := (hasType G e t) : typing_scope.
Hint Constructors hasType : type_db.

Section ValueTyping.
Local Open Scope typing_scope.

Notice that we need value and environments definitions to be mutually recursive. Also notice that by choosing inductive definitions, we rule out "circular" lambdas. If we picked CoInductive instead, we could model this sort of case...
Inductive valType : value -> type -> Prop :=
| Num_vt : forall n, valType (Num_v n) Nat_t
| Bool_vt : forall b, valType (Bool_v b) Bool_t
| Lam_vt : forall env x e G t1 t2,
envType env G ->
(x,t1)::G |-- e ; t2 ->
valType (Lam_v env x e) (Arrow_t t1 t2)
with envType : env_t value -> env_t type -> Prop :=
| Nil_et : envType nil nil
| Cons_et : forall x v t env G,
valType v t ->
envType env G ->
envType ((x,v)::env) ((x,t)::G).
End ValueTyping.
Hint Constructors valType envType : type_db.

We don't really need this induction scheme, but whenever I have mutually inductive definitions, I always generate this in case I do need it.
Scheme valType_ind_2 := Induction for valType Sort Prop
with envType_ind_2 := Induction for envType Sort Prop.
Combined Scheme valenvType_ind from valType_ind_2, envType_ind_2.

Inductive ansType : answer -> type -> Prop :=
| Val_ans : forall v t, valType v t -> ansType (Value v) t.
Hint Constructors ansType : type_db.

Binop Evaluation

Definition eval_binop(b:binop)(v1 v2:value) : answer :=
match b, v1, v2 with
| Plus_op, Num_v n1, Num_v n2 => Value (Num_v (n1+n2))
| Minus_op, Num_v n1, Num_v n2 => Value (Num_v (n1-n2))
| Eq_op, Num_v n1, Num_v n2 =>
Value (Bool_v (if eq_nat_dec n1 n2 then true else false))
| _, _, _ => TypeError
end.

We're going to use the Haskell-like approach, but instead of producing values, we'll produce computations. A computation is simply a way to reify the monad, except that we'll add an extra case for "delayed" expressions that we haven't bothered to compile yet. This will allow us to break the cycle in our semantics, at the price of needing an operational definition of the meaning of a computation.

Our denotations will be computations. Notice that we use the Coq function space to represent Bind. That will greatly simplify our treatment of substitution in our semantics, and allow us to use an arbitrary Coq function to build a continuation.
Inductive comp :=
| Ret : answer -> comp
| Bind : comp -> (value -> comp) -> comp
| Delay : exp -> list (var * value) -> comp.

Notation "'ret' x" := (Ret (Value x)) (at level 75) : comp_scope.
Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2))
(right associativity, at level 84, c1 at next level) : comp_scope.
Local Open Scope comp_scope.
Definition Terr := Ret TypeError.

Translate expressions to a computation -- this is exactly the same as the Haskell approach except that we Delay the compilation of the appliation of a function -- this is the only place where Coq can't conclude that the compilation will terminate.
Fixpoint compile (e:exp) (env:env_t value) : comp :=
match e with
| Var_e x =>
match lookup env x with
| None => Terr
| Some v => ret v
end
| Lam_e x e => ret (Lam_v env x e)
| App_e e1 e2 =>
v1 <- compile e1 env ;
v2 <- compile e2 env ;
match v1 with
| Lam_v env' x e' => Delay e' ((x,v2)::env')
| _ => Terr
end
| Num_e n => ret Num_v n
| Binop_e b e1 e2 =>
v1 <- compile e1 env ;
v2 <- compile e2 env ;
Ret (eval_binop b v1 v2)
| Bool_e b => ret Bool_v b
| If_e e1 e2 e3 =>
v1 <- compile e1 env ;
match v1 with
| Bool_v b =>
if b then compile e2 env else compile e3 env
| _ => Terr
end
end.

Now we can define a variety of different kinds of operational semantics for computations, including big-step, small-step, and even a partial function (since steps are deterministic.) The point is that the compilation doesn't preclude our modeling "effects" such as non-determinism (i.e., threads) or state or exceptions. We just need to have the right monadic structure to support those things.

The important point is that there are many, many fewer rules or cases to deal with in the computation space. And this will scale a lot better as we grow the source language.

A Big-Step Operational Semantics for Computations
Inductive run : comp -> answer -> Prop :=
| run_Ret : forall a, run (Ret a) a
| run_Delay : forall env e v,
run (compile e env) v -> run (Delay e env) v
| run_Bind_value : forall c f v a,
run c (Value v) -> run (f v) a -> run (Bind c f) a
| run_Bind_typeerror : forall c f,
run c TypeError -> run (Bind c f) TypeError.
Hint Constructors run : evals_db.

A Small-Step Operational Semantics
Inductive step : comp -> comp -> Prop :=
| step_Delay : forall env e, step (Delay e env) (compile e env)
| step_Bind_value : forall f v, step (Bind (Ret (Value v)) f) (f v)
| step_Bind_typeerror : forall f, step (Bind (Ret TypeError) f) (Ret TypeError)
| step_Bind : forall c1 c2 f, step c1 c2 -> step (Bind c1 f) (Bind c2 f).
Hint Constructors step : evals_db.

Alternatively, we can define a step function.
Implicit Arguments inl [A B].
Implicit Arguments inr [A B].
Fixpoint step_fn(c:comp) : comp + answer :=
match c with
| Ret a => inr a
| Delay e env => inl (compile e env)
| Bind c1 f =>
match step_fn c1 with
| inl c2 => inl (Bind c2 f)
| inr (Value v) => inl (f v)
| inr TypeError => inl (Ret TypeError)
end
end.

Now we can define the 1-step evaluation relation i nterms of the step function. Alternatively, we could use the inductively-defined step relation.
Definition step1(c1 c2:comp) : Prop := step_fn c1 = inl c2.

And we can define the steps relations as the reflexive, transitive closure of the 1-step relation.
Require Import Relation_Operators.
Definition steps := clos_refl_trans comp step1.
Hint Constructors clos_refl_trans : evals_db.

Notation "c1 '==>1' c2" := (step1 c1 c2) (at level 80) : evals_scope.
Notation "c1 '==>*' c2" := (steps c1 c2) (at level 80) : evals_scope.
Local Open Scope evals_scope.

Two different notions of evaluation -- evals1 uses the big-step semantics, and evals2 uses the small-step semantics.
Definition evals1 (env:env_t value) (e:exp) (a:answer) := run (compile e env) a.
Definition evals2 (env:env_t value) (e:exp) (a:answer) :=
(compile e env) ==>* (Ret a).

Notation "env |= e ==> a" := (evals2 env e a) (at level 80) : evals_scope.

Now let's prove that our new semantics respects the typing rules.
Local Open Scope typing_scope.

Typing for computations: Notice that the type for bind!
Inductive compType : comp -> type -> Prop :=
| Ret_ct : forall a t, ansType a t -> compType (Ret a) t
| Delay_ct : forall e env G t,
envType env G -> G |-- e ; t ->
compType (Delay e env) t
| Bind_ct :
forall c f t1 t,
compType c t1 -> (forall v, valType v t1 -> compType (f v) t) -> compType (Bind c f) t.
Hint Constructors compType : type_db.

The compiler preserves types.
Lemma CompPreserves : forall G e t, G |-- e ; t ->
forall env, envType env G -> compType (compile e env) t.
Proof.
Ltac mysimp := simpl in * ; intros ; subst ; try congruence ;
match goal with
| [ |- context[string_dec ?x ?y] ] => destruct (string_dec x y)
| [ H : Some _ = Some _ |- _ ] => injection H ; clear H
| [ IH : forall _, envType _ ?G -> compType (compile ?e _) _, H: envType ?env ?G |- _] =>
generalize (IH env H) ; clear IH ; intro IH
| [ |- forall _, _ ] => intro
| _ => eauto with type_db
end.
Ltac pv :=
match goal with
| [ H : lookup _ _ = Some _, H0:envType _ _ |- context[lookup _ _]] =>
generalize H ; induction H0
| [ H : valType _ Nat_t |- _ ] => inversion H ; clear H
| [ H : valType _ Bool_t |- _ ] => inversion H ; clear H
| [ H : valType _ (Arrow_t _ _) |- _ ] => inversion H ; clear H
| [ |- context[compType(if ?b then _ else _) _] ] => destruct b
| [ |- compType (Ret (eval_binop ?b (Num_v _) (Num_v _))) _ ] => destruct b ; repeat mysimp
| _ => econstructor ; eauto with type_db ; econstructor ; eauto with type_db
end ; repeat mysimp.

induction 1 ; simpl ; intros; repeat mysimp ; (pv || econstructor ; eauto ; mysimp) ; repeat pv.
Qed.

A small step using the step_fn preserves types -- contrast with the operational version below.
Lemma Step1Preserves' : forall c t,
compType c t ->
match step_fn c with
| inl c' => compType c' t
| inr a => ansType a t
end.
Proof.
induction 1 ; simpl. auto. eapply CompPreserves ; eauto.
remember (step_fn c) as x. destruct x. econstructor ; eauto.
destruct a. inversion IHcompType. subst. apply H0. auto.
inversion IHcompType.
Qed.

A small step using step_fn preserves types
Lemma Step1Preserves : forall c c',
c ==>1 c' -> forall t, compType c t -> compType c' t.
Proof.
unfold step1. intros. generalize (Step1Preserves' H0). rewrite H. auto.
Qed.

A small step using the operational version of a single step preserves types
Lemma StepPreserves : forall c c',
step c c' -> forall t, compType c t -> compType c' t.
Proof.
Ltac s :=
match goal with
| [ |- compType (compile _ _) _ ] => eapply CompPreserves ; eauto
| [ H : compType (ret _) _ |- _ ] => inversion H ; clear H ; subst
| [ H : ansType (Value _) _ |- _ ] => inversion H ; clear H ; subst
| [ H : compType (Ret TypeError) _ |- _] => inversion H ; clear H ; subst
| [ H : ansType TypeError _ |- _ ] => inversion H
| _ => eauto with type_db
end.
induction 1 ; intros ;
match goal with | [ H : compType _ _ |- _ ] => inversion H ; subst end ; repeat s.
Qed.

The reflexive/transitive closure of the step relation preserves types.
Lemma StepsPreserves : forall c c' t, c ==>* c' -> compType c t -> compType c' t.
Proof.
induction 1 ; auto ; eapply Step1Preserves ; auto.
Qed.

Putting the translation and the compuation lemmas together, we get that any expression which has type t and that evaluates to an answer, produces an answer of type t.
Lemma Preservation : forall env e a,
env |= e ==> a ->
forall G t,
envType env G ->
G |-- e ; t -> ansType a t.
Proof.
intros env e a H G t H1 H2 ;
generalize (StepsPreserves H (CompPreserves H2 H1)) ; inversion 1 ; subst ; auto.
Qed.

Lemma steps_bind : forall c1 c2,
c1 ==>* c2 -> forall f, (Bind c1 f) ==>* (Bind c2 f).
Proof.

Lemma big_to_small : forall c a,
run c a -> c ==>* (Ret a).
Proof.

Lemma step_cons : forall c,
match step_fn c with
| inl c' => forall a, run c' a -> run c a
| inr a => run c a
end.
Proof.

Lemma small_to_big' : forall c1 c2,
c1 ==>* c2 -> forall a, run c2 a -> run c1 a.
Proof.

Lemma small_to_big : forall c a,
c ==>* Ret a -> run c a.
Proof.