Nominal/nominal_dt_rawfuns.ML
changeset 3239 67370521c09c
parent 3226 780b7a2c50b6
child 3243 c4f31f1564b7
--- a/Nominal/nominal_dt_rawfuns.ML	Tue Jul 08 11:18:31 2014 +0100
+++ b/Nominal/nominal_dt_rawfuns.ML	Thu Jul 09 02:32:46 2015 +0100
@@ -125,7 +125,7 @@
       val raw_bn_eqs = the simps
 
       val raw_bn_info = 
-        prep_bn_info lthy raw_dt_names raw_dts fs (map prop_of raw_bn_eqs)
+        prep_bn_info lthy raw_dt_names raw_dts fs (map Thm.prop_of raw_bn_eqs)
     in
       (fs, raw_bn_eqs, raw_bn_info, raw_bn_induct, lthy2)
     end
@@ -166,7 +166,7 @@
       binders
       |> map (bind_fn lthy args)
       |> split_list
-      |> pairself combine_fn
+      |> apply2 combine_fn
     end  
 
     val t1 = map (mk_fv_body fv_map args) bodies
@@ -199,7 +199,7 @@
 
 fun mk_fv_eq lthy fv_map fv_bn_map (constr, ty, arg_tys, _) bclauses = 
   let
-    val arg_names = Datatype_Prop.make_tnames arg_tys
+    val arg_names = Old_Datatype_Prop.make_tnames arg_tys
     val args = map Free (arg_names ~~ arg_tys)
     val fv = lookup fv_map ty
     val lhs = fv $ list_comb (constr, args)
@@ -211,7 +211,7 @@
 
 fun mk_fv_bn_eq lthy bn_trm fv_map fv_bn_map (bn_args, (constr, _, arg_tys, _)) bclauses =
   let
-    val arg_names = Datatype_Prop.make_tnames arg_tys
+    val arg_names = Old_Datatype_Prop.make_tnames arg_tys
     val args = map Free (arg_names ~~ arg_tys)
     val fv_bn = lookup fv_bn_map bn_trm
     val lhs = fv_bn $ list_comb (constr, args)
@@ -287,7 +287,7 @@
 fun mk_perm_bn_eq lthy bn_trm perm_bn_map bn_args (constr, _, arg_tys, _) =
   let
     val p = Free ("p", @{typ perm})
-    val arg_names = Datatype_Prop.make_tnames arg_tys
+    val arg_names = Old_Datatype_Prop.make_tnames arg_tys
     val args = map Free (arg_names ~~ arg_tys)
     val perm_bn = lookup perm_bn_map bn_trm
     val lhs = perm_bn $ p $ list_comb (constr, args)
@@ -347,7 +347,7 @@
 fun prove_permute_zero induct perm_defs perm_fns ctxt =
   let
     val perm_types = map (body_type o fastype_of) perm_fns
-    val perm_indnames = Datatype_Prop.make_tnames perm_types
+    val perm_indnames = Old_Datatype_Prop.make_tnames perm_types
   
     fun single_goal ((perm_fn, T), x) =
       HOLogic.mk_eq (perm_fn $ @{term "0::perm"} $ Free (x, T), Free (x, T))
@@ -358,11 +358,11 @@
 
     val simpset = put_simpset HOL_basic_ss ctxt addsimps (@{thm permute_zero} :: perm_defs)
 
