(** * Software Foundations, Formally   
      Benjamin C. Pierce
      Version of 11/7/2007
*)

Require Export lec13_sol.
(* ---------------------------------------------------------------------- *)

(* Topic for today: The simply typed lambda-calculus

   Reading: TAPL Chapters 8 and 9.  

   [overview on the board]
*)


(* ====================================================================== *)
(** * Association lists *)



(* ---------------------------------------------------------------------- *)
(** Preliminaries *)

(* We'll need a couple of facts about numbers and lists that we
   neglected to prove in earlier lectures... *)

Lemma eqnat_n_n : forall n : nat,
  eqnat n n = yes.
Proof.
  intros n. induction n.
    simpl. reflexivity.
    simpl. rewrite -> IHn. reflexivity.
Qed.

Lemma eqnat_symm : forall x y r,
  eqnat x y = r -> eqnat y x = r.
Proof.
  induction x.
    CASE "O". intros y r E. destruct y.
      assumption.
      simpl. simpl in E. assumption.
    CASE "S". intros y r E. destruct y.
      simpl. simpl in E. assumption.
      simpl. simpl in E. apply IHx. assumption.
Qed.

Lemma snoc_append : forall (X:Set) (l:list X) (x:X),
  snoc _ l x = l ++ [x].
Proof.
  intros X l. induction l.
    reflexivity.
    simpl. intros x0.
    assert (snoc X l x0 = l ++ [x0]).
      apply IHl.
    rewrite H.
    reflexivity.
Qed.

(* ---------------------------------------------------------------------- *)
(** Definition of association lists *)

(* An association list is a list of pairs (k,v) of keys and values.
   The keys are [nat]s, so that we can compare them for equality.  (Of
   course, we could define association lists with keys of any type
   with an equality function, but [nat]s are all we need here.) *)

Definition alist (X : Set) := list (nat * X).

Fixpoint lookup (X : Set) (k : nat) (l : alist X) {struct l} : option X :=
  match l with
  | nil => None _
  | (j',a') :: l' =>
      if eqnat k j' then Some _ a' else lookup _ k l'
  end.

Definition binds (X:Set) (k:nat) (v:X) (l:alist X) :=
  lookup X k l = Some _ v.

Definition not_bound_in (X:Set) (k:nat) (l:alist X) :=
  lookup _ k l = None _.

(* ---------------------------------------------------------------------- *)
(** Properties of association lists *)

Lemma empty_alist_binds_nothing : forall (X:Set) (k:nat),
  not_bound_in _ k (nil (nat*X)).
Proof.
  intros X k. unfold not_bound_in. simpl. reflexivity.
Qed.

Lemma found_before : forall (X:Set) k j v w l,
     lookup X k l = Some _ w
  -> lookup X k (l ++ [(j, v)]) = Some _ w.
Proof.
  intros X k j v w l1.
  induction l1; intros H.
    CASE "nil". inversion H.
    CASE "cons". destruct x.
      simpl. simpl in H.
      remember (eqnat k n) as e. destruct e.
        assumption.
        apply IHl1. assumption.
Qed.

Lemma last_binding : forall (X:Set) (l : alist X) (k:nat) (v:X),
     not_bound_in _ k l
  -> lookup _ k (l ++ [(k, v)]) = Some X v.
Proof.
  intros X l k v Hnb.
  induction l.
    CASE "nil". simpl. rewrite eqnat_n_n. reflexivity.
    CASE "cons". simpl. destruct x as (j,a).
     remember (eqnat k j) as e. destruct e.
       SCASE "k = j".
         unfold not_bound_in in Hnb. simpl in Hnb.
         rewrite <- Heqe in Hnb. inversion Hnb.
       SCASE "k <> j".
         rewrite -> IHl. reflexivity.
         unfold not_bound_in. unfold not_bound_in in Hnb. simpl.
         simpl in Hnb. rewrite <- Heqe in Hnb. assumption.
Qed.

Lemma not_last_binding : forall (X:Set) k j v w l,
     eqnat k j = no
  -> lookup X k (l ++ [(j, v)]) = w
  -> lookup X k l = w.
