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