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

Module STLCWithSubtyping'.
Export STLCWithSubtyping.

(* ====================================================================== *)
(* Algorithmic subtyping -- motivations *)

(* We've done a lot of work over the past several weeks with
   DEFINITIONS of programming languages -- formal, abstract
   descriptions of their syntax, operational semantics, and typing
   rules such as might be included in a language reference manual.  We
   have also looked at IMPLEMENTATIONS of syntax and operational
   semantics (as evaluation functions), but we have not yet considered
   how to implement the typing and subtyping relations.  

   For the plain simply typed lambda-calculus (without subtyping),
   implementing a typechecker is straightforward.  Notice that the
   typing relation for this system...

      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

   ... is SYNTAX-DIRECTED: For each syntactic form of the language,
   there is exactly one typing rule that can be used to type
   expressions of this form.  Moreover, all of the metavariables that
   appear in premises of this rule also appear in the conclusion, so
   it is easy to write out a Fixpoint definition that "runs the rules
   backwards" without having to do any hard work to fill in
   metavariables on recursive calls:

         Fixpoint check_typing Gamma t {struct t} : option ty :=
           match t with
           | !x => 
                lookup _ x Gamma 
           | \x~T1,t2 => 
                check_typing ([(x,T1)] ++ Gamma) t2
           | t1 @ t2 => 
                match check_typing Gamma t1 with
                | Some (T11-->T12) => 
                    match check_typing Gamma t2 with
                    | Some T2 => 
                        if check_eqty T2 T11 then Some _ T12 else None _
                    | None => None _
                    end
                | _ => None _
                end
           | [||] => 
               Some _ [[]]
           | [|k==t1;t2|] =>
                match check_typing Gamma t1 with
                | Some T1 => 
                    match check_typing Gamma t2 with
                    | Some T2 => 
                        let T := [[k~T1;T2]] in
                        if check_well_formed T then Some _ T else None _
                    | None => None _
                    end
                | _ => None _
                end
           | t1 # k => 
                match check_typing Gamma t1 with
                | Some T1 => ty_rcd_lookup k T1
                | None => None _
                end
           end.

   When we add subtyping, however, things become a little more
   complicated and we need to work a little harder to implement what
   we have defined.  The problem, of course, is the addition of the
   rule of SUBSUMPTION

           | T_Sub : forall Gamma t S T,
                  Gamma |- t ~ S
               -> S <: T
               -> Gamma |- t ~ T

   which overlaps ALL of the other rules.  Moreover, the principle
   argument [t] is the same in the premise as in the conclusion, so a
   direct translation of this rule into a clause of a Fixpoint would
   yield a non-terminating function (and Coq would reject it!).

   Not only does the typing relation require some work to implement,
   but so does the subtyping relation.  The reason is similar: Some of
   the rules overlap others (e.g., in particular, S_Refl overlaps all
   the other rules in a somewhat trivial way and S_Trans overlaps in a
   more serious way); also, the rule S_Trans has a metavariable in its
   premises that does not appear in its conclusion.

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

   The plan for addressing these issues goes like this:

      - For subtyping...
          - define a SYNTAX-DIRECTED (or ALGORITHMIC) SUBTYPING
            relation that
              - restricts S_Refl to a few particular cases
              - combines the three record subtyping rules into a single
                "monster rule" that captures all of their effects together
              - drop the S_Trans rule
          - show that this definition yields the same relation as the
            ordinary subtyping rules -- i.e., that the new rules are SOUND
            and COMPLETE
          - define a SUBTYPE CHECKER -- a recursive function that takes
            two types and returns a [yesno]
          - show that this function is a decision procedure for
            subtyping by comparing its definition to the algorithmic
            subtyping rules.

      - For typing...
          - define a SYNTAX-DIRECTED (or ALGORITHMIC) TYPING relation
            that
              - adds subtype checks to the premises of other rules (in
                particular, to T_App)
              - drops the T_Sub rule
          - show that this definition yields the same relation as the
            ordinary typing rules -- i.e., that the new rules are SOUND
            and COMPLETE
          - define a TYPE CHECKER -- a recursive function that takes
            a context and a term and returns an [option ty]
          - show that this function is a decision procedure for the
            typing relation by comparing its definition to the algorithmic
            typing rules.

   We don't have time to go into the details of all these steps, but
   let's look at them in a little more detail.

   First, let's look at subtyping...
*)

Module Examples.

Notation k := (S (S (S (S O)))).
Notation x := (S (S (S (S (S O))))).
Notation y := (S (S (S (S (S (S O)))))).

