src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML
changeset 54267 78e8a178b690
parent 54266 4e0738356ac9
child 54268 807532d15d16
equal deleted inserted replaced
54266:4e0738356ac9 54267:78e8a178b690
    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