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)

lemma difference_supset:
fixes xs::"'a list"
and ys::"'a list"
and zs::"'a list"
assumes asm: "set xs ⊆ set ys"
shows "xs - ys = []"

using asm
by (induct xs) (auto)

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 *}

consts ftv :: "'a => tvar list"

overloading
ftv_prod "ftv :: ('a × 'b) => tvar list"
ftv_tvar "ftv :: tvar => tvar list"
ftv_var "ftv :: var => tvar list"
ftv_list "ftv :: 'a list => tvar list"
ftv_ty "ftv :: ty => tvar list"
begin


primrec
ftv_prod
where
"ftv_prod (x, y) = (ftv x) @ (ftv y)"


definition
ftv_tvar :: "tvar => tvar list"
where
[simp]: "ftv_tvar X ≡ [(X::tvar)]"


definition
ftv_var :: "var => tvar list"
where
[simp]: "ftv_var x ≡ []"


primrec
ftv_list
where
"ftv_list [] = []"
| "ftv_list (x#xs) = (ftv x)@(ftv_list xs)"


nominal_primrec
ftv_ty :: "ty => tvar list"
where
"ftv_ty (TVar X) = [X]"
| "ftv_ty (T1 ->T2) = (ftv_ty T1) @ (ftv_ty T2)"

by (rule TrueI)+

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)+


overloading
ftv_tyS "ftv :: tyS => tvar list"
begin


nominal_primrec
ftv_tyS :: "tyS => tvar list"
where
"ftv_tyS (Ty T) = ((ftv (T::ty))::tvar list)"
| "ftv_tyS (∀[X].S) = (ftv_tyS 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

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"

consts
psubst :: "Subst => 'a => 'a" ("_<_>" [100,60] 120)


abbreviation
subst :: "'a => 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)

lemma lookup_fresh:
fixes X::"tvar"
assumes a: "X\<sharp>ϑ"
shows "lookup ϑ X = TVar X"

using a
by (induct ϑ)
(auto simp add: fresh_list_cons fresh_prod fresh_atm)


overloading
psubst_ty "psubst :: Subst => ty => ty"
begin


nominal_primrec
psubst_ty
where
"ϑ<TVar X> = lookup ϑ X"
| "ϑ<T1 -> T2> = (ϑ<T1>) -> (ϑ<T2>)"

by (rule TrueI)+

end

lemma psubst_ty_eqvt[eqvt]:
fixes pi::"tvar prm"
and ϑ::"Subst"
and T::"ty"
shows "pi•(ϑ<T>) = (pi•ϑ)<(pi•T)>"

by (induct T rule: ty.induct) (simp_all add: eqvts)

overloading
psubst_tyS "psubst :: Subst => tyS => tyS"
begin


nominal_primrec
psubst_tyS :: "Subst => tyS => tyS"
where
"ϑ<(Ty T)> = Ty (ϑ<T>)"
| "X\<sharp>ϑ ==> ϑ<(∀[X].S)> = ∀[X].(ϑ<S>)"

apply(finite_guess add: psubst_ty_eqvt fs_tvar1)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess add: psubst_ty_eqvt fs_tvar1)+
done

end

overloading
psubst_Ctxt "psubst :: Subst => Ctxt => Ctxt"
begin


fun
psubst_Ctxt :: "Subst => Ctxt => Ctxt"
where
"psubst_Ctxt ϑ [] = []"
| "psubst_Ctxt ϑ ((x,S)#Γ) = (x,ϑ<S>)#(psubst_Ctxt ϑ Γ)"


end

lemma fresh_lookup:
fixes X::"tvar"
and ϑ::"Subst"
and Y::"tvar"
assumes asms: "X\<sharp>Y" "X\<sharp>ϑ"
shows "X\<sharp>(lookup ϑ Y)"

using asms
by (induct ϑ)
(auto simp add: fresh_list_cons fresh_prod fresh_atm)


lemma fresh_psubst_ty:
fixes X::"tvar"
and ϑ::"Subst"
and T::"ty"
assumes asms: "X\<sharp>ϑ" "X\<sharp>T"
shows "X\<sharp>ϑ<T>"

using asms
by (nominal_induct T rule: ty.strong_induct)
(auto simp add: fresh_list_append fresh_list_cons fresh_prod fresh_lookup)


lemma fresh_psubst_tyS:
fixes X::"tvar"
and ϑ::"Subst"
and S::"tyS"
assumes asms: "X\<sharp>ϑ" "X\<sharp>S"
shows "X\<sharp>ϑ<S>"

using asms
by (nominal_induct S avoiding: ϑ X rule: tyS.strong_induct)
(auto simp add: fresh_psubst_ty abs_fresh)


lemma fresh_psubst_Ctxt:
fixes X::"tvar"
and ϑ::"Subst"
and Γ::"Ctxt"
assumes asms: "X\<sharp>ϑ" "X\<sharp>Γ"
shows "X\<sharp>ϑ<Γ>"

using asms
by (induct Γ)
(auto simp add: fresh_psubst_tyS fresh_list_cons)