(* The [Variable] command lets us introduce some assumptions that
   we'll use in the following examples... *)
Variable S1 S2 U1 U2 T1 T2 : ty.
Variable WF_T1 : well_formed T1.
Variable WF_T2 : well_formed T2.
Variable WF_T1T2 : well_formed (T1-->T2).

Lemma wf_A : well_formed A.
Proof. auto. Qed.

Lemma wf_RA : well_formed [[k~A]].
Proof. auto. Qed.

(* The reflexivity rule is more general than we need... *)

(* Here we apply S_Refl to an arrow type: *)
Definition refl_proof_1 := 
  S_Refl (T1-->T2) WF_T1T2.
Check refl_proof_1.

(* But we could just as well have used S_Arrow for this proof, using
   S_Refl only on smaller types: *)
Definition refl_proof_2 := 
  S_Arrow T1 T2 T1 T2 (S_Refl T1 WF_T1) (S_Refl T2 WF_T2).
Check refl_proof_2.

(* Similarly, here we apply S_Refl to Top: *)
Definition refl_proof_3 := 
  S_Refl (Top) wf_top.
Check refl_proof_3.

(* But we could just as well have achieved this using the S_Top
   rule: *)
Definition refl_proof_4 := 
  S_Top Top wf_top.
Check refl_proof_4.

(* These examples suggest that we can, intuitively, keep "pushing
   reflexivity down" from more complex types to simpler ones.  

   If we repeat this process long enough, most uses of S_Refl will
   disappear.  Which ones will not? *)

(* What about this one? *)
Definition refl_proof_5 := 
  S_Refl A wf_A.
Check refl_proof_5.
(* No: There is no other way to prove this. *)

(* What about this one? *)
Definition refl_proof_6 := 
  S_Refl [[k~A]] wf_RA.
Check refl_proof_6.

(* Yes: We can push the reflexivity through the ty_rcd_cons constructor. *)
Definition refl_proof_7 := 
  S_Rcddepth k A [[]] A [[]] (S_Refl A wf_A) (S_Refl [[]] wf_rcdnil) wf_RA.
Check refl_proof_7.
(* Can we go further and get rid of the remaining ones?  Not quite:
   The first one can go, but we need S_Refl to show that [[]] is a
   subtype of itself. *)

(* What we've learned so far is that S_Refl is not needed to prove
   reflexivity of arrow types, cons-records, or Top, but it *is*
   needed for base types and empty records. *)


(* What about transitivity? *)

(* Let's assume that we've got derivations (evidence) establishing the
   following subtyping relations: *)
Variable D1 : U1 <: S1.
Variable D2 : S2 <: U2.
Variable E1 : T1 <: U1.
Variable E2 : U2 <: T2.

Definition arrow_proof_1 := 
  S_Trans (S1-->S2) (U1-->U2) (T1-->T2)
    (S_Arrow S1 S2 U1 U2 D1 D2)
    (S_Arrow U1 U2 T1 T2 E1 E2).
Check arrow_proof_1.

(* Can we "push down" these uses of S_Trans? *)

(* Yes: Like this... *)
Definition arrow_proof_1' := 
  S_Arrow S1 S2 T1 T2
    (S_Trans T1 U1 S1 E1 D1)
    (S_Trans S2 U2 T2 D2 E2).
Check arrow_proof_1'.

(* In fact, ALL uses of S_Trans can be pushed down in this fashion,
   except the ones used to "paste together" instances of the record
   subtyping rules.  For example, there is no way to prove

       [[x~A, y~B, z~C]]  <:  [[z~C, y~B, x~A]]

   without using transitivity. *)

(* These experiments tell us what we need to do to produce a
   syntax-directed subtyping relation:
      - replace the three "fine-grained" record subtyping rules by a
        single "coarse-grained" rule that can, for example, take into
        account multiple permutations at the same time.
      - replace general reflexivity by reflexivity on base types (the
        coarse-grained record rule will also handle reflexivity of
        empty records, so there's no need for a special rule for
        that). *)

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

(* Typing... *)

Variable t s : tm.
Variable wf_S1 : well_formed S1.
Variable Et : [(x,S1)] |- t ~ S2.
Variable Es : empty |- s ~ S1.

(* A very basic typing proof *)
Definition typing_proof_1 := 
  T_App S1 S2 empty (\x~S1,t) s 
     (T_Abs empty x S1 S2 t wf_S1 Et)
     Es.
Check typing_proof_1.

(* A more intersting typing proof involving subsumption *)
Variable Es' : empty |- s ~ T1.
Definition typing_proof_2 := 
  T_App T1 T2 empty (\x~S1,t) s 
     (T_Sub empty (\x~S1,t) (S1-->S2) (T1-->T2)
       (T_Abs empty x S1 S2 t wf_S1 Et)
       arrow_proof_1')
     Es'.
Check typing_proof_2.

(* Can we "push down" this use of subsumption? *)
(* EXERCISE: Give an alternate proof of the SAME SUBTYPING FACT using
   two instances of the T_Sub rule -- one around the argument
   Es' (promoting T1 to S1) and another on the outside (promoting S2
   to T2). *)
(* FILL IN HERE *)

End Examples.

(* ====================================================================== *)
(* Some technical preliminaries *)

(* Please skip over this section -- it defines some low-level
   technical properties that are needed to make Coq happy with the
   definitions we are going to give later.  The details are not
   important. *)

Inductive proper_subexpression : ty -> ty -> Prop :=
  | se_arrow1 : forall T1 T2,
         proper_subexpression T1 (T1-->T2)
  | se_arrow2 : forall T1 T2,
         proper_subexpression T2 (T1-->T2)
  | se_arrow1' : forall S T1 T2,
         proper_subexpression S T1
      -> proper_subexpression S (T1-->T2)
  | se_arrow2' : forall S T1 T2,
         proper_subexpression S T2
      -> proper_subexpression S (T1-->T2)
  | se_rcd1 : forall k T1 T2,
         proper_subexpression T1 [[k~T1;T2]]
  | se_rcd2 : forall k T1 T2,
         proper_subexpression T2 [[k~T1;T2]]
  | se_rcd1' : forall S k T1 T2,
         proper_subexpression S T1
      -> proper_subexpression S [[k~T1;T2]]
  | se_rcd2' : forall S k T1 T2,
         proper_subexpression S T2
      -> proper_subexpression S [[k~T1;T2]].

Inductive proper_subexpressions : (ty*ty) -> (ty*ty) -> Prop :=
    se_pair : forall S1 S2 T1 T2,
       proper_subexpression S1 T1
    -> proper_subexpression S2 T2
    -> proper_subexpressions (S1,S2) (T1,T2).

Require Recdef.

(* ====================================================================== *)
(* Algorithmic subtyping relation *)

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

Inductive alg_subtyping : ty -> ty -> Prop :=
  | SA_ReflBase : forall n,
         ty_base n <:: ty_base n
  | SA_Top : forall S,
         well_formed S
      -> S <:: Top
  | SA_Arrow : forall S1 S2 T1 T2,
         T1 <:: S1
      -> S2 <:: T2
      -> S1-->S2 <:: T1-->T2
  | SA_Rcd : forall S T,
         well_formed S
      -> well_formed T
      -> record_type S
      -> record_type T
      -> (forall k Tk,       
               ty_rcd_binds k Tk T 
            -> exists Sk, 
                     ty_rcd_binds k Sk S 
                  /\ Sk <:: Tk)
      -> S <:: T

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

(* Subtype checker *)

Fixpoint check_record_type (T : ty) {struct T} : yesno :=
  match T with
  | [[]] => yes
  | [[k~T1;T2]] => yes
  | _ => no
  end.

Fixpoint check_doesn't_bind (k : nat) (T : ty) {struct T} : yesno :=
  match T with
  | [[k'~T1;T2]] => both_yes (swap_yesno (eqnat k k')) (check_doesn't_bind k T2)
  | _ => yes
  end.

Fixpoint check_well_formed (T : ty) {struct T} : yesno :=
  match T with
  | Top => yes
  | ty_base n => yes
  | T1-->T2 => both_yes (check_well_formed T1) (check_well_formed T2)
  | [[]] => yes
  | [[k~T1;T2]] =>  both_yes (check_well_formed T1) 
                   (both_yes (check_well_formed T2)
                   (both_yes (check_record_type T2)
                             (check_doesn't_bind k T2)))
  end.

(* Note that we use here a slightly more powerful form of recursive
   function definition -- [Function] rather than [Fixpoint].  This is
   needed to convince Coq that subtype checking always terminates,
   because the arguments to recursive calls are not immediate
   subphrases of one of a single "principle argument" (in the arrow
   and record cases). *)

(* This is commented out for now -- I am having trouble getting Coq to
   accept the definition.  (In the meantime, I know a better way of
   formalizing it that does not use these rather experimental features
   of Coq!  But there isn't time to carry it through or explain it
   right now.)

Function check_subtyping (UV : ty * ty) {wf proper_subexpressions UV} 
            : yesno :=
  match UV with
  | (U,Top) => 
       check_well_formed U
  | (ty_base m, ty_base n) => 
       eqnat m n
  | (U1-->U2, V1-->V2) => 
       both_yes (check_subtyping (V1,U1)) (check_subtyping (U2,V2))
  | (U, [[]]) => both_yes (check_well_formed U) (check_record_type U) 
  | (U, [[k~V1;V2]]) => 
       match ty_rcd_lookup k U with
       | None => no
       | Some Uk => 
            both_yes (check_well_formed U)
           (both_yes (check_well_formed [[k~V1;V2]])
           (both_yes (check_record_type U)
           (both_yes (check_subtyping (Uk,V1)) 
                     (check_subtyping (U,V2)))))
       end
  | (_,_) => no
  end.
Proof.
Admitted.
*)

(* Bogus replacement version for now, just so that we have something
   of the right type for later definitions. *)
Definition check_subtyping (S T : ty) : yesno := yes.

(* ====================================================================== *)
(* Algorithmic typing relation *)

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

Inductive alg_typing : context -> tm -> ty -> Prop :=
  | TA_Var : forall Gamma x T,
         binds _ x T Gamma
      -> well_formed T
      -> Gamma |- (!x) ~~ T
  | TA_Abs : forall Gamma x T1 T2 t,
         well_formed T1
      -> [(x,T1)] ++ Gamma |- t ~~ T2
      -> Gamma |- (\x~T1, t) ~~ T1-->T2
  | TA_App : forall S S' T Gamma t1 t2,
         Gamma |- t1 ~~ (S-->T)
      -> Gamma |- t2 ~~ S'                (* These two lines... *)
      -> S' <:: S                         (* ...are the crucial difference *)
      -> Gamma |- (t1 @ t2) ~~ T
  | TA_Rcdnil : forall Gamma,
         Gamma |- [||] ~~ [[]]
  | TA_Rcdcons : forall Gamma k t1 t2 T1 T2,
         Gamma |- t1 ~~ T1
      -> Gamma |- t2 ~~ T2
      -> well_formed [[k~T1;T2]]
      -> Gamma |- [|k==t1;t2|] ~~ [[k~T1;T2]]
  | TA_Proj : forall Gamma k Tk t T,
         Gamma |- t ~~ T
      -> ty_rcd_binds k Tk T
      -> Gamma |- t # k ~~ Tk
(* ...and note that T_Sub is omitted! *)

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

Module Example.
Notation r := (S (S (S (S (S (S (S (S O)))))))).
Notation s := (S (S (S (S (S (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))))))).

(* EXERCISE: Prove the following assertion about algorithmic
   typing. *)
Lemma typing_example_1 : 
  empty |-   (\r~[[y~B-->B]], r # y) 
           @ [|x==(\z~A,z),y==(\z~B,z)|] 
        ~~ B-->B.
Proof. 
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

End Example.

(* Type checker *)

Fixpoint check_typing Gamma t {struct t} : option ty :=
  match t with
  | !x => 
       lookup _ x Gamma 
  | \x~T1,t2 => 
       if check_well_formed T1 then
         check_typing ([(x,T1)] ++ Gamma) t2
       else None _
  | t1 @ t2 => 
       match check_typing Gamma t1 with
       | Some (T11-->T12) => 
           match check_typing Gamma t2 with
           | Some T2 => 
               if check_subtyping T2 T11 then Some _ T12 else None _
           | None => None _
           end
       | _ => None _
       end
  | [||] => 
      Some _ [[]]
  | [|k==t1;t2|] =>
       match check_typing Gamma t1 with
       | Some T1 => 
           match check_typing Gamma t2 with
           | Some T2 => 
               let T := [[k~T1;T2]] in
               if check_well_formed T then Some _ T else None _
           | None => None _
           end
       | _ => None _
       end
  | t1 # k => 
       match check_typing Gamma t1 with
       | Some T1 => ty_rcd_lookup k T1
       | None => None _
       end
  end.


(* ====================================================================== *)
(* ====================================================================== *)
(* ====================================================================== *)
(* Correctness of the algorithmic subtyping *)


Tactic Notation "alg_subtyping_cases" tactic(first) tactic(c) :=
  first; [ c "SA_ReflBase" | c "SA_Top" | c "SA_Arrow" | c "SA_Rcd" ].

Lemma alg_subtyping_ind2 :
       forall P : ty -> ty -> Prop,
       (forall n : nat, P (ty_base n) (ty_base n)) ->
       (forall S : ty, well_formed S -> P S Top) ->
       (forall S1 S2 T1 T2 : ty,
        T1 <:: S1 ->
        P T1 S1 -> S2 <:: T2 -> P S2 T2 -> P (S1 --> S2) (T1 --> T2)) ->
       (forall S T : ty,
        well_formed S ->
        well_formed T ->
        record_type S ->
        record_type T ->
        (forall (k : nat) (Tk : ty),
         ty_rcd_binds k Tk T ->
         exists Sk : ty, ty_rcd_binds k Sk S /\ P Sk Tk) -> 
        P S T) -> forall S T : ty, S <:: T -> P S T.
Proof.
  intros P HReflBase HTop HArrow HRcd.
  fix r 3.
  intros S T SUB. destruct SUB; auto.
  (* Only the record case is non-trivial *)
  apply HRcd; auto.
  intros k Tk B.
  assert (exists Sk : ty, ty_rcd_binds k Sk S /\ Sk <:: Tk) by auto.
  destruct H4. rename witness into Sk. destruct H4.
  apply ex_intro with (witness := Sk). apply conj. auto. 
  apply r. assumption.
Qed.

Lemma alg_subtyping__well_formed : forall S T,
     S <:: T
  -> well_formed S /\ well_formed T.
Proof.
  intros. induction H; apply conj; auto.
  destruct IHalg_subtyping1. destruct IHalg_subtyping2. auto.
  destruct IHalg_subtyping1. destruct IHalg_subtyping2. auto.
Qed.

(* To help with automation, let's break this lemma apart into two
   separate statements and add them both to the hints database. *)
Lemma alg_subtyping__well_formed_1 : forall S T,
     S <:: T
  -> well_formed S.
Proof.
  intros. pose proof (alg_subtyping__well_formed S T H). destruct H0. auto.
Qed.
Lemma alg_subtyping__well_formed_2 : forall S T,
     S <:: T
  -> well_formed T.
Proof.
  intros. pose proof (alg_subtyping__well_formed S T H). destruct H0. auto.
Qed.
Hint Resolve alg_subtyping__well_formed_1.
Hint Resolve alg_subtyping__well_formed_2.
(* While we're at it, let's do the same for ordinary subtyping. *)
Lemma subtypes__well_formed_1 : forall S T,
     S <: T
  -> well_formed S.
Proof. 
  intros. pose proof (subtypes__well_formed S T H). destruct H0. auto.
Qed.
Lemma subtypes__well_formed_2 : forall S T,
     S <: T
  -> well_formed T.
Proof. 
  intros. pose proof (subtypes__well_formed S T H). destruct H0. auto.
Qed.
Hint Resolve subtypes__well_formed_1.
Hint Resolve subtypes__well_formed_2.

Lemma alg_subtyping_refl : forall T,
     well_formed T
  -> T <:: T.
Proof.
  intros T WF.
  (ty_cases (induction T) CASE); inversion WF.
    CASE "ty_top". apply SA_Top. auto.
    CASE "ty_base". apply SA_ReflBase.
    CASE "ty_arrow". auto using SA_Arrow.
    CASE "ty_rcd_nil". apply SA_Rcd; auto.
      intros k Tk R. inversion R.
    CASE "ty_rcd_cons". apply SA_Rcd; auto. 
      subst.
      intros k Tk R. 
      unfold ty_rcd_binds in R. simpl in R.
      unfold ty_rcd_binds. simpl.
      remember (eqnat k n) as E. destruct E.
        SCASE "k = n".
          inversion R. subst. 
          apply ex_intro with (witness := Tk). auto using conj.
        SCASE "k <> n".
          pose proof (IHT2 H3). inversion H; subst; try solve [solve by inversion].
          unfold ty_rcd_binds in H8.
          pose proof (H8 k Tk R).
          assumption.
Qed.

Lemma alg_subtyping_inversion_top_right : forall T,
  Top <:: T -> T = Top.
Proof.
  intros. inversion H. subst. reflexivity. subst. solve by inversion.
Qed.

Lemma alg_subtyping_inversion_base_left : forall n T,
     (ty_base n) <:: T 
  -> T = Top \/ T = (ty_base n).
Proof.
  intros. inversion H. subst. 
    apply or_intror. auto.
    apply or_introl. auto. 
    solve by inversion.
Qed.

Lemma alg_subtyping_inversion_arrow_left : forall S T1 T2,
     S <:: T1-->T2 
  -> exists S1, exists S2, 
           S = S1-->S2
        /\ T1 <:: S1
        /\ S2 <:: T2.
Proof.
  intros. inversion H. subst.
    eauto using ex_intro, SA_Arrow, conj.
    solve by inversion.
Qed.

Lemma alg_subtyping_inversion_arrow_right : forall S1 S2 T,
     S1-->S2 <:: T
  -> T = Top
     \/ exists T1, exists T2, 
              T = T1-->T2
           /\ T1 <:: S1
           /\ S2 <:: T2.
Proof.
  intros. inversion H; subst.
    apply or_introl. auto.
    apply or_intror. eauto using ex_intro, SA_Arrow, conj.
    solve by inversion.
Qed.

Lemma alg_subtyping_inversion_rcd_left : forall S T,
     S <:: T 
  -> record_type T
  -> record_type S 
     /\ (forall k Tk,    
               ty_rcd_binds k Tk T 
            -> exists Sk, 
                     ty_rcd_binds k Sk S 
                  /\ Sk <:: Tk).
Proof.
  intros. inversion H; subst; try solve [solve by inversion].
  eauto using ex_intro, conj.
Qed.

Lemma alg_subtyping_inversion_rcd_right : forall S T,
     S <:: T 
  -> record_type S
  -> T = Top
     \/ (record_type T
         /\ (forall k Tk,    
                   ty_rcd_binds k Tk T 
                -> exists Sk, 
                         ty_rcd_binds k Sk S 
                      /\ Sk <:: Tk)).
Proof.
  intros. inversion H; subst; try solve [solve by inversion].
    apply or_introl. auto.
    apply or_intror. eauto using ex_intro, conj.
Qed.

Lemma alg_subtyping_trans_aux : forall S T,
     S <:: T
  -> (forall U, U <:: S -> U <:: T) /\ (forall U, T <:: U -> S <:: U).
Proof.
  intros S T H.
  (alg_subtyping_cases (induction H using alg_subtyping_ind2) CASE); (apply conj; 
      [SCASE "U on the left"; intros U SubUS | SCASE "U on the right"; intros U SubTU]).
    CASE "SA_ReflBase". SCASE "U on the left". 
      assumption.
    CASE "SA_ReflBase". SCASE "U on the right". 
      assumption.
    CASE "SA_Top". SCASE "U on the left". 
      eauto using SA_Top.  (* FIX: Why eauto? *)
    CASE "SA_Top". SCASE "U on the right". 
      assert (U = Top) by (auto using alg_subtyping_inversion_top_right). 
      subst. auto using SA_Top.
    CASE "SA_Arrow". SCASE "U on the left". 
      pose proof (alg_subtyping_inversion_arrow_left U S1 S2 SubUS).  (* NEW *)
      (* Or: remember (alg_subtyping_inversion_arrow_left U S1 S2 SubUS) as RR. *)
      destruct H1. rename witness into U1. destruct H1. rename witness into U2. 
      destruct H1. destruct H2.
      subst.
      destruct IHalg_subtyping1. destruct IHalg_subtyping2.
      auto using SA_Arrow.
    CASE "SA_Arrow". SCASE "U on the right". 
      pose proof (alg_subtyping_inversion_arrow_right T1 T2 U SubTU).  
      inversion H1.
        SSCASE "U = Top". subst. eauto using SA_Top.
        SSCASE "U is an arrow type". 
          destruct H2. rename witness into U1. destruct H2. rename witness into U2.
          destruct H2. destruct H3. subst.
          destruct IHalg_subtyping1. destruct IHalg_subtyping2.          
          auto using SA_Arrow.
    CASE "SA_Rcd". SCASE "U on the left".
      assert (record_type U 
              /\ (forall k Sk,    
                        ty_rcd_binds k Sk S
                     -> exists Uk, 
                              ty_rcd_binds k Uk U
                           /\ Uk <:: Sk)) as R by (auto using alg_subtyping_inversion_rcd_left).
      destruct R.
      assert (well_formed U /\ well_formed S) as W by (auto using alg_subtyping__well_formed).
      destruct W.
      apply SA_Rcd; auto.
      intros k Tk B.
      assert (exists Sk : ty,
                ty_rcd_binds k Sk S /\
                (forall U : ty, U <:: Sk -> U <:: Tk) /\
                (forall U : ty, Tk <:: U -> Sk <:: U)) as E by auto.
      destruct E. rename witness into Sk. destruct H8. destruct H9.
      assert (exists Uk : ty, ty_rcd_binds k Uk U /\ Uk <:: Sk) by auto.
      destruct H11. rename witness into Uk. destruct H11.
      apply ex_intro with (witness := Uk). auto using conj.
    CASE "SA_Rcd". SCASE "U on the right".
      assert (U = Top
              \/ (record_type U
                  /\ (forall k Uk,    
                            ty_rcd_binds k Uk U 
                         -> exists Tk, 
                                  ty_rcd_binds k Tk T 
                               /\ Tk <:: Uk))) as R by (auto using alg_subtyping_inversion_rcd_right).
      destruct R.
        SSCASE "U = Top". 
          subst. eapply SA_Top. assumption.
        SSCASE "U is a record". 
          destruct H4. 
          assert (well_formed T /\ well_formed U) as W by (auto using alg_subtyping__well_formed).
          destruct W.
          apply SA_Rcd; auto.
          intros k Uk B.
          assert (exists Tk : ty, ty_rcd_binds k Tk T /\ Tk <:: Uk) by auto.
          destruct H8. rename witness into Tk. destruct H8.
          assert (exists Sk : ty,
                    ty_rcd_binds k Sk S /\
                    (forall U : ty, U <:: Sk -> U <:: Tk) /\
                    (forall U : ty, Tk <:: U -> Sk <:: U)) as E by auto.
          destruct E. rename witness into Sk. destruct H10. destruct H11.
          apply ex_intro with (witness := Sk). auto using conj.
Qed.

Lemma alg_subtyping_trans : forall S U T,
     S <:: U
  -> U <:: T
  -> S <:: T.
Proof.
  intros.
  assert ((forall T, T <:: S -> T <:: U) /\ (forall T, U <:: T -> S <:: T)) 
    by (auto using alg_subtyping_trans_aux).
  destruct H1. eauto.
Qed.

Lemma bring_a_field_to_the_front : forall S k Sk,
     well_formed S
  -> ty_rcd_binds k Sk S
  -> exists S2,
          (forall k', doesn't_bind k' S -> doesn't_bind k' [[k~Sk;S2]])
       /\ S <: [[k~Sk;S2]]
       /\ [[k~Sk;S2]] <: S.
Proof. 
  (ty_cases (induction S) CASE); intros k Sk W B; try solve [solve by inversion].
  (* Only the ty_rcd_cons case is interesting *)
  unfold ty_rcd_binds in B. simpl in B.
  remember (eqnat k n) as E. destruct E.
    SCASE "k = n". inversion B. subst. 
      apply eq_symm in HeqE. apply eqnat_yes in HeqE. subst.
      eauto 7 using ex_intro, S_Refl, conj.
    SCASE "k <> n". inversion W. subst.
    apply eq_symm in HeqE. pose proof HeqE as NEQ. apply eqnat_no in NEQ.
      apply eqnat_symm in HeqE. apply eqnat_no in HeqE.
      pose proof (IHS2 k Sk H3 B).
      destruct H. rename witness into S3. destruct H.
      apply ex_intro with (witness := [[n~S1;S3]]).
      clear IHS1.
      apply conj; [idtac | apply conj].
        SSCASE "first part".
          intros k' DB.
          inversion DB. subst. 
          pose proof (H k' H9). inversion H1. subst. auto.
        SSCASE "second part".
          destruct H0.
          assert (well_formed [[k ~ Sk; S3]]) by eauto. inversion H6. subst. 
          apply S_Trans with (U := [[n~S1;[[k~Sk;S3]]]]).
            apply S_Rcddepth; eauto. apply S_Refl; auto. 
            apply S_Rcdperm. apply wf_rcdcons; auto. auto. 
        SSCASE "third part".
          destruct H0.
          assert (well_formed [[k ~ Sk; S3]]) by eauto. inversion H6. subst. 
          apply S_Trans with (U := [[n~S1;[[k~Sk;S3]]]]).
            SSSCASE "left". apply S_Rcdperm. apply wf_rcdcons; auto. 
              assert (doesn't_bind n [[k ~ Sk; S3]]) by auto.
              inversion H7. subst. auto. auto.
            SSSCASE "right". apply S_Rcddepth. auto using S_Refl. assumption. auto. auto.
Qed.

Lemma doesn't_bind__not_bound : forall k Tk T,
     doesn't_bind k T
  -> ~ ty_rcd_binds k Tk T.
Proof.
  intros k Tk T D.
  induction T; try solve [solve by inversion].
    CASE "empty record". intros C. inversion C.
    CASE "cons record". inversion D. subst.
     unfold ty_rcd_binds. simpl. 
     apply eqnat_n_n' in H1. rewrite H1. unfold ty_rcd_binds in IHT2. auto.
Qed.

Lemma fields_sub__subtype : forall S T,
     fields_sub S T
  -> well_formed S
  -> well_formed T
  -> record_type S
  -> record_type T
  -> S <: T.
Proof.
  intros S T B WFS WFT RS RT. 
  generalize dependent S.
  induction WFT; inversion RT; subst; intros S B WFS RS.
    CASE "T empty". 
      inversion RS. apply S_Refl. auto. apply S_Rcdwidth. subst. assumption.
    CASE "T nonempty".
      unfold fields_sub in B. 
      assert (exists Sk, ty_rcd_binds k Sk S /\ Sk <: T1).
        SCASE "Pf". apply B. unfold ty_rcd_binds. simpl.
          assert (eqnat k k = yes). apply eqnat_n_n. rewrite H1. reflexivity.
      destruct H1. rename witness into Sk. destruct H1.
      assert (exists S2, (forall k', doesn't_bind k' S -> doesn't_bind k' [[k~Sk;S2]]) 
                         /\ S <: [[k~Sk;S2]] /\ [[k~Sk;S2]] <: S).
        apply bring_a_field_to_the_front. assumption. assumption.
      destruct H3. rename witness into S2. destruct H3. destruct H4.
      assert (fields_sub [[k~Sk; S2]] [[k~T1;T2]]). 
        SCASE "Pf". apply fields_sub_trans with (U:=S). apply subtype__fields_sub. 
          assumption. assumption.
      assert (fields_sub S2 T2).
        SCASE "Pf". unfold fields_sub. intros k' Tk' B'.
          remember (eqnat k k') as E. destruct E. 
            SSCASE "k = k'".  
              apply eq_symm in HeqE. apply eqnat_yes in HeqE. subst k'.
              assert (~ ty_rcd_binds k Tk' T2). apply doesn't_bind__not_bound. subst. assumption.
              contradiction.
            SSCASE "k <> k'".
              unfold fields_sub in H6. 
              apply eq_symm in HeqE. apply eqnat_symm in HeqE. 
              assert (exists Sk0, ty_rcd_binds k' Sk0 [[k ~ Sk; S2]] /\ Sk0 <: Tk').
                apply H6. unfold ty_rcd_binds. simpl. rewrite HeqE. assumption.
              destruct H7. rename witness into Sk0. destruct H7. 
              unfold ty_rcd_binds in H7. simpl in H7. rewrite HeqE in H7.
              apply ex_intro with (witness := Sk0). auto.
      apply S_Trans with (U := [[k ~ Sk; S2]]).  
        assumption.
        assert (well_formed [[k ~ Sk; S2]]).
          SCASE "Pf". assert (well_formed [[k ~ Sk; S2]] /\ well_formed S). 
            auto using subtypes__well_formed. destruct H8. assumption.
        apply S_Rcddepth. assumption. apply IHWFT2. assumption. 
        inversion H8. assumption. subst. inversion H8. assumption. inversion H8. assumption. assumption.
        auto.
Qed.

Theorem alg_subtyping_correctness : forall S T,
  S<:T <-> S<::T.
Proof.
  unfold iff. intros. apply conj.
  CASE "->".
    intros H. subtyping_cases (induction H) SCASE.
      SCASE "S_Refl". auto using alg_subtyping_refl.
      SCASE "S_Trans". eauto using alg_subtyping_trans.
      SCASE "S_Top". auto using SA_Top.
      SCASE "S_Arrow". auto using SA_Arrow.
      SCASE "S_Rcdwidth". apply SA_Rcd; auto. intros. solve by inversion.
      SCASE "S_Rcddepth". apply SA_Rcd; auto. 
        intros k' Tk' B. 
        unfold ty_rcd_binds in B. simpl in B. 
        unfold ty_rcd_binds. simpl.
        remember (eqnat k' k) as E. destruct E. 
          SSCASE "k' = k".
            inversion B. subst.
            apply eq_symm in HeqE. apply eqnat_yes in HeqE. subst. 
            apply ex_intro with (witness := S1). auto using conj. 
          SSCASE "k' <> k".
            inversion IHsubtyping2; subst; try solve [solve by inversion].
            unfold ty_rcd_binds in H7.
            apply H7. auto.
      SCASE "S_Rcdperm". 
        inversion H. subst. inversion H5. subst.
        inversion H7. subst. 
        assert (k2<>k1). intros C. apply eq_symm in C. contradiction.
        apply SA_Rcd; auto.
        unfold ty_rcd_binds. simpl.
        intros k Tk B.
        remember (eqnat k k1) as E1. destruct E1.
          SSCASE "k = k1". 
            apply eq_symm in HeqE1. apply eqnat_yes in HeqE1. subst. 
            apply eqnat_n_n' in H3. rewrite H3 in B. inversion B. subst.
            eauto 6 using ex_intro, conj, alg_subtyping_refl.
          SSCASE "k <> k1". 
            destruct (eqnat k k2); inversion B; subst. 
            eauto 6 using ex_intro, conj, alg_subtyping_refl.
            unfold ty_rcd_binds.
            apply ex_intro with (witness := Tk). apply conj. auto. apply alg_subtyping_refl.
            eapply fields_of_well_formed_types_are_well_formed. apply H9. unfold ty_rcd_binds. eauto.
  CASE "<-".
    intros H. alg_subtyping_cases (induction H using alg_subtyping_ind2) SCASE.
      SCASE "SA_ReflBase". auto using S_Refl.
      SCASE "SA_Top". auto using S_Top.
      SCASE "SA_Arrow". auto using S_Arrow.
      SCASE "SA_Rcd". auto using fields_sub__subtype.
Qed.

(* Still to be filled in: Similar proofs for the typing relation. *)

End STLCWithSubtyping'.

(* ====================================================================== *)
(* ====================================================================== *)
(* ====================================================================== *)
(* Lecture 23 *) 

(* Look over today's lecture slides and read TAPL Chapter 19 carefully
   before digging into the Coq formalization that follows. *)

(* This material was formalized by Leonid Spesivtsev based on an
   earlier formalization by Stephanie Weirich.

   It is just definitions and statements of properties at the
   moment -- no proofs.*)

Module FeatherweightJava.

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

(* Declare some synonyms for [nat] to make the definition of terms easier to follow. *)
Definition varName    :Set := nat.
Definition fieldName  :Set := nat.
Definition methodName :Set := nat.
Definition className  :Set := nat.

(* Types are just class names in FJ.  (In full Java there are also a
   handful of other types like [int] and [bool].  We ignore these.)
   So we don't need an inductive definition of the set of types. *)

(* Syntax of terms *)
Inductive tm : Set := 
  | tm_var : varName -> tm                        (* variable *)
  | tm_field : tm -> fieldName -> tm              (* field access *)
  | tm_invoke : tm -> methodName -> list tm -> tm (* method invocation *)
  | tm_new : className -> list tm -> tm           (* object creation *)
  | tm_cast : className -> tm -> tm.              (* cast *)

Hint Constructors tm.
Tactic Notation "tm_cases" tactic(first) tactic(c) :=
  first;
  [ c "tm_var" | c "tm_field" | c "tm_invoke" | c "tm_new" | c "tm_cast" ].

Definition this := zero.

(* Syntax of values.  (Intuitively: A value is a [new] expression
   where all the constructor arguments are also values.) *)
Inductive value : tm -> Prop :=
  | v_new : forall C vl,
          value_list vl
      -> value (tm_new C vl)
with value_list : list tm -> Prop :=
  | v_nil : value_list (nil _)  
  | v_cons : forall v l,
          value v
      -> value_list l
      -> value_list (v :: l).

Hint Constructors value.
Hint Constructors value_list.

(* constructor declarations *)
Inductive K : Set :=
  | constructor : 
         className -> list (varName * className) 
      -> list varName -> list varName -> K.

(* method declarations *)
Inductive M : Set :=
  | method : 
         className -> methodName 
      -> list (varName * className) -> tm -> M.

(* class declarations *)
Inductive CL : Set :=
  | class : 
         className -> className 
      -> list (fieldName * className) -> K -> list M -> CL.

(* class table *)
Definition CT : Set := alist CL. 

(* The special class Object is "named" zero. *)
Definition Object :=  zero.

(* ---------------------------------------------------------------------- *)
(* EXERCISE: Translate the following FJ class table (from TAPL 
   chapter 19) into Coq. 

      class A extends Object { A() { super(); } }

      class B extends Object { B() { super(); } }

      class Pair extends Object {
        Object fst;
        Object snd;

        Pair(Object fst, Object snd) {
          super(); this.fst=fst; this.snd=snd; }

        Pair setfst(Object newfst) {
          return new Pair(newfst, this.snd); } 
      }
*)

Definition A : className := one.
Definition B : className := two.
Definition Pair : className := three.
Definition fst : fieldName := one.
Definition snd : fieldName := two.
Definition setfst : fieldName := three.
Definition newfst : fieldName := four.

Definition CL_A :=
  class A Object (nil _) (constructor A (nil _) (nil _) (nil _)) (nil _).

(* <------ remove this comment
Definition CL_B :=
  FILL IN HERE

Definition CL_Pair :=
  FILL IN HERE

remove this comment ------> *)

(* Dummy definitions (so that Coq accepts the lecture notes)
remove this comment ------> *)
Definition CL_B := CL_A.
Definition CL_Pair := CL_A.
(* <------ remove this comment
*)

Definition ct : CT :=
  [(A, CL_A),
   (B, CL_B),
   (Pair, CL_Pair)].
  
(* ---------------------------------------------------------------------- *)
(* Subtyping *)

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

Inductive subtyping : CT -> className -> className -> Prop :=
  | S_Refl : forall CT C,
         subtyping CT C C
  | S_Trans : forall CT C D E,
         subtyping CT C D
      -> subtyping CT D E
      -> subtyping CT C E
  | S_Ext : forall CT C D Cf K M,
         lookup _ C CT = Some _ (class C D Cf K M)
      -> subtyping CT C D.

Tactic Notation "subtyping_cases" tactic(first) tactic(c) :=
  first;
  [ c "S_Refl" | c "S_Trans" | c "S_Ext" ].

(* ---------------------------------------------------------------------- *)
(* Auxiliary Definitions *)

(* Field lookup *)
Inductive fields : CT -> className -> list (fieldName * className) -> Prop :=
   | f_obj : forall CT C,
          C = Object -> fields CT C (nil _)
   | f_class : forall CT C D Cf K M' Dg, 
          lookup _ C CT = Some _ (class C D Cf K M')  
     -> fields CT D Dg 
     -> fields CT C  (Dg ++ Cf).
Hint Constructors fields.

(* Search for a method in a list of method delarations *)
Fixpoint mlookup (m : methodName) (l : list M) {struct l} : option M :=
  match l with
  | nil => None _
  | (method T m' Cx t) :: l' =>
      if eqnat m m' then Some _ (method T m' Cx t) else mlookup m l'
  end.

(* Method type lookup *)
Inductive mtype : CT -> methodName -> className -> list className -> className -> Prop :=
   | mt_class : forall CT m C D Cf K M' Cx t B' B,
         lookup _ C CT = Some _ (class C D Cf K M')  
     -> mlookup m M' = Some _ (method B m Cx t)
     -> B' = map _ _ (fun p => match p with (f,s) => s end) Cx
     -> mtype CT m C B' B
   | mt_super : forall CT m C D Cf K M' B' B,
         lookup _ C CT = Some _ (class C D Cf K M')  
     -> mlookup m M' = None _
     -> mtype CT m D B' B
     -> mtype CT m C B' B.
Hint Constructors mtype.

(* Method body lookup *)
Inductive mbody : CT -> methodName -> className -> list varName -> tm -> Prop :=
   | mb_class : forall CT m C D Cf K M' Cx t x B,
         lookup _ C CT = Some _ (class C D Cf K M')  
     -> mlookup m M' = Some _ (method B m Cx t)
     -> x = map _ _ (fun p => match p with (f,s) => f end) Cx
     -> mbody CT m C x t
   | mb_super : forall CT m C D Cf K M' x t,
         lookup _ C CT = Some _ (class C D Cf K M')  
     -> mlookup m M' = None _
     -> mbody CT m D x t
     -> mbody CT m C x t.
Hint Constructors mbody.

Inductive method_not_defined_in_class : CT -> methodName -> className -> Prop :=
  | mndic_obj : forall CT m,
      method_not_defined_in_class CT m Object
  | mndic_class : forall CT m C D Cf K M',
      lookup _ C CT = Some _ (class C D Cf K M') 
   -> method_not_defined_in_class CT m C.

(* Valid method overriding *)
Inductive override : CT -> methodName -> className -> list className -> className -> Prop :=
   | m_notboundinsuper : forall CT m D C' C0,
        method_not_defined_in_class CT m D
     -> override CT m D C' C0
   | m_over : forall CT m D C' C0 D' D0,
        mtype CT m D D' D0  
     -> C' = D'
     -> C0=D0
     -> override CT m D C' C0.
Hint Constructors override.

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

(* A missing list utility: [combine] takes two lists and produces a
   list of pairs of corresponding elements. If the lists given to
   [combine] are of different lengths, the result will have the same
   number of elements as the shorter input. *)
Fixpoint combine (X Y : Set) (l : list X) (l' : list Y) {struct l} : list (X*Y) :=
  match l,l' with
    | x::tl, y::tl' => (x,y)::(combine _ _ tl tl')
    | _, _ => nil _
  end.

(* Substitution *)

(* The substitution function for FJ is superficially quite a bit more
   complex than what we have seen before, but conceptually it is not
   much different.  The important thing to realize is that we are
   performing a SIMULTANEOUS substitution for a whole list of
   variables ([x]) by a list of values ([u]) in a term [t].  Moreover,
   we treat the variable [this] specially: the parameters [C] and [v]
   represent the class name and field values of the "current object",
   and the substitution function reconstitutes copies of this object
   in place of any occurrences of [this] in the body [t]. 

   The other technical complication in the definition is that we are
   actually performing a *simultaneous* recursion on terms and lists
   of terms; this is the reason for the two occurrences of [fix] in
   the body.  You do not need to understand this part in detail --
   just the overall purpose of the substitution function is enough.
*)
Fixpoint subst (x: list varName) (u: list tm) 
               (C:className) (v:list tm) 
               (t:tm) {struct t} : tm :=
  match t with
  | tm_var this => tm_new C v
  | tm_var y => 
      match lookup _ y (combine _ _ x u) with
        | Some u1 => u1
        | None => t
      end
  | tm_field t1 f => 
      tm_field (subst x u C v t1) f
  | tm_invoke t1 m l => 
      tm_invoke (subst x u C v t1) m 
        ((fix subst_list (x: list varName) (u: list tm) 
                         (C:className) (v:list tm) (tl: list tm) 
                         {struct tl} : list tm := 
          match tl with 
            | nil => nil _ 
            | (h::t) => (subst x u C v h) :: (subst_list x u C v t) 
          end) x u C v l)
  | tm_new D l => 
      tm_new D ((fix subst_list (x: list varName) (u: list tm) 
                                (C:className) (v:list tm) (tl: list tm) 
                                {struct tl} : list tm := 
                match tl with 
                | nil => nil _ 
                | (h::t) => (subst x u C v h) :: (subst_list x u C v t) 
                end) x u C v l)
  | tm_cast D t1 => tm_cast D (subst x u C v t1)
  end.

Inductive eval : CT -> tm -> tm -> Prop :=
  | E_ProjNew : forall CT C v fj vj Cf,
         value_list v
      -> fields CT C Cf
      -> (lookup _ fj 
           (combine _ _ (map _ _ (fun p => match p with (f,s) => f end) Cf) v)) 
          = Some _ vj
      -> eval CT (tm_field (tm_new C v) fj) (vj)
  | E_InvkNew : forall CT C v m u t0 x,
         value_list v
      -> value_list u
      -> mbody CT m C x t0
      -> eval CT (tm_invoke (tm_new C v) m u) (subst x u C v t0)
  | E_CastNew : forall CT C D v,
         value_list v
      -> subtyping CT C D
      -> eval CT (tm_cast D (tm_new C v)) (tm_new C v)
  | E_Field : forall CT f t t',
         eval CT t t'
      -> eval CT (tm_field t f) (tm_field t' f)
  | E_Invk_Recv : forall CT l m t0 t0',
         eval CT t0 t0'
      -> eval CT (tm_invoke t0 m l) (tm_invoke t0' m l)
  | E_Invk_Arg : forall CT v0 m v ti ti' t,
         value v0
      -> value_list v
      -> eval CT ti ti'
      -> eval CT (tm_invoke v0 m (v ++ [ti] ++ t)) 
                 (tm_invoke v0 m (v ++ [ti'] ++ t))
  | E_New_Arg : forall CT C v ti ti' t,
         value_list v
      -> eval CT ti ti'
      -> eval CT (tm_new C (v ++ [ti] ++ t)) (tm_new C (v ++ [ti'] ++ t))
  | E_Cast : forall CT C t t',
         eval CT t t'
      -> eval CT (tm_cast C t) (tm_cast C t').

Hint Constructors eval.
Tactic Notation "eval_cases" tactic(first) tactic(c) :=
  first;
  [ c "E_ProjNew" | c "E_InvkNew" | c "E_CastNew" |
  | c "E_Field" | c "E_Invk_Recv" | c "E_Invk_Arg" | c "E_New_Arg"
  | c "E_Cast"].

(* EXERCISE: Prove that
      new Pair(new A(), new B()).setfst(new B())
   evaluates in one step to
      new Pair(new B(), new Pair(new A(), new B()).snd)
*)
Lemma eval_exercise : 
  eval
     ct
     (tm_invoke 
        (tm_new Pair [tm_new A (nil _), tm_new B (nil _)])
        setfst 
        [tm_new B (nil _)])
     (tm_new Pair [tm_new B (nil _), 
                   tm_field (tm_new Pair [tm_new A (nil _), tm_new B (nil _)]) snd]).
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

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

Notation context := (alist className).

Definition empty : context := nil _.

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

Inductive typing : CT -> context -> tm -> className -> Prop :=
  | T_Var : forall CT Gamma x C,
           binds _ x C Gamma
      -> CT >> Gamma |- (tm_var x) ~ C
  | T_Field : forall CT Gamma t0 fi Ci C0 Cf,
           CT >> Gamma |- t0 ~ C0
      -> fields CT C0 Cf
      -> (lookup _ fi Cf) = Some _ Ci
      -> CT >> Gamma |- (tm_field t0 fi) ~ Ci
  | T_Invk : forall CT Gamma t0 m tl C C0 Dl,
           CT >> Gamma |- t0 ~ C0
      -> mtype CT m C0 Dl C
      -> typing_list CT Gamma tl Dl
      -> CT >> Gamma |- (tm_invoke t0 m tl) ~ C
  | T_New : forall CT Gamma tl C Df,
           fields CT C Df
      -> typing_list CT Gamma tl 
            (map _ _ (fun p => match p with (f,s) => s end) Df)
      -> CT >> Gamma |- (tm_new C tl) ~ C
  | T_UCast : forall CT Gamma t0 C D,
           CT >> Gamma |- t0 ~ D
      -> subtyping CT D C
      -> CT >> Gamma |- (tm_cast C t0) ~ C
  | T_DCast : forall CT Gamma t0 C D,
           CT >> Gamma |- t0 ~ D
      -> subtyping CT C D
      -> C<>D
      -> CT >> Gamma |- (tm_cast C t0) ~ C
  | T_SCast : forall CT Gamma t0 C D,
           CT >> Gamma |- t0 ~ D
      -> ~ (subtyping CT C D)
      -> ~ (subtyping CT D C)
      -> CT >> Gamma |- (tm_cast C t0) ~ C

with typing_list : CT -> context -> list tm -> list className -> Prop :=
   | TL_nil  : forall CT Gamma,
              typing_list CT Gamma (nil _) (nil _)
   | TL_cons : forall CT Gamma t tl C Cl T,
              typing CT Gamma t T
         -> subtyping CT T C
	 -> typing_list CT Gamma tl Cl 
	 -> typing_list CT Gamma (t::tl) (C::Cl)

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

Tactic Notation "typing_cases" tactic(first) tactic(c) :=
  first;
  [   c "T_Var" | c "T_Field" | c "T_Invk" | c "T_New" 
    | c "T_UCast" | c "T_DCast" | c "T_SCast" ].

(* Method typing *)
Inductive mtyping : CT -> className -> methodName 
                 -> list (varName * className) -> tm ->className -> Prop :=
   | m_ok : forall CT C0 m Cx t0 C D Cl Df K Ml E0,
         CT >> (this,C) :: Cx |- t0 ~ E0  
     -> subtyping CT E0 C0
     -> lookup _ C CT = Some _ (class C D Df K Ml)
     -> override CT m D Cl C0
     -> mtyping CT C0 m Cx t0 C.
Hint Constructors mtyping.

Inductive mlist_typing : CT -> list M -> className -> Prop :=
   | m_ok_nil : forall CT C,
         mlist_typing CT (nil _) C
   | m_ok_cons : forall CT M C Ml C0 m Cx t0,
         M = method C0 m Cx t0
     -> mtyping CT C0 m Cx t0 C
     -> mlist_typing CT (M :: Ml) C.
Hint Constructors mlist_typing.

(* Class typing *)
Inductive ctyping : CT -> className -> className 
                 -> list (fieldName * className) -> K -> list M -> Prop :=
   | c_ok : forall CT C D Cf K Ml Dg,
         K = constructor C (Dg ++ Cf) 
               (map _ _ (fun p => match p with (f,s) => f end) Dg) 
               (map _ _ (fun p => match p with (f,s) => f end) Cf) 
     -> fields CT D Dg
     -> mlist_typing CT Ml C 
     -> ctyping CT C D Cf K Ml.
Hint Constructors ctyping.

(* The whole class table is well formed if each class definition in it is well typed. *)
Definition wf_class_table (ct : CT) : Prop :=
  forall C D Cf K M',
        lookup _ C ct = Some _ (class C D Cf K M')
     -> ctyping ct C D Cf K M'.

(* EXERCISE (optional): Prove that the class table we defined above is
   well formed. *)
Lemma wf_exercise : 
  wf_class_table ct.
Proof.
  (* FILL IN HERE (and delete "Admitted") *) Admitted.

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

Theorem preservation : forall CT Gamma t t' C,
     CT >> Gamma |- t ~ C
  -> eval CT t t'
  -> exists C', (subtyping CT C' C) /\ (CT >> Gamma |- t' ~ C').
Proof.
Admitted.

(* Evaluation context *)
Inductive E : Set :=
   | ec_hole : E                     (* hole *)
   | ec_field : E -> fieldName -> E (* field access *)
   | ec_invk_recv : E -> methodName -> list tm -> E (* method inv (receiver) *)
   | ec_invk_arg : tm -> methodName -> list tm -> E -> list tm -> E (* method invocation (arg) *)
   | ec_new : className -> list tm -> E -> list tm -> E (* object creation (arg) *)
   | ec_cast : className -> E -> E (* cast *).

Inductive well_formed_context : E -> Prop :=
   | wfc_hole : well_formed_context ec_hole 
   | wfc_field : forall c c1 f,
          c = ec_field c1 f
     -> well_formed_context c1
     -> well_formed_context c
   | wfc_invk_recv : forall c c1 m l,
          c = ec_invk_recv c1 m l
     -> well_formed_context c1
     -> well_formed_context c
   | wfc_invk_arg : forall c c1 v m vl tl,
          c = ec_invk_arg v m vl c1 tl
     -> value v
     -> value_list vl
     -> well_formed_context c
   | wfc_new : forall c C vl c1 tl,
          c = ec_new C vl c1 tl
     -> value_list vl
     -> well_formed_context c1
     -> well_formed_context c
   | wfc_cast : forall c c1 C,
          c = ec_cast C c1
     -> well_formed_context c1
     -> well_formed_context c.

Fixpoint E_subst (e: E) (t: tm) {struct e} : tm :=
  match e with 
   | ec_hole => t 
   | ec_field c f => tm_field (E_subst c t) f
   | ec_invk_recv c m l => tm_invoke (E_subst c t) m l
   | ec_invk_arg v m vl c tl => tm_invoke v m (vl ++ [(E_subst c t)] ++ tl)
   | ec_new C vl c tl => tm_new C (vl ++ [(E_subst c t)] ++ tl)
   | ec_cast C c => tm_cast C (E_subst c t)
  end.

Theorem progress : forall CT Gamma t C,
     CT >> Gamma |- t ~ C
  -> (value t) 
     \/ (exists e:E, exists D:className, exists vl:list tm, 
              (well_formed_context e) 
           /\ (t = E_subst e (tm_cast C (tm_new D vl))) 
           /\ (value_list vl) 
           /\ (~ subtyping CT D C)).
Proof.
Admitted.

End FeatherweightJava.