Proofs about substitutions that match bounds |
Require
Import
List.
Require
Import
Arith.
Require
Import
Wf_nat.
Require
Import
MatchCompNat.
Require
Import
Util.
Require
Syntax
.
Module
SetProgram(My_Program: Syntax.Program).
Import
My_Program.
Require
Progress_proofs.
Module
My_Progress_proofs := Progress_proofs.SetProgram(My_Program).
Import
My_Progress_proofs.
Import
My_TransitivityElimination_proofs.
Import
My_Normalization_proofs.
Import
My_Subtyping_proofs.
Import
My_Typing_proofs.
Import
My_Confluence.
Import
My_Auxiliary_proofs.
Import
My_Substitutions_proofs.
Import
My_Binders_proofs.
Import
My_Semantics.
Import
My_WellFormedness.
Import
My_Typing.
Import
My_Auxiliary.
Import
My_Substitutions.
Import
My_Binders.
Lemma
Lifting_preserves_removeBounds:
forall (t t': TypeS) (k n: nat),
(removeBounds t t') ->
(removeBounds (lift_at_depth_in_type t n k) t')
.
Lemma
removeBounds_invariant_by_lifting:
forall (t t': TypeS) (k n: nat),
(removeBounds t t') ->
(lift_at_depth_in_type t' n k) = t'
.
Lemma
lift_of_some_inversion:
forall (t N: TypeS) (n k: nat),
(lift_at_depth_in_type t n k) = (Type_some N) ->
exists N0: TypeS,
t = (Type_some N0) /\
N = (lift_at_depth_in_type N0 n k)
.
Lemma
lift_of_cons_inversion:
forall (t u us: TypeS) (n k: nat),
(lift_at_depth_in_type t n k) = (Type_cons u us) ->
exists u0: TypeS, exists us0: TypeS,
t = (Type_cons u0 us0) /\
u = (lift_at_depth_in_type u0 n k) /\
us = (lift_at_depth_in_type us0 n k)
.
Lemma
TypeS_at_of_lift_inversion:
forall (t u: TypeS) (i n k: nat),
(TypeS_at (lift_at_depth_in_type t n k) i u) ->
exists u0: TypeS,
(TypeS_at t i u0) /\
u = (lift_at_depth_in_type u0 n k)
.
Lemma
Weakening_of_param_satisfaction:
forall (D1 D2 D3: TypeEnv) (K P: TypeS),
(ParamSat (D1 ++ D3) K P) ->
(ParamSat (D1 ++ D2 ++ (lift_in_typeEnv D3 (length D2)))
(lift_at_depth_in_type K (length D2) (length D3))
(lift_at_depth_in_type P (length D2) (length D3)))
.
Lemma
Weakening_of_satisfaction:
forall (D1 D2 D3: TypeEnv) (R Pi: TypeS),
(SectionSat (D1 ++ D3) R Pi) ->
(SectionSat (D1 ++ D2 ++ (lift_in_typeEnv D3 (length D2)))
(lift_at_depth_in_type R (length D2) (length D3))
(lift_at_depth_in_type Pi (length D2) (length D3)))
.
Lemma
Weakening_of_satisfaction_by_the_right:
forall (D D': TypeEnv) (R Pi: TypeS),
(SectionSat D R Pi) ->
(SectionSat (D ++ D')
(lift_in_type R (length D'))
(lift_in_type Pi (length D')))
.
Fixpoint
size_of_kind (k: KindS): nat :=
match k with
| (Kind_tuple k1) => (size_of_kind k1) + 1
| (Kind_constr k1) => (size_of_kind k1) + 1
| Kind_nil => 0
| (Kind_cons k1 k2) => (size_of_kind k1) + (size_of_kind k2) + 1
end
.
Lemma
typeSubst_of_class_type:
forall (C: ClassSym) (R R': TypeS) (n: nat),
(typeSubst_in_type (Class_type C R) n R') =
(Class_type C (typeSubst_in_type R n R'))
.
Lemma
Substitution_in_closed_type_aux:
forall (D: TypeEnv) (t R: TypeS) (c: TypeC) (k: nat),
(Type_WK D t c) ->
(typeSubst_in_type t ((length D) + k) R) = t
.
Lemma
removeBounds_is_idempotent:
forall (t t': TypeS),
(removeBounds t t') ->
(removeBounds t' t')
.
Lemma
removeBounds_preserves_kind_of:
forall (t t': TypeS) (k: KindS),
(kind_of t k) ->
(removeBounds t t') ->
(kind_of t' k)
.
Lemma
Substitution_preserves_removeBounds:
forall (t t' R: TypeS) (k: nat),
(removeBounds t t') ->
(removeBounds (typeSubst_in_type t k R) t')
.
Lemma
removeBounds_then_substitution:
forall (t t' R: TypeS) (k: nat),
(removeBounds t t') ->
(typeSubst_in_type t' k R) = t'
.
Lemma
removeBounds_invariant_by_substitution:
forall (t t' R: TypeS) (k: nat),
(removeBounds t t') ->
(typeSubst_in_type t' k R) = t'
.
Lemma
TypeParamList_ind:
forall (D: TypeEnv) (Q: TypeS -> Prop),
(Q Type_nil) ->
(forall (P Ps: TypeS),
(Type_WK D P TypeParam) ->
(Type_WK D Ps TypeParamList) ->
(Q Ps) ->
(Q (Type_cons P Ps))
) ->
forall (Ps: TypeS),
(Type_WK D Ps TypeParamList) ->
(Q Ps)
.
Lemma
kind_of_params_inversion:
forall (Ps P: TypeS) (k ks: KindS) (i: nat),
(kind_of Ps ks) ->
(TypeS_at Ps i P) ->
(KindS_at ks i k) ->
(kind_of P k)
.
Lemma
kind_of_params_inversion_variant1:
forall (Ps P: TypeS) (ks: KindS) (i: nat),
(kind_of Ps ks) ->
(TypeS_at Ps i P) ->
exists k: KindS,
(KindS_at ks i k) /\
(kind_of P k)
.
Lemma
removeBounds_of_params_inversion:
forall (Ps Ps' P': TypeS) (i: nat),
(removeBounds Ps Ps') ->
(TypeS_at Ps' i P') ->
exists P: TypeS,
(TypeS_at Ps i P) /\
(removeBounds P P')
.
Lemma
removeBounds_and_kind_of_inversion:
forall (t t': TypeS) (k: KindS),
(removeBounds t t') ->
(kind_of t' k) ->
(kind_of t k)
.
Lemma
kind_equality_implies_param_satisfaction:
forall (D: TypeEnv) (K P P' Pi N_opt: TypeS) (k: KindS),
P = (Type_param Pi N_opt) ->
(Type_WK D K (TypeConstr k)) ->
(removeBounds P P') ->
(kind_of P k) ->
(ParamSat D K P')
.
Theorem
kind_equality_implies_poly_satisfaction:
forall (D: TypeEnv) (R Pi Pi': TypeS) (k: KindS),
(Type_WK D R (TypeTuple k)) ->
(Type_WK D Pi TypeSection) ->
(kind_of Pi k) ->
(removeBounds Pi Pi') ->
(SectionSat D R Pi')
.
Lemma
TypeEnv_WK_inversion:
forall (D: TypeEnv) (i: nat) (Pi: TypeS),
(TypeEnv_WK D) ->
(TypeSection_at D i Pi) ->
(Type_WK D (lift_in_type Pi (S i)) TypeSection)
.
Lemma
TypeEnv_WK_inversion_cor1:
forall (D: TypeEnv) (X: TypeVar) (Pi: TypeS),
(TypeEnv_WK D) ->
(decl_of_typeVar D X Pi) ->
(Type_WK D Pi TypeSection)
.
Lemma
Var_expansion_preserves_well_kindedness_aux:
forall (Ps Pi N_opt: TypeS) (i: nat) (k ks: KindS),
(TypeS_at Ps i (Type_param Pi N_opt)) ->
(kind_of Ps ks) ->
(KindS_at ks i (Kind_constr k)) ->
(kind_of Pi k)
.
Theorem
Var_expansion_preserves_well_kindedness:
forall (D: TypeEnv) (X: TypeVar) (R Ps Pi N: TypeS) (i: nat),
(TypeEnv_WK D) ->
(decl_of_typeVar D X (Type_section Ps)) ->
(TypeS_at (typeSubst_in_type Ps 0 (Type_var X)) i (Type_param Pi (Type_some N))) ->
(Type_WK D (Var_type X i R) Type_) ->
(Type_WK D (typeSubst_in_type N 0 R) Type_)
.
Lemma
TypeEnv_WK_inversion_cor2:
forall (D1 D2: TypeEnv) (Pi: TypeS),
(TypeEnv_WK (D1 ++ (Pi :: D2))) ->
(Type_WK D1 Pi TypeSection)
.
Lemma
KindS_at_and_size:
forall (k ks: KindS) (i: nat),
(KindS_at ks i k) ->
(size_of_kind k) < (size_of_kind ks)
.
Lemma
Substitution_in_well_kinded_type_env:
forall (D1 D2: TypeEnv) (Pi R: TypeS) (k: KindS),
(TypeEnv_WK (D1 ++ Pi :: D2)) ->
(Type_WK D1 R (TypeTuple k)) ->
(kind_of Pi k) ->
(TypeEnv_WK (D1 ++ (typeSubst_in_typeEnv D2 0 R)))
.
Lemma
removeBounds_preserves_well_kindedness:
forall (D: TypeEnv) (t t': TypeS) (c: TypeC),
(Type_WK D t c) ->
(removeBounds t t') ->
forall (D': TypeEnv),
(Type_WK D' t' c)
.
Lemma
Type_substitution_preserves_subtyping_aux1:
forall (D1 D2: TypeEnv) (R Pi': TypeS) (i: nat) (k0 k1: KindS),
(Type_WK D1 R (TypeTuple (Kind_tuple k1))) ->
(KindS_at k1 i (Kind_constr k0)) ->
(kind_of Pi' k0) ->
(Type_WK (snoc (D1 ++ typeSubst_in_typeEnv D2 0 R) Pi')
(Type_apply (lift_in_type (Type_proj (lift_in_type R (length D2)) i) 1)
(Type_var 0)) Type_)
.
Theorem
Type_substitution_preserves_subtyping:
forall (D1 D2: TypeEnv) (Pi R T U: TypeS) (k: KindS),
(Type_WK D1 R (TypeTuple k)) ->
(SectionSat D1 R Pi) ->
(TypeEnv_WK (D1 ++ (Pi :: D2))) ->
(Subtyping (D1 ++ (Pi :: D2)) T U) ->
(Type_WK (D1 ++ (Pi :: D2)) T Type_) ->
(Type_WK (D1 ++ (Pi :: D2)) U Type_) ->
(Subtyping (D1 ++ (typeSubst_in_typeEnv D2 0 R))
(typeSubst_in_type T (length D2) R)
(typeSubst_in_type U (length D2) R))
.
Theorem
Type_substitution_preserves_subtyping_snoc:
forall (D1: TypeEnv) (Pi R T U: TypeS) (k: KindS),
(Type_WK D1 R (TypeTuple k)) ->
(SectionSat D1 R Pi) ->
(TypeEnv_WK (snoc D1 Pi)) ->
(Subtyping (snoc D1 Pi) T U) ->
(Type_WK (snoc D1 Pi) T Type_) ->
(Type_WK (snoc D1 Pi) U Type_) ->
(Subtyping D1 (typeSubst_in_type T 0 R) (typeSubst_in_type U 0 R))
.
Lemma
Type_substitution_preserves_subtyping_cor1:
forall (Pi1 Pi2 R T U: TypeS) (k: KindS),
(Type_WK nil R (TypeTuple k)) ->
(SectionSat nil R Pi1) ->
let D := (Pi1 :: Pi2 :: nil) in
(TypeEnv_WK D) ->
(Type_WK D T Type_) ->
(Type_WK D U Type_) ->
(Subtyping D T U) ->
(Subtyping ((typeSubst_in_type Pi2 0 R) :: nil)
(typeSubst_in_type T 1 R)
(typeSubst_in_type U 1 R))
.
Proof
.
intros.
cut (
(Subtyping (nil ++ (typeSubst_in_typeEnv (Pi2 :: nil) 0 R))
(typeSubst_in_type T (length (Pi2 :: nil)) R)
(typeSubst_in_type U (length (Pi2 :: nil)) R))
).
simpl. tauto.
eapply Type_substitution_preserves_subtyping; eauto.
Qed
.
Lemma
Type_substitution_preserves_subtyping_cor2:
forall (Pi R T U: TypeS) (k: KindS),
(Type_WK nil R (TypeTuple k)) ->
(SectionSat nil R Pi) ->
let D := (Pi :: nil) in
(TypeEnv_WK D) ->
(Type_WK D T Type_) ->
(Type_WK D U Type_) ->
(Subtyping D T U) ->
(Subtyping nil
(typeSubst_in_type T 0 R)
(typeSubst_in_type U 0 R))
.
Proof
.
intros.
cut (
(Subtyping (nil ++ (typeSubst_in_typeEnv nil 0 R))
(typeSubst_in_type T (length (nil (A:= TypeS))) R)
(typeSubst_in_type U (length (nil (A:= TypeS))) R))
).
simpl. tauto.
eapply Type_substitution_preserves_subtyping; eauto.
Qed
.
Lemma
typeSubst_of_some_inversion:
forall (D: TypeEnv) (t N R: TypeS) (k: nat),
(Type_WK D t TypeOption) ->
(typeSubst_in_type t k R) = (Type_some N) ->
exists N0: TypeS,
t = (Type_some N0) /\
N = (typeSubst_in_type N0 k R)
.
Lemma
typeSubst_of_cons_inversion:
forall (D: TypeEnv) (t u us R: TypeS) (k: nat),
(Type_WK D t TypeParamList) ->
(typeSubst_in_type t k R) = (Type_cons u us) ->
exists u0: TypeS, exists us0: TypeS,
t = (Type_cons u0 us0) /\
u = (typeSubst_in_type u0 k R) /\
us = (typeSubst_in_type us0 k R)
.
Lemma
TypeS_at_of_typeSubst_inversion:
forall (D: TypeEnv) (t u R: TypeS) (i k: nat),
(Type_WK D t TypeParamList) ->
(TypeS_at (typeSubst_in_type t k R) i u) ->
exists u0: TypeS,
(TypeS_at t i u0) /\
u = (typeSubst_in_type u0 k R)
.
Lemma
Type_substitution_preserves_param_satisfaction:
forall (D1 D2: TypeEnv) (Pi R K P: TypeS) (k k': KindS),
let D := (D1 ++ (Pi :: D2)) in
(Type_WK D1 R (TypeTuple k)) ->
(SectionSat D1 R Pi) ->
(TypeEnv_WK D) ->
(ParamSat D K P) ->
(Type_WK D K (TypeConstr k')) ->
(Type_WK D P TypeParam) ->
(kind_of P k') ->
(ParamSat (D1 ++ (typeSubst_in_typeEnv D2 0 R))
(typeSubst_in_type K (length D2) R)
(typeSubst_in_type P (length D2) R))
.
Proof
.
intros.
destruct H2.
simpl. econstructor.
apply Substitution_preserves_removeBounds. eauto.
intros.
inversion_clear H4.
destruct (typeSubst_of_some_inversion _ _ _ _ _ H9 H7).
destruct H4. rename x into N0. subst N.
replace (snoc (D1 ++ typeSubst_in_typeEnv D2 0 R) Pi') with
(D1 ++ (typeSubst_in_typeEnv (snoc D2 Pi') 0 R)).
Focus 2. rewrite snoc_of_append. rewrite typeSubst_of_snoc.
rewrite removeBounds_invariant_by_substitution with (t:= Pi0). trivial. trivial.
replace (Type_apply (lift_in_type (typeSubst_in_type K (length D2) R) 1)
(Type_var 0)) with
(typeSubst_in_type (Type_apply (lift_in_type K 1) (Type_var 0))
(length (snoc D2 Pi'))
R).
Focus 2. simpl. rewrite length_of_snoc.
unfold typeSubst_in_typeVar. rewrite match_comp_nat3_lt.
rewrite Permuting_type_lifting_and_substitution_cor1. trivial.
omega.
replace (typeSubst_in_type N0 (S (length D2)) R) with
(typeSubst_in_type N0 (length (snoc D2 Pi')) R).
Focus 2. rewrite length_of_snoc. trivial.
eapply Type_substitution_preserves_subtyping. eauto. eauto.
rewrite <- snoc_of_cons. rewrite <- snoc_of_append.
constructor. trivial.
eapply removeBounds_preserves_well_kindedness. eauto. trivial.
rewrite <- snoc_of_cons. rewrite <- snoc_of_append. auto.
inversion H5. subst k'.
econstructor.
rewrite <- snoc_of_cons. rewrite <- snoc_of_append.
apply Weakening_of_well_kindedness_by_the_right_snoc. eauto.
econstructor. econstructor.
rewrite <- snoc_of_cons. rewrite <- snoc_of_append.
constructor.
unfold lift_in_type. apply Lifting_preserves_kind_of.
eapply removeBounds_preserves_kind_of. apply H13. trivial.
subst N_opt. inversion_clear H9.
rewrite <- snoc_of_cons. rewrite <- snoc_of_append. unfold snoc.
assert (exists k0: KindS, (kind_of Pi0 k0)).
eapply wellKinded_implies_kind_of_exists; eauto. destruct H9. rename x into k0.
eapply Well_kindedness_does_not_depend_on_bounds. apply H9.
eapply removeBounds_preserves_kind_of. apply H9. trivial.
trivial.
Qed
.
Theorem
Type_substitution_preserves_satisfaction:
forall (D1 D2: TypeEnv) (Pi R R' Pi': TypeS) (k: KindS),
let D := (D1 ++ (Pi :: D2)) in
(Type_WK D1 R (TypeTuple k)) ->
(SectionSat D1 R Pi) ->
(TypeEnv_WK D) ->
(SectionSat D R' Pi') ->
(Type_WK D Pi' TypeSection) ->
(SectionSat (D1 ++ (typeSubst_in_typeEnv D2 0 R))
(typeSubst_in_type R' (length D2) R)
(typeSubst_in_type Pi' (length D2) R))
.
Proof
.
intros.
inversion H2. subst Pi'.
inversion H3. clear D0 Ps0 H8 H7.
unfold Forall_ParamSat in H6.
simpl. econstructor.
apply Substitution_preserves_kind_of. eauto.
eapply Type_substitution_preserves_well_kindedness. eauto.
eapply Satisfaction_implies_same_kind; eauto. eauto. trivial.
unfold Forall_ParamSat. intros.
rewrite <- Permuting_type_substitutions_cor1 in H7.
assert (Type_WK D (typeSubst_in_type Ps 0 R') TypeParamList).
eapply Substitution_preserves_well_kindedness_snoc. eauto.
apply Kind_of_section. eauto. trivial.
destruct (TypeS_at_of_typeSubst_inversion _ _ _ _ _ _ H8 H7).
destruct H10. rename x into P0. subst P.
change (Type_proj (typeSubst_in_type R' (length D2) R) i) with
(typeSubst_in_type (Type_proj R' i) (length D2) R).
assert (exists k : KindS, (KindS_at ks i k) /\ (kind_of P0 k)).
eapply kind_of_params_inversion_variant1.
apply Substitution_preserves_kind_of. apply H4. eauto.
destruct H11. destruct H11. rename x into k0.
eapply Type_substitution_preserves_param_satisfaction. eauto. eauto.
trivial. auto.
econstructor; eauto.
eapply TypeParamList_WK_inversion. apply H8. eauto.
trivial.
Qed
.
Theorem
Type_substitution_preserves_satisfaction_snoc:
forall (D1: TypeEnv) (Pi R R' Pi': TypeS) (k: KindS),
let D := (snoc D1 Pi) in
(Type_WK D1 R (TypeTuple k)) ->
(SectionSat D1 R Pi) ->
(TypeEnv_WK D) ->
(SectionSat D R' Pi') ->
(Type_WK D Pi' TypeSection) ->
(SectionSat D1 (typeSubst_in_type R' 0 R) (typeSubst_in_type Pi' 0 R))
.
Proof
.
intros.
replace
( SectionSat D1 (typeSubst_in_type R' 0 R) (typeSubst_in_type Pi' 0 R))
with
(SectionSat (D1 ++ (typeSubst_in_typeEnv nil 0 R))
(typeSubst_in_type R' (length (nil (A:= TypeS))) R)
(typeSubst_in_type Pi' (length (nil (A:= TypeS))) R)).
eapply Type_substitution_preserves_satisfaction; eauto.
simpl. rewrite <- app_nil_end. trivial.
Qed
.
End
SetProgram.