372 |
372 |
373 fun corec_specs_of bs arg_Ts res_Ts callers callssss0 lthy0 = |
373 fun corec_specs_of bs arg_Ts res_Ts callers callssss0 lthy0 = |
374 let |
374 let |
375 val thy = Proof_Context.theory_of lthy0; |
375 val thy = Proof_Context.theory_of lthy0; |
376 |
376 |
377 val ((missing_res_Ts, perm0_kks, fp_sugars as {nested_bnfs, co_iters = coiter1 :: _, |
377 val ((missing_res_Ts, perm0_kks, fp_sugars as {nested_bnfs, co_rec = corec, |
378 common_co_inducts = common_coinduct_thms, ...} :: _, |
378 common_co_inducts = common_coinduct_thms, ...} :: _, |
379 (_, gfp_sugar_thms)), lthy) = |
379 (_, gfp_sugar_thms)), lthy) = |
380 nested_to_mutual_fps Greatest_FP bs res_Ts callers callssss0 lthy0; |
380 nested_to_mutual_fps Greatest_FP bs res_Ts callers callssss0 lthy0; |
381 |
381 |
382 val perm_fp_sugars = sort (int_ord o pairself #fp_res_index) fp_sugars; |
382 val perm_fp_sugars = sort (int_ord o pairself #fp_res_index) fp_sugars; |
392 val kks = 0 upto nn - 1; |
392 val kks = 0 upto nn - 1; |
393 val perm_ns' = map length perm_ctrXs_Tsss'; |
393 val perm_ns' = map length perm_ctrXs_Tsss'; |
394 |
394 |
395 val perm_Ts = map #T perm_fp_sugars; |
395 val perm_Ts = map #T perm_fp_sugars; |
396 val perm_Xs = map #X perm_fp_sugars; |
396 val perm_Xs = map #X perm_fp_sugars; |
397 val perm_Cs = map (domain_type o body_fun_type o fastype_of o co_rec_of o #co_iters) perm_fp_sugars; |
397 val perm_Cs = map (domain_type o body_fun_type o fastype_of o #co_rec) perm_fp_sugars; |
398 val Xs_TCs = perm_Xs ~~ (perm_Ts ~~ perm_Cs); |
398 val Xs_TCs = perm_Xs ~~ (perm_Ts ~~ perm_Cs); |
399 |
399 |
400 fun zip_corecT (Type (s, Us)) = [Type (s, map (mk_sumTN o zip_corecT) Us)] |
400 fun zip_corecT (Type (s, Us)) = [Type (s, map (mk_sumTN o zip_corecT) Us)] |
401 | zip_corecT U = |
401 | zip_corecT U = |
402 (case AList.lookup (op =) Xs_TCs U of |
402 (case AList.lookup (op =) Xs_TCs U of |
452 disc_excludess = disc_excludess, collapse = collapse, corec_thm = corec_thm, |
452 disc_excludess = disc_excludess, collapse = collapse, corec_thm = corec_thm, |
453 disc_corec = disc_corec, sel_corecs = sel_corecs} |
453 disc_corec = disc_corec, sel_corecs = sel_corecs} |
454 end; |
454 end; |
455 |
455 |
456 fun mk_ctr_specs ({ctrs, discs, selss, discIs, sel_thmss, disc_excludesss, collapses, ...} |
456 fun mk_ctr_specs ({ctrs, discs, selss, discIs, sel_thmss, disc_excludesss, collapses, ...} |
457 : ctr_sugar) p_is q_isss f_isss f_Tsss coiter_thmss disc_coiterss sel_coitersss = |
457 : ctr_sugar) p_is q_isss f_isss f_Tsss corec_thms disc_corecs sel_corecss = |
458 let |
458 let val p_ios = map SOME p_is @ [NONE] in |
459 val p_ios = map SOME p_is @ [NONE]; |
|
460 val corec_thms = co_rec_of coiter_thmss; |
|
461 val disc_corecs = co_rec_of disc_coiterss; |
|
462 val sel_corecss = co_rec_of sel_coitersss; |
|
463 in |
|
464 map14 mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss |
459 map14 mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss |
465 disc_excludesss collapses corec_thms disc_corecs sel_corecss |
460 disc_excludesss collapses corec_thms disc_corecs sel_corecss |
466 end; |
461 end; |
467 |
462 |
468 fun mk_spec ({T, ctr_sugar as {disc_exhausts, ...}, co_iters = coiters, |
463 fun mk_spec ({T, ctr_sugar as {disc_exhausts, ...}, co_rec = corec, |
469 co_iter_thmss = coiter_thmss, disc_co_iterss = disc_coiterss, |
464 co_rec_thms = corec_thms, disc_co_recs = disc_corecs, |
470 sel_co_itersss = sel_coitersss, ...} : fp_sugar) p_is q_isss f_isss f_Tsss = |
465 sel_co_recss = sel_corecss, ...} : fp_sugar) p_is q_isss f_isss f_Tsss = |
471 {corec = mk_co_iter thy Greatest_FP (substAT T) perm_Cs' (co_rec_of coiters), |
466 {corec = mk_co_iter thy Greatest_FP (substAT T) perm_Cs' corec, |
472 disc_exhausts = disc_exhausts, |
467 disc_exhausts = disc_exhausts, |
473 nested_maps = maps (map_thms_of_typ lthy o T_of_bnf) nested_bnfs, |
468 nested_maps = maps (map_thms_of_typ lthy o T_of_bnf) nested_bnfs, |
474 nested_map_idents = map (unfold_thms lthy @{thms id_def} o map_id0_of_bnf) nested_bnfs, |
469 nested_map_idents = map (unfold_thms lthy @{thms id_def} o map_id0_of_bnf) nested_bnfs, |
475 nested_map_comps = map map_comp_of_bnf nested_bnfs, |
470 nested_map_comps = map map_comp_of_bnf nested_bnfs, |
476 ctr_specs = mk_ctr_specs ctr_sugar p_is q_isss f_isss f_Tsss coiter_thmss disc_coiterss |
471 ctr_specs = mk_ctr_specs ctr_sugar p_is q_isss f_isss f_Tsss corec_thms disc_corecs |
477 sel_coitersss}; |
472 sel_corecss}; |
478 in |
473 in |
479 ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts, |
474 ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts, |
480 co_induct_of common_coinduct_thms, strong_co_induct_of common_coinduct_thms, |
475 co_induct_of common_coinduct_thms, strong_co_induct_of common_coinduct_thms, |
481 co_induct_of coinduct_thmss, strong_co_induct_of coinduct_thmss), lthy) |
476 co_induct_of coinduct_thmss, strong_co_induct_of coinduct_thmss), lthy) |
482 end; |
477 end; |