(** * Software Foundations, Formally   
      Benjamin C. Pierce
      Version of 11/12/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 lec1415. 

(* IMPORTANT: The file lec1415.v has been updated.  You'll need to
   download and compile the new version before working with this file. *)

(* ---------------------------------------------------------------------- *)
(* Reflexive transitive closure, revisited *)

(* Let's begin with a little improvement of something we did before.

   Our earlier definition of the reflexive and transitive closure of a
   relation looked like this:

     Inductive refl_trans_closure (X:Set) (R: relation X) : X -> X -> Prop :=
       | rtc_R     : forall (x y : X), R x y -> refl_trans_closure X R x y
       | rtc_refl  : forall (x : X),
                      refl_trans_closure X R x x
       | rtc_trans : forall (x y z : X),
                         refl_trans_closure X R x y
                      -> refl_trans_closure X R y z
                      -> refl_trans_closure X R x z.

   This definition is the natural one -- it says, explicitly, that the
   reflexive and transitive closure of [R] is the least relation that
   includes [R] and that is closed under rules of reflexivity and
   transitivity.  But this definition turns out not always to be
   convenient for doing proofs -- the "nondeterminism" of the
   rtc_trans rule can sometimes lead to tricky inductions.  

   Here is a better definition... *)

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.

(* This new definition "bundles together" the rtc_R and rtc_trans
   rules into the single rule rtc'_step.  The left-hand premise of
   this step is a single use of R, leading to a much simpler induction
   principle.

   Before we go on, we should check that the two definitions do indeed
   define the same relation... *)

Lemma rtc'_transitive : 
  forall (X:Set) (R: relation X) (x y z : X),
      refl_trans_closure' X R x y 
   -> refl_trans_closure' X R y z
   -> refl_trans_closure' X R x z.
Proof.
  (* SOLUTION *)
  intros X R x y z G H.
  induction G.
    CASE "refl". assumption.
    CASE "step". 
      eapply rtc'_step. eassumption. 
      apply IHG. assumption.
Qed.

Lemma two_versions_of_rtc_coincide : 
         forall (X:Set) (R: relation X) (x y : X),
  refl_trans_closure X R x y <-> refl_trans_closure' X R x y.
Proof.
  intros X R x y.
  unfold iff. apply conj.
    CASE "->".
      intros H. induction H.
        SUBCASE "rtc_R".
          eapply rtc'_step. eassumption. apply rtc'_refl.
        SUBCASE "rtc_refl".
          apply rtc'_refl.
        SUBCASE "rtc_trans".
          eapply rtc'_transitive. eassumption. eassumption.
    CASE "<-".
      intros H. induction H.
        SUBCASE "rtc'_refl". apply rtc_refl.
        SUBCASE "rtc'_step". eapply rtc_trans. eapply rtc_R. eassumption.
          apply IHrefl_trans_closure'.
Qed.

(* ====================================================================== *)
(** * The [remember] tactic *)

Module RememberExamples.

(* Another brief digression to introduce a useful tactic. 

   [This material also appeared in an earlier set of lecture notes;
   I'm including it here too so that we can talk about it.]
*)

(* We have seen how the [destruct] tactic can be used to perform case
   analysis of the results of arbitrary computations.  If [e] is an
   expression whose type is some inductively defined set [T], then,
   for each constructor [c] of [T], [destruct e] generates a subgoal
   in which all occurrences of [e] (in the goal and in the context)
   are replaced by [c].

   Sometimes, however, this substitution process loses information
   that we need in order to complete the proof.  For example, suppose
   we define a function [sillyfun1] like this... *)
Definition sillyfun1 (n : nat) : yesno :=
  if eqnat n three then yes
  else if eqnat n five then yes
  else no.

(* ... and suppose that we want to convince Coq of the rather obvious
   observation that [sillyfun1 n] yields [yes] only if [n] is odd.  By
   analogy with the proofs we did earlier with [sillyfun], it is
   natural to start the proof like this: *)
Lemma sillyfun1_odd_FAILED : forall (n : nat),
     sillyfun1 n = yes
  -> odd n = yes.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (eqnat n three).
  (* At this point, we are stuck: the context does not contain enough
     information to prove the goal!  The problem is that the
     substitution peformed by [destruct] is too brutal -- it threw
     away every occurrence of [eqnat n three], but we need to keep at
     least one of these because we need to be able to reason that, in
     this branch of the case analysis, [eqnat n three = yes], hence it
     must be that [n = three], from which it follows that [n] is
     odd. *)
Admitted.

(* What we would really like is not to use [destruct] directly on
   [eqnat n three] and substitute away all occurrences of this
   expression, but rather to use [destruct] on something else that is
   EQUAL to [eqnat n three] -- e.g., if we had a variable that we knew
   was equal to [eqnat n three], we could [destruct] this variable
   instead.

   The [remember] tactic allows us to introduce such a variable. *)

Lemma sillyfun1_odd : forall (n : nat),
     sillyfun1 n = yes
  -> odd n = yes.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  remember (eqnat n three) as e3.
  (* At this point, the context has been enriched with a new variable
     [e3] and an assumption that [e3 = eqnat n three].  Now if we do
     [destruct e3]... *)
  destruct e3.
  (* ... the variable [e3] gets substituted away (it disappears
     completely) and we are left with the same state as at the point
     where we got stuck above, except that the context still contains
     the extra equality assumption -- now with [yes] substituted for
     [e3] -- which is exactly what we need to make progress. *)
    Case "yes". apply eq_symm in Heqe3. apply eqnat_yes in Heqe3.
      rewrite -> Heqe3. reflexivity.
    Case "no".
      (* When we come to the second equality test in the body of the
         function we are reasoning about, we can use [remember] again
         in the same way, allowing us to finish the proof. *)
      remember (eqnat n five) as e5. destruct e5.
        Case "yes". apply eq_symm in Heqe5. apply eqnat_yes in Heqe5.
          rewrite -> Heqe5. reflexivity.
        Case "no". inversion eq.
Qed.

(* Now you try it... *)
Lemma filter_exercise : forall (X : Set) (test : X -> yesno)
                               (x : X) (l l' : list X),
     filter _ test l = x :: l'
  -> test x = yes.
Proof.
  (* SOLUTION *)
  intros X test x l. induction l.
    Case "nil". intros l' eq. inversion eq.
    Case "cons". intros l' eq.
      simpl in eq.
      remember (test x0) as t. destruct t.
        Case "yes". inversion eq. rewrite <- H0. rewrite <- Heqt. reflexivity.
        Case "no". apply IHl with (l':=l').
          apply eq.
Qed.

End RememberExamples.

(* ---------------------------------------------------------------------- *)
(* Determinism of single-step evaluation *)

(* Like most of the other evaluation relations we have defined,
   single-step call-by-value evaluation of lambda terms is
   deterministic.  The proof is very similar to ones we have seen
   previously -- so not too interesting in itself -- but we'll need
   the property in several places below so let's record it here. *)

Module LambdaContd'.
Export LambdaContd.

Lemma value_subterms_are_values : forall t1 t2, 
     value (t1 @ t2) 
  -> (value t1) /\ (value t2).
Proof.
  intros t1 t2 Hv. 
  apply conj.
    CASE "t1". tm_cases (induction t1) SCASE.
      apply v_const. reflexivity.
      inversion Hv. solve by inversion.
      inversion Hv. inversion H. apply v_const. simpl. 
      destruct (both_yes (only_constants t1_1) (only_constants t1_2)).
        reflexivity.
        solve by inversion.
      apply v_abs.
    CASE "t2". tm_cases (induction t2) SCASE.
      apply v_const. reflexivity.
      inversion Hv. inversion H. 
      destruct (only_constants t1). solve by inversion. solve by inversion.
      inversion Hv. inversion H. apply v_const. simpl. 
      destruct (both_yes (only_constants t2_1) (only_constants t2_2)).
        reflexivity.
        destruct (only_constants t1). solve by inversion. solve by inversion.
      apply v_abs.
Qed.

Lemma values_don't_step : forall t t', 
  value t -> ~ eval t t'.
Proof.
  intros u v Hv1. unfold not.
  generalize dependent v.
  (tm_cases (induction u) CASE); intros v He1.
    CASE "tm_const". inversion He1.
    CASE "tm_var". inversion Hv1; subst. solve by inversion.
    CASE "tm_app". inversion He1; subst.
      inversion Hv1. solve by inversion.
      apply IHu1 in H2. inversion H2. apply value_subterms_are_values in Hv1. 
        destruct Hv1. assumption.
      apply IHu2 in H3. inversion H3. apply value_subterms_are_values in Hv1. 
        destruct Hv1. assumption.
    CASE "tm_abs". solve by inversion.
Qed.

Lemma eval_deterministic : 
  partial_function _ eval.
Proof.
  (* A little trick: Put this in the context so that we can do 
     [unfold] in it. *)
  assert (forall t t', value t -> ~ eval t t') as values_don't_step. 
    apply values_don't_step.
  unfold partial_function.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  (eval_cases (induction Hy1) CASE); 
         intros y2 Hy2; 
         (eval_cases (inversion Hy2) SCASE); 
         subst;
         try solve [reflexivity | solve by inversion].
  CASE "E_AppAbs".
    SCASE "E_App2".
      unfold not in values_don't_step. apply values_don't_step in H4. 
        inversion H4. assumption.
  CASE "E_App1".
    SCASE "E_App1".
      apply IHHy1 in H2. subst. reflexivity.
    SCASE "E_App2".
      unfold not in values_don't_step. apply values_don't_step in Hy1. 
      inversion Hy1. assumption.
  CASE "E_App2".            
    SCASE "E_AppAbs".
      unfold not in values_don't_step. apply values_don't_step in Hy1. 
      inversion Hy1. assumption.                
    SCASE "E_App1".
      unfold not in values_don't_step. apply values_don't_step in H3. 
      inversion H3. assumption.                
    SCASE "E_App2".
      apply IHHy1 in H4. subst. reflexivity.
Qed.

(* ---------------------------------------------------------------------- *)
(* Many-step evaluation *)

(* As always, we define multi-step evaluation on top of single-step,
   and then define the concept of "normalizable term" on top of this. *)

Notation evalmany := (refl_trans_closure' _ eval). 
Notation eval_normal_form := (normal_form _ eval).  

Definition normalizable (t : tm) :=
  exists t', evalmany t t' /\  eval_normal_form t'.

(* For working with examples, it is nice to be able to perform complex
   evaluation sequences using the [simplify_steps] (or [-->*])
   relation and its associated [steps] tactic.  The following lemmas
   connect these to multi-step evaluation and normalization. *)

Lemma simplify_steps__evalmany : forall t t',
     simplify_steps t t' 
  -> evalmany t t'.
Proof.
  intros t t' SS. induction SS.
    CASE "ss_refl". apply rtc'_refl.
    CASE "ss_step". 
      assert (eval t t' <-> simplify_step t = Some _ t').
        apply two_variants_of_single_step_evaluation_coincide.
      destruct H0. apply H1 in H.
      apply rtc'_step with (y:=t').
        assumption. assumption.
Qed.

Lemma simplify_steps__normalizable : forall t t',
     simplify_steps t t' 
  -> is_value t' = yes
  -> normalizable t.
Proof.
  intros t t' SS IV.
  unfold normalizable. apply ex_intro with (witness := t'). 
  apply conj.
    CASE "evalmany". apply simplify_steps__evalmany. assumption.
    CASE "nf". unfold normal_form. intros C. 
       apply is_value__value in IV. 
       destruct C.
       assert (value t' -> ~ eval t' witness).
         apply values_don't_step.
       apply H0 in IV. unfold not in IV. apply IV in H. assumption.
Qed.

(* Some examples... *)

Module LambdaExamplesContd'.
Export LambdaExamplesContd.

Lemma one_pls_zero_normalizable : 
  normalizable (pls @ c_one @ c_zero).
Proof.
  apply simplify_steps__normalizable
    with (t' := \s, \z, c_one @ s @ (c_zero @ s @ z)). 
  steps. reflexivity.
Qed.

Lemma omega_eval_omega :
  eval omega omega.
Proof.
  assert ({x |-> (\ x, x @ x)}(x@x) = omega).
    reflexivity.
  (* Here we need to bend over backwards a little to avoid
     rewriting *both* occurrences of omega in the goal! *)
  assert 
      (eval ((\ x, x @ x) @ (\ x, x @ x)) ({x |-> (\ x, x @ x)}(x@x))
    -> eval ((\ x, x @ x) @ (\ x, x @ x)) ((\ x, x @ x) @ (\ x, x @ x))).
    simpl. intros G. assumption.
  apply H0.
  apply E_AppAbs.
  apply v_abs.
Qed.

Lemma omega_not_normalizable :
  ~ normalizable omega.
Proof.
  intros N. unfold normalizable in N. inversion N. destruct H. 
  remember omega as o. induction H. 
    CASE "rtc'_refl". subst. unfold normal_form in H0. unfold not in H0.
      apply H0. apply ex_intro with (witness:=omega).
      apply omega_eval_omega.
    CASE "rtc'_step". subst.
      apply IHrefl_trans_closure'. 
      apply ex_intro with (witness:=z). apply conj. 
      assumption. assumption. assumption.
      inversion H.
        reflexivity. solve by inversion. solve by inversion.
Qed.

Lemma omega_tru_not_normalizable :
  ~ normalizable (omega @ tru).
Proof.
  (* SOLUTION *)
  intros N. unfold normalizable in N. inversion N. destruct H. 
  remember (omega @ tru) as o. induction H. 
    CASE "rtc'_refl". subst. unfold normal_form in H0. unfold not in H0.
      apply H0. apply ex_intro with (witness:=(omega @ tru)).
      apply E_App1.
      apply omega_eval_omega.
    CASE "rtc'_step". subst.
      apply IHrefl_trans_closure'. 
      apply ex_intro with (witness:=z). apply conj. 
      assumption. assumption. assumption.
      inversion H; subst.
      inversion H5; subst.
        reflexivity. inversion H6. inversion H7. inversion H6.
Qed.

Lemma normalizable_example_6 :
  normalizable (c_zero @ poisonpill @ tru).
Proof.
  apply simplify_steps__normalizable with (t' := tru). 
  steps. reflexivity.
Qed.

(* To show that a particular example *is* normalizable, it is enough
   just to give its normal form.  But showing that particular terms
   are *not* normalizable often requires more work.  We can sometimes
   avoid this work by observing that, if a term [t] evaluates to a
   non-normalizable term, then [t] itself is not normalizable. *)

Lemma evalmany_diverge__diverge : forall t t',
     evalmany t t'
  -> ~ normalizable t'
  -> ~ normalizable t.
Proof.
  intros t t' E. induction E.
    CASE "rtc'_refl". 
      intros H. assumption.
    CASE "rtc'_trans". 
      intros Nz C. apply IHE in Nz. unfold normalizable in C. inversion C.
      destruct H0. inversion H0; subst. 
      unfold normal_form in H1. 
      assert (exists t' : tm, eval witness t').
        apply ex_intro with (witness := y). assumption.
      unfold not in H1. apply H1 in H2. assumption.
      assert (partial_function _ eval) as ED.
        apply eval_deterministic.
      assert (y = y0).
        unfold partial_function in ED. apply ED with (x:=x). 
        assumption. assumption.
      subst. 
      assert (normalizable y0).
        unfold normalizable. apply ex_intro with (witness:=witness).
        apply conj. assumption. assumption. 
      unfold not in Nz. apply Nz in H4.        assumption.
Qed.

Lemma normalizable_example_5 :
  ~ normalizable (pls @ c_one @ c_zero @ poisonpill @ tru).
Proof.
  assert (evalmany (pls @ c_one @ c_zero @ poisonpill @ tru) 
                   omega).
    apply simplify_steps__evalmany. steps.
  apply evalmany_diverge__diverge with (t' := omega).
  assumption. apply omega_not_normalizable.
Qed.

(* ---------------------------------------------------------------------- *)
(* Hypothetical evaluation *)

(* Another situation where a little more work is required is when we
   want to reason about the evaluation behavior of a term in which
   some subterm is not a concrete lambda-expression but a meta-level
   variable that stands for some arbitrary lambda-expression.  For
   example, any term of the form [c_one @ t], where [t] is an
   arbitrary value, reduces in one step to [\z, t @ z].  (Note that we
   need the assumption that [t] is a value, since otherwise we would
   not be justified in applying the [E_AppAbs] rule.)  

   This section shows a few typical examples of this sort of
   "hypothetical" reasoning about evaluation. *)

(* To begin, we need a couple of facts about substitution. *)

Lemma not_free__subst_invariant : forall x s t,
     ~ (appears_free_in x t) 
  -> {x|->s}t = t.
Proof.
  intros x s t H. 
  (tm_cases (induction t) CASE); simpl.
    CASE "tm_const". reflexivity.
    CASE "tm_var". unfold not in H. 
      remember (eqname x n) as r. destruct r.
        SCASE "yes". 
          assert (appears_free_in x (!n)).
            assert (x = n).
              apply eqnat_yes. apply eq_symm. assumption.
            subst. apply afi_var.
          apply H in H0. solve by inversion.
        SCASE "no". reflexivity. 
    CASE "tm_app". 
      assert ({x |-> s}t1 = t1). 
        apply IHt1. unfold not. intros C. apply afi_app1 with (t2:=t2) in C.
        unfold not in H. apply H in C. solve by inversion.
      assert ({x |-> s}t2 = t2). 
        apply IHt2. unfold not. intros C. apply afi_app2 with (t1:=t1) in C.
        unfold not in H. apply H in C. solve by inversion.
        rewrite H0. rewrite H1. reflexivity.
    CASE "tm_abs".
      remember (eqname x n) as r. destruct r.
        SCASE "x = n". reflexivity.
        SCASE "x<>n". 
          assert ({x |-> s}t = t). 
            SSCASE "Pf of assertion". apply IHt. unfold not. intros C. 
              apply afi_abs with (y:=n) in C.
              unfold not in H. apply H in C. solve by inversion. 
              apply eq_symm. assumption.
          rewrite H0. reflexivity.
Qed.

Lemma subst_doesn't_change_closed_terms : forall x s t,
     closed t 
  -> {x|->s}t = t.
Proof.
  intros x s t Closed.
  apply not_free__subst_invariant. apply Closed.
Qed.

(* Now here are the examples... *)

Lemma evalmany_example_0 : forall t,
     value t 
  -> evalmany
       (pls @ c_one @ c_zero @ t)
       (\z, c_one @ t @ (c_zero @ t @ z)).
Proof.
  intros t Vt.
  (* We can first do a couple of steps the easy way... *)
  apply rtc'_step with 
    (y := (\n, \s, \z, c_one @ s @ (n @ s @ z)) @ c_zero @ t).
  apply simplify_step__eval. reflexivity.
  apply rtc'_step with 
    (y := (\s, \z, c_one @ s @ (c_zero @ s @ z)) @ t).
  apply simplify_step__eval. reflexivity.
  (* But we have to do this step the hard way *)
  apply rtc'_step 
    with (y := (\z, c_one @ t @ (c_zero @ t @ z))).
  assert ({s|->t} (\z, c_one @ s @ (c_zero @ s @ z))
           = \z, c_one @ t @ (c_zero @ t @ z)) as R.
    reflexivity.
  rewrite <- R.
  apply E_AppAbs. assumption.
  apply rtc'_refl.
Qed.

Lemma evalmany_example_1 : forall t t0,
     value t 
  -> closed t
  -> value t0
  -> evalmany 
       (pls @ c_one @ c_zero @ t @ t0) 
       (t @ t0).
Proof.
  intros t t0 Ct Vt Vt0.

  (* Begin by recording a couple of facts about substitution 
     that are needed multiple times *)
  assert ({z|->t0}t = t) as E.
    apply subst_doesn't_change_closed_terms. assumption.
  assert ({s|->t} (\z, s @ z) = \z, t @ z) as E1.
    reflexivity.
  assert ({z|->t0} z = t0) as E2.
    reflexivity.

  (* Now, we can first do a couple of steps the easy way... *)
  apply rtc'_step with 
    (y := (\n, \s, \z, c_one @ s @ (n @ s @ z)) @ c_zero @ t @ t0).
  apply simplify_step__eval. reflexivity.
  apply rtc'_step with 
    (y := (\s, \z, c_one @ s @ (c_zero @ s @ z)) @ t @ t0).
  apply simplify_step__eval. reflexivity.

  (* But we have to do this step the hard way *)
  apply rtc'_step 
    with (y := (\z, c_one @ t @ (c_zero @ t @ z)) @ t0).
  SCASE "show first step".
  apply E_App1.
  assert ({s|->t} (\z, c_one @ s @ (c_zero @ s @ z))
           = \z, c_one @ t @ (c_zero @ t @ z)) as R.
    reflexivity.
  rewrite <- R.
  apply E_AppAbs. assumption.

  (* This one too *)
  apply rtc'_step with 
    (y := c_one @ t @ (c_zero @ t @ t0)).
  SCASE "show first step".
  assert ({z|->t0} (c_one @ t @ (c_zero @ t @ z))
           = c_one @ t @ (c_zero @ t @ t0)) as R.
    simpl. rewrite E. reflexivity.
  rewrite <- R.
  apply E_AppAbs. assumption.
  
  (* This one too *)
  apply rtc'_step with 
    (y := (\z, t @ z) @ (c_zero @ t @ t0)).
  SCASE "show first step".
  rewrite <- E1.
  apply E_App1. apply E_AppAbs. assumption.
  
  (* This one too *)
  apply rtc'_step with 
    (y := (\z, t @ z) @ ((\z, z) @ t0)).
  SCASE "show first step".
  apply E_App2. apply v_abs.
  apply E_App1.
  assert ({s|->t} (\z, z)
          = (\z, z)) as E3.
    reflexivity.
  rewrite <- E3.
  apply E_AppAbs. assumption.

  (* This one too *)
  apply rtc'_step with 
    (y := (\z, t @ z) @ t0).
  SCASE "show first step".
  apply E_App2. apply v_abs.
  assert ({z|->t0}(z) = t0) as R.
    reflexivity.
  rewrite <- R. apply E_AppAbs. assumption.

  (* This one too *)
  apply rtc'_step with 
    (y := t @ t0).
  SCASE "show first step".
  assert ({z|->t0}(t @ z) = t @ t0) as R.
    simpl. rewrite E. reflexivity.
  rewrite <- R. apply E_AppAbs. 
  assumption.

  (* ... and now we're done! *)
  apply rtc'_refl.
Qed.

(* Here's a simpler one for you to try. *)
Lemma evalmany_example_2 : forall t t0,
     value t 
  -> closed t
  -> value t0
  -> evalmany 
       (c_one @ t @ t0) 
       (t @ t0).
Proof.
  (* SOLUTION *)
  intros t t0 Ct Vt Vt0.
  assert ({z|->t0}t = t) as E1.
    apply subst_doesn't_change_closed_terms. assumption.
  assert ({z|->t0}(t @ z) = t @ t0) as E2.
    simpl. rewrite E1. reflexivity.
  assert ({s|->t}(\z, s @ z) = \z, t @ z) as E3.
    simpl. reflexivity.
  apply rtc'_step with (y := (\z, t @ z) @ t0).
    rewrite <- E3. apply E_App1. apply E_AppAbs. assumption.
  apply rtc'_step with (y := t @ t0).
    rewrite <- E2. apply E_AppAbs. assumption.
  apply rtc'_refl.
Qed.

(* And here's an even simpler one that we'll need later. *)
Lemma evalmany_example_3 : forall t,
     value t 
  -> evalmany 
       (c_one @ t) 
       (\z, t @ z).
Proof.
  intros t Vt.
  assert ({s|->t}(\z, s @ z) = \z, t @ z) as E3.
    simpl. reflexivity.
  apply rtc'_step with (y := (\z, t @ z)).
    rewrite <- E3. apply E_AppAbs. assumption.
  apply rtc'_refl.
Qed.

(* ====================================================================== *)
(* Introduction to behavioral equivalence *)

(* We have observed that the evaluation behavior of lambda-terms does
   not always quite reflect our informal intuitions.  For example,

     pls @ c_one @ c_zero 

   does not reduce to

     c_one,

   although they "behave the same".  We would like to have a
   way of talking about this precisely.

   One way of articulating this intuition is to say that [pls @ c_one
   @ c_zero] and [c_one] are cannot be distinguished in any context --
   i.e., all the experiments we can perform on them from within the
   language yield the same results.  To make this formal, we need to
   say precisely what we mean by "performing an experiment" and
   "observing the result."  

      - "Performing an experiment" on a term [t] = applying [t] to
        some list [v1,v2,...,vn] of closed values.

      - "Observing the result" of an experiment [t @ v1 @ ... @ vn] =
        seeing whether this term normalizes or diverges.

   The notion of equivalence between terms that we obtain in this way
   is called BEHAVIORAL EQUIVALENCE.  

   Behavioral equivalence is one point (a particularly useful point)
   along a spectrum of possible program equivalences:

      - SYNTACTIC EQUIVALENCE (i.e., Coq's =) -- a term is equivalent
        only to itself

             (\x,x)  ~~  (\x,x)

      - EQUIVALENCE UP TO RENAMING OF BOUND VARIABLES (often called
        ALPHA-EQUIVALENCE)

             (\x,x)  ~~  (\y,y)

      - EQUIVALENCE MODULO EVALUATION

             tru @ fls @ fls  ~~  c_zero @ poisonpill @ fls

      - BEHAVIORAL EQUIVALENCE -- terms are equivalent if they "behave
        the same in all contexts"

             \x, tru  ~~  \x, (\y,y) @ tru
             pls @ c_one @ c_zero  ~~  c_one
             omega  ~~  omega @ tru

      - OBSERVATIONAL EQUIVALENCE (both normalize or both diverge)

             pls @ c_one @ c_zero  ~~  poisonpill

      - UNIVERSAL (or TRIVIAL) EQUIVALENCE (all terms are equivalent)

             omega  ~~  poisonpill

   Behavioral equivalence is the most natural of these in the sense
   that it is the most EXTENSIONAL -- it pays attention only to what
   we can *do* with a term, not how it is written internally.

   The observational equivalence relation is much "coarser" than
   behavioral equivalence -- it relates many terms that are not
   behaviorally equivalent.  It is is not useful on its own: it is
   just a technical device to help define behavioral equivalence --
   giving us a way to talk about "results of experiments."
*)


(* ---------------------------------------------------------------------- *)
(* Observational equivalence *)

(* Let's start by formalizing observational equivalence and working
   some examples. *)

Definition observationally_equivalent (t t' : tm) :=
  normalizable t <-> normalizable t'.

(* We've seen that propositions expressed in terms of [<->] can be a
   little awkward to work with.  So let's record a few immediate
   corollaries that are easier to use. *)

Lemma divergent_terms_observationally_equivalent : forall t1 t2,
     ~ normalizable t1
  -> ~ normalizable t2
  -> observationally_equivalent t1 t2.
Proof.
  intros t1 t2 D1 D2.
  unfold observationally_equivalent. unfold iff. apply conj.
    intros O. unfold not in D1. apply D1 in O. solve by inversion.
    intros O. unfold not in D2. apply D2 in O. solve by inversion.
Qed.

Lemma normalizable_terms_observationally_equivalent : forall t1 t2,
     normalizable t1 
  -> normalizable t2 
  -> observationally_equivalent t1 t2.
Proof.
  intros t1 t2 N1 N2.
  unfold observationally_equivalent. unfold iff. apply conj.
    intros N. assumption. 
    intros N. assumption. 
Qed.

Lemma normalizable_and_divergent_not_observationally_equivalent : forall t1 t2,
     normalizable t1 
  -> ~ normalizable t2 
  -> ~ observationally_equivalent t1 t2.
Proof.
  intros t1 t2 N D.
  unfold observationally_equivalent. unfold iff. intros C. destruct C. 
  apply H in N. unfold not in D. apply D in N. assumption.
Qed.

Lemma observational_equivalence_symmetric : forall t1 t2,
     observationally_equivalent t1 t2
  -> observationally_equivalent t2 t1.
Proof.
  unfold observationally_equivalent. unfold iff.
  intros t1 t2 H. apply conj.
    CASE "->". intro N. destruct H. apply H0. assumption.
    CASE "<-". intro N. destruct H. apply H. assumption.
Qed.

(* It can easily be shown that observational equivalence is also
   reflexive and transitive -- i.e., that it is really an
   equivalence. *)

(* Now, here are some examples... *)

Lemma observationally_equivalent_example_1 :
  observationally_equivalent
    (omega @ tru)
    omega.
Proof.
  apply divergent_terms_observationally_equivalent.
  apply omega_tru_not_normalizable.
  apply omega_not_normalizable.
Qed.

Lemma observationally_equivalent_example_2 :
  observationally_equivalent
    tru
    fls.
Proof.
  (* SOLUTION *)
  apply normalizable_terms_observationally_equivalent.
  CASE "tru".
    unfold normalizable. apply ex_intro with (witness:= tru). apply conj.
    apply rtc'_refl. unfold normal_form. unfold not. intros H. solve by inversion 2.
  CASE "fls".
    unfold normalizable. apply ex_intro with (witness:= fls). apply conj.
    apply rtc'_refl. unfold normal_form. unfold not. intros H. solve by inversion 2.
Qed.

Lemma observationally_equivalent_example_3 :
  ~ observationally_equivalent
      (pls @ c_one @ c_zero)
      omega.
Proof.
  apply normalizable_and_divergent_not_observationally_equivalent.
  apply one_pls_zero_normalizable.
  apply omega_not_normalizable.
Qed.

Lemma observationally_equivalent_example_4 :
  observationally_equivalent
    (pls @ c_one @ c_zero)
    c_one.
Proof.
  (* Hint: This proof can be pretty short.  You may find one or more
     of the examples and lemmas from earlier in the file useful... *)
  (* SOLUTION *)
  apply normalizable_terms_observationally_equivalent.
  apply one_pls_zero_normalizable.    
  apply simplify_steps__normalizable with (t' := c_one).
    steps. reflexivity.
Qed.

Lemma observationally_equivalent_example_5 :
  observationally_equivalent
    (pls @ c_one @ c_zero)
    c_zero.
Proof.
  (* Hint: This proof should be very similar to the previous one. *)
  (* SOLUTION *)
  apply normalizable_terms_observationally_equivalent.
  apply one_pls_zero_normalizable.    
  apply simplify_steps__normalizable with (t' := c_zero).
    steps. reflexivity.
Qed.
(* This example illustrates the point that observational equivalence,
   by itself, is too course to be useful: it identifies terms that
   "behave the same" to a first approximation -- they both converge --
   but that contain within themselves the possibility of behaving
   differently if we apply them to other things. *)

(* If we apply these to just a single argument, we still get
   observationally equivalent terms.  (Note the use of hypothetical
   reasoning about evaluation here.) *)
Lemma observationally_equivalent_example_7 : forall t,
     value t 
  -> observationally_equivalent
       (pls @ c_one @ c_zero @ t)
       (c_one @ t).
Proof.
  intros t Vt.
  apply normalizable_terms_observationally_equivalent.
    CASE "(pls @ c_one @ c_zero @ t) normalizable".
      unfold normalizable.
      apply ex_intro with (witness := \z, c_one @ t @ (c_zero @ t @ z)).
      apply conj. apply evalmany_example_0. assumption. unfold normal_form.
      intros C. solve by inversion 2.
    CASE "(c_one @ t) normalizable".
      unfold normalizable.
      apply ex_intro with (witness := \z, t @ z).
      apply conj. apply evalmany_example_3. assumption. unfold normal_form.
      intros C. solve by inversion 2.
Qed.

(* However, if we apply them to two (carefully chosen) arguments, we
   obtain terms that are *not* observationally equivalent. *)
Lemma observationally_equivalent_example_6 : 
  ~ observationally_equivalent
      (pls @ c_one @ c_zero @ poisonpill @ tru)
      (c_zero @ poisonpill @ tru).
Proof.
  intros C.
  apply observational_equivalence_symmetric in C.
  generalize dependent C.
  apply normalizable_and_divergent_not_observationally_equivalent.
  apply normalizable_example_6.
  apply normalizable_example_5.
Qed.
(* This example will be used to show, below, that these terms are
   *not* behaviorally equivalent. *)

(* Finally, let us record one deeper fact about observational
   equivalence: That it is strictly coarser than the [eval]
   relation -- i.e., that every pair of terms related by evaluation is
   also related by observational equivalence.  (We'll use this to show
   a similar fact about behavioral equivalence later.) *)

Lemma eval_preserves_observational_equivalence : forall t t',
     eval t t'
  -> observationally_equivalent t t'.
Proof.
  (* SOLUTION *)
  intros t t' E. unfold observationally_equivalent. 
  unfold normalizable. unfold iff. apply conj.
    CASE "->". 
      intros N. inversion N. apply ex_intro with (witness:=witness).
      destruct H. 
      apply conj.
        SCASE "evalmany'". inversion H; subst.
          SSCASE "rtc'_refl". unfold normal_form in H0. unfold not in H0.
            assert False. apply H0. apply ex_intro with (witness:=t'). 
            assumption.
            solve by inversion.
          SSCASE "rtc'_step".
            assert (partial_function _ eval) as ED.
              apply eval_deterministic.
            assert (t'=y). 
              unfold partial_function in ED. apply ED with (x:=t). 
              assumption. assumption.
            subst. assumption.
        SCASE "eval_normal_form". assumption.
    CASE "<-". 
      intros N. inversion N. apply ex_intro with (witness:=witness).
      destruct H. apply conj.
        SCASE "evalmany'". apply rtc'_step with (y:=t'). assumption. assumption.
        SCASE "eval_normal_form". assumption.        
         
Qed.

(* ---------------------------------------------------------------------- *)
(* Behavioral equivalence *)

(* Now let us define behavioral equivalence.  The intuition is that
   two terms are behaviorally equivalent if the results of any
   experiment we can make on them (by applying them to arbitrary
   numbers of arguments) are observationally equivalent.  

   Formally, we begin by defining an operation of "applying a term [t]
   to a list of closed values [v1,...,vn]"... *)

Fixpoint apply_list (base : tm) (ts : list tm) {struct ts} : tm :=
  match ts with
  | nil => base
  | t1 :: ts' => apply_list (base@t1) ts'
  end.

Inductive all_closed_values : list tm -> Prop :=
  | acv_nil : 
         all_closed_values (nil _)
  | acv_cons : forall t1 ts, 
         closed t1 
      -> value t1 
      -> all_closed_values ts 
      -> all_closed_values (t1::ts).

(* ... and then define behavioral equivalence in terms of this
   operation together with the observational equivalence relation
   defined above. *)
Definition behaviorally_equivalent (t1 t2 : tm) := forall ts,
     all_closed_values ts
  -> observationally_equivalent
       (apply_list t1 ts)
       (apply_list t2 ts).

(* Before getting to examples, let's examine some basic properties of
   behavioral equivalence. 

   First, let's verify that it *is* an equivalence relation -- i.e.,
   that it is reflexive, transitive, and symmetric. *)

Lemma behavior_equivalence_reflexive : forall t,
     behaviorally_equivalent t t.
Proof.
  unfold behaviorally_equivalent. unfold observationally_equivalent. unfold iff.
  intros t ts H. apply conj.
    CASE "->". intro N. assumption.
    CASE "<-". intro N. assumption.
Qed.

Lemma behavior_equivalence_transitive : forall t1 t2 t3,
     behaviorally_equivalent t1 t2
  -> behaviorally_equivalent t2 t3
  -> behaviorally_equivalent t1 t3.
Proof.
  unfold behaviorally_equivalent. unfold observationally_equivalent. unfold iff.
  intros t1 t2 t3 H1 H2 ts H0. apply conj.
    CASE "->". intro N. assert (all_closed_values ts) as H0'.  assumption.
      apply H2 in H0. destruct H0. apply H. apply H1 in H0'. destruct H0'. 
      apply H3. assumption.
    CASE "<-". intro N. assert (all_closed_values ts) as H0'.  assumption.
      apply H1 in H0. destruct H0. apply H0. apply H2 in H0'. destruct H0'. 
      apply H4. assumption.
Qed.

Lemma behavior_equivalence_symmetric : forall t1 t2,
     behaviorally_equivalent t1 t2
  -> behaviorally_equivalent t2 t1.
Proof.
  unfold behaviorally_equivalent. unfold observationally_equivalent. unfold iff.
  intros t1 t2 H ts H0. apply conj.
    CASE "->". intro N. apply H in H0. destruct H0. apply H1. assumption.
    CASE "<-". intro N. apply H in H0. destruct H0. apply H0. assumption.
Qed.

(* Next, let's check that behavioral equivalence is coarser
   than (i.e., includes) single-step evaluation... *)

Lemma eval_preserves_behavioral_equivalence : forall t t',
     eval t t'
  -> behaviorally_equivalent t t'.
Proof.
  unfold behaviorally_equivalent. intros t t' He ts Hv.
  apply eval_preserves_observational_equivalence.
  (* SOLUTION *)
  generalize dependent t'. generalize dependent t.
  induction ts; intros t t' He.
  CASE "nil". simpl. assumption.
  CASE "cons". simpl. apply IHts.
    SCASE "all_closed_values". simpl. inversion Hv. assumption.
    SCASE "eval". apply E_App1. assumption.
Qed.

(* ... and multi-step evaluation: *)

Lemma evalmany_preserves_behavioral_equivalence : forall t1 t', 
  evalmany t1 t' -> behaviorally_equivalent t1 t'.
Proof.
  intros t1 t' He. induction He.
  SCASE "rtc'_refl". 
    apply behavior_equivalence_reflexive.
  SCASE "rtc'_step". 
    apply behavior_equivalence_transitive with (t2:=y).
    apply eval_preserves_behavioral_equivalence. 
      assumption. assumption.
Qed.

(* Building on this, we can show that if two terms [t1] and [t2]
   evaluate to the same term [t'], then [t1] and [t2] are behaviorally
   equivalent.  (Note that [t'] need not be a normal form -- it can be
   any term.  This means that we can use this lemma to reason about
   behavioral equivalence of non-terminating terms; we'll see an
   example below.) *)

Lemma terms_reaching_same_term_are_behaviorally_equivalent : forall t1 t2 t',
     evalmany t1 t'
  -> evalmany t2 t'
  -> behaviorally_equivalent t1 t2.
Proof.
  intros t1 t2 t' He1 He2.
  apply behavior_equivalence_transitive with (t2:=t').
    CASE "t1 t'". 
      apply evalmany_preserves_behavioral_equivalence. assumption.
    CASE "t' t2". 
      apply behavior_equivalence_symmetric. 
      apply evalmany_preserves_behavioral_equivalence. assumption.
Qed.

(* Now let's see some examples of behavioral equivalence.  First, as a
   sanity check, let's show that

     pls @ c_one @ c_zero

   and

     c_zero

   are NOT behaviorally equivalent.  To do this, we'll need to use the
   example shown at the end of the observational equivalence section,
   where we saw that these two terms are not observationally
   equivalent when applied first to [tru] and then to [poisonpill].  
*)

Lemma tru_closed :
  closed tru.
Proof.
  unfold closed. intros x. intros A. inversion A; subst. 
  inversion H3; subst. 
  inversion H5. 
  apply eqnat_no in H2. unfold not in H2. apply H2 in H1. solve by inversion.
Qed.
Lemma c_zero_closed :
  closed c_zero.
Proof.
  unfold closed. intros x. intros A. inversion A; subst. 
  inversion H3; subst. 
  inversion H5.
  apply eqnat_no in H4. unfold not in H4. apply H4 in H1. solve by inversion.
Qed.

Lemma poisonpill_closed :
  closed poisonpill.
Proof.
  unfold closed. intros x. intros A. inversion A; subst. 
  inversion H3; subst. inversion H1; subst.  
  inversion H6; subst. inversion H4; subst. 
  apply eqnat_no in H5. apply H5. reflexivity.
  inversion H4; subst. 
  apply eqnat_no in H5. apply H5. reflexivity.
  inversion H1; subst.  
  inversion H6; subst. inversion H4; subst. 
  apply eqnat_no in H5. apply H5. reflexivity.
  inversion H4; subst. 
  apply eqnat_no in H5. apply H5. reflexivity.  
Qed.

(* A sanity check *)
Lemma behaviorally_equivalent_example_0 : 
  ~ behaviorally_equivalent 
     (pls @ c_one @ c_zero)
     c_zero.
Proof.
  unfold behaviorally_equivalent. intros C.
  assert (exists ts, 
                all_closed_values ts
            /\ ~ observationally_equivalent
                   (apply_list (pls @ c_one @ c_zero) ts)
                   (apply_list c_zero ts)).
    apply ex_intro with (witness := [poisonpill, tru]).
      CASE "Pf of assertion". apply conj.
        SCASE "all_closed_values".
          apply acv_cons. apply poisonpill_closed. apply v_abs.
          apply acv_cons. apply tru_closed. apply v_abs.
          apply acv_nil.
        SCASE "not obs equiv".
          apply observationally_equivalent_example_6.
    destruct H. destruct H. apply H0. apply C. assumption.
Qed.

(* Finally, let's go back to the example that motivated the whole
   discussion: let's show that [pls @ c_one @ c_zero] and [c_one] are
   behaviorally equivalent.

   We do this in two steps.  First, we show that, for any closed
   values [t] and [t0], the terms [pls @ c_one @ c_zero @ t @ t0] and
   [c_one @ t @ t0] are behaviorally equivalent.  This is easy because
   they actually reach the same term after a few steps of
   evaluation. *)

Lemma behaviorally_equivalent_example_1 : forall t t0,
     value t 
  -> closed t
  -> value t0
  -> behaviorally_equivalent 
      (pls @ c_one @ c_zero @ t @ t0)
      (c_one @ t @ t0).
Proof.
  intros t t0 Ct Vt Vt0.
  apply terms_reaching_same_term_are_behaviorally_equivalent
    with (t' := t @ t0).
  apply evalmany_example_1; assumption.
  apply evalmany_example_2; assumption.
Qed.

(* Now we can extend this to the terms that we originally had in
   mind. *)

Lemma behaviorally_equivalent_example_2 : 
  behaviorally_equivalent 
   (pls @ c_one @ c_zero)
   c_one.
Proof.
  (* Proof sketch: We must show that, for any list of closed values
     [ts], the terms [apply_list (pls @ c_one @ c_zero) ts] and
     [apply_list c_one ts] are observationally equivalent.  Reason by
     cases on [ts].
        - If [ts] is empty, the result follows because [pls @ c_one @
          c_zero] and [c_one] both normalize, as we saw above.
        - If [ts] contains a single element [t], the result follows
          because [pls @ c_one @ c_zero @ t] and [c_one @ t] both
          normalize, as we saw above.
        - Otherwise, suppose [ts] contains two or more elements --
          i.e., [ts] = [t :: t0 :: ts'].  We showed above that [pls @
          c_one @ c_zero @ t @ t0] and [c_one @ t @ t0] are
          behaviorally equivalent.  But this means precisely that, for
          any list of closed values [ts'], the terms (apply_list (pls
          @ c_one @ c_zero @ t @ t0) ts'] and [apply_list (c_one @ t @
          t0) ts'] are observationally equivalent --
          i.e., (apply_list (pls @ c_one @ c_zero) (t :: t0 :: ts')]
          and [apply_list (c_one) (t :: t0 :: ts')] are
          observationally equivalent. *)
  (* SOLUTION *)
  unfold behaviorally_equivalent. intros ts A.
  destruct ts.
  apply observationally_equivalent_example_4.
  destruct ts. simpl.
  apply observationally_equivalent_example_7. inversion A. assumption.
  simpl. inversion A; subst. inversion H3; subst. 
  assert (behaviorally_equivalent 
            (pls @ c_one @ c_zero @ t @ t0) 
            (c_one @ t @ t0)) as B.
     apply behaviorally_equivalent_example_1. 
     assumption. assumption. assumption.
  unfold behaviorally_equivalent in B.
  apply B. assumption. 
Qed.

(* OPTIONAL THOUGHT EXERCISE (not to be handed in, and only for those
   who enjoy a little extra challenge): Can we use a similar line of
   argument to show that [pls @ c_one @ c_one] is behaviorally
   equivalent to [c_two]? *)


End LambdaExamplesContd'.
End LambdaContd'.

(* ====================================================================== *)
(* ====================================================================== *)
(* ====================================================================== *)
(* LECTURE 17 *)

(* ADMINISTRIVIA:

      - Next Wednesday is the second midterm.  

        -----> Class that day will meet in the Skirkanich
               auditorium (Berger Aud, room 13 in the basement of
               Skirkanich), not Wu and Chen!  <-----

      - Next Monday will be a review session

      - A set of review exercises will be available by late Sunday 
*)

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

(* 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.
  (* SOLUTION *)
  intros X k j v w l neq H. induction l.
    simpl. simpl in H. rewrite -> neq in H.
     rewrite -> H. reflexivity.
    simpl. destruct x as (j0,a). simpl in H.
     remember (eqnat k j0) as e. destruct e.
       rewrite -> H. reflexivity.
       apply IHl. assumption.
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).
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". *)

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

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

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.
  (* SOLUTION *)
  apply ex_intro with (witness := (A-->B) --> (B-->C) --> A --> C).
  apply T_Abs.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (S := B).
  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_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.
  (* SOLUTION *)
  intros C. destruct C. 
  inversion H. subst. 
  inversion H5. subst. 
  inversion H6. subst.
  inversion H7. subst. 
  inversion H3. subst.
  unfold binds in H2. simpl in H2. inversion H2. subst.
  unfold binds in H4. simpl in H4. inversion H4.
Qed.  

Lemma typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |- (\x \in S, x @ x) \in T).
Proof.
  (* SOLUTION *)
  intros C. destruct C. 
  inversion H. subst.  clear H. 
  inversion H0. subst. clear H0.
  inversion H5. subst. clear H5.
  inversion H2. subst. clear H2.
  inversion H4. subst. clear H4.
  unfold binds in H1. unfold binds in H2.
  rewrite H2 in H1. clear H2.
  inversion H1. clear H1.
  (* At this point, we have an assumption that [S] is equal to
     [S-->T2].  But there can't be any such (finite) [S]. *)
  induction S. 
    inversion H0.
    inversion H0.  apply IHS1. rewrite <- H2. assumption.
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.) *)
      (* SOLUTION *)
      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.
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.) *)
  (* SOLUTION *)
  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.


End SimplyTypedLambdaCalculus.