--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Nominal/Ex/CPS/CPS3_DanvyFilinski_FCB2.thy Sun Jul 03 21:04:06 2011 +0900
@@ -0,0 +1,356 @@
+header {* CPS transformation of Danvy and Filinski *}
+theory CPS3_DanvyFilinski 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) \<sharp>* c \<Longrightarrow> (set as) \<sharp>* f as x c"
+ and fresh1: "set as \<sharp>* c"
+ and fresh2: "set bs \<sharp>* c"
+ and perm1: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f as x c) = f (p \<bullet> as) (p \<bullet> x) c"
+ and perm2: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f bs y c) = f (p \<bullet> bs) (p \<bullet> 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 \<bullet> (set as)) \<sharp>* (x, c, f as x c, f bs y c)" and
+ fr2: "supp q \<sharp>* Abs_lst as x" and
+ inc: "supp q \<subseteq> (set as) \<union> q \<bullet> (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 \<bullet> as) (q \<bullet> x) = q \<bullet> Abs_lst as x" by simp
+ also have "\<dots> = Abs_lst as x"
+ by (simp only: fr2 perm_supp_eq)
+ finally have "Abs_lst (q \<bullet> as) (q \<bullet> x) = Abs_lst bs y" using eq by simp
+ then obtain r::perm where
+ qq1: "q \<bullet> x = r \<bullet> y" and
+ qq2: "q \<bullet> as = r \<bullet> bs" and
+ qq3: "supp r \<subseteq> (q \<bullet> (set as)) \<union> 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) \<sharp>* f as x c"
+ apply(rule fcb1)
+ apply(rule fresh1)
+ done
+ then have "q \<bullet> ((set as) \<sharp>* f as x c)"
+ by (simp add: permute_bool_def)
+ then have "set (q \<bullet> as) \<sharp>* f (q \<bullet> as) (q \<bullet> 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 \<bullet> bs) \<sharp>* f (r \<bullet> bs) (r \<bullet> y) c" using qq1 qq2 by simp
+ then have "r \<bullet> ((set bs) \<sharp>* 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) \<sharp>* f bs y c" by (simp add: permute_bool_def)
+ have "f as x c = q \<bullet> (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 "\<dots> = f (q \<bullet> as) (q \<bullet> x) c"
+ apply(rule perm1)
+ using inc fresh1 fr1 by (auto simp add: fresh_star_def)
+ also have "\<dots> = f (r \<bullet> bs) (r \<bullet> y) c" using qq1 qq2 by simp
+ also have "\<dots> = r \<bullet> (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 \<sharp> c \<Longrightarrow> a \<sharp> f a x c"
+ and fresh: "{a, b} \<sharp>* c"
+ and perm1: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f a x c) = f (p \<bullet> a) (p \<bullet> x) c"
+ and perm2: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f b y c) = f (p \<bullet> b) (p \<bullet> y) c"
+ shows "f a x c = f b y c"
+using e
+apply(drule_tac Abs_lst_fcb2[where c="c" and f="\<lambda>(as::atom list) . f (hd as)"])
+apply(simp_all)
+using fcb1 fresh perm1 perm2
+apply(simp_all add: fresh_star_def)
+done
+
+nominal_primrec
+ CPS1 :: "lt \<Rightarrow> (lt \<Rightarrow> lt) \<Rightarrow> lt" ("_*_" [100,100] 100)
+and
+ CPS2 :: "lt \<Rightarrow> lt \<Rightarrow> lt" ("_^_" [100,100] 100)
+where
+ "eqvt k \<Longrightarrow> (x~)*k = k (x~)"
+| "eqvt k \<Longrightarrow> (M$N)*k = M*(%m. (N*(%n.((m $ n) $ (Abs c (k (c~)))))))"
+| "eqvt k \<Longrightarrow> atom c \<sharp> (x, M) \<Longrightarrow> (Abs x M)*k = k (Abs x (Abs c (M^(c~))))"
+| "\<not>eqvt k \<Longrightarrow> (CPS1 t k) = t"
+| "(x~)^l = l $ (x~)"
+| "(M$N)^l = M*(%m. (N*(%n.((m $ n) $ l))))"
+| "atom c \<sharp> (x, M) \<Longrightarrow> (Abs x M)^l = l $ (Abs x (Abs c (M^(c~))))"
+ apply (simp only: eqvt_def CPS1_CPS2_graph_def)
+ apply (rule, perm_simp, rule)
+ apply auto
+ apply (case_tac x)
+ apply (case_tac a)
+ apply (case_tac "eqvt b")
+ apply (rule_tac y="aa" in lt.strong_exhaust)
+ apply auto[4]
+ apply (rule_tac x="(name, lt)" and ?'a="name" in obtain_fresh)
+ apply (simp add: fresh_at_base Abs1_eq_iff)
+ apply (case_tac b)
+ apply (rule_tac y="a" in lt.strong_exhaust)
+ apply auto[3]
+ apply blast
+ apply (rule_tac x="(name, lt)" and ?'a="name" in obtain_fresh)
+ apply (simp add: fresh_at_base Abs1_eq_iff)
+ apply blast
+--"-"
+ apply (subgoal_tac "Abs c (ka (c~)) = Abs ca (ka (ca~))")
+ apply (simp only:)
+ apply (simp add: Abs1_eq_iff)
+ apply (case_tac "c=ca")
+ apply simp_all[2]
+ apply rule
+ apply (perm_simp)
+ apply (simp add: eqvt_def)
+ apply (simp add: fresh_def)
+ apply (rule contra_subsetD[OF supp_fun_app])
+ back
+ apply (simp add: supp_fun_eqvt lt.supp supp_at_base)
+--"-"
+ apply (rule arg_cong)
+ back
+ apply simp
+ apply (erule Abs_lst1_fcb2)
+ apply simp
+ apply (thin_tac "eqvt ka")
+ apply (rule_tac x="(c, ca, x, xa, M, Ma)" and ?'a="name" in obtain_fresh)
+ apply (subgoal_tac "Abs c (CPS1_CPS2_sumC (Inr (M, c~))) = Abs a (CPS1_CPS2_sumC (Inr (M, a~)))")
+ prefer 2
+ apply (simp add: Abs1_eq_iff')
+ apply (case_tac "c = a")
+ apply simp_all[2]
+ apply rule
+ apply (simp add: eqvt_at_def)
+ apply (simp add: swap_fresh_fresh fresh_Pair_elim)
+ apply (erule fresh_eqvt_at)
+ apply (simp add: supp_Inr finite_supp)
+ apply (simp add: fresh_Inr fresh_Pair lt.fresh fresh_at_base)
+ apply (subgoal_tac "Abs ca (CPS1_CPS2_sumC (Inr (Ma, ca~))) = Abs a (CPS1_CPS2_sumC (Inr (Ma, a~)))")
+ prefer 2
+ apply (simp add: Abs1_eq_iff')
+ apply (case_tac "ca = a")
+ apply simp_all[2]
+ apply rule
+ apply (simp add: eqvt_at_def)
+ apply (simp add: swap_fresh_fresh fresh_Pair_elim)
+ apply (erule fresh_eqvt_at)
+ apply (simp add: supp_Inr finite_supp)
+ apply (simp add: fresh_Inr fresh_Pair lt.fresh fresh_at_base)
+ apply (simp only: )
+ apply (erule Abs_lst1_fcb2)
+ apply (simp add: Abs_fresh_iff)
+ apply (simp add: fresh_star_def fresh_Pair_elim lt.fresh fresh_at_base)
+ apply (subgoal_tac "p \<bullet> CPS1_CPS2_sumC (Inr (M, a~)) = CPS1_CPS2_sumC (p \<bullet> (Inr (M, a~)))")
+ apply (simp add: perm_supp_eq fresh_star_def lt.fresh)
+ apply (drule sym)
+ apply (simp only: )
+ apply (simp only: permute_Abs_lst)
+ apply simp
+ apply (simp add: eqvt_at_def)
+ apply (drule sym)
+ apply (simp only:)
+ apply (simp add: Abs_fresh_iff lt.fresh)
+ apply clarify
+ apply (erule fresh_eqvt_at)
+ apply (simp add: supp_Inr finite_supp)
+ apply (simp add: fresh_Inr fresh_Pair lt.fresh fresh_at_base)
+ apply (drule sym)
+ apply (drule sym)
+ apply (drule sym)
+ apply (simp only:)
+ apply (thin_tac "Abs a (CPS1_CPS2_sumC (Inr (M, a~))) = Abs c (CPS1_CPS2_sumC (Inr (M, c~)))")
+ apply (thin_tac "Abs a (CPS1_CPS2_sumC (Inr (Ma, a~))) = Abs ca (CPS1_CPS2_sumC (Inr (Ma, ca~)))")
+ apply (thin_tac "atom a \<sharp> (c, ca, x, xa, M, Ma)")
+ apply (simp add: fresh_Pair_elim)
+ apply (subst iffD1[OF meta_eq_to_obj_eq[OF eqvt_at_def]])
+ back
+ back
+ back
+ apply assumption
+ apply (simp add: Abs1_eq_iff' fresh_Pair_elim fresh_at_base swap_fresh_fresh lt.fresh)
+ apply (case_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> c = ca")
+ apply simp_all[3]
+ apply rule
+ apply (case_tac "c = xa")
+ apply simp_all[2]
+ apply (simp add: eqvt_at_def)
+ apply clarify
+ apply (smt flip_def permute_flip_at permute_swap_cancel swap_fresh_fresh)
+ apply (simp add: eqvt_at_def)
+ apply clarify
+ apply (smt atom_eq_iff atom_eqvt flip_def fresh_eqvt permute_flip_at permute_swap_cancel swap_at_base_simps(3) swap_fresh_fresh)
+ apply (case_tac "c = xa")
+ apply simp
+ apply (subgoal_tac "((ca \<leftrightarrow> x) \<bullet> (atom x)) \<sharp> (ca \<leftrightarrow> x) \<bullet> CPS1_CPS2_sumC (Inr (Ma, ca~))")
+ apply (simp add: atom_eqvt eqvt_at_def)
+ apply (simp add: flip_fresh_fresh)
+ apply (subst fresh_permute_iff)
+ apply (erule fresh_eqvt_at)
+ apply (simp add: supp_Inr finite_supp)
+ apply (simp add: fresh_Inr lt.fresh fresh_at_base fresh_Pair)
+ apply simp
+ apply clarify
+ apply (subgoal_tac "atom ca \<sharp> (atom x \<rightleftharpoons> atom xa) \<bullet> CPS1_CPS2_sumC (Inr (M, c~))")
+ apply (simp add: eqvt_at_def)
+ apply (subgoal_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> atom ca \<sharp> CPS1_CPS2_sumC (Inr (M, c~))")
+ apply (metis Nominal2_Base.swap_commute fresh_permute_iff permute_swap_cancel2)
+ apply (erule fresh_eqvt_at)
+ apply (simp add: finite_supp supp_Inr)
+ apply (simp add: fresh_Inr fresh_Pair lt.fresh)
+ apply rule
+ apply (metis Nominal2_Base.swap_commute fresh_permute_iff permute_swap_cancel2)
+ apply (simp add: fresh_def supp_at_base)
+ apply (metis atom_eq_iff permute_swap_cancel2 swap_atom_simps(3))
+--"-"
+ apply (rule_tac x="(c, ca, x, xa, M, Ma)" and ?'a="name" in obtain_fresh)
+ apply (subgoal_tac "Abs c (CPS1_CPS2_sumC (Inr (M, c~))) = Abs a (CPS1_CPS2_sumC (Inr (M, a~)))")
+ prefer 2
+ apply (simp add: Abs1_eq_iff')
+ apply (case_tac "c = a")
+ apply simp_all[2]
+ apply rule
+ apply (simp add: eqvt_at_def)
+ apply (simp add: swap_fresh_fresh fresh_Pair_elim)
+ apply (erule fresh_eqvt_at)
+ apply (simp add: supp_Inr finite_supp)
+ apply (simp add: fresh_Inr fresh_Pair lt.fresh fresh_at_base)
+ apply (subgoal_tac "Abs ca (CPS1_CPS2_sumC (Inr (Ma, ca~))) = Abs a (CPS1_CPS2_sumC (Inr (Ma, a~)))")
+ prefer 2
+ apply (simp add: Abs1_eq_iff')
+ apply (case_tac "ca = a")
+ apply simp_all[2]
+ apply rule
+ apply (simp add: eqvt_at_def)
+ apply (simp add: swap_fresh_fresh fresh_Pair_elim)
+ apply (erule fresh_eqvt_at)
+ apply (simp add: supp_Inr finite_supp)
+ apply (simp add: fresh_Inr fresh_Pair lt.fresh fresh_at_base)
+ apply (simp only: )
+ apply (erule Abs_lst1_fcb)
+ apply (simp add: Abs_fresh_iff)
+ apply (drule sym)
+ apply (simp only:)
+ apply (simp add: Abs_fresh_iff lt.fresh)
+ apply clarify
+ apply (erule fresh_eqvt_at)
+ apply (simp add: supp_Inr finite_supp)
+ apply (simp add: fresh_Inr fresh_Pair lt.fresh fresh_at_base)
+ apply (drule sym)
+ apply (drule sym)
+ apply (drule sym)
+ apply (simp only:)
+ apply (thin_tac "Abs a (CPS1_CPS2_sumC (Inr (M, a~))) = Abs c (CPS1_CPS2_sumC (Inr (M, c~)))")
+ apply (thin_tac "Abs a (CPS1_CPS2_sumC (Inr (Ma, a~))) = Abs ca (CPS1_CPS2_sumC (Inr (Ma, ca~)))")
+ apply (thin_tac "atom a \<sharp> (c, ca, x, xa, M, Ma)")
+ apply (simp add: fresh_Pair_elim)
+ apply (subst iffD1[OF meta_eq_to_obj_eq[OF eqvt_at_def]])
+ back
+ back
+ back
+ apply assumption
+ apply (simp add: Abs1_eq_iff' fresh_Pair_elim fresh_at_base swap_fresh_fresh lt.fresh)
+ apply (case_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> c = ca")
+ apply simp_all[3]
+ apply rule
+ apply (case_tac "c = xa")
+ apply simp_all[2]
+ apply (simp add: eqvt_at_def)
+ apply clarify
+ apply (smt flip_def permute_flip_at permute_swap_cancel swap_fresh_fresh)
+ apply (simp add: eqvt_at_def)
+ apply clarify
+ apply (smt atom_eq_iff atom_eqvt flip_def fresh_eqvt permute_flip_at permute_swap_cancel swap_at_base_simps(3) swap_fresh_fresh)
+ apply (case_tac "c = xa")
+ apply simp
+ apply (subgoal_tac "((ca \<leftrightarrow> x) \<bullet> (atom x)) \<sharp> (ca \<leftrightarrow> x) \<bullet> CPS1_CPS2_sumC (Inr (Ma, ca~))")
+ apply (simp add: atom_eqvt eqvt_at_def)
+ apply (simp add: flip_fresh_fresh)
+ apply (subst fresh_permute_iff)
+ apply (erule fresh_eqvt_at)
+ apply (simp add: supp_Inr finite_supp)
+ apply (simp add: fresh_Inr lt.fresh fresh_at_base fresh_Pair)
+ apply simp
+ apply clarify
+ apply (subgoal_tac "atom ca \<sharp> (atom x \<rightleftharpoons> atom xa) \<bullet> CPS1_CPS2_sumC (Inr (M, c~))")
+ apply (simp add: eqvt_at_def)
+ apply (subgoal_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> atom ca \<sharp> CPS1_CPS2_sumC (Inr (M, c~))")
+ apply (metis Nominal2_Base.swap_commute fresh_permute_iff permute_swap_cancel2)
+ apply (erule fresh_eqvt_at)
+ apply (simp add: finite_supp supp_Inr)
+ apply (simp add: fresh_Inr fresh_Pair lt.fresh)
+ apply rule
+ apply (metis Nominal2_Base.swap_commute fresh_permute_iff permute_swap_cancel2)
+ apply (simp add: fresh_def supp_at_base)
+ apply (metis atom_eq_iff permute_swap_cancel2 swap_atom_simps(3))
+ done
+
+termination
+ by lexicographic_order
+
+definition psi:: "lt => lt"
+ where [simp]: "psi V == V*(\<lambda>x. x)"
+
+section {* Simple consequence of CPS *}
+
+lemma [simp]: "eqvt (\<lambda>x\<Colon>lt. x)"
+ by (simp add: eqvt_def eqvt_bound eqvt_lambda)
+
+lemma value_eq1 : "isValue V \<Longrightarrow> eqvt k \<Longrightarrow> V*k = k (psi V)"
+ apply (cases V rule: lt.exhaust)
+ apply simp_all
+ apply (rule_tac x="(name, lt)" and ?'a="name" in obtain_fresh)
+ apply simp
+ done
+
+lemma value_eq2 : "isValue V \<Longrightarrow> V^K = K $ (psi V)"
+ apply (cases V rule: lt.exhaust)
+ apply simp_all
+ apply (rule_tac x="(name, lt)" and ?'a="name" in obtain_fresh)
+ apply simp
+ done
+
+lemma value_eq3' : "~isValue M \<Longrightarrow> eqvt k \<Longrightarrow> M*k = (M^(Abs n (k (Var n))))"
+ by (cases M rule: lt.exhaust) auto
+
+
+
+end
+
+
+