(** * Software Foundations, Formally   
      Benjamin C. Pierce
      Version of 10/31/2007

   Before handing in this file with your homework solutions, please
   fill in the names of all members of your group:
     FILL IN HERE

   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).
     FILL IN HERE

*)

Require Export lec1213. 

(* ====================================================================== *)
(* More on programming in the lambda-calculus *)

Module LambdaContd.
Export Lambda.

Module LambdaExamplesAgain.

(* ====================================================================== *)
(* LECTURE 15 *)

(* EXERCISE: 
     - Part 1: What is the normal form of the lambda-expression
      
                 foo @ c_two @ AA @ BB  

       given the following definitions...?  (No need to hand anything
       in for this -- you'll just use the answer in the next part of
       the exercise -- but it's important to think about it on paper
       before starting to work with Coq...) *)

Notation f_foo := (\f,
                      \n,
                         pls 
                           @ c_one 
                           @ (test @ (iszro @ n)
                              @ (\z, c_zero)
                              @ (\z, f @ (prd @ n)))).

Notation foo := (Z @ f_foo).

Notation Z_foo := 
                 (\y,   (\x, f_foo @ (\y, x @ x @ y)) 
                      @ (\x, f_foo @ (\y, x @ x @ y)) 
                      @ y).


(* 
     - Part 2: Write a series of lemmas in the same style as above,
       demonstrating this.
*)
(* FILL IN HERE *)

End LambdaExamplesAgain.


(* ====================================================================== *)
(* Properties of evaluation *)

(* Now that we've developed a little intuition about what the
   lambda-calculus is like by writing programs in it, it's time to
   turn our attention to some of its theoretical properties... *)

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

(* Since "everything is a function in the lambda-calculus," we might
   expect that a progress theorem would hold for this language.  This
   is intuitively true, but we need to be a little careful about how
   we state the details.

   First, if we consider terms containing constants, then it certainly
   *is* possible to have a term that is stuck -- a normal form but not
   a value.  For example, the term [AA @ (\x,x)] is stuck.

   Since we are mainly interested in the properties of the pure
   lambda-calculus, such examples need not worry us.  But if we want
   to state a progress theorem that's true, we need to eliminate
   them by restricting attention to "pure terms"... *)

Inductive pure : tm -> Prop :=
  | p_var : forall x, pure (tm_var x)
  | p_app : forall t1 t2, pure t1 -> pure t2 -> pure (t1 @ t2)
  | p_abs : forall x t1, pure t1 -> pure (\x,t1).

Lemma pure__not_only_constants : forall t,
  pure t -> only_constants t = no.
Proof.
  intros t P. induction P.
    CASE "p_var". reflexivity.
    CASE "p_app". simpl. rewrite IHP1. rewrite IHP2. reflexivity.
    CASE "p_abs". reflexivity.
Qed.

(* This helps, but it's not quite enough.  Terms like [x @ y] are also
   stuck, because we didn't include variables in the set of values.
   There are technical reasons for doing things this way (it
   simplifies the definition of substitution, as well see when we look
   at full beta-reduction in a few minutes).  So we should leave the
   definition of value as it is but refine the statement of the
   progress theorem so that it only applies to terms with no variables
   "free" at the top level. *)

Inductive appears_free_in : name -> 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 t1, 
        eqname x y = no
     -> appears_free_in x t1 
     -> appears_free_in x (\y,t1).

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

Theorem pure_closed_terms_are_not_stuck : forall t,
  pure t -> closed t -> (value t \/ exists t', eval t t').
