39 fp_nesting_map_comps: thm list, |
39 fp_nesting_map_comps: thm list, |
40 ctr_specs: corec_ctr_spec list} |
40 ctr_specs: corec_ctr_spec list} |
41 |
41 |
42 val corec_specs_of: binding list -> typ list -> typ list -> term list -> |
42 val corec_specs_of: binding list -> typ list -> typ list -> term list -> |
43 (term * term list list) list list -> local_theory -> |
43 (term * term list list) list list -> local_theory -> |
44 (bool * corec_spec list * typ list * thm * thm * thm list * thm list) * local_theory |
44 corec_spec list * typ list * thm * thm * thm list * thm list * (Token.src list * Token.src list) |
|
45 * bool * local_theory |
45 val add_primcorecursive_cmd: primcorec_option list -> |
46 val add_primcorecursive_cmd: primcorec_option list -> |
46 (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list -> |
47 (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list -> |
47 Proof.context -> Proof.state |
48 Proof.context -> Proof.state |
48 val add_primcorec_cmd: primcorec_option list -> |
49 val add_primcorec_cmd: primcorec_option list -> |
49 (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list -> |
50 (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list -> |
408 |
409 |
409 val ((missing_res_Ts, perm0_kks, fp_sugars as {fp_nesting_bnfs, |
410 val ((missing_res_Ts, perm0_kks, fp_sugars as {fp_nesting_bnfs, |
410 common_co_inducts = common_coinduct_thms, ...} :: _, (_, gfp_sugar_thms)), lthy) = |
411 common_co_inducts = common_coinduct_thms, ...} :: _, (_, gfp_sugar_thms)), lthy) = |
411 nested_to_mutual_fps Greatest_FP bs res_Ts callers callssss0 lthy0; |
412 nested_to_mutual_fps Greatest_FP bs res_Ts callers callssss0 lthy0; |
412 |
413 |
|
414 val coinduct_attrs_pair = (case gfp_sugar_thms of SOME ((_, _, pair), _) => pair | NONE => []); |
|
415 |
413 val perm_fp_sugars = sort (int_ord o pairself #fp_res_index) fp_sugars; |
416 val perm_fp_sugars = sort (int_ord o pairself #fp_res_index) fp_sugars; |
414 |
417 |
415 val indices = map #fp_res_index fp_sugars; |
418 val indices = map #fp_res_index fp_sugars; |
416 val perm_indices = map #fp_res_index perm_fp_sugars; |
419 val perm_indices = map #fp_res_index perm_fp_sugars; |
417 |
420 |
500 fp_nesting_map_ident0s = map map_ident0_of_bnf fp_nesting_bnfs, |
503 fp_nesting_map_ident0s = map map_ident0_of_bnf fp_nesting_bnfs, |
501 fp_nesting_map_comps = map map_comp_of_bnf fp_nesting_bnfs, |
504 fp_nesting_map_comps = map map_comp_of_bnf fp_nesting_bnfs, |
502 ctr_specs = mk_ctr_specs ctr_sugar p_is q_isss f_isss f_Tsss corec_thms corec_discs |
505 ctr_specs = mk_ctr_specs ctr_sugar p_is q_isss f_isss f_Tsss corec_thms corec_discs |
503 corec_selss}; |
506 corec_selss}; |
504 in |
507 in |
505 ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts, |
508 (map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts, |
506 co_induct_of common_coinduct_thms, strong_co_induct_of common_coinduct_thms, |
509 co_induct_of common_coinduct_thms, strong_co_induct_of common_coinduct_thms, |
507 co_induct_of coinduct_thmss, strong_co_induct_of coinduct_thmss), lthy) |
510 co_induct_of coinduct_thmss, strong_co_induct_of coinduct_thmss, coinduct_attrs_pair, |
|
511 is_some gfp_sugar_thms, lthy) |
508 end; |
512 end; |
509 |
513 |
510 val undef_const = Const (@{const_name undefined}, dummyT); |
514 val undef_const = Const (@{const_name undefined}, dummyT); |
511 |
515 |
512 val abs_tuple_balanced = HOLogic.tupled_lambda o mk_tuple_balanced; |
516 val abs_tuple_balanced = HOLogic.tupled_lambda o mk_tuple_balanced; |
1022 |> map (flat o snd) |
1026 |> map (flat o snd) |
1023 |> map2 (fold o find_corec_calls lthy has_call) basic_ctr_specss |
1027 |> map2 (fold o find_corec_calls lthy has_call) basic_ctr_specss |
1024 |> map2 (curry (op |>)) (map (map (fn {ctr, sels, ...} => |
1028 |> map2 (curry (op |>)) (map (map (fn {ctr, sels, ...} => |
1025 (ctr, map (K []) sels))) basic_ctr_specss); |
1029 (ctr, map (K []) sels))) basic_ctr_specss); |
1026 |
1030 |
1027 val ((n2m, corec_specs', _, coinduct_thm, coinduct_strong_thm, coinduct_thms, |
1031 val (corec_specs', _, coinduct_thm, coinduct_strong_thm, coinduct_thms, coinduct_strong_thms, |
1028 coinduct_strong_thms), lthy') = |
1032 (coinduct_attrs, common_coinduct_attrs), n2m, lthy') = |
1029 corec_specs_of bs arg_Ts res_Ts frees callssss lthy; |
1033 corec_specs_of bs arg_Ts res_Ts frees callssss lthy; |
1030 val corec_specs = take actual_nn corec_specs'; |
1034 val corec_specs = take actual_nn corec_specs'; |
1031 val ctr_specss = map #ctr_specs corec_specs; |
1035 val ctr_specss = map #ctr_specs corec_specs; |
1032 |
1036 |
1033 val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data |
1037 val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data |
1404 |
1408 |
1405 val anonymous_notes = |
1409 val anonymous_notes = |
1406 [(flat disc_iff_or_disc_thmss, simp_attrs)] |
1410 [(flat disc_iff_or_disc_thmss, simp_attrs)] |
1407 |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); |
1411 |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); |
1408 |
1412 |
|
1413 val common_notes = |
|
1414 [(coinductN, if n2m then [coinduct_thm] else [], common_coinduct_attrs), |
|
1415 (coinduct_strongN, if n2m then [coinduct_strong_thm] else [], common_coindut_attrs)] |
|
1416 |> filter_out (null o #2) |
|
1417 |> map (fn (thmN, thms, attrs) => |
|
1418 ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])])); |
|
1419 |
1409 val notes = |
1420 val notes = |
1410 [(coinductN, map (if n2m then single else K []) coinduct_thms, []), |
1421 [(coinductN, map (if n2m then single else K []) coinduct_thms, coinduct_attrs), |
|
1422 (coinduct_strongN, map (if n2m then single else K []) coinduct_strong_thms, |
|
1423 coinduct_attrs), |
1411 (codeN, code_thmss, code_nitpicksimp_attrs), |
1424 (codeN, code_thmss, code_nitpicksimp_attrs), |
1412 (ctrN, ctr_thmss, []), |
1425 (ctrN, ctr_thmss, []), |
1413 (discN, disc_thmss, []), |
1426 (discN, disc_thmss, []), |
1414 (disc_iffN, disc_iff_thmss, []), |
1427 (disc_iffN, disc_iff_thmss, []), |
1415 (excludeN, exclude_thmss, []), |
1428 (excludeN, exclude_thmss, []), |
1416 (exhaustN, nontriv_exhaust_thmss, []), |
1429 (exhaustN, nontriv_exhaust_thmss, []), |
1417 (selN, sel_thmss, simp_attrs), |
1430 (selN, sel_thmss, simp_attrs), |
1418 (simpsN, simp_thmss, []), |
1431 (simpsN, simp_thmss, [])] |
1419 (coinduct_strongN, map (if n2m then single else K []) coinduct_strong_thms, [])] |
|
1420 |> maps (fn (thmN, thmss, attrs) => |
1432 |> maps (fn (thmN, thmss, attrs) => |
1421 map2 (fn fun_name => fn thms => |
1433 map2 (fn fun_name => fn thms => |
1422 ((Binding.qualify true fun_name (Binding.name thmN), attrs), [(thms, [])])) |
1434 ((Binding.qualify true fun_name (Binding.name thmN), attrs), [(thms, [])])) |
1423 fun_names (take actual_nn thmss)) |
1435 fun_names (take actual_nn thmss)) |
1424 |> filter_out (null o fst o hd o snd); |
1436 |> filter_out (null o fst o hd o snd); |
1425 |
|
1426 val common_notes = |
|
1427 [(coinductN, if n2m then [coinduct_thm] else [], []), |
|
1428 (coinduct_strongN, if n2m then [coinduct_strong_thm] else [], [])] |
|
1429 |> filter_out (null o #2) |
|
1430 |> map (fn (thmN, thms, attrs) => |
|
1431 ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])])); |
|
1432 in |
1437 in |
1433 lthy |
1438 lthy |
1434 |> Spec_Rules.add Spec_Rules.Equational (map fst def_infos, flat sel_thmss) |
1439 |> Spec_Rules.add Spec_Rules.Equational (map fst def_infos, flat sel_thmss) |
1435 |> Spec_Rules.add Spec_Rules.Equational (map fst def_infos, flat ctr_thmss) |
1440 |> Spec_Rules.add Spec_Rules.Equational (map fst def_infos, flat ctr_thmss) |
1436 |> Spec_Rules.add Spec_Rules.Equational (map fst def_infos, flat code_thmss) |
1441 |> Spec_Rules.add Spec_Rules.Equational (map fst def_infos, flat code_thmss) |
1437 |> Local_Theory.notes (anonymous_notes @ notes @ common_notes) |
1442 |> Local_Theory.notes (anonymous_notes @ common_notes @ notes) |
1438 |> snd |
1443 |> snd |
1439 end; |
1444 end; |
1440 |
1445 |
1441 fun after_qed thmss' = fold_map Local_Theory.define defs #-> prove thmss'; |
1446 fun after_qed thmss' = fold_map Local_Theory.define defs #-> prove thmss'; |
1442 in |
1447 in |