src/HOL/Nominal/nominal_fresh_fun.ML
changeset 22729 69ef734825c5
child 22753 49d7818e6161
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Nominal/nominal_fresh_fun.ML	Thu Apr 19 16:27:53 2007 +0200
     1.3 @@ -0,0 +1,154 @@
     1.4 +(*  Title:      HOL/Nominal/nominal_fresh_fun.ML
     1.5 +    ID:         $Id$
     1.6 +    Authors:    Stefan Berghofer, Julien Narboux, TU Muenchen
     1.7 +
     1.8 +A tactic to generate fresh names.
     1.9 +A tactic to get rid of the fresh_fun.
    1.10 +*)
    1.11 +
    1.12 +(* First some functions that could be
    1.13 + in the library *)
    1.14 +
    1.15 +fun gen_res_inst_tac_term instf tyinst tinst elim th i st =
    1.16 +  let
    1.17 +    val thy = theory_of_thm st;
    1.18 +    val cgoal = nth (cprems_of st) (i - 1);
    1.19 +    val {maxidx, ...} = rep_cterm cgoal;
    1.20 +    val j = maxidx + 1;
    1.21 +    val tyinst' = map (apfst (Logic.incr_tvar j)) tyinst;
    1.22 +    val ps = Logic.strip_params (term_of cgoal);
    1.23 +    val Ts = map snd ps;
    1.24 +    val tinst' = map (fn (t, u) =>
    1.25 +      (head_of (Logic.incr_indexes (Ts, j) t),
    1.26 +       list_abs (ps, u))) tinst;
    1.27 +    val th' = instf
    1.28 +      (map (pairself (ctyp_of thy)) tyinst')
    1.29 +      (map (pairself (cterm_of thy)) tinst')
    1.30 +      (Thm.lift_rule cgoal th)
    1.31 +  in
    1.32 +    compose_tac (elim, th', nprems_of th) i st
    1.33 +  end handle Subscript => Seq.empty;
    1.34 +
    1.35 +val res_inst_tac_term = 
    1.36 +  gen_res_inst_tac_term (curry Thm.instantiate);
    1.37 +
    1.38 +val res_inst_tac_term' = 
    1.39 +  gen_res_inst_tac_term (K Drule.cterm_instantiate) [];
    1.40 +
    1.41 +fun cut_inst_tac_term' tinst th =
    1.42 +  res_inst_tac_term' tinst false (Tactic.make_elim_preserve th);
    1.43 +
    1.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."); 
    1.45 +
    1.46 +(* End of function waiting to be
    1.47 + in the library *)
    1.48 +
    1.49 +(* The theorems needed that are known at
    1.50 +compile time. *)
    1.51 +
    1.52 +val at_exists_fresh' = thm "at_exists_fresh'";
    1.53 +val fresh_fun_app = thm "fresh_fun_app";
    1.54 +val fresh_prod = thm "fresh_prod";
    1.55 +
    1.56 +(* A tactic to generate a name fresh for 
    1.57 +all the free variables and parameters of the goal *)
    1.58 +
    1.59 +fun generate_fresh_tac atom_name i thm =
    1.60 + let 
    1.61 +   val thy = theory_of_thm thm;
    1.62 +(* the parsing function returns a qualified name, we get back the base name *)
    1.63 +   val atom_basename = Sign.base_name atom_name;
    1.64 +   val goal = List.nth(prems_of thm, i-1);
    1.65 +   val ps = Logic.strip_params goal;
    1.66 +   val Ts = rev (map snd ps);
    1.67 +   fun is_of_fs_name T = Type.of_sort (Sign.tsig_of thy)
    1.68 +     (T, Sign.intern_sort thy ["fs_"^atom_basename]); 
    1.69 +(* rebuild de bruijn indices *)
    1.70 +   val bvs = map_index (Bound o fst) ps;
    1.71 +(* select variables of the right class *)
    1.72 +   val vs = filter (fn t => is_of_fs_name (fastype_of1 (Ts, t)))
    1.73 +     (term_frees goal @ bvs);
    1.74 +(* build the tuple *)
    1.75 +   val s = Library.foldr1 (fn (v, s) =>
    1.76 +     HOLogic.pair_const (fastype_of1 (Ts, v)) (fastype_of1 (Ts, s)) $ v $ s)
    1.77 +       vs;
    1.78 +   val fs_name_thm = get_dyn_thm thy ("fs_"^atom_basename^"1") atom_basename;
    1.79 +   val at_name_inst_thm = get_dyn_thm thy ("at_"^atom_basename^"_inst") atom_basename;
    1.80 +   val exists_fresh' = at_name_inst_thm RS at_exists_fresh';
    1.81 +(* find the variable we want to instantiate *)
    1.82 +   val x = hd (term_vars (prop_of exists_fresh'));
    1.83 + in 
    1.84 +   (cut_inst_tac_term' [(x,s)] exists_fresh' 1 THEN
    1.85 +   rtac fs_name_thm 1 THEN
    1.86 +   etac exE 1) thm
    1.87 +  handle Empty  => all_tac thm (* if we collected no variables then we do nothing *)
    1.88 +  end;
    1.89 +
    1.90 +fun get_inner_fresh_fun (Bound j) = NONE
    1.91 +  | get_inner_fresh_fun (v as Free _) = NONE 
    1.92 +  | get_inner_fresh_fun (v as Var _)  = NONE
    1.93 +  | get_inner_fresh_fun (Const _) = NONE
    1.94 +  | get_inner_fresh_fun (Abs (_, _, t)) = get_inner_fresh_fun t 
    1.95 +  | get_inner_fresh_fun (Const ("Nominal.fresh_fun",Type("fun",[Type ("fun",[Type (T,_),_]),_])) $ u) = SOME T 
    1.96 +  | get_inner_fresh_fun (t $ u) = 
    1.97 +     let val a = get_inner_fresh_fun u in
    1.98 +     if a = NONE then get_inner_fresh_fun t else a 
    1.99 +     end;
   1.100 +
   1.101 +(* This tactic generates a fresh name 
   1.102 +of the atom type given by the inner most fresh_fun *)
   1.103 +
   1.104 +fun generate_fresh_fun_tac i thm =
   1.105 +  let
   1.106 +    val goal = List.nth(prems_of thm, i-1);
   1.107 +    val atom_name_opt = get_inner_fresh_fun goal;
   1.108 +  in
   1.109 +  case atom_name_opt of 
   1.110 +    NONE => all_tac thm
   1.111 +  | SOME atom_name  => generate_fresh_tac atom_name i thm               
   1.112 +  end
   1.113 +
   1.114 +(* A substitution tactic, FIXME : change the search function to get the inner occurence of fresh_fun (bottom -> up search ) *)
   1.115 +
   1.116 +fun subst_outer_tac ctx = EqSubst.eqsubst_tac' ctx (curry (Seq.flat o (uncurry EqSubst.searchf_lr_unify_valid)));
   1.117 +
   1.118 +fun fresh_fun_tac i thm = 
   1.119 +  (* Find the variable we instantiate *)
   1.120 +  let
   1.121 +    val thy = theory_of_thm thm;
   1.122 +    val ctx = Context.init_proof thy;
   1.123 +    val ss = simpset_of thy;
   1.124 +    val abs_fresh = PureThy.get_thms thy (Name "abs_fresh");
   1.125 +    val ss' = ss addsimps fresh_prod::abs_fresh;
   1.126 +    val x = hd (tl (term_vars (prop_of exI)));
   1.127 +    val goal = List.nth(prems_of thm, i-1);
   1.128 +    val atom_name_opt = get_inner_fresh_fun goal;
   1.129 +    val n = List.length (Logic.strip_params goal);
   1.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 *)
   1.131 +  in
   1.132 +  case atom_name_opt of 
   1.133 +    NONE => all_tac thm
   1.134 +  | SOME atom_name  =>    
   1.135 +  let 
   1.136 +    val atom_basename = Sign.base_name atom_name;
   1.137 +    val pt_name_inst = get_dyn_thm thy ("pt_"^atom_basename^"_inst") atom_basename;
   1.138 +    val at_name_inst = get_dyn_thm thy ("at_"^atom_basename^"_inst") atom_basename;
   1.139 +  in
   1.140 +  (generate_fresh_tac atom_name i               THEN
   1.141 +   subst_outer_tac ctx fresh_fun_app i          THEN
   1.142 +   rtac pt_name_inst i                          THEN
   1.143 +   rtac at_name_inst i                          THEN
   1.144 +   NominalPermeq.finite_guess_tac HOL_ss i      THEN
   1.145 +   auto_tac (HOL_cs , HOL_ss)                   THEN
   1.146 +   NominalPermeq.fresh_guess_tac HOL_ss (i+1)   THEN
   1.147 +   res_inst_tac_term' [(x,Bound n)] false exI i THEN
   1.148 +   asm_full_simp_tac ss' i                      THEN
   1.149 +   NominalPermeq.fresh_guess_tac HOL_ss i) thm 
   1.150 +  end
   1.151 +  end
   1.152 +
   1.153 +val setup_generate_fresh =
   1.154 +  Method.goal_args_ctxt' Args.tyname (fn ctxt => generate_fresh_tac) 
   1.155 +
   1.156 +val setup_fresh_fun_simp =
   1.157 +  Method.no_args (Method.SIMPLE_METHOD (fresh_fun_tac 1))