Proof.
  intros t HP. induction HP.
    CASE "var". intros C. unfold closed in C. 
      assert (appears_free_in x (!x)).
        SCASE "Pf of assertion". apply afi_var. 
      unfold not in C. apply C with (x0 := x) in H. solve by inversion.
    CASE "app".
      intros H. unfold closed in H. 
      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 H with (x:=x). assumption.
      assert (value t1 \/ (exists t' : tm, eval t1 t')).
        apply IHHP1. 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 H with (x:=x). assumption.
      assert (value t2 \/ (exists t' : tm, eval t2 t')).
        apply IHHP2. assumption.
      apply or_intror.       
      inversion H1; inversion H3; subst.
        SCASE "t1 value / t2 value".
          inversion H4. 
            SSCASE "constant value".
              apply pure__not_only_constants in HP1. 
              rewrite HP1 in H6. solve by inversion.
            SSCASE "abstraction value".
              apply ex_intro with (witness := {x |-> t2}t).
              apply E_AppAbs. assumption.
        SCASE "t1 value / t2 steps".
          inversion H5.
          apply ex_intro with (witness := t1 @ witness).
          apply E_App2. assumption. assumption. 
        SCASE "t1 steps / t2 value".
          inversion H4.
          apply ex_intro with (witness := witness @ t2).
          apply E_App1. assumption. 
        SCASE "t1 steps / t2 steps".
          inversion H4.
          apply ex_intro with (witness := witness @ t2).
          apply E_App1. assumption. 
    CASE "abs".
      intros H. apply or_introl. apply v_abs.
Qed.

(* ---------------------------------------------------------------------- *)
(* Call-by-name evaluation *)


Inductive eval_cbn : tm -> tm -> Prop :=
  | En_AppAbs : forall x t12 v2,
         eval_cbn ((\x, t12) @ v2) ({x |-> v2} t12)
  | En_App1 : forall t1 t1' t2,
         eval_cbn t1 t1'
      -> eval_cbn (t1 @ t2) (t1' @ t2).

Fixpoint simplify_step_cbn (t:tm) {struct t} : option tm :=
  match t with
  | t1 @ t2 =>
      match t1 with
      | \x,t12 => Some _ (({x |-> t2} t12))
      | _ => 
          match simplify_step_cbn t1 with
          | None => None _
          | Some t1' => Some _ (t1' @ t2)
          end
      end
  | _ => None _
  end.

Lemma simplify_step_cbn__eval_cbn : forall t t',
     simplify_step_cbn t = Some _ t'
  -> eval_cbn t t'.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.


(* ---------------------------------------------------------------------- *)
(* Nondeterministic outer evaluation *)

