2024-09-22 15:57:15 +02:00
|
|
|
|
From Coq Require Import Lists.List.
|
|
|
|
|
Require Import Atom.
|
|
|
|
|
Require Import Environment.
|
|
|
|
|
Require Import Metatheory.
|
|
|
|
|
Require Import debruijn.
|
|
|
|
|
Require Import subtype.
|
|
|
|
|
Require Import env.
|
|
|
|
|
Require Import morph.
|
|
|
|
|
Require Import subst_lemmas.
|
|
|
|
|
Require Import typing.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
Require Import typing_regular.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
Require Import typing_weakening.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Lemma map_type : forall Γ,
|
|
|
|
|
Γ |- [{ $at_map }] \is [< ∀ ∀ ((%1) -> (%0)) -> [%1] -> [%0] >]
|
|
|
|
|
.
|
|
|
|
|
Proof.
|
|
|
|
|
Admitted.
|
|
|
|
|
|
|
|
|
|
Lemma specialized_map_type : forall Γ τ τ',
|
|
|
|
|
Γ |- [{ $at_map # τ # τ' }] \is [<
|
|
|
|
|
(τ -> τ') -> [τ] -> [τ']
|
|
|
|
|
>].
|
|
|
|
|
Proof.
|
|
|
|
|
intros.
|
|
|
|
|
set (u:=[< ((%1)->(%0)) -> [%1] -> [%0] >]).
|
|
|
|
|
set (v:=[< (τ->(%0)) -> [τ] -> [%0] >]).
|
|
|
|
|
set (x:=(type_open τ u)).
|
|
|
|
|
set (y:=(type_open τ' x)).
|
|
|
|
|
(*
|
|
|
|
|
unfold type_open in x.
|
|
|
|
|
simpl in x.
|
|
|
|
|
apply T_TypeApp with (Γ:=Γ) (e:=[{ $at_map # τ }]) (τ:=x) (σ:=τ').
|
|
|
|
|
*)
|
|
|
|
|
Admitted.
|
|
|
|
|
|
2024-09-24 04:28:41 +02:00
|
|
|
|
Lemma type_lc_spec_inv : forall τ,
|
|
|
|
|
type_lc [< [τ] >] ->
|
|
|
|
|
type_lc τ
|
|
|
|
|
.
|
|
|
|
|
Proof.
|
|
|
|
|
Admitted.
|
|
|
|
|
|
|
|
|
|
Lemma type_lc_ladder_inv2 : forall σ τ,
|
|
|
|
|
type_lc [< σ ~ τ >] ->
|
|
|
|
|
type_lc τ
|
|
|
|
|
.
|
|
|
|
|
Proof.
|
|
|
|
|
Admitted.
|
|
|
|
|
|
|
|
|
|
Lemma morph_regular_lc : forall Γ τ τ',
|
|
|
|
|
env_wf Γ ->
|
|
|
|
|
type_lc τ ->
|
|
|
|
|
(Γ |- τ ~~> τ') ->
|
|
|
|
|
type_lc τ'
|
|
|
|
|
.
|
|
|
|
|
Proof.
|
|
|
|
|
intros.
|
|
|
|
|
induction H1.
|
|
|
|
|
- apply type_lc_sub with (τ1:=τ).
|
|
|
|
|
assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
Admitted.
|
|
|
|
|
|
|
|
|
|
Lemma morph_path_inv : forall Γ τ τ' m,
|
|
|
|
|
(Γ |- [[ τ ~~> τ' ]] = m) ->
|
|
|
|
|
(Γ |- τ ~~> τ')
|
|
|
|
|
.
|
|
|
|
|
Proof.
|
|
|
|
|
Admitted.
|
|
|
|
|
|
2024-09-22 15:57:15 +02:00
|
|
|
|
(*
|
|
|
|
|
* translated morphism path is locally closed
|
|
|
|
|
*)
|
2024-09-24 04:28:41 +02:00
|
|
|
|
Lemma morph_path_lc : forall Γ τ τ' m,
|
2024-09-22 15:57:15 +02:00
|
|
|
|
type_lc τ ->
|
|
|
|
|
env_wf Γ ->
|
|
|
|
|
(Γ |- [[ τ ~~> τ' ]] = m) ->
|
|
|
|
|
expr_lc m
|
|
|
|
|
.
|
|
|
|
|
Proof.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
intros Γ τ τ' m Wfτ WfEnv H.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
induction H.
|
|
|
|
|
|
|
|
|
|
(* Subtype / Identity *)
|
|
|
|
|
- apply Elc_Morph with (L:=dom Γ).
|
|
|
|
|
assumption.
|
|
|
|
|
intros x Fr.
|
|
|
|
|
unfold expr_open.
|
|
|
|
|
simpl.
|
|
|
|
|
apply Elc_Descend.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply type_lc_sub with (τ1:=τ).
|
|
|
|
|
assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
assumption.
|
|
|
|
|
apply Elc_Var.
|
|
|
|
|
|
|
|
|
|
(* Lift *)
|
|
|
|
|
- apply Elc_Morph with (L:=dom Γ).
|
|
|
|
|
trivial.
|
|
|
|
|
intros x Fr.
|
|
|
|
|
unfold expr_open.
|
|
|
|
|
simpl.
|
|
|
|
|
apply Elc_Ascend.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
inversion Wfτ; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply Elc_App.
|
|
|
|
|
rewrite expr_open_lc.
|
|
|
|
|
|
|
|
|
|
apply IHtranslate_morphism_path.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
inversion Wfτ; assumption.
|
|
|
|
|
inversion Wfτ; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
|
|
|
|
|
apply IHtranslate_morphism_path.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
inversion Wfτ; assumption.
|
|
|
|
|
inversion Wfτ; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
|
|
|
|
|
apply Elc_Descend, Elc_Var.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
inversion Wfτ; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
|
|
|
|
|
(* Single Morphism *)
|
|
|
|
|
- apply Elc_Var.
|
|
|
|
|
|
|
|
|
|
(* Chain *)
|
|
|
|
|
- apply Elc_Morph with (L:=dom Γ).
|
|
|
|
|
assumption.
|
|
|
|
|
intros x Fr.
|
|
|
|
|
unfold expr_open; simpl.
|
|
|
|
|
|
|
|
|
|
apply Elc_App.
|
|
|
|
|
rewrite expr_open_lc.
|
|
|
|
|
apply IHtranslate_morphism_path2.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
apply morph_regular_lc with (Γ:=Γ) (τ:=τ).
|
|
|
|
|
assumption. assumption.
|
|
|
|
|
apply morph_path_inv with (m:=m1), H.
|
|
|
|
|
assumption.
|
|
|
|
|
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply IHtranslate_morphism_path2.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
|
|
|
|
|
apply morph_regular_lc with (Γ:=Γ) (τ:=τ).
|
|
|
|
|
assumption. assumption.
|
|
|
|
|
apply morph_path_inv with (m:=m1), H.
|
|
|
|
|
assumption.
|
|
|
|
|
|
2024-09-22 15:57:15 +02:00
|
|
|
|
|
|
|
|
|
apply Elc_App.
|
|
|
|
|
rewrite expr_open_lc.
|
|
|
|
|
apply IHtranslate_morphism_path1.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
|
|
|
|
|
apply morph_regular_lc with (Γ:=Γ) (τ:=τ).
|
|
|
|
|
assumption. assumption.
|
|
|
|
|
apply id_morphism_path.
|
|
|
|
|
assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply IHtranslate_morphism_path1.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply Elc_Var.
|
|
|
|
|
|
|
|
|
|
(* Map *)
|
|
|
|
|
- apply Elc_Morph with (L:=dom Γ).
|
|
|
|
|
assumption.
|
|
|
|
|
intros x Fr.
|
|
|
|
|
unfold expr_open; simpl.
|
|
|
|
|
apply Elc_App.
|
|
|
|
|
2: apply Elc_Var.
|
|
|
|
|
apply Elc_App.
|
|
|
|
|
apply Elc_TypApp.
|
|
|
|
|
apply Elc_TypApp.
|
|
|
|
|
apply Elc_Var.
|
|
|
|
|
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply type_lc_spec_inv; assumption.
|
|
|
|
|
apply morph_path_inv in H.
|
|
|
|
|
apply morph_regular_lc with (Γ:=Γ) (τ:=τ).
|
|
|
|
|
assumption.
|
|
|
|
|
apply type_lc_spec_inv; assumption.
|
|
|
|
|
assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
rewrite expr_open_lc.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply IHtranslate_morphism_path.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply type_lc_spec_inv; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
assumption.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply IHtranslate_morphism_path.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply type_lc_spec_inv; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
assumption.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
(*
|
|
|
|
|
* translated morphism path has valid typing
|
|
|
|
|
*)
|
|
|
|
|
Lemma morphism_path_correct : forall Γ τ τ' m,
|
|
|
|
|
type_lc τ ->
|
|
|
|
|
env_wf Γ ->
|
|
|
|
|
(Γ |- [[ τ ~~> τ' ]] = m) ->
|
|
|
|
|
(Γ |- m \is [< τ ->morph τ' >])
|
|
|
|
|
.
|
|
|
|
|
Proof.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
intros Γ τ τ' m Lcτ WfEnv H.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
induction H.
|
|
|
|
|
|
|
|
|
|
(* Sub *)
|
|
|
|
|
- apply T_MorphAbs with (σ:=τ) (τ:=τ') (L:=dom Γ).
|
|
|
|
|
intros.
|
|
|
|
|
unfold expr_open.
|
|
|
|
|
simpl.
|
|
|
|
|
apply T_Descend with (τ:=τ).
|
|
|
|
|
apply T_Var.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply env_wf_type.
|
|
|
|
|
1-3,5:assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
simpl_env.
|
|
|
|
|
apply binds_head, binds_singleton.
|
|
|
|
|
|
|
|
|
|
(* Lift *)
|
|
|
|
|
- apply T_MorphAbs with (σ:=[<σ~τ>]) (τ:=[<σ~τ'>]) (L:=dom Γ).
|
|
|
|
|
intros x Fr.
|
|
|
|
|
unfold expr_open; simpl.
|
|
|
|
|
apply T_Ascend.
|
|
|
|
|
apply T_App with (σ':=τ) (σ:=τ) (τ:=τ').
|
|
|
|
|
3: apply id_morphism_path.
|
|
|
|
|
2: {
|
|
|
|
|
apply T_Descend with (τ:=[< σ ~ τ >]).
|
|
|
|
|
apply T_Var.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply env_wf_type; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
simpl_env.
|
|
|
|
|
unfold binds. simpl.
|
|
|
|
|
destruct (x==x).
|
|
|
|
|
reflexivity.
|
|
|
|
|
contradict n.
|
|
|
|
|
reflexivity.
|
|
|
|
|
apply TSubRepr_Ladder, TSubRepr_Refl.
|
|
|
|
|
apply equiv.TEq_Refl.
|
|
|
|
|
}
|
|
|
|
|
|
2024-09-24 04:28:41 +02:00
|
|
|
|
inversion Lcτ; subst.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
rewrite expr_open_lc.
|
|
|
|
|
apply typing_weakening with (Γ':=(x,[< σ ~ τ >])::[]).
|
|
|
|
|
apply T_MorphFun.
|
|
|
|
|
apply IHtranslate_morphism_path.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply type_lc_ladder_inv2 with (σ:=σ); assumption; assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
apply env_wf_type.
|
|
|
|
|
assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
apply morph_path_lc with (Γ:=Γ) (τ:=τ) (τ':=τ').
|
|
|
|
|
assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
apply type_lc_ladder_inv2 with (σ:=σ).
|
2024-09-22 15:57:15 +02:00
|
|
|
|
all: assumption.
|
|
|
|
|
|
|
|
|
|
(* Single *)
|
|
|
|
|
- apply T_Var.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply H.
|
|
|
|
|
|
|
|
|
|
(* Chain *)
|
|
|
|
|
- apply T_MorphAbs with (L:=dom Γ).
|
|
|
|
|
intros x Fr.
|
|
|
|
|
unfold expr_open.
|
|
|
|
|
simpl.
|
|
|
|
|
apply T_App with (σ':=τ') (σ:=τ') (τ:=τ'').
|
|
|
|
|
3: apply id_morphism_path.
|
|
|
|
|
|
|
|
|
|
* apply T_MorphFun.
|
|
|
|
|
rewrite expr_open_lc.
|
|
|
|
|
simpl_env; apply typing_weakening.
|
|
|
|
|
apply IHtranslate_morphism_path2.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
|
|
|
|
|
apply morph_path_inv in H.
|
|
|
|
|
apply morph_regular_lc with (Γ:=Γ) (τ:=τ).
|
2024-09-22 15:57:15 +02:00
|
|
|
|
1-3: assumption.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
|
|
|
|
|
assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply env_wf_type.
|
|
|
|
|
1-3: assumption.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply morph_path_lc with (Γ:=Γ) (τ:=τ') (τ':=τ'').
|
|
|
|
|
2-3: assumption.
|
|
|
|
|
apply morph_path_inv in H.
|
|
|
|
|
apply morph_regular_lc with (Γ:=Γ) (τ:=τ).
|
|
|
|
|
all: assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
|
|
|
|
|
* apply T_App with (σ':=τ) (σ:=τ) (τ:=τ').
|
|
|
|
|
rewrite expr_open_lc.
|
|
|
|
|
apply typing_weakening with (Γ':=(x,τ)::[]).
|
|
|
|
|
apply T_MorphFun.
|
|
|
|
|
apply IHtranslate_morphism_path1.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
3: apply env_wf_type.
|
|
|
|
|
1-5: assumption.
|
|
|
|
|
apply morph_path_lc with (Γ:=Γ) (τ:=τ) (τ':=τ').
|
|
|
|
|
1-3: assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply T_Var.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply env_wf_type; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
2: apply id_morphism_path.
|
|
|
|
|
simpl_env; apply binds_head, binds_singleton.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
assumption.
|
|
|
|
|
|
|
|
|
|
* apply morph_path_inv in H.
|
|
|
|
|
apply morph_regular_lc with (Γ:=Γ) (τ:=τ).
|
|
|
|
|
all: assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
|
|
|
|
|
(* Map Sequence *)
|
|
|
|
|
- apply T_MorphAbs with (L:=dom Γ).
|
|
|
|
|
intros x Fr.
|
|
|
|
|
unfold expr_open.
|
|
|
|
|
simpl.
|
|
|
|
|
apply T_App with (σ':=[< [τ] >]) (σ:=[< [τ] >]).
|
|
|
|
|
3: apply id_morphism_path.
|
|
|
|
|
apply T_App with (σ':=[< τ -> τ' >]) (σ:=[< τ -> τ' >]).
|
|
|
|
|
3: apply id_morphism_path.
|
|
|
|
|
|
|
|
|
|
apply specialized_map_type.
|
|
|
|
|
rewrite expr_open_lc.
|
|
|
|
|
simpl_env; apply typing_weakening.
|
|
|
|
|
apply T_MorphFun.
|
|
|
|
|
apply IHtranslate_morphism_path.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
2: assumption.
|
|
|
|
|
2: apply env_wf_type; assumption.
|
|
|
|
|
|
|
|
|
|
inversion Lcτ; assumption.
|
|
|
|
|
apply morph_path_lc with (Γ:=Γ) (τ:=τ) (τ':=τ').
|
|
|
|
|
inversion Lcτ; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
1-2: assumption.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply Tlc_Func.
|
|
|
|
|
apply type_lc_spec_inv; assumption.
|
|
|
|
|
|
|
|
|
|
apply morph_path_inv in H.
|
|
|
|
|
apply morph_regular_lc in H.
|
|
|
|
|
assumption.
|
|
|
|
|
assumption.
|
|
|
|
|
apply type_lc_spec_inv; assumption.
|
|
|
|
|
|
2024-09-22 15:57:15 +02:00
|
|
|
|
apply T_Var.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
apply env_wf_type; assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
simpl_env; apply binds_head, binds_singleton.
|
2024-09-24 04:28:41 +02:00
|
|
|
|
assumption.
|
2024-09-22 15:57:15 +02:00
|
|
|
|
Qed.
|