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

   Any thoughts or comments on this assignment?
     FILL IN HERE
*)

(* ---------------------------------------------------------------------- *)
Require Export lec19.


(* ====================================================================== *)
(* Motivation for Subtyping *)

Module STLCWithRecords'.
Export STLCWithRecords.
Export STLCWithRecords.Examples.

(* TAPL chapter 15 is useful background for this week's material. *)

(* Here is a slight variant of the non-example that we saw in Lecture 18. *)
Lemma typing_nonexample_2 : 
  ~ exists T,
      empty |- (\r~[[y~B-->B]], r # y) 
                @ [|x==(\z~A,z),y==(\z~B,z)|] 
             ~ T.
Proof. 
  intros C. destruct C.
  inversion H. subst. clear H.
  inversion H3. subst. clear H3.
  inversion H5. 
Qed.
(* This term is not typable because it involves an application of a
   function that wants a one-field record to an argument that actually
   provides two fields.  

   But this is a bit silly.  The only thing the body of the function
   can possibly do with its record argument [r] is project the field
   [y] from it: nothing else is allowed by the type.  So the presence
   or absence of an extra [x] field should make no difference at all.
   In general, a longer record type is "better than" a shorter
   one (with just a subset of its fields), in the sense that any value
   belonging to the longer record type can be used SAFELY in any
   context expecting the shorter record type.

   This idea can be pushed further.  For example, suppose:
       f  ~  C --> [[x~A-->A,y~B-->B]]
       g  ~  (C-->[[y~B-->B]]) --> D
   That is, [f] is a function that yields a record of type
   [[x~A-->A,y~B-->B]], and [g] is a higher-order function that its
   argument to yield a record of type [[y~B-->B]].  Then it is safe to
   pass [f] as an argument to [g] even though their types do not match
   up precisely, because the only thing [g] can do with [f] is to
   apply it to some argument (of type [C]).  The result of each such
   application will actually be a two-field record, while [g] will be
   expecting only a record with a single field; but this is safe,
   since the only thing [g] can then do is to project out the single
   field that it knows about, and this will certainly be among the two
   fields that are present.
      
   The general principle at work here is called SUBTYPING.  We say
   that "[S] is a subtype of [T]", written [S <: T], if a value of
   type [S] can safely be used in any context where a value of type
   [T] is expected.  This principle plays a fundamental role in many
   widely used programming languages -- in particular, it is closely
   related to the notion of SUBCLASSING in object-oriented languages.

   Our goal for today is to add subtyping to the simply typed
   lambda-calculus with records.  This involves two steps:
      - 1. Defining subtyping as a binary relation between types.
      - 2. Enriching the typing relation to take subtyping into
           account.

   The second step is actually very simple.  We add just a single rule
   to the typing relation -- the so-called RULE OF SUBSUMPTION:

           | T_Sub : forall Gamma t S T,
                  Gamma |- t ~ S
               -> S <: T
               -> Gamma |- t ~ T
   
   This rule says, intuitively, that we can "forget" some of the
   information that we know about a term.  For example, we may know
   that [t] is a record with two fields (i.e., [ S =
   [[x~A-->A,y~B-->B]] ], but choose to forget about one of the
   fields (i.e., [ T = [[y~B-->B]] ] so that we can pass [t] to a
   function that expects just a single-field record.

   The first step -- the definition of the relation [S <: T] -- is
   where all the action is.  Let's look at each of the clauses of its
   definition.

   To begin with, we need to formalize the basic intuition about
   record types that a longer record should be a subtype of a shorter
   one.  Since our record types are presented in a "binary" form (with
   constructors for nil and cons, rather than a single constructor
   that assembles a whole multi-field record all at once), we need to
   formulate subtyping in the same terms.  This can be accomplished by
   a combination of three rules.  First, any record type is a subtype
   of the empty record type:

           | S_Rcdwidth : forall k T1 T2,
                  [[k~T1;T2]] <: [[]]
               
   Second, we can drop later fields of a multi-field record while
   keeping earlier fields:

           | S_Rcddepth : forall k S1 T1 T2,
               -> S2 <: T2
               -> [[k~S1;S2]] <: [[k~S1;T2]]

   For example, we can use S_Rcddepth and S_Rcdwidth together to show that 
   [[y~B-->B, x~A-->A]] <: [[y~B-->B]].

   Actually, we can generalize S_Rcddepth a little to allow the type
   of the first field to vary at the same time:

           | S_Rcddepth : forall k S1 S2 T1 T2,
                  S1 <: T1
               -> S2 <: T2
               -> [[k~S1;S2]] <: [[k~T1;T2]]

   Now we can use S_Rcddepth and S_Rcdwidth together to show that
   [[ y~[[z~B-->B]], x~A-->A ]] <: [[ y~[[]] ]].  

   The example we originally had in mind was [[x~A-->A,y~B-->B]] <:
   [[y~B-->B]].  We haven't quite achieved this yet: using just
   S_Rcddepth and S_Rcdwidth we can only drop fields from the END of a
   record type.  To handle the original example, we also need to be
   able to reorder fields:

           | S_Rcdperm : forall k1 k2 S1 S2 S3,
                  k1 <> k2
               -> [[k1~S1; [[k2~S2; S3]] ]] <: [[k2~S2; [[k1~S1; S3]] ]]

   For example, [[x~A-->A,y~B-->B]] <: [[y~B-->B,x~A-->A]].

   We can also include a general rule of TRANSITIVITY, which
   says (intuitively) that, if [S] is better than [U] and [U] is
   better than [T], then [S] is better than [T].

           | S_Trans : forall S U T,
                  S <: U
               -> U <: T
               -> S <: T

   This rule allows us to paste together the proof that
   [[x~A-->A,y~B-->B]] <: [[y~B-->B,x~A-->A]] using S_Rcdperm with the
   earlier proof that [[y~B-->B, x~A-->A]] <: [[y~B-->B]] using
   S_Rcddepth and S_Rcdwidth, to yield a proof that
   [[x~A-->A,y~B-->B]] <: [[y~B-->B]].

   This completes the subtyping rules for records.  To finish the
   whole definition of subtyping, we need to consider how each of the
   other type constructors behaves with respect to subtyping.  Since
   we're dealing with a very simple language with just arrows and
   records, we have only arrows left to deal with.

   The rule suggested above says that two arrow types are in the
   subtype relation if their results are:

           | S_Arrow : forall S1 T1 T2,
                  S2 <: T2
               -> S1-->S2 <: S1-->T2

   We can generalize this rule a little so that the arguments of the
   two arrow types are also in a subtype relation:

           | S_Arrow : forall S1 S2 T1 T2,
                  T1 <: S1
               -> S2 <: T2
               -> S1-->S2 <: T1-->T2

   Notice, here, that the argument types are in the subtype relation
   "the other way round": we demand that [T1] be a subtype of [S1].
   This is called CONTRAVARIANCE. 

   Finally, we add one last structural rule, which (together with
   transitivity) ensures that the subtype relation is a preorder:

           | S_Refl : forall T,
                  T <: T

   We can stop here, if we like.  But it is common practice to go one
   further step and add to the language one new type constant, called
   Top, together with a subtyping rule that places it above every
   other type in the subtype relation:

           | S_Top : forall S,
                  S <: Top

*)

End STLCWithRecords'.

(* ====================================================================== *)
(* STLC with records and subtyping *)

Module STLCWithSubtyping.

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

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

Tactic Notation "ty_cases" tactic(first) tactic(c) :=
  first;
  [ c "ty_top" | c "ty_base" | c "ty_arrow" | c "ty_rcd_nil" | c "ty_rcd_cons"].

Inductive tm : Set :=
  | tm_var : nat -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : nat -> ty -> tm -> tm
  | tm_rcd_nil : tm
  | tm_rcd_cons : nat -> tm -> tm -> tm
  | tm_proj : tm -> nat -> tm.

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

Notation A := (ty_base one).
Notation B := (ty_base two).
Notation C := (ty_base three).
Notation Top := (ty_top).
Notation "S --> T" := (ty_arrow S T) (at level 20, right associativity).

Notation "[[ ]]" := (ty_rcd_nil).
Notation "[[ l1 ~ T1 ]]" := (ty_rcd_cons l1 T1 ty_rcd_nil).
Notation "[[ l1 ~ T1 ; T2 ]]" := (ty_rcd_cons l1 T1 T2).
Notation "[[ l1 ~ T1 , l2 ~ T2 ]]" :=
  (ty_rcd_cons l1 T1 (ty_rcd_cons l2 T2 ty_rcd_nil)).
Notation "[[ l1 ~ T1 , l2 ~ T2 , l3 ~ T3 ]]" :=
  (ty_rcd_cons l1 T1 (ty_rcd_cons l2 T2 (ty_rcd_cons l3 T3 ty_rcd_nil))).

Notation "! n" := (tm_var n) (at level 39).
Notation "\ x ~ T , t" := (tm_abs x T t) (at level 42).
Notation "r @ s" := (tm_app r s) (at level 40, left associativity).
Notation "r # s" := (tm_proj r s) (at level 41).



Notation "[| |]" :=
  (tm_rcd_nil).
Notation "[| l1 == t1 |]" :=
  (tm_rcd_cons l1 t1 tm_rcd_nil).
Notation "[| l1 == t1 ; t2 |]" := (tm_rcd_cons l1 t1 t2).
Notation "[| l1 == t1 , l2 == t2 |]" :=
  (tm_rcd_cons l1 t1 (tm_rcd_cons l2 t2 tm_rcd_nil)).
Notation "[| l1 == t1 , l2 == t2 , l3 == t3 |]" :=
  (tm_rcd_cons l1 t1 (tm_rcd_cons l2 t2 (tm_rcd_cons l3 t3 tm_rcd_nil))).

(* ---------------------------------------------------------------------- *)
(* Operational semantics *)

(* Exactly the same as before *)

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

Fixpoint subst (x:nat) (s:tm) (t:tm) {struct t} : tm :=
  match t with
  | !y => if eqnat x y then s else t
  | \y~T, t1 => if eqnat x y then t else \y~T, {x |-> s}t1
  | t1 @ t2 => ({x |-> s}t1) @ ({x |-> s}t2)
  | [||] => [||]
  | [| l==t1; t2 |] => [| l=={x |-> s}t1; {x |-> s}t2 |]
  | t # k => ({x |-> s}t) # k
  end

where "{ x |-> s } t" := (subst x s t).

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
         value (\x~T, t)
  | v_rcd_nil :
         value [||]
  | v_rcd_cons : forall l t1 t2,
         value t1
      -> value t2
      -> value [| l==t1; t2|].

Inductive eval : tm -> tm -> Prop :=
  | E_AppAbs : forall x T t12 v2,
         value v2
      -> eval ((\x~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')
  | E_Rcdcons1 : forall k t1 t1' t2,
         eval t1 t1'
      -> eval [|k==t1;t2|] [|k==t1';t2|]
  | E_Rcdcons2 : forall k t1 t2 t2',
         value t1
      -> eval t2 t2'
      -> eval [|k==t1;t2|] [|k==t1;t2'|]
  | E_ProjRcdcons1 : forall k t1 t2,
         value t1
      -> value t2
      -> eval ([|k==t1;t2|] # k) t1
  | E_ProjRcdcons2 : forall k k' t1 t2,
         value t1
      -> value t2
      -> k <> k'
      -> eval ([|k'==t1;t2|] # k) (t2 # k)
  | E_Proj : forall k t t',
         eval t t'
      -> eval (t # k) (t' # k).

Tactic Notation "eval_cases" tactic(first) tactic(c) :=
  first;
  [ c "E_AppAbs" | c "E_App1" | c "E_App2" |
  | c "E_Rcdcons1" | c "E_Rcdcons2" | c "E_ProjRcdcons1" | c "E_ProjRcdcons2"
  | c "E_Proj"].

Notation evalmany := (refl_trans_closure' _ eval).

Inductive appears_free_in : nat -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (! 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~T, t1)
  | afi_rcdcons1 : forall x k t1 t2,
      appears_free_in x t1 -> appears_free_in x [|k==t1;t2|]
  | afi_rcdcons2 : forall x k t1 t2,
      appears_free_in x t2 -> appears_free_in x [|k==t1;t2|].

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

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

Reserved Notation "S <: T" (at level 70).

Inductive record_type : ty -> Prop :=
  | rt_nil :
         record_type [[]]
  | rt_cons : forall k T1 T2,
         record_type T2
      -> record_type [[k~T1;T2]].

Inductive subtyping : ty -> ty -> Prop :=
  | S_Refl : forall T,
         T <: T
  | S_Trans : forall S U T,
         S <: U
      -> U <: T
      -> S <: T
  | S_Top : forall S,
         S <: Top
  | S_Arrow : forall S1 S2 T1 T2,
         T1 <: S1
      -> S2 <: T2
      -> S1-->S2 <: T1-->T2
  | S_Rcdwidth : forall k T1 T2,
         record_type T2
      -> [[k~T1;T2]] <: [[]]
  | S_Rcddepth : forall k S1 S2 T1 T2,
         S1 <: T1
      -> S2 <: T2
      -> [[k~S1;S2]] <: [[k~T1;T2]]
  | S_Rcdperm : forall k1 k2 S1 S2 S3,
         k1 <> k2
      -> [[k1~S1; [[k2~S2; S3]] ]] <: [[k2~S2; [[k1~S1; S3]] ]]

where "S <: T" := (subtyping S T).

Tactic Notation "subtyping_cases" tactic(first) tactic(c) :=
  first;
  [ c "S_Refl" | c "S_Trans" | c "S_Top" | c "S_Arrow"
  | c "S_Rcdwidth" | c "S_Rcddepth" | c "S_Rcdperm" ].

Lemma sub_inversion_arrow : forall S T1 T2,
    S <: T1 --> T2
  -> exists S1, exists S2, (S=S1-->S2) /\ (T1<:S1) /\ (S2<:T2).
Proof.
  intros S T1 T2 Hs.
  remember (T1-->T2) as T.
  generalize dependent T2. generalize dependent T1.
  (subtyping_cases (induction Hs) CASE); subst; intros; try solve [solve by inversion].
    CASE "S_Refl".
      apply ex_intro with (witness:=T1). apply ex_intro with (witness:=T2).
      apply conj. assumption. apply conj; apply S_Refl.
    CASE "S_Trans".
      apply IHHs2 in HeqT. destruct HeqT. destruct H.
      rename witness into U1. rename witness0 into U2.   (* NEW *)
      destruct H. destruct H0.
      apply IHHs1 in H. destruct H. destruct H.
      rename witness into S1. rename witness0 into S2.
      destruct H. destruct H2.
      apply ex_intro with (witness := S1).
      apply ex_intro with (witness := S2).
      apply conj. assumption. apply conj.
      (* WHY NOT??  eauto 10 using S_Trans. *)
      apply S_Trans with (U := U1); assumption.
      apply S_Trans with (U := U2); assumption.
    CASE "S_Arrow".
      apply ex_intro with (witness := S1).
      apply ex_intro with (witness := S2).
      inversion HeqT. subst.
      rename T0 into T1. rename T3 into T2.
      auto using conj.
Qed.

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

Notation context := (alist ty).

Definition empty : context := nil _.

Fixpoint ty_rcd_lookup (k:nat) (t:ty) {struct t} : option ty :=
  match t with
  | ty_rcd_cons k' T' t' => if eqnat k k' then Some _ T' else ty_rcd_lookup k t'
  | _ => None _
  end.

Definition ty_rcd_binds (k:nat) (Tk:ty) (T:ty) := ty_rcd_lookup k T = Some _ Tk.

Reserved Notation "Gamma |- t ~ T" (at level 69).

Inductive typing : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
         binds _ x T Gamma
      -> Gamma |- (!x) ~ T
  | T_Abs : forall Gamma x T1 T2 t,
         [(x,T1)] ++ Gamma |- t ~ T2
      -> Gamma |- (\x~T1, t) ~ T1-->T2
  | T_App : forall S T Gamma t1 t2,
         Gamma |- t1 ~ (S-->T)
      -> Gamma |- t2 ~ S
      -> Gamma |- (t1 @ t2) ~ T
  | T_Rcdnil : forall Gamma,
         Gamma |- [||] ~ ty_rcd_nil
  | T_Rcdcons : forall Gamma k t1 t2 T1 T2,
         Gamma |- t1 ~ T1
      -> Gamma |- t2 ~ T2
      -> record_type T2
      -> Gamma |- [|k==t1;t2|] ~ [[k~T1;T2]]
  | T_Proj : forall Gamma k Tk t T,
         Gamma |- t ~ T
      -> record_type T
      -> ty_rcd_binds k Tk T
      -> Gamma |- t # k ~ Tk
  | T_Sub : forall Gamma t S T,
         Gamma |- t ~ S
      -> S <: T
      -> Gamma |- t ~ T

where "Gamma |- t ~ T" := (typing Gamma t T).

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

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

Module Examples.

Notation l := (S (S (S O))).
Notation k := (S (S (S (S O)))).
Notation x := (S (S (S (S (S O))))).
Notation y := (S (S (S (S (S (S O)))))).
Notation z := (S (S (S (S (S (S (S O))))))).
Notation r := (S (S (S (S (S (S (S (S O)))))))).
Notation s := (S (S (S (S (S (S (S (S (S O))))))))).
Definition nat_in_tm : nat -> tm := tm_var.
Coercion nat_in_tm : nat >-> tm.

Lemma subtyping_example : 
  empty |-   (\r~[[y~B-->B]], r # y) 
           @ [|x==(\z~A,z),y==(\z~B,z)|] 
        ~ B-->B.
Proof. 
  (* This proof is similar to the one you did on the last homework, but you'll need to
     add a little bit. *)
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

End Examples.

(* ---------------------------------------------------------------------- *)
(* Properties of subtyping *)

Lemma subtypes_of_arrow_types_are_arrow_types : forall U V1 V2,
     U <: V1-->V2
  -> exists U1, exists U2, U = U1-->U2.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma subtypes_of_rcd_types_are_rcd_types : forall S T,
     S <: T
  -> record_type T
  -> record_type S.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma just_one_rcd_binding : forall k Tk Tk' T,
     ty_rcd_binds k Tk T
  -> ty_rcd_binds k Tk' T
  -> Tk = Tk'.
Proof.
  intros k Tk Tk' T.
  (ty_cases (induction T) CASE); intros H1 H2; try solve [solve by inversion].
  unfold ty_rcd_binds in H1. unfold ty_rcd_binds in H2. rewrite  H1 in H2.  inversion H2.
  reflexivity.
Qed.

Lemma ty_rcd_binds__sub : forall U V l Vl,
     U <: V
  -> ty_rcd_binds l Vl V
  -> exists Ul,
          ty_rcd_binds l Ul U
       /\ Ul <: Vl.
Proof.
  intros U V l Vl SUB.
  generalize dependent Vl.
  (subtyping_cases (induction SUB) CASE); intros Vl BV; try solve [solve by inversion].
    CASE "S_Refl".
      eapply ex_intro. apply conj. eassumption. apply S_Refl.
    CASE "S_Trans".
      assert (exists Ul : ty, ty_rcd_binds l Ul U /\ Ul <: Vl). apply IHSUB2; assumption.
      destruct H. rename witness into Ul.
      destruct H.
      assert (exists Sl : ty, ty_rcd_binds l Sl S /\ Sl <: Ul). apply IHSUB1; assumption.
      destruct H1. rename witness into Sl.
      destruct H1.
      apply ex_intro with (witness := Sl). apply conj.
        assumption.
        eauto using S_Trans.
    CASE "S_Rcddepth".
      unfold ty_rcd_binds. simpl.
      unfold ty_rcd_binds in BV. simpl in BV.
      destruct (eqnat l k).
        SCASE "first binding".
          inversion BV. subst T1.
          apply ex_intro with (witness := S1).
          apply conj; auto.
        SCASE "later binding".
          unfold ty_rcd_binds in IHSUB2. apply IHSUB2. assumption.
    CASE "S_Rcdperm".
      unfold ty_rcd_binds. unfold ty_rcd_binds in BV. simpl. simpl in BV.
      remember (eqnat l k1) as E1. destruct E1.
        SCASE "l = k1".
          apply eq_symm in HeqE1. apply eqnat_yes in HeqE1. subst k1.
          apply eqnat_n_n' in H. rewrite H in BV. inversion BV. rewrite <- H1.
          eauto using ex_intro, S_Refl.
        SCASE "l <> k1".
          rewrite BV.
          eauto using ex_intro, S_Refl.
Qed.

Definition binds_sub (S T : ty) :=
  forall k Tk, ty_rcd_binds k Tk T -> exists Sk, ty_rcd_binds k Sk S /\ Sk <: Tk.

Lemma subtype__binds_sub : forall S T,
     S <: T
  -> binds_sub S T.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma binds_sub_refl : forall S,
     binds_sub S S.
Proof.
  intros S. unfold binds_sub. intros k Tk B.
  eauto using ex_intro, conj, S_Refl.
Qed.

Lemma binds_sub_trans : forall S U T,
     binds_sub S U
  -> binds_sub U T
  -> binds_sub S T.
Proof.
  unfold binds_sub. intros S U T B1 B2.
  intros k Tk B.
  assert (exists Uk : ty, ty_rcd_binds k Uk U /\ Uk <: Tk).
    auto using B2.
  destruct H. rename witness into Uk. destruct H.
  assert (exists Sk : ty, ty_rcd_binds k Sk S /\ Sk <: Uk).
    auto using B1.
  destruct H1. rename witness into Sk. destruct H1.
  apply ex_intro with (witness := Sk).
  eauto using conj, S_Trans.
Qed.

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

(* FIX: Random fact *)
Lemma empty_record's_type_binds_nothing : forall Gamma T,
     Gamma |- [||] ~ T
  -> forall k Tk, ~ ty_rcd_binds k Tk T.
Proof.
  intros Gamma T H.
  remember [||] as t.
  (typing_cases (induction H) CASE); try solve [solve by inversion].
    CASE "T_Rcdnil". intros k Tk C. inversion C.
    CASE "T_Sub". intros k Tk C.
      assert (exists Sk, ty_rcd_binds k Sk S /\ Sk <: Tk).
        eauto using ty_rcd_binds__sub.
      destruct H1. destruct H1.
      generalize dependent H1. apply IHtyping. assumption.
Qed.

Lemma typing_inversion_rcd : forall Gamma k t1 t2 T,
     Gamma |- [|k==t1; t2|] ~ T
  -> record_type T
  -> exists T1, exists T2,
          record_type T2
       /\ [[k~T1; T2]] <: T
       /\ binds_sub [[k~T1; T2]] T
       /\ Gamma |- t1 ~ T1
       /\ Gamma |- t2 ~ T2.
Proof.
  intros Gamma k t1 t2 T H.
  remember [|k==t1; t2|] as t.
  (typing_cases (induction H) CASE); subst; try solve [intros; solve by inversion].
    CASE "T_Rcdcons".
      intros R. inversion Heqt. subst. clear Heqt.
      apply ex_intro with (witness := T1).
      apply ex_intro with (witness := T2).
      auto using conj, S_Refl, binds_sub_refl.
    CASE "T_Sub".
      intros R.
      assert (exists T1 : ty,
               exists T2 : ty,
                 record_type T2 /\
                 [[k ~ T1; T2]] <: S /\
                 binds_sub [[k ~ T1; T2]] S /\
                 Gamma |- t1 ~ T1 /\ Gamma |- t2 ~ T2).
        SCASE "Pf". eauto using IHtyping, subtypes_of_rcd_types_are_rcd_types.
      destruct H1. rename witness into T1.
      destruct H1. rename witness into T2.
      destruct H1. destruct H2. destruct H3. destruct H4.
      assert (binds_sub [[k ~ T1; T2]] T).
        SCASE "Pf". eauto using binds_sub_trans, subtype__binds_sub.
      assert ([[k ~ T1; T2]] <: T).
        SCASE "Pf". eauto using S_Trans.
      eauto 7 using ex_intro.
Qed.

Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     Gamma |- s ~ T1-->T2
  -> value s
  -> exists x, exists S1, exists s2,
        s = \x~S1,s2.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

Lemma canonical_forms_of_rcd_types : forall Gamma s T,
     Gamma |- s ~ T
  -> value s
  -> record_type T
  ->    s = [||]
     \/ exists k, exists s1, exists s2,
              s = [|k==s1;s2|]
           /\ value s1 /\ value s2.
Proof.
  intros Gamma s T H.
  (typing_cases (induction H) CASE); intros V R; inversion V; inversion R; subst.
    auto using or_introl.
    eauto 8 using or_intror, ex_intro.
    (* FIX: Any way to get rid of all this guff? *)
    apply IHtyping. assumption. eauto using subtypes_of_rcd_types_are_rcd_types.
    apply IHtyping. assumption. eauto using subtypes_of_rcd_types_are_rcd_types.
    apply IHtyping. assumption. eauto using subtypes_of_rcd_types_are_rcd_types.
    apply IHtyping. assumption. eauto using subtypes_of_rcd_types_are_rcd_types.
    apply IHtyping. assumption. eauto using subtypes_of_rcd_types_are_rcd_types.
    apply IHtyping. assumption. eauto using subtypes_of_rcd_types_are_rcd_types.
Qed.

(* GOOD EXERCISE??  Yes, but only if I tell them to remember [remember]!! *)
Lemma typing_inversion_abs : forall Gamma x S1 t2 T1 T2,
     Gamma |- \x~S1,t2 ~ T1-->T2
  -> (exists S2, T1 <: S1 /\ S2 <: T2
              /\ [(x,S1)] ++ Gamma |- t2 ~ S2).
Proof.
  intros Gamma x S1 t2 T1 T2 H.
  remember (\x~S1,t2) as t.
  remember (T1-->T2) as T.
  generalize dependent T2. generalize dependent T1.
  (typing_cases (induction H) CASE); subst; try solve [intros; solve by inversion].
    CASE "T_Abs".
      intros. inversion HeqT. inversion Heqt. subst. subst.
      rename T3 into S2.
      apply ex_intro with (witness := S2).
      apply conj.
        apply S_Refl.
        apply conj.
          apply S_Refl. assumption.
    CASE "T_Sub".
      intros. subst.
      assert (exists U1, exists U2, (S=U1-->U2) /\ (T1<:U1) /\ (U2<:T2)).
        apply sub_inversion_arrow. assumption.
      destruct H1. destruct H1. destruct H1. destruct H2.
      rename witness into U1. rename witness0 into U2. subst.
      assert (exists S2, U1<:S1 /\ S2<:U2 /\ [(x, S1)] ++ Gamma |- t2 ~ S2).
        SCASE "Pf of assertion". apply IHtyping; reflexivity.
      destruct H1. rename witness into S2.
      destruct H1. destruct H4.
      apply ex_intro with (witness:=S2).
      apply conj.
        eapply S_Trans; eassumption. (* WHY??? *)
        apply conj.
          eapply S_Trans; eassumption.
          assumption.
Qed.

(* Note that we have to prove this by induction on typing derivations,
   not on terms as we did before.  OPTIONAL EXERCISE: Why? *)


Lemma drop_duplicate_binding : forall Delta t T y U,
     Delta ++ [(y,U)] |- t ~ T
  -> (exists V, binds _ y V Delta)
  -> Delta |- t ~ T.
Proof.
  intros Delta t T y U H.
  remember (Delta ++ [(y,U)]) as Gamma.
  generalize dependent Delta.
  (typing_cases (induction H) CASE); intros Delta Eq B.
    CASE "T_Var".
      subst. apply T_Var.
      remember (eqnat x y) as eq. destruct eq.
        SCASE "x = y".
          apply eq_symm in Heqeq.
          assert (x = y). apply eqnat_yes. assumption. subst x.
          unfold binds. unfold binds in H.
          unfold binds in B.
          inversion B.
          assert (lookup ty y (Delta ++ [(y, U)]) = Some _ witness).
            apply shadowed_binding with (v:=U). assumption.
          rewrite -> H in H1.
          inversion H1. auto.
        SCASE "x <> y".
          unfold binds.
          apply not_last_binding with (j:=y)(v:=U).
          auto. auto.
    CASE "T_Abs".
      apply T_Abs. apply IHtyping. subst Gamma.
      unfold alist.   
      apply append_assoc.
      unfold binds. simpl.
      remember (eqnat y x) as E. destruct E.
        SCASE "y = x". eapply ex_intro. auto.
        SCASE "y <> x". auto.
    CASE "T_App".
      apply T_App with (S:=S); auto.
    CASE "T_Rcdnil".
      apply T_Rcdnil.
    CASE "T_Rcdcons".
      apply T_Rcdcons; auto.
    CASE "T_Proj".
      eapply T_Proj; eauto.
    CASE "T_Sub".
      eapply T_Sub; eauto.
Qed.

Hint Unfold binds.
Lemma weakening_preserves_typing : forall Gamma x U t T,
     Gamma |- t ~ T
  -> Gamma ++ [(x,U)] |- t ~ T.
Proof.
  intros Gamma x U t T H.
  typing_cases (induction H) CASE.
    CASE "T_Var". auto using T_Var, found_before.
    CASE "T_Abs". auto using T_Abs.
    CASE "T_App". eauto 6 using T_App.
    CASE "T_Rcdnil". auto using T_Rcdnil.
    CASE "T_Rcdcons". auto using T_Rcdcons.
    CASE "T_Proj". eauto 6 using T_Proj.
    CASE "T_Sub". eauto using T_Sub.
Qed.

Lemma weakening_empty_preserves_typing : forall Gamma t T,
     empty |- t ~ T
  -> Gamma |- t ~ T.
Proof.
  intros Gamma t T H.
  assert (forall Delta, reverse _ Delta |- t ~ T).
    CASE "Pf of assertion". induction Delta.
      SCASE "Delta empty". auto.
      SCASE "Delta cons".
        simpl.
        destruct x.
        assert (  snoc _ (reverse _ Delta) (n,t0)
                = (reverse _ Delta) ++ [(n,t0)]).
          apply snoc_append.
        rewrite -> H0.
        auto using weakening_preserves_typing.
  assert (reverse _ (reverse _ Gamma) = Gamma).
    apply reverse_reverse.
  rewrite <- H1.
  auto.
Qed.


Lemma substitution_preserves_typing : forall Delta x U v t S,
     Delta ++ [(x,U)] |- t ~ S
  -> empty |- v ~ U
  -> not_bound_in _ x Delta
  -> Delta |- {x|->v}t ~ S.
Proof.
  intros Delta x U v t S H.
  remember (Delta ++ [(x,U)]) as Gamma.
  generalize dependent Delta.
  (typing_cases (induction H) CASE); intros Delta Eq V B; subst; simpl.
    CASE "T_Var".
      remember (eqnat x x0) as test. destruct test.
        SCASE "x = x0".
          apply eq_symm in Heqtest. apply eqnat_yes in Heqtest. subst x0.
          assert (lookup ty x (Delta ++ [(x, U)]) = Some _ U).
            SSCASE "Proof of assertion".
              apply last_binding. assumption.
          unfold binds in H. rewrite -> H0 in H. inversion H. 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.
          auto.
    CASE "T_Abs".
      simpl. remember (eqnat x x0) as test. destruct test.
        SCASE "x = x0".
          apply eq_symm in Heqtest. apply eqnat_yes in Heqtest.
          subst x0. apply T_Abs.
          apply drop_duplicate_binding with (y:=x)(U:=U). assumption.
          unfold binds. simpl.
          assert (eqnat x x = yes). apply eqnat_n_n. rewrite -> H0.
          eauto using ex_intro.
        SCASE "x <> x0".
          apply T_Abs. apply IHtyping.
          simpl. reflexivity. assumption.
          unfold not_bound_in. simpl. apply eq_symm in Heqtest.
          rewrite Heqtest. assumption.
    CASE "T_App".
      eauto using T_App.
    CASE "T_Rcdnil".
      apply T_Rcdnil.
    CASE "T_Rcdcons".
      auto using T_Rcdcons.
    CASE "T_Proj".
      eauto using T_Proj.
    CASE "T_Sub".
      eauto using T_Sub.
Qed.

Theorem preservation : forall t t' T,
     empty |- t ~ T
  -> eval t t'
  -> empty |- t' ~ 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".
      rename T0 into T11.
      assert (exists T2, S <: T11 /\ T2 <: T /\ [(x,T11)] ++ empty |- t12 ~ T2) as TI.
        SSCASE "Pf". apply typing_inversion_abs. assumption.
      inversion TI. rename witness into T12.
      inversion H. inversion H1. simpl in H4.
      apply T_Sub with (S:=T12).
      apply substitution_preserves_typing with (U:=T11).
        assumption.
        apply T_Sub with (S:=S); assumption.
        unfold binds. unfold empty. apply empty_alist_binds_nothing.
        assumption.
    CASE "T_App". SCASE "E_App1".
      apply T_App with (S:=S); auto.
    CASE "T_App". SCASE "E_App2".
      apply T_App with (S:=S); auto.
    CASE "T_Rcdcons".
      SCASE "E_Rcdcons1"; auto using T_Rcdcons.
      SCASE "E_Rcdcons2"; auto using T_Rcdcons.
    CASE "T_Proj".
      SCASE "E_ProjRcdcons1".
        assert (exists T1, exists T2,
                   record_type T2
                /\ [[k~T1; T2]] <: T
                /\ binds_sub [[k~T1; T2]] T
                /\ empty |- t' ~ T1
                /\ empty |- t2 ~ T2) as TI.
          SSCASE "Pf". apply typing_inversion_rcd; assumption.
        inversion TI. rename witness into T1.
        inversion H1. rename witness into T2. clear TI. clear H1. clear IHHty. clear He. clear Hty.
        destruct H2. destruct H2. destruct H4. destruct H6.
        assert (T1 <: Tk).
          SSCASE "Pf".
            assert (exists T1', ty_rcd_binds k T1' [[k ~ T1; T2]] /\ T1' <: Tk).
              SSSCASE "Pf". eauto using ty_rcd_binds__sub.
            destruct H8. rename witness into T1'. destruct H8.
            unfold ty_rcd_binds in H8. simpl in H8.
            assert (eqnat k k = yes). apply eqnat_n_n. rewrite H10 in H8. inversion H8.
            subst. assumption.
        apply T_Sub with (S:=T1); auto.
      SCASE "E_ProjRcdcons2".
        assert (exists T1, exists T2,
                   record_type T2
                /\ [[k'~T1; T2]] <: T
                /\ binds_sub [[k'~T1; T2]] T
                /\ empty |- t1 ~ T1
                /\ empty |- t2 ~ T2) as TI.
          SSCASE "Pf". apply typing_inversion_rcd; assumption.
        inversion TI. rename witness into T1.
        inversion H1. rename witness into T2.
        clear TI. clear H1. clear IHHty. clear He. clear Hty.
        inversion H2. clear H2. inversion H5. clear H5.
        inversion H7. clear H7. inversion H8. clear H8.
        assert (exists Sk, ty_rcd_binds k Sk [[k'~T1; T2]] /\ Sk <: Tk) as B.
          SSCASE "Pf". unfold binds_sub in H5. apply H5. assumption.
        destruct B. rename witness into Sk.
        unfold ty_rcd_binds in H8.
        simpl in H8. apply eqnat_n_n' in H6. rewrite H6 in H8.
        destruct H8.
        apply T_Sub with (S := Sk). apply T_Proj with (T:=T2); assumption. assumption.
      SCASE "E_Proj".
        eapply T_Proj; eauto.
  CASE "T_Sub".
    (* FIX: Is there a better way?? *)
    eauto using T_Sub.
    eauto using T_Sub.
    eauto using T_Sub.
    eauto using T_Sub.
    eauto using T_Sub.
    eauto using T_Sub.
    eauto using T_Sub.
    eauto using T_Sub.
Qed.

Theorem progress : forall t T,
     empty |- t ~ T
  -> value t \/ exists t', eval t t'.
Proof.
  intros t T Hty.
  remember empty as Gamma.
  (typing_cases (induction Hty) (CASE)); subst.
  CASE "T_Var".
    solve by inversion.
  CASE "T_Abs".
    apply or_introl. apply v_abs.
  CASE "T_App".
    assert (value t1 \/ (exists t' : tm, eval t1 t')) as IH1. auto.
    assert (value t2 \/ (exists t' : tm, eval t2 t')) as IH2. auto.
    apply or_intror.
    inversion IH1.
      SCASE "t1 value". inversion IH2; subst.
        SSCASE "t1 value / t2 value".
          assert (exists x, exists T11, exists t12, t1 = \x~T11,t12).
            SSSCASE "Pf". eapply canonical_forms_of_arrow_types; eassumption.
          destruct H1. rename witness into x.
          destruct H1. rename witness into T11.
          destruct H1. rename witness into t12.
          subst.
          eauto using ex_intro, E_AppAbs.
        SSCASE "t1 value / t2 steps".
          inversion H0.
          eauto using ex_intro, E_App2.
      SCASE "t1 steps".
        inversion H.
        eauto using ex_intro, E_App1.
  CASE "T_Rcdnil".
    apply or_introl. apply v_rcd_nil.
  CASE "T_Rcdcons".
    assert (value t1 \/ (exists t' : tm, eval t1 t')) as IH1. auto.
    assert (value t2 \/ (exists t' : tm, eval t2 t')) as IH2. auto.
    inversion IH1.
      SCASE "t1 value". inversion IH2; subst.
        SSCASE "t1 value / t2 value".
          auto using or_introl, v_rcd_cons.
        SSCASE "t1 value / t2 steps".
          apply or_intror.
          inversion H1.
          eauto using ex_intro, E_Rcdcons2.
      SCASE "t1 steps".
        apply or_intror.
        inversion H0.
        eauto using ex_intro, E_Rcdcons1.
  CASE "T_Proj".
    apply or_intror.
    assert (value t \/ (exists t' : tm, eval t t')) as IH. auto.
    inversion IH.
      SCASE "t is a value".
        assert (t = [||] \/ exists k, exists s1, exists s2, t = [|k==s1;s2|] /\ value s1 /\ value s2).
          SSCASE "Pf". eapply canonical_forms_of_rcd_types; eassumption.
        destruct H2.
          SSSCASE "t is the empty record".
            subst.
            assert (~ ty_rcd_binds k Tk T).
              SSSSCASE "Pf". eauto using empty_record's_type_binds_nothing.
            contradiction.
          SSSCASE "t is a cons-record".
            destruct H2. rename witness into k'.
            destruct H2. rename witness into s1.
            destruct H2. rename witness into s2.
            destruct H2. destruct H3.
            subst.
            (* FIX: Tricky -- how to explain?? *)
            remember (eqnat k k') as e. apply eq_symm in Heqe. destruct e.
              SSCASE "k = k'". apply eqnat_yes in Heqe. rewrite <- Heqe.
                eauto using ex_intro, E_ProjRcdcons1.
              SSCASE "k <> k'". apply eqnat_no in Heqe.
                eauto using ex_intro, E_ProjRcdcons2.
      SCASE "t steps to some t'".
        inversion H1.
        eauto using ex_intro, E_Proj.
  CASE "T_Sub".
    apply IHHty. reflexivity.
Qed.

End STLCWithSubtyping.