Theory W

Up to index of Isabelle/HOL/HOL-Nominal/Examples

theory W
imports Nominal

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

(* free type-variables of types *)

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