tuning

--- a/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Fri Jun 07 11:42:37 2013 +0200
+++ b/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Fri Jun 07 12:00:29 2013 +0200
@@ -16,8 +16,7 @@
      ctr_defss: thm list list,
      ctr_sugars: BNF_Ctr_Sugar.ctr_sugar list,
      co_iterss: term list list,
-     co_induct: thm,
-     strong_co_induct: thm,
+     co_inducts: thm list,
      co_iter_thmsss: thm list list list};
 
   val of_fp_sugar: (fp_sugar -> 'a list) -> fp_sugar -> 'a
@@ -104,8 +103,7 @@
    ctr_defss: thm list list,
    ctr_sugars: ctr_sugar list,
    co_iterss: term list list,
-   co_induct: thm,
-   strong_co_induct: thm,
+   co_inducts: thm list,
    co_iter_thmsss: thm list list list};
 
 fun of_fp_sugar f (fp_sugar as {index, ...}) = nth (f fp_sugar) index;
@@ -114,14 +112,14 @@
     {T = T2, fp = fp2, index = index2, fp_res = fp_res2, ...} : fp_sugar) =
   T1 = T2 andalso fp1 = fp2 andalso index1 = index2 andalso eq_fp_result (fp_res1, fp_res2);
 
-fun morph_fp_sugar phi {T, fp, index, pre_bnfs, fp_res, ctr_defss, ctr_sugars, co_iterss, co_induct,
-    strong_co_induct, co_iter_thmsss} =
+fun morph_fp_sugar phi {T, fp, index, pre_bnfs, fp_res, ctr_defss, ctr_sugars, co_iterss,
+    co_inducts, co_iter_thmsss} =
   {T = Morphism.typ phi T, fp = fp, index = index, pre_bnfs = map (morph_bnf phi)
    pre_bnfs, fp_res = morph_fp_result phi fp_res,
    ctr_defss = map (map (Morphism.thm phi)) ctr_defss,
    ctr_sugars = map (morph_ctr_sugar phi) ctr_sugars,
-   co_iterss = map (map (Morphism.term phi)) co_iterss, co_induct = Morphism.thm phi co_induct,
-   strong_co_induct = Morphism.thm phi strong_co_induct,
+   co_iterss = map (map (Morphism.term phi)) co_iterss,
+   co_inducts = map (Morphism.thm phi) co_inducts,
    co_iter_thmsss = map (map (map (Morphism.thm phi))) co_iter_thmsss};
 
 structure Data = Generic_Data
@@ -138,13 +136,13 @@
   Local_Theory.declaration {syntax = false, pervasive = true}
     (fn phi => Data.map (Symtab.update_new (key, morph_fp_sugar phi fp_sugar)));
 
-fun register_fp_sugars fp pre_bnfs (fp_res as {Ts, ...}) ctr_defss ctr_sugars co_iterss co_induct
-    strong_co_induct co_iter_thmsss lthy =
+fun register_fp_sugars fp pre_bnfs (fp_res as {Ts, ...}) ctr_defss ctr_sugars co_iterss co_inducts
+    co_iter_thmsss lthy =
   (0, lthy)
   |> fold (fn T as Type (s, _) => fn (kk, lthy) => (kk + 1,
     register_fp_sugar s {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, fp_res = fp_res,
         ctr_defss = ctr_defss, ctr_sugars = ctr_sugars, co_iterss = co_iterss,
-        co_induct = co_induct, strong_co_induct = strong_co_induct, co_iter_thmsss = co_iter_thmsss}
+        co_inducts = co_inducts, co_iter_thmsss = co_iter_thmsss}
       lthy)) Ts
   |> snd;
 
@@ -1347,8 +1345,8 @@
       in
         lthy
         |> Local_Theory.notes (common_notes @ notes) |> snd
-        |> register_fp_sugars Least_FP pre_bnfs fp_res ctr_defss ctr_sugars iterss induct_thm
-          induct_thm (transpose [fold_thmss, rec_thmss])
+        |> register_fp_sugars Least_FP pre_bnfs fp_res ctr_defss ctr_sugars iterss [induct_thm]
+          (transpose [fold_thmss, rec_thmss])
       end;
 
     fun derive_and_note_coinduct_coiters_thms_for_types
@@ -1407,8 +1405,8 @@
       in
         lthy
         |> Local_Theory.notes (anonymous_notes @ common_notes @ notes) |> snd
-        |> register_fp_sugars Greatest_FP pre_bnfs fp_res ctr_defss ctr_sugars coiterss coinduct_thm
-          strong_coinduct_thm (transpose [unfold_thmss, corec_thmss])
+        |> register_fp_sugars Greatest_FP pre_bnfs fp_res ctr_defss ctr_sugars coiterss
+          [coinduct_thm, strong_coinduct_thm] (transpose [unfold_thmss, corec_thmss])
       end;
 
     val lthy' = lthy

--- a/src/HOL/BNF/Tools/bnf_fp_util.ML	Fri Jun 07 11:42:37 2013 +0200
+++ b/src/HOL/BNF/Tools/bnf_fp_util.ML	Fri Jun 07 12:00:29 2013 +0200
@@ -28,6 +28,8 @@
 
   val morph_fp_result: morphism -> fp_result -> fp_result
   val eq_fp_result: fp_result * fp_result -> bool
+  val weak_co_induct_of: 'a list -> 'a
+  val strong_co_induct_of: 'a list -> 'a
   val un_fold_of: 'a list -> 'a
   val co_rec_of: 'a list -> 'a
 
@@ -217,6 +219,9 @@
 fun eq_fp_result ({bnfs = bnfs1, ...} : fp_result, {bnfs = bnfs2, ...} : fp_result) =
   eq_list eq_bnf (bnfs1, bnfs2);
 
+fun weak_co_induct_of [w, _] = w;
+fun strong_co_induct_of [_, s] = s;
+
 fun un_fold_of [f, _] = f;
 fun co_rec_of [_, r] = r;