Up to index of Isabelle/HOL/HOL-Nominal/Examples
theory Compile(* $Id: Compile.thy,v 1.9 2007/07/11 09:36:07 berghofe Exp $ *) (* The definitions for a challenge suggested by Adam Chlipala *) theory Compile imports "../Nominal" begin atom_decl name nominal_datatype data = DNat | DProd "data" "data" | DSum "data" "data" nominal_datatype ty = Data "data" | Arrow "ty" "ty" ("_->_" [100,100] 100) nominal_datatype trm = Var "name" | Lam "«name»trm" ("Lam [_]._" [100,100] 100) | App "trm" "trm" | Const "nat" | Pr "trm" "trm" | Fst "trm" | Snd "trm" | InL "trm" | InR "trm" | Case "trm" "«name»trm" "«name»trm" ("Case _ of inl _ -> _ | inr _ -> _" [100,100,100,100,100] 100) nominal_datatype dataI = OneI | NatI nominal_datatype tyI = DataI "dataI" | ArrowI "tyI" "tyI" ("_->_" [100,100] 100) nominal_datatype trmI = IVar "name" | ILam "«name»trmI" ("ILam [_]._" [100,100] 100) | IApp "trmI" "trmI" | IUnit | INat "nat" | ISucc "trmI" | IAss "trmI" "trmI" ("_\<mapsto>_" [100,100] 100) | IRef "trmI" | ISeq "trmI" "trmI" ("_;;_" [100,100] 100) | Iif "trmI" "trmI" "trmI" text {* valid contexts *} inductive valid :: "(name×'a::pt_name) list => bool" where v1[intro]: "valid []" | v2[intro]: "[|valid Γ;a\<sharp>Γ|]==> valid ((a,σ)#Γ)" (* maybe dom of Γ *) text {* typing judgements for trms *} inductive typing :: "(name×ty) list=>trm=>ty=>bool" (" _ \<turnstile> _ : _ " [80,80,80] 80) where t0[intro]: "[|valid Γ; (x,τ)∈set Γ|]==> Γ \<turnstile> Var x : τ" | t1[intro]: "[|Γ \<turnstile> e1 : τ1->τ2; Γ \<turnstile> e2 : τ1|]==> Γ \<turnstile> App e1 e2 : τ2" | t2[intro]: "[|x\<sharp>Γ;((x,τ1)#Γ) \<turnstile> t : τ2|] ==> Γ \<turnstile> Lam [x].t : τ1->τ2" | t3[intro]: "valid Γ ==> Γ \<turnstile> Const n : Data(DNat)" | t4[intro]: "[|Γ \<turnstile> e1 : Data(σ1); Γ \<turnstile> e2 : Data(σ2)|] ==> Γ \<turnstile> Pr e1 e2 : Data (DProd σ1 σ2)" | t5[intro]: "[|Γ \<turnstile> e : Data(DProd σ1 σ2)|] ==> Γ \<turnstile> Fst e : Data(σ1)" | t6[intro]: "[|Γ \<turnstile> e : Data(DProd σ1 σ2)|] ==> Γ \<turnstile> Snd e : Data(σ2)" | t7[intro]: "[|Γ \<turnstile> e : Data(σ1)|] ==> Γ \<turnstile> InL e : Data(DSum σ1 σ2)" | t8[intro]: "[|Γ \<turnstile> e : Data(σ2)|] ==> Γ \<turnstile> InR e : Data(DSum σ1 σ2)" | t9[intro]: "[|x1\<sharp>Γ; x2\<sharp>Γ; Γ \<turnstile> e: Data(DSum σ1 σ2); ((x1,Data(σ1))#Γ) \<turnstile> e1 : τ; ((x2,Data(σ2))#Γ) \<turnstile> e2 : τ|] ==> Γ \<turnstile> (Case e of inl x1 -> e1 | inr x2 -> e2) : τ" text {* typing judgements for Itrms *} inductive Ityping :: "(name×tyI) list=>trmI=>tyI=>bool" (" _ I\<turnstile> _ : _ " [80,80,80] 80) where t0[intro]: "[|valid Γ; (x,τ)∈set Γ|]==> Γ I\<turnstile> IVar x : τ" | t1[intro]: "[|Γ I\<turnstile> e1 : τ1->τ2; Γ I\<turnstile> e2 : τ1|]==> Γ I\<turnstile> IApp e1 e2 : τ2" | t2[intro]: "[|x\<sharp>Γ;((x,τ1)#Γ) I\<turnstile> t : τ2|] ==> Γ I\<turnstile> ILam [x].t : τ1->τ2" | t3[intro]: "valid Γ ==> Γ I\<turnstile> IUnit : DataI(OneI)" | t4[intro]: "valid Γ ==> Γ I\<turnstile> INat(n) : DataI(NatI)" | t5[intro]: "Γ I\<turnstile> e : DataI(NatI) ==> Γ I\<turnstile> ISucc(e) : DataI(NatI)" | t6[intro]: "[|Γ I\<turnstile> e : DataI(NatI)|] ==> Γ I\<turnstile> IRef e : DataI (NatI)" | t7[intro]: "[|Γ I\<turnstile> e1 : DataI(NatI); Γ I\<turnstile> e2 : DataI(NatI)|] ==> Γ I\<turnstile> e1\<mapsto>e2 : DataI(OneI)" | t8[intro]: "[|Γ I\<turnstile> e1 : DataI(NatI); Γ I\<turnstile> e2 : τ|] ==> Γ I\<turnstile> e1;;e2 : τ" | t9[intro]: "[|Γ I\<turnstile> e: DataI(NatI); Γ I\<turnstile> e1 : τ; Γ I\<turnstile> e2 : τ|] ==> Γ I\<turnstile> Iif e e1 e2 : τ" text {* capture-avoiding substitution *} consts subst :: "'a => name => 'a => 'a" ("_[_::=_]" [100,100,100] 100) nominal_primrec "(Var x)[y::=t'] = (if x=y then t' else (Var x))" "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])" "[|x\<sharp>y; x\<sharp>t'|] ==> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])" "(Const n)[y::=t'] = Const n" "(Pr e1 e2)[y::=t'] = Pr (e1[y::=t']) (e2[y::=t'])" "(Fst e)[y::=t'] = Fst (e[y::=t'])" "(Snd e)[y::=t'] = Snd (e[y::=t'])" "(InL e)[y::=t'] = InL (e[y::=t'])" "(InR e)[y::=t'] = InR (e[y::=t'])" "[|z≠x; x\<sharp>y; x\<sharp>e; x\<sharp>e2; z\<sharp>y; z\<sharp>e; z\<sharp>e1; x\<sharp>t'; z\<sharp>t'|] ==> (Case e of inl x -> e1 | inr z -> e2)[y::=t'] = (Case (e[y::=t']) of inl x -> (e1[y::=t']) | inr z -> (e2[y::=t']))" apply(finite_guess)+ apply(rule TrueI)+ apply(simp add: abs_fresh)+ apply(fresh_guess)+ done nominal_primrec (Isubst) "(IVar x)[y::=t'] = (if x=y then t' else (IVar x))" "(IApp t1 t2)[y::=t'] = IApp (t1[y::=t']) (t2[y::=t'])" "[|x\<sharp>y; x\<sharp>t'|] ==> (ILam [x].t)[y::=t'] = ILam [x].(t[y::=t'])" "(INat n)[y::=t'] = INat n" "(IUnit)[y::=t'] = IUnit" "(ISucc e)[y::=t'] = ISucc (e[y::=t'])" "(IAss e1 e2)[y::=t'] = IAss (e1[y::=t']) (e2[y::=t'])" "(IRef e)[y::=t'] = IRef (e[y::=t'])" "(ISeq e1 e2)[y::=t'] = ISeq (e1[y::=t']) (e2[y::=t'])" "(Iif e e1 e2)[y::=t'] = Iif (e[y::=t']) (e1[y::=t']) (e2[y::=t'])" apply(finite_guess)+ apply(rule TrueI)+ apply(simp add: abs_fresh)+ apply(fresh_guess)+ done lemma Isubst_eqvt[eqvt]: fixes pi::"name prm" and t1::"trmI" and t2::"trmI" and x::"name" shows "pi•(t1[x::=t2]) = ((pi•t1)[(pi•x)::=(pi•t2)])" apply (nominal_induct t1 avoiding: x t2 rule: trmI.induct) apply (simp_all add: Isubst.simps eqvts fresh_bij) done lemma Isubst_supp: fixes t1::"trmI" and t2::"trmI" and x::"name" shows "((supp (t1[x::=t2]))::name set) ⊆ (supp t2)∪((supp t1)-{x})" apply (nominal_induct t1 avoiding: x t2 rule: trmI.induct) apply (auto simp add: Isubst.simps trmI.supp supp_atm abs_supp supp_nat) apply blast+ done lemma Isubst_fresh: fixes x::"name" and y::"name" and t1::"trmI" and t2::"trmI" assumes a: "x\<sharp>[y].t1" "x\<sharp>t2" shows "x\<sharp>(t1[y::=t2])" using a apply(auto simp add: fresh_def Isubst_supp) apply(drule rev_subsetD) apply(rule Isubst_supp) apply(simp add: abs_supp) done text {* big-step evaluation for trms *} inductive big :: "trm=>trm=>bool" ("_ \<Down> _" [80,80] 80) where b0[intro]: "Lam [x].e \<Down> Lam [x].e" | b1[intro]: "[|e1\<Down>Lam [x].e; e2\<Down>e2'; e[x::=e2']\<Down>e'|] ==> App e1 e2 \<Down> e'" | b2[intro]: "Const n \<Down> Const n" | b3[intro]: "[|e1\<Down>e1'; e2\<Down>e2'|] ==> Pr e1 e2 \<Down> Pr e1' e2'" | b4[intro]: "e\<Down>Pr e1 e2 ==> Fst e\<Down>e1" | b5[intro]: "e\<Down>Pr e1 e2 ==> Snd e\<Down>e2" | b6[intro]: "e\<Down>e' ==> InL e \<Down> InL e'" | b7[intro]: "e\<Down>e' ==> InR e \<Down> InR e'" | b8[intro]: "[|e\<Down>InL e'; e1[x::=e']\<Down>e''|] ==> Case e of inl x1 -> e1 | inr x2 -> e2 \<Down> e''" | b9[intro]: "[|e\<Down>InR e'; e2[x::=e']\<Down>e''|] ==> Case e of inl x1 -> e1 | inr x2 -> e2 \<Down> e''" inductive Ibig :: "((nat=>nat)×trmI)=>((nat=>nat)×trmI)=>bool" ("_ I\<Down> _" [80,80] 80) where m0[intro]: "(m,ILam [x].e) I\<Down> (m,ILam [x].e)" | m1[intro]: "[|(m,e1)I\<Down>(m',ILam [x].e); (m',e2)I\<Down>(m'',e3); (m'',e[x::=e3])I\<Down>(m''',e4)|] ==> (m,IApp e1 e2) I\<Down> (m''',e4)" | m2[intro]: "(m,IUnit) I\<Down> (m,IUnit)" | m3[intro]: "(m,INat(n))I\<Down>(m,INat(n))" | m4[intro]: "(m,e)I\<Down>(m',INat(n)) ==> (m,ISucc(e))I\<Down>(m',INat(n+1))" | m5[intro]: "(m,e)I\<Down>(m',INat(n)) ==> (m,IRef(e))I\<Down>(m',INat(m' n))" | m6[intro]: "[|(m,e1)I\<Down>(m',INat(n1)); (m',e2)I\<Down>(m'',INat(n2))|] ==> (m,e1\<mapsto>e2)I\<Down>(m''(n1:=n2),IUnit)" | m7[intro]: "[|(m,e1)I\<Down>(m',IUnit); (m',e2)I\<Down>(m'',e)|] ==> (m,e1;;e2)I\<Down>(m'',e)" | m8[intro]: "[|(m,e)I\<Down>(m',INat(n)); n≠0; (m',e1)I\<Down>(m'',e)|] ==> (m,Iif e e1 e2)I\<Down>(m'',e)" | m9[intro]: "[|(m,e)I\<Down>(m',INat(0)); (m',e2)I\<Down>(m'',e)|] ==> (m,Iif e e1 e2)I\<Down>(m'',e)" text {* Translation functions *} consts trans :: "trm => trmI" nominal_primrec "trans (Var x) = (IVar x)" "trans (App e1 e2) = IApp (trans e1) (trans e2)" "trans (Lam [x].e) = ILam [x].(trans e)" "trans (Const n) = INat n" "trans (Pr e1 e2) = (let limit = IRef(INat 0) in let v1 = (trans e1) in let v2 = (trans e2) in (((ISucc limit)\<mapsto>v1);;(ISucc(ISucc limit)\<mapsto>v2));;(INat 0 \<mapsto> ISucc(ISucc(limit))))" "trans (Fst e) = IRef (ISucc (trans e))" "trans (Snd e) = IRef (ISucc (ISucc (trans e)))" "trans (InL e) = (let limit = IRef(INat 0) in let v = (trans e) in (((ISucc limit)\<mapsto>INat(0));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))" "trans (InR e) = (let limit = IRef(INat 0) in let v = (trans e) in (((ISucc limit)\<mapsto>INat(1));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))" "[|x2≠x1; x1\<sharp>e; x1\<sharp>e2; x2\<sharp>e; x2\<sharp>e1|] ==> trans (Case e of inl x1 -> e1 | inr x2 -> e2) = (let v = (trans e) in let v1 = (trans e1) in let v2 = (trans e2) in Iif (IRef (ISucc v)) (v2[x2::=IRef (ISucc (ISucc v))]) (v1[x1::=IRef (ISucc (ISucc v))]))" apply(finite_guess add: Let_def)+ apply(rule TrueI)+ apply(simp add: abs_fresh Isubst_fresh)+ apply(fresh_guess add: Let_def)+ done consts trans_type :: "ty => tyI" nominal_primrec "trans_type (Data σ) = DataI(NatI)" "trans_type (τ1->τ2) = (trans_type τ1)->(trans_type τ2)" by (rule TrueI)+ end
lemma Isubst_eqvt:
pi • t1.0[x::=t2.0] = (pi • t1.0)[(pi • x)::=(pi • t2.0)]
lemma Isubst_supp:
supp (t1.0[x::=t2.0]) ⊆ supp t2.0 ∪ (supp t1.0 - {x})
lemma Isubst_fresh:
[| x \<sharp> [y].t1.0; x \<sharp> t2.0 |] ==> x \<sharp> t1.0[y::=t2.0]