lemma subst_freshfact2_ty:
fixes X::"tvar"
and Y::"tvar"
and T::"ty"
assumes asms: "X\<sharp>S"
shows "X\<sharp>T[X::=S]"

using asms
by (nominal_induct T rule: ty.strong_induct)
(auto simp add: fresh_atm)


text {* instance of a type scheme *}
inductive
inst :: "ty => tyS => bool"("_ \<prec> _" [50,51] 50)
where
I_Ty[intro]: "T \<prec> (Ty T)"
| I_All[intro]: "[|X\<sharp>T'; T \<prec> S|] ==> T[X::=T'] \<prec> ∀[X].S"


equivariance inst[tvar]

nominal_inductive inst
by (simp_all add: abs_fresh subst_freshfact2_ty)

lemma subst_forget_ty:
fixes T::"ty"
and X::"tvar"
assumes a: "X\<sharp>T"
shows "T[X::=S] = T"

using a
by (nominal_induct T rule: ty.strong_induct)
(auto simp add: fresh_atm)


lemma psubst_ty_lemma:
fixes ϑ::"Subst"
and X::"tvar"
and T'::"ty"
and T::"ty"
assumes a: "X\<sharp>ϑ"
shows "ϑ<T[X::=T']> = (ϑ<T>)[X::=ϑ<T'>]"

