14 (term -> int list) -> term list list list list -> BNF_FP_Def_Sugar.fp_sugar list -> |
14 (term -> int list) -> term list list list list -> BNF_FP_Def_Sugar.fp_sugar list -> |
15 local_theory -> |
15 local_theory -> |
16 (BNF_FP_Def_Sugar.fp_sugar list |
16 (BNF_FP_Def_Sugar.fp_sugar list |
17 * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option)) |
17 * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option)) |
18 * local_theory |
18 * local_theory |
19 val pad_and_indexify_calls: BNF_FP_Def_Sugar.fp_sugar list -> int -> |
19 val indexify_callsss: BNF_FP_Def_Sugar.fp_sugar -> (term * term list list) list -> |
20 (term * term list list) list list -> term list list list list |
20 term list list list |
21 val nested_to_mutual_fps: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) -> |
21 val nested_to_mutual_fps: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) -> |
22 (term * term list list) list list -> local_theory -> |
22 (term * term list list) list list -> local_theory -> |
23 (typ list * int list * BNF_FP_Def_Sugar.fp_sugar list |
23 (typ list * int list * BNF_FP_Def_Sugar.fp_sugar list |
24 * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option)) |
24 * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option)) |
25 * local_theory |
25 * local_theory |
116 fold_rev (fn x => fn (ys, (good, bad)) => |
116 fold_rev (fn x => fn (ys, (good, bad)) => |
117 case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad))) |
117 case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad))) |
118 xs ([], ([], [])); |
118 xs ([], ([], [])); |
119 |
119 |
120 fun key_of_fp_eqs fp fpTs fp_eqs = |
120 fun key_of_fp_eqs fp fpTs fp_eqs = |
121 Type (fp_case fp "l" "g", fpTs @ maps (fn (z, T) => [TFree z, T]) fp_eqs); |
121 Type (fp_case fp "l" "g", fpTs @ maps (fn (x, T) => [TFree x, T]) fp_eqs); |
122 |
122 |
123 (* TODO: test with sort constraints on As *) |
123 (* TODO: test with sort constraints on As *) |
124 (* TODO: use right sorting order for "fp_sort" w.r.t. original BNFs (?) -- treat new variables |
124 (* TODO: use right sorting order for "fp_sort" w.r.t. original BNFs (?) -- treat new variables |
125 as deads? *) |
125 as deads? *) |
126 fun mutualize_fp_sugars has_nested fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 = |
126 fun mutualize_fp_sugars has_nested fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 = |
282 | SOME callss => map (map (Envir.beta_eta_contract o unfold_let)) callss); |
282 | SOME callss => map (map (Envir.beta_eta_contract o unfold_let)) callss); |
283 in |
283 in |
284 map do_ctr ctrs |
284 map do_ctr ctrs |
285 end; |
285 end; |
286 |
286 |
287 fun pad_and_indexify_calls fp_sugars0 = map2 indexify_callsss fp_sugars0 oo pad_list []; |
|
288 |
|
289 fun nested_to_mutual_fps fp actual_bs actual_Ts get_indices actual_callssss0 lthy = |
287 fun nested_to_mutual_fps fp actual_bs actual_Ts get_indices actual_callssss0 lthy = |
290 let |
288 let |
291 val qsoty = quote o Syntax.string_of_typ lthy; |
289 val qsoty = quote o Syntax.string_of_typ lthy; |
292 val qsotys = space_implode " or " o map qsoty; |
290 val qsotys = space_implode " or " o map qsoty; |
293 |
291 |
349 val (perm_Us, _) = fold_map generalize_type perm_Ts ([], lthy); |
347 val (perm_Us, _) = fold_map generalize_type perm_Ts ([], lthy); |
350 |
348 |
351 val nn = length Ts; |
349 val nn = length Ts; |
352 val kks = 0 upto nn - 1; |
350 val kks = 0 upto nn - 1; |
353 |
351 |
|
352 val callssss0 = pad_list [] nn actual_callssss0; |
|
353 |
354 val common_name = mk_common_name (map Binding.name_of actual_bs); |
354 val common_name = mk_common_name (map Binding.name_of actual_bs); |
355 val bs = pad_list (Binding.name common_name) nn actual_bs; |
355 val bs = pad_list (Binding.name common_name) nn actual_bs; |
356 |
356 |
357 fun permute xs = permute_like (op =) Ts perm_Ts xs; |
357 fun permute xs = permute_like (op =) Ts perm_Ts xs; |
358 fun unpermute perm_xs = permute_like (op =) perm_Ts Ts perm_xs; |
358 fun unpermute perm_xs = permute_like (op =) perm_Ts Ts perm_xs; |
359 |
359 |
360 val perm_bs = permute bs; |
360 val perm_bs = permute bs; |
361 val perm_kks = permute kks; |
361 val perm_kks = permute kks; |
|
362 val perm_callssss0 = permute callssss0; |
362 val perm_fp_sugars0 = map (the o fp_sugar_of lthy o fst o dest_Type) perm_Ts; |
363 val perm_fp_sugars0 = map (the o fp_sugar_of lthy o fst o dest_Type) perm_Ts; |
363 |
364 |
364 val has_nested = exists (fn Type (_, ty_args) => ty_args <> ty_args0) Ts; |
365 val has_nested = exists (fn Type (_, ty_args) => ty_args <> ty_args0) Ts; |
365 val perm_callssss = pad_and_indexify_calls perm_fp_sugars0 nn actual_callssss0; |
366 val perm_callssss = map2 indexify_callsss perm_fp_sugars0 perm_callssss0; |
366 |
367 |
367 val get_perm_indices = map (fn kk => find_index (curry (op =) kk) perm_kks) o get_indices; |
368 val get_perm_indices = map (fn kk => find_index (curry (op =) kk) perm_kks) o get_indices; |
368 |
369 |
369 val ((perm_fp_sugars, fp_sugar_thms), lthy) = |
370 val ((perm_fp_sugars, fp_sugar_thms), lthy) = |
370 mutualize_fp_sugars has_nested fp perm_bs perm_Us get_perm_indices perm_callssss |
371 mutualize_fp_sugars has_nested fp perm_bs perm_Us get_perm_indices perm_callssss |