samuelgruetter/dot-calculus

Switch branches/tags
Nothing to show
Fetching contributors…
Cannot retrieve contributors at this time
1765 lines (1537 sloc) 51 KB
 (* DSub (D<:) T ::= Top | p.Type | { Type = T } | { Type <: T } | (z: T) -> T^z t ::= p | t t p ::= x | v v ::= { Type = T } | lambda x:T.t *) (* based on *) (*************************************************************************** * Preservation and Progress for System-F with Subtyping - Definitions * * Brian Aydemir & Arthur Charguéraud, March 2007 * ***************************************************************************) Set Implicit Arguments. Require Import LibLN. Implicit Types x : var. (* ********************************************************************** *) (** * Description of the Language *) (** Representation of pre-types *) Inductive typ : Set := | typ_top : typ | typ_sel : trm -> typ | typ_mem : bool -> typ -> typ | typ_all : typ -> typ -> typ (** Representation of pre-terms *) with trm : Set := | trm_bvar : nat -> trm | trm_fvar : var -> trm | trm_abs : typ -> trm -> trm | trm_mem : typ -> trm | trm_app : trm -> trm -> trm. Fixpoint open_t_rec (k : nat) (f : trm) (T : typ) {struct T} : typ := match T with | typ_top => typ_top | typ_sel t => typ_sel (open_e_rec k f t) | typ_mem b T => typ_mem b (open_t_rec k f T) | typ_all T1 T2 => typ_all (open_t_rec k f T1) (open_t_rec (S k) f T2) end (** Opening up a term binder occuring in a term *) with open_e_rec (k : nat) (f : trm) (e : trm) {struct e} : trm := match e with | trm_bvar i => If k = i then f else (trm_bvar i) | trm_fvar x => trm_fvar x | trm_abs V e1 => trm_abs (open_t_rec k f V) (open_e_rec (S k) f e1) | trm_mem T => trm_mem (open_t_rec k f T) | trm_app e1 e2 => trm_app (open_e_rec k f e1) (open_e_rec k f e2) end. Definition open_t T f := open_t_rec 0 f T. Definition open_e t u := open_e_rec 0 u t. (** Notation for opening up binders with variables *) Notation "t 'open_t_var' x" := (open_t t (trm_fvar x)) (at level 67). Notation "t 'open_e_var' x" := (open_e t (trm_fvar x)) (at level 67). (** Types as locally closed pre-types *) Inductive type : typ -> Prop := | type_top : type typ_top | type_sel : forall e1, term e1 -> type (typ_sel e1) | type_mem : forall b T1, type T1 -> type (typ_mem b T1) | type_all : forall L T1 T2, type T1 -> (forall x, x \notin L -> type (T2 open_t_var x)) -> type (typ_all T1 T2) (** Terms as locally closed pre-terms *) with term : trm -> Prop := | term_var : forall x, term (trm_fvar x) | term_abs : forall L V e1, type V -> (forall x, x \notin L -> term (e1 open_e_var x)) -> term (trm_abs V e1) | term_mem : forall T1, type T1 -> term (trm_mem T1) | term_app : forall e1 e2, term e1 -> term e2 -> term (trm_app e1 e2). (** Values *) Inductive value : trm -> Prop := | value_abs : forall V e1, term (trm_abs V e1) -> value (trm_abs V e1) | value_mem : forall V, term (trm_mem V) -> value (trm_mem V). (** Environment is an associative list of bindings. *) Definition env := LibEnv.env typ. (** Well-formedness of a pre-type T in an environment E: all the type variables of T must be bound via a subtyping relation in E. This predicates implies that T is a type *) Inductive wft : env -> typ -> Prop := | wft_top : forall E, wft E typ_top | wft_sel : forall E e, value e \/ (exists x, trm_fvar x = e) -> wfe E e -> wft E (typ_sel e) | wft_mem : forall E b T1, wft E T1 -> wft E (typ_mem b T1) | wft_all : forall L E T1 T2, wft E T1 -> (forall x, x \notin L -> wft (E & x ~ T1) (T2 open_t_var x)) -> wft E (typ_all T1 T2) with wfe : env -> trm -> Prop := | wfe_var : forall U E x, binds x U E -> wfe E (trm_fvar x) | wfe_abs : forall L E V e, wft E V -> (forall x, x \notin L -> wfe (E & x ~ V) (e open_e_var x)) -> wfe E (trm_abs V e) | wfe_mem : forall E T, wft E T -> wfe E (trm_mem T) | wfe_app : forall E e1 e2, wfe E e1 -> wfe E e2 -> wfe E (trm_app e1 e2) . (** A environment E is well-formed if it contains no duplicate bindings and if each type in it is well-formed with respect to the environment it is pushed on to. *) Inductive okt : env -> Prop := | okt_empty : okt empty | okt_push : forall E x T, okt E -> wft E T -> x # E -> okt (E & x ~ T). (** Subtyping relation *) Inductive sub : env -> typ -> typ -> Prop := | sub_top : forall E S, okt E -> wft E S -> sub E S typ_top | sub_refl_sel : forall E t, okt E -> wft E (typ_sel t) -> sub E (typ_sel t) (typ_sel t) | sub_sel1 : forall E U t, has E t (typ_mem false U) -> sub E (typ_sel t) U | sub_sel2 : forall E S t, has E t (typ_mem true S) -> sub E S (typ_sel t) | sub_mem_false : forall E b1 T1 T2, sub E T1 T2 -> sub E (typ_mem b1 T1) (typ_mem false T2) | sub_mem_true : forall E T1 T2, sub E T1 T2 -> sub E T2 T1 -> sub E (typ_mem true T1) (typ_mem true T2) | sub_all : forall L E S1 S2 T1 T2, sub E T1 S1 -> (forall x, x \notin L -> sub (E & x ~ T1) (S2 open_t_var x) (T2 open_t_var x)) -> sub E (typ_all S1 S2) (typ_all T1 T2) | sub_trans : forall E S T U, sub E S T -> sub E T U -> sub E S U with has : env -> trm -> typ -> Prop := | has_var : forall E x T, okt E -> binds x T E -> has E (trm_fvar x) T | has_mem : forall E b T, okt E -> wft E T -> has E (trm_mem T) (typ_mem b T) | has_abs : forall E V e T,(* dummy case for smooth substitution lemma, see val_typing_has *) okt E -> wfe E (trm_abs V e) -> wft E (typ_all V T) -> has E (trm_abs V e) (typ_all V T) (* return typ doesn't matter, as long as it's moot for sel1 and sel2 *) | has_sub : forall E t T U, has E t T -> sub E T U -> has E t U . (** Typing relation *) Inductive typing : env -> trm -> typ -> Prop := | typing_var : forall E x T, okt E -> binds x T E -> typing E (trm_fvar x) T | typing_abs : forall L E V e1 T1, (forall x, x \notin L -> typing (E & x ~ V) (e1 open_e_var x) (T1 open_t_var x)) -> typing E (trm_abs V e1) (typ_all V T1) | typing_mem : forall E T1, okt E -> wft E T1 -> typing E (trm_mem T1) (typ_mem true T1) | typing_app : forall T1 E e1 e2 T2, typing E e1 (typ_all T1 T2) -> typing E e2 T1 -> wft E T2 -> typing E (trm_app e1 e2) T2 | typing_appvar : forall T1 E e1 e2 T2 T2' M, typing E e1 (typ_all T1 T2) -> typing E e2 T1 -> has E e2 M -> T2' = open_t T2 e2 -> wft E T2' -> typing E (trm_app e1 e2) T2' | typing_sub : forall S E e T, typing E e S -> sub E S T -> typing E e T. (** One-step reduction *) Inductive red : trm -> trm -> Prop := | red_app_1 : forall e1 e1' e2, term e2 -> red e1 e1' -> red (trm_app e1 e2) (trm_app e1' e2) | red_app_2 : forall e1 e2 e2', value e1 -> red e2 e2' -> red (trm_app e1 e2) (trm_app e1 e2') | red_abs : forall V e1 v2, term (trm_abs V e1) -> value v2 -> red (trm_app (trm_abs V e1) v2) (open_e e1 v2). (** Our goal is to prove preservation and progress *) Definition preservation := forall e e' T, typing empty e T -> red e e' -> typing empty e' T. Definition progress := forall e T, typing empty e T -> value e \/ exists e', red e e'. (*************************************************************************** * Preservation and Progress for System-F with Subtyping - Infrastructure * ***************************************************************************) (* ********************************************************************** *) (** * Additional Definitions Used in the Proofs *) (** Computing free variables in a type *) Fixpoint fv_t (T : typ) {struct T} : vars := match T with | typ_top => \{} | typ_sel t => fv_e t | typ_mem b T1 => (fv_t T1) | typ_all T1 T2 => (fv_t T1) \u (fv_t T2) end (** Computing free variables in a term *) with fv_e (e : trm) {struct e} : vars := match e with | trm_bvar i => \{} | trm_fvar x => \{x} | trm_abs V e1 => (fv_t V) \u (fv_e e1) | trm_mem T => fv_t T | trm_app e1 e2 => (fv_e e1) \u (fv_e e2) end. (** Substitution for free type variables in types. *) Fixpoint subst_t (z : var) (u : trm) (T : typ) {struct T} : typ := match T with | typ_top => typ_top | typ_sel t => typ_sel (subst_e z u t) | typ_mem b T1 => typ_mem b (subst_t z u T1) | typ_all T1 T2 => typ_all (subst_t z u T1) (subst_t z u T2) end (** Substitution for free term variables in terms. *) with subst_e (z : var) (u : trm) (e : trm) {struct e} : trm := match e with | trm_bvar i => trm_bvar i | trm_fvar x => If x = z then u else (trm_fvar x) | trm_abs V e1 => trm_abs (subst_t z u V) (subst_e z u e1) | trm_mem T1 => trm_mem (subst_t z u T1) | trm_app e1 e2 => trm_app (subst_e z u e1) (subst_e z u e2) end. (* ********************************************************************** *) (** * Tactics *) (** Constructors as hints. *) Hint Constructors type term wft wfe ok okt value red. Hint Resolve sub_top sub_refl_sel typing_var typing_app typing_sub. (** Gathering free names already used in the proofs *) Ltac gather_vars := let A := gather_vars_with (fun x : vars => x) in let B := gather_vars_with (fun x : var => \{x}) in let C := gather_vars_with (fun x : typ => fv_t x) in let D := gather_vars_with (fun x : trm => fv_e x) in let E := gather_vars_with (fun x : env => dom x) in constr:(A \u B \u C \u D \u E). (** "pick_fresh x" tactic create a fresh variable with name x *) Ltac pick_fresh x := let L := gather_vars in (pick_fresh_gen L x). (** "apply_fresh T as x" is used to apply inductive rule which use an universal quantification over a cofinite set *) Tactic Notation "apply_fresh" constr(T) "as" ident(x) := apply_fresh_base T gather_vars x. Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) := apply_fresh T as x; auto*. (** These tactics help applying a lemma which conclusion mentions an environment (E & F) in the particular case when F is empty *) Ltac get_env := match goal with | |- wft ?E _ => E | |- wfe ?E _ => E | |- sub ?E _ _ => E | |- has ?E _ _ => E | |- typing ?E _ _ => E end. Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) := let E := get_env in rewrite <- (concat_empty_r E); eapply lemma; try rewrite concat_empty_r. Tactic Notation "apply_empty" constr(F) := apply_empty_bis (get_env) F. Tactic Notation "apply_empty" "*" constr(F) := apply_empty F; auto*. Scheme typ_mut := Induction for typ Sort Prop with trm_mut := Induction for trm Sort Prop. Combined Scheme typ_trm_mutind from typ_mut, trm_mut. Scheme type_mut := Induction for type Sort Prop with term_mut := Induction for term Sort Prop. Combined Scheme lc_mutind from type_mut, term_mut. Scheme wft_mut := Induction for wft Sort Prop with wfe_mut := Induction for wfe Sort Prop. Combined Scheme wf_mutind from wft_mut, wfe_mut. Scheme sub_mut := Induction for sub Sort Prop with has_mut := Induction for has Sort Prop. Combined Scheme sub_has_mutind from sub_mut, has_mut. (* ********************************************************************** *) (** * Properties of Substitutions *) (** Substitution on indices is identity on well-formed terms. *) Lemma open_rec_lc_core : (forall T j v u i, i <> j -> (open_t_rec j v T) = open_t_rec i u (open_t_rec j v T) -> T = open_t_rec i u T) /\ (forall e j v u i, i <> j -> open_e_rec j v e = open_e_rec i u (open_e_rec j v e) -> e = open_e_rec i u e). Proof. apply typ_trm_mutind; try (introv IH1 IH2 Neq H); try (introv IH Neq H); try (introv Neq H); simpl in *; inversion H; f_equal*. case_nat*. case_nat*. Qed. Lemma open_rec_lc : (forall T, type T -> forall u k, T = open_t_rec k u T) /\ (forall e, term e -> forall u k, e = open_e_rec k u e). Proof. apply lc_mutind; intros; simpl; f_equal*. pick_fresh x. apply* ((proj1 open_rec_lc_core) T2 0 (trm_fvar x)). pick_fresh x. apply* ((proj2 open_rec_lc_core) e1 0 (trm_fvar x)). Qed. Lemma open_t_var_type : forall x T, type T -> T open_t_var x = T. Proof. intros. unfold open_t. rewrite* <- (proj1 open_rec_lc). Qed. (** Substitution for a fresh name is identity. *) Lemma subst_fresh : (forall T z u, z \notin fv_t T -> subst_t z u T = T) /\ (forall e z u, z \notin fv_e e -> subst_e z u e = e). Proof. apply typ_trm_mutind; simpl; intros; f_equal*. case_var*. Qed. (** Substitution distributes on the open operation. *) Lemma subst_open_rec : (forall T1 t2 x u n, term u -> subst_t x u (open_t_rec n t2 T1) = open_t_rec n (subst_e x u t2) (subst_t x u T1)) /\ (forall t1 t2 x u n, term u -> subst_e x u (open_e_rec n t2 t1) = open_e_rec n (subst_e x u t2) (subst_e x u t1)). Proof. apply typ_trm_mutind; intros; simpls; f_equal*. case_nat*. case_var*. rewrite* <- (proj2 open_rec_lc). Qed. Lemma subst_t_open_t : forall T1 t2 x u, term u -> subst_t x u (open_t T1 t2) = open_t (subst_t x u T1) (subst_e x u t2). Proof. unfold open_t. auto* (proj1 subst_open_rec). Qed. Lemma subst_e_open_e : forall t1 t2 x u, term u -> subst_e x u (open_e t1 t2) = open_e (subst_e x u t1) (subst_e x u t2). Proof. unfold open_e. auto* (proj2 subst_open_rec). Qed. (** Substitution and open_var for distinct names commute. *) Lemma subst_t_open_t_var : forall x y u T, y <> x -> term u -> (subst_t x u T) open_t_var y = subst_t x u (T open_t_var y). Proof. introv Neq Wu. rewrite* subst_t_open_t. simpl. case_var*. Qed. Lemma subst_e_open_e_var : forall x y u e, y <> x -> term u -> (subst_e x u e) open_e_var y = subst_e x u (e open_e_var y). Proof. introv Neq Wu. rewrite* subst_e_open_e. simpl. case_var*. Qed. (** Opening up a body t with a type u is the same as opening up the abstraction with a fresh name x and then substituting u for x. *) Lemma subst_t_intro : forall x T2 u, x \notin fv_t T2 -> term u -> open_t T2 u = subst_t x u (T2 open_t_var x). Proof. introv Fr Wu. rewrite* subst_t_open_t. rewrite* (proj1 subst_fresh). simpl. case_var*. Qed. Lemma subst_e_intro : forall x t2 u, x \notin fv_e t2 -> term u -> open_e t2 u = subst_e x u (t2 open_e_var x). Proof. introv Fr Wu. rewrite* subst_e_open_e. rewrite* (proj2 subst_fresh). simpl. case_var*. Qed. (** Substitutions preserve local closure. *) Lemma subst_lc : (forall T, type T -> forall z u, term u -> type (subst_t z u T)) /\ (forall e, term e -> forall z u, term u -> term (subst_e z u e)). Proof. apply lc_mutind; intros; simpl; auto. apply_fresh* type_all as X. rewrite* subst_t_open_t_var. case_var*. apply_fresh* term_abs as y. rewrite* subst_e_open_e_var. Qed. Lemma subst_t_type : forall T z u, type T -> term u -> type (subst_t z u T). Proof. intros. apply* (proj1 subst_lc). Qed. Lemma subst_e_term : forall e1 z e2, term e1 -> term e2 -> term (subst_e z e2 e1). Proof. intros. apply* (proj2 subst_lc). Qed. Lemma subst_e_value : forall e1 z e2, value e1 -> term e2 -> value (subst_e z e2 e1). Proof. intros. inversion H; subst; simpl. - apply value_abs. assert (trm_abs (subst_t z e2 V) (subst_e z e2 e0) = subst_e z e2 (trm_abs V e0)) as A. { simpl. reflexivity. } rewrite A. apply* subst_e_term. - apply value_mem. assert (trm_mem (subst_t z e2 V) = subst_e z e2 (trm_mem V)) as A. { simpl. reflexivity. } rewrite A. apply* subst_e_term. Qed. Lemma value_is_term: forall e, value e -> term e. Proof. introv H. inversion H; subst; eauto. Qed. Hint Resolve subst_t_type subst_e_term subst_e_value value_is_term. (* ********************************************************************** *) (** * Properties of well-formedness of a type in an environment *) (** If a type is well-formed in an environment then it is locally closed. *) Lemma wf_lc : (forall E T, wft E T -> type T) /\ (forall E e, wfe E e -> term e). Proof. apply wf_mutind; eauto. Qed. Lemma wft_type : forall E T, wft E T -> type T. Proof. intros. eapply (proj1 wf_lc); eauto. Qed. Lemma wfe_term : forall E e, wfe E e -> term e. Proof. intros. eapply (proj2 wf_lc); eauto. Qed. (** Through weakening *) Lemma wf_weaken : (forall E0 T, wft E0 T -> forall E F G, E0 = E & G -> ok (E & F & G) -> wft (E & F & G) T) /\ (forall E0 e, wfe E0 e -> forall E F G, E0 = E & G -> ok (E & F & G) -> wfe (E & F & G) e). Proof. apply wf_mutind; intros; subst; eauto. apply_fresh* wft_all as Y. apply_ih_bind* H0. apply (@wfe_var U). apply* binds_weaken. apply_fresh* wfe_abs as y. apply_ih_bind* H0. Qed. Lemma wft_weaken : forall G T E F, wft (E & G) T -> ok (E & F & G) -> wft (E & F & G) T. Proof. intros. eapply (proj1 wf_weaken); eauto. Qed. Lemma wft_weaken_empty : forall T E, wft empty T -> ok E -> wft E T. Proof. intros. assert (E = empty & E & empty) as A. { rewrite concat_empty_l. rewrite concat_empty_r. reflexivity. } rewrite A. apply wft_weaken. rewrite concat_empty_l. auto. rewrite concat_empty_l. rewrite concat_empty_r. auto. Qed. Lemma wfe_weaken : forall G T E F, wfe (E & G) T -> ok (E & F & G) -> wfe (E & F & G) T. Proof. intros. eapply (proj2 wf_weaken); eauto. Qed. Lemma wfe_weaken_empty : forall T E, wfe empty T -> ok E -> wfe E T. Proof. intros. assert (E = empty & E & empty) as A. { rewrite concat_empty_l. rewrite concat_empty_r. reflexivity. } rewrite A. apply wfe_weaken. rewrite concat_empty_l. auto. rewrite concat_empty_l. rewrite concat_empty_r. auto. Qed. (** Through narrowing *) Lemma wf_narrow : (forall E0 T, wft E0 T -> forall V F U E x, E0 = (E & x ~ V & F) -> ok (E & x ~ U & F) -> wft (E & x ~ U & F) T) /\ (forall E0 e, wfe E0 e -> forall V F U E x, E0 = (E & x ~ V & F) -> ok (E & x ~ U & F) -> wfe (E & x ~ U & F) e). Proof. apply wf_mutind; intros; subst; eauto. apply_fresh* wft_all as Y. apply_ih_bind* H0. destruct (binds_middle_inv b) as [K|[K|K]]; try destructs K. applys wfe_var. apply* binds_concat_right. subst. applys wfe_var. apply~ binds_middle_eq. applys wfe_var. apply~ binds_concat_left. apply* binds_concat_left. apply_fresh* wfe_abs as y. apply_ih_bind* H0. Qed. Lemma wft_narrow : forall V F U T E x, wft (E & x ~ V & F) T -> ok (E & x ~ U & F) -> wft (E & x ~ U & F) T. Proof. intros. eapply (proj1 wf_narrow); eauto. Qed. (** Through substitution *) Lemma wf_subst : (forall E0 T, wft E0 T -> forall F Q E Z u, E0 = E & Z ~ Q & F -> (value u \/ exists x, trm_fvar x = u) -> wfe E u -> ok (E & map (subst_t Z u) F) -> wft (E & map (subst_t Z u) F) (subst_t Z u T)) /\ (forall E0 e, wfe E0 e -> forall F Q E Z u, E0 = E & Z ~ Q & F -> (value u \/ exists x, trm_fvar x = u) -> wfe E u -> ok (E & map (subst_t Z u) F) -> wfe (E & map (subst_t Z u) F) (subst_e Z u e)). Proof. apply wf_mutind; intros; subst; simpl; eauto. - destruct o as [? | [? ?]]. + apply* wft_sel. left. apply subst_e_value. assumption. apply* wfe_term. + subst. simpl. case_var*. * apply_empty* wft_weaken. * apply* wft_sel. rewrite* <- ((proj2 subst_fresh) (trm_fvar x) Z u). simpl. auto. - apply_fresh* wft_all as Y. lets: wft_type. rewrite* subst_t_open_t_var. apply_ih_map_bind* H0. apply* wfe_term. - case_var*. + apply_empty* (proj2 wf_weaken). + destruct (binds_concat_inv b) as [?|[? ?]]. apply (@wfe_var (subst_t Z u U)). apply~ binds_concat_right. destruct (binds_push_inv H3) as [[? ?]|[? ?]]. subst. false~. applys wfe_var. apply* binds_concat_left. - apply_fresh* wfe_abs as y. lets: (proj2 wf_lc). rewrite* subst_e_open_e_var. apply_ih_map_bind* H0. Qed. Lemma wft_subst : forall F Q E Z u T, wft (E & Z ~ Q & F) T -> (value u \/ exists x, trm_fvar x = u) -> wfe E u -> ok (E & map (subst_t Z u) F) -> wft (E & map (subst_t Z u) F) (subst_t Z u T). Proof. intros. eapply (proj1 wf_subst); eauto. Qed. Lemma wft_subst1 : forall F Q Z u T, wft (Z ~ Q & F) T -> (value u \/ exists x, trm_fvar x = u) -> wfe empty u -> ok (map (subst_t Z u) F) -> wft (map (subst_t Z u) F) (subst_t Z u T). Proof. intros. rewrite <- (@concat_empty_l typ (map (subst_t Z u) F)). apply* wft_subst. rewrite concat_empty_l. eassumption. rewrite concat_empty_l. eassumption. Qed. Lemma wft_subst_empty : forall Q Z u T, wft (Z ~ Q) T -> (value u \/ exists x, trm_fvar x = u) -> wfe empty u -> wft empty (subst_t Z u T). Proof. intros. assert (empty & map (subst_t Z u) empty = empty) as A. { rewrite map_empty. rewrite concat_empty_l. reflexivity. } rewrite <- A. eapply wft_subst; eauto. rewrite concat_empty_l. rewrite concat_empty_r. eauto. rewrite A. eauto. Qed. (** Through type reduction *) Lemma wft_open : forall E u T1 T2, ok E -> wft E (typ_all T1 T2) -> (value u \/ exists x, trm_fvar x = u) -> wfe E u -> wft E (open_t T2 u). Proof. introv Ok WA VU WU. inversions WA. pick_fresh X. auto* wft_type. rewrite* (@subst_t_intro X). lets K: (@wft_subst empty). specializes_vars K. clean_empty K. apply* K. apply* wfe_term. Qed. (* ********************************************************************** *) (** * Relations between well-formed environment and types well-formed in environments *) (** If an environment is well-formed, then it does not contain duplicated keys. *) Lemma ok_from_okt : forall E, okt E -> ok E. Proof. induction 1; auto. Qed. Hint Extern 1 (ok _) => apply ok_from_okt. (** Extraction from an assumption in a well-formed environments *) Lemma wft_from_env_has : forall x U E, okt E -> binds x U E -> wft E U. Proof. induction E using env_ind; intros Ok B. false* binds_empty_inv. inversions Ok. false (empty_push_inv H0). destruct (eq_push_inv H) as [? [? ?]]. subst. clear H. destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst. apply_empty* wft_weaken. apply_empty* wft_weaken. Qed. (** Extraction from a well-formed environment *) Lemma wft_from_okt : forall x T E, okt (E & x ~ T) -> wft E T. Proof. intros. inversions* H. false (empty_push_inv H1). destruct (eq_push_inv H0) as [? [? ?]]. subst. assumption. Qed. (** Automation *) Lemma wft_weaken_right : forall T E F, wft E T -> ok (E & F) -> wft (E & F) T. Proof. intros. apply_empty* wft_weaken. Qed. Hint Resolve wft_weaken_right. Hint Resolve wft_from_okt. Hint Immediate wft_from_env_has. Hint Resolve wft_subst. (* ********************************************************************** *) (** ** Properties of well-formedness of an environment *) (** Inversion lemma *) Lemma okt_push_inv : forall E x T, okt (E & x ~ T) -> okt E /\ wft E T /\ x # E. Proof. introv O. inverts O. false* empty_push_inv. lets (?&M&?): (eq_push_inv H). subst. eauto. Qed. Lemma okt_push_type : forall E x T, okt (E & x ~ T) -> type T. Proof. intros. applys wft_type. forwards*: okt_push_inv. Qed. Hint Immediate okt_push_type. (** Through narrowing *) Lemma okt_narrow : forall V (E F:env) U x, okt (E & x ~ V & F) -> wft E U -> okt (E & x ~ U & F). Proof. introv O W. induction F using env_ind. rewrite concat_empty_r in *. lets*: (okt_push_inv O). rewrite concat_assoc in *. lets (?&?&?): (okt_push_inv O). applys~ okt_push. applys* wft_narrow. Qed. (** Through substitution *) Lemma okt_subst : forall Q Z u (E F:env), okt (E & Z ~ Q & F) -> (value u \/ exists x, trm_fvar x = u) -> wfe E u -> okt (E & map (subst_t Z u) F). Proof. introv O V W. induction F using env_ind. rewrite map_empty. rewrite concat_empty_r in *. lets*: (okt_push_inv O). rewrite map_push. rewrite concat_assoc in *. lets*: (okt_push_inv O). apply okt_push. apply* IHF. apply* wft_subst. auto*. Qed. Lemma okt_subst1 : forall Q Z u (F:env), okt (Z ~ Q & F) -> (value u \/ exists x, trm_fvar x = u) -> wfe empty u -> okt (map (subst_t Z u) F). Proof. intros. rewrite <- concat_empty_l. apply* okt_subst. rewrite concat_empty_l. eassumption. Qed. (** Automation *) Hint Resolve okt_narrow okt_subst wft_weaken. (* ********************************************************************** *) (** ** Environment is unchanged by substitution from a fresh name *) Ltac destruct_notin_union := match goal with | H: _ \notin _ \u _ |- _ => eapply notin_union in H; destruct H end. Lemma notin_fv_open_rec : (forall T k y x, x \notin fv_t (open_t_rec k (trm_fvar y) T) -> x \notin fv_t T) /\ (forall e k y x, x \notin fv_e (open_e_rec k (trm_fvar y) e) -> x \notin fv_e e). Proof. apply typ_trm_mutind; simpl; intros; repeat destruct_notin_union; eauto using notin_union_l. Qed. Lemma notin_fv_t_open : forall y x T, x \notin fv_t (T open_t_var y) -> x \notin fv_t T. Proof. unfold open_t. intros. apply* (proj1 notin_fv_open_rec). Qed. Lemma notin_fv_e_open : forall y x e, x \notin fv_e (e open_e_var y) -> x \notin fv_e e. Proof. unfold open_e. intros. apply* (proj2 notin_fv_open_rec). Qed. Lemma notin_fv_wf_rec : (forall E T, wft E T -> forall x, x # E -> x \notin fv_t T) /\ (forall E e, wfe E e -> forall x, x # E -> x \notin fv_e e). Proof. apply wf_mutind; intros; simpl; eauto. notin_simpl; auto. pick_fresh Y. apply* (@notin_fv_t_open Y). rewrite notin_singleton. intro. subst. applys binds_fresh_inv b H. notin_simpl; auto. pick_fresh y. apply* (@notin_fv_e_open y). Qed. Lemma notin_fv_wf : forall E x T, wft E T -> x # E -> x \notin fv_t T. Proof. intros. eapply (proj1 notin_fv_wf_rec); eauto. Qed. Lemma map_subst_id : forall G z u, okt G -> z # G -> G = map (subst_t z u) G. Proof. induction 1; intros Fr; autorewrite with rew_env_map; simpl. auto. rewrite* <- IHokt. rewrite* (proj1 subst_fresh). apply* notin_fv_wf. Qed. (* ********************************************************************** *) (** ** Regularity of relations *) (** The subtyping relation is restricted to well-formed objects. *) Lemma sub_has_regular : (forall E S T, sub E S T -> okt E /\ wft E S /\ wft E T) /\ (forall E p T, has E p T -> okt E /\ wft E (typ_sel p) /\ wft E T). Proof. apply sub_has_mutind; intros; try auto*. splits*. destruct H as [? [? A]]. inversion A; subst. assumption. splits*. destruct H as [? [? A]]. inversion A; subst. assumption. split. auto*. split; apply_fresh* wft_all as Y; forwards~: (H0 Y); apply_empty* (@wft_narrow T1). splits*. apply wft_sel. left. apply value_mem. apply* wfe_term. apply* wfe_mem. splits*. apply wft_sel. left. apply value_abs. apply* wfe_term. assumption. Qed. Lemma sub_regular : forall E S T, sub E S T -> okt E /\ wft E S /\ wft E T. Proof. intros. apply* (proj1 sub_has_regular). Qed. Lemma has_regular : forall E p T, has E p T -> okt E /\ wft E (typ_sel p) /\ wft E T. Proof. intros. apply* (proj2 sub_has_regular). Qed. Lemma has_regular_e : forall E p T, has E p T -> (value p \/ (exists x, trm_fvar x = p)) /\ wfe E p. Proof. intros. apply has_regular in H. destruct H as [? [A ?]]. inversion A; subst. split; assumption. Qed. (** The typing relation is restricted to well-formed objects. *) Lemma typing_regular : forall E e T, typing E e T -> okt E /\ wfe E e /\ wft E T. Proof. induction 1. splits*. splits. pick_fresh y. specializes H0 y. destructs~ H0. forwards*: okt_push_inv. apply_fresh* wfe_abs as y. pick_fresh y. forwards~ K: (H0 y). destructs K. forwards*: okt_push_inv. forwards~ K: (H0 y). destructs K. auto. apply_fresh* wft_all as Y. pick_fresh y. forwards~ K: (H0 y). destructs K. forwards*: okt_push_inv. forwards~ K: (H0 Y). destructs K. forwards*: okt_push_inv. splits*. splits*. splits*. splits*. destructs~ (sub_regular H0). Qed. (** The value relation is restricted to well-formed objects. *) Lemma value_regular : forall t, value t -> term t. Proof. induction 1; auto*. Qed. (** The reduction relation is restricted to well-formed objects. *) Lemma red_regular : forall t t', red t t' -> term t /\ term t'. Proof. induction 1; split; auto* value_regular. inversions H. pick_fresh y. rewrite* (@subst_e_intro y). Qed. (** Automation *) Hint Extern 1 (okt ?E) => match goal with | H: sub _ _ _ |- _ => apply (proj31 (sub_regular H)) | H: has _ _ _ |- _ => apply (proj31 (has_regular H)) | H: typing _ _ _ |- _ => apply (proj31 (typing_regular H)) end. Hint Extern 1 (wft ?E ?T) => match goal with | H: typing E _ T |- _ => apply (proj33 (typing_regular H)) | H: sub E T _ |- _ => apply (proj32 (sub_regular H)) | H: sub E _ T |- _ => apply (proj33 (sub_regular H)) | H: has E _ T |- _ => apply (proj33 (has_regular H)) end. Hint Extern 1 (wfe ?E ?e) => match goal with | H: typing E e _ |- _ => apply (proj32 (typing_regular H)) | H: has E e _ |- _ => apply (proj2 (has_regular_e H)) end. Hint Extern 1 (type ?T) => let go E := apply (@wft_type E); auto in match goal with | H: typing ?E _ T |- _ => go E | H: sub ?E T _ |- _ => go E | H: sub ?E _ T |- _ => go E end. Hint Extern 1 (term ?e) => match goal with | H: typing _ ?e _ |- _ => apply (wfe_term (proj32 (typing_regular H))) | H: red ?e _ |- _ => apply (proj1 (red_regular H)) | H: red _ ?e |- _ => apply (proj2 (red_regular H)) end. (*************************************************************************** * Preservation and Progress for System-F with Subtyping - Proofs * ***************************************************************************) (** In parentheses are given the label of the corresponding lemma in the description of the POPLMark Challenge. *) (* ********************************************************************** *) (** * Properties of Subtyping *) (* ********************************************************************** *) (** Reflexivity (1) *) Lemma sub_reflexivity : forall E T, okt E -> wft E T -> sub E T T . Proof. introv Ok WI. lets W: (wft_type WI). gen E. induction W; intros; inversions WI; eauto. destruct b. apply* sub_mem_true. apply* sub_mem_false. apply_fresh* sub_all as Y. Qed. (* ********************************************************************** *) (** Weakening (2) *) Lemma sub_has_weakening : (forall E0 S T, sub E0 S T -> forall E F G, E0 = E & G -> okt (E & F & G) -> sub (E & F & G) S T) /\ (forall E0 p T, has E0 p T -> forall E F G, E0 = E & G -> okt (E & F & G) -> has (E & F & G) p T). Proof. apply sub_has_mutind; intros; subst; auto. apply* sub_sel1. apply* sub_sel2. apply* sub_mem_false. apply* sub_mem_true. apply_fresh* sub_all as Y. apply_ih_bind* H0. apply* sub_trans. apply* has_var. apply* binds_weaken. apply* has_mem. apply* has_abs. apply* wfe_weaken. apply* has_sub. Qed. Lemma sub_weakening : forall E F G S T, sub (E & G) S T -> okt (E & F & G) -> sub (E & F & G) S T. Proof. intros. apply* (proj1 sub_has_weakening). Qed. Lemma sub_weakening1 : forall E F G S T, sub E S T -> okt (E & F & G) -> sub (E & F & G) S T. Proof. intros. assert (E & F & G = E & (F & G) & empty) as A. { rewrite concat_empty_r. rewrite concat_assoc. reflexivity. } rewrite A. apply* sub_weakening. rewrite concat_empty_r. assumption. rewrite <- A. assumption. Qed. Lemma sub_weakening_empty : forall E S T, sub empty S T -> okt E -> sub E S T. Proof. intros. assert (empty & E & empty = E) as A. { rewrite concat_empty_r. rewrite concat_empty_l. reflexivity. } rewrite <- A. apply* sub_weakening. rewrite concat_empty_r. assumption. rewrite A. assumption. Qed. Lemma has_weakening : forall E F G p T, has (E & G) p T -> okt (E & F & G) -> has (E & F & G) p T. Proof. intros. apply* (proj2 sub_has_weakening). Qed. Lemma has_weakening1 : forall E F G p T, has E p T -> okt (E & F & G) -> has (E & F & G) p T. Proof. intros. assert (E & F & G = E & (F & G) & empty) as A. { rewrite concat_empty_r. rewrite concat_assoc. reflexivity. } rewrite A. apply* has_weakening. rewrite concat_empty_r. assumption. rewrite <- A. assumption. Qed. Lemma has_weakening_empty : forall E p T, has empty p T -> okt E -> has E p T. Proof. intros. assert (empty & E & empty = E) as A. { rewrite concat_empty_r. rewrite concat_empty_l. reflexivity. } rewrite <- A. apply* has_weakening. rewrite concat_empty_r. assumption. rewrite A. assumption. Qed. (* ********************************************************************** *) (** Narrowing and transitivity (3) *) Section NarrowTrans. Hint Resolve wft_narrow. Lemma sub_has_narrowing_aux : (forall E0 S T, sub E0 S T -> forall Q E F z P, E0 = (E & z ~ Q & F) -> sub E P Q -> sub (E & z ~ P & F) S T) /\ (forall E0 p T, has E0 p T -> forall Q E F z P, E0 = (E & z ~ Q & F) -> sub E P Q -> has (E & z ~ P & F) p T). Proof. Hint Constructors sub has. apply sub_has_mutind; intros; subst; eauto. apply* sub_top. apply* sub_refl_sel. apply_fresh* sub_all as Y. apply_ih_bind H0; eauto. tests EQ: (x = z). lets M: (@okt_narrow Q). apply binds_middle_eq_inv in b. subst. eapply has_sub. eapply has_var. apply* M. apply binds_middle_eq. eapply ok_from_okt in o. eapply ok_middle_inv in o. destruct o as [o1 o2]. apply o2. eapply sub_weakening1; eauto. auto*. eapply has_var; eauto. binds_cases b; auto. apply* has_mem. apply* has_abs. eapply (proj2 wf_narrow); eauto. Qed. Lemma sub_narrowing : forall Q E F Z P S T, sub E P Q -> sub (E & Z ~ Q & F) S T -> sub (E & Z ~ P & F) S T. Proof. intros. apply* (proj1 sub_has_narrowing_aux). Qed. Lemma sub_narrowing_empty : forall Q Z P S T, sub empty P Q -> sub (Z ~ Q) S T -> sub (Z ~ P) S T. Proof. intros. rewrite <- (concat_empty_r (Z ~ P)). rewrite <- (concat_empty_l (Z ~ P)). eapply sub_narrowing; eauto. rewrite concat_empty_r. rewrite concat_empty_l. auto. Qed. End NarrowTrans. (* ********************************************************************** *) (** Substitution preserves subtyping (10) *) Lemma has_value_var : forall E u T, has E u T -> (value u \/ exists x, trm_fvar x = u). Proof. intros. apply has_regular_e in H. destruct H as [A ?]. apply A. Qed. Hint Resolve has_value_var. Lemma var_typing_has: forall E x Q, typing E (trm_fvar x) Q -> has E (trm_fvar x) Q. Proof. introv H. remember (trm_fvar x) as t. gen Heqt. induction H; intros; subst; try solve [inversion Heqt]. - inversion Heqt. subst. apply* has_var. - eapply has_sub. eapply IHtyping; eauto. assumption. Qed. Lemma val_typing_has: forall E u Q, value u -> typing E u Q -> has E u Q. Proof. introv Hv H. lets R: (typing_regular H). induction H; intros; subst; try solve [inversion Hv]. - apply* has_abs. - apply* has_mem. - apply* has_sub. Qed. Lemma sub_has_through_subst : (forall E0 S T, sub E0 S T -> forall Q E F Z u, E0 = (E & Z ~ Q & F) -> (value u \/ exists x, trm_fvar x = u) -> typing E u Q -> sub (E & map (subst_t Z u) F) (subst_t Z u S) (subst_t Z u T)) /\ (forall E0 p T, has E0 p T -> forall Q E F Z u, E0 = (E & Z ~ Q & F) -> (value u \/ exists x, trm_fvar x = u) -> typing E u Q -> has (E & map (subst_t Z u) F) (subst_e Z u p) (subst_t Z u T)). Proof. apply sub_has_mutind; intros; subst; simpl. - apply* sub_top. - simpl. apply* sub_refl_sel. assert (typ_sel (subst_e Z u t) = subst_t Z u (typ_sel t)) as A by auto. rewrite A. auto*. - apply* sub_sel1. - apply* sub_sel2. - apply* sub_mem_false. - apply* sub_mem_true. - apply_fresh* sub_all as X. rewrite* subst_t_open_t_var. rewrite* subst_t_open_t_var. apply_ih_map_bind* H0. - apply* sub_trans. - case_var. + apply binds_middle_eq_inv in b; eauto. subst. destruct H0 as [H0 | [x H0]]. * apply_empty* has_weakening1. rewrite (proj1 subst_fresh). apply* val_typing_has. apply* (@notin_fv_wf E0). * subst. rewrite (proj1 subst_fresh). apply_empty* has_weakening1. apply var_typing_has. assumption. apply* (@notin_fv_wf E0). + destruct (binds_concat_inv b) as [?|[? ?]]. * eapply has_var. auto*. apply binds_concat_right. apply binds_map. eassumption. * applys has_var. apply* okt_subst. assert (T = subst_t Z u T) as B. { rewrite (proj1 subst_fresh). reflexivity. apply* (@notin_fv_wf E0). apply* wft_from_env_has. apply binds_concat_left_inv in H2. eassumption. auto*. } apply binds_concat_left. rewrite <- B. apply binds_concat_left_inv in H2. apply H2. auto*. auto*. - apply* has_mem. - apply* has_abs. assert (trm_abs (subst_t Z u V) (subst_e Z u e) = subst_e Z u (trm_abs V e)) as A by solve [simpl; reflexivity]. rewrite A. eapply (proj2 wf_subst); eauto. assert (typ_all (subst_t Z u V) (subst_t Z u T) = subst_t Z u (typ_all V T)) as B by solve [simpl; reflexivity]. rewrite B. apply* wft_subst. - apply* has_sub. Qed. (* ********************************************************************** *) (** * Properties of Typing *) (* ********************************************************************** *) (** Weakening (5) *) Lemma typing_weakening : forall E F G e T, typing (E & G) e T -> okt (E & F & G) -> typing (E & F & G) e T. Proof. introv Typ. gen F. inductions Typ; introv Ok. apply* typing_var. apply* binds_weaken. apply_fresh* typing_abs as x. forwards~ K: (H x). apply_ih_bind (H0 x); eauto. apply* typing_mem. apply* typing_app. eapply typing_appvar; eauto. eapply (proj2 sub_has_weakening); eauto. apply* typing_sub. apply* sub_weakening. Qed. (************************************************************************ *) (** Preservation by Type Narrowing (7) *) Lemma typing_narrowing : forall Q E F X P e T, sub E P Q -> typing (E & X ~ Q & F) e T -> typing (E & X ~ P & F) e T. Proof. introv PsubQ Typ. gen_eq E': (E & X ~ Q & F). gen F. inductions Typ; introv EQ; subst; simpl. - binds_cases H0. + apply* typing_var. + subst. apply* typing_sub. apply* sub_weakening1. + apply* typing_var. - apply_fresh* typing_abs as y. apply_ih_bind* H0. - apply* typing_mem. apply* wft_narrow. - apply* typing_app. apply* wft_narrow. - apply* typing_appvar. apply* (proj2 sub_has_narrowing_aux). apply* wft_narrow. - apply* typing_sub. apply* (@sub_narrowing Q). Qed. Lemma typing_narrowing_empty : forall Q X P e T, sub empty P Q -> typing (X ~ Q) e T -> typing (X ~ P) e T. Proof. intros. rewrite <- (concat_empty_r (X ~ P)). rewrite <- (concat_empty_l (X ~ P)). eapply typing_narrowing; eauto. rewrite concat_empty_r. rewrite concat_empty_l. auto. Qed. (************************************************************************ *) (** Preservation by Substitution (8) *) Lemma typing_through_subst : forall U E F z T e u, typing (E & z ~ U & F) e T -> (value u \/ exists x, trm_fvar x = u) -> typing E u U -> typing (E & (map (subst_t z u) F)) (subst_e z u e) (subst_t z u T). Proof. introv TypT Hu TypU. inductions TypT; introv; subst; simpl. - case_var. + binds_get H0. rewrite (proj1 subst_fresh). apply_empty typing_weakening. assumption. apply* okt_subst. apply* (@notin_fv_wf E). + binds_cases H0. rewrite (proj1 subst_fresh). eapply typing_var; eauto. apply (@notin_fv_wf E). eapply wft_from_env_has. auto*. eapply B0. auto*. apply* typing_var. - apply_fresh* typing_abs as y. rewrite* subst_e_open_e_var. rewrite* subst_t_open_t_var. rewrite <- concat_assoc_map_push. eapply H0; eauto. rewrite concat_assoc. auto. - apply* typing_mem. - eapply typing_app. eapply IHTypT1; eauto. eapply IHTypT2; eauto. apply* wft_subst. - eapply typing_appvar. eapply IHTypT1; eauto. eapply IHTypT2; eauto. apply* (proj2 sub_has_through_subst). eapply subst_t_open_t. auto*. apply* wft_subst. - eapply typing_sub. eapply IHTypT; eauto. eapply (proj1 sub_has_through_subst); eauto. Qed. (* ********************************************************************** *) (** * Preservation *) (* ********************************************************************** *) (** Inversions for Typing (13) *) Inductive psub : typ -> typ -> Prop := | psub_top : forall S, wft empty S -> psub S typ_top | psub_refl_sel : forall t, wft empty (typ_sel t) -> psub (typ_sel t) (typ_sel t) | psub_sel1 : forall U, wft empty U -> psub (typ_sel (trm_mem U)) U | psub_sel2 : forall S, wft empty S -> psub S (typ_sel (trm_mem S)) | psub_mem_false : forall b1 T1 T2, psub T1 T2 -> psub (typ_mem b1 T1) (typ_mem false T2) | psub_mem_true : forall T1 T2, psub T1 T2 -> psub T2 T1 -> psub (typ_mem true T1) (typ_mem true T2) | psub_all : forall L S1 S2 T1 T2, psub T1 S1 -> (forall x, x \notin L -> sub (x ~ T1) (S2 open_t_var x) (T2 open_t_var x)) -> psub (typ_all S1 S2) (typ_all T1 T2) | psub_trans : forall S T U, psub S T -> psub T U -> psub S U . Lemma has_empty_value: forall p T, has empty p T -> value p. Proof. intros. apply has_regular_e in H. destruct H as [[HV | [x Eq]] Hwf]. - assumption. - subst. inversion Hwf; subst. false. apply* binds_empty_inv. Qed. Hint Constructors psub. Lemma psub_sub: forall S T, psub S T -> sub empty S T. Proof. intros. induction H; eauto. - apply* sub_sel1. apply* has_mem. - apply* sub_sel2. apply* has_mem. - apply* sub_mem_false. - apply* sub_mem_true. - apply_fresh* sub_all as y. rewrite concat_empty_l. auto*. - eapply sub_trans; eauto. Qed. Inductive possible_types : nat -> trm -> typ -> Prop := | pt_top : forall n v, value v -> wfe empty v -> possible_types n v typ_top | pt_mem_true : forall n T T', psub T T' -> psub T' T -> possible_types n (trm_mem T) (typ_mem true T') | pt_mem_false : forall n T U, psub T U -> possible_types n (trm_mem T) (typ_mem false U) | pt_all : forall L n V V' e1 T1 T1', (forall X, X \notin L -> typing (X ~ V) (e1 open_e_var X) (T1 open_t_var X)) -> psub V' V -> (forall X, X \notin L -> sub (X ~ V') (T1 open_t_var X) (T1' open_t_var X)) -> possible_types (S n) (trm_abs V e1) (typ_all V' T1') | pt_all_shallow : forall V V' e1 T1', wfe empty (trm_abs V e1) -> wft empty (typ_all V' T1') -> possible_types 0 (trm_abs V e1) (typ_all V' T1') | pt_sel : forall n v S, possible_types n v S -> possible_types n v (typ_sel (trm_mem S)) . Lemma possible_types_value : forall n p T, possible_types n p T -> value p. Proof. introv Hpt. induction Hpt; eauto. - apply psub_sub in H. auto*. - apply psub_sub in H. auto*. - apply value_abs. apply_fresh* term_abs as y. apply psub_sub in H0. auto*. assert (y \notin L) as Fr by auto. specialize (H y Fr). apply typing_regular in H. destruct H as [? [A ?]]. apply* wfe_term. - apply value_abs. apply* wfe_term. Qed. Lemma possible_types_wfe : forall n p T, possible_types n p T -> wfe empty p. Proof. introv Hpt. induction Hpt; eauto. - apply psub_sub in H. auto*. - apply psub_sub in H. auto*. - apply_fresh* wfe_abs as y. apply psub_sub in H0. auto*. assert (y \notin L) as FrL by auto. specialize (H y FrL). apply typing_regular in H. destruct H as [? [A ?]]. rewrite concat_empty_l. assumption. Qed. Lemma possible_types_wft : forall n p T, possible_types n p T -> wft empty T. Proof. introv Hpt. induction Hpt; eauto. - apply psub_sub in H. auto*. - apply psub_sub in H. auto*. - apply_fresh* wft_all as y. apply psub_sub in H0. auto*. assert (y \notin L) as FrL by auto. specialize (H1 y FrL). apply sub_regular in H1. destruct H1 as [? [? A]]. rewrite concat_empty_l. assumption. - apply wft_sel. left. apply value_mem. apply* wfe_term. apply* wfe_mem. Qed. Lemma has_empty_var_false: forall x T, has empty (trm_fvar x) T -> False. Proof. intros. remember (trm_fvar x) as p. generalize dependent x. remember empty as E. gen HeqE. induction H; intros; subst; eauto. - apply* binds_empty_inv. - inversion Heqp. - inversion Heqp. Qed. Lemma possible_types_closure_psub : forall n v T U, possible_types n v T -> psub T U -> possible_types n v U. Proof. introv Hpt Hsub. generalize dependent v. induction Hsub; intros; subst; eauto. - apply pt_top. apply* possible_types_value. apply* possible_types_wfe. - inversion Hpt; subst. assumption. - apply* pt_sel. - inversion Hpt; subst. * apply pt_mem_false. eapply psub_trans; eauto. * apply pt_mem_false. eapply psub_trans; eauto. - inversion Hpt; subst. apply* pt_mem_true. - inversion Hpt; subst. apply_fresh* pt_all as y. eapply sub_trans. eapply sub_narrowing_empty. eapply psub_sub. eassumption. auto*. auto*. apply pt_all_shallow; eauto. apply_fresh* wft_all as y. apply psub_sub in Hsub. auto*. rewrite concat_empty_l. assert (y \notin L) as Fr by auto. specialize (H y Fr). auto*. Qed. Lemma psub_reflexivity : forall T, wft empty T -> psub T T . Proof. introv WI. lets W: (wft_type WI). remember empty as E. gen E. induction W; intros; inversions WI; eauto. destruct b. apply* psub_mem_true. apply* psub_mem_false. apply_fresh* psub_all as y. assert (y \notin L0)as Fr0 by auto. specialize (H5 y Fr0). rewrite concat_empty_l in H5. apply* sub_reflexivity. rewrite <- concat_empty_l. apply* okt_push. Grab Existential Variables. pick_fresh y. apply y. Qed. Lemma sub_psub_aux: (forall E S T, sub E S T -> E = empty -> psub S T) /\ (forall E p T, has E p T -> E = empty -> possible_types 0 p T). Proof. apply sub_has_mutind; intros; subst; eauto. - specialize (H eq_refl). inversion H; subst. eapply psub_trans. eapply psub_sel1. apply psub_sub in H3. auto*. assumption. - specialize (H eq_refl). inversion H; subst. eapply psub_trans. eassumption. eapply psub_sel2. apply psub_sub in H1. auto*. - apply_fresh* psub_all as y. rewrite <- (@concat_empty_l typ (y ~ T1)). auto*. - false. apply* binds_empty_inv. - destruct b. apply pt_mem_true; eauto. apply pt_mem_false; eauto. - apply* pt_all_shallow. - eapply possible_types_closure_psub; eauto. Qed. Lemma sub_psub: forall S T, sub empty S T -> psub S T. Proof. intros. apply* (proj1 sub_psub_aux). Qed. Lemma possible_types_closure : forall n v T U, possible_types n v T -> sub empty T U -> possible_types n v U. Proof. intros. eapply possible_types_closure_psub; eauto. apply* sub_psub. Qed. Lemma possible_types_typing : forall v T, typing empty v T -> value v -> possible_types 1 v T. Proof. introv Ht Hv. remember Ht as Hc. clear HeqHc. remember empty as E. generalize HeqE. generalize Hc. induction Ht; intros; subst; eauto; try solve [inversion Hv]. - eapply typing_regular in Hc. destruct Hc as [? [? Hc]]. inversion Hc; subst. apply_fresh pt_all as Y. assert (Y \notin L) as Fr by eauto. specialize (H Y Fr). rewrite concat_empty_l in H. eapply H. eapply psub_reflexivity; eauto. eapply sub_reflexivity; eauto. rewrite <- concat_empty_l. eauto. assert (Y \notin L0) as Fr by eauto. specialize (H7 Y Fr). rewrite concat_empty_l in H7. eapply H7. - apply pt_mem_true. apply* psub_reflexivity. apply* psub_reflexivity. - eapply possible_types_closure; eauto. Qed. Lemma typing_inv_abs : forall S1 e1 T, typing empty (trm_abs S1 e1) T -> forall U1 U2, sub empty T (typ_all U1 U2) -> sub empty U1 S1 /\ exists S2, exists L, forall x, x \notin L -> typing (x ~ S1) (e1 open_e_var x) (S2 open_t_var x) /\ sub (x ~ U1) (S2 open_t_var x) (U2 open_t_var x). Proof. introv Typ Hsub. apply possible_types_typing in Typ; eauto. assert (possible_types 1 (trm_abs S1 e1) (typ_all U1 U2)) as Hc. { eapply possible_types_closure; eauto. } inversion Hc; subst. repeat eexists; eauto. apply* psub_sub. Qed. (** Canonical Forms (14) *) Lemma canonical_form_abs : forall t U1 U2, value t -> typing empty t (typ_all U1 U2) -> exists V, exists e1, t = trm_abs V e1. Proof. introv Val Typ. eapply possible_types_typing in Typ; eauto. inversion Typ; subst; eauto. Qed. Lemma canonical_form_mem : forall t b T, value t -> typing empty t (typ_mem b T) -> exists V, t = trm_mem V. Proof. introv Val Typ. eapply possible_types_typing in Typ; eauto. inversion Typ; subst; eauto. Qed. Lemma typing_through_subst1 : forall V y v e T, typing (y ~ V) e T -> value v -> typing empty v V -> typing empty (subst_e y v e) (subst_t y v T). Proof. intros. assert (empty & map (subst_t y v) empty = empty) as A. { rewrite concat_empty_l. rewrite map_empty. reflexivity. } rewrite <- A. eapply typing_through_subst. rewrite concat_empty_l. rewrite concat_empty_r. eauto. left. assumption. assumption. Qed. (* ********************************************************************** *) (** Preservation Result (20) *) Lemma value_red_contra: forall e e', value e -> red e e' -> False. Proof. introv Hv Hr. inversion Hv; subst; inversion Hr; subst; eauto. Qed. Lemma preservation_result : preservation. Proof. introv Typ. gen_eq E: (@empty typ). gen e'. induction Typ; introv QEQ; introv Red; try solve [inversion Typ; congruence]; try solve [ inversion Red ]. - (* case: app *) inversions Red; try solve [ apply* typing_app ]. destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]]. apply* sub_reflexivity. pick_fresh X. forwards~ K: (P2 X). destruct K. rewrite* (@subst_e_intro X). erewrite <- (proj1 subst_fresh). eapply typing_through_subst1. eapply typing_sub. eapply typing_narrowing_empty. eapply P1. eassumption. rewrite <- (@open_t_var_type X). assert (X \notin L) as FrL by auto. specialize (P2 X FrL). destruct P2 as [P2t P2s]. eassumption. apply* wft_type. assumption. assumption. auto*. - (* case: appvar *) inversions Red; try solve [ apply* typing_appvar ]. lets HV2: (has_empty_value H). false. eapply value_red_contra in HV2; eauto. destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]]. apply* sub_reflexivity. pick_fresh X. forwards~ K: (P2 X). destruct K. rewrite* (@subst_t_intro X). rewrite* (@subst_e_intro X). eapply typing_through_subst1. eapply typing_sub. eapply typing_narrowing_empty. eapply P1. eassumption. assert (X \notin L) as FrL by auto. specialize (P2 X FrL). destruct P2 as [P2t P2s]. eassumption. assumption. assumption. - (* case sub *) apply* typing_sub. Qed. (* ********************************************************************** *) (** * Progress *) (* ********************************************************************** *) (* ********************************************************************** *) (** Progress Result (16) *) Lemma progress_result : progress. Proof. introv Typ. gen_eq E: (@empty typ). lets Typ': Typ. induction Typ; intros EQ; subst. - (* case: var *) false* binds_empty_inv. - (* case: abs *) left*. - (* case: mem *) left*. - (* case: app *) right. destruct* IHTyp1 as [Val1 | [e1' Rede1']]. destruct* IHTyp2 as [Val2 | [e2' Rede2']]. destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]]. subst. exists* (open_e e3 e2). - (* case: appvar *) right. destruct* IHTyp1 as [Val1 | [e1' Rede1']]. destruct* IHTyp2 as [Val2 | [e2' Rede2']]. destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]]. subst. exists* (open_e e3 e2). - (* case: sub *) auto*. Qed.