ladder-calculus/coq/soundness.v

From Coq Require Import Strings.String.
Require Import terms.
Require Import subst.
Require Import equiv.
Require Import subtype.
Require Import context.
Require Import morph.
Require Import smallstep.
Require Import typing.

Lemma typing_weakening : forall Γ e τ x σ,
  (Γ |- e \is τ) ->
  ((ctx_assign x σ Γ) |- e \is τ)
.
Proof.
  intros.
  induction H.

  apply T_Var.
  apply C_shuffle.
  apply H.
  
  apply T_Let with (σ:=σ0).
  apply IHexpr_type1.
  admit.

Admitted.


Lemma morphism_path_solves_type : forall Γ τ τ' m,
  (translate_morphism_path Γ τ τ' m) ->
  Γ |- m \is (type_morph τ τ')
.
Proof.
  intros.
  induction H.

  (* Sub *)
  apply T_MorphAbs.
  apply T_DescendImplicit with (τ:=τ).
  apply T_Var.
  apply C_take.
  apply H.

  (* Lift *)
  apply T_MorphAbs.
  apply T_Ascend.
  apply T_App with (σ':=τ) (σ:=τ).
  apply T_MorphFun.
  apply typing_weakening.
  apply IHtranslate_morphism_path.
  apply T_Descend with (τ:=(type_ladder σ τ)).
  apply T_Var.
  apply C_take.
  apply TSubRepr_Ladder, TSubRepr_Refl, TEq_Refl.
  apply M_Sub, TSubRepr_Refl, TEq_Refl.

  (* Single *)
  apply T_Var.
  apply H.

  (* Chain *)
  apply T_MorphAbs.
  apply T_App with (σ':=τ') (σ:=τ') (τ:=τ'').
  apply T_MorphFun.
  apply typing_weakening.
  apply IHtranslate_morphism_path2.
  
  apply T_App with (σ':=τ) (σ:=τ) (τ:=τ').
  apply T_MorphFun.
  apply typing_weakening.
  apply IHtranslate_morphism_path1.

  apply T_Var.
  apply C_take.
  apply M_Sub, TSubRepr_Refl, TEq_Refl.
  apply M_Sub, TSubRepr_Refl, TEq_Refl.

  (* Map Sequence *)
  apply T_MorphAbs.
  apply T_App with (σ':=(type_spec (type_id "Seq") τ)) (σ:=(type_spec (type_id "Seq") τ)).
  apply T_App with (σ':=(type_fun τ τ')) (σ:=(type_fun τ τ')).

  admit.

  apply T_MorphFun.
  apply typing_weakening.
  apply IHtranslate_morphism_path.
  apply M_Sub, TSubRepr_Refl, TEq_Refl.

  apply T_Var.
  apply C_take.
  apply M_Sub, TSubRepr_Refl, TEq_Refl.
Admitted.

(* reduction step preserves well-typedness *)
Lemma preservation : forall Γ e e' τ,
  ~(is_value e) ->
  (Γ |- e \is τ) ->
  (e -->β e') ->
  (Γ |- e' \is τ)
.
Proof.
  intros.
  induction e.

  (* `e` is Variable *)
  contradict H.
  apply V_Abs, VAbs_Var.

  (* `e` is Type-Abstraction *)
  contradict H.
  apply V_Abs, VAbs_TypAbs.

  (* `e` is Type-Application *)
  admit.

  (* `e` is Abstraction *)
  contradict H.
  apply V_Abs, VAbs_Abs.

  (* `e` is morphism *)
  contradict H.
  apply V_Abs, VAbs_Morph.

  (* `e` is Application *)
  admit.

  (* `e` is Let-Binding *)
  admit.

  (* `e` is Ascension *)
  admit.

  (* `e` is Descension *)
  admit.
Admitted.

(* translation of expression preserves typing *)
Lemma translation_preservation : forall Γ e e' τ,
  (Γ |- e \is τ) ->
  (translate_typing Γ e τ e') ->
  (Γ |- e' \is τ)
.
Proof.
  intros.  
  induction H0.

  (* e is Variable *)
  apply H.

  (* e is Let-Binding *)
  apply T_Let with (τ:=τ) (σ:=σ).
  apply IHtranslate_typing1.
  apply H0.
  apply IHtranslate_typing2.
  apply H1.

  (* e is Type-Abstraction *)
  apply T_TypeAbs.
  apply IHtranslate_typing.
  apply H0.

  (* e is Type-Application *)
  admit.

  (* e is Abstraction *)
  apply T_Abs.
  apply IHtranslate_typing.
  apply H0.

  (* e is Morphism-Abstraction *)
  apply T_MorphAbs.
  apply IHtranslate_typing.
  apply H0.

  (* e is Application *)
  apply T_App with (σ':=σ) (σ:=σ) (τ:=τ).
  apply IHtranslate_typing1.
  apply H0.

  induction H3.

    (* Repr-Subtype *)
    apply T_App with (σ':=τ0) (σ:=τ0) (τ:=τ').
    apply T_MorphFun.
    apply T_MorphAbs.
    apply T_DescendImplicit with (τ:=τ0).
    apply T_Var.
    apply C_take.
    apply H3.

    apply T_DescendImplicit with (τ:=τ0).
    apply IHtranslate_typing2.
    apply H1.
    apply TSubRepr_Refl, TEq_Refl.
    apply M_Sub, TSubRepr_Refl, TEq_Refl.

    (* Lifted Morphism *)
    apply T_App with (σ':=(type_ladder σ τ0)) (σ:=(type_ladder σ τ0)) (τ:=(type_ladder σ τ')).
    apply T_MorphFun.
    apply T_MorphAbs.
    apply T_Ascend with (τ:=τ').
    apply T_App with (σ':=τ0) (σ:=τ0) (τ:=τ').
    apply T_MorphFun.
    apply typing_weakening.
    apply morphism_path_solves_type.
    apply H4.

    apply T_Descend with (τ:=(type_ladder σ τ0)).
    apply T_Var.
    apply C_take.

    apply TSubRepr_Ladder, TSubRepr_Refl, TEq_Refl.
    apply M_Sub, TSubRepr_Refl, TEq_Refl.
    apply IHtranslate_typing2.
    apply H1.

    apply M_Sub, TSubRepr_Refl, TEq_Refl.

    (* argument coecrion is single function variable *)
    apply T_App with (σ':= τ0) (σ:=τ0).
    apply T_MorphFun.
    apply T_Var.
    apply H3.
    apply IHtranslate_typing2.
    apply H1.
    (* lemma: every context implies identity morphism *)
    apply M_Sub, TSubRepr_Refl, TEq_Refl.

    (* argument coecrion is chain of coercions *)
    apply T_App with (σ':=τ0) (σ:=τ0).
    apply T_MorphFun.
    apply T_MorphAbs.
    apply T_App with (σ':=τ') (σ:=τ').
    apply T_MorphFun.
    apply typing_weakening.
    apply morphism_path_solves_type.
    apply H3_0.
    apply T_App with (σ':=τ0) (σ:=τ0).
    apply T_MorphFun.
    apply typing_weakening.
    apply morphism_path_solves_type.
    apply H3_.
    apply T_Var.
    apply C_take.
    (* lemma: every context implies identity morphism *)
    apply M_Sub, TSubRepr_Refl, TEq_Refl.
    (* lemma: every context implies identity morphism *)
    apply M_Sub, TSubRepr_Refl, TEq_Refl.
    apply IHtranslate_typing2.
    apply H1.
    (* lemma: every context implies identity morphism *)
    apply M_Sub, TSubRepr_Refl, TEq_Refl.

    (* argument coercion is is map *)
(*
    apply T_App with (σ':=(type_spec (type_id "Seq") τ0)) (σ:=(type_spec (type_id "Seq") τ0)).
    apply T_MorphFun.
    apply T_MorphAbs.
    apply T_App with (σ':=(type_spec (type_id "Seq") τ0)) (σ:=(type_spec (type_id "Seq") τ0)).
    apply T_App with (σ':=(type_fun τ0 τ')) (σ:=(type_fun τ0 τ')).
    apply T_TypeApp with
      (α:="T2"%string)
      (e:=(expr_ty_app (expr_var "map") τ0))
      (τ:=(type_fun
            (type_fun τ0 τ')
            (type_fun
              (type_spec (type_id "Seq") τ0)
              (type_spec (type_id "Seq") τ')))).

    apply T_TypeApp with
      (α:="T1"%string)
      (e:=(expr_var "map"))
      (τ:=(type_univ "T2"
          (type_fun
            (type_fun τ0 τ')
            (type_fun
              (type_spec (type_id "Seq") (type_var "T1"))
              (type_spec (type_id "Seq") (type_var "T2")))))).

    apply T_Var.
    admit.

    apply TSubst_VarReplace.
    apply TSubst_UnivReplace.
*)
    admit.

    (* argument coercion *)
    apply M_Sub, TSubRepr_Refl, TEq_Refl.

  (* end case `e application` *)

  (* e is Morphism *)
  apply T_MorphFun.
  apply IHtranslate_typing.
  apply H0.

  (* e is Ascension *)
  apply T_Ascend.
  apply IHtranslate_typing.
  apply H0.

  (* e is Desecension *)
  apply T_DescendImplicit with (τ:=τ).
  apply IHtranslate_typing.
  apply H0.
  apply H1.
Admitted.

(* e is stuck when it is neither a value, nor can it be reduced *)
Definition is_stuck (e:expr_term) : Prop :=
  ~(is_value e) ->
  ~(exists e', e -->β e')
.

(* the translation any well typed term is not stuck *)
Lemma progress :
  forall Γ e τ e',
  (Γ |- e \is τ) ->
  (translate_typing Γ e τ e') ->
  ~(is_stuck e')
.
Proof.
Admitted.

(* every well-typed expression is translated,
 * such that it be reduced to a value
 *)
Theorem soundness :
  forall Γ e e' τ,
  (Γ |- e \is τ) ->
  (translate_typing Γ e τ e') ->
  (exists v, (e' -->β* v) /\ (is_value v) /\ (Γ |- v \is τ))
.
Proof.
  intros.

  (* `e` is Variable *)
  induction H0.
  exists (expr_var x).
  split. apply Multi_Refl.
  split. apply V_Abs,VAbs_Var.
  apply H.

  (* `e` is Let-Binding *)
  exists (expr_subst x e' t').
  split.
  apply Multi_Step with (y:=(expr_subst x e' t')).
  apply E_Let with (x:=x) (a:=e') (e:=t').
  apply Multi_Refl.
(*
  split.
  unfold expr_subst.
  induction t'.
  
  exists (expr_subst x e' (expr_var s)).
  split.
  unfold expr_subst.
  apply E_Let.
  *)
  admit.

  (* `e` is Type-Abstraction *)
  exists (expr_ty_abs α e').
  split.
  apply Multi_Refl.
  split.
  apply V_Abs, VAbs_TypAbs.
  apply T_TypeAbs.
  apply translation_preservation with (e:=e).
  apply H0.
  apply H1.

  (* `e` is Type-Application *)
  admit.

  (* `e`is Abstraction *)
  exists (expr_abs x σ e').
  split. apply Multi_Refl.
  split. apply V_Abs, VAbs_Abs.
  apply T_Abs.
  apply translation_preservation with (e:=e).
  apply H0.
  apply H2.

  (* `e` is Morphism Abstraction *)
  exists (expr_morph x σ e').
  split. apply Multi_Refl.
  split. apply V_Abs, VAbs_Morph.
  apply T_MorphAbs.
  apply translation_preservation with (e:=e).
  apply H0.
  apply H2.

  (* `e` is Application *)
  admit.
  admit.

  (* `e` is Ascension *)
  admit.

  (* `e` is Descension *)
  admit.
Admitted.