diff -r 132575f5bd26 -r f0fab367453a Nominal/Ex/CPS/CPS1_Plotkin.thy --- a/Nominal/Ex/CPS/CPS1_Plotkin.thy Fri Aug 19 11:07:17 2011 +0900 +++ b/Nominal/Ex/CPS/CPS1_Plotkin.thy Fri Aug 19 12:49:38 2011 +0900 @@ -3,111 +3,13 @@ imports Lt begin -lemma Abs_lst_fcb2: - fixes as bs :: "atom list" - and x y :: "'b :: fs" - and c::"'c::fs" - assumes eq: "[as]lst. x = [bs]lst. y" - and fcb1: "(set as) \* c \ (set as) \* f as x c" - and fresh1: "set as \* c" - and fresh2: "set bs \* c" - and perm1: "\p. supp p \* c \ p \ (f as x c) = f (p \ as) (p \ x) c" - and perm2: "\p. supp p \* c \ p \ (f bs y c) = f (p \ bs) (p \ y) c" - shows "f as x c = f bs y c" -proof - - have "supp (as, x, c) supports (f as x c)" - unfolding supports_def fresh_def[symmetric] - by (simp add: fresh_Pair perm1 fresh_star_def supp_swap swap_fresh_fresh) - then have fin1: "finite (supp (f as x c))" - by (auto intro: supports_finite simp add: finite_supp) - have "supp (bs, y, c) supports (f bs y c)" - unfolding supports_def fresh_def[symmetric] - by (simp add: fresh_Pair perm2 fresh_star_def supp_swap swap_fresh_fresh) - then have fin2: "finite (supp (f bs y c))" - by (auto intro: supports_finite simp add: finite_supp) - obtain q::"perm" where - fr1: "(q \ (set as)) \* (x, c, f as x c, f bs y c)" and - fr2: "supp q \* Abs_lst as x" and - inc: "supp q \ (set as) \ q \ (set as)" - using at_set_avoiding3[where xs="set as" and c="(x, c, f as x c, f bs y c)" and x="[as]lst. x"] - fin1 fin2 - by (auto simp add: supp_Pair finite_supp Abs_fresh_star dest: fresh_star_supp_conv) - have "Abs_lst (q \ as) (q \ x) = q \ Abs_lst as x" by simp - also have "\ = Abs_lst as x" - by (simp only: fr2 perm_supp_eq) - finally have "Abs_lst (q \ as) (q \ x) = Abs_lst bs y" using eq by simp - then obtain r::perm where - qq1: "q \ x = r \ y" and - qq2: "q \ as = r \ bs" and - qq3: "supp r \ (q \ (set as)) \ set bs" - apply(drule_tac sym) - apply(simp only: Abs_eq_iff2 alphas) - apply(erule exE) - apply(erule conjE)+ - apply(drule_tac x="p" in meta_spec) - apply(simp add: set_eqvt) - apply(blast) - done - have "(set as) \* f as x c" - apply(rule fcb1) - apply(rule fresh1) - done - then have "q \ ((set as) \* f as x c)" - by (simp add: permute_bool_def) - then have "set (q \ as) \* f (q \ as) (q \ x) c" - apply(simp add: fresh_star_eqvt set_eqvt) - apply(subst (asm) perm1) - using inc fresh1 fr1 - apply(auto simp add: fresh_star_def fresh_Pair) - done - then have "set (r \ bs) \* f (r \ bs) (r \ y) c" using qq1 qq2 by simp - then have "r \ ((set bs) \* f bs y c)" - apply(simp add: fresh_star_eqvt set_eqvt) - apply(subst (asm) perm2[symmetric]) - using qq3 fresh2 fr1 - apply(auto simp add: set_eqvt fresh_star_def fresh_Pair) - done - then have fcb2: "(set bs) \* f bs y c" by (simp add: permute_bool_def) - have "f as x c = q \ (f as x c)" - apply(rule perm_supp_eq[symmetric]) - using inc fcb1[OF fresh1] fr1 by (auto simp add: fresh_star_def) - also have "\ = f (q \ as) (q \ x) c" - apply(rule perm1) - using inc fresh1 fr1 by (auto simp add: fresh_star_def) - also have "\ = f (r \ bs) (r \ y) c" using qq1 qq2 by simp - also have "\ = r \ (f bs y c)" - apply(rule perm2[symmetric]) - using qq3 fresh2 fr1 by (auto simp add: fresh_star_def) - also have "... = f bs y c" - apply(rule perm_supp_eq) - using qq3 fr1 fcb2 by (auto simp add: fresh_star_def) - finally show ?thesis by simp -qed - -lemma Abs_lst1_fcb2: - fixes a b :: "atom" - and x y :: "'b :: fs" - and c::"'c :: fs" - assumes e: "(Abs_lst [a] x) = (Abs_lst [b] y)" - and fcb1: "a \ c \ a \ f a x c" - and fresh: "{a, b} \* c" - and perm1: "\p. supp p \* c \ p \ (f a x c) = f (p \ a) (p \ x) c" - and perm2: "\p. supp p \* c \ p \ (f b y c) = f (p \ b) (p \ y) c" - shows "f a x c = f b y c" -using e -apply(drule_tac Abs_lst_fcb2[where c="c" and f="\(as::atom list) . f (hd as)"]) -apply(simp_all) -using fcb1 fresh perm1 perm2 -apply(simp_all add: fresh_star_def) -done - nominal_primrec CPS :: "lt \ lt" ("_*" [250] 250) where - "atom k \ x \ (x~)* = (Abs k ((k~) $ (x~)))" -| "atom k \ (x, M) \ (Abs x M)* = Abs k (k~ $ Abs x (M*))" + "atom k \ x \ (x~)* = (Lam k ((k~) $ (x~)))" +| "atom k \ (x, M) \ (Lam x M)* = Lam k (k~ $ Lam x (M*))" | "atom k \ (M, N) \ atom m \ (N, k) \ atom n \ (k, m) \ - (M $ N)* = Abs k (M* $ Abs m (N* $ Abs n (m~ $ n~ $ k~)))" + (M $ N)* = Lam k (M* $ Lam m (N* $ Lam n (m~ $ n~ $ k~)))" unfolding eqvt_def CPS_graph_def apply (rule, perm_simp, rule, rule) apply (simp_all add: fresh_Pair_elim) @@ -123,7 +25,7 @@ apply (simp add: fresh_Pair_elim fresh_at_base) apply (simp add: Abs1_eq_iff lt.fresh fresh_at_base) --"-" -apply(rule_tac s="[[atom ka]]lst. ka~ $ Abs x (CPS_sumC M)" in trans) +apply(rule_tac s="[[atom ka]]lst. ka~ $ Lam x (CPS_sumC M)" in trans) apply (case_tac "k = ka") apply simp apply(simp (no_asm) add: Abs1_eq_iff del:eqvts) @@ -155,7 +57,7 @@ apply (simp_all add: Abs1_eq_iff lt.fresh flip_def[symmetric] fresh_at_base flip_fresh_fresh permute_eq_iff) by (metis flip_at_base_simps(3) flip_at_simps(2) flip_commute permute_flip_at)+ -termination (eqvt) by (relation "measure size") (simp_all) +termination (eqvt) by lexicographic_order lemmas [simp] = fresh_Pair_elim CPS.simps(2,3)[simplified fresh_Pair_elim] @@ -170,7 +72,7 @@ convert:: "lt => lt" ("_+" [250] 250) where "(Var x)+ = Var x" -| "(Abs x M)+ = Abs x (M*)" +| "(Lam x M)+ = Lam x (M*)" | "(M $ N)+ = M $ N" unfolding convert_graph_def eqvt_def apply (rule, perm_simp, rule, rule) @@ -195,20 +97,16 @@ shows "isValue (p \ (M::lt)) = isValue M" by (nominal_induct M rule: lt.strong_induct) auto -lemma [eqvt]: - shows "p \ isValue M = isValue (p \ M)" - by (induct M rule: lt.induct) (perm_simp, rule refl)+ - nominal_primrec Kapply :: "lt \ lt \ lt" (infixl ";" 100) where - "Kapply (Abs x M) K = K $ (Abs x M)+" + "Kapply (Lam x M) K = K $ (Lam x M)+" | "Kapply (Var x) K = K $ Var x" | "isValue M \ isValue N \ Kapply (M $ N) K = M+ $ N+ $ K" | "isValue M \ \isValue N \ atom n \ M \ atom n \ K \ - Kapply (M $ N) K = N; (Abs n (M+ $ Var n $ K))" + Kapply (M $ N) K = N; (Lam n (M+ $ Var n $ K))" | "\isValue M \ atom m \ N \ atom m \ K \ atom n \ m \ atom n \ K \ - Kapply (M $ N) K = M; (Abs m (N* $ (Abs n (Var m $ Var n $ K))))" + Kapply (M $ N) K = M; (Lam m (N* $ (Lam n (Var m $ Var n $ K))))" unfolding Kapply_graph_def eqvt_def apply (rule, perm_simp, rule, rule) apply (simp_all) @@ -225,10 +123,10 @@ apply (simp add: fresh_Pair_elim fresh_at_base) apply (auto simp add: Abs1_eq_iff eqvts)[1] apply (rename_tac M N u K) -apply (subgoal_tac "Abs n (M+ $ n~ $ K) = Abs u (M+ $ u~ $ K)") +apply (subgoal_tac "Lam n (M+ $ n~ $ K) = Lam u (M+ $ u~ $ K)") apply (simp only:) apply (auto simp add: Abs1_eq_iff flip_def[symmetric] lt.fresh fresh_at_base flip_fresh_fresh[symmetric])[1] -apply (subgoal_tac "Abs m (Na* $ Abs n (m~ $ n~ $ Ka)) = Abs ma (Na* $ Abs na (ma~ $ na~ $ Ka))") +apply (subgoal_tac "Lam m (Na* $ Lam n (m~ $ n~ $ Ka)) = Lam ma (Na* $ Lam na (ma~ $ na~ $ Ka))") apply (simp only:) apply (simp add: Abs1_eq_iff flip_def[symmetric] lt.fresh fresh_at_base) apply (subgoal_tac "Ka = (n \ na) \ Ka") @@ -254,14 +152,14 @@ lemma value_CPS: assumes "isValue V" and "atom a \ V" - shows "V* = Abs a (a~ $ V+)" + shows "V* = Lam a (a~ $ V+)" using assms proof (nominal_induct V avoiding: a rule: lt.strong_induct, simp_all add: lt.fresh) fix name :: name and lt aa - assume a: "atom name \ aa" "\b. \isValue lt; atom b \ lt\ \ lt* = Abs b (b~ $ lt+)" + assume a: "atom name \ aa" "\b. \isValue lt; atom b \ lt\ \ lt* = Lam b (b~ $ lt+)" "atom aa \ lt \ aa = name" obtain ab :: name where b: "atom ab \ (name, lt, a)" using obtain_fresh by blast - show "Abs name lt* = Abs aa (aa~ $ Abs name (lt*))" using a b + show "Lam name lt* = Lam aa (aa~ $ Lam name (lt*))" using a b by (simp add: Abs1_eq_iff fresh_at_base lt.fresh) qed @@ -269,28 +167,28 @@ lemma CPS_subst_fv: assumes *:"isValue V" - shows "((M[V/x])* = (M*)[V+/x])" + shows "((M[x ::= V])* = (M*)[x ::= V+])" using * proof (nominal_induct M avoiding: V x rule: lt.strong_induct) case (Var name) assume *: "isValue V" obtain a :: name where a: "atom a \ (x, name, V)" using obtain_fresh by blast - show "((name~)[V/x])* = (name~)*[V+/x]" using a + show "((name~)[x ::= V])* = (name~)*[x ::= V+]" using a by (simp add: fresh_at_base * value_CPS) next - case (Abs name lt V x) - assume *: "atom name \ V" "atom name \ x" "\b ba. isValue b \ (lt[b/ba])* = lt*[b+/ba]" + case (Lam name lt V x) + assume *: "atom name \ V" "atom name \ x" "\b ba. isValue b \ (lt[ba ::= b])* = lt*[ba ::= b+]" "isValue V" - obtain a :: name where a: "atom a \ (name, lt, lt[V/x], x, V)" using obtain_fresh by blast - show "(Abs name lt[V/x])* = Abs name lt*[V+/x]" using * a + obtain a :: name where a: "atom a \ (name, lt, lt[x ::= V], x, V)" using obtain_fresh by blast + show "(Lam name lt[x ::= V])* = Lam name lt*[x ::= V+]" using * a by (simp add: fresh_at_base) next case (App lt1 lt2 V x) - assume *: "\b ba. isValue b \ (lt1[b/ba])* = lt1*[b+/ba]" "\b ba. isValue b \ (lt2[b/ba])* = lt2*[b+/ba]" + assume *: "\b ba. isValue b \ (lt1[ba ::= b])* = lt1*[ba ::= b+]" "\b ba. isValue b \ (lt2[ba ::= b])* = lt2*[ba ::= b+]" "isValue V" - obtain a :: name where a: "atom a \ (lt1[V/x], lt1, lt2[V/x], lt2, V, x)" using obtain_fresh by blast - obtain b :: name where b: "atom b \ (lt2[V/x], lt2, a, V, x)" using obtain_fresh by blast + obtain a :: name where a: "atom a \ (lt1[x ::= V], lt1, lt2[x ::= V], lt2, V, x)" using obtain_fresh by blast + obtain b :: name where b: "atom b \ (lt2[x ::= V], lt2, a, V, x)" using obtain_fresh by blast obtain c :: name where c: "atom c \ (a, b, V, x)" using obtain_fresh by blast - show "((lt1 $ lt2)[V/x])* = (lt1 $ lt2)*[V+/x]" using * a b c + show "((lt1 $ lt2)[x ::= V])* = (lt1 $ lt2)*[x ::= V+]" using * a b c by (simp add: fresh_at_base) qed @@ -312,7 +210,7 @@ assume *: "atom name \ K" "\b. isValue b \ lt* $ b \\<^isub>\\<^sup>* lt ; b" "isValue K" obtain a :: name where a: "atom a \ (name, K, lt)" using obtain_fresh by blast then have b: "atom name \ a" using fresh_PairD(1) fresh_at_base atom_eq_iff by metis - show "Abs name lt* $ K \\<^isub>\\<^sup>* K $ Abs name (lt*)" using * a b + show "Lam name lt* $ K \\<^isub>\\<^sup>* K $ Lam name (lt*)" using * a b by simp (rule evbeta', simp_all) next fix lt1 lt2 K @@ -322,24 +220,24 @@ obtain c :: name where c: "atom c \ (lt1, lt2, K, a, b)" using obtain_fresh by blast have d: "atom a \ lt1" "atom a \ lt2" "atom a \ K" "atom b \ lt1" "atom b \ lt2" "atom b \ K" "atom b \ a" "atom c \ lt1" "atom c \ lt2" "atom c \ K" "atom c \ a" "atom c \ b" using fresh_Pair a b c by simp_all - have "(lt1 $ lt2)* $ K \\<^isub>\\<^sup>* lt1* $ Abs b (lt2* $ Abs c (b~ $ c~ $ K))" using * d + have "(lt1 $ lt2)* $ K \\<^isub>\\<^sup>* lt1* $ Lam b (lt2* $ Lam c (b~ $ c~ $ K))" using * d by (simp add: fresh_at_base) (rule evbeta', simp_all add: fresh_at_base) also have "... \\<^isub>\\<^sup>* lt1 $ lt2 ; K" proof (cases "isValue lt1") assume e: "isValue lt1" - have "lt1* $ Abs b (lt2* $ Abs c (b~ $ c~ $ K)) \\<^isub>\\<^sup>* Abs b (lt2* $ Abs c (b~ $ c~ $ K)) $ lt1+" + have "lt1* $ Lam b (lt2* $ Lam c (b~ $ c~ $ K)) \\<^isub>\\<^sup>* Lam b (lt2* $ Lam c (b~ $ c~ $ K)) $ lt1+" using * d e by simp - also have "... \\<^isub>\\<^sup>* lt2* $ Abs c (lt1+ $ c~ $ K)" + also have "... \\<^isub>\\<^sup>* lt2* $ Lam c (lt1+ $ c~ $ K)" by (rule evbeta', simp_all add: * d e, metis d(12) fresh_at_base) also have "... \\<^isub>\\<^sup>* lt1 $ lt2 ; K" proof (cases "isValue lt2") assume f: "isValue lt2" - have "lt2* $ Abs c (lt1+ $ c~ $ K) \\<^isub>\\<^sup>* Abs c (lt1+ $ c~ $ K) $ lt2+" using * d e f by simp + have "lt2* $ Lam c (lt1+ $ c~ $ K) \\<^isub>\\<^sup>* Lam c (lt1+ $ c~ $ K) $ lt2+" using * d e f by simp also have "... \\<^isub>\\<^sup>* lt1+ $ lt2+ $ K" by (rule evbeta', simp_all add: d e f) finally show ?thesis using * d e f by simp next assume f: "\ isValue lt2" - have "lt2* $ Abs c (lt1+ $ c~ $ K) \\<^isub>\\<^sup>* lt2 ; Abs c (lt1+ $ c~ $ K)" using * d e f by simp - also have "... \\<^isub>\\<^sup>* lt2 ; Abs a (lt1+ $ a~ $ K)" using Kapply.simps(4) d e evs1 f by metis + have "lt2* $ Lam c (lt1+ $ c~ $ K) \\<^isub>\\<^sup>* lt2 ; Lam c (lt1+ $ c~ $ K)" using * d e f by simp + also have "... \\<^isub>\\<^sup>* lt2 ; Lam a (lt1+ $ a~ $ K)" using Kapply.simps(4) d e evs1 f by metis finally show ?thesis using * d e f by simp qed finally show ?thesis . @@ -355,11 +253,11 @@ case (evbeta x V M) fix K assume a: "isValue K" "isValue V" "atom x \ V" - have "Abs x (M*) $ V+ $ K \\<^isub>\\<^sup>* ((M*)[V+/x] $ K)" + have "Lam x (M*) $ V+ $ K \\<^isub>\\<^sup>* (((M*)[x ::= V+]) $ K)" by (rule evs2,rule ev2,rule Lt.evbeta) (simp_all add: fresh_def a[simplified fresh_def] evs1) - also have "... = ((M[V/x])* $ K)" by (simp add: CPS_subst_fv a) - also have "... \\<^isub>\\<^sup>* (M[V/x] ; K)" by (rule CPS_eval_Kapply, simp_all add: a) - finally show "(Abs x M $ V ; K) \\<^isub>\\<^sup>* (M[V/x] ; K)" using a by simp + also have "... = ((M[x ::= V])* $ K)" by (simp add: CPS_subst_fv a) + also have "... \\<^isub>\\<^sup>* ((M[x ::= V]) ; K)" by (rule CPS_eval_Kapply, simp_all add: a) + finally show "(Lam x M $ V ; K) \\<^isub>\\<^sup>* ((M[x ::= V]) ; K)" using a by simp next case (ev1 V M N) fix V M N K @@ -370,7 +268,7 @@ then show "V $ M ; K \\<^isub>\\<^sup>* V $ N ; K" using a b by simp next assume n: "isValue N" - have c: "M; Abs a (V+ $ a~ $ K) \\<^isub>\\<^sup>* Abs a (V+ $ a~ $ K) $ N+" using a b by (simp add: n) + have c: "M; Lam a (V+ $ a~ $ K) \\<^isub>\\<^sup>* Lam a (V+ $ a~ $ K) $ N+" using a b by (simp add: n) also have d: "... \\<^isub>\\<^sup>* V+ $ N+ $ K" by (rule evbeta') (simp_all add: a b n) finally show "V $ M ; K \\<^isub>\\<^sup>* V $ N ; K" using a b by (simp add: n) qed @@ -381,19 +279,19 @@ obtain b :: name where b: "atom b \ (a, K, M, N, M', N+)" using obtain_fresh by blast have d: "atom a \ K" "atom a \ M" "atom a \ N" "atom a \ M'" "atom b \ a" "atom b \ K" "atom b \ M" "atom b \ N" "atom b \ M'" using a b fresh_Pair by simp_all - have "M $ N ; K \\<^isub>\\<^sup>* M' ; Abs a (N* $ Abs b (a~ $ b~ $ K))" using * d by simp + have "M $ N ; K \\<^isub>\\<^sup>* M' ; Lam a (N* $ Lam b (a~ $ b~ $ K))" using * d by simp also have "... \\<^isub>\\<^sup>* M' $ N ; K" proof (cases "isValue M'") assume "\ isValue M'" then show ?thesis using * d by (simp_all add: evs1) next assume e: "isValue M'" - then have "M' ; Abs a (N* $ Abs b (a~ $ b~ $ K)) = Abs a (N* $ Abs b (a~ $ b~ $ K)) $ M'+" by simp - also have "... \\<^isub>\\<^sup>* (N* $ Abs b (a~ $ b~ $ K))[M'+/a]" + then have "M' ; Lam a (N* $ Lam b (a~ $ b~ $ K)) = Lam a (N* $ Lam b (a~ $ b~ $ K)) $ M'+" by simp + also have "... \\<^isub>\\<^sup>* (N* $ Lam b (a~ $ b~ $ K))[a ::= M'+]" by (rule evbeta') (simp_all add: fresh_at_base e d) - also have "... = N* $ Abs b (M'+ $ b~ $ K)" using * d by (simp add: fresh_at_base) + also have "... = N* $ Lam b (M'+ $ b~ $ K)" using * d by (simp add: fresh_at_base) also have "... \\<^isub>\\<^sup>* M' $ N ; K" proof (cases "isValue N") assume f: "isValue N" - have "N* $ Abs b (M'+ $ b~ $ K) \\<^isub>\\<^sup>* Abs b (M'+ $ b~ $ K) $ N+" + have "N* $ Lam b (M'+ $ b~ $ K) \\<^isub>\\<^sup>* Lam b (M'+ $ b~ $ K) $ N+" by (rule eval_trans, rule CPS_eval_Kapply) (simp_all add: d e f * evs1) also have "... \\<^isub>\\<^sup>* M' $ N ; K" by (rule evbeta') (simp_all add: d e f evs1) finally show ?thesis . @@ -415,17 +313,17 @@ lemma assumes "isValue V" "M \\<^isub>\\<^sup>* V" - shows "M* $ (Abs x (x~)) \\<^isub>\\<^sup>* V+" + shows "M* $ (Lam x (x~)) \\<^isub>\\<^sup>* V+" proof- obtain y::name where *: "atom y \ V" using obtain_fresh by blast - have e: "Abs x (x~) = Abs y (y~)" + have e: "Lam x (x~) = Lam y (y~)" by (simp add: Abs1_eq_iff lt.fresh fresh_at_base) - have "M* $ Abs x (x~) \\<^isub>\\<^sup>* M ; Abs x (x~)" + have "M* $ Lam x (x~) \\<^isub>\\<^sup>* M ; Lam x (x~)" by(rule CPS_eval_Kapply,simp_all add: assms) - also have "... \\<^isub>\\<^sup>* (V ; Abs x (x~))" by (rule Kapply_eval_rtrancl, simp_all add: assms) - also have "... = V ; Abs y (y~)" using e by (simp only:) + also have "... \\<^isub>\\<^sup>* (V ; Lam x (x~))" by (rule Kapply_eval_rtrancl, simp_all add: assms) + also have "... = V ; Lam y (y~)" using e by (simp only:) also have "... \\<^isub>\\<^sup>* (V+)" by (simp add: assms, rule evbeta') (simp_all add: assms *) - finally show "M* $ (Abs x (x~)) \\<^isub>\\<^sup>* (V+)" . + finally show "M* $ (Lam x (x~)) \\<^isub>\\<^sup>* (V+)" . qed end