# HG changeset patch
# User Cezary Kaliszyk <kaliszyk@in.tum.de>
# Date 1309694646 -32400
# Node ID 78fc2bd14d0205c869fbde23982b597ee0c161b4
# Parent  3be019a861170b8acb7151c61087aff3aeeb5fba
Added non-working CPS3 using FCB2

diff -r 3be019a86117 -r 78fc2bd14d02 Nominal/Ex/CPS/CPS3_DanvyFilinski_FCB2.thy
--- /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
+
+
+