src/HOL/Tools/BNF/bnf_def.ML
author traytel
Sun Dec 17 08:42:59 2017 +0100 (18 months ago)
changeset 67222 19809bc9d7ff
parent 66272 c6714a9562ae
child 69593 3dda49e08b9d
permissions -rw-r--r--
made tactics more robust
     1 (*  Title:      HOL/Tools/BNF/bnf_def.ML
     2     Author:     Dmitriy Traytel, TU Muenchen
     3     Author:     Jasmin Blanchette, TU Muenchen
     4     Author:     Martin Desharnais, TU Muenchen
     5     Copyright   2012, 2013, 2014
     6 
     7 Definition of bounded natural functors.
     8 *)
     9 
    10 signature BNF_DEF =
    11 sig
    12   type bnf
    13   type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
    14 
    15   val morph_bnf: morphism -> bnf -> bnf
    16   val morph_bnf_defs: morphism -> bnf -> bnf
    17   val permute_deads: (typ list -> typ list) -> bnf -> bnf
    18   val transfer_bnf: theory -> bnf -> bnf
    19   val bnf_of: Proof.context -> string -> bnf option
    20   val bnf_of_global: theory -> string -> bnf option
    21   val bnf_interpretation: string -> (bnf -> local_theory -> local_theory) -> theory -> theory
    22   val interpret_bnf: (string -> bool) -> bnf -> local_theory -> local_theory
    23   val register_bnf_raw: string -> bnf -> local_theory -> local_theory
    24   val register_bnf: (string -> bool) -> string -> bnf -> local_theory -> local_theory
    25 
    26   val name_of_bnf: bnf -> binding
    27   val T_of_bnf: bnf -> typ
    28   val live_of_bnf: bnf -> int
    29   val lives_of_bnf: bnf -> typ list
    30   val dead_of_bnf: bnf -> int
    31   val deads_of_bnf: bnf -> typ list
    32   val bd_of_bnf: bnf -> term
    33   val nwits_of_bnf: bnf -> int
    34 
    35   val mapN: string
    36   val predN: string
    37   val relN: string
    38   val setN: string
    39   val mk_setN: int -> string
    40   val mk_witN: int -> string
    41 
    42   val map_of_bnf: bnf -> term
    43   val pred_of_bnf: bnf -> term
    44   val rel_of_bnf: bnf -> term
    45   val sets_of_bnf: bnf -> term list
    46 
    47   val mk_T_of_bnf: typ list -> typ list -> bnf -> typ
    48   val mk_bd_of_bnf: typ list -> typ list -> bnf -> term
    49   val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    50   val mk_pred_of_bnf: typ list -> typ list -> bnf -> term
    51   val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    52   val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list
    53   val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list
    54 
    55   val bd_Card_order_of_bnf: bnf -> thm
    56   val bd_Cinfinite_of_bnf: bnf -> thm
    57   val bd_Cnotzero_of_bnf: bnf -> thm
    58   val bd_card_order_of_bnf: bnf -> thm
    59   val bd_cinfinite_of_bnf: bnf -> thm
    60   val collect_set_map_of_bnf: bnf -> thm
    61   val in_bd_of_bnf: bnf -> thm
    62   val in_cong_of_bnf: bnf -> thm
    63   val in_mono_of_bnf: bnf -> thm
    64   val in_rel_of_bnf: bnf -> thm
    65   val inj_map_of_bnf: bnf -> thm
    66   val inj_map_strong_of_bnf: bnf -> thm
    67   val le_rel_OO_of_bnf: bnf -> thm
    68   val map_comp0_of_bnf: bnf -> thm
    69   val map_comp_of_bnf: bnf -> thm
    70   val map_cong0_of_bnf: bnf -> thm
    71   val map_cong_of_bnf: bnf -> thm
    72   val map_cong_pred_of_bnf: bnf -> thm
    73   val map_cong_simp_of_bnf: bnf -> thm
    74   val map_def_of_bnf: bnf -> thm
    75   val map_id0_of_bnf: bnf -> thm
    76   val map_id_of_bnf: bnf -> thm
    77   val map_ident0_of_bnf: bnf -> thm
    78   val map_ident_of_bnf: bnf -> thm
    79   val map_transfer_of_bnf: bnf -> thm
    80   val pred_cong0_of_bnf: bnf -> thm
    81   val pred_cong_of_bnf: bnf -> thm
    82   val pred_cong_simp_of_bnf: bnf -> thm
    83   val pred_def_of_bnf: bnf -> thm
    84   val pred_map_of_bnf: bnf -> thm
    85   val pred_mono_strong0_of_bnf: bnf -> thm
    86   val pred_mono_strong_of_bnf: bnf -> thm
    87   val pred_mono_of_bnf: bnf -> thm
    88   val pred_set_of_bnf: bnf -> thm
    89   val pred_rel_of_bnf: bnf -> thm
    90   val pred_transfer_of_bnf: bnf -> thm
    91   val pred_True_of_bnf: bnf -> thm
    92   val rel_Grp_of_bnf: bnf -> thm
    93   val rel_OO_Grp_of_bnf: bnf -> thm
    94   val rel_OO_of_bnf: bnf -> thm
    95   val rel_cong0_of_bnf: bnf -> thm
    96   val rel_cong_of_bnf: bnf -> thm
    97   val rel_cong_simp_of_bnf: bnf -> thm
    98   val rel_conversep_of_bnf: bnf -> thm
    99   val rel_def_of_bnf: bnf -> thm
   100   val rel_eq_of_bnf: bnf -> thm
   101   val rel_flip_of_bnf: bnf -> thm
   102   val rel_map_of_bnf: bnf -> thm list
   103   val rel_mono_of_bnf: bnf -> thm
   104   val rel_mono_strong0_of_bnf: bnf -> thm
   105   val rel_mono_strong_of_bnf: bnf -> thm
   106   val rel_eq_onp_of_bnf: bnf -> thm
   107   val rel_refl_of_bnf: bnf -> thm
   108   val rel_refl_strong_of_bnf: bnf -> thm
   109   val rel_reflp_of_bnf: bnf -> thm
   110   val rel_symp_of_bnf: bnf -> thm
   111   val rel_transfer_of_bnf: bnf -> thm
   112   val rel_transp_of_bnf: bnf -> thm
   113   val set_bd_of_bnf: bnf -> thm list
   114   val set_defs_of_bnf: bnf -> thm list
   115   val set_map0_of_bnf: bnf -> thm list
   116   val set_map_of_bnf: bnf -> thm list
   117   val set_transfer_of_bnf: bnf -> thm list
   118   val wit_thms_of_bnf: bnf -> thm list
   119   val wit_thmss_of_bnf: bnf -> thm list list
   120 
   121   val mk_map: int -> typ list -> typ list -> term -> term
   122   val mk_pred: typ list -> term -> term
   123   val mk_rel: int -> typ list -> typ list -> term -> term
   124   val mk_set: typ list -> term -> term
   125   val build_map: Proof.context -> typ list -> typ list -> (typ * typ -> term) -> typ * typ -> term
   126   val build_rel: (string * (int * term)) list -> Proof.context -> typ list -> typ list ->
   127     (typ * typ -> term) -> typ * typ -> term
   128   val build_set: Proof.context -> typ -> typ -> term
   129   val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
   130   val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
   131     'a list
   132 
   133   val mk_witness: int list * term -> thm list -> nonemptiness_witness
   134   val mk_wit_goals: term list -> term list -> term list -> int list * term -> term list
   135   val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
   136   val wits_of_bnf: bnf -> nonemptiness_witness list
   137 
   138   val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a -> 'a list
   139 
   140   datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
   141   datatype fact_policy = Dont_Note | Note_Some | Note_All
   142 
   143   val bnf_internals: bool Config.T
   144   val bnf_timing: bool Config.T
   145   val user_policy: fact_policy -> Proof.context -> fact_policy
   146   val note_bnf_thms: fact_policy -> (binding -> binding) -> binding -> bnf -> local_theory ->
   147     bnf * local_theory
   148   val note_bnf_defs: bnf -> local_theory -> bnf * local_theory
   149 
   150   val print_bnfs: Proof.context -> unit
   151   val prepare_def: inline_policy -> (Proof.context -> fact_policy) -> bool ->
   152     (binding -> binding) -> (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) ->
   153     typ list option -> binding -> binding -> binding -> binding list ->
   154     ((((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option) * 'b option ->
   155     Proof.context ->
   156     string * term list * ((Proof.context -> thm list -> tactic) option * term list list) *
   157     ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
   158     local_theory * thm list
   159   val define_bnf_consts: inline_policy -> fact_policy -> bool -> typ list option ->
   160     binding -> binding -> binding -> binding list ->
   161     ((((((binding * typ) * term) * term list) * term) * term list) * term option) * term option ->
   162     local_theory ->
   163       ((typ list * typ list * typ list * typ) *
   164        (term * term list * term * (int list * term) list * term * term) *
   165        (thm * thm list * thm * thm list * thm * thm) *
   166        ((typ list -> typ list -> typ list -> term) *
   167         (typ list -> typ list -> term -> term) *
   168         (typ list -> typ list -> typ -> typ) *
   169         (typ list -> typ list -> typ list -> term) *
   170         (typ list -> typ list -> term) *
   171         (typ list -> typ list -> typ list -> term) *
   172         (typ list -> typ list -> term))) * local_theory
   173 
   174   val bnf_def: inline_policy -> (Proof.context -> fact_policy) -> bool -> (binding -> binding) ->
   175     (Proof.context -> tactic) list -> (Proof.context -> tactic) -> typ list option -> binding ->
   176     binding -> binding -> binding list ->
   177     ((((((binding * typ) * term) * term list) * term) * term list) * term option) * term option ->
   178     local_theory -> bnf * local_theory
   179   val bnf_cmd: (((((((binding * string) * string) * string list) * string) * string list)
   180       * string option) * string option) * (Proof.context -> Plugin_Name.filter) ->
   181     Proof.context -> Proof.state
   182 end;
   183 
   184 structure BNF_Def : BNF_DEF =
   185 struct
   186 
   187 open BNF_Util
   188 open BNF_Tactics
   189 open BNF_Def_Tactics
   190 
   191 val fundefcong_attrs = @{attributes [fundef_cong]};
   192 val mono_attrs = @{attributes [mono]};
   193 
   194 type axioms = {
   195   map_id0: thm,
   196   map_comp0: thm,
   197   map_cong0: thm,
   198   set_map0: thm list,
   199   bd_card_order: thm,
   200   bd_cinfinite: thm,
   201   set_bd: thm list,
   202   le_rel_OO: thm,
   203   rel_OO_Grp: thm,
   204   pred_set: thm
   205 };
   206 
   207 fun mk_axioms' (((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel), pred) =
   208   {map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o,
   209    bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel, pred_set = pred};
   210 
   211 fun dest_cons [] = raise List.Empty
   212   | dest_cons (x :: xs) = (x, xs);
   213 
   214 fun mk_axioms n thms = thms
   215   |> map the_single
   216   |> dest_cons
   217   ||>> dest_cons
   218   ||>> dest_cons
   219   ||>> chop n
   220   ||>> dest_cons
   221   ||>> dest_cons
   222   ||>> chop n
   223   ||>> dest_cons
   224   ||>> dest_cons
   225   ||> the_single
   226   |> mk_axioms';
   227 
   228 fun zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel pred =
   229   [mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel, pred];
   230 
   231 fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
   232   le_rel_OO, rel_OO_Grp, pred_set} =
   233   {map_id0 = f map_id0,
   234     map_comp0 = f map_comp0,
   235     map_cong0 = f map_cong0,
   236     set_map0 = map f set_map0,
   237     bd_card_order = f bd_card_order,
   238     bd_cinfinite = f bd_cinfinite,
   239     set_bd = map f set_bd,
   240     le_rel_OO = f le_rel_OO,
   241     rel_OO_Grp = f rel_OO_Grp,
   242     pred_set = f pred_set};
   243 
   244 val morph_axioms = map_axioms o Morphism.thm;
   245 
   246 type defs = {
   247   map_def: thm,
   248   set_defs: thm list,
   249   rel_def: thm,
   250   pred_def: thm
   251 }
   252 
   253 fun mk_defs map sets rel pred = {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred};
   254 
   255 fun map_defs f {map_def, set_defs, rel_def, pred_def} =
   256   {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def, pred_def = f pred_def};
   257 
   258 val morph_defs = map_defs o Morphism.thm;
   259 
   260 type facts = {
   261   bd_Card_order: thm,
   262   bd_Cinfinite: thm,
   263   bd_Cnotzero: thm,
   264   collect_set_map: thm lazy,
   265   in_bd: thm lazy,
   266   in_cong: thm lazy,
   267   in_mono: thm lazy,
   268   in_rel: thm lazy,
   269   inj_map: thm lazy,
   270   inj_map_strong: thm lazy,
   271   map_comp: thm lazy,
   272   map_cong: thm lazy,
   273   map_cong_simp: thm lazy,
   274   map_cong_pred: thm lazy,
   275   map_id: thm lazy,
   276   map_ident0: thm lazy,
   277   map_ident: thm lazy,
   278   map_transfer: thm lazy,
   279   rel_eq: thm lazy,
   280   rel_flip: thm lazy,
   281   set_map: thm lazy list,
   282   rel_cong0: thm lazy,
   283   rel_cong: thm lazy,
   284   rel_cong_simp: thm lazy,
   285   rel_map: thm list lazy,
   286   rel_mono: thm lazy,
   287   rel_mono_strong0: thm lazy,
   288   rel_mono_strong: thm lazy,
   289   set_transfer: thm list lazy,
   290   rel_Grp: thm lazy,
   291   rel_conversep: thm lazy,
   292   rel_OO: thm lazy,
   293   rel_refl: thm lazy,
   294   rel_refl_strong: thm lazy,
   295   rel_reflp: thm lazy,
   296   rel_symp: thm lazy,
   297   rel_transp: thm lazy,
   298   rel_transfer: thm lazy,
   299   rel_eq_onp: thm lazy,
   300   pred_transfer: thm lazy,
   301   pred_True: thm lazy,
   302   pred_map: thm lazy,
   303   pred_rel: thm lazy,
   304   pred_mono_strong0: thm lazy,
   305   pred_mono_strong: thm lazy,
   306   pred_mono: thm lazy,
   307   pred_cong0: thm lazy,
   308   pred_cong: thm lazy,
   309   pred_cong_simp: thm lazy
   310 };
   311 
   312 fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel
   313     inj_map inj_map_strong map_comp map_cong map_cong_simp map_cong_pred map_id map_ident0 map_ident
   314     map_transfer rel_eq rel_flip set_map rel_cong0 rel_cong rel_cong_simp rel_map rel_mono
   315     rel_mono_strong0 rel_mono_strong set_transfer rel_Grp rel_conversep rel_OO rel_refl
   316     rel_refl_strong rel_reflp rel_symp rel_transp rel_transfer rel_eq_onp pred_transfer pred_True
   317     pred_map pred_rel pred_mono_strong0 pred_mono_strong pred_mono pred_cong0 pred_cong
   318     pred_cong_simp = {
   319   bd_Card_order = bd_Card_order,
   320   bd_Cinfinite = bd_Cinfinite,
   321   bd_Cnotzero = bd_Cnotzero,
   322   collect_set_map = collect_set_map,
   323   in_bd = in_bd,
   324   in_cong = in_cong,
   325   in_mono = in_mono,
   326   in_rel = in_rel,
   327   inj_map = inj_map,
   328   inj_map_strong = inj_map_strong,
   329   map_comp = map_comp,
   330   map_cong = map_cong,
   331   map_cong_simp = map_cong_simp,
   332   map_cong_pred = map_cong_pred,
   333   map_id = map_id,
   334   map_ident0 = map_ident0,
   335   map_ident = map_ident,
   336   map_transfer = map_transfer,
   337   rel_eq = rel_eq,
   338   rel_flip = rel_flip,
   339   set_map = set_map,
   340   rel_cong0 = rel_cong0,
   341   rel_cong = rel_cong,
   342   rel_cong_simp = rel_cong_simp,
   343   rel_map = rel_map,
   344   rel_mono = rel_mono,
   345   rel_mono_strong0 = rel_mono_strong0,
   346   rel_mono_strong = rel_mono_strong,
   347   rel_transfer = rel_transfer,
   348   rel_Grp = rel_Grp,
   349   rel_conversep = rel_conversep,
   350   rel_OO = rel_OO,
   351   rel_refl = rel_refl,
   352   rel_refl_strong = rel_refl_strong,
   353   rel_reflp = rel_reflp,
   354   rel_symp = rel_symp,
   355   rel_transp = rel_transp,
   356   set_transfer = set_transfer,
   357   rel_eq_onp = rel_eq_onp,
   358   pred_transfer = pred_transfer,
   359   pred_True = pred_True,
   360   pred_map = pred_map,
   361   pred_rel = pred_rel,
   362   pred_mono_strong0 = pred_mono_strong0,
   363   pred_mono_strong = pred_mono_strong,
   364   pred_mono = pred_mono,
   365   pred_cong0 = pred_cong0,
   366   pred_cong = pred_cong,
   367   pred_cong_simp = pred_cong_simp};
   368 
   369 fun map_facts f {
   370   bd_Card_order,
   371   bd_Cinfinite,
   372   bd_Cnotzero,
   373   collect_set_map,
   374   in_bd,
   375   in_cong,
   376   in_mono,
   377   in_rel,
   378   inj_map,
   379   inj_map_strong,
   380   map_comp,
   381   map_cong,
   382   map_cong_simp,
   383   map_cong_pred,
   384   map_id,
   385   map_ident0,
   386   map_ident,
   387   map_transfer,
   388   rel_eq,
   389   rel_flip,
   390   set_map,
   391   rel_cong0,
   392   rel_cong,
   393   rel_cong_simp,
   394   rel_map,
   395   rel_mono,
   396   rel_mono_strong0,
   397   rel_mono_strong,
   398   rel_transfer,
   399   rel_Grp,
   400   rel_conversep,
   401   rel_OO,
   402   rel_refl,
   403   rel_refl_strong,
   404   rel_reflp,
   405   rel_symp,
   406   rel_transp,
   407   set_transfer,
   408   rel_eq_onp,
   409   pred_transfer,
   410   pred_True,
   411   pred_map,
   412   pred_rel,
   413   pred_mono_strong0,
   414   pred_mono_strong,
   415   pred_mono,
   416   pred_cong0,
   417   pred_cong,
   418   pred_cong_simp} =
   419   {bd_Card_order = f bd_Card_order,
   420     bd_Cinfinite = f bd_Cinfinite,
   421     bd_Cnotzero = f bd_Cnotzero,
   422     collect_set_map = Lazy.map f collect_set_map,
   423     in_bd = Lazy.map f in_bd,
   424     in_cong = Lazy.map f in_cong,
   425     in_mono = Lazy.map f in_mono,
   426     in_rel = Lazy.map f in_rel,
   427     inj_map = Lazy.map f inj_map,
   428     inj_map_strong = Lazy.map f inj_map_strong,
   429     map_comp = Lazy.map f map_comp,
   430     map_cong = Lazy.map f map_cong,
   431     map_cong_simp = Lazy.map f map_cong_simp,
   432     map_cong_pred = Lazy.map f map_cong_pred,
   433     map_id = Lazy.map f map_id,
   434     map_ident0 = Lazy.map f map_ident0,
   435     map_ident = Lazy.map f map_ident,
   436     map_transfer = Lazy.map f map_transfer,
   437     rel_eq = Lazy.map f rel_eq,
   438     rel_flip = Lazy.map f rel_flip,
   439     set_map = map (Lazy.map f) set_map,
   440     rel_cong0 = Lazy.map f rel_cong0,
   441     rel_cong = Lazy.map f rel_cong,
   442     rel_cong_simp = Lazy.map f rel_cong_simp,
   443     rel_map = Lazy.map (map f) rel_map,
   444     rel_mono = Lazy.map f rel_mono,
   445     rel_mono_strong0 = Lazy.map f rel_mono_strong0,
   446     rel_mono_strong = Lazy.map f rel_mono_strong,
   447     rel_transfer = Lazy.map f rel_transfer,
   448     rel_Grp = Lazy.map f rel_Grp,
   449     rel_conversep = Lazy.map f rel_conversep,
   450     rel_OO = Lazy.map f rel_OO,
   451     rel_refl = Lazy.map f rel_refl,
   452     rel_refl_strong = Lazy.map f rel_refl_strong,
   453     rel_reflp = Lazy.map f rel_reflp,
   454     rel_symp = Lazy.map f rel_symp,
   455     rel_transp = Lazy.map f rel_transp,
   456     set_transfer = Lazy.map (map f) set_transfer,
   457     rel_eq_onp = Lazy.map f rel_eq_onp,
   458     pred_transfer = Lazy.map f pred_transfer,
   459     pred_True = Lazy.map f pred_True,
   460     pred_map = Lazy.map f pred_map,
   461     pred_rel = Lazy.map f pred_rel,
   462     pred_mono_strong0 = Lazy.map f pred_mono_strong0,
   463     pred_mono_strong = Lazy.map f pred_mono_strong,
   464     pred_mono = Lazy.map f pred_mono,
   465     pred_cong0 = Lazy.map f pred_cong0,
   466     pred_cong = Lazy.map f pred_cong,
   467     pred_cong_simp = Lazy.map f pred_cong_simp};
   468 
   469 val morph_facts = map_facts o Morphism.thm;
   470 
   471 type nonemptiness_witness = {
   472   I: int list,
   473   wit: term,
   474   prop: thm list
   475 };
   476 
   477 fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
   478 fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
   479 fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
   480 
   481 datatype bnf = BNF of {
   482   name: binding,
   483   T: typ,
   484   live: int,
   485   lives: typ list, (*source type variables of map*)
   486   lives': typ list, (*target type variables of map*)
   487   dead: int,
   488   deads: typ list,
   489   map: term,
   490   sets: term list,
   491   bd: term,
   492   axioms: axioms,
   493   defs: defs,
   494   facts: facts,
   495   nwits: int,
   496   wits: nonemptiness_witness list,
   497   rel: term,
   498   pred: term
   499 };
   500 
   501 (* getters *)
   502 
   503 fun rep_bnf (BNF bnf) = bnf;
   504 val name_of_bnf = #name o rep_bnf;
   505 val T_of_bnf = #T o rep_bnf;
   506 fun mk_T_of_bnf Ds Ts bnf =
   507   let val bnf_rep = rep_bnf bnf
   508   in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
   509 val live_of_bnf = #live o rep_bnf;
   510 val lives_of_bnf = #lives o rep_bnf;
   511 val dead_of_bnf = #dead o rep_bnf;
   512 val deads_of_bnf = #deads o rep_bnf;
   513 val axioms_of_bnf = #axioms o rep_bnf;
   514 val facts_of_bnf = #facts o rep_bnf;
   515 val nwits_of_bnf = #nwits o rep_bnf;
   516 val wits_of_bnf = #wits o rep_bnf;
   517 
   518 fun flatten_type_args_of_bnf bnf dead_x xs =
   519   let
   520     val Type (_, Ts) = T_of_bnf bnf;
   521     val lives = lives_of_bnf bnf;
   522     val deads = deads_of_bnf bnf;
   523   in
   524     permute_like_unique (op =) (deads @ lives) Ts (replicate (length deads) dead_x @ xs)
   525   end;
   526 
   527 (*terms*)
   528 val map_of_bnf = #map o rep_bnf;
   529 val sets_of_bnf = #sets o rep_bnf;
   530 fun mk_map_of_bnf Ds Ts Us bnf =
   531   let val bnf_rep = rep_bnf bnf;
   532   in
   533     Term.subst_atomic_types
   534       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
   535   end;
   536 fun mk_sets_of_bnf Dss Tss bnf =
   537   let val bnf_rep = rep_bnf bnf;
   538   in
   539     map2 (fn (Ds, Ts) => Term.subst_atomic_types
   540       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
   541   end;
   542 val bd_of_bnf = #bd o rep_bnf;
   543 fun mk_bd_of_bnf Ds Ts bnf =
   544   let val bnf_rep = rep_bnf bnf;
   545   in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
   546 fun mk_wits_of_bnf Dss Tss bnf =
   547   let
   548     val bnf_rep = rep_bnf bnf;
   549     val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
   550   in
   551     map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
   552       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
   553   end;
   554 val rel_of_bnf = #rel o rep_bnf;
   555 fun mk_rel_of_bnf Ds Ts Us bnf =
   556   let val bnf_rep = rep_bnf bnf;
   557   in
   558     Term.subst_atomic_types
   559       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
   560   end;
   561 val pred_of_bnf = #pred o rep_bnf;
   562 fun mk_pred_of_bnf Ds Ts bnf =
   563   let val bnf_rep = rep_bnf bnf;
   564   in
   565     Term.subst_atomic_types
   566       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#pred bnf_rep)
   567   end;
   568 
   569 (*thms*)
   570 val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
   571 val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
   572 val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
   573 val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
   574 val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
   575 val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf;
   576 val in_bd_of_bnf = Lazy.force o #in_bd o #facts o rep_bnf;
   577 val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
   578 val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
   579 val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
   580 val inj_map_of_bnf = Lazy.force o #inj_map o #facts o rep_bnf;
   581 val inj_map_strong_of_bnf = Lazy.force o #inj_map_strong o #facts o rep_bnf;
   582 val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf;
   583 val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf;
   584 val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf;
   585 val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
   586 val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
   587 val map_cong_pred_of_bnf = Lazy.force o #map_cong_pred o #facts o rep_bnf;
   588 val map_cong_simp_of_bnf = Lazy.force o #map_cong_simp o #facts o rep_bnf;
   589 val map_def_of_bnf = #map_def o #defs o rep_bnf;
   590 val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf;
   591 val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf;
   592 val map_ident0_of_bnf = Lazy.force o #map_ident0 o #facts o rep_bnf;
   593 val map_ident_of_bnf = Lazy.force o #map_ident o #facts o rep_bnf;
   594 val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf;
   595 val rel_eq_onp_of_bnf = Lazy.force o #rel_eq_onp o #facts o rep_bnf;
   596 val pred_def_of_bnf = #pred_def o #defs o rep_bnf;
   597 val pred_map_of_bnf = Lazy.force o #pred_map o #facts o rep_bnf;
   598 val pred_mono_strong0_of_bnf = Lazy.force o #pred_mono_strong0 o #facts o rep_bnf;
   599 val pred_mono_strong_of_bnf = Lazy.force o #pred_mono_strong o #facts o rep_bnf;
   600 val pred_mono_of_bnf = Lazy.force o #pred_mono o #facts o rep_bnf;
   601 val pred_cong0_of_bnf = Lazy.force o #pred_cong0 o #facts o rep_bnf;
   602 val pred_cong_of_bnf = Lazy.force o #pred_cong o #facts o rep_bnf;
   603 val pred_cong_simp_of_bnf = Lazy.force o #pred_cong_simp o #facts o rep_bnf;
   604 val pred_rel_of_bnf = Lazy.force o #pred_rel o #facts o rep_bnf;
   605 val pred_set_of_bnf = #pred_set o #axioms o rep_bnf;
   606 val pred_transfer_of_bnf = Lazy.force o #pred_transfer o #facts o rep_bnf;
   607 val pred_True_of_bnf = Lazy.force o #pred_True o #facts o rep_bnf;
   608 val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf;
   609 val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf;
   610 val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf;
   611 val rel_cong0_of_bnf = Lazy.force o #rel_cong0 o #facts o rep_bnf;
   612 val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
   613 val rel_cong_simp_of_bnf = Lazy.force o #rel_cong_simp o #facts o rep_bnf;
   614 val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf;
   615 val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
   616 val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf;
   617 val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf;
   618 val rel_map_of_bnf = Lazy.force o #rel_map o #facts o rep_bnf;
   619 val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
   620 val rel_mono_strong0_of_bnf = Lazy.force o #rel_mono_strong0 o #facts o rep_bnf;
   621 val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf;
   622 val rel_refl_of_bnf = Lazy.force o #rel_refl o #facts o rep_bnf;
   623 val rel_refl_strong_of_bnf = Lazy.force o #rel_refl_strong o #facts o rep_bnf;
   624 val rel_reflp_of_bnf = Lazy.force o #rel_reflp o #facts o rep_bnf;
   625 val rel_symp_of_bnf = Lazy.force o #rel_symp o #facts o rep_bnf;
   626 val rel_transfer_of_bnf = Lazy.force o #rel_transfer o #facts o rep_bnf;
   627 val rel_transp_of_bnf = Lazy.force o #rel_transp o #facts o rep_bnf;
   628 val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
   629 val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
   630 val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf;
   631 val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf;
   632 val set_transfer_of_bnf = Lazy.force o #set_transfer o #facts o rep_bnf;
   633 val wit_thms_of_bnf = maps #prop o wits_of_bnf;
   634 val wit_thmss_of_bnf = map #prop o wits_of_bnf;
   635 
   636 fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel pred =
   637   BNF {name = name, T = T,
   638        live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
   639        map = map, sets = sets, bd = bd,
   640        axioms = axioms, defs = defs, facts = facts,
   641        nwits = length wits, wits = wits, rel = rel, pred = pred};
   642 
   643 fun map_bnf f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17
   644   (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
   645   dead = dead, deads = deads, map = map, sets = sets, bd = bd,
   646   axioms = axioms, defs = defs, facts = facts,
   647   nwits = nwits, wits = wits, rel = rel, pred = pred}) =
   648   BNF {name = f1 name, T = f2 T,
   649        live = f3 live, lives = f4 lives, lives' = f5 lives', dead = f6 dead, deads = f7 deads,
   650        map = f8 map, sets = f9 sets, bd = f10 bd,
   651        axioms = f11 axioms, defs = f12 defs, facts = f13 facts,
   652        nwits = f14 nwits, wits = f15 wits, rel = f16 rel, pred = f17 pred};
   653 
   654 fun morph_bnf phi =
   655   let
   656     val Tphi = Morphism.typ phi;
   657     val tphi = Morphism.term phi;
   658   in
   659     map_bnf (Morphism.binding phi) Tphi I (map Tphi) (map Tphi) I (map Tphi) tphi (map tphi) tphi
   660       (morph_axioms phi) (morph_defs phi) (morph_facts phi) I (map (morph_witness phi)) tphi tphi
   661   end;
   662 
   663 fun morph_bnf_defs phi = map_bnf I I I I I I I I I I I (morph_defs phi) I I I I I;
   664 
   665 fun permute_deads perm = map_bnf I I I I I I perm I I I I I I I I I I;
   666 
   667 val transfer_bnf = morph_bnf o Morphism.transfer_morphism;
   668 
   669 structure Data = Generic_Data
   670 (
   671   type T = bnf Symtab.table;
   672   val empty = Symtab.empty;
   673   val extend = I;
   674   fun merge data : T = Symtab.merge (K true) data;
   675 );
   676 
   677 fun bnf_of_generic context =
   678   Option.map (transfer_bnf (Context.theory_of context)) o Symtab.lookup (Data.get context);
   679 
   680 val bnf_of = bnf_of_generic o Context.Proof;
   681 val bnf_of_global = bnf_of_generic o Context.Theory;
   682 
   683 
   684 (* Utilities *)
   685 
   686 fun normalize_set insts instA set =
   687   let
   688     val (T, T') = dest_funT (fastype_of set);
   689     val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
   690     val params = Term.add_tvar_namesT T [];
   691   in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
   692 
   693 fun normalize_rel ctxt instTs instA instB rel =
   694   let
   695     val thy = Proof_Context.theory_of ctxt;
   696     val tyenv =
   697       Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB))
   698         Vartab.empty;
   699   in Envir.subst_term (tyenv, Vartab.empty) rel end
   700   handle Type.TYPE_MATCH => error "Bad relator";
   701 
   702 fun normalize_pred ctxt instTs instA pred =
   703   let
   704     val thy = Proof_Context.theory_of ctxt;
   705     val tyenv =
   706       Sign.typ_match thy (fastype_of pred, Library.foldr (op -->) (instTs, mk_pred1T instA))
   707         Vartab.empty;
   708   in Envir.subst_term (tyenv, Vartab.empty) pred end
   709   handle Type.TYPE_MATCH => error "Bad predicator";
   710 
   711 fun normalize_wit insts CA As wit =
   712   let
   713     fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
   714         if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
   715       | strip_param x = x;
   716     val (Ts, T) = strip_param ([], fastype_of wit);
   717     val subst = Term.add_tvar_namesT T [] ~~ insts;
   718     fun find y = find_index (fn x => x = y) As;
   719   in
   720     (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
   721   end;
   722 
   723 fun minimize_wits wits =
   724  let
   725    fun minimize done [] = done
   726      | minimize done ((I, wit) :: todo) =
   727        if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
   728        then minimize done todo
   729        else minimize ((I, wit) :: done) todo;
   730  in minimize [] wits end;
   731 
   732 fun mk_map live Ts Us t =
   733   let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   734     Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   735   end;
   736 
   737 fun mk_pred Ts t =
   738   let val Type (_, Ts0) = domain_type (body_fun_type (fastype_of t)) in
   739     Term.subst_atomic_types (Ts0 ~~ Ts) t
   740   end;
   741 val mk_set = mk_pred;
   742 
   743 fun mk_rel live Ts Us t =
   744   let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
   745     Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   746   end;
   747 
   748 fun build_map_or_rel mk const of_bnf dest pre_cst_table ctxt simple_Ts simple_Us build_simple =
   749   let
   750     fun build (TU as (T, U)) =
   751       if exists (curry (op =) T) simple_Ts orelse exists (curry (op =) U) simple_Us then
   752         build_simple TU
   753       else if T = U andalso not (exists_subtype_in simple_Ts T) andalso
   754           not (exists_subtype_in simple_Us U) then
   755         const T
   756       else
   757         (case TU of
   758           (Type (s, Ts), Type (s', Us)) =>
   759           if s = s' then
   760             let
   761               fun recurse (live, cst0) =
   762                 let
   763                   val cst = mk live Ts Us cst0;
   764                   val TUs' = map dest (fst (strip_typeN live (fastype_of cst)));
   765                 in Term.list_comb (cst, map build TUs') end;
   766             in
   767               (case AList.lookup (op =) pre_cst_table s of
   768                 NONE =>
   769                 (case bnf_of ctxt s of
   770                   SOME bnf => recurse (live_of_bnf bnf, of_bnf bnf)
   771                 | NONE => build_simple TU)
   772               | SOME entry => recurse entry)
   773             end
   774           else
   775             build_simple TU
   776         | _ => build_simple TU);
   777   in build end;
   778 
   779 val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT
   780   [(@{type_name set}, (1, @{term image}))];
   781 val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T o append
   782   [(@{type_name set}, (1, @{term rel_set})), (@{type_name fun}, (2, @{term rel_fun}))];
   783 
   784 fun build_set ctxt A =
   785   let
   786     fun build T =
   787       Abs (Name.uu, T,
   788         if T = A then
   789           HOLogic.mk_set A [Bound 0]
   790         else
   791           (case T of
   792             Type (s, Ts) =>
   793             let
   794               val sets = map (mk_set Ts) (sets_of_bnf (the (bnf_of ctxt s)))
   795                 |> filter (exists_subtype_in [A] o range_type o fastype_of);
   796               val set_apps = map (fn set => Term.betapply (set, Bound 0)) sets;
   797 
   798               fun recurse set_app =
   799                 let val Type (@{type_name set}, [elemT]) = fastype_of set_app in
   800                   if elemT = A then set_app else mk_UNION set_app (build elemT)
   801                 end;
   802             in
   803               if null set_apps then HOLogic.mk_set A []
   804               else Library.foldl1 mk_union (map recurse set_apps)
   805             end
   806           | _ => HOLogic.mk_set A []));
   807   in build end;
   808 
   809 fun map_flattened_map_args ctxt s map_args fs =
   810   let
   811     val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
   812     val flat_fs' = map_args flat_fs;
   813   in
   814     permute_like_unique (op aconv) flat_fs fs flat_fs'
   815   end;
   816 
   817 
   818 (* Names *)
   819 
   820 val mapN = "map";
   821 val setN = "set";
   822 fun mk_setN i = setN ^ nonzero_string_of_int i;
   823 val bdN = "bd";
   824 val witN = "wit";
   825 fun mk_witN i = witN ^ nonzero_string_of_int i;
   826 val relN = "rel";
   827 val predN = "pred";
   828 
   829 val bd_Card_orderN = "bd_Card_order";
   830 val bd_CinfiniteN = "bd_Cinfinite";
   831 val bd_CnotzeroN = "bd_Cnotzero";
   832 val bd_card_orderN = "bd_card_order";
   833 val bd_cinfiniteN = "bd_cinfinite";
   834 val collect_set_mapN = "collect_set_map";
   835 val in_bdN = "in_bd";
   836 val in_monoN = "in_mono";
   837 val in_relN = "in_rel";
   838 val inj_mapN = "inj_map";
   839 val inj_map_strongN = "inj_map_strong";
   840 val map_comp0N = "map_comp0";
   841 val map_compN = "map_comp";
   842 val map_cong0N = "map_cong0";
   843 val map_congN = "map_cong";
   844 val map_cong_simpN = "map_cong_simp";
   845 val map_cong_predN = "map_cong_pred";
   846 val map_id0N = "map_id0";
   847 val map_idN = "map_id";
   848 val map_identN = "map_ident";
   849 val map_transferN = "map_transfer";
   850 val pred_mono_strong0N = "pred_mono_strong0";
   851 val pred_mono_strongN = "pred_mono_strong";
   852 val pred_monoN = "pred_mono";
   853 val pred_transferN = "pred_transfer";
   854 val pred_TrueN = "pred_True";
   855 val pred_mapN = "pred_map";
   856 val pred_relN = "pred_rel";
   857 val pred_setN = "pred_set";
   858 val pred_congN = "pred_cong";
   859 val pred_cong_simpN = "pred_cong_simp";
   860 val rel_GrpN = "rel_Grp";
   861 val rel_comppN = "rel_compp";
   862 val rel_compp_GrpN = "rel_compp_Grp";
   863 val rel_congN = "rel_cong";
   864 val rel_cong_simpN = "rel_cong_simp";
   865 val rel_conversepN = "rel_conversep";
   866 val rel_eqN = "rel_eq";
   867 val rel_eq_onpN = "rel_eq_onp";
   868 val rel_flipN = "rel_flip";
   869 val rel_mapN = "rel_map";
   870 val rel_monoN = "rel_mono";
   871 val rel_mono_strong0N = "rel_mono_strong0";
   872 val rel_mono_strongN = "rel_mono_strong";
   873 val rel_reflN = "rel_refl";
   874 val rel_refl_strongN = "rel_refl_strong";
   875 val rel_reflpN = "rel_reflp";
   876 val rel_sympN = "rel_symp";
   877 val rel_transferN = "rel_transfer";
   878 val rel_transpN = "rel_transp";
   879 val set_bdN = "set_bd";
   880 val set_map0N = "set_map0";
   881 val set_mapN = "set_map";
   882 val set_transferN = "set_transfer";
   883 
   884 datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
   885 
   886 datatype fact_policy = Dont_Note | Note_Some | Note_All;
   887 
   888 val bnf_internals = Attrib.setup_config_bool @{binding bnf_internals} (K false);
   889 val bnf_timing = Attrib.setup_config_bool @{binding bnf_timing} (K false);
   890 
   891 fun user_policy policy ctxt = if Config.get ctxt bnf_internals then Note_All else policy;
   892 
   893 val smart_max_inline_term_size = 25; (*FUDGE*)
   894 
   895 fun note_bnf_thms fact_policy qualify0 bnf_b bnf lthy =
   896   let
   897     val axioms = axioms_of_bnf bnf;
   898     val facts = facts_of_bnf bnf;
   899     val wits = wits_of_bnf bnf;
   900     val qualify =
   901       let val qs = Binding.path_of bnf_b;
   902       in fold_rev (fn (s, mand) => Binding.qualify mand s) qs #> qualify0 end;
   903 
   904     fun note_if_note_all (noted0, lthy0) =
   905       let
   906         val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
   907         val notes =
   908           [(bd_card_orderN, [#bd_card_order axioms]),
   909            (bd_cinfiniteN, [#bd_cinfinite axioms]),
   910            (bd_Card_orderN, [#bd_Card_order facts]),
   911            (bd_CinfiniteN, [#bd_Cinfinite facts]),
   912            (bd_CnotzeroN, [#bd_Cnotzero facts]),
   913            (collect_set_mapN, [Lazy.force (#collect_set_map facts)]),
   914            (in_bdN, [Lazy.force (#in_bd facts)]),
   915            (in_monoN, [Lazy.force (#in_mono facts)]),
   916            (map_comp0N, [#map_comp0 axioms]),
   917            (rel_mono_strong0N, [Lazy.force (#rel_mono_strong0 facts)]),
   918            (pred_mono_strong0N, [Lazy.force (#pred_mono_strong0 facts)]),
   919            (set_map0N, #set_map0 axioms),
   920            (set_bdN, #set_bd axioms)] @
   921           (witNs ~~ wit_thmss_of_bnf bnf)
   922           |> map (fn (thmN, thms) =>
   923             ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), []),
   924              [(thms, [])]));
   925       in
   926         Local_Theory.notes notes lthy0 |>> append noted0
   927       end;
   928 
   929     fun note_unless_dont_note (noted0, lthy0) =
   930       let
   931         val notes =
   932           [(in_relN, [Lazy.force (#in_rel facts)], []),
   933            (inj_mapN, [Lazy.force (#inj_map facts)], []),
   934            (inj_map_strongN, [Lazy.force (#inj_map_strong facts)], []),
   935            (map_compN, [Lazy.force (#map_comp facts)], []),
   936            (map_cong0N, [#map_cong0 axioms], []),
   937            (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
   938            (map_cong_simpN, [Lazy.force (#map_cong_simp facts)], []),
   939            (map_cong_predN, [Lazy.force (#map_cong_pred facts)], []),
   940            (map_idN, [Lazy.force (#map_id facts)], []),
   941            (map_id0N, [#map_id0 axioms], []),
   942            (map_transferN, [Lazy.force (#map_transfer facts)], []),
   943            (map_identN, [Lazy.force (#map_ident facts)], []),
   944            (pred_mono_strongN, [Lazy.force (#pred_mono_strong facts)], []),
   945            (pred_monoN, [Lazy.force (#pred_mono facts)], []),
   946            (pred_congN, [Lazy.force (#pred_cong facts)], fundefcong_attrs),
   947            (pred_cong_simpN, [Lazy.force (#pred_cong_simp facts)], []),
   948            (pred_mapN, [Lazy.force (#pred_map facts)], []),
   949            (pred_relN, [Lazy.force (#pred_rel facts)], []),
   950            (pred_transferN, [Lazy.force (#pred_transfer facts)], []),
   951            (pred_TrueN, [Lazy.force (#pred_True facts)], []),
   952            (pred_setN, [#pred_set axioms], []),
   953            (rel_comppN, [Lazy.force (#rel_OO facts)], []),
   954            (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
   955            (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
   956            (rel_eqN, [Lazy.force (#rel_eq facts)], []),
   957            (rel_eq_onpN, [Lazy.force (#rel_eq_onp facts)], []),
   958            (rel_flipN, [Lazy.force (#rel_flip facts)], []),
   959            (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
   960            (rel_mapN, Lazy.force (#rel_map facts), []),
   961            (rel_monoN, [Lazy.force (#rel_mono facts)], mono_attrs),
   962            (rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)], []),
   963            (rel_congN, [Lazy.force (#rel_cong facts)], fundefcong_attrs),
   964            (rel_cong_simpN, [Lazy.force (#rel_cong_simp facts)], []),
   965            (rel_reflN, [Lazy.force (#rel_refl facts)], []),
   966            (rel_refl_strongN, [Lazy.force (#rel_refl_strong facts)], []),
   967            (rel_reflpN, [Lazy.force (#rel_reflp facts)], []),
   968            (rel_sympN, [Lazy.force (#rel_symp facts)], []),
   969            (rel_transpN, [Lazy.force (#rel_transp facts)], []),
   970            (rel_transferN, [Lazy.force (#rel_transfer facts)], []),
   971            (set_mapN, map Lazy.force (#set_map facts), []),
   972            (set_transferN, Lazy.force (#set_transfer facts), [])]
   973           |> filter_out (null o #2)
   974           |> map (fn (thmN, thms, attrs) =>
   975             ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), attrs),
   976              [(thms, [])]));
   977       in
   978         Local_Theory.notes notes lthy0 |>> append noted0
   979       end;
   980   in
   981     ([], lthy)
   982     |> fact_policy = Note_All ? note_if_note_all
   983     |> fact_policy <> Dont_Note ? note_unless_dont_note
   984     |>> (fn [] => bnf | noted => morph_bnf (substitute_noted_thm noted) bnf)
   985   end;
   986 
   987 fun note_bnf_defs bnf lthy =
   988   let
   989     fun mk_def_binding cst_of =
   990       Thm.def_binding (Binding.qualified_name (dest_Const (cst_of bnf) |> fst));
   991     val notes =
   992       [(mk_def_binding map_of_bnf, map_def_of_bnf bnf),
   993        (mk_def_binding rel_of_bnf, rel_def_of_bnf bnf),
   994        (mk_def_binding pred_of_bnf, pred_def_of_bnf bnf)] @
   995       @{map 2} (pair o mk_def_binding o K) (sets_of_bnf bnf) (set_defs_of_bnf bnf)
   996       |> map (fn (b, thm) => ((b, []), [([thm], [])]));
   997   in
   998     lthy
   999     |> Local_Theory.notes notes
  1000     |>> (fn noted => morph_bnf (substitute_noted_thm noted) bnf)
  1001   end;
  1002 
  1003 fun mk_wit_goals zs bs sets (I, wit) =
  1004   let
  1005     val xs = map (nth bs) I;
  1006     fun wit_goal i =
  1007       let
  1008         val z = nth zs i;
  1009         val set_wit = nth sets i $ Term.list_comb (wit, xs);
  1010         val concl = HOLogic.mk_Trueprop
  1011           (if member (op =) I i then HOLogic.mk_eq (z, nth bs i) else @{term False});
  1012       in
  1013         fold_rev Logic.all (z :: xs) (Logic.mk_implies (mk_Trueprop_mem (z, set_wit), concl))
  1014       end;
  1015   in
  1016     map wit_goal (0 upto length sets - 1)
  1017   end;
  1018 
  1019 
  1020 (* Define new BNFs *)
  1021 
  1022 fun define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b pred_b set_bs
  1023     (((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt), pred_rhs_opt)
  1024     no_defs_lthy =
  1025   let
  1026     val live = length set_rhss;
  1027 
  1028     val def_qualify = Binding.qualify false (Binding.name_of bnf_b);
  1029 
  1030     fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b;
  1031 
  1032     fun maybe_define user_specified (b, rhs) lthy =
  1033       let
  1034         val inline =
  1035           (user_specified orelse fact_policy = Dont_Note) andalso
  1036           (case const_policy of
  1037             Dont_Inline => false
  1038           | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
  1039           | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_term_size
  1040           | Do_Inline => true);
  1041       in
  1042         if inline then
  1043           ((rhs, Drule.reflexive_thm), lthy)
  1044         else
  1045           let val b = b () in
  1046             apfst (apsnd snd)
  1047               ((if internal then Local_Theory.define_internal else Local_Theory.define)
  1048                 ((b, NoSyn), ((Binding.concealed (Thm.def_binding b), []), rhs)) lthy)
  1049           end
  1050       end;
  1051 
  1052     val map_bind_def =
  1053       (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b),
  1054          map_rhs);
  1055     val set_binds_defs =
  1056       let
  1057         fun set_name i get_b =
  1058           (case try (nth set_bs) (i - 1) of
  1059             SOME b => if Binding.is_empty b then get_b else K b
  1060           | NONE => get_b) #> def_qualify;
  1061         val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)]
  1062           else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live);
  1063       in bs ~~ set_rhss end;
  1064     val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs);
  1065 
  1066     val ((((bnf_map_term, raw_map_def),
  1067       (bnf_set_terms, raw_set_defs)),
  1068       (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
  1069         no_defs_lthy
  1070         |> Local_Theory.open_target |> snd
  1071         |> maybe_define true map_bind_def
  1072         ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
  1073         ||>> maybe_define true bd_bind_def
  1074         ||> `Local_Theory.close_target;
  1075 
  1076     val phi = Proof_Context.export_morphism lthy_old lthy;
  1077 
  1078     val bnf_map_def = Morphism.thm phi raw_map_def;
  1079     val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
  1080     val bnf_bd_def = Morphism.thm phi raw_bd_def;
  1081 
  1082     val bnf_map = Morphism.term phi bnf_map_term;
  1083 
  1084     (*TODO: handle errors*)
  1085     (*simple shape analysis of a map function*)
  1086     val ((alphas, betas), (Calpha, _)) =
  1087       fastype_of bnf_map
  1088       |> strip_typeN live
  1089       |>> map_split dest_funT
  1090       ||> dest_funT
  1091       handle TYPE _ => error "Bad map function";
  1092 
  1093     val Calpha_params = map TVar (Term.add_tvarsT Calpha []);
  1094 
  1095     val bnf_T = Morphism.typ phi T_rhs;
  1096     val bad_args = Term.add_tfreesT bnf_T [];
  1097     val _ = null bad_args orelse error ("Locally fixed type arguments " ^
  1098       commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args));
  1099 
  1100     val bnf_sets =
  1101       map2 (normalize_set Calpha_params) alphas (map (Morphism.term phi) bnf_set_terms);
  1102     val bnf_bd =
  1103       Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ Calpha_params)
  1104         (Morphism.term phi bnf_bd_term);
  1105 
  1106     (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
  1107     val deads = (case Ds_opt of
  1108       NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
  1109     | SOME Ds => map (Morphism.typ phi) Ds);
  1110 
  1111     (*TODO: further checks of type of bnf_map*)
  1112     (*TODO: check types of bnf_sets*)
  1113     (*TODO: check type of bnf_bd*)
  1114     (*TODO: check type of bnf_rel*)
  1115 
  1116     fun mk_bnf_map Ds As' Bs' =
  1117       Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
  1118     fun mk_bnf_t Ds As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
  1119     fun mk_bnf_T Ds As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
  1120 
  1121     val (((As, Bs), unsorted_Ds), names_lthy) = lthy
  1122       |> mk_TFrees live
  1123       ||>> mk_TFrees live
  1124       ||>> mk_TFrees (length deads);
  1125 
  1126     val Ds = map2 (resort_tfree_or_tvar o Type.sort_of_atyp) deads unsorted_Ds;
  1127 
  1128     val RTs = map2 (curry HOLogic.mk_prodT) As Bs;
  1129     val pred2RTs = map2 mk_pred2T As Bs;
  1130     val (Rs, Rs') = names_lthy |> mk_Frees' "R" pred2RTs |> fst;
  1131     val CA = mk_bnf_T Ds As Calpha;
  1132     val CR = mk_bnf_T Ds RTs Calpha;
  1133     val setRs =
  1134       @{map 3} (fn R => fn T => fn U =>
  1135           HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_case_prod R) Rs As Bs;
  1136 
  1137     (*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO
  1138       Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*)
  1139     val rel_spec =
  1140       let
  1141         val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs);
  1142         val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs);
  1143         val bnf_in = mk_in setRs (map (mk_bnf_t Ds RTs) bnf_sets) CR;
  1144       in
  1145         mk_rel_compp (mk_conversep (mk_Grp bnf_in map1), mk_Grp bnf_in map2)
  1146         |> fold_rev Term.absfree Rs'
  1147       end;
  1148 
  1149     val rel_rhs = the_default rel_spec rel_rhs_opt;
  1150 
  1151     val rel_bind_def =
  1152       (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
  1153          rel_rhs);
  1154 
  1155     val pred_spec =
  1156       if live = 0 then Term.absdummy (mk_bnf_T Ds As Calpha) @{term True} else
  1157       let
  1158         val sets = map (mk_bnf_t Ds As) bnf_sets;
  1159         val argTs = map mk_pred1T As;
  1160         val T = mk_bnf_T Ds As Calpha;
  1161         val ((Ps, Ps'), x) = lthy
  1162           |> mk_Frees' "P" argTs
  1163           ||>> yield_singleton (mk_Frees "x") T
  1164           |> fst;
  1165         val conjs = map2 (fn set => fn P => mk_Ball (set $ x) P) sets Ps;
  1166       in
  1167         fold_rev Term.absfree Ps'
  1168           (Term.absfree (dest_Free x) (Library.foldr1 HOLogic.mk_conj conjs))
  1169       end;
  1170 
  1171     val pred_rhs = the_default pred_spec pred_rhs_opt;
  1172 
  1173     val pred_bind_def =
  1174       (fn () => def_qualify (if Binding.is_empty pred_b then mk_prefix_binding predN else pred_b),
  1175          pred_rhs);
  1176 
  1177     val wit_rhss =
  1178       if null wit_rhss then
  1179         [fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As,
  1180           map2 (fn T => fn i => Term.absdummy T (Bound i)) As (live downto 1)) $
  1181           Const (@{const_name undefined}, CA))]
  1182       else wit_rhss;
  1183     val nwits = length wit_rhss;
  1184     val wit_binds_defs =
  1185       let
  1186         val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)]
  1187           else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
  1188       in bs ~~ wit_rhss end;
  1189 
  1190     val ((((bnf_rel_term, raw_rel_def), (bnf_pred_term, raw_pred_def)),
  1191         (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
  1192       lthy
  1193       |> Local_Theory.open_target |> snd
  1194       |> maybe_define (is_some rel_rhs_opt) rel_bind_def
  1195       ||>> maybe_define (is_some pred_rhs_opt) pred_bind_def
  1196       ||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs
  1197       ||> `Local_Theory.close_target;
  1198 
  1199     val phi = Proof_Context.export_morphism lthy_old lthy;
  1200     val bnf_rel_def = Morphism.thm phi raw_rel_def;
  1201     val bnf_rel = Morphism.term phi bnf_rel_term;
  1202     fun mk_bnf_rel Ds As' Bs' =
  1203       normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha)
  1204         bnf_rel;
  1205 
  1206     val bnf_pred_def = Morphism.thm phi raw_pred_def;
  1207     val bnf_pred = Morphism.term phi bnf_pred_term;
  1208     fun mk_bnf_pred Ds As' =
  1209       normalize_pred lthy (map mk_pred1T As') (mk_bnf_T Ds As' Calpha) bnf_pred;
  1210 
  1211     val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
  1212     val bnf_wits =
  1213       map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms;
  1214 
  1215     fun mk_rel_spec Ds' As' Bs' =
  1216       Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) rel_spec;
  1217 
  1218     fun mk_pred_spec Ds' As' =
  1219       Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As')) pred_spec;
  1220   in
  1221     (((alphas, betas, deads, Calpha),
  1222      (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel, bnf_pred),
  1223      (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def, bnf_pred_def),
  1224      (mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_bnf_pred, mk_rel_spec, mk_pred_spec)), lthy)
  1225   end;
  1226 
  1227 fun prepare_def const_policy mk_fact_policy internal qualify prep_typ prep_term Ds_opt map_b rel_b
  1228   pred_b set_bs (((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt),
  1229     raw_pred_opt) no_defs_lthy =
  1230   let
  1231     val fact_policy = mk_fact_policy no_defs_lthy;
  1232     val bnf_b = qualify raw_bnf_b;
  1233     val live = length raw_sets;
  1234 
  1235     val T_rhs = prep_typ no_defs_lthy raw_bnf_T;
  1236     val map_rhs = prep_term no_defs_lthy raw_map;
  1237     val set_rhss = map (prep_term no_defs_lthy) raw_sets;
  1238     val bd_rhs = prep_term no_defs_lthy raw_bd;
  1239     val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
  1240     val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt;
  1241     val pred_rhs_opt = Option.map (prep_term no_defs_lthy) raw_pred_opt;
  1242 
  1243     fun err T =
  1244       error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
  1245         " as unnamed BNF");
  1246 
  1247     val (bnf_b, key) =
  1248       if Binding.is_empty bnf_b then
  1249         (case T_rhs of
  1250           Type (C, Ts) =>
  1251           if forall (can dest_TFree) Ts andalso not (has_duplicates (op =) Ts) then
  1252             (Binding.qualified_name C, C)
  1253           else
  1254             err T_rhs
  1255         | T => err T)
  1256       else
  1257         (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
  1258 
  1259     val (((alphas, betas, deads, Calpha),
  1260      (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel, bnf_pred),
  1261      (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def, bnf_pred_def),
  1262      (mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, _, mk_rel_spec, mk_pred_spec)), lthy) =
  1263        define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b pred_b set_bs
  1264          (((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt), pred_rhs_opt)
  1265          no_defs_lthy;
  1266 
  1267     val dead = length deads;
  1268 
  1269     val (((((((As', Bs'), Cs), unsorted_Ds), Es), B1Ts), B2Ts), (Ts, T)) = lthy
  1270       |> mk_TFrees live
  1271       ||>> mk_TFrees live
  1272       ||>> mk_TFrees live
  1273       ||>> mk_TFrees dead
  1274       ||>> mk_TFrees live
  1275       ||>> mk_TFrees live
  1276       ||>> mk_TFrees live
  1277       ||> fst o mk_TFrees 1
  1278       ||> the_single
  1279       ||> `(replicate live);
  1280 
  1281     val Ds = map2 (resort_tfree_or_tvar o Type.sort_of_atyp) deads unsorted_Ds;
  1282 
  1283     val mk_bnf_map = mk_bnf_map_Ds Ds;
  1284     val mk_bnf_t = mk_bnf_t_Ds Ds;
  1285     val mk_bnf_T = mk_bnf_T_Ds Ds;
  1286 
  1287     val pred1PTs = map mk_pred1T As';
  1288     val pred1QTs = map mk_pred1T Bs';
  1289     val pred2RTs = map2 mk_pred2T As' Bs';
  1290     val pred2RTsAsCs = map2 mk_pred2T As' Cs;
  1291     val pred2RTsBsCs = map2 mk_pred2T Bs' Cs;
  1292     val pred2RTsBsEs = map2 mk_pred2T Bs' Es;
  1293     val pred2RTsCsBs = map2 mk_pred2T Cs Bs';
  1294     val pred2RTsCsEs = map2 mk_pred2T Cs Es;
  1295     val pred2RT's = map2 mk_pred2T Bs' As';
  1296     val self_pred2RTs = map2 mk_pred2T As' As';
  1297     val transfer_domRTs = map2 mk_pred2T As' B1Ts;
  1298     val transfer_ranRTs = map2 mk_pred2T Bs' B2Ts;
  1299 
  1300     val CA' = mk_bnf_T As' Calpha;
  1301     val CB' = mk_bnf_T Bs' Calpha;
  1302     val CC' = mk_bnf_T Cs Calpha;
  1303     val CE' = mk_bnf_T Es Calpha;
  1304     val CB1 = mk_bnf_T B1Ts Calpha;
  1305     val CB2 = mk_bnf_T B2Ts Calpha;
  1306 
  1307     val bnf_map_AsAs = mk_bnf_map As' As';
  1308     val bnf_map_AsBs = mk_bnf_map As' Bs';
  1309     val bnf_map_AsCs = mk_bnf_map As' Cs;
  1310     val bnf_map_BsCs = mk_bnf_map Bs' Cs;
  1311     val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
  1312     val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
  1313     val bnf_bd_As = mk_bnf_t As' bnf_bd;
  1314     fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel;
  1315     fun mk_bnf_pred PTs CA = normalize_pred lthy PTs CA bnf_pred;
  1316 
  1317     val ((((((((((((((((((((((((((fs, fs'), gs), hs), is), x), x'), y), y'), zs), zs'), ys), As),
  1318       As_copy), bs), (Ps, Ps')), Ps_copy), Qs), Rs), Rs_copy), Ss), S_AsCs), S_CsBs), S_BsEs),
  1319       transfer_domRs), transfer_ranRs), _) = lthy
  1320       |> mk_Frees "f" (map2 (curry op -->) As' Bs')
  1321       ||>> mk_Frees "f" (map2 (curry op -->) As' Bs')
  1322       ||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs)
  1323       ||>> mk_Frees "h" (map2 (curry op -->) As' Ts)
  1324       ||>> mk_Frees "i" (map2 (curry op -->) As' Cs)
  1325       ||>> yield_singleton (mk_Frees "x") CA'
  1326       ||>> yield_singleton (mk_Frees "x") CA'
  1327       ||>> yield_singleton (mk_Frees "y") CB'
  1328       ||>> yield_singleton (mk_Frees "y") CB'
  1329       ||>> mk_Frees "z" As'
  1330       ||>> mk_Frees "z" As'
  1331       ||>> mk_Frees "y" Bs'
  1332       ||>> mk_Frees "A" (map HOLogic.mk_setT As')
  1333       ||>> mk_Frees "A" (map HOLogic.mk_setT As')
  1334       ||>> mk_Frees "b" As'
  1335       ||>> mk_Frees' "P" pred1PTs
  1336       ||>> mk_Frees "P" pred1PTs
  1337       ||>> mk_Frees "Q" pred1QTs
  1338       ||>> mk_Frees "R" pred2RTs
  1339       ||>> mk_Frees "R" pred2RTs
  1340       ||>> mk_Frees "S" pred2RTsBsCs
  1341       ||>> mk_Frees "S" pred2RTsAsCs
  1342       ||>> mk_Frees "S" pred2RTsCsBs
  1343       ||>> mk_Frees "S" pred2RTsBsEs
  1344       ||>> mk_Frees "R" transfer_domRTs
  1345       ||>> mk_Frees "S" transfer_ranRTs;
  1346 
  1347     val fs_copy = map2 (retype_const_or_free o fastype_of) fs gs;
  1348     val x_copy = retype_const_or_free CA' y';
  1349     val y_copy = retype_const_or_free CB' x';
  1350 
  1351     val rel = mk_bnf_rel pred2RTs CA' CB';
  1352     val pred = mk_bnf_pred pred1PTs CA';
  1353     val pred' = mk_bnf_pred pred1QTs CB';
  1354     val relCsEs = mk_bnf_rel pred2RTsCsEs CC' CE';
  1355     val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
  1356     val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
  1357 
  1358     val map_id0_goal =
  1359       let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
  1360         mk_Trueprop_eq (bnf_map_app_id, HOLogic.id_const CA')
  1361       end;
  1362 
  1363     val map_comp0_goal =
  1364       let
  1365         val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
  1366         val comp_bnf_map_app = HOLogic.mk_comp
  1367           (Term.list_comb (bnf_map_BsCs, gs), Term.list_comb (bnf_map_AsBs, fs));
  1368       in
  1369         fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
  1370       end;
  1371 
  1372     fun mk_map_cong_prem mk_implies x z set f f_copy =
  1373       Logic.all z (mk_implies (mk_Trueprop_mem (z, set $ x), mk_Trueprop_eq (f $ z, f_copy $ z)));
  1374 
  1375     val map_cong0_goal =
  1376       let
  1377         val prems = @{map 4} (mk_map_cong_prem Logic.mk_implies x) zs bnf_sets_As fs fs_copy;
  1378         val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
  1379           Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
  1380       in
  1381         fold_rev Logic.all (x :: fs @ fs_copy) (Logic.list_implies (prems, eq))
  1382       end;
  1383 
  1384     val set_map0s_goal =
  1385       let
  1386         fun mk_goal setA setB f =
  1387           let
  1388             val set_comp_map = HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
  1389             val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
  1390           in
  1391             fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
  1392           end;
  1393       in
  1394         @{map 3} mk_goal bnf_sets_As bnf_sets_Bs fs
  1395       end;
  1396 
  1397     val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
  1398 
  1399     val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
  1400 
  1401     val set_bds_goal =
  1402       let
  1403         fun mk_goal set =
  1404           Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
  1405       in
  1406         map mk_goal bnf_sets_As
  1407       end;
  1408 
  1409     val relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC';
  1410     val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC';
  1411     val relCsBs = mk_bnf_rel pred2RTsCsBs CC' CB';
  1412     val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss);
  1413     val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss));
  1414     val le_rel_OO_goal =
  1415       fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs));
  1416 
  1417     val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs),
  1418       Term.list_comb (mk_rel_spec Ds As' Bs', Rs)));
  1419 
  1420     val pred_set_goal = fold_rev Logic.all Ps (mk_Trueprop_eq (Term.list_comb (pred, Ps),
  1421       Term.list_comb (mk_pred_spec Ds As', Ps)));
  1422 
  1423     val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal
  1424       card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal pred_set_goal;
  1425 
  1426     val mk_wit_goals = mk_wit_goals bs zs bnf_sets_As;
  1427     fun triv_wit_tac ctxt = mk_trivial_wit_tac ctxt bnf_wit_defs;
  1428 
  1429     val wit_goalss =
  1430       (if null raw_wits then SOME triv_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
  1431 
  1432     fun after_qed mk_wit_thms thms lthy =
  1433       let
  1434         val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
  1435 
  1436         val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
  1437         val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
  1438         val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
  1439 
  1440         fun mk_collect_set_map () =
  1441           let
  1442             val defT = mk_bnf_T Ts Calpha --> HOLogic.mk_setT T;
  1443             val collect_map = HOLogic.mk_comp (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
  1444               Term.list_comb (mk_bnf_map As' Ts, hs));
  1445             val image_collect = mk_collect
  1446               (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As) defT;
  1447             (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
  1448             val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
  1449           in
  1450             Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} =>
  1451               mk_collect_set_map_tac ctxt (#set_map0 axioms))
  1452             |> Thm.close_derivation
  1453           end;
  1454 
  1455         val collect_set_map = Lazy.lazy mk_collect_set_map;
  1456 
  1457         fun mk_in_mono () =
  1458           let
  1459             val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_leq) As As_copy;
  1460             val in_mono_goal =
  1461               fold_rev Logic.all (As @ As_copy)
  1462                 (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
  1463                   (mk_leq (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
  1464           in
  1465             Goal.prove_sorry lthy [] [] in_mono_goal (fn {context = ctxt, prems = _} =>
  1466               mk_in_mono_tac ctxt live)
  1467             |> Thm.close_derivation
  1468           end;
  1469 
  1470         val in_mono = Lazy.lazy mk_in_mono;
  1471 
  1472         fun mk_in_cong () =
  1473           let
  1474             val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy;
  1475             val in_cong_goal =
  1476               fold_rev Logic.all (As @ As_copy)
  1477                 (Logic.list_implies (prems_cong,
  1478                   mk_Trueprop_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA')));
  1479           in
  1480             Goal.prove_sorry lthy [] [] in_cong_goal
  1481               (fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1)
  1482             |> Thm.close_derivation
  1483           end;
  1484 
  1485         val in_cong = Lazy.lazy mk_in_cong;
  1486 
  1487         val map_id = Lazy.lazy (fn () => mk_map_id (#map_id0 axioms));
  1488         val map_ident0 = Lazy.lazy (fn () => mk_map_ident lthy (#map_id0 axioms));
  1489         val map_ident = Lazy.lazy (fn () => mk_map_ident lthy (Lazy.force map_id));
  1490         val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms));
  1491 
  1492         fun mk_map_cong mk_implies () =
  1493           let
  1494             val prem0 = mk_Trueprop_eq (x, x_copy);
  1495             val prems = @{map 4} (mk_map_cong_prem mk_implies x_copy) zs bnf_sets_As fs fs_copy;
  1496             val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
  1497               Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
  1498             val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
  1499               (Logic.list_implies (prem0 :: prems, eq));
  1500           in
  1501             Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} =>
  1502               unfold_thms_tac ctxt @{thms simp_implies_def} THEN
  1503               mk_map_cong_tac ctxt (#map_cong0 axioms))
  1504             |> Thm.close_derivation
  1505           end;
  1506 
  1507         val map_cong = Lazy.lazy (mk_map_cong Logic.mk_implies);
  1508         val map_cong_simp = Lazy.lazy (mk_map_cong (fn (a, b) => @{term simp_implies} $ a $ b));
  1509 
  1510         fun mk_inj_map () =
  1511           let
  1512             val prems = map (HOLogic.mk_Trueprop o mk_inj) fs;
  1513             val concl = HOLogic.mk_Trueprop (mk_inj (Term.list_comb (bnf_map_AsBs, fs)));
  1514             val goal = fold_rev Logic.all fs (Logic.list_implies (prems, concl));
  1515           in
  1516             Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} =>
  1517               mk_inj_map_tac ctxt live (Lazy.force map_id) (Lazy.force map_comp) (#map_cong0 axioms)
  1518                 (Lazy.force map_cong))
  1519             |> Thm.close_derivation
  1520           end;
  1521 
  1522         val inj_map = Lazy.lazy mk_inj_map;
  1523 
  1524         val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
  1525 
  1526         val wit_thms =
  1527           if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
  1528 
  1529         fun mk_in_bd () =
  1530           let
  1531             val bdT = fst (dest_relT (fastype_of bnf_bd_As));
  1532             val bdTs = replicate live bdT;
  1533             val bd_bnfT = mk_bnf_T bdTs Calpha;
  1534             val surj_imp_ordLeq_inst = (if live = 0 then TrueI else
  1535               let
  1536                 val ranTs = map (fn AT => mk_sumT (AT, HOLogic.unitT)) As';
  1537                 val funTs = map (fn T => bdT --> T) ranTs;
  1538                 val ran_bnfT = mk_bnf_T ranTs Calpha;
  1539                 val (revTs, Ts) = `rev (bd_bnfT :: funTs);
  1540                 val cTs = map (SOME o Thm.ctyp_of lthy) [ran_bnfT,
  1541                   Library.foldr1 HOLogic.mk_prodT Ts];
  1542                 val tinst = fold (fn T => fn t =>
  1543                   HOLogic.mk_case_prod (Term.absdummy T t)) (tl revTs)
  1544                     (Term.absdummy (hd revTs) (Term.list_comb (mk_bnf_map bdTs ranTs,
  1545                       map Bound (live - 1 downto 0)) $ Bound live));
  1546                 val cts = [NONE, SOME (Thm.cterm_of lthy tinst)];
  1547               in
  1548                 Thm.instantiate' cTs cts @{thm surj_imp_ordLeq}
  1549               end);
  1550             val bd = mk_cexp
  1551               (if live = 0 then ctwo
  1552                 else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
  1553               (mk_csum bnf_bd_As (mk_card_of (HOLogic.mk_UNIV bd_bnfT)));
  1554             val in_bd_goal =
  1555               fold_rev Logic.all As
  1556                 (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd));
  1557           in
  1558             Goal.prove_sorry lthy [] [] in_bd_goal
  1559               (fn {context = ctxt, prems = _} => mk_in_bd_tac ctxt live surj_imp_ordLeq_inst
  1560                 (Lazy.force map_comp) (Lazy.force map_id) (#map_cong0 axioms)
  1561                 (map Lazy.force set_map) (#set_bd axioms) (#bd_card_order axioms)
  1562                 bd_Card_order bd_Cinfinite bd_Cnotzero)
  1563             |> Thm.close_derivation
  1564           end;
  1565 
  1566         val in_bd = Lazy.lazy mk_in_bd;
  1567 
  1568         val rel_OO_Grp = #rel_OO_Grp axioms;
  1569         val rel_OO_Grps = no_refl [rel_OO_Grp];
  1570 
  1571         fun mk_rel_Grp () =
  1572           let
  1573             val lhs = Term.list_comb (rel, map2 mk_Grp As fs);
  1574             val rhs = mk_Grp (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
  1575             val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
  1576           in
  1577             Goal.prove_sorry lthy [] [] goal
  1578               (fn {context = ctxt, prems = _} => mk_rel_Grp_tac ctxt rel_OO_Grps (#map_id0 axioms)
  1579                 (#map_cong0 axioms) (Lazy.force map_id) (Lazy.force map_comp)
  1580                 (map Lazy.force set_map))
  1581             |> Thm.close_derivation
  1582           end;
  1583 
  1584         val rel_Grp = Lazy.lazy mk_rel_Grp;
  1585 
  1586         fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy;
  1587         fun mk_rel_concl f = HOLogic.mk_Trueprop
  1588           (f (Term.list_comb (rel, Rs), Term.list_comb (rel, Rs_copy)));
  1589 
  1590         fun mk_rel_mono () =
  1591           let
  1592             val mono_prems = mk_rel_prems mk_leq;
  1593             val mono_concl = mk_rel_concl (uncurry mk_leq);
  1594           in
  1595             Goal.prove_sorry lthy [] []
  1596               (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
  1597               (fn {context = ctxt, prems = _} =>
  1598                 mk_rel_mono_tac ctxt rel_OO_Grps (Lazy.force in_mono))
  1599             |> Thm.close_derivation
  1600           end;
  1601 
  1602         fun mk_rel_cong0 () =
  1603           let
  1604             val cong_prems = mk_rel_prems (curry HOLogic.mk_eq);
  1605             val cong_concl = mk_rel_concl HOLogic.mk_eq;
  1606           in
  1607             Goal.prove_sorry lthy [] []
  1608               (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
  1609               (fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1)
  1610             |> Thm.close_derivation
  1611           end;
  1612 
  1613         val rel_mono = Lazy.lazy mk_rel_mono;
  1614         val rel_cong0 = Lazy.lazy mk_rel_cong0;
  1615 
  1616         fun mk_rel_eq () =
  1617           Goal.prove_sorry lthy [] []
  1618             (mk_Trueprop_eq (Term.list_comb (relAsAs, map HOLogic.eq_const As'),
  1619               HOLogic.eq_const CA'))
  1620             (fn {context = ctxt, prems = _} =>
  1621               mk_rel_eq_tac ctxt live (Lazy.force rel_Grp) (Lazy.force rel_cong0) (#map_id0 axioms))
  1622           |> Thm.close_derivation;
  1623 
  1624         val rel_eq = Lazy.lazy mk_rel_eq;
  1625 
  1626         fun mk_rel_conversep () =
  1627           let
  1628             val relBsAs = mk_bnf_rel pred2RT's CB' CA';
  1629             val lhs = Term.list_comb (relBsAs, map mk_conversep Rs);
  1630             val rhs = mk_conversep (Term.list_comb (rel, Rs));
  1631             val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_leq lhs rhs));
  1632             val le_thm = Goal.prove_sorry lthy [] [] le_goal
  1633               (fn {context = ctxt, prems = _} => mk_rel_conversep_le_tac ctxt rel_OO_Grps
  1634                 (Lazy.force rel_eq) (#map_cong0 axioms) (Lazy.force map_comp)
  1635                 (map Lazy.force set_map))
  1636               |> Thm.close_derivation
  1637             val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
  1638           in
  1639             Goal.prove_sorry lthy [] [] goal
  1640               (fn {context = ctxt, prems = _} =>
  1641                 mk_rel_conversep_tac ctxt le_thm (Lazy.force rel_mono))
  1642             |> Thm.close_derivation
  1643           end;
  1644 
  1645         val rel_conversep = Lazy.lazy mk_rel_conversep;
  1646 
  1647         fun mk_rel_OO () =
  1648           Goal.prove_sorry lthy [] []
  1649             (fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_lhs rel_OO_rhs)))
  1650             (fn {context = ctxt, prems = _} => mk_rel_OO_le_tac ctxt rel_OO_Grps (Lazy.force rel_eq)
  1651               (#map_cong0 axioms) (Lazy.force map_comp) (map Lazy.force set_map))
  1652           |> Thm.close_derivation
  1653           |> (fn thm => @{thm antisym} OF [thm, #le_rel_OO axioms]);
  1654 
  1655         val rel_OO = Lazy.lazy mk_rel_OO;
  1656 
  1657         fun mk_in_rel () = trans OF [rel_OO_Grp, @{thm OO_Grp_alt}] RS @{thm predicate2_eqD};
  1658 
  1659         val in_rel = Lazy.lazy mk_in_rel;
  1660 
  1661         fun mk_rel_flip () =
  1662           unfold_thms lthy @{thms conversep_iff}
  1663             (Lazy.force rel_conversep RS @{thm predicate2_eqD});
  1664 
  1665         val rel_flip = Lazy.lazy mk_rel_flip;
  1666 
  1667         fun mk_rel_mono_strong0 () =
  1668           let
  1669             fun mk_prem setA setB R S a b =
  1670               HOLogic.mk_Trueprop
  1671                 (mk_Ball (setA $ x) (Term.absfree (dest_Free a)
  1672                   (mk_Ball (setB $ y) (Term.absfree (dest_Free b)
  1673                     (HOLogic.mk_imp (R $ a $ b, S $ a $ b))))));
  1674             val prems = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs) $ x $ y) ::
  1675               @{map 6} mk_prem bnf_sets_As bnf_sets_Bs Rs Rs_copy zs ys;
  1676             val concl = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs_copy) $ x $ y);
  1677           in
  1678             Goal.prove_sorry lthy [] []
  1679               (fold_rev Logic.all (x :: y :: Rs @ Rs_copy) (Logic.list_implies (prems, concl)))
  1680               (fn {context = ctxt, prems = _} => mk_rel_mono_strong0_tac ctxt (Lazy.force in_rel)
  1681                 (map Lazy.force set_map))
  1682             |> Thm.close_derivation
  1683           end;
  1684 
  1685         val rel_mono_strong0 = Lazy.lazy mk_rel_mono_strong0;
  1686 
  1687         val rel_mono_strong = Lazy.map (Object_Logic.rulify lthy) rel_mono_strong0;
  1688 
  1689         fun mk_rel_cong_prem mk_implies x x' z z' set set' R R_copy =
  1690           Logic.all z (Logic.all z'
  1691             (mk_implies (mk_Trueprop_mem (z, set $ x), mk_implies (mk_Trueprop_mem (z', set' $ x'),
  1692               mk_Trueprop_eq (R $ z $ z', R_copy $ z $ z')))));
  1693 
  1694         fun mk_rel_cong mk_implies () =
  1695           let
  1696             val prem0 = mk_Trueprop_eq (x, x_copy);
  1697             val prem1 = mk_Trueprop_eq (y, y_copy);
  1698             val prems = @{map 6} (mk_rel_cong_prem mk_implies x_copy y_copy)
  1699               zs ys bnf_sets_As bnf_sets_Bs Rs Rs_copy;
  1700             val eq = mk_Trueprop_eq (Term.list_comb (rel, Rs) $ x $ y,
  1701               Term.list_comb (rel, Rs_copy) $ x_copy $ y_copy);
  1702           in
  1703             fold (Variable.add_free_names lthy) (eq :: prem0 :: prem1 :: prems) []
  1704             |> (fn vars => Goal.prove_sorry lthy vars (prem0 :: prem1 :: prems) eq
  1705               (fn {context = ctxt, prems} =>
  1706                 mk_rel_cong_tac ctxt (chop 2 prems) (Lazy.force rel_mono_strong)))
  1707             |> Thm.close_derivation
  1708           end;
  1709 
  1710         val rel_cong = Lazy.lazy (mk_rel_cong Logic.mk_implies);
  1711         val rel_cong_simp = Lazy.lazy (mk_rel_cong (fn (a, b) => @{term simp_implies} $ a $ b));
  1712 
  1713         fun mk_pred_prems f = map2 (HOLogic.mk_Trueprop oo f) Ps Ps_copy;
  1714         fun mk_pred_concl f = HOLogic.mk_Trueprop
  1715           (f (Term.list_comb (pred, Ps), Term.list_comb (pred, Ps_copy)));
  1716 
  1717         fun mk_pred_cong0 () =
  1718           let
  1719             val cong_prems = mk_pred_prems (curry HOLogic.mk_eq);
  1720             val cong_concl = mk_pred_concl HOLogic.mk_eq;
  1721           in
  1722             Goal.prove_sorry lthy [] []
  1723               (fold_rev Logic.all (Ps @ Ps_copy) (Logic.list_implies (cong_prems, cong_concl)))
  1724               (fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1)
  1725             |> Thm.close_derivation
  1726           end;
  1727 
  1728         val pred_cong0 = Lazy.lazy mk_pred_cong0;
  1729 
  1730         fun mk_rel_eq_onp () =
  1731           let
  1732             val lhs = Term.list_comb (relAsAs, map mk_eq_onp Ps);
  1733             val rhs = mk_eq_onp (Term.list_comb (pred, Ps));
  1734           in
  1735             Goal.prove_sorry lthy (map fst Ps') [] (mk_Trueprop_eq (lhs, rhs))
  1736               (fn {context = ctxt, prems = _} =>
  1737                 mk_rel_eq_onp_tac ctxt (#pred_set axioms) (#map_id0 axioms) (Lazy.force rel_Grp))
  1738             |> Thm.close_derivation
  1739           end;
  1740 
  1741         val rel_eq_onp = Lazy.lazy mk_rel_eq_onp;
  1742         val pred_rel = Lazy.map (fn thm => thm RS sym RS @{thm eq_onp_eqD}) rel_eq_onp;
  1743 
  1744         fun mk_pred_mono_strong0 () =
  1745           let
  1746             fun mk_prem setA P Q a =
  1747               HOLogic.mk_Trueprop
  1748                 (mk_Ball (setA $ x) (Term.absfree (dest_Free a) (HOLogic.mk_imp (P $ a, Q $ a))));
  1749             val prems = HOLogic.mk_Trueprop (Term.list_comb (pred, Ps) $ x) ::
  1750               @{map 4} mk_prem bnf_sets_As Ps Ps_copy zs;
  1751             val concl = HOLogic.mk_Trueprop (Term.list_comb (pred, Ps_copy) $ x);
  1752           in
  1753             Goal.prove_sorry lthy [] []
  1754               (fold_rev Logic.all (x :: Ps @ Ps_copy) (Logic.list_implies (prems, concl)))
  1755               (fn {context = ctxt, prems = _} =>
  1756                 mk_pred_mono_strong0_tac ctxt (Lazy.force pred_rel) (Lazy.force rel_mono_strong0))
  1757             |> Thm.close_derivation
  1758           end;
  1759 
  1760         val pred_mono_strong0 = Lazy.lazy mk_pred_mono_strong0;
  1761 
  1762         val pred_mono_strong = Lazy.map (Object_Logic.rulify lthy) pred_mono_strong0;
  1763 
  1764         fun mk_pred_mono () =
  1765           let
  1766             val mono_prems = mk_pred_prems mk_leq;
  1767             val mono_concl = mk_pred_concl (uncurry mk_leq);
  1768           in
  1769             Goal.prove_sorry lthy [] []
  1770               (fold_rev Logic.all (Ps @ Ps_copy) (Logic.list_implies (mono_prems, mono_concl)))
  1771               (fn {context = ctxt, prems = _} =>
  1772                 mk_pred_mono_tac ctxt (Lazy.force rel_eq_onp) (Lazy.force rel_mono))
  1773             |> Thm.close_derivation
  1774           end;
  1775 
  1776         val pred_mono = Lazy.lazy mk_pred_mono;
  1777 
  1778         fun mk_pred_cong_prem mk_implies x z set P P_copy =
  1779           Logic.all z
  1780             (mk_implies (mk_Trueprop_mem (z, set $ x), mk_Trueprop_eq (P $ z, P_copy $ z)));
  1781 
  1782         fun mk_pred_cong mk_implies () =
  1783           let
  1784             val prem0 = mk_Trueprop_eq (x, x_copy);
  1785             val prems = @{map 4} (mk_pred_cong_prem mk_implies x_copy) zs bnf_sets_As Ps Ps_copy;
  1786             val eq = mk_Trueprop_eq (Term.list_comb (pred, Ps) $ x,
  1787               Term.list_comb (pred, Ps_copy) $ x_copy);
  1788           in
  1789             fold (Variable.add_free_names lthy) (eq :: prem0 :: prems) []
  1790             |> (fn vars => Goal.prove_sorry lthy vars (prem0 :: prems) eq
  1791               (fn {context = ctxt, prems} =>
  1792                 mk_rel_cong_tac ctxt (chop 1 prems) (Lazy.force pred_mono_strong)))
  1793             |> Thm.close_derivation
  1794           end;
  1795 
  1796         val pred_cong = Lazy.lazy (mk_pred_cong Logic.mk_implies);
  1797         val pred_cong_simp = Lazy.lazy (mk_pred_cong (fn (a, b) => @{term simp_implies} $ a $ b));
  1798 
  1799         fun mk_map_cong_pred () =
  1800           let
  1801             val prem0 = mk_Trueprop_eq (x, x_copy);
  1802             fun mk_eq f g z = Term.absfree (dest_Free z) (HOLogic.mk_eq (f $ z, g $ z));
  1803             val prem = HOLogic.mk_Trueprop
  1804               (Term.list_comb (pred, @{map 3} mk_eq fs fs_copy zs) $ x_copy);
  1805             val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
  1806               Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
  1807             val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
  1808               (Logic.list_implies ([prem0, prem], eq));
  1809           in
  1810             Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} =>
  1811               unfold_thms_tac ctxt [#pred_set axioms] THEN
  1812               HEADGOAL (EVERY' [REPEAT_DETERM o etac ctxt conjE,
  1813                 etac ctxt (Lazy.force map_cong) THEN_ALL_NEW
  1814                   (etac ctxt @{thm bspec} THEN' assume_tac ctxt)]))
  1815             |> Thm.close_derivation
  1816           end;
  1817 
  1818         val map_cong_pred = Lazy.lazy mk_map_cong_pred;
  1819 
  1820         fun mk_rel_map () =
  1821           let
  1822             fun mk_goal lhs rhs =
  1823               fold_rev Logic.all ([x, y] @ S_CsBs @ S_AsCs @ is @ gs) (mk_Trueprop_eq (lhs, rhs));
  1824 
  1825             val lhss =
  1826               [Term.list_comb (relCsBs, S_CsBs) $ (Term.list_comb (bnf_map_AsCs, is) $ x) $ y,
  1827                Term.list_comb (relAsCs, S_AsCs) $ x $ (Term.list_comb (bnf_map_BsCs, gs) $ y)];
  1828             val rhss =
  1829               [Term.list_comb (rel, @{map 3} (fn f => fn P => fn T =>
  1830                  mk_vimage2p f (HOLogic.id_const T) $ P) is S_CsBs Bs') $ x $ y,
  1831                Term.list_comb (rel, @{map 3} (fn f => fn P => fn T =>
  1832                  mk_vimage2p (HOLogic.id_const T) f $ P) gs S_AsCs As') $ x $ y];
  1833             val goals = map2 mk_goal lhss rhss;
  1834           in
  1835             goals
  1836             |> map (fn goal => Goal.prove_sorry lthy [] [] goal
  1837               (fn {context = ctxt, prems = _} =>
  1838                  mk_rel_map0_tac ctxt live (Lazy.force rel_OO) (Lazy.force rel_conversep)
  1839                   (Lazy.force rel_Grp) (Lazy.force map_id)))
  1840             |> map (unfold_thms lthy @{thms vimage2p_def[of id, simplified id_apply]
  1841                  vimage2p_def[of _ id, simplified id_apply]})
  1842             |> map Thm.close_derivation
  1843           end;
  1844 
  1845         val rel_map = Lazy.lazy mk_rel_map;
  1846 
  1847         fun mk_rel_refl () = @{thm ge_eq_refl[OF ord_eq_le_trans]} OF
  1848           [Lazy.force rel_eq RS sym, Lazy.force rel_mono OF (replicate live @{thm refl_ge_eq})];
  1849 
  1850         val rel_refl = Lazy.lazy mk_rel_refl;
  1851 
  1852         fun mk_rel_refl_strong () =
  1853           (rule_by_tactic lthy (ALLGOALS (Object_Logic.full_atomize_tac lthy))
  1854             ((Lazy.force rel_eq RS @{thm predicate2_eqD}) RS @{thm iffD2[OF _ refl]} RS
  1855               Lazy.force rel_mono_strong)) OF
  1856             (replicate live @{thm diag_imp_eq_le})
  1857 
  1858         val rel_refl_strong = Lazy.lazy mk_rel_refl_strong;
  1859 
  1860         fun mk_rel_preserves mk_prop prop_conv_thm thm () =
  1861           let
  1862             val Rs = map2 retype_const_or_free self_pred2RTs Rs;
  1863             val prems = map (HOLogic.mk_Trueprop o mk_prop) Rs;
  1864             val goal = HOLogic.mk_Trueprop (mk_prop (Term.list_comb (relAsAs, Rs)));
  1865         val vars = fold (Variable.add_free_names lthy) (goal :: prems) [];
  1866           in
  1867             Goal.prove_sorry lthy vars [] (Logic.list_implies (prems, goal))
  1868               (fn {context = ctxt, prems = _} =>
  1869                 unfold_thms_tac ctxt [prop_conv_thm] THEN
  1870                 HEADGOAL (rtac ctxt (Lazy.force thm RS sym RS @{thm ord_eq_le_trans})
  1871                   THEN' rtac ctxt (Lazy.force rel_mono) THEN_ALL_NEW assume_tac ctxt))
  1872             |> Thm.close_derivation
  1873           end;
  1874 
  1875         val rel_reflp = Lazy.lazy (mk_rel_preserves mk_reflp @{thm reflp_eq} rel_eq);
  1876         val rel_symp = Lazy.lazy (mk_rel_preserves mk_symp @{thm symp_conversep} rel_conversep);
  1877         val rel_transp = Lazy.lazy (mk_rel_preserves mk_transp @{thm transp_relcompp} rel_OO);
  1878 
  1879         fun mk_pred_True () =
  1880           let
  1881             val lhs = Term.list_comb (pred, map (fn T => absdummy T @{term True}) As');
  1882             val rhs = absdummy CA' @{term True};
  1883             val goal = mk_Trueprop_eq (lhs, rhs);
  1884           in
  1885             Goal.prove_sorry lthy [] [] goal
  1886               (fn {context = ctxt, prems = _} =>
  1887                 HEADGOAL (EVERY' (map (rtac ctxt) [ext, Lazy.force pred_rel RS trans,
  1888                   Lazy.force rel_cong0 RS fun_cong RS fun_cong RS trans OF
  1889                     replicate live @{thm eq_onp_True},
  1890                   Lazy.force rel_eq RS fun_cong RS fun_cong RS trans, @{thm eqTrueI[OF refl]}])))
  1891             |> Thm.close_derivation
  1892           end;
  1893 
  1894         val pred_True = Lazy.lazy mk_pred_True;
  1895 
  1896         fun mk_pred_map () =
  1897           let
  1898             val lhs = Term.list_comb (pred', Qs) $ (Term.list_comb (bnf_map_AsBs, fs) $ x);
  1899             val rhs = Term.list_comb (pred, @{map 2} (curry HOLogic.mk_comp) Qs fs) $ x;
  1900             val goal = mk_Trueprop_eq (lhs, rhs);
  1901             val vars = Variable.add_free_names lthy goal [];
  1902             val pred_set = #pred_set axioms RS fun_cong RS sym;
  1903           in
  1904             Goal.prove_sorry lthy vars [] goal
  1905               (fn {context = ctxt, prems = _} =>
  1906                 HEADGOAL (rtac ctxt (pred_set RSN (2, pred_set RSN (2, box_equals)))) THEN
  1907                 unfold_thms_tac ctxt
  1908                   (@{thms Ball_image_comp ball_empty} @ map Lazy.force set_map) THEN
  1909                 HEADGOAL (rtac ctxt refl))
  1910             |> Thm.close_derivation
  1911           end;
  1912 
  1913         val pred_map = Lazy.lazy mk_pred_map;
  1914 
  1915         fun mk_map_transfer () =
  1916           let
  1917             val rels = map2 mk_rel_fun transfer_domRs transfer_ranRs;
  1918             val rel = mk_rel_fun
  1919               (Term.list_comb (mk_bnf_rel transfer_domRTs CA' CB1, transfer_domRs))
  1920               (Term.list_comb (mk_bnf_rel transfer_ranRTs CB' CB2, transfer_ranRs));
  1921             val concl = HOLogic.mk_Trueprop
  1922               (fold_rev mk_rel_fun rels rel $ bnf_map_AsBs $ mk_bnf_map B1Ts B2Ts);
  1923           in
  1924             Goal.prove_sorry lthy [] []
  1925               (fold_rev Logic.all (transfer_domRs @ transfer_ranRs) concl)
  1926               (fn {context = ctxt, prems = _} => mk_map_transfer_tac ctxt (Lazy.force rel_mono)
  1927                 (Lazy.force in_rel) (map Lazy.force set_map) (#map_cong0 axioms)
  1928                 (Lazy.force map_comp))
  1929             |> Thm.close_derivation
  1930           end;
  1931 
  1932         val map_transfer = Lazy.lazy mk_map_transfer;
  1933 
  1934         fun mk_pred_transfer () =
  1935           let
  1936             val iff = HOLogic.eq_const HOLogic.boolT;
  1937             val prem_rels = map (fn T => mk_rel_fun T iff) Rs;
  1938             val prem_elems = mk_rel_fun (Term.list_comb (rel, Rs)) iff;
  1939             val goal = HOLogic.mk_Trueprop
  1940               (fold_rev mk_rel_fun prem_rels prem_elems $ pred $ pred');
  1941             val vars = Variable.add_free_names lthy goal [];
  1942           in
  1943             Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} =>
  1944               mk_pred_transfer_tac ctxt live (Lazy.force in_rel) (Lazy.force pred_map)
  1945                 (Lazy.force pred_cong))
  1946             |> Thm.close_derivation
  1947           end;
  1948 
  1949         val pred_transfer = Lazy.lazy mk_pred_transfer;
  1950 
  1951         fun mk_rel_transfer () =
  1952           let
  1953             val iff = HOLogic.eq_const HOLogic.boolT;
  1954             val prem_rels =
  1955               map2 (fn T1 => fn T2 => mk_rel_fun T1 (mk_rel_fun T2 iff)) S_AsCs S_BsEs;
  1956             val prem_elems =
  1957               mk_rel_fun (Term.list_comb (mk_bnf_rel pred2RTsAsCs CA' CC', S_AsCs))
  1958                 (mk_rel_fun (Term.list_comb (mk_bnf_rel pred2RTsBsEs CB' CE', S_BsEs)) iff);
  1959             val goal =
  1960               HOLogic.mk_Trueprop (fold_rev mk_rel_fun prem_rels prem_elems $ rel $ relCsEs);
  1961             val vars = Variable.add_free_names lthy goal [];
  1962           in
  1963             Goal.prove_sorry lthy vars [] goal
  1964               (fn {context = ctxt, prems = _} =>
  1965                 mk_rel_transfer_tac ctxt (Lazy.force in_rel) (Lazy.force rel_map)
  1966                   (Lazy.force rel_mono_strong))
  1967             |> Thm.close_derivation
  1968           end;
  1969 
  1970         val rel_transfer = Lazy.lazy mk_rel_transfer;
  1971 
  1972         fun mk_set_transfer () =
  1973           let
  1974             val rel_sets = map2 (fn A => fn B => mk_rel 1 [A] [B] @{term rel_set}) As' Bs';
  1975             val rel_Rs = Term.list_comb (rel, Rs);
  1976             val goals = @{map 4} (fn R => fn rel_set => fn setA => fn setB => HOLogic.mk_Trueprop
  1977               (mk_rel_fun rel_Rs (rel_set $ R) $ setA $ setB)) Rs rel_sets bnf_sets_As bnf_sets_Bs;
  1978           in
  1979             if null goals then []
  1980             else
  1981               let
  1982                 val goal = Logic.mk_conjunction_balanced goals;
  1983                 val vars = Variable.add_free_names lthy goal [];
  1984               in
  1985                 Goal.prove_sorry lthy vars [] goal
  1986                   (fn {context = ctxt, prems = _} =>
  1987                      mk_set_transfer_tac ctxt (Lazy.force in_rel) (map Lazy.force set_map))
  1988                 |> Thm.close_derivation
  1989                 |> Conjunction.elim_balanced (length goals)
  1990               end
  1991           end;
  1992 
  1993         val set_transfer = Lazy.lazy mk_set_transfer;
  1994 
  1995         fun mk_inj_map_strong () =
  1996           let
  1997             val assms = @{map 5} (fn setA => fn z => fn f => fn z' => fn f' =>
  1998               fold_rev Logic.all [z, z']
  1999                 (Logic.mk_implies (mk_Trueprop_mem (z, setA $ x),
  2000                    Logic.mk_implies (mk_Trueprop_mem (z', setA $ x'),
  2001                      Logic.mk_implies (mk_Trueprop_eq (f $ z, f' $ z'),
  2002                        mk_Trueprop_eq (z, z')))))) bnf_sets_As zs fs zs' fs';
  2003             val concl = Logic.mk_implies
  2004               (mk_Trueprop_eq
  2005                  (Term.list_comb (bnf_map_AsBs, fs) $ x,
  2006                   Term.list_comb (bnf_map_AsBs, fs') $ x'),
  2007                mk_Trueprop_eq (x, x'));
  2008             val goal = fold_rev Logic.all (x :: x' :: fs @ fs')
  2009               (fold_rev (curry Logic.mk_implies) assms concl);
  2010           in
  2011             Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} =>
  2012               mk_inj_map_strong_tac ctxt (Lazy.force rel_eq) (Lazy.force rel_map)
  2013                 (Lazy.force rel_mono_strong))
  2014             |> Thm.close_derivation
  2015           end;
  2016 
  2017         val inj_map_strong = Lazy.lazy mk_inj_map_strong;
  2018 
  2019         val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def bnf_pred_def;
  2020 
  2021         val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong
  2022           in_mono in_rel inj_map inj_map_strong map_comp map_cong map_cong_simp map_cong_pred map_id
  2023           map_ident0 map_ident map_transfer rel_eq rel_flip set_map rel_cong0 rel_cong rel_cong_simp
  2024           rel_map rel_mono rel_mono_strong0 rel_mono_strong set_transfer rel_Grp rel_conversep
  2025           rel_OO rel_refl rel_refl_strong rel_reflp rel_symp rel_transp rel_transfer rel_eq_onp
  2026           pred_transfer pred_True pred_map pred_rel pred_mono_strong0 pred_mono_strong pred_mono
  2027           pred_cong0 pred_cong pred_cong_simp;
  2028 
  2029         val wits = map2 mk_witness bnf_wits wit_thms;
  2030 
  2031         val bnf_rel =
  2032           Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
  2033 
  2034         val bnf_pred = Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas)) pred;
  2035 
  2036         val bnf = mk_bnf bnf_b Calpha live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms
  2037           defs facts wits bnf_rel bnf_pred;
  2038       in
  2039         note_bnf_thms fact_policy qualify bnf_b bnf lthy
  2040       end;
  2041 
  2042     val one_step_defs =
  2043       no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @
  2044         [bnf_rel_def, bnf_pred_def]);
  2045   in
  2046     (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
  2047   end;
  2048 
  2049 structure BNF_Plugin = Plugin(type T = bnf);
  2050 
  2051 fun bnf_interpretation name f =
  2052   BNF_Plugin.interpretation name
  2053     (fn bnf => fn lthy => f (transfer_bnf (Proof_Context.theory_of lthy) bnf) lthy);
  2054 
  2055 val interpret_bnf = BNF_Plugin.data;
  2056 
  2057 fun register_bnf_raw key bnf =
  2058   Local_Theory.declaration {syntax = false, pervasive = true}
  2059     (fn phi => Data.map (Symtab.update (key, morph_bnf phi bnf)));
  2060 
  2061 fun register_bnf plugins key bnf =
  2062   register_bnf_raw key bnf #> interpret_bnf plugins bnf;
  2063 
  2064 fun bnf_def const_policy fact_policy internal qualify tacs wit_tac Ds map_b rel_b pred_b set_bs
  2065     raw_csts =
  2066   (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
  2067   let
  2068     fun mk_wits_tac ctxt set_maps =
  2069       TRYALL Goal.conjunction_tac THEN
  2070       (case triv_tac_opt of
  2071         SOME tac => tac ctxt set_maps
  2072       | NONE => unfold_thms_tac ctxt one_step_defs THEN wit_tac ctxt);
  2073     val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  2074     fun mk_wit_thms set_maps =
  2075       Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
  2076         (fn {context = ctxt, prems = _} => mk_wits_tac ctxt set_maps)
  2077         |> Thm.close_derivation
  2078         |> Conjunction.elim_balanced (length wit_goals)
  2079         |> map2 (Conjunction.elim_balanced o length) wit_goalss
  2080         |> (map o map) (Thm.forall_elim_vars 0);
  2081   in
  2082     map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
  2083       goals (map (fn tac => fn {context = ctxt, prems = _} =>
  2084         unfold_thms_tac ctxt one_step_defs THEN tac ctxt) tacs)
  2085     |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
  2086   end) o prepare_def const_policy fact_policy internal qualify (K I) (K I) Ds map_b rel_b pred_b
  2087     set_bs raw_csts;
  2088 
  2089 fun bnf_cmd (raw_csts, raw_plugins) =
  2090   (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
  2091   let
  2092     val plugins = raw_plugins lthy;
  2093     val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  2094     fun mk_triv_wit_thms tac set_maps =
  2095       Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
  2096         (fn {context = ctxt, prems = _} => TRYALL Goal.conjunction_tac THEN tac ctxt set_maps)
  2097         |> Thm.close_derivation
  2098         |> Conjunction.elim_balanced (length wit_goals)
  2099         |> map2 (Conjunction.elim_balanced o length) wit_goalss
  2100         |> (map o map) (Thm.forall_elim_vars 0);
  2101     val (mk_wit_thms, nontriv_wit_goals) =
  2102       (case triv_tac_opt of
  2103         NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
  2104       | SOME tac => (mk_triv_wit_thms tac, []));
  2105   in
  2106     lthy
  2107     |> Proof.theorem NONE (uncurry (register_bnf plugins key) oo after_qed mk_wit_thms)
  2108       (map (single o rpair []) goals @ nontriv_wit_goals)
  2109     |> Proof.unfolding ([[(@{thm OO_Grp_alt} :: @{thm mem_Collect_eq} :: defs, [])]])
  2110     |> Proof.refine_singleton (Method.Basic (fn ctxt =>
  2111       Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl))))
  2112   end) o prepare_def Do_Inline (user_policy Note_Some) false I Syntax.read_typ Syntax.read_term
  2113     NONE Binding.empty Binding.empty Binding.empty [] raw_csts;
  2114 
  2115 fun print_bnfs ctxt =
  2116   let
  2117     fun pretty_set sets i = Pretty.block
  2118       [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
  2119         Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
  2120 
  2121     fun pretty_bnf (key, BNF {T, map, sets, bd, live, lives, dead, deads, ...}) =
  2122       Pretty.big_list
  2123         (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
  2124           Pretty.quote (Syntax.pretty_typ ctxt T)]))
  2125         ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
  2126             Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
  2127           Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
  2128             Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
  2129           Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
  2130             Pretty.quote (Syntax.pretty_term ctxt map)]] @
  2131           List.map (pretty_set sets) (0 upto length sets - 1) @
  2132           [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
  2133             Pretty.quote (Syntax.pretty_term ctxt bd)]]);
  2134   in
  2135     Pretty.big_list "Registered bounded natural functors:"
  2136       (map pretty_bnf (sort_by fst (Symtab.dest (Data.get (Context.Proof ctxt)))))
  2137     |> Pretty.writeln
  2138   end;
  2139 
  2140 val _ =
  2141   Outer_Syntax.command @{command_keyword print_bnfs}
  2142     "print all bounded natural functors"
  2143     (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
  2144 
  2145 val _ =
  2146   Outer_Syntax.local_theory_to_proof @{command_keyword bnf}
  2147     "register a type as a bounded natural functor"
  2148     (parse_opt_binding_colon -- Parse.typ --|
  2149        (Parse.reserved "map" -- @{keyword ":"}) -- Parse.term --
  2150        Scan.optional ((Parse.reserved "sets" -- @{keyword ":"}) |--
  2151          Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) [] --|
  2152        (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term --
  2153        Scan.optional ((Parse.reserved "wits" -- @{keyword ":"}) |--
  2154          Scan.repeat1 (Scan.unless (Parse.reserved "rel" ||
  2155            Parse.reserved "plugins") Parse.term)) [] --
  2156        Scan.option ((Parse.reserved "rel" -- @{keyword ":"}) |-- Parse.term) --
  2157        Scan.option ((Parse.reserved "pred" -- @{keyword ":"}) |-- Parse.term) --
  2158        Scan.optional Plugin_Name.parse_filter (K Plugin_Name.default_filter)
  2159        >> bnf_cmd);
  2160 
  2161 end;