diff -r a30d0bb76869 -r 9f667f6da04f Nominal/CPS/CPS2_DanvyNielsen.thy --- a/Nominal/CPS/CPS2_DanvyNielsen.thy Thu Jun 16 21:23:38 2011 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -header {* CPS transformation of Danvy and Nielsen *} -theory DanvyNielsen -imports Lt -begin - -nominal_datatype cpsctxt = - Hole -| CFun cpsctxt lt -| CArg lt cpsctxt -| CAbs x::name c::cpsctxt bind x in c - -nominal_primrec - fill :: "cpsctxt \ lt \ lt" ("_<_>" [200, 200] 100) -where - fill_hole : "Hole = M" -| fill_fun : "(CFun C N) = (C) $ N" -| fill_arg : "(CArg N C) = N $ (C)" -| fill_abs : "atom x \ M \ (CAbs x C) = Abs x (C)" - unfolding eqvt_def fill_graph_def - apply perm_simp - apply auto - apply (rule_tac y="a" and c="b" in cpsctxt.strong_exhaust) - apply (auto simp add: fresh_star_def) - apply (erule Abs_lst1_fcb) - apply (simp_all add: Abs_fresh_iff) - apply (erule fresh_eqvt_at) - apply (simp add: finite_supp) - apply (simp add: fresh_Pair) - apply (simp add: eqvt_at_def swap_fresh_fresh) - done - -termination - by (relation "measure (\(x, _). size x)") (auto simp add: cpsctxt.size) - -lemma [eqvt]: "p \ fill c t = fill (p \ c) (p \ t)" - by (nominal_induct c avoiding: t rule: cpsctxt.strong_induct) simp_all - -nominal_primrec - ccomp :: "cpsctxt => cpsctxt => cpsctxt" -where - "ccomp Hole C = C" -| "atom x \ C' \ ccomp (CAbs x C) C' = CAbs x (ccomp C C')" -| "ccomp (CArg N C) C' = CArg N (ccomp C C')" -| "ccomp (CFun C N) C' = CFun (ccomp C C') N" - unfolding eqvt_def ccomp_graph_def - apply perm_simp - apply auto - apply (rule_tac y="a" and c="b" in cpsctxt.strong_exhaust) - apply (auto simp add: fresh_star_def) - apply blast+ - apply (erule Abs_lst1_fcb) - apply (simp_all add: Abs_fresh_iff) - apply (erule fresh_eqvt_at) - apply (simp add: finite_supp) - apply (simp add: fresh_Pair) - apply (simp add: eqvt_at_def swap_fresh_fresh) - done - -termination - by (relation "measure (\(x, _). size x)") (auto simp add: cpsctxt.size) - -lemma [eqvt]: "p \ ccomp c c' = ccomp (p \ c) (p \ c')" - by (nominal_induct c avoiding: c' rule: cpsctxt.strong_induct) simp_all - -nominal_primrec - CPSv :: "lt => lt" -and CPS :: "lt => cpsctxt" where - "CPSv (Var x) = x~" -| "CPS (Var x) = CFun Hole (x~)" -| "atom b \ M \ CPSv (Abs y M) = Abs y (Abs b ((CPS M)))" -| "atom b \ M \ CPS (Abs y M) = CFun Hole (Abs y (Abs b ((CPS M))))" -| "CPSv (M $ N) = Abs x (Var x)" -| "isValue M \ isValue N \ CPS (M $ N) = CArg (CPSv M $ CPSv N) Hole" -| "isValue M \ ~isValue N \ atom a \ N \ CPS (M $ N) = - ccomp (CPS N) (CAbs a (CArg (CPSv M $ Var a) Hole))" -| "~isValue M \ isValue N \ atom a \ N \ CPS (M $ N) = - ccomp (CPS M) (CAbs a (CArg (Var a $ (CPSv N)) Hole))" -| "~isValue M \ ~isValue N \ atom a \ (N, b) \ CPS (M $ N) = - ccomp (CPS M) (CAbs a (ccomp (CPS N) (CAbs b (CArg (Var a $ Var b) Hole))))" - apply auto - oops --"The goals seem reasonable" - -end