diff -r 41137dc935ff -r 8193bbaa07fe Nominal/Abs.thy --- a/Nominal/Abs.thy Sun Nov 14 12:09:14 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,587 +0,0 @@ -theory Abs -imports "../Nominal-General/Nominal2_Base" - "../Nominal-General/Nominal2_Eqvt" - "Quotient" - "Quotient_List" - "Quotient_Product" -begin - - -section {* Abstractions *} - -fun - alpha_set -where - alpha_set[simp del]: - "alpha_set (bs, x) R f pi (cs, y) \ - f x - bs = f y - cs \ - (f x - bs) \* pi \ - R (pi \ x) y \ - pi \ bs = cs" - -fun - alpha_res -where - alpha_res[simp del]: - "alpha_res (bs, x) R f pi (cs, y) \ - f x - bs = f y - cs \ - (f x - bs) \* pi \ - R (pi \ x) y" - -fun - alpha_lst -where - alpha_lst[simp del]: - "alpha_lst (bs, x) R f pi (cs, y) \ - f x - set bs = f y - set cs \ - (f x - set bs) \* pi \ - R (pi \ x) y \ - pi \ bs = cs" - -lemmas alphas = alpha_set.simps alpha_res.simps alpha_lst.simps - -notation - alpha_set ("_ \set _ _ _ _" [100, 100, 100, 100, 100] 100) and - alpha_res ("_ \res _ _ _ _" [100, 100, 100, 100, 100] 100) and - alpha_lst ("_ \lst _ _ _ _" [100, 100, 100, 100, 100] 100) - -section {* Mono *} - -lemma [mono]: - shows "R1 \ R2 \ alpha_set bs R1 \ alpha_set bs R2" - and "R1 \ R2 \ alpha_res bs R1 \ alpha_res bs R2" - and "R1 \ R2 \ alpha_lst cs R1 \ alpha_lst cs R2" - by (case_tac [!] bs, case_tac [!] cs) - (auto simp add: le_fun_def le_bool_def alphas) - -section {* Equivariance *} - -lemma alpha_eqvt[eqvt]: - shows "(bs, x) \set R f q (cs, y) \ (p \ bs, p \ x) \set (p \ R) (p \ f) (p \ q) (p \ cs, p \ y)" - and "(bs, x) \res R f q (cs, y) \ (p \ bs, p \ x) \res (p \ R) (p \ f) (p \ q) (p \ cs, p \ y)" - and "(ds, x) \lst R f q (es, y) \ (p \ ds, p \ x) \lst (p \ R) (p \ f) (p \ q) (p \ es, p \ y)" - unfolding alphas - unfolding permute_eqvt[symmetric] - unfolding set_eqvt[symmetric] - unfolding permute_fun_app_eq[symmetric] - unfolding Diff_eqvt[symmetric] - by (auto simp add: permute_bool_def fresh_star_permute_iff) - - -section {* Equivalence *} - -lemma alpha_refl: - assumes a: "R x x" - shows "(bs, x) \set R f 0 (bs, x)" - and "(bs, x) \res R f 0 (bs, x)" - and "(cs, x) \lst R f 0 (cs, x)" - using a - unfolding alphas - unfolding fresh_star_def - by (simp_all add: fresh_zero_perm) - -lemma alpha_sym: - assumes a: "R (p \ x) y \ R (- p \ y) x" - shows "(bs, x) \set R f p (cs, y) \ (cs, y) \set R f (- p) (bs, x)" - and "(bs, x) \res R f p (cs, y) \ (cs, y) \res R f (- p) (bs, x)" - and "(ds, x) \lst R f p (es, y) \ (es, y) \lst R f (- p) (ds, x)" - unfolding alphas fresh_star_def - using a - by (auto simp add: fresh_minus_perm) - -lemma alpha_trans: - assumes a: "\R (p \ x) y; R (q \ y) z\ \ R ((q + p) \ x) z" - shows "\(bs, x) \set R f p (cs, y); (cs, y) \set R f q (ds, z)\ \ (bs, x) \set R f (q + p) (ds, z)" - and "\(bs, x) \res R f p (cs, y); (cs, y) \res R f q (ds, z)\ \ (bs, x) \res R f (q + p) (ds, z)" - and "\(es, x) \lst R f p (gs, y); (gs, y) \lst R f q (hs, z)\ \ (es, x) \lst R f (q + p) (hs, z)" - using a - unfolding alphas fresh_star_def - by (simp_all add: fresh_plus_perm) - -lemma alpha_sym_eqvt: - assumes a: "R (p \ x) y \ R y (p \ x)" - and b: "p \ R = R" - shows "(bs, x) \set R f p (cs, y) \ (cs, y) \set R f (- p) (bs, x)" - and "(bs, x) \res R f p (cs, y) \ (cs, y) \res R f (- p) (bs, x)" - and "(ds, x) \lst R f p (es, y) \ (es, y) \lst R f (- p) (ds, x)" -apply(auto intro!: alpha_sym) -apply(drule_tac [!] a) -apply(rule_tac [!] p="p" in permute_boolE) -apply(perm_simp add: permute_minus_cancel b) -apply(assumption) -apply(perm_simp add: permute_minus_cancel b) -apply(assumption) -apply(perm_simp add: permute_minus_cancel b) -apply(assumption) -done - -lemma alpha_set_trans_eqvt: - assumes b: "(cs, y) \set R f q (ds, z)" - and a: "(bs, x) \set R f p (cs, y)" - and d: "q \ R = R" - and c: "\R (p \ x) y; R y (- q \ z)\ \ R (p \ x) (- q \ z)" - shows "(bs, x) \set R f (q + p) (ds, z)" -apply(rule alpha_trans) -defer -apply(rule a) -apply(rule b) -apply(drule c) -apply(rule_tac p="q" in permute_boolE) -apply(perm_simp add: permute_minus_cancel d) -apply(assumption) -apply(rotate_tac -1) -apply(drule_tac p="q" in permute_boolI) -apply(perm_simp add: permute_minus_cancel d) -apply(simp add: permute_eqvt[symmetric]) -done - -lemma alpha_res_trans_eqvt: - assumes b: "(cs, y) \res R f q (ds, z)" - and a: "(bs, x) \res R f p (cs, y)" - and d: "q \ R = R" - and c: "\R (p \ x) y; R y (- q \ z)\ \ R (p \ x) (- q \ z)" - shows "(bs, x) \res R f (q + p) (ds, z)" -apply(rule alpha_trans) -defer -apply(rule a) -apply(rule b) -apply(drule c) -apply(rule_tac p="q" in permute_boolE) -apply(perm_simp add: permute_minus_cancel d) -apply(assumption) -apply(rotate_tac -1) -apply(drule_tac p="q" in permute_boolI) -apply(perm_simp add: permute_minus_cancel d) -apply(simp add: permute_eqvt[symmetric]) -done - -lemma alpha_lst_trans_eqvt: - assumes b: "(cs, y) \lst R f q (ds, z)" - and a: "(bs, x) \lst R f p (cs, y)" - and d: "q \ R = R" - and c: "\R (p \ x) y; R y (- q \ z)\ \ R (p \ x) (- q \ z)" - shows "(bs, x) \lst R f (q + p) (ds, z)" -apply(rule alpha_trans) -defer -apply(rule a) -apply(rule b) -apply(drule c) -apply(rule_tac p="q" in permute_boolE) -apply(perm_simp add: permute_minus_cancel d) -apply(assumption) -apply(rotate_tac -1) -apply(drule_tac p="q" in permute_boolI) -apply(perm_simp add: permute_minus_cancel d) -apply(simp add: permute_eqvt[symmetric]) -done - -lemmas alpha_trans_eqvt = alpha_set_trans_eqvt alpha_res_trans_eqvt alpha_lst_trans_eqvt - - -section {* General Abstractions *} - -fun - alpha_abs_set -where - [simp del]: - "alpha_abs_set (bs, x) (cs, y) \ (\p. (bs, x) \set (op=) supp p (cs, y))" - -fun - alpha_abs_lst -where - [simp del]: - "alpha_abs_lst (bs, x) (cs, y) \ (\p. (bs, x) \lst (op=) supp p (cs, y))" - -fun - alpha_abs_res -where - [simp del]: - "alpha_abs_res (bs, x) (cs, y) \ (\p. (bs, x) \res (op=) supp p (cs, y))" - -notation - alpha_abs_set (infix "\abs'_set" 50) and - alpha_abs_lst (infix "\abs'_lst" 50) and - alpha_abs_res (infix "\abs'_res" 50) - -lemmas alphas_abs = alpha_abs_set.simps alpha_abs_res.simps alpha_abs_lst.simps - - -lemma alphas_abs_refl: - shows "(bs, x) \abs_set (bs, x)" - and "(bs, x) \abs_res (bs, x)" - and "(cs, x) \abs_lst (cs, x)" - unfolding alphas_abs - unfolding alphas - unfolding fresh_star_def - by (rule_tac [!] x="0" in exI) - (simp_all add: fresh_zero_perm) - -lemma alphas_abs_sym: - shows "(bs, x) \abs_set (cs, y) \ (cs, y) \abs_set (bs, x)" - and "(bs, x) \abs_res (cs, y) \ (cs, y) \abs_res (bs, x)" - and "(ds, x) \abs_lst (es, y) \ (es, y) \abs_lst (ds, x)" - unfolding alphas_abs - unfolding alphas - unfolding fresh_star_def - by (erule_tac [!] exE, rule_tac [!] x="-p" in exI) - (auto simp add: fresh_minus_perm) - -lemma alphas_abs_trans: - shows "\(bs, x) \abs_set (cs, y); (cs, y) \abs_set (ds, z)\ \ (bs, x) \abs_set (ds, z)" - and "\(bs, x) \abs_res (cs, y); (cs, y) \abs_res (ds, z)\ \ (bs, x) \abs_res (ds, z)" - and "\(es, x) \abs_lst (gs, y); (gs, y) \abs_lst (hs, z)\ \ (es, x) \abs_lst (hs, z)" - unfolding alphas_abs - unfolding alphas - unfolding fresh_star_def - apply(erule_tac [!] exE, erule_tac [!] exE) - apply(rule_tac [!] x="pa + p" in exI) - by (simp_all add: fresh_plus_perm) - -lemma alphas_abs_eqvt: - shows "(bs, x) \abs_set (cs, y) \ (p \ bs, p \ x) \abs_set (p \ cs, p \ y)" - and "(bs, x) \abs_res (cs, y) \ (p \ bs, p \ x) \abs_res (p \ cs, p \ y)" - and "(ds, x) \abs_lst (es, y) \ (p \ ds, p \ x) \abs_lst (p \ es, p \ y)" - unfolding alphas_abs - unfolding alphas - unfolding set_eqvt[symmetric] - unfolding supp_eqvt[symmetric] - unfolding Diff_eqvt[symmetric] - apply(erule_tac [!] exE) - apply(rule_tac [!] x="p \ pa" in exI) - by (auto simp add: fresh_star_permute_iff permute_eqvt[symmetric]) - -quotient_type - 'a abs_set = "(atom set \ 'a::pt)" / "alpha_abs_set" -and 'b abs_res = "(atom set \ 'b::pt)" / "alpha_abs_res" -and 'c abs_lst = "(atom list \ 'c::pt)" / "alpha_abs_lst" - apply(rule_tac [!] equivpI) - unfolding reflp_def symp_def transp_def - by (auto intro: alphas_abs_sym alphas_abs_refl alphas_abs_trans simp only:) - -quotient_definition - Abs_set ("[_]set. _" [60, 60] 60) -where - "Abs_set::atom set \ ('a::pt) \ 'a abs_set" -is - "Pair::atom set \ ('a::pt) \ (atom set \ 'a)" - -quotient_definition - Abs_res ("[_]res. _" [60, 60] 60) -where - "Abs_res::atom set \ ('a::pt) \ 'a abs_res" -is - "Pair::atom set \ ('a::pt) \ (atom set \ 'a)" - -quotient_definition - Abs_lst ("[_]lst. _" [60, 60] 60) -where - "Abs_lst::atom list \ ('a::pt) \ 'a abs_lst" -is - "Pair::atom list \ ('a::pt) \ (atom list \ 'a)" - -lemma [quot_respect]: - shows "(op= ===> op= ===> alpha_abs_set) Pair Pair" - and "(op= ===> op= ===> alpha_abs_res) Pair Pair" - and "(op= ===> op= ===> alpha_abs_lst) Pair Pair" - unfolding fun_rel_def - by (auto intro: alphas_abs_refl) - -lemma [quot_respect]: - shows "(op= ===> alpha_abs_set ===> alpha_abs_set) permute permute" - and "(op= ===> alpha_abs_res ===> alpha_abs_res) permute permute" - and "(op= ===> alpha_abs_lst ===> alpha_abs_lst) permute permute" - unfolding fun_rel_def - by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt) - -lemma Abs_eq_iff: - shows "Abs_set bs x = Abs_set cs y \ (\p. (bs, x) \set (op =) supp p (cs, y))" - and "Abs_res bs x = Abs_res cs y \ (\p. (bs, x) \res (op =) supp p (cs, y))" - and "Abs_lst bsl x = Abs_lst csl y \ (\p. (bsl, x) \lst (op =) supp p (csl, y))" - by (lifting alphas_abs) - -lemma Abs_exhausts: - shows "(\as (x::'a::pt). y1 = Abs_set as x \ P1) \ P1" - and "(\as (x::'a::pt). y2 = Abs_res as x \ P2) \ P2" - and "(\as (x::'a::pt). y3 = Abs_lst as x \ P3) \ P3" - by (lifting prod.exhaust[where 'a="atom set" and 'b="'a"] - prod.exhaust[where 'a="atom set" and 'b="'a"] - prod.exhaust[where 'a="atom list" and 'b="'a"]) - -instantiation abs_set :: (pt) pt -begin - -quotient_definition - "permute_abs_set::perm \ ('a::pt abs_set) \ 'a abs_set" -is - "permute:: perm \ (atom set \ 'a::pt) \ (atom set \ 'a::pt)" - -lemma permute_Abs_set[simp]: - fixes x::"'a::pt" - shows "(p \ (Abs_set as x)) = Abs_set (p \ as) (p \ x)" - by (lifting permute_prod.simps[where 'a="atom set" and 'b="'a"]) - -instance - apply(default) - apply(case_tac [!] x rule: Abs_exhausts(1)) - apply(simp_all) - done - -end - -instantiation abs_res :: (pt) pt -begin - -quotient_definition - "permute_abs_res::perm \ ('a::pt abs_res) \ 'a abs_res" -is - "permute:: perm \ (atom set \ 'a::pt) \ (atom set \ 'a::pt)" - -lemma permute_Abs_res[simp]: - fixes x::"'a::pt" - shows "(p \ (Abs_res as x)) = Abs_res (p \ as) (p \ x)" - by (lifting permute_prod.simps[where 'a="atom set" and 'b="'a"]) - -instance - apply(default) - apply(case_tac [!] x rule: Abs_exhausts(2)) - apply(simp_all) - done - -end - -instantiation abs_lst :: (pt) pt -begin - -quotient_definition - "permute_abs_lst::perm \ ('a::pt abs_lst) \ 'a abs_lst" -is - "permute:: perm \ (atom list \ 'a::pt) \ (atom list \ 'a::pt)" - -lemma permute_Abs_lst[simp]: - fixes x::"'a::pt" - shows "(p \ (Abs_lst as x)) = Abs_lst (p \ as) (p \ x)" - by (lifting permute_prod.simps[where 'a="atom list" and 'b="'a"]) - -instance - apply(default) - apply(case_tac [!] x rule: Abs_exhausts(3)) - apply(simp_all) - done - -end - -lemmas permute_Abs[eqvt] = permute_Abs_set permute_Abs_res permute_Abs_lst - - -lemma Abs_swap1: - assumes a1: "a \ (supp x) - bs" - and a2: "b \ (supp x) - bs" - shows "Abs_set bs x = Abs_set ((a \ b) \ bs) ((a \ b) \ x)" - and "Abs_res bs x = Abs_res ((a \ b) \ bs) ((a \ b) \ x)" - unfolding Abs_eq_iff - unfolding alphas - unfolding supp_eqvt[symmetric] Diff_eqvt[symmetric] - unfolding fresh_star_def fresh_def - unfolding swap_set_not_in[OF a1 a2] - using a1 a2 - by (rule_tac [!] x="(a \ b)" in exI) - (auto simp add: supp_perm swap_atom) - -lemma Abs_swap2: - assumes a1: "a \ (supp x) - (set bs)" - and a2: "b \ (supp x) - (set bs)" - shows "Abs_lst bs x = Abs_lst ((a \ b) \ bs) ((a \ b) \ x)" - unfolding Abs_eq_iff - unfolding alphas - unfolding supp_eqvt[symmetric] Diff_eqvt[symmetric] set_eqvt[symmetric] - unfolding fresh_star_def fresh_def - unfolding swap_set_not_in[OF a1 a2] - using a1 a2 - by (rule_tac [!] x="(a \ b)" in exI) - (auto simp add: supp_perm swap_atom) - -lemma Abs_supports: - shows "((supp x) - as) supports (Abs_set as x)" - and "((supp x) - as) supports (Abs_res as x)" - and "((supp x) - set bs) supports (Abs_lst bs x)" - unfolding supports_def - unfolding permute_Abs - by (simp_all add: Abs_swap1[symmetric] Abs_swap2[symmetric]) - -function - supp_set :: "('a::pt) abs_set \ atom set" -where - "supp_set (Abs_set as x) = supp x - as" -apply(case_tac x rule: Abs_exhausts(1)) -apply(simp) -apply(simp add: Abs_eq_iff alphas_abs alphas) -done - -termination supp_set - by (auto intro!: local.termination) - -function - supp_res :: "('a::pt) abs_res \ atom set" -where - "supp_res (Abs_res as x) = supp x - as" -apply(case_tac x rule: Abs_exhausts(2)) -apply(simp) -apply(simp add: Abs_eq_iff alphas_abs alphas) -done - -termination supp_res - by (auto intro!: local.termination) - -function - supp_lst :: "('a::pt) abs_lst \ atom set" -where - "supp_lst (Abs_lst cs x) = (supp x) - (set cs)" -apply(case_tac x rule: Abs_exhausts(3)) -apply(simp) -apply(simp add: Abs_eq_iff alphas_abs alphas) -done - -termination supp_lst - by (auto intro!: local.termination) - -lemma [eqvt]: - shows "(p \ supp_set x) = supp_set (p \ x)" - and "(p \ supp_res y) = supp_res (p \ y)" - and "(p \ supp_lst z) = supp_lst (p \ z)" - apply(case_tac x rule: Abs_exhausts(1)) - apply(simp add: supp_eqvt Diff_eqvt) - apply(case_tac y rule: Abs_exhausts(2)) - apply(simp add: supp_eqvt Diff_eqvt) - apply(case_tac z rule: Abs_exhausts(3)) - apply(simp add: supp_eqvt Diff_eqvt set_eqvt) - done - -lemma Abs_fresh_aux: - shows "a \ Abs bs x \ a \ supp_set (Abs bs x)" - and "a \ Abs_res bs x \ a \ supp_res (Abs_res bs x)" - and "a \ Abs_lst cs x \ a \ supp_lst (Abs_lst cs x)" - by (rule_tac [!] fresh_fun_eqvt_app) - (simp_all only: eqvts_raw) - -lemma Abs_supp_subset1: - assumes a: "finite (supp x)" - shows "(supp x) - as \ supp (Abs_set as x)" - and "(supp x) - as \ supp (Abs_res as x)" - and "(supp x) - (set bs) \ supp (Abs_lst bs x)" - unfolding supp_conv_fresh - by (auto dest!: Abs_fresh_aux) - (simp_all add: fresh_def supp_finite_atom_set a) - -lemma Abs_supp_subset2: - assumes a: "finite (supp x)" - shows "supp (Abs_set as x) \ (supp x) - as" - and "supp (Abs_res as x) \ (supp x) - as" - and "supp (Abs_lst bs x) \ (supp x) - (set bs)" - by (rule_tac [!] supp_is_subset) - (simp_all add: Abs_supports a) - -lemma Abs_finite_supp: - assumes a: "finite (supp x)" - shows "supp (Abs_set as x) = (supp x) - as" - and "supp (Abs_res as x) = (supp x) - as" - and "supp (Abs_lst bs x) = (supp x) - (set bs)" - by (rule_tac [!] subset_antisym) - (simp_all add: Abs_supp_subset1[OF a] Abs_supp_subset2[OF a]) - -lemma supp_Abs: - fixes x::"'a::fs" - shows "supp (Abs_set as x) = (supp x) - as" - and "supp (Abs_res as x) = (supp x) - as" - and "supp (Abs_lst bs x) = (supp x) - (set bs)" - by (rule_tac [!] Abs_finite_supp) - (simp_all add: finite_supp) - -instance abs_set :: (fs) fs - apply(default) - apply(case_tac x rule: Abs_exhausts(1)) - apply(simp add: supp_Abs finite_supp) - done - -instance abs_res :: (fs) fs - apply(default) - apply(case_tac x rule: Abs_exhausts(2)) - apply(simp add: supp_Abs finite_supp) - done - -instance abs_lst :: (fs) fs - apply(default) - apply(case_tac x rule: Abs_exhausts(3)) - apply(simp add: supp_Abs finite_supp) - done - -lemma Abs_fresh_iff: - fixes x::"'a::fs" - shows "a \ Abs_set bs x \ a \ bs \ (a \ bs \ a \ x)" - and "a \ Abs_res bs x \ a \ bs \ (a \ bs \ a \ x)" - and "a \ Abs_lst cs x \ a \ (set cs) \ (a \ (set cs) \ a \ x)" - unfolding fresh_def - unfolding supp_Abs - by auto - -lemma Abs_fresh_star: - fixes x::"'a::fs" - shows "as \* Abs_set as x" - and "as \* Abs_res as x" - and "set bs \* Abs_lst bs x" - unfolding fresh_star_def - by(simp_all add: Abs_fresh_iff) - - -section {* Infrastructure for building tuples of relations and functions *} - -fun - prod_fv :: "('a \ atom set) \ ('b \ atom set) \ ('a \ 'b) \ atom set" -where - "prod_fv fv1 fv2 (x, y) = fv1 x \ fv2 y" - -definition - prod_alpha :: "('a \ 'a \ bool) \ ('b \ 'b \ bool) \ ('a \ 'b \ 'a \ 'b \ bool)" -where - "prod_alpha = prod_rel" - -lemma [quot_respect]: - shows "((R1 ===> op =) ===> (R2 ===> op =) ===> prod_rel R1 R2 ===> op =) prod_fv prod_fv" - unfolding fun_rel_def - unfolding prod_rel_def - by auto - -lemma [quot_preserve]: - assumes q1: "Quotient R1 abs1 rep1" - and q2: "Quotient R2 abs2 rep2" - shows "((abs1 ---> id) ---> (abs2 ---> id) ---> prod_fun rep1 rep2 ---> id) prod_fv = prod_fv" - by (simp add: fun_eq_iff Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]) - -lemma [mono]: - shows "A <= B \ C <= D ==> prod_alpha A C <= prod_alpha B D" - unfolding prod_alpha_def - by auto - -lemma [eqvt]: - shows "p \ prod_alpha A B x y = prod_alpha (p \ A) (p \ B) (p \ x) (p \ y)" - unfolding prod_alpha_def - unfolding prod_rel_def - by (perm_simp) (rule refl) - -lemma [eqvt]: - shows "p \ prod_fv A B (x, y) = prod_fv (p \ A) (p \ B) (p \ x, p \ y)" - unfolding prod_fv.simps - by (perm_simp) (rule refl) - -lemma prod_fv_supp: - shows "prod_fv supp supp = supp" -by (rule ext) - (auto simp add: prod_fv.simps supp_Pair) - -lemma prod_alpha_eq: - shows "prod_alpha (op=) (op=) = (op=)" -unfolding prod_alpha_def -by (auto intro!: ext) - - -end -