-    val tac = (Datatype_Aux.ind_tac induct perm_indnames 
+    val tac = (Old_Datatype_Aux.ind_tac induct perm_indnames 
                THEN_ALL_NEW asm_simp_tac simpset) 1
   in
     Goal.prove ctxt perm_indnames [] goals (K tac)
-    |> Datatype_Aux.split_conj_thm
+    |> Old_Datatype_Aux.split_conj_thm
   end
 
 
@@ -371,7 +371,7 @@
     val p = Free ("p", @{typ perm})
     val q = Free ("q", @{typ perm})
     val perm_types = map (body_type o fastype_of) perm_fns
-    val perm_indnames = Datatype_Prop.make_tnames perm_types
+    val perm_indnames = Old_Datatype_Prop.make_tnames perm_types
   
     fun single_goal ((perm_fn, T), x) = HOLogic.mk_eq 
       (perm_fn $ (mk_plus p q) $ Free (x, T), perm_fn $ p $ (perm_fn $ q $ Free (x, T)))
@@ -383,11 +383,11 @@
     (* FIXME proper goal context *)
     val simpset = put_simpset HOL_basic_ss ctxt addsimps (@{thm permute_plus} :: perm_defs)
 
-    val tac = (Datatype_Aux.ind_tac induct perm_indnames
+    val tac = (Old_Datatype_Aux.ind_tac induct perm_indnames
                THEN_ALL_NEW asm_simp_tac simpset) 1
   in
     Goal.prove ctxt ("p" :: "q" :: perm_indnames) [] goals (K tac)
-    |> Datatype_Aux.split_conj_thm 
+    |> Old_Datatype_Aux.split_conj_thm 
   end
 
 
@@ -403,7 +403,7 @@
       fastype_of cnstr
       |> strip_type
 
-    val arg_names = Name.variant_list ["p"] (Datatype_Prop.make_tnames arg_tys)
+    val arg_names = Name.variant_list ["p"] (Old_Datatype_Prop.make_tnames arg_tys)
     val args = map Free (arg_names ~~ arg_tys)
 
     val lhs = lookup_perm p (ty, list_comb (cnstr, args))
@@ -430,8 +430,8 @@
 
     val perm_eqs = map (mk_perm_eq (raw_tys ~~ perm_fn_frees)) (flat raw_all_cns)
 
-    fun tac _ (_, _, simps) =
-      Class.intro_classes_tac [] THEN ALLGOALS (resolve_tac simps)
+    fun tac ctxt (_, _, simps) =
+      Class.intro_classes_tac ctxt [] THEN ALLGOALS (resolve_tac ctxt simps)
   
     fun morphism phi (fvs, dfs, simps) =
       (map (Morphism.term phi) fvs, 
@@ -442,7 +442,7 @@
       lthy
       |> Local_Theory.exit_global
       |> Class.instantiation (raw_dt_names, raw_ty_args, @{sort pt}) 
-      |> Primrec.add_primrec perm_fn_binds perm_eqs
+      |> BNF_LFP_Compat.primrec perm_fn_binds perm_eqs
     
     val perm_zero_thms = prove_permute_zero raw_induct_thm perm_eq_thms perm_funs lthy'
     val perm_plus_thms = prove_permute_plus raw_induct_thm perm_eq_thms perm_funs lthy'  
@@ -468,7 +468,7 @@
 fun prove_eqvt_tac insts ind_thms const_names simps ctxt = 
   HEADGOAL
     (Object_Logic.full_atomize_tac ctxt
-     THEN' (DETERM o (Induct_Tacs.induct_rules_tac ctxt insts ind_thms))  
+     THEN' (DETERM o (Induct_Tacs.induct_tac ctxt insts (SOME ind_thms)))
      THEN_ALL_NEW  subproof_tac const_names simps ctxt)
 
 fun mk_eqvt_goal pi const arg =
@@ -491,13 +491,13 @@
         |> map fastype_of
         |> map domain_type 
       val (arg_names, ctxt'') = 
-        Variable.variant_fixes (Datatype_Prop.make_tnames arg_tys) ctxt'
+        Variable.variant_fixes (Old_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      
     in
-      Goal.prove_multi ctxt'' [] [] goals (fn {context, ...} => 
+      Goal.prove_common ctxt'' NONE [] [] goals (fn {context, ...} => 
         prove_eqvt_tac insts ind_thms const_names simps context)
       |> Proof_Context.export ctxt'' ctxt
     end