src/HOL/Tools/BNF/bnf_fp_def_sugar.ML
changeset 58572 2e0cf67fa89f
parent 58571 d78b00f98de8
child 58573 04f5d23cd9e5
equal deleted inserted replaced
58571:d78b00f98de8 58572:2e0cf67fa89f
    35      common_co_inducts: thm list,
    35      common_co_inducts: thm list,
    36      co_inducts: thm list,
    36      co_inducts: thm list,
    37      co_rec_def: thm,
    37      co_rec_def: thm,
    38      co_rec_thms: thm list,
    38      co_rec_thms: thm list,
    39      co_rec_discs: thm list,
    39      co_rec_discs: thm list,
       
    40      co_rec_disc_iffs: thm list,
    40      co_rec_selss: thm list list}
    41      co_rec_selss: thm list list}
    41 
    42 
    42   type fp_sugar =
    43   type fp_sugar =
    43     {T: typ,
    44     {T: typ,
    44      BT: typ,
    45      BT: typ,
   199    common_co_inducts: thm list,
   200    common_co_inducts: thm list,
   200    co_inducts: thm list,
   201    co_inducts: thm list,
   201    co_rec_def: thm,
   202    co_rec_def: thm,
   202    co_rec_thms: thm list,
   203    co_rec_thms: thm list,
   203    co_rec_discs: thm list,
   204    co_rec_discs: thm list,
       
   205    co_rec_disc_iffs: thm list,
   204    co_rec_selss: thm list list};
   206    co_rec_selss: thm list list};
   205 
   207 
   206 type fp_sugar =
   208 type fp_sugar =
   207   {T: typ,
   209   {T: typ,
   208    BT: typ,
   210    BT: typ,
   232    set_sels = map (Morphism.thm phi) set_sels,
   234    set_sels = map (Morphism.thm phi) set_sels,
   233    set_intros = map (Morphism.thm phi) set_intros,
   235    set_intros = map (Morphism.thm phi) set_intros,
   234    set_cases = map (Morphism.thm phi) set_cases};
   236    set_cases = map (Morphism.thm phi) set_cases};
   235 
   237 
   236 fun morph_fp_co_induct_sugar phi ({co_rec, common_co_inducts, co_inducts, co_rec_def, co_rec_thms,
   238 fun morph_fp_co_induct_sugar phi ({co_rec, common_co_inducts, co_inducts, co_rec_def, co_rec_thms,
   237     co_rec_discs, co_rec_selss} : fp_co_induct_sugar) =
   239     co_rec_discs, co_rec_disc_iffs, co_rec_selss} : fp_co_induct_sugar) =
   238   {co_rec = Morphism.term phi co_rec,
   240   {co_rec = Morphism.term phi co_rec,
   239    common_co_inducts = map (Morphism.thm phi) common_co_inducts,
   241    common_co_inducts = map (Morphism.thm phi) common_co_inducts,
   240    co_inducts = map (Morphism.thm phi) co_inducts,
   242    co_inducts = map (Morphism.thm phi) co_inducts,
   241    co_rec_def = Morphism.thm phi co_rec_def,
   243    co_rec_def = Morphism.thm phi co_rec_def,
   242    co_rec_thms = map (Morphism.thm phi) co_rec_thms,
   244    co_rec_thms = map (Morphism.thm phi) co_rec_thms,
   243    co_rec_discs = map (Morphism.thm phi) co_rec_discs,
   245    co_rec_discs = map (Morphism.thm phi) co_rec_discs,
       
   246    co_rec_disc_iffs = map (Morphism.thm phi) co_rec_disc_iffs,
   244    co_rec_selss = map (map (Morphism.thm phi)) co_rec_selss};
   247    co_rec_selss = map (map (Morphism.thm phi)) co_rec_selss};
   245 
   248 
   246 fun morph_fp_ctr_sugar phi ({ctrXs_Tss, ctr_defs, ctr_sugar, ctr_transfers, case_transfers,
   249 fun morph_fp_ctr_sugar phi ({ctrXs_Tss, ctr_defs, ctr_sugar, ctr_transfers, case_transfers,
   247     disc_transfers} : fp_ctr_sugar) =
   250     disc_transfers} : fp_ctr_sugar) =
   248   {ctrXs_Tss = map (map (Morphism.typ phi)) ctrXs_Tss,
   251   {ctrXs_Tss = map (map (Morphism.typ phi)) ctrXs_Tss,
   318 
   321 
   319 fun interpret_bnfs_register_fp_sugars plugins Ts BTs Xs fp pre_bnfs absT_infos fp_nesting_bnfs
   322 fun interpret_bnfs_register_fp_sugars plugins Ts BTs Xs fp pre_bnfs absT_infos fp_nesting_bnfs
   320     live_nesting_bnfs fp_res ctrXs_Tsss ctr_defss ctr_sugars co_recs co_rec_defs map_thmss
   323     live_nesting_bnfs fp_res ctrXs_Tsss ctr_defss ctr_sugars co_recs co_rec_defs map_thmss
   321     common_co_inducts co_inductss co_rec_thmss co_rec_discss co_rec_selsss rel_injectss
   324     common_co_inducts co_inductss co_rec_thmss co_rec_discss co_rec_selsss rel_injectss
   322     rel_distinctss map_disc_iffss map_selss rel_selss rel_intross rel_casess set_thmss set_selss
   325     rel_distinctss map_disc_iffss map_selss rel_selss rel_intross rel_casess set_thmss set_selss
   323     set_intross set_casess ctr_transferss case_transferss disc_transferss noted =
   326     set_intross set_casess ctr_transferss case_transferss disc_transferss co_rec_disc_iffss noted =
   324   let
   327   let
   325     val fp_sugars =
   328     val fp_sugars =
   326       map_index (fn (kk, T) =>
   329       map_index (fn (kk, T) =>
   327         {T = T, BT = nth BTs kk, X = nth Xs kk, fp = fp, fp_res = fp_res, fp_res_index = kk,
   330         {T = T, BT = nth BTs kk, X = nth Xs kk, fp = fp, fp_res = fp_res, fp_res_index = kk,
   328          pre_bnf = nth pre_bnfs kk, absT_info = nth absT_infos kk,
   331          pre_bnf = nth pre_bnfs kk, absT_info = nth absT_infos kk,
   352             common_co_inducts = common_co_inducts,
   355             common_co_inducts = common_co_inducts,
   353             co_inducts = nth co_inductss kk,
   356             co_inducts = nth co_inductss kk,
   354             co_rec_def = nth co_rec_defs kk,
   357             co_rec_def = nth co_rec_defs kk,
   355             co_rec_thms = nth co_rec_thmss kk,
   358             co_rec_thms = nth co_rec_thmss kk,
   356             co_rec_discs = nth co_rec_discss kk,
   359             co_rec_discs = nth co_rec_discss kk,
       
   360             co_rec_disc_iffs = nth co_rec_disc_iffss kk,
   357             co_rec_selss = nth co_rec_selsss kk}}
   361             co_rec_selss = nth co_rec_selsss kk}}
   358         |> morph_fp_sugar (substitute_noted_thm noted)) Ts;
   362         |> morph_fp_sugar (substitute_noted_thm noted)) Ts;
   359   in
   363   in
   360     register_fp_sugars_raw fp_sugars
   364     register_fp_sugars_raw fp_sugars
   361     #> fold (interpret_bnf plugins) (#bnfs fp_res)
   365     #> fold (interpret_bnf plugins) (#bnfs fp_res)
  2199         |-> interpret_bnfs_register_fp_sugars plugins fpTs fpBTs Xs Least_FP pre_bnfs absT_infos
  2203         |-> interpret_bnfs_register_fp_sugars plugins fpTs fpBTs Xs Least_FP pre_bnfs absT_infos
  2200           fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctr_defss ctr_sugars recs rec_defs
  2204           fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctr_defss ctr_sugars recs rec_defs
  2201           map_thmss [induct_thm] (map single induct_thms) rec_thmss (replicate nn [])
  2205           map_thmss [induct_thm] (map single induct_thms) rec_thmss (replicate nn [])
  2202           (replicate nn []) rel_injectss rel_distinctss map_disc_iffss map_selss rel_selss
  2206           (replicate nn []) rel_injectss rel_distinctss map_disc_iffss map_selss rel_selss
  2203           rel_intross rel_casess set_thmss set_selss set_intross set_casess ctr_transferss
  2207           rel_intross rel_casess set_thmss set_selss set_intross set_casess ctr_transferss
  2204           case_transferss disc_transferss
  2208           case_transferss disc_transferss (replicate nn [])
  2205       end;
  2209       end;
  2206 
  2210 
  2207     fun derive_corec_transfer_thms lthy corecs corec_defs =
  2211     fun derive_corec_transfer_thms lthy corecs corec_defs =
  2208       let
  2212       let
  2209         val (Rs, Ss, goals, names_lthy) = mk_co_rec_transfer_goals lthy corecs;
  2213         val (Rs, Ss, goals, names_lthy) = mk_co_rec_transfer_goals lthy corecs;
  2317           fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctr_defss ctr_sugars corecs corec_defs
  2321           fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctr_defss ctr_sugars corecs corec_defs
  2318           map_thmss [coinduct_thm, coinduct_strong_thm]
  2322           map_thmss [coinduct_thm, coinduct_strong_thm]
  2319           (transpose [coinduct_thms, coinduct_strong_thms]) corec_thmss corec_disc_thmss
  2323           (transpose [coinduct_thms, coinduct_strong_thms]) corec_thmss corec_disc_thmss
  2320           corec_sel_thmsss rel_injectss rel_distinctss map_disc_iffss map_selss rel_selss
  2324           corec_sel_thmsss rel_injectss rel_distinctss map_disc_iffss map_selss rel_selss
  2321           rel_intross rel_casess set_thmss set_selss set_intross set_casess ctr_transferss
  2325           rel_intross rel_casess set_thmss set_selss set_intross set_casess ctr_transferss
  2322           case_transferss disc_transferss
  2326           case_transferss disc_transferss corec_disc_iff_thmss
  2323       end;
  2327       end;
  2324 
  2328 
  2325     val lthy'' = lthy'
  2329     val lthy'' = lthy'
  2326       |> live > 0 ? fold2 (fn Type (s, _) => fn bnf => register_bnf_raw s bnf) fpTs fp_bnfs
  2330       |> live > 0 ? fold2 (fn Type (s, _) => fn bnf => register_bnf_raw s bnf) fpTs fp_bnfs
  2327       |> fold_map define_ctrs_dtrs_for_type (fp_bnfs ~~ fp_bs ~~ fpTs ~~ ctors ~~ dtors ~~
  2331       |> fold_map define_ctrs_dtrs_for_type (fp_bnfs ~~ fp_bs ~~ fpTs ~~ ctors ~~ dtors ~~