using a
apply(nominal_induct T avoiding: ϑ X T' rule: ty.strong_induct)
apply(auto simp add: ty.inject lookup_fresh)
apply(rule sym)
apply(rule subst_forget_ty)
apply(rule fresh_lookup)
apply(simp_all add: fresh_atm)
done

lemma general_preserved:
fixes ϑ::"Subst"
assumes a: "T \<prec> S"
shows "ϑ<T> \<prec> ϑ<S>"

using a
apply(nominal_induct T S avoiding: ϑ rule: inst.strong_induct)
apply(auto)[1]
apply(simp add: psubst_ty_lemma)
apply(rule_tac I_All)
apply(simp add: fresh_psubst_ty)
apply(simp)
done


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"


equivariance typing[tvar]

lemma fresh_tvar_trm:
fixes X::"tvar"
and t::"trm"
shows "X\<sharp>t"

by (nominal_induct t rule: trm.strong_induct)
(simp_all add: fresh_atm abs_fresh)


lemma ftv_ty:
fixes T::"ty"
shows "supp T = set (ftv T)"

by (nominal_induct T rule: ty.strong_induct)
(simp_all add: ty.supp supp_atm)


lemma ftv_tyS:
fixes S::"tyS"
shows "supp S = set (ftv S)"

by (nominal_induct S rule: tyS.strong_induct)
(auto simp add: tyS.supp abs_supp ftv_ty)


lemma ftv_Ctxt:
fixes Γ::"Ctxt"
shows "supp Γ = 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:
fixes Tvs::"tvar list"
shows "supp Tvs = set Tvs"

by (induct Tvs)
(simp_all add: supp_list_nil supp_list_cons supp_atm)


lemma difference_supp:
fixes xs ys::"tvar list"
shows "((supp (xs - 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:
fixes xs::"tvar list"
shows "set xs = 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:
fixes S::"tvar set"
assumes "x ∈ S"
and "S \<sharp>* z"
shows "x \<sharp> z"

using prems 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:
shows "(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:
shows "T - (T - U) = T ∩ U"

by blast

lemma close_supp:
shows "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

lemma ftv_ty_subst:
fixes T::"ty"
and ϑ::"Subst"
and X Y ::"tvar"
assumes a1: "X ∈ set (ftv T)"
and a2: "Y ∈ set (ftv (lookup ϑ X))"
shows "Y ∈ set (ftv (ϑ<T>))"

using a1 a2
by (nominal_induct T rule: ty.strong_induct) (auto)

lemma ftv_tyS_subst:
fixes S::"tyS"
and ϑ::"Subst"
and X Y::"tvar"
assumes a1: "X ∈ set (ftv S)"
and a2: "Y ∈ set (ftv (lookup ϑ X))"
shows "Y ∈ set (ftv (ϑ<S>))"

using a1 a2
by (nominal_induct S avoiding: ϑ Y rule: tyS.strong_induct)
(auto simp add: ftv_ty_subst fresh_atm)


lemma ftv_Ctxt_subst:
fixes Γ::"Ctxt"
and ϑ::"Subst"
assumes a1: "X ∈ set (ftv Γ)"
and a2: "Y ∈ set (ftv (lookup ϑ X))"
shows "Y ∈ set (ftv (ϑ<Γ>))"

using a1 a2
by (induct Γ)
(auto simp add: ftv_tyS_subst)


lemma gen_preserved1:
assumes asm: "Xs \<sharp>* ϑ"
shows "ϑ<gen T Xs> = gen (ϑ<T>) Xs"

using asm
by (induct Xs)
(auto simp add: fresh_star_def)


lemma gen_preserved2:
fixes T::"ty"
and Γ::"Ctxt"
assumes asm: "((ftv T) - (ftv Γ)) \<sharp>* ϑ"
shows "((ftv (ϑ<T>)) - (ftv (ϑ<Γ>))) = ((ftv T) - (ftv Γ))"

using asm
apply(nominal_induct T rule: ty.strong_induct)
apply(auto simp add: fresh_star_def)
apply(simp add: lookup_fresh)
apply(simp add: ftv_Ctxt[symmetric])
apply(fold fresh_def)
apply(rule fresh_psubst_Ctxt)
apply(assumption)
apply(assumption)
apply(rule difference_supset)
apply(auto)
apply(simp add: ftv_Ctxt_subst)
done

lemma close_preserved:
fixes Γ::"Ctxt"
assumes asm: "((ftv T) - (ftv Γ)) \<sharp>* ϑ"
shows "ϑ<close Γ T> = close (ϑ<Γ>) (ϑ<T>)"

using asm
by (simp add: gen_preserved1 gen_preserved2)

lemma var_fresh_for_ty:
fixes x::"var"
and T::"ty"
shows "x\<sharp>T"

by (nominal_induct T rule: ty.strong_induct)
(simp_all add: fresh_atm)


lemma var_fresh_for_tyS:
fixes x::"var"
and S::"tyS"
shows "x\<sharp>S"

by (nominal_induct S rule: tyS.strong_induct)
(simp_all add: abs_fresh var_fresh_for_ty)


lemma psubst_fresh_Ctxt:
fixes x::"var"
and Γ::"Ctxt"
and ϑ::"Subst"
shows "x\<sharp>ϑ<Γ> = x\<sharp>Γ"

by (induct Γ)
(auto simp add: fresh_list_cons fresh_list_nil fresh_prod var_fresh_for_tyS)


lemma psubst_valid:
fixes ϑ::Subst
and Γ::Ctxt
assumes a: "valid Γ"
shows "valid (ϑ<Γ>)"

using a
by (induct)
(auto simp add: psubst_fresh_Ctxt)


lemma psubst_in:
fixes Γ::"Ctxt"
and ϑ::"Subst"
and pi::"tvar prm"
and S::"tyS"
assumes a: "(x,S)∈set Γ"
shows "(x,ϑ<S>)∈set (ϑ<Γ>)"

using a
by (induct Γ)
(auto simp add: calc_atm)



lemma typing_preserved:
fixes ϑ::"Subst"
and pi::"tvar prm"
assumes a: "Γ \<turnstile> t : T"
shows "(ϑ<Γ>) \<turnstile> t : (ϑ<T>)"

using a
proof (nominal_induct Γ t T avoiding: ϑ rule: typing.strong_induct)
case (T_VAR Γ x S T)
have a1: "valid Γ" by fact
have a2: "(x, S) ∈ set Γ" by fact
have a3: "T \<prec> S" by fact
have "valid (ϑ<Γ>)" using a1 by (simp add: psubst_valid)
moreover
have "(x,ϑ<S>)∈set (ϑ<Γ>)" using a2 by (simp add: psubst_in)
moreover
have "ϑ<T> \<prec> ϑ<S>" using a3 by (simp add: general_preserved)
ultimately show "(ϑ<Γ>) \<turnstile> Var x : (ϑ<T>)" by (simp add: typing.T_VAR)
next
case (T_APP Γ t1 T1 T2 t2)
have "ϑ<Γ> \<turnstile> t1 : ϑ<T1 -> T2>" by fact
then have "ϑ<Γ> \<turnstile> t1 : (ϑ<T1>) -> (ϑ<T2>)" by simp
moreover
have "ϑ<Γ> \<turnstile> t2 : ϑ<T1>" by fact
ultimately show "ϑ<Γ> \<turnstile> App t1 t2 : ϑ<T2>" by (simp add: typing.T_APP)
next
case (T_LAM x Γ T1 t T2)
fix pi::"tvar prm" and ϑ::"Subst"
have "x\<sharp>Γ" by fact
then have "x\<sharp>ϑ<Γ>" by (simp add: psubst_fresh_Ctxt)
moreover
have "ϑ<((x, Ty T1)#Γ)> \<turnstile> t : ϑ<T2>" by fact
then have "((x, Ty (ϑ<T1>))#(ϑ<Γ>)) \<turnstile> t : ϑ<T2>" by (simp add: calc_atm)
ultimately show "ϑ<Γ> \<turnstile> Lam [x].t : ϑ<T1 -> T2>" by (simp add: typing.T_LAM)
next
case (T_LET x Γ t1 T1 t2 T2)
have vc: "((ftv T1) - (ftv Γ)) \<sharp>* ϑ" by fact
have "x\<sharp>Γ" by fact
then have a1: "x\<sharp>ϑ<Γ>" by (simp add: calc_atm psubst_fresh_Ctxt)
have a2: "ϑ<Γ> \<turnstile> t1 : ϑ<T1>" by fact
have a3: "ϑ<((x, close Γ T1)#Γ)> \<turnstile> t2 : ϑ<T2>" by fact
from a2 a3 show "ϑ<Γ> \<turnstile> Let x be t1 in t2 : ϑ<T2>"
apply -
apply(rule better_T_LET)
apply(rule a1)
apply(rule a2)
apply(simp add: close_preserved vc)
done
qed



end