Inductive eval_ndo : tm -> tm -> Prop :=
  | Endo_AppAbs : forall x t12 v2,
         eval_ndo ((\x, t12) @ v2) ({x |-> v2} t12)
  | Endo_App1 : forall t1 t1 t1',
         eval_ndo t1 t1'
      -> eval_ndo (t1 @ t2) (t1' @ t2)
  | Endo_App2 : forall t1 t2 t2',
         eval_ndo t2 t2'
      -> eval_ndo (t1 @ t2) (t1 @ t2').


(* ---------------------------------------------------------------------- *)
(* Full nondeterministic evaluation *)

(* Also known as FULL BETA-REDUCTION (because the "beta-reduction
   rule," Efull_AppAbs, can be applied anywhere in the term at each
   step). *)

Inductive eval_full : tm -> tm -> Prop :=
  | Efull_AppAbs : forall x t12 v2,
         eval_full ((\x, t12) @ v2) ({x |-> v2} t12)
  | Efull_App1 : forall t1 t1' t2,
         eval_full t1 t1'
      -> eval_full (t1 @ t2) (t1' @ t2)
  | Efull_App2 : forall t1 t2 t2',
         eval_full t2 t2'
      -> eval_full (t1 @ t2) (t1 @ t2')
  | Efull_Abs : forall x t1 t1',
         eval_full t1 t1'
      -> eval_full (\x, t1) (\x, t1').

(* However, something is a little bit wrong with this definition... *)

(* Remember the principle that renaming a bound variable should not
   change a program's meaning: if [y] is not free in [t], then [\x,t]
   and [\y, {x|->y}t] should behave exactly the same.

   Unfortunately, if we allow evaluation under lambda abstractions (as
   we are doing here), this property breaks...
*)

Module LambdaExamplesContd.
Export LambdaExamplesAgain.

Lemma uh_oh_1 : 
  eval_full 
    (\y, (\x, \y, x) @ (\z, y)) 
    (\y, (\y, \z, y)).
Proof.
  apply Efull_Abs. 
  assert ({x |-> (\z, y)}(\y, x) = (\y, \z, y)).
    reflexivity.
  rewrite <- H.
  apply Efull_AppAbs.
Qed.

Lemma uh_oh_2 : 
  eval_full 
    (\y, (\x, \w, x) @ (\z, y)) 
    (\y, (\w, \z, y)).
Proof.
  apply Efull_Abs. 
  assert ({x |-> (\z, y)}(\w, x) = (\w, \z, y)).
    reflexivity.
  rewrite <- H.
  apply Efull_AppAbs.
Qed.

(* But these results -- [\y, (\y, \z, y)] and [\y, (\w, \z, y)] --
   behave differently!  (I.e., just renaming a bound variable caused
   reduction to give us different answers).  For example,

      (\y, (\y, \z, y)) omega 

   has a normal form, while

      (\y, (\w, \z, y)) omega 

   does not. *)

(* OPTIONAL EXERCISE: Think about how to redefine the substitution
   function to avoid this problem.  Then read the end of TAPL chapter
   5. *)

End LambdaExamplesContd.


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

(* We're going to want to use the following definition in later
   lectures, so let's temporarily close the Module we're in, give the
   definition at the top level, and then open a new module that
   imports the one we're currently in. *) 
End LambdaContd.

(* 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 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.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

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.

Module LambdaContd'.
Export LambdaContd.

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

Module RememberExamples.

(* Another brief digression to introduce a useful tactic. 

   [This material also appeared in last week's lecture notes; I'm
   including it here too because today is when we'll 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.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

End RememberExamples.


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

Notation evalmany' := (refl_trans_closure' _ eval). 
Notation eval_normal_form := (normal_form _ eval).  
(*
Definition normal_form_of (t t' : tm) :=
  exists n, normalize t n = Some _ t'.
*)

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

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

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.

Module LambdaExamplesContd'.
Export LambdaExamplesContd.

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.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

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.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma observationally_equivalent_example_3 :
  ~ observationally_equivalent
      (pls @ c_two @ c_two @ AA @ BB)
      omega.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma eval_preserves_observational_equivalence : forall t t',
     eval t t'
  -> observationally_equivalent t t'.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.


(* Behavioral equivalence *)

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_values : list tm -> Prop :=
  | av_nil : all_values (nil _)
  | av_cons : forall t1 ts, value t1 -> all_values ts -> all_values (t1::ts).

Definition behaviorally_equivalent (t1 t2 : tm) := forall ts,
     all_values ts
  -> observationally_equivalent
       (apply_list t1 ts)
       (apply_list t2 ts).

Lemma behavior_equivalence_reflexive : forall t,
     behaviorally_equivalent t t.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma behavior_equivalence_transitive : forall t1 t2 t3,
     behaviorally_equivalent t1 t2
  -> behaviorally_equivalent t2 t3
  -> behaviorally_equivalent t1 t3.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma behavior_equivalence_symmetric : forall t1 t2,
     behaviorally_equivalent t1 t2
  -> behaviorally_equivalent t2 t1.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma eval_preserves_behavioral_equivalence : forall t t',
     eval t t'
  -> behaviorally_equivalent t t'.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma terms_reaching_same_term_are_behaviorally_equivalent : forall t1 t2 t',
     evalmany' t1 t'
  -> evalmany' t2 t'
  -> behaviorally_equivalent t1 t2.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

End LambdaExamplesContd'.

End LambdaContd'.