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