theory W
imports Nominal
begin
text {* Example for strong induction rules avoiding sets of atoms. *}
atom_decl tvar var
abbreviation
"difference_list" :: "'a list => 'a list => 'a list" ("_ - _" [60,60] 60)
where
"xs - ys ≡ [x \<leftarrow> xs. x∉set ys]"
lemma difference_eqvt_tvar[eqvt]:
fixes pi::"tvar prm"
and Xs Ys::"tvar list"
shows "pi•(Xs - Ys) = (pi•Xs) - (pi•Ys)"
by (induct Xs) (simp_all add: eqvts)
lemma difference_fresh:
fixes X::"tvar"
and Xs Ys::"tvar list"
assumes a: "X∈set Ys"
shows "X\<sharp>(Xs - Ys)"
using a
by (induct Xs) (auto simp add: fresh_list_nil fresh_list_cons fresh_atm)
nominal_datatype ty =
TVar "tvar"
| Fun "ty" "ty" ("_->_" [100,100] 100)
nominal_datatype tyS =
Ty "ty"
| ALL "«tvar»tyS" ("∀[_]._" [100,100] 100)
nominal_datatype trm =
Var "var"
| App "trm" "trm"
| Lam "«var»trm" ("Lam [_]._" [100,100] 100)
| Let "«var»trm" "trm"
abbreviation
LetBe :: "var => trm => trm => trm" ("Let _ be _ in _" [100,100,100] 100)
where
"Let x be t1 in t2 ≡ trm.Let x t2 t1"
types
Ctxt = "(var×tyS) list"
text {* free type variables *}
class ftv =
fixes ftv :: "'a => tvar list"
instantiation * :: (ftv, ftv) ftv
begin
primrec ftv_prod
where
"ftv (x::'a::ftv, y::'b::ftv) = (ftv x)@(ftv y)"
instance ..
end
instantiation tvar :: ftv
begin
definition
ftv_of_tvar[simp]: "ftv X ≡ [(X::tvar)]"
instance ..
end
instantiation var :: ftv
begin
definition
ftv_of_var[simp]: "ftv (x::var) ≡ []"
instance ..
end
instantiation list :: (ftv) ftv
begin
primrec ftv_list
where
"ftv [] = []"
| "ftv (x#xs) = (ftv x)@(ftv xs)"
instance ..
end
instantiation ty :: ftv
begin
nominal_primrec ftv_ty
where
"ftv (TVar X) = [X]"
| "ftv (T1->T2) = (ftv T1)@(ftv T2)"
by (rule TrueI)+
instance ..
end
lemma ftv_ty_eqvt[eqvt]:
fixes pi::"tvar prm"
and T::"ty"
shows "pi•(ftv T) = ftv (pi•T)"
by (nominal_induct T rule: ty.strong_induct)
(perm_simp add: append_eqvt)+
instantiation tyS :: ftv
begin
nominal_primrec ftv_tyS
where
"ftv (Ty T) = ftv T"
| "ftv (∀[X].S) = (ftv S) - [X]"
apply(finite_guess add: ftv_ty_eqvt fs_tvar1)+
apply(rule TrueI)+
apply(rule difference_fresh)
apply(simp)
apply(fresh_guess add: ftv_ty_eqvt fs_tvar1)+
done
instance ..
end
lemma ftv_tyS_eqvt[eqvt]:
fixes pi::"tvar prm"
and S::"tyS"
shows "pi•(ftv S) = ftv (pi•S)"
apply(nominal_induct S rule: tyS.strong_induct)
apply(simp add: eqvts)
apply(simp only: ftv_tyS.simps)
apply(simp only: eqvts)
apply(simp add: eqvts)
done
lemma ftv_Ctxt_eqvt[eqvt]:
fixes pi::"tvar prm"
and Γ::"Ctxt"
shows "pi•(ftv Γ) = ftv (pi•Γ)"
by (induct Γ) (auto simp add: eqvts)
text {* Valid *}
inductive
valid :: "Ctxt => bool"
where
V_Nil[intro]: "valid []"
| V_Cons[intro]: "[|valid Γ;x\<sharp>Γ|]==> valid ((x,S)#Γ)"
equivariance valid
text {* General *}
consts
gen :: "ty => tvar list => tyS"
primrec
"gen T [] = Ty T"
"gen T (X#Xs) = ∀[X].(gen T Xs)"
lemma gen_eqvt[eqvt]:
fixes pi::"tvar prm"
shows "pi•(gen T Xs) = gen (pi•T) (pi•Xs)"
by (induct Xs) (simp_all add: eqvts)
abbreviation
close :: "Ctxt => ty => tyS"
where
"close Γ T ≡ gen T ((ftv T) - (ftv Γ))"
lemma close_eqvt[eqvt]:
fixes pi::"tvar prm"
shows "pi•(close Γ T) = close (pi•Γ) (pi•T)"
by (simp_all only: eqvts)
text {* Substitution *}
types Subst = "(tvar×ty) list"
class psubst =
fixes psubst :: "Subst => 'a => 'a" ("_<_>" [100,60] 120)
abbreviation
subst :: "'a::psubst => tvar => ty => 'a" ("_[_::=_]" [100,100,100] 100)
where
"smth[X::=T] ≡ ([(X,T)])<smth>"
fun
lookup :: "Subst => tvar => ty"
where
"lookup [] X = TVar X"
| "lookup ((Y,T)#ϑ) X = (if X=Y then T else lookup ϑ X)"
lemma lookup_eqvt[eqvt]:
fixes pi::"tvar prm"
shows "pi•(lookup ϑ X) = lookup (pi•ϑ) (pi•X)"
by (induct ϑ) (auto simp add: eqvts)
instantiation ty :: psubst
begin
nominal_primrec psubst_ty
where
"ϑ<TVar X> = lookup ϑ X"
| "ϑ<T1 -> T2> = (ϑ<T1>) -> (ϑ<T2>)"
by (rule TrueI)+
instance ..
end
lemma psubst_ty_eqvt[eqvt]:
fixes pi1::"tvar prm"
and ϑ::"Subst"
and T::"ty"
shows "pi1•(ϑ<T>) = (pi1•ϑ)<(pi1•T)>"
by (induct T rule: ty.induct) (simp_all add: eqvts)
text {* instance *}
inductive
general :: "ty => tyS => bool"("_ \<prec> _" [50,51] 50)
where
G_Ty[intro]: "T \<prec> (Ty T)"
| G_All[intro]: "[|X\<sharp>T'; (T::ty) \<prec> S|] ==> T[X::=T'] \<prec> ∀[X].S"
equivariance general[tvar]
text{* typing judgements *}
inductive
typing :: "Ctxt => trm => ty => bool" (" _ \<turnstile> _ : _ " [60,60,60] 60)
where
T_VAR[intro]: "[|valid Γ; (x,S)∈set Γ; T \<prec> S|]==> Γ \<turnstile> Var x : T"
| T_APP[intro]: "[|Γ \<turnstile> t1 : T1->T2; Γ \<turnstile> t2 : T1|]==> Γ \<turnstile> App t1 t2 : T2"
| T_LAM[intro]: "[|x\<sharp>Γ;((x,Ty T1)#Γ) \<turnstile> t : T2|] ==> Γ \<turnstile> Lam [x].t : T1->T2"
| T_LET[intro]: "[|x\<sharp>Γ; Γ \<turnstile> t1 : T1; ((x,close Γ T1)#Γ) \<turnstile> t2 : T2; set (ftv T1 - ftv Γ) \<sharp>* T2|] ==> Γ \<turnstile> Let x be t1 in t2 : T2"
lemma fresh_star_tvar_eqvt[eqvt]:
"(pi::tvar prm) • ((Xs::tvar set) \<sharp>* (x::'a::{cp_tvar_tvar,pt_tvar})) = (pi • Xs) \<sharp>* (pi • x)"
by (simp only: pt_fresh_star_bij_ineq(1) [OF pt_tvar_inst pt_tvar_inst at_tvar_inst cp_tvar_tvar_inst] perm_bool)
equivariance typing[tvar]
lemma fresh_tvar_trm: "(X::tvar) \<sharp> (t::trm)"
by (nominal_induct t rule: trm.strong_induct) (simp_all add: fresh_atm abs_fresh)
lemma ftv_ty: "supp (T::ty) = set (ftv T)"
by (nominal_induct T rule: ty.strong_induct) (simp_all add: ty.supp supp_atm)
lemma ftv_tyS: "supp (s::tyS) = set (ftv s)"
by (nominal_induct s rule: tyS.strong_induct) (auto simp add: tyS.supp abs_supp ftv_ty)
lemma ftv_Ctxt: "supp (Γ::Ctxt) = set (ftv Γ)"
apply (induct Γ)
apply (simp_all add: supp_list_nil supp_list_cons)
apply (case_tac a)
apply (simp add: supp_prod supp_atm ftv_tyS)
done
lemma ftv_tvars: "supp (Tvs::tvar list) = set Tvs"
by (induct Tvs) (simp_all add: supp_list_nil supp_list_cons supp_atm)
lemma difference_supp: "((supp ((xs::tvar list) - ys))::tvar set) = supp xs - supp ys"
by (induct xs) (auto simp add: supp_list_nil supp_list_cons ftv_tvars)
lemma set_supp_eq: "set (xs::tvar list) = supp xs"
by (induct xs) (simp_all add: supp_list_nil supp_list_cons supp_atm)
nominal_inductive2 typing
avoids T_LET: "set (ftv T1 - ftv Γ)"
apply (simp add: fresh_star_def fresh_def ftv_Ctxt)
apply (simp add: fresh_star_def fresh_tvar_trm)
apply assumption
apply simp
done
lemma perm_fresh_fresh_aux:
"∀(x,y)∈set (pi::tvar prm). x \<sharp> z ∧ y \<sharp> z ==> pi • (z::'a::pt_tvar) = z"
apply (induct pi rule: rev_induct)
apply simp
apply (simp add: split_paired_all pt_tvar2)
apply (frule_tac x="(a, b)" in bspec)
apply simp
apply (simp add: perm_fresh_fresh)
done
lemma freshs_mem: "x ∈ (S::tvar set) ==> S \<sharp>* z ==> x \<sharp> z"
by (simp add: fresh_star_def)
lemma fresh_gen_set:
fixes X::"tvar"
and Xs::"tvar list"
assumes asm: "X∈set Xs"
shows "X\<sharp>gen T Xs"
using asm
apply(induct Xs)
apply(simp)
apply(case_tac "X=a")
apply(simp add: abs_fresh)
apply(simp add: abs_fresh)
done
lemma close_fresh:
fixes Γ::"Ctxt"
shows "∀(X::tvar)∈set ((ftv T) - (ftv Γ)). X\<sharp>(close Γ T)"
by (simp add: fresh_gen_set)
lemma gen_supp: "(supp (gen T Xs)::tvar set) = supp T - supp Xs"
by (induct Xs) (auto simp add: supp_list_nil supp_list_cons tyS.supp abs_supp supp_atm)
lemma minus_Int_eq: "T - (T - U) = T ∩ U"
by blast
lemma close_supp: "supp (close Γ T) = set (ftv T) ∩ set (ftv Γ)"
apply (simp add: gen_supp difference_supp ftv_ty ftv_Ctxt)
apply (simp only: set_supp_eq minus_Int_eq)
done
lemma better_T_LET:
assumes x: "x\<sharp>Γ"
and t1: "Γ \<turnstile> t1 : T1"
and t2: "((x,close Γ T1)#Γ) \<turnstile> t2 : T2"
shows "Γ \<turnstile> Let x be t1 in t2 : T2"
proof -
have fin: "finite (set (ftv T1 - ftv Γ))" by simp
obtain pi where pi1: "(pi • set (ftv T1 - ftv Γ)) \<sharp>* (T2, Γ)"
and pi2: "set pi ⊆ set (ftv T1 - ftv Γ) × (pi • set (ftv T1 - ftv Γ))"
by (rule at_set_avoiding [OF at_tvar_inst fin fs_tvar1, of "(T2, Γ)"])
from pi1 have pi1': "(pi • set (ftv T1 - ftv Γ)) \<sharp>* Γ"
by (simp add: fresh_star_prod)
have Gamma_fresh: "∀(x,y)∈set pi. x \<sharp> Γ ∧ y \<sharp> Γ"
apply (rule ballI)
apply (simp add: split_paired_all)
apply (drule subsetD [OF pi2])
apply (erule SigmaE)
apply (drule freshs_mem [OF _ pi1'])
apply (simp add: ftv_Ctxt [symmetric] fresh_def)
done
have close_fresh': "∀(x, y)∈set pi. x \<sharp> close Γ T1 ∧ y \<sharp> close Γ T1"
apply (rule ballI)
apply (simp add: split_paired_all)
apply (drule subsetD [OF pi2])
apply (erule SigmaE)
apply (drule bspec [OF close_fresh])
apply (drule freshs_mem [OF _ pi1'])
apply (simp add: fresh_def close_supp ftv_Ctxt)
done
note x
moreover from Gamma_fresh perm_boolI [OF t1, of pi]
have "Γ \<turnstile> t1 : pi • T1"
by (simp add: perm_fresh_fresh_aux eqvts fresh_tvar_trm)
moreover from t2 close_fresh'
have "(x,(pi • close Γ T1))#Γ \<turnstile> t2 : T2"
by (simp add: perm_fresh_fresh_aux)
with Gamma_fresh have "(x,close Γ (pi • T1))#Γ \<turnstile> t2 : T2"
by (simp add: close_eqvt perm_fresh_fresh_aux)
moreover from pi1 Gamma_fresh
have "set (ftv (pi • T1) - ftv Γ) \<sharp>* T2"
by (simp only: eqvts fresh_star_prod perm_fresh_fresh_aux)
ultimately show ?thesis by (rule T_LET)
qed
end