src/HOL/Codatatype/Tools/bnf_fp_sugar.ML
changeset 49221 6d8d5fe9f3a2
parent 49220 a6260b4fb410
child 49224 60a0394d98f7
equal deleted inserted replaced
49220:a6260b4fb410 49221:6d8d5fe9f3a2
   220           (((gss, g_Tss, map (map (map single)) ysss), (hss, h_Tss, zssss)),
   220           (((gss, g_Tss, map (map (map single)) ysss), (hss, h_Tss, zssss)),
   221            ([], [], [], (([], []), [], [], []), (([], []), [], [], [])))
   221            ([], [], [], (([], []), [], [], []), (([], []), [], [], [])))
   222         end
   222         end
   223       else
   223       else
   224         let
   224         let
       
   225           (*avoid "'a itself" arguments in coiterators and corecursors*)
       
   226           val mss' =  map (fn [0] => [1] | ms => ms) mss;
       
   227 
   225           val p_Tss =
   228           val p_Tss =
   226             map2 (fn C => fn n => replicate (Int.max (0, n - 1)) (C --> HOLogic.boolT)) Cs ns;
   229             map2 (fn C => fn n => replicate (Int.max (0, n - 1)) (C --> HOLogic.boolT)) Cs ns;
   227 
   230 
   228           fun popescu_zip [] [fs] = fs
   231           fun popescu_zip [] [fs] = fs
   229             | popescu_zip (p :: ps) (fs :: fss) = p :: fs @ popescu_zip ps fss;
   232             | popescu_zip (p :: ps) (fs :: fss) = p :: fs @ popescu_zip ps fss;
   231           fun mk_types fun_Ts =
   234           fun mk_types fun_Ts =
   232             let
   235             let
   233               val f_sum_prod_Ts = map range_type fun_Ts;
   236               val f_sum_prod_Ts = map range_type fun_Ts;
   234               val f_prod_Tss = map2 dest_sumTN ns f_sum_prod_Ts;
   237               val f_prod_Tss = map2 dest_sumTN ns f_sum_prod_Ts;
   235               val f_Tsss =
   238               val f_Tsss =
   236                 map3 (fn C => map2 (map (curry (op -->) C) oo dest_tupleT)) Cs mss f_prod_Tss;
   239                 map3 (fn C => map2 (map (curry (op -->) C) oo dest_tupleT)) Cs mss' f_prod_Tss;
   237               val pf_Tss = map2 popescu_zip p_Tss f_Tsss
   240               val pf_Tss = map2 popescu_zip p_Tss f_Tsss
   238             in (f_sum_prod_Ts, f_prod_Tss, f_Tsss, pf_Tss) end;
   241             in (f_sum_prod_Ts, f_prod_Tss, f_Tsss, pf_Tss) end;
   239 
   242 
   240           val (g_sum_prod_Ts, g_prod_Tss, g_Tsss, pg_Tss) = mk_types fp_iter_fun_Ts;
   243           val (g_sum_prod_Ts, g_prod_Tss, g_Tsss, pg_Tss) = mk_types fp_iter_fun_Ts;
   241           val (h_sum_prod_Ts, h_prod_Tss, h_Tsss, ph_Tss) = mk_types fp_rec_fun_Ts;
   244           val (h_sum_prod_Ts, h_prod_Tss, h_Tsss, ph_Tss) = mk_types fp_rec_fun_Ts;