368 |
368 |
369 fun map_thms_of_typ ctxt (Type (s, _)) = |
369 fun map_thms_of_typ ctxt (Type (s, _)) = |
370 (case fp_sugar_of ctxt s of SOME {maps, ...} => maps | NONE => []) |
370 (case fp_sugar_of ctxt s of SOME {maps, ...} => maps | NONE => []) |
371 | map_thms_of_typ _ _ = []; |
371 | map_thms_of_typ _ _ = []; |
372 |
372 |
373 fun corec_specs_of bs arg_Ts res_Ts get_indices 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, |
377 val ((missing_res_Ts, perm0_kks, fp_sugars as {nested_bnfs, co_iters = coiter1 :: _, |
378 fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = dtor_coiters1 :: _, ...}, |
378 common_co_inducts = common_coinduct_thms, ...} :: _, |
379 common_co_inducts = common_coinduct_thms, ...} :: _, (_, gfp_sugar_thms)), lthy) = |
379 (_, gfp_sugar_thms)), lthy) = |
380 nested_to_mutual_fps Greatest_FP bs res_Ts get_indices 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; |
383 |
383 |
384 val indices = map #fp_res_index fp_sugars; |
384 val indices = map #fp_res_index fp_sugars; |
385 val perm_indices = map #fp_res_index perm_fp_sugars; |
385 val perm_indices = map #fp_res_index perm_fp_sugars; |
386 |
386 |
387 val perm_ctrss = map (#ctrs o #ctr_sugar) perm_fp_sugars; |
387 val perm_gfpTs = map #T perm_fp_sugars; |
388 val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss; |
388 val perm_ctrXs_Tsss' = map (repair_nullary_single_ctr o #ctrXs_Tss) perm_fp_sugars; |
389 val perm_gfpTs = map (body_type o fastype_of o hd) perm_ctrss; |
|
390 |
389 |
391 val nn0 = length res_Ts; |
390 val nn0 = length res_Ts; |
392 val nn = length perm_gfpTs; |
391 val nn = length perm_gfpTs; |
393 val kks = 0 upto nn - 1; |
392 val kks = 0 upto nn - 1; |
394 val perm_ns = map length perm_ctr_Tsss; |
393 val perm_ns' = map length perm_ctrXs_Tsss'; |
395 |
394 |
396 val perm_Cs = map (fn {fp_res, fp_res_index, ...} => domain_type (body_fun_type (fastype_of |
395 val perm_Ts = map #T perm_fp_sugars; |
397 (co_rec_of (nth (#xtor_co_iterss fp_res) fp_res_index))))) perm_fp_sugars; |
396 val perm_Xs = map #X perm_fp_sugars; |
398 val (perm_p_Tss, (perm_q_Tssss, _, perm_f_Tssss, _)) = |
397 val perm_Cs = map (domain_type o body_fun_type o fastype_of o co_rec_of o #co_iters) perm_fp_sugars; |
399 mk_coiter_fun_arg_types perm_ctr_Tsss perm_Cs perm_ns (co_rec_of dtor_coiters1); |
398 val Xs_TCs = perm_Xs ~~ (perm_Ts ~~ perm_Cs); |
|
399 |
|
400 fun zip_corecT (Type (s, Us)) = [Type (s, map (mk_sumTN o zip_corecT) Us)] |
|
401 | zip_corecT U = |
|
402 (case AList.lookup (op =) Xs_TCs U of |
|
403 SOME (T, C) => [T, C] |
|
404 | NONE => [U]); |
|
405 |
|
406 val perm_p_Tss = mk_coiter_p_pred_types perm_Cs perm_ns'; |
|
407 val perm_f_Tssss = |
|
408 map2 (fn C => map (map (map (curry (op -->) C) o zip_corecT))) perm_Cs perm_ctrXs_Tsss'; |
|
409 val perm_q_Tssss = |
|
410 map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) perm_f_Tssss; |
400 |
411 |
401 val (perm_p_hss, h) = indexedd perm_p_Tss 0; |
412 val (perm_p_hss, h) = indexedd perm_p_Tss 0; |
402 val (perm_q_hssss, h') = indexedddd perm_q_Tssss h; |
413 val (perm_q_hssss, h') = indexedddd perm_q_Tssss h; |
403 val (perm_f_hssss, _) = indexedddd perm_f_Tssss h'; |
414 val (perm_f_hssss, _) = indexedddd perm_f_Tssss h'; |
404 |
415 |
934 val _ = tracing ("callssss = " ^ @{make_string} callssss); |
946 val _ = tracing ("callssss = " ^ @{make_string} callssss); |
935 *) |
947 *) |
936 |
948 |
937 val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms, |
949 val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms, |
938 strong_coinduct_thms), lthy') = |
950 strong_coinduct_thms), lthy') = |
939 corec_specs_of bs arg_Ts res_Ts (get_free_indices fixes) callssss lthy; |
951 corec_specs_of bs arg_Ts res_Ts frees callssss lthy; |
940 val corec_specs = take actual_nn corec_specs'; |
952 val corec_specs = take actual_nn corec_specs'; |
941 val ctr_specss = map #ctr_specs corec_specs; |
953 val ctr_specss = map #ctr_specs corec_specs; |
942 |
954 |
943 val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data |
955 val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data |
944 |> partition_eq (op = o pairself #fun_name) |
956 |> partition_eq (op = o pairself #fun_name) |