src/HOL/BNF/Tools/bnf_fp_def_sugar.ML
changeset 52317 7132de305921
parent 52315 fafab8eac3ee
child 52319 37a3b00759dc
equal deleted inserted replaced
52315:fafab8eac3ee 52317:7132de305921
   358     val corec_args = mk_args sssss hssss;
   358     val corec_args = mk_args sssss hssss;
   359   in
   359   in
   360     ((cs, cpss, (unfold_args, unfold_types), (corec_args, corec_types)), lthy)
   360     ((cs, cpss, (unfold_args, unfold_types), (corec_args, corec_types)), lthy)
   361   end;
   361   end;
   362 
   362 
   363 fun mk_un_fold_co_rec_prelims fp fpTs Cs ns mss [xtor_un_folds0, xtor_co_recs0] lthy =
   363 fun mk_un_fold_co_rec_prelims fp fpTs Cs ns mss xtor_co_iterss0 lthy =
   364   let
   364   let
   365     val thy = Proof_Context.theory_of lthy;
   365     val thy = Proof_Context.theory_of lthy;
   366 
   366 
   367     val (xtor_un_fold_fun_Ts, xtor_un_folds) = mk_co_iters thy fp fpTs Cs xtor_un_folds0
   367     val (xtor_co_iter_fun_Tss, xtor_co_iterss) =
   368       |> `(mk_fp_iter_fun_types o hd);
   368       map (mk_co_iters thy fp fpTs Cs #> `(mk_fp_iter_fun_types o hd)) xtor_co_iterss0
   369     val (xtor_co_rec_fun_Ts, xtor_co_recs) = mk_co_iters thy fp fpTs Cs xtor_co_recs0
   369       |> split_list;
   370       |> `(mk_fp_iter_fun_types o hd);
       
   371 
   370 
   372     val ((fold_rec_args_types, unfold_corec_args_types), lthy') =
   371     val ((fold_rec_args_types, unfold_corec_args_types), lthy') =
   373       if fp = Least_FP then
   372       if fp = Least_FP then
   374         mk_fold_rec_args_types Cs ns mss [xtor_un_fold_fun_Ts, xtor_co_rec_fun_Ts] lthy
   373         mk_fold_rec_args_types Cs ns mss xtor_co_iter_fun_Tss lthy |>> (rpair NONE o SOME)
   375         |>> (rpair NONE o SOME)
       
   376       else
   374       else
   377         mk_unfold_corec_args_types Cs ns mss [xtor_un_fold_fun_Ts, xtor_co_rec_fun_Ts] lthy
   375         mk_unfold_corec_args_types Cs ns mss xtor_co_iter_fun_Tss lthy |>> (pair NONE o SOME)
   378         |>> (pair NONE o SOME)
       
   379   in
   376   in
   380     (([xtor_un_folds, xtor_co_recs], fold_rec_args_types, unfold_corec_args_types), lthy')
   377     ((xtor_co_iterss, fold_rec_args_types, unfold_corec_args_types), lthy')
   381   end;
   378   end;
   382 
   379 
   383 fun mk_map live Ts Us t =
   380 fun mk_map live Ts Us t =
   384   let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   381   let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   385     Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   382     Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t