Proof.
  intros.
  induction l.
    CASE "nil". simpl in H0. rewrite H in H0. rewrite <- H0. simpl. trivial.
    CASE "cons". simpl. destruct x as (j',a').
     remember (eqnat k j') as e. destruct e.
       SCASE "k = j".
         simpl in H0. rewrite <- Heqe in H0. trivial.
       SCASE "k <> j".
         simpl in H0. rewrite <- Heqe in H0. exact (IHl H0).
Qed.

Lemma shadowed_binding : forall (X:Set) x y v l1,
     lookup X x l1 = Some _ y
  -> lookup X x (l1 ++ [(x, v)]) = Some _ y.
Proof.
  intros X x y v l1 H. induction l1.
    inversion H.
    destruct x0.
    simpl.
    remember (eqnat x n) as e. destruct e.
      SCASE "x = n".
        simpl in H. rewrite <- Heqe in H. assumption.
      SCASE "x <> n".
        simpl in H. rewrite <- Heqe in H.
        apply IHl1. assumption.
Qed.

(* ====================================================================== *)
(** * Simply typed lambda-calculus *)

Module SimplyTypedLambdaCalculus.

(* ---------------------------------------------------------------------- *)
(* Syntax and operational semantics *)

Inductive ty : Set :=
  | ty_base  : nat -> ty
  | ty_arrow : ty -> ty -> ty.

Notation A := (ty_base one).
Notation B := (ty_base two).
Notation C := (ty_base three).
(* Wei: --> has been defined in lec14 at level 80 with no associativity:
   Notation " t --> t' " := (simplify_steps t t') (at level 80).
   Once fixed, this cannot be changed (see http://flint.cs.yale.edu/cs428/coq/pdf/Translator.pdf).
   The V8only trick described in that document doesn't seem to work.
   So this is why we only Import lec13 *)
Notation " S --> T " := (ty_arrow S T) (at level 20, right associativity).

(* Note that we're re-using the [-->] symbol to mean "arrow type"
   instead of "evaluates to". *)

(* Wei: While I was browsing the coq manual, I found that it seems we can turn on the optimized vm by default *)
Test Virtual Machine.
Set Virtual Machine.
Test Virtual Machine.

(* The language of terms is almost exactly the same as the untyped
   lambda-calculus.
      - We drop constants, since we aren't going to be playing with
        evaluating examples in this language.
      - The [tm_abs] constructor takes an additional parameter for the
        type annotation on the bound variable. 
      - We use plain old [nat]s to represent variables, instead of
        defining [name] to be an abbreviation for [nat] and saying
        that a variable is a [name].  (This simplifies some of the
        proofs a little bit.) *)
Inductive tm : Set :=
  | tm_var : nat -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : nat -> ty -> tm -> tm.

Tactic Notation "tm_cases" tactic(first) tactic(c) :=
  first;
  [ c "tm_var" | c "tm_app" | c "tm_abs" ].

Notation " ! n " := (tm_var n) (at level 19).
Notation " \ x \in T , t " := (tm_abs x T t) (at level 21).
Notation " r @ s " := (tm_app r s) (at level 20).

Fixpoint subst (x:nat) (s:tm) (t:tm) {struct t} : tm :=
  match t with
  | !y' => if eqnat x y' then s else t
  | \y' \in T, t1 => if eqnat x y' then t else (\y' \in T, subst x s t1)
  | t1 @ t2 => (subst x s t1) @ (subst x s t2)
  end.

Notation "{ x |-> s } t" := (subst x s t) (at level 17).

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (\x \in T, t).

Inductive eval : tm -> tm -> Prop :=
  | E_AppAbs : forall x T t12 v2,
         value v2
      -> eval ((\x \in 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').

Tactic Notation "eval_cases" tactic(first) tactic(c) :=
  first;
  [ c "E_AppAbs" | c "E_App1" | c "E_App2" ].

(* Wei: Pull in this relation from lec15 *)
Inductive refl_trans_closure' (X:Set) (R: relation X) : X -> X -> Prop :=
  | rtc'_refl  : forall (x : X),
                 refl_trans_closure' X R x x
  | rtc'_step : forall (x y z : X),
                    R x y
                 -> refl_trans_closure' X R y z
                 -> refl_trans_closure' X R x z.

Notation evalmany := (refl_trans_closure' _ eval).

Inductive appears_free_in : nat -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tm_var 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 \in T,t1).

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(* ---------------------------------------------------------------------- *)
(* Typing *)


(* A typing context is an association list mapping
   variables (i.e.,numbers) to types. *)

Notation context := (alist ty).

Definition empty : context := nil _.

(* The typing relation... *)

(* The following command allows us to use the symbolic notation for
   the typing relation in its definition, instead of defining it first
   without the notation and then defining the notation in a separate
   step. *)
Reserved Notation "Gamma |- t \in T" (at level 69).

Inductive typing : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      binds _ x T Gamma ->
      Gamma |- !x \in T
  | T_Abs : forall Gamma x T1 T2 t,
         (x,T1) :: Gamma |- t \in T2
      -> Gamma |- (\x \in T1, t) \in T1-->T2
  | T_App : forall S T Gamma t1 t2,
         Gamma |- t1 \in S-->T
      -> Gamma |- t2 \in S
      -> Gamma |- t1@t2 \in T
(* Wei: Think of a type as a set, then the choice of \in is easy to understand *)
where "Gamma |- t \in T" := (typing Gamma t T).

(* WARNING: There is a small but potentially confusing notational
   difference between this presentation and TAPL: In TAPL, typing
   contexts are extended on the right -- i.e., the "newest" binding is
   the one furthest to the right.  Here, contexts are extended on the
   left.  (This simplifies the notation.) *)

Tactic Notation "typing_cases" tactic(first) tactic(c) :=
  first;
  [ c "T_Var" | c "T_Abs" | c "T_App" ].

(* Repeat some notational hacks from the untyped lambda-calculus *)
Notation x := (S (S (S O))).
Notation y := (S (S (S (S O)))).
Notation z := (S (S (S (S (S O))))).
Definition nat_in_tm : nat -> tm := tm_var.
Coercion nat_in_tm : nat >-> tm.


(* ---------------------------------------------------------------------- *)
(* Examples *)

Lemma typing_example_1 :
  empty |- (\x \in A, x) \in A-->A.
Proof.
  apply T_Abs.
  apply T_Var.
  unfold binds. reflexivity.
Qed.

Lemma typing_example_2 :
  empty |- (\x \in A, \y \in A-->A, y @ (y @ x)) 
            \in A --> (A-->A) --> A.
Proof.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (S := A).
  apply T_Var. unfold binds. reflexivity.
  apply T_App with (S := A).
  apply T_Var. unfold binds. reflexivity.
  apply T_Var. unfold binds. reflexivity.
Qed.

Lemma typing_example_3 :
  exists T, 
    empty |- (\x \in A-->B, \y \in B-->C, \z \in A, y @ (x @ z)) 
          \in T.
Proof.
  exists ((A-->B)-->(B-->C)-->A-->C).
  apply T_Abs. apply T_Abs. apply T_Abs.
  apply T_App with (S:=B).
  apply T_Var. compute. trivial.
  apply T_App with (S:=A).
  apply T_Var. compute. trivial.
  apply T_Var. compute. trivial.
Qed.  

Lemma typing_nonexample_1 :
  ~ exists T,
      empty |- (\x \in A, \y \in B, x @ y) \in T.
Proof.
  intros C. destruct C. 
  (* The [clear] tactic is useful for tidying away bits of the
     context that we're not going to need again. *)
  inversion H. subst.  clear H. 
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  unfold binds in H1. simpl in H1. inversion H1.
Qed.

Lemma typing_nonexample_2 :
  ~ exists T,
      empty |- (\x \in A-->A, \y \in B, x @ y) \in T.
Proof.
  intros C. destruct C. 
  inversion H. subst.  clear H. 
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  unfold binds in H1. simpl in H1. inversion H1. subst.
  unfold binds in H2. simpl in H2. inversion H2.
Qed.

(* Wei: This lemma is used in the next proof *)
Lemma type_unique : (forall S T, ~ (S = (S --> T))).
  induction S; intros T contra; inversion contra; clear contra.
  apply (IHS1 S2). trivial.
Qed.  

Lemma typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |- (\x \in S, x @ x) \in T).
Proof.
  intros C. destruct C. destruct H.
  inversion H. subst.  clear H. 
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  compute in H1. compute in H3.
  rewrite H1 in H3. inversion H3. clear H1 H3.
  apply (type_unique S T2). trivial.
Qed.  

(* ---------------------------------------------------------------------- *)
(* Properties of typing *)

Lemma drop_duplicate_binding : forall Gamma x U t T,
     Gamma ++ [(x, U)] |- t \in T
  -> (exists V, binds _ x V Gamma)
  -> Gamma |- t \in 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 = n".
        apply ex_intro with (witness := t).
        apply eq_symm in HeqE. apply eqnat_yes in HeqE. reflexivity.
      SCASE "x <> n".
        apply eq_symm in HeqE.
        inversion B.
        apply ex_intro with (witness := witness).
        unfold binds in H0. assumption.
Qed.

Lemma weakening_preserves_typing : forall Gamma x U t T,
     Gamma |- t \in T
  -> Gamma ++ [(x,U)] |- t \in 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.
Qed.

Lemma weakening_empty_preserves_typing : forall Gamma t T,
     empty |- t \in T
  -> Gamma |- t \in T.
Proof.
  intros Gamma t T H.
  assert (forall Delta, reverse _ Delta |- t \in 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 substitution_preserves_typing : forall Gamma x U v t S,
     Gamma ++ [(x,U)] |- t \in S
  -> empty |- v \in U
  -> not_bound_in _ x Gamma
  -> Gamma |- {x|->v}t \in 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".
      (* Intuitively, this case proceeds using the [T_Abs] rule and
         the induction hypothesis, but the actual reasoning is a tiny
         bit more involved.  (You will need a case split on whether x
         and n are equal, and you will need to apply
         [drop_duplicate_binding] at some point.) *)
      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). trivial.
          exists t. unfold binds. simpl.
          rewrite (eqnat_n_n x). trivial.
        SCASE "x <> x0".
          apply T_Abs. apply IHt with (S:=T2).
          trivial. unfold not_bound_in. simpl. rewrite <- Heqtest. trivial.
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T
  -> eval t t'
  -> empty |- t' \in 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 \in 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.
Qed.

Theorem preservation' : forall t t' S,
     empty |- t \in S
  -> eval t t'
  -> empty |- t' \in S.
Proof.
  (* Give an alternate proof by induction on evaluation derivations
     instead of typing derivations.  (Hint: You will need a
     [generalize dependent] here too.) *)
  intros t t' S Hty He. generalize dependent S.
  (eval_cases (induction He) (CASE)); intros S Hty; inversion Hty; subst.
    CASE "E_AppAbs".
      inversion H3. subst.
      assert ((nil _) ++ (nil _) |- {x |-> v2}t12 \in S) as Ht12.
        SCASE "Proof of assertion".
          apply substitution_preserves_typing with (U:=S0).
          unfold empty in H2. simpl. assumption.
          assert (not_bound_in ty x (nil _)).
            SSCASE "Pf of subassertion". apply empty_alist_binds_nothing.
          assumption.
          simpl.
          apply empty_alist_binds_nothing.
      simpl in Ht12. unfold empty. assumption.
    CASE "E_App1".
      apply T_App with (S := S0).
      apply IHHe. assumption. assumption.
    CASE "E_App2".
      apply T_App with (S := S0).  assumption.
      apply IHHe. assumption.
Qed.

Theorem progress : forall t T,
     closed t 
  -> empty |- t \in T    
  ->    value t
     \/ exists t', eval t t'.
Proof.
  intros t T C Hty.
  (typing_cases (induction Hty) (CASE)).
  CASE "T_Var".
    assert (appears_free_in x (!x)).
        SCASE "Pf of assertion". apply afi_var. 
    unfold closed in C. unfold not in C. apply C with (x0 := x) in H0.
    solve by inversion.
  CASE "T_Abs".
    apply or_introl. apply v_abs.
  CASE "T_App".
    assert (closed t1).
      SCASE "Pf of assertion". unfold closed. intros x Contra.
        assert (appears_free_in x (t1@t2)).
          SSCASE "Pf of assertion". apply afi_app1. assumption.
        apply C with (x:=x). assumption.
    assert (value t1 \/ (exists t' : tm, eval t1 t')).
      apply IHHty1. assumption.
    assert (closed t2).
      SCASE "Pf of assertion". unfold closed. intros x Contra.
        assert (appears_free_in x (t1@t2)).
          SSCASE "Pf of assertion". apply afi_app2. assumption.
        apply C with (x:=x). assumption.
    assert (value t2 \/ (exists t' : tm, eval t2 t')).
      apply IHHty2. assumption.
    apply or_intror.
    inversion H0; inversion H2; subst.
      SCASE "t1 value / t2 value".
        inversion H3. subst. apply ex_intro with (witness:={x |-> t2} t).
        apply E_AppAbs. assumption.
      SCASE "t1 value / t2 steps".
        inversion H4.
        apply ex_intro with (witness := t1 @ witness).
        apply E_App2. assumption. assumption.
      SCASE "t1 steps / t2 value".
        inversion H3.
        apply ex_intro with (witness := witness @ t2).
        apply E_App1. assumption.
      SCASE "t1 steps / t2 steps".
        inversion H3.
        apply ex_intro with (witness := witness @ t2).
        apply E_App1. assumption.
Qed.

End SimplyTypedLambdaCalculus.