(** * 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.

Inductive answer : Set := 
| Value : value -> answer 
| TypeError : 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.

(** ** Value, Environment, and Answer Typing *)
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.
  Admitted.

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

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.
  Admitted.

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

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

(** * Required exercises:  

  - Add a "let" construct to the language.  

  - Add a new type [Pair_t : type -> type -> type], expressions [Pair_e : exp -> exp -> exp] [Fst_e : exp -> exp] and [Snd_e : exp] and a value [Pair_v : value -> value -> value].  

  - Prove a progress theorem for well-typed computations:  
    If [compType c t] then either [c] is a well-typed answer, or else [c ==>1 c'].  

  - Prove that [evals1 c a <-> evals2 c a].  
*)