Nominal/nominal_dt_rawfuns.ML
changeset 2309 13f20fe02ff3
parent 2308 387fcbd33820
child 2311 4da5c5c29009
--- a/Nominal/nominal_dt_rawfuns.ML	Wed Jun 02 11:37:51 2010 +0200
+++ b/Nominal/nominal_dt_rawfuns.ML	Thu Jun 03 11:48:44 2010 +0200
@@ -226,9 +226,6 @@
   val all_fun_names = map (fn s => (Binding.name s, NONE, NoSyn)) (fv_names @ fv_bn_names)
   val all_fun_eqs = map (pair Attrib.empty_binding) (flat fv_eqs @ flat fv_bn_eqs)
 
-  val _ = tracing ("eqs\n" ^ cat_lines (map (Syntax.string_of_term lthy) ((flat fv_eqs) @ (flat fv_bn_eqs))))
-
-
   val (_, lthy') = Function.add_function all_fun_names all_fun_eqs
     Function_Common.default_config (pat_completeness_simp constr_thms) lthy
 
@@ -257,6 +254,13 @@
   HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))
 end
 
+fun subproof_tac const_names simps ctxt = 
+  Subgoal.FOCUS (fn {prems, context, ...} => 
+    HEADGOAL 
+      (simp_tac (HOL_basic_ss addsimps simps)
+       THEN' Nominal_Permeq.eqvt_tac context [] const_names
+       THEN' simp_tac (HOL_basic_ss addsimps (@{thms eqvt_apply[symmetric]} @ prems)))) ctxt 
+
 fun raw_prove_eqvt consts ind_thms simps ctxt =
   if null consts then []
   else
@@ -267,20 +271,18 @@
         consts
         |> map fastype_of
         |> map domain_type 
-      val (arg_names, ctxt'') = Variable.variant_fixes (replicate (length arg_tys) "") ctxt'
+      val (arg_names, ctxt'') = Variable.variant_fixes (Datatype_Prop.make_tnames arg_tys) ctxt'
       val args = map Free (arg_names ~~ arg_tys)
       val goals = map2 (mk_eqvt_goal p) consts args
       val insts = map (single o SOME) arg_names
       val const_names = map (fst o dest_Const) consts
+
       fun tac ctxt = 
         Object_Logic.full_atomize_tac
-        THEN' InductTacs.induct_rules_tac ctxt insts ind_thms 
-        THEN_ALL_NEW   
-          (asm_full_simp_tac (HOL_basic_ss addsimps simps)
-           THEN' Nominal_Permeq.eqvt_tac ctxt simps const_names
-           THEN' asm_simp_tac HOL_basic_ss)
+        THEN' (DETERM o (InductTacs.induct_rules_tac ctxt insts ind_thms))  
+        THEN_ALL_NEW  subproof_tac const_names simps ctxt 
     in
-      Goal.prove_multi ctxt' [] [] goals (fn {context, ...} => (HEADGOAL (tac context)))
+      Goal.prove_multi ctxt'' [] [] goals (fn {context, ...} => (HEADGOAL (tac context)))
       |> ProofContext.export ctxt'' ctxt
     end