coq: add translate_typing example

& other minor stuff
This commit is contained in:
Michael Sippel 2024-09-19 01:46:29 +02:00
parent d23ad61ba3
commit 826077e37b
Signed by: senvas
GPG key ID: F96CF119C34B64A6
3 changed files with 223 additions and 63 deletions

View file

@ -16,16 +16,21 @@ Proof.
intros. intros.
induction H. induction H.
apply T_Var. - apply T_Var.
apply C_shuffle. apply C_shuffle.
apply H. apply H.
apply T_Let with (σ:=σ0). - apply T_Let with (σ:=σ0).
apply IHexpr_type1. apply IHexpr_type1.
admit. admit.
Admitted. Admitted.
Lemma map_type : forall Γ,
Γ |- [{ %"map"% }] \is [<
"σ","τ", (%"σ"% -> %"τ"%) -> [%"σ"%] -> [%"τ"%]
>].
Proof.
Admitted.
Lemma morphism_path_solves_type : forall Γ τ τ' m, Lemma morphism_path_solves_type : forall Γ τ τ' m,
(translate_morphism_path Γ τ τ' m) -> (translate_morphism_path Γ τ τ' m) ->
@ -37,7 +42,7 @@ Proof.
(* Sub *) (* Sub *)
apply T_MorphAbs. apply T_MorphAbs.
apply T_DescendImplicit with (τ:=τ). apply T_Descend with (τ:=τ).
apply T_Var. apply T_Var.
apply C_take. apply C_take.
apply H. apply H.
@ -53,7 +58,7 @@ Proof.
apply T_Var. apply T_Var.
apply C_take. apply C_take.
apply TSubRepr_Ladder, TSubRepr_Refl, TEq_Refl. apply TSubRepr_Ladder, TSubRepr_Refl, TEq_Refl.
apply M_Sub, TSubRepr_Refl, TEq_Refl. apply id_morphism_path.
(* Single *) (* Single *)
apply T_Var. apply T_Var.
@ -73,15 +78,30 @@ Proof.
apply T_Var. apply T_Var.
apply C_take. apply C_take.
apply M_Sub, TSubRepr_Refl, TEq_Refl. apply id_morphism_path.
apply M_Sub, TSubRepr_Refl, TEq_Refl. apply id_morphism_path.
(* Map Sequence *) (* Map Sequence *)
apply T_MorphAbs. apply T_MorphAbs.
apply T_App with (σ':=(type_spec (type_id "Seq") τ)) (σ:=(type_spec (type_id "Seq") τ)). apply T_App with (σ':=(type_spec (type_id "Seq") τ)) (σ:=(type_spec (type_id "Seq") τ)).
apply T_App with (σ':=(type_fun τ τ')) (σ:=(type_fun τ τ')). apply T_App with (σ':=(type_fun τ τ')) (σ:=(type_fun τ τ')).
set (k:=[< (%"σ"% -> %"τ"%) -> <$"Seq"$ %"σ"%> -> <$"Seq"$ %"τ"%> >]).
set (k1:=[< (τ -> %"τ"%) -> <$"Seq"$ τ> -> <$"Seq"$ %"τ"%> >]).
set (k2:=[< (τ -> τ') -> <$"Seq"$ τ> -> <$"Seq"$ τ'> >]).
set (P:=(type_subst "τ" τ' k1) = k2).
(* apply T_TypeApp with (α:="τ"%string) (τ:=k2).*)
(* apply T_TypeApp with (α:="τ"%string) (τ:=(type_subst "τ" τ' k1)).*)
(*
apply map_type.
apply TSubst_UnivReplace.
admit. admit.
admit.
apply TSubst_UnivReplace.
apply T_MorphFun. apply T_MorphFun.
apply typing_weakening. apply typing_weakening.
@ -91,6 +111,7 @@ Proof.
apply T_Var. apply T_Var.
apply C_take. apply C_take.
apply M_Sub, TSubRepr_Refl, TEq_Refl. apply M_Sub, TSubRepr_Refl, TEq_Refl.
*)
Admitted. Admitted.
(* reduction step preserves well-typedness *) (* reduction step preserves well-typedness *)
@ -185,7 +206,7 @@ Proof.
apply T_App with (σ':=τ0) (σ:=τ0) (τ:=τ'). apply T_App with (σ':=τ0) (σ:=τ0) (τ:=τ').
apply T_MorphFun. apply T_MorphFun.
apply T_MorphAbs. apply T_MorphAbs.
apply T_DescendImplicit with (τ:=τ0). apply T_Descend with (τ:=τ0).
apply T_Var. apply T_Var.
apply C_take. apply C_take.
apply H3. apply H3.
@ -303,7 +324,7 @@ Proof.
apply H0. apply H0.
(* e is Desecension *) (* e is Desecension *)
apply T_DescendImplicit with (τ:=τ). apply T_Descend with (τ:=τ).
apply IHtranslate_typing. apply IHtranslate_typing.
apply H0. apply H0.
apply H1. apply H1.

View file

@ -1,60 +1,34 @@
From Coq Require Import Strings.String. From Coq Require Import Strings.String.
From Coq Require Import Lists.List.
Import ListNotations.
Require Import terms. Require Import terms.
(* Type Variable "x" is a free variable in type *)
Inductive type_var_free (x:string) : type_term -> Prop :=
| TFree_Var :
(type_var_free x (type_var x))
| TFree_Ladder : forall τ1 τ2,
(type_var_free x τ1) ->
(type_var_free x τ2) ->
(type_var_free x (type_ladder τ1 τ2))
| TFree_Fun : forall τ1 τ2,
(type_var_free x τ1) ->
(type_var_free x τ2) ->
(type_var_free x (type_fun τ1 τ2))
| TFree_Morph : forall τ1 τ2,
(type_var_free x τ1) ->
(type_var_free x τ2) ->
(type_var_free x (type_morph τ1 τ2))
| TFree_Spec : forall τ1 τ2,
(type_var_free x τ1) ->
(type_var_free x τ2) ->
(type_var_free x (type_spec τ1 τ2))
| TFree_Univ : forall y τ,
~(y = x) ->
(type_var_free x τ) ->
(type_var_free x (type_univ y τ))
.
Fixpoint type_fv (τ : type_term) {struct τ} : (list string) :=
match τ with
| type_id s => []
| type_var α => [α]
| type_univ α τ => (remove string_dec α (type_fv τ))
| type_spec σ τ => (type_fv σ) ++ (type_fv τ)
| type_fun σ τ => (type_fv σ) ++ (type_fv τ)
| type_morph σ τ => (type_fv σ) ++ (type_fv τ)
| type_ladder σ τ => (type_fv σ) ++ (type_fv τ)
end.
Open Scope ladder_type_scope. Open Scope ladder_type_scope.
Example ex_type_free_var1 : Example ex_type_fv1 :
(type_var_free "T" (type_univ "U" (type_var "T"))) (In "T"%string (type_fv [< "U",%"T"% >]))
. .
Proof. Proof. simpl. left. auto. Qed.
apply TFree_Univ.
easy.
apply TFree_Var.
Qed.
Open Scope ladder_type_scope. Open Scope ladder_type_scope.
Example ex_type_free_var2 : Example ex_type_fv2 :
~(type_var_free "T" (type_univ "T" (type_var "T"))) ~(In "T"%string (type_fv [< "T",%"T"% >]))
. .
Proof. Proof. simpl. auto. Qed.
intro H.
inversion H.
contradiction.
Qed.
(* scoped variable substitution in type terms $\label{coq:subst-type}$ *) (* scoped variable substitution in type terms $\label{coq:subst-type}$ *)
Fixpoint type_subst (v:string) (n:type_term) (t0:type_term) := Fixpoint type_subst (v:string) (n:type_term) (t0:type_term) : type_term :=
match t0 with match t0 with
| type_var name => if (eqb v name) then n else t0 | type_var name => if (eqb v name) then n else t0
| type_fun t1 t2 => (type_fun (type_subst v n t1) (type_subst v n t2)) | type_fun t1 t2 => (type_fun (type_subst v n t1) (type_subst v n t2))
@ -64,12 +38,14 @@ Fixpoint type_subst (v:string) (n:type_term) (t0:type_term) :=
| t => t | t => t
end. end.
(*
Inductive type_subst1 (x:string) (σ:type_term) : type_term -> type_term -> Prop := Inductive type_subst1 (x:string) (σ:type_term) : type_term -> type_term -> Prop :=
| TSubst_VarReplace : | TSubst_VarReplace :
(type_subst1 x σ (type_var x) σ) (type_subst1 x σ (type_var x) σ)
| TSubst_VarKeep : forall y, | TSubst_VarKeep : forall y,
~(x = y) -> (x <> y) ->
(type_subst1 x σ (type_var y) (type_var y)) (type_subst1 x σ (type_var y) (type_var y))
| TSubst_UnivReplace : forall y τ τ', | TSubst_UnivReplace : forall y τ τ',
@ -101,6 +77,56 @@ Inductive type_subst1 (x:string) (σ:type_term) : type_term -> type_term -> Prop
(type_subst1 x σ τ2 τ2') -> (type_subst1 x σ τ2 τ2') ->
(type_subst1 x σ (type_ladder τ1 τ2) (type_ladder τ1' τ2')) (type_subst1 x σ (type_ladder τ1 τ2) (type_ladder τ1' τ2'))
. .
*)
Lemma type_subst_symm :
forall x y τ τ',
((type_subst x (type_var y) τ) = τ') ->
((type_subst y (type_var x) τ') = τ)
.
Proof.
intros.
induction H.
unfold type_subst.
induction τ.
reflexivity.
Admitted.
Lemma type_subst_fresh :
forall α τ u,
~ (In α (type_fv τ))
-> (type_subst α u τ) = τ
.
Proof.
intros.
unfold type_subst.
induction τ.
reflexivity.
unfold eqb.
admit.
(*
apply TSubst_Id.
apply TSubst_VarKeep.
contradict H.
rewrite H.
apply TFree_Var.
apply TSubst_Fun.
apply IHτ1.
contradict H.
apply TFree_Fun.
apply H.
apply
*)
Admitted.
(* scoped variable substitution, replaces free occurences of v with n in expression e *) (* scoped variable substitution, replaces free occurences of v with n in expression e *)
Fixpoint expr_subst (v:string) (n:expr_term) (e0:expr_term) := Fixpoint expr_subst (v:string) (n:expr_term) (e0:expr_term) :=

View file

@ -11,6 +11,7 @@ Require Import morph.
(** Typing Derivation *) (** Typing Derivation *)
Open Scope ladder_type_scope.
Open Scope ladder_expr_scope. Open Scope ladder_expr_scope.
Reserved Notation "Gamma '|-' x '\is' X" (at level 101, x at next level, X at level 0). Reserved Notation "Gamma '|-' x '\is' X" (at level 101, x at next level, X at level 0).
@ -267,4 +268,116 @@ Proof.
apply M_Sub. apply TSubRepr_Refl. apply TEq_Refl. apply M_Sub. apply TSubRepr_Refl. apply TEq_Refl.
Qed. Qed.
End Typing.
Ltac var_typing := auto using T_Var, C_shuffle, C_take.
Ltac repr_subtype := auto using TSubRepr_Ladder, TSubRepr_Refl, TEq_Refl, TEq_LadderAssocLR.
Example expand1 :
(translate_typing
(ctx_assign "60" [< $""$ >]
(ctx_assign "360" [< $""$ >]
(ctx_assign "/" [< $""$ -> $""$ -> $""$ >]
ctx_empty)))
[{
let "deg2turns" :=
(λ"x",$"Angle"$~$"Degrees"$~$""$
morph ((%"/"% (%"x"% des $""$) %"360"%) as $"Angle"$~$"Turns"$)) in
let "sin" := (λ"α",$"Angle"$~$"Turns"$~$""$ (%"α"% des $""$)) in
( %"sin"% (%"60"% as $"Angle"$~$"Degrees"$) )
}]
[<
$""$
>]
[{
let "deg2turns" :=
(λ"x",$"Angle"$~$"Degrees"$~$""$
morph ((%"/"% (%"x"% des $""$) %"360"%) as $"Angle"$~$"Turns"$)) in
let "sin" := (λ"α",$"Angle"$~$"Turns"$~$""$ (%"α"% des $""$)) in
(%"sin"% (%"deg2turns"% (%"60"% as $"Angle"$~$"Degrees"$)))
}])
.
Proof.
apply Expand_Let with (σ:=[< ($"Angle"$~$"Degrees"$)~$""$ ->morph ($"Angle"$~$"Turns"$)~$""$ >]).
- apply T_DescendImplicit with (τ:=[< $"Angle"$~$"Degrees"$~$""$ ->morph $"Angle"$~$"Turns"$ ~ $""$ >]).
2: {
apply TSubRepr_Refl.
apply TEq_SubMorph.
apply TEq_LadderAssocRL.
apply TEq_LadderAssocRL.
}
apply T_MorphAbs.
apply T_DescendImplicit with (τ:=[< ($"Angle"$~$"Turns"$) ~ $""$ >]).
2: {
apply TSubRepr_Refl.
apply TEq_LadderAssocLR.
}
apply T_Ascend with (τ:=[<$""$>]) (τ':=[<$"Angle"$~$"Turns"$>]).
apply T_App with (σ':=[<$""$>]) (σ:=[<$""$>]).
apply T_App with (σ':=[<$""$>]) (σ:=[<$""$>]).
var_typing.
var_typing.
apply T_Descend with (τ:=[<$"Angle"$~$"Degrees"$~$""$>]).
repr_subtype.
var_typing.
repr_subtype.
apply id_morphism_path.
var_typing.
apply id_morphism_path.
- apply T_Let with (σ:=[< $"Angle"$~$"Turns"$~$""$ -> $""$ >]).
apply T_Abs.
* apply T_Descend with (τ:=[<$"Angle"$~$"Turns"$~$""$>]).
2: repr_subtype.
var_typing.
* apply T_App with (σ':=[<($"Angle"$~$"Degrees"$)~$""$>]) (σ:=[<($"Angle"$~$"Turns"$)~$""$>]) (τ:=[<$""$>]).
apply T_DescendImplicit with (τ:=[< $"Angle"$~$"Turns"$~$""$ -> $""$ >]).
2: {
apply TSubRepr_Refl.
apply TEq_SubFun.
apply TEq_LadderAssocRL.
apply TEq_Refl.
}
var_typing.
apply T_Ascend with (τ':=[<$"Angle"$~$"Degrees"$>]) (τ:=[<$""$>]).
var_typing.
apply M_Single with (h:="deg2turns"%string).
var_typing.
- admit.
(*
- apply Expand_MorphAbs.
* apply T_DescendImplicit with (τ:=[< ($"Angle"$~$"Turns"$) ~ $""$ >]).
2: repr_subtype.
apply T_Ascend with (τ':=[<$"Angle"$~$"Turns"$>]) (τ:=[<$""$>]).
apply T_App with (σ:=[<$""$>]) (σ':=[<$""$>]).
apply T_App with (σ:=[<$""$>]) (σ':=[<$""$>]).
auto using T_Var, C_shuffle, C_take.
apply T_Descend with (τ:=[<$"Angle"$~$"Degrees"$~$""$>]).
2: repr_subtype.
var_typing.
apply id_morphism_path.
var_typing.
apply id_morphism_path.
* apply T_Abs.
apply T_DescendImplicit with (τ:=[< ($"Angle"$~$"Turns"$) ~ $""$ >]).
2: repr_subtype.
apply T_Ascend with (τ':=[<$"Angle"$~$"Turns"$>]) (τ:=[<$""$>]).
apply T_App with (σ':=[<$""$>]) (σ:=[<$""$>]).
apply T_App with (σ':=[<$""$>]) (σ:=[<$""$>]).
var_typing.
apply T_Descend with [<$"Angle"$~$"Degrees"$~$""$>].
2: repr_subtype.
var_typing.
apply id_morphism_path.
var_typing.
apply id_morphism_path.
* apply Expand_Ascend.
*)
- admit.
Admitted.