add a tactic to generate fresh names
authornarboux
Thu Apr 19 16:27:53 2007 +0200 (2007-04-19)
changeset 2272969ef734825c5
parent 22728 ecbbdf50df2f
child 22730 8bcc8809ed3b
add a tactic to generate fresh names
src/HOL/Nominal/Nominal.thy
src/HOL/Nominal/nominal_fresh_fun.ML
     1.1 --- a/src/HOL/Nominal/Nominal.thy	Wed Apr 18 21:30:14 2007 +0200
     1.2 +++ b/src/HOL/Nominal/Nominal.thy	Thu Apr 19 16:27:53 2007 +0200
     1.3 @@ -3203,6 +3203,10 @@
     1.4  (* various tactics for analysing permutations, supports etc *)
     1.5  use "nominal_permeq.ML";
     1.6  
     1.7 +(****************************************************************)
     1.8 +(* tactics for generating fresh names and simplifying fresh_fun *)
     1.9 +use "nominal_fresh_fun.ML";
    1.10 +
    1.11  method_setup perm_simp =
    1.12    {* NominalPermeq.perm_simp_meth *}
    1.13    {* simp rules and simprocs for analysing permutations *}
    1.14 @@ -3243,6 +3247,16 @@
    1.15    {* NominalPermeq.fresh_guess_meth_debug *}
    1.16    {* tactic for deciding whether an atom is fresh for something including debugging facilities *}
    1.17  
    1.18 +
    1.19 +method_setup generate_fresh = 
    1.20 +  {* setup_generate_fresh *} 
    1.21 +  {* tactic to generate a name fresh for all the variables in the goal *}
    1.22 +
    1.23 +method_setup fresh_fun_simp = 
    1.24 +  {* setup_fresh_fun_simp *} 
    1.25 +  {* tactic to delete one inner occurence of fresh_fun *}
    1.26 +
    1.27 +
    1.28  (************************************************)
    1.29  (* main file for constructing nominal datatypes *)
    1.30  use "nominal_package.ML"
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Nominal/nominal_fresh_fun.ML	Thu Apr 19 16:27:53 2007 +0200
     2.3 @@ -0,0 +1,154 @@
     2.4 +(*  Title:      HOL/Nominal/nominal_fresh_fun.ML
     2.5 +    ID:         $Id$
     2.6 +    Authors:    Stefan Berghofer, Julien Narboux, TU Muenchen
     2.7 +
     2.8 +A tactic to generate fresh names.
     2.9 +A tactic to get rid of the fresh_fun.
    2.10 +*)
    2.11 +
    2.12 +(* First some functions that could be
    2.13 + in the library *)
    2.14 +
    2.15 +fun gen_res_inst_tac_term instf tyinst tinst elim th i st =
    2.16 +  let
    2.17 +    val thy = theory_of_thm st;
    2.18 +    val cgoal = nth (cprems_of st) (i - 1);
    2.19 +    val {maxidx, ...} = rep_cterm cgoal;
    2.20 +    val j = maxidx + 1;
    2.21 +    val tyinst' = map (apfst (Logic.incr_tvar j)) tyinst;
    2.22 +    val ps = Logic.strip_params (term_of cgoal);
    2.23 +    val Ts = map snd ps;
    2.24 +    val tinst' = map (fn (t, u) =>
    2.25 +      (head_of (Logic.incr_indexes (Ts, j) t),
    2.26 +       list_abs (ps, u))) tinst;
    2.27 +    val th' = instf
    2.28 +      (map (pairself (ctyp_of thy)) tyinst')
    2.29 +      (map (pairself (cterm_of thy)) tinst')
    2.30 +      (Thm.lift_rule cgoal th)
    2.31 +  in
    2.32 +    compose_tac (elim, th', nprems_of th) i st
    2.33 +  end handle Subscript => Seq.empty;
    2.34 +
    2.35 +val res_inst_tac_term = 
    2.36 +  gen_res_inst_tac_term (curry Thm.instantiate);
    2.37 +
    2.38 +val res_inst_tac_term' = 
    2.39 +  gen_res_inst_tac_term (K Drule.cterm_instantiate) [];
    2.40 +
    2.41 +fun cut_inst_tac_term' tinst th =
    2.42 +  res_inst_tac_term' tinst false (Tactic.make_elim_preserve th);
    2.43 +
    2.44 +fun get_dyn_thm thy name atom_name = (PureThy.get_thm thy (Name name)) handle _ => raise ERROR ("The atom type "^atom_name^" is not defined."); 
    2.45 +
    2.46 +(* End of function waiting to be
    2.47 + in the library *)
    2.48 +
    2.49 +(* The theorems needed that are known at
    2.50 +compile time. *)
    2.51 +
    2.52 +val at_exists_fresh' = thm "at_exists_fresh'";
    2.53 +val fresh_fun_app = thm "fresh_fun_app";
    2.54 +val fresh_prod = thm "fresh_prod";
    2.55 +
    2.56 +(* A tactic to generate a name fresh for 
    2.57 +all the free variables and parameters of the goal *)
    2.58 +
    2.59 +fun generate_fresh_tac atom_name i thm =
    2.60 + let 
    2.61 +   val thy = theory_of_thm thm;
    2.62 +(* the parsing function returns a qualified name, we get back the base name *)
    2.63 +   val atom_basename = Sign.base_name atom_name;
    2.64 +   val goal = List.nth(prems_of thm, i-1);
    2.65 +   val ps = Logic.strip_params goal;
    2.66 +   val Ts = rev (map snd ps);
    2.67 +   fun is_of_fs_name T = Type.of_sort (Sign.tsig_of thy)
    2.68 +     (T, Sign.intern_sort thy ["fs_"^atom_basename]); 
    2.69 +(* rebuild de bruijn indices *)
    2.70 +   val bvs = map_index (Bound o fst) ps;
    2.71 +(* select variables of the right class *)
    2.72 +   val vs = filter (fn t => is_of_fs_name (fastype_of1 (Ts, t)))
    2.73 +     (term_frees goal @ bvs);
    2.74 +(* build the tuple *)
    2.75 +   val s = Library.foldr1 (fn (v, s) =>
    2.76 +     HOLogic.pair_const (fastype_of1 (Ts, v)) (fastype_of1 (Ts, s)) $ v $ s)
    2.77 +       vs;
    2.78 +   val fs_name_thm = get_dyn_thm thy ("fs_"^atom_basename^"1") atom_basename;
    2.79 +   val at_name_inst_thm = get_dyn_thm thy ("at_"^atom_basename^"_inst") atom_basename;
    2.80 +   val exists_fresh' = at_name_inst_thm RS at_exists_fresh';
    2.81 +(* find the variable we want to instantiate *)
    2.82 +   val x = hd (term_vars (prop_of exists_fresh'));
    2.83 + in 
    2.84 +   (cut_inst_tac_term' [(x,s)] exists_fresh' 1 THEN
    2.85 +   rtac fs_name_thm 1 THEN
    2.86 +   etac exE 1) thm
    2.87 +  handle Empty  => all_tac thm (* if we collected no variables then we do nothing *)
    2.88 +  end;
    2.89 +
    2.90 +fun get_inner_fresh_fun (Bound j) = NONE
    2.91 +  | get_inner_fresh_fun (v as Free _) = NONE 
    2.92 +  | get_inner_fresh_fun (v as Var _)  = NONE
    2.93 +  | get_inner_fresh_fun (Const _) = NONE
    2.94 +  | get_inner_fresh_fun (Abs (_, _, t)) = get_inner_fresh_fun t 
    2.95 +  | get_inner_fresh_fun (Const ("Nominal.fresh_fun",Type("fun",[Type ("fun",[Type (T,_),_]),_])) $ u) = SOME T 
    2.96 +  | get_inner_fresh_fun (t $ u) = 
    2.97 +     let val a = get_inner_fresh_fun u in
    2.98 +     if a = NONE then get_inner_fresh_fun t else a 
    2.99 +     end;
   2.100 +
   2.101 +(* This tactic generates a fresh name 
   2.102 +of the atom type given by the inner most fresh_fun *)
   2.103 +
   2.104 +fun generate_fresh_fun_tac i thm =
   2.105 +  let
   2.106 +    val goal = List.nth(prems_of thm, i-1);
   2.107 +    val atom_name_opt = get_inner_fresh_fun goal;
   2.108 +  in
   2.109 +  case atom_name_opt of 
   2.110 +    NONE => all_tac thm
   2.111 +  | SOME atom_name  => generate_fresh_tac atom_name i thm               
   2.112 +  end
   2.113 +
   2.114 +(* A substitution tactic, FIXME : change the search function to get the inner occurence of fresh_fun (bottom -> up search ) *)
   2.115 +
   2.116 +fun subst_outer_tac ctx = EqSubst.eqsubst_tac' ctx (curry (Seq.flat o (uncurry EqSubst.searchf_lr_unify_valid)));
   2.117 +
   2.118 +fun fresh_fun_tac i thm = 
   2.119 +  (* Find the variable we instantiate *)
   2.120 +  let
   2.121 +    val thy = theory_of_thm thm;
   2.122 +    val ctx = Context.init_proof thy;
   2.123 +    val ss = simpset_of thy;
   2.124 +    val abs_fresh = PureThy.get_thms thy (Name "abs_fresh");
   2.125 +    val ss' = ss addsimps fresh_prod::abs_fresh;
   2.126 +    val x = hd (tl (term_vars (prop_of exI)));
   2.127 +    val goal = List.nth(prems_of thm, i-1);
   2.128 +    val atom_name_opt = get_inner_fresh_fun goal;
   2.129 +    val n = List.length (Logic.strip_params goal);
   2.130 +    (* Here we rely on the fact that the variable introduced by generate_fresh_tac is the last one in the list, the inner one *)
   2.131 +  in
   2.132 +  case atom_name_opt of 
   2.133 +    NONE => all_tac thm
   2.134 +  | SOME atom_name  =>    
   2.135 +  let 
   2.136 +    val atom_basename = Sign.base_name atom_name;
   2.137 +    val pt_name_inst = get_dyn_thm thy ("pt_"^atom_basename^"_inst") atom_basename;
   2.138 +    val at_name_inst = get_dyn_thm thy ("at_"^atom_basename^"_inst") atom_basename;
   2.139 +  in
   2.140 +  (generate_fresh_tac atom_name i               THEN
   2.141 +   subst_outer_tac ctx fresh_fun_app i          THEN
   2.142 +   rtac pt_name_inst i                          THEN
   2.143 +   rtac at_name_inst i                          THEN
   2.144 +   NominalPermeq.finite_guess_tac HOL_ss i      THEN
   2.145 +   auto_tac (HOL_cs , HOL_ss)                   THEN
   2.146 +   NominalPermeq.fresh_guess_tac HOL_ss (i+1)   THEN
   2.147 +   res_inst_tac_term' [(x,Bound n)] false exI i THEN
   2.148 +   asm_full_simp_tac ss' i                      THEN
   2.149 +   NominalPermeq.fresh_guess_tac HOL_ss i) thm 
   2.150 +  end
   2.151 +  end
   2.152 +
   2.153 +val setup_generate_fresh =
   2.154 +  Method.goal_args_ctxt' Args.tyname (fn ctxt => generate_fresh_tac) 
   2.155 +
   2.156 +val setup_fresh_fun_simp =
   2.157 +  Method.no_args (Method.SIMPLE_METHOD (fresh_fun_tac 1))