src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML
changeset 55863 fa3a1ec69a1b
parent 55860 756275b550d9
child 55869 54ddb003e128
equal deleted inserted replaced
55862:b458558cbcc2 55863:fa3a1ec69a1b
   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;