# HG changeset patch # User urbanc # Date 1175039718 -7200 # Node ID 3ccb92dfb5e933459813edae65fa1845b0c980a8 # Parent c55f5631a4ecedbe9dfbc7c338bdbe4b0a6158f0 tuned proofs (taking full advantage of nominal_inductive) diff -r c55f5631a4ec -r 3ccb92dfb5e9 src/HOL/Nominal/Examples/Crary.thy --- a/src/HOL/Nominal/Examples/Crary.thy Wed Mar 28 01:29:43 2007 +0200 +++ b/src/HOL/Nominal/Examples/Crary.thy Wed Mar 28 01:55:18 2007 +0200 @@ -261,7 +261,7 @@ v_nil[intro]: "valid []" | v_cons[intro]: "\valid \;a\\\ \ valid ((a,T)#\)" -nominal_inductive valid . +equivariance valid inductive_cases2 valid_cons_elim_auto[elim]:"valid ((x,T)#\)" @@ -562,7 +562,6 @@ with ih have "(x,T\<^isub>1)#\ \ App s (Var x) \ App u (Var x) : T\<^isub>2" by simp then show "\ \ s \ u : T\<^isub>1\T\<^isub>2" using fs by (auto simp add: fresh_prod) next - (* HERE *) case (QAP_App \ p q T\<^isub>1 T\<^isub>2 s t u) have "\ \ App q t \ u : T\<^isub>2" by fact then obtain r T\<^isub>1' v where ha: "\ \ q \ r : T\<^isub>1'\T\<^isub>2" and hb: "\ \ t \ v : T\<^isub>1'" and eq: "u = App r v" diff -r c55f5631a4ec -r 3ccb92dfb5e9 src/HOL/Nominal/Examples/SN.thy --- a/src/HOL/Nominal/Examples/SN.thy Wed Mar 28 01:29:43 2007 +0200 +++ b/src/HOL/Nominal/Examples/SN.thy Wed Mar 28 01:55:18 2007 +0200 @@ -55,74 +55,15 @@ where b1[intro!]: "s1\\<^isub>\s2 \ (App s1 t)\\<^isub>\(App s2 t)" | b2[intro!]: "s1\\<^isub>\s2 \ (App t s1)\\<^isub>\(App t s2)" -| b3[intro!]: "s1\\<^isub>\s2 \ (Lam [a].s1)\\<^isub>\ (Lam [(a::name)].s2)" -| b4[intro!]: "(App (Lam [(a::name)].s1) s2)\\<^isub>\(s1[a::=s2])" +| b3[intro!]: "s1\\<^isub>\s2 \ (Lam [a].s1)\\<^isub>\ (Lam [a].s2)" +| b4[intro!]: "a\(s1,s2) \(App (Lam [a].s1) s2)\\<^isub>\(s1[a::=s2])" + +nominal_inductive Beta + by (simp_all add: abs_fresh fresh_fact) abbreviation "Beta_star" :: "lam\lam\bool" (" _ \\<^isub>\\<^sup>* _" [80,80] 80) where "t1 \\<^isub>\\<^sup>* t2 \ Beta\<^sup>*\<^sup>* t1 t2" -equivariance Beta - -lemma beta_induct[consumes 1, case_names b1 b2 b3 b4]: - fixes P :: "'a::fs_name\lam \ lam \bool" - and t :: "lam" - and s :: "lam" - and x :: "'a::fs_name" - assumes a: "t\\<^isub>\s" - and a1: "\t s1 s2 x. s1\\<^isub>\s2 \ (\z. P z s1 s2) \ P x (App s1 t) (App s2 t)" - and a2: "\t s1 s2 x. s1\\<^isub>\s2 \ (\z. P z s1 s2) \ P x (App t s1) (App t s2)" - and a3: "\a s1 s2 x. a\x \ s1\\<^isub>\s2 \ (\z. P z s1 s2) \ P x (Lam [a].s1) (Lam [a].s2)" - and a4: "\a t1 s1 x. a\x \ P x (App (Lam [a].t1) s1) (t1[a::=s1])" - shows "P x t s" -proof - - from a have "\(pi::name prm) x. P x (pi\t) (pi\s)" - proof (induct) - case b1 thus ?case using a1 by (simp, blast intro: eqvt) - next - case b2 thus ?case using a2 by (simp, blast intro: eqvt) - next - case (b3 s1 s2 a) - have j1: "s1 \\<^isub>\ s2" by fact - have j2: "\x (pi::name prm). P x (pi\s1) (pi\s2)" by fact - show ?case - proof (simp) - have f: "\c::name. c\(pi\a,pi\s1,pi\s2,x)" - by (rule exists_fresh', simp add: fs_name1) - then obtain c::"name" - where f1: "c\(pi\a)" and f2: "c\x" and f3: "c\(pi\s1)" and f4: "c\(pi\s2)" - by (force simp add: fresh_prod fresh_atm) - have x: "P x (Lam [c].(([(c,pi\a)]@pi)\s1)) (Lam [c].(([(c,pi\a)]@pi)\s2))" - using a3 f2 j1 j2 by (simp, blast intro: eqvt) - have alpha1: "(Lam [c].([(c,pi\a)]\(pi\s1))) = (Lam [(pi\a)].(pi\s1))" using f1 f3 - by (simp add: lam.inject alpha) - have alpha2: "(Lam [c].([(c,pi\a)]\(pi\s2))) = (Lam [(pi\a)].(pi\s2))" using f1 f3 - by (simp add: lam.inject alpha) - show " P x (Lam [(pi\a)].(pi\s1)) (Lam [(pi\a)].(pi\s2))" - using x alpha1 alpha2 by (simp only: pt_name2) - qed - next - case (b4 a s1 s2) - show ?case - proof (simp add: subst_eqvt) - have f: "\c::name. c\(pi\a,pi\s1,pi\s2,x)" - by (rule exists_fresh', simp add: fs_name1) - then obtain c::"name" - where f1: "c\(pi\a)" and f2: "c\x" and f3: "c\(pi\s1)" and f4: "c\(pi\s2)" - by (force simp add: fresh_prod fresh_atm) - have x: "P x (App (Lam [c].(([(c,pi\a)]@pi)\s1)) (pi\s2)) ((([(c,pi\a)]@pi)\s1)[c::=(pi\s2)])" - using a4 f2 by (blast intro!: eqvt) - have alpha1: "(Lam [c].([(c,pi\a)]\(pi\s1))) = (Lam [(pi\a)].(pi\s1))" using f1 f3 - by (simp add: lam.inject alpha) - have alpha2: "(([(c,pi\a)]@pi)\s1)[c::=(pi\s2)] = (pi\s1)[(pi\a)::=(pi\s2)]" - using f3 by (simp only: subst_rename[symmetric] pt_name2) - show "P x (App (Lam [(pi\a)].(pi\s1)) (pi\s2)) ((pi\s1)[(pi\a)::=(pi\s2)])" - using x alpha1 alpha2 by (simp only: pt_name2) - qed - qed - hence "P x (([]::name prm)\t) (([]::name prm)\s)" by blast - thus ?thesis by simp -qed - lemma supp_beta: assumes a: "t\\<^isub>\ s" shows "(supp s)\((supp t)::name set)" @@ -130,7 +71,6 @@ by (induct) (auto intro!: simp add: abs_supp lam.supp subst_supp) - lemma beta_abs: "Lam [a].t\\<^isub>\ t'\\t''. t'=Lam [a].t'' \ t\\<^isub>\ t''" apply(ind_cases2 "Lam [a].t \\<^isub>\ t'") apply(auto simp add: lam.distinct lam.inject) @@ -152,8 +92,8 @@ assumes a: "M \\<^isub>\ M'" shows "M[x::=N]\\<^isub>\ M'[x::=N]" using a -apply(nominal_induct M M' avoiding: x N rule: beta_induct) -apply(auto simp add: fresh_atm subst_lemma) +apply(nominal_induct M M' avoiding: x N rule: Beta.strong_induct) +apply(auto simp add: fresh_atm subst_lemma fresh_fact) done section {* types *} @@ -188,7 +128,7 @@ v1[intro]: "valid []" | v2[intro]: "\valid \;a\\\\ valid ((a,\)#\)" -nominal_inductive valid . +equivariance valid (* typing judgements *) @@ -218,84 +158,8 @@ | t2[intro]: "\\ \ t1 : \\\; \ \ t2 : \\\ \ \ App t1 t2 : \" | t3[intro]: "\a\\;((a,\)#\) \ t : \\ \ \ \ Lam [a].t : \\\" -lemma eqvt_typing: - fixes \ :: "(name\ty) list" - and t :: "lam" - and \ :: "ty" - and pi:: "name prm" - assumes a: "\ \ t : \" - shows "(pi\\) \ (pi\t) : \" -using a -proof (induct) - case (t1 \ a \) - have "valid (pi\\)" by (rule valid_eqvt) - moreover - have "(pi\(a,\))\((pi::name prm)\set \)" by (rule pt_set_bij2[OF pt_name_inst, OF at_name_inst]) - ultimately show "(pi\\) \ ((pi::name prm)\Var a) : \" - using typing.t1 by (force simp add: set_eqvt[symmetric]) -next - case (t3 a \ \ t \) - moreover have "(pi\a)\(pi\\)" by (simp add: fresh_bij) - ultimately show "(pi\\) \ (pi\Lam [a].t) :\\\" by force -qed (auto) - -lemma typing_induct[consumes 1, case_names t1 t2 t3]: - fixes P :: "'a::fs_name\(name\ty) list \ lam \ ty \bool" - and \ :: "(name\ty) list" - and t :: "lam" - and \ :: "ty" - and x :: "'a::fs_name" - assumes a: "\ \ t : \" - and a1: "\\ (a::name) \ x. valid \ \ (a,\) \ set \ \ P x \ (Var a) \" - and a2: "\\ \ \ t1 t2 x. - \ \ t1 : \\\ \ (\z. P z \ t1 (\\\)) \ \ \ t2 : \ \ (\z. P z \ t2 \) - \ P x \ (App t1 t2) \" - and a3: "\a \ \ \ t x. a\x \ a\\ \ ((a,\) # \) \ t : \ \ (\z. P z ((a,\)#\) t \) - \ P x \ (Lam [a].t) (\\\)" - shows "P x \ t \" -proof - - from a have "\(pi::name prm) x. P x (pi\\) (pi\t) \" - proof (induct) - case (t1 \ a \) - have j1: "valid \" by fact - have j2: "(a,\)\set \" by fact - from j1 have j3: "valid (pi\\)" by (rule valid_eqvt) - from j2 have "pi\(a,\)\pi\(set \)" by (simp only: pt_set_bij[OF pt_name_inst, OF at_name_inst]) - hence j4: "(pi\a,\)\set (pi\\)" by (simp add: eqvt) - show "P x (pi\\) (pi\(Var a)) \" using a1 j3 j4 by simp - next - case (t2 \ t1 \ \ t2) - thus ?case using a2 by (simp, blast intro: eqvt_typing) - next - case (t3 a \ \ t \) - have k1: "a\\" by fact - have k2: "((a,\)#\)\t:\" by fact - have k3: "\(pi::name prm) (x::'a::fs_name). P x (pi \((a,\)#\)) (pi\t) \" by fact - have f: "\c::name. c\(pi\a,pi\t,pi\\,x)" - by (rule exists_fresh', simp add: fs_name1) - then obtain c::"name" - where f1: "c\(pi\a)" and f2: "c\x" and f3: "c\(pi\t)" and f4: "c\(pi\\)" - by (force simp add: fresh_prod at_fresh[OF at_name_inst]) - from k1 have k1a: "(pi\a)\(pi\\)" - by (simp add: pt_fresh_left[OF pt_name_inst, OF at_name_inst] - pt_rev_pi[OF pt_name_inst, OF at_name_inst]) - have l1: "(([(c,pi\a)]@pi)\\) = (pi\\)" using f4 k1a - by (simp only: pt2[OF pt_name_inst], rule pt_fresh_fresh[OF pt_name_inst, OF at_name_inst]) - have "\x. P x (([(c,pi\a)]@pi)\((a,\)#\)) (([(c,pi\a)]@pi)\t) \" using k3 by force - hence l2: "\x. P x ((c, \)#(pi\\)) (([(c,pi\a)]@pi)\t) \" using f1 l1 - by (force simp add: pt2[OF pt_name_inst] at_calc[OF at_name_inst]) - have "(([(c,pi\a)]@pi)\((a,\)#\)) \ (([(c,pi\a)]@pi)\t) : \" using k2 by (rule eqvt_typing) - hence l3: "((c, \)#(pi\\)) \ (([(c,pi\a)]@pi)\t) : \" using l1 f1 - by (force simp add: pt2[OF pt_name_inst] at_calc[OF at_name_inst]) - have l4: "P x (pi\\) (Lam [c].(([(c,pi\a)]@pi)\t)) (\ \ \)" using f2 f4 l2 l3 a3 by auto - have alpha: "(Lam [c].([(c,pi\a)]\(pi\t))) = (Lam [(pi\a)].(pi\t))" using f1 f3 - by (simp add: lam.inject alpha) - show "P x (pi\\) (pi\(Lam [a].t)) (\ \ \)" using l4 alpha - by (simp only: pt2[OF pt_name_inst], simp) - qed - hence "P x (([]::name prm)\\) (([]::name prm)\t) \" by blast - thus "P x \ t \" by simp -qed +nominal_inductive typing + by (simp_all add: abs_fresh fresh_ty) abbreviation "sub" :: "(name\ty) list \ (name\ty) list \ bool" (" _ \ _ " [80,80] 80) where @@ -307,7 +171,7 @@ and c: "\1 \ \2" shows "\2 \ t:\" using a b c -apply(nominal_induct \1 t \ avoiding: \2 rule: typing_induct) +apply(nominal_induct \1 t \ avoiding: \2 rule: typing.strong_induct) apply(auto | atomize)+ (* FIXME: before using meta-connectives and the new induction *) (* method, this was completely automatic *) @@ -323,7 +187,7 @@ assumes a: "\ \ t : \" shows " (supp t)\set(dom_ty \)" using a -by (nominal_induct \ t \ rule: typing_induct) +by (nominal_induct \ t \ rule: typing.strong_induct) (auto simp add: lam.supp abs_supp supp_atm in_ctxt) lemma t1_elim: "\ \ Var a : \ \ valid \ \ (a,\) \ set \" @@ -339,12 +203,12 @@ lemma t3_elim: "\\ \ Lam [a].t : \;a\\\\ \\ \'. \=\\\' \ ((a,\)#\) \ t : \'" apply(ind_cases2 "\ \ Lam [a].t : \") apply(auto simp add: lam.distinct lam.inject alpha) -apply(drule_tac pi="[(a,aa)]::name prm" in eqvt_typing) +apply(drule_tac pi="[(a,aa)]::name prm" in typing_eqvt) apply(simp) apply(subgoal_tac "([(a,aa)]::name prm)\\ = \")(*A*) apply(force simp add: calc_atm) (*A*) -apply(force intro!: pt_fresh_fresh[OF pt_name_inst, OF at_name_inst]) +apply(force intro!: perm_fresh_fresh) done lemma typing_valid: @@ -427,22 +291,22 @@ and b: "\ \ t1:\" shows "\ \ t2:\" using a b -proof (nominal_induct t1 t2 avoiding: \ \ rule: beta_induct) - case (b1 t s1 s2) --"App-case left" +proof (nominal_induct t1 t2 avoiding: \ \ rule: Beta.strong_induct) + case (b1 s1 s2 t) --"App-case left" have ih: "\\ \. \ \ s1:\ \ \ \ s2 : \" by fact have "\ \ App s1 t : \" by fact hence "\\. \ \ s1 : \\\ \ \ \ t : \" by (rule t2_elim) then obtain \ where "\ \ s1 : \\\" and "\ \ t : \" by blast with ih show "\ \ App s2 t : \" by blast next - case (b2 t s1 s2) --"App-case right" + case (b2 s1 s2 t) --"App-case right" have ih: "\\ \. \ \ s1 : \ \ \ \ s2 : \" by fact have "\ \ App t s1 : \" by fact hence "\\. \ \ t : \\\ \ \ \ s1 : \" by (rule t2_elim) then obtain \ where "\ \ t : \\\" and "\ \ s1 : \" by blast with ih show "\ \ App t s2 : \" by blast next - case (b3 a s1 s2) --"Lam-case" + case (b3 s1 s2 a) --"Lam-case" have fr: "a\\" "a\\" by fact have ih: "\\ \. \ \ s1 : \ \ \ \ s2 : \" by fact have "\ \ Lam [a].s1 : \" by fact @@ -464,7 +328,7 @@ and b: "\ \ t1:\" shows "\ \ t2:\" using a b -apply(nominal_induct t1 t2 avoiding: \ \ rule: beta_induct) +apply(nominal_induct t1 t2 avoiding: \ \ rule: Beta.strong_induct) apply(auto dest!: t2_elim t3_elim intro: ty_subs simp add: ty.inject) done @@ -511,7 +375,6 @@ apply(rule TrueI)+ done - constdefs NEUT :: "lam \ bool" "NEUT t \ (\a. t=Var a)\(\t1 t2. t=App t1 t2)"