src/HOL/Tools/BNF/bnf_def.ML
author wenzelm
Fri Mar 06 15:58:56 2015 +0100 (2015-03-06)
changeset 59621 291934bac95e
parent 59580 cbc38731d42f
child 59663 fb544855e3b1
permissions -rw-r--r--
Thm.cterm_of and Thm.ctyp_of operate on local context;
     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 transfer_bnf: theory -> bnf -> bnf
    18   val bnf_of: Proof.context -> string -> bnf option
    19   val bnf_of_global: theory -> string -> bnf option
    20   val bnf_interpretation: string -> (bnf -> local_theory -> local_theory) -> theory -> theory
    21   val interpret_bnf: (string -> bool) -> bnf -> local_theory -> local_theory
    22   val register_bnf_raw: string -> bnf -> local_theory -> local_theory
    23   val register_bnf: (string -> bool) -> string -> bnf -> local_theory -> local_theory
    24 
    25   val name_of_bnf: bnf -> binding
    26   val T_of_bnf: bnf -> typ
    27   val live_of_bnf: bnf -> int
    28   val lives_of_bnf: bnf -> typ list
    29   val dead_of_bnf: bnf -> int
    30   val deads_of_bnf: bnf -> typ list
    31   val bd_of_bnf: bnf -> term
    32   val nwits_of_bnf: bnf -> int
    33 
    34   val mapN: string
    35   val relN: string
    36   val setN: string
    37   val mk_setN: int -> string
    38   val mk_witN: int -> string
    39 
    40   val map_of_bnf: bnf -> term
    41   val sets_of_bnf: bnf -> term list
    42   val rel_of_bnf: bnf -> term
    43 
    44   val mk_T_of_bnf: typ list -> typ list -> bnf -> typ
    45   val mk_bd_of_bnf: typ list -> typ list -> bnf -> term
    46   val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    47   val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    48   val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list
    49   val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list
    50 
    51   val bd_Card_order_of_bnf: bnf -> thm
    52   val bd_Cinfinite_of_bnf: bnf -> thm
    53   val bd_Cnotzero_of_bnf: bnf -> thm
    54   val bd_card_order_of_bnf: bnf -> thm
    55   val bd_cinfinite_of_bnf: bnf -> thm
    56   val collect_set_map_of_bnf: bnf -> thm
    57   val in_bd_of_bnf: bnf -> thm
    58   val in_cong_of_bnf: bnf -> thm
    59   val in_mono_of_bnf: bnf -> thm
    60   val in_rel_of_bnf: bnf -> thm
    61   val inj_map_of_bnf: bnf -> thm
    62   val inj_map_strong_of_bnf: bnf -> thm
    63   val map_comp0_of_bnf: bnf -> thm
    64   val map_comp_of_bnf: bnf -> thm
    65   val map_cong0_of_bnf: bnf -> thm
    66   val map_cong_of_bnf: bnf -> thm
    67   val map_cong_simp_of_bnf: bnf -> thm
    68   val map_def_of_bnf: bnf -> thm
    69   val map_id0_of_bnf: bnf -> thm
    70   val map_id_of_bnf: bnf -> thm
    71   val map_ident0_of_bnf: bnf -> thm
    72   val map_ident_of_bnf: bnf -> thm
    73   val map_transfer_of_bnf: bnf -> thm
    74   val le_rel_OO_of_bnf: bnf -> thm
    75   val rel_def_of_bnf: bnf -> thm
    76   val rel_Grp_of_bnf: bnf -> thm
    77   val rel_OO_of_bnf: bnf -> thm
    78   val rel_OO_Grp_of_bnf: bnf -> thm
    79   val rel_cong_of_bnf: bnf -> thm
    80   val rel_conversep_of_bnf: bnf -> thm
    81   val rel_mono_of_bnf: bnf -> thm
    82   val rel_mono_strong0_of_bnf: bnf -> thm
    83   val rel_mono_strong_of_bnf: bnf -> thm
    84   val rel_transfer_of_bnf: bnf -> thm
    85   val rel_eq_of_bnf: bnf -> thm
    86   val rel_flip_of_bnf: bnf -> thm
    87   val set_bd_of_bnf: bnf -> thm list
    88   val set_defs_of_bnf: bnf -> thm list
    89   val set_map0_of_bnf: bnf -> thm list
    90   val set_map_of_bnf: bnf -> thm list
    91   val set_transfer_of_bnf: bnf -> thm list
    92   val wit_thms_of_bnf: bnf -> thm list
    93   val wit_thmss_of_bnf: bnf -> thm list list
    94 
    95   val mk_map: int -> typ list -> typ list -> term -> term
    96   val mk_rel: int -> typ list -> typ list -> term -> term
    97   val build_map: Proof.context -> typ list -> (typ * typ -> term) -> typ * typ -> term
    98   val build_rel: (string * (int * term)) list -> Proof.context -> typ list -> (typ * typ -> term) ->
    99     typ * typ -> term
   100   val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
   101   val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
   102     'a list
   103 
   104   val mk_witness: int list * term -> thm list -> nonemptiness_witness
   105   val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
   106   val wits_of_bnf: bnf -> nonemptiness_witness list
   107 
   108   val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
   109 
   110   datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
   111   datatype fact_policy = Dont_Note | Note_Some | Note_All
   112 
   113   val bnf_note_all: bool Config.T
   114   val bnf_timing: bool Config.T
   115   val user_policy: fact_policy -> Proof.context -> fact_policy
   116   val note_bnf_thms: fact_policy -> (binding -> binding) -> binding -> bnf -> Proof.context ->
   117     bnf * Proof.context
   118 
   119   val print_bnfs: Proof.context -> unit
   120   val prepare_def: inline_policy -> (Proof.context -> fact_policy) -> bool ->
   121     (binding -> binding) -> (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) ->
   122     typ list option -> binding -> binding -> binding list ->
   123     (((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option -> Proof.context ->
   124     string * term list * ((Proof.context -> thm list -> tactic) option * term list list) *
   125     ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
   126     local_theory * thm list
   127   val define_bnf_consts: inline_policy -> fact_policy -> bool -> typ list option ->
   128     binding -> binding -> binding list ->
   129     (((((binding * typ) * term) * term list) * term) * term list) * term option -> local_theory ->
   130       ((typ list * typ list * typ list * typ) *
   131        (term * term list * term * (int list * term) list * term) *
   132        (thm * thm list * thm * thm list * thm) *
   133        ((typ list -> typ list -> typ list -> term) *
   134         (typ list -> typ list -> term -> term) *
   135         (typ list -> typ list -> typ -> typ) *
   136         (typ list -> typ list -> typ list -> term) *
   137         (typ list -> typ list -> typ list -> term))) * local_theory
   138 
   139   val bnf_def: inline_policy -> (Proof.context -> fact_policy) -> bool -> (binding -> binding) ->
   140     (Proof.context -> tactic) list -> (Proof.context -> tactic) -> typ list option -> binding ->
   141     binding -> binding list ->
   142     (((((binding * typ) * term) * term list) * term) * term list) * term option -> local_theory ->
   143     bnf * local_theory
   144 end;
   145 
   146 structure BNF_Def : BNF_DEF =
   147 struct
   148 
   149 open BNF_Util
   150 open BNF_Tactics
   151 open BNF_Def_Tactics
   152 
   153 val fundefcong_attrs = @{attributes [fundef_cong]};
   154 val mono_attrs = @{attributes [mono]};
   155 
   156 type axioms = {
   157   map_id0: thm,
   158   map_comp0: thm,
   159   map_cong0: thm,
   160   set_map0: thm list,
   161   bd_card_order: thm,
   162   bd_cinfinite: thm,
   163   set_bd: thm list,
   164   le_rel_OO: thm,
   165   rel_OO_Grp: thm
   166 };
   167 
   168 fun mk_axioms' ((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel) =
   169   {map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o,
   170    bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel};
   171 
   172 fun dest_cons [] = raise List.Empty
   173   | dest_cons (x :: xs) = (x, xs);
   174 
   175 fun mk_axioms n thms = thms
   176   |> map the_single
   177   |> dest_cons
   178   ||>> dest_cons
   179   ||>> dest_cons
   180   ||>> chop n
   181   ||>> dest_cons
   182   ||>> dest_cons
   183   ||>> chop n
   184   ||>> dest_cons
   185   ||> the_single
   186   |> mk_axioms';
   187 
   188 fun zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel =
   189   [mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel];
   190 
   191 fun dest_axioms {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
   192   le_rel_OO, rel_OO_Grp} =
   193   zip_axioms map_id0 map_comp0 map_cong0 set_map0 bd_card_order bd_cinfinite set_bd le_rel_OO
   194     rel_OO_Grp;
   195 
   196 fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
   197   le_rel_OO, rel_OO_Grp} =
   198   {map_id0 = f map_id0,
   199     map_comp0 = f map_comp0,
   200     map_cong0 = f map_cong0,
   201     set_map0 = map f set_map0,
   202     bd_card_order = f bd_card_order,
   203     bd_cinfinite = f bd_cinfinite,
   204     set_bd = map f set_bd,
   205     le_rel_OO = f le_rel_OO,
   206     rel_OO_Grp = f rel_OO_Grp};
   207 
   208 val morph_axioms = map_axioms o Morphism.thm;
   209 
   210 type defs = {
   211   map_def: thm,
   212   set_defs: thm list,
   213   rel_def: thm
   214 }
   215 
   216 fun mk_defs map sets rel = {map_def = map, set_defs = sets, rel_def = rel};
   217 
   218 fun map_defs f {map_def, set_defs, rel_def} =
   219   {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def};
   220 
   221 val morph_defs = map_defs o Morphism.thm;
   222 
   223 type facts = {
   224   bd_Card_order: thm,
   225   bd_Cinfinite: thm,
   226   bd_Cnotzero: thm,
   227   collect_set_map: thm lazy,
   228   in_bd: thm lazy,
   229   in_cong: thm lazy,
   230   in_mono: thm lazy,
   231   in_rel: thm lazy,
   232   inj_map: thm lazy,
   233   inj_map_strong: thm lazy,
   234   map_comp: thm lazy,
   235   map_cong: thm lazy,
   236   map_cong_simp: thm lazy,
   237   map_id: thm lazy,
   238   map_ident0: thm lazy,
   239   map_ident: thm lazy,
   240   map_transfer: thm lazy,
   241   rel_eq: thm lazy,
   242   rel_flip: thm lazy,
   243   set_map: thm lazy list,
   244   rel_cong: thm lazy,
   245   rel_map: thm list lazy,
   246   rel_mono: thm lazy,
   247   rel_mono_strong0: thm lazy,
   248   rel_mono_strong: thm lazy,
   249   set_transfer: thm list lazy,
   250   rel_Grp: thm lazy,
   251   rel_conversep: thm lazy,
   252   rel_OO: thm lazy,
   253   rel_transfer: thm lazy
   254 };
   255 
   256 fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel
   257     inj_map inj_map_strong map_comp map_cong map_cong_simp map_id map_ident0 map_ident
   258     map_transfer rel_eq rel_flip set_map rel_cong rel_map rel_mono rel_mono_strong0 rel_mono_strong
   259     rel_transfer rel_Grp rel_conversep rel_OO set_transfer = {
   260   bd_Card_order = bd_Card_order,
   261   bd_Cinfinite = bd_Cinfinite,
   262   bd_Cnotzero = bd_Cnotzero,
   263   collect_set_map = collect_set_map,
   264   in_bd = in_bd,
   265   in_cong = in_cong,
   266   in_mono = in_mono,
   267   in_rel = in_rel,
   268   inj_map = inj_map,
   269   inj_map_strong = inj_map_strong,
   270   map_comp = map_comp,
   271   map_cong = map_cong,
   272   map_cong_simp = map_cong_simp,
   273   map_id = map_id,
   274   map_ident0 = map_ident0,
   275   map_ident = map_ident,
   276   map_transfer = map_transfer,
   277   rel_eq = rel_eq,
   278   rel_flip = rel_flip,
   279   set_map = set_map,
   280   rel_cong = rel_cong,
   281   rel_map = rel_map,
   282   rel_mono = rel_mono,
   283   rel_mono_strong0 = rel_mono_strong0,
   284   rel_mono_strong = rel_mono_strong,
   285   rel_transfer = rel_transfer,
   286   rel_Grp = rel_Grp,
   287   rel_conversep = rel_conversep,
   288   rel_OO = rel_OO,
   289   set_transfer = set_transfer};
   290 
   291 fun map_facts f {
   292   bd_Card_order,
   293   bd_Cinfinite,
   294   bd_Cnotzero,
   295   collect_set_map,
   296   in_bd,
   297   in_cong,
   298   in_mono,
   299   in_rel,
   300   inj_map,
   301   inj_map_strong,
   302   map_comp,
   303   map_cong,
   304   map_cong_simp,
   305   map_id,
   306   map_ident0,
   307   map_ident,
   308   map_transfer,
   309   rel_eq,
   310   rel_flip,
   311   set_map,
   312   rel_cong,
   313   rel_map,
   314   rel_mono,
   315   rel_mono_strong0,
   316   rel_mono_strong,
   317   rel_transfer,
   318   rel_Grp,
   319   rel_conversep,
   320   rel_OO,
   321   set_transfer} =
   322   {bd_Card_order = f bd_Card_order,
   323     bd_Cinfinite = f bd_Cinfinite,
   324     bd_Cnotzero = f bd_Cnotzero,
   325     collect_set_map = Lazy.map f collect_set_map,
   326     in_bd = Lazy.map f in_bd,
   327     in_cong = Lazy.map f in_cong,
   328     in_mono = Lazy.map f in_mono,
   329     in_rel = Lazy.map f in_rel,
   330     inj_map = Lazy.map f inj_map,
   331     inj_map_strong = Lazy.map f inj_map_strong,
   332     map_comp = Lazy.map f map_comp,
   333     map_cong = Lazy.map f map_cong,
   334     map_cong_simp = Lazy.map f map_cong_simp,
   335     map_id = Lazy.map f map_id,
   336     map_ident0 = Lazy.map f map_ident0,
   337     map_ident = Lazy.map f map_ident,
   338     map_transfer = Lazy.map f map_transfer,
   339     rel_eq = Lazy.map f rel_eq,
   340     rel_flip = Lazy.map f rel_flip,
   341     set_map = map (Lazy.map f) set_map,
   342     rel_cong = Lazy.map f rel_cong,
   343     rel_map = Lazy.map (map f) rel_map,
   344     rel_mono = Lazy.map f rel_mono,
   345     rel_mono_strong0 = Lazy.map f rel_mono_strong0,
   346     rel_mono_strong = Lazy.map f rel_mono_strong,
   347     rel_transfer = Lazy.map f rel_transfer,
   348     rel_Grp = Lazy.map f rel_Grp,
   349     rel_conversep = Lazy.map f rel_conversep,
   350     rel_OO = Lazy.map f rel_OO,
   351     set_transfer = Lazy.map (map f) set_transfer};
   352 
   353 val morph_facts = map_facts o Morphism.thm;
   354 
   355 type nonemptiness_witness = {
   356   I: int list,
   357   wit: term,
   358   prop: thm list
   359 };
   360 
   361 fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
   362 fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
   363 fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
   364 
   365 datatype bnf = BNF of {
   366   name: binding,
   367   T: typ,
   368   live: int,
   369   lives: typ list, (*source type variables of map*)
   370   lives': typ list, (*target type variables of map*)
   371   dead: int,
   372   deads: typ list,
   373   map: term,
   374   sets: term list,
   375   bd: term,
   376   axioms: axioms,
   377   defs: defs,
   378   facts: facts,
   379   nwits: int,
   380   wits: nonemptiness_witness list,
   381   rel: term
   382 };
   383 
   384 (* getters *)
   385 
   386 fun rep_bnf (BNF bnf) = bnf;
   387 val name_of_bnf = #name o rep_bnf;
   388 val T_of_bnf = #T o rep_bnf;
   389 fun mk_T_of_bnf Ds Ts bnf =
   390   let val bnf_rep = rep_bnf bnf
   391   in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
   392 val live_of_bnf = #live o rep_bnf;
   393 val lives_of_bnf = #lives o rep_bnf;
   394 val dead_of_bnf = #dead o rep_bnf;
   395 val deads_of_bnf = #deads o rep_bnf;
   396 val axioms_of_bnf = #axioms o rep_bnf;
   397 val facts_of_bnf = #facts o rep_bnf;
   398 val nwits_of_bnf = #nwits o rep_bnf;
   399 val wits_of_bnf = #wits o rep_bnf;
   400 
   401 fun flatten_type_args_of_bnf bnf dead_x xs =
   402   let
   403     val Type (_, Ts) = T_of_bnf bnf;
   404     val lives = lives_of_bnf bnf;
   405     val deads = deads_of_bnf bnf;
   406   in
   407     permute_like_unique (op =) (deads @ lives) Ts (replicate (length deads) dead_x @ xs)
   408   end;
   409 
   410 (*terms*)
   411 val map_of_bnf = #map o rep_bnf;
   412 val sets_of_bnf = #sets o rep_bnf;
   413 fun mk_map_of_bnf Ds Ts Us bnf =
   414   let val bnf_rep = rep_bnf bnf;
   415   in
   416     Term.subst_atomic_types
   417       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
   418   end;
   419 fun mk_sets_of_bnf Dss Tss bnf =
   420   let val bnf_rep = rep_bnf bnf;
   421   in
   422     map2 (fn (Ds, Ts) => Term.subst_atomic_types
   423       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
   424   end;
   425 val bd_of_bnf = #bd o rep_bnf;
   426 fun mk_bd_of_bnf Ds Ts bnf =
   427   let val bnf_rep = rep_bnf bnf;
   428   in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
   429 fun mk_wits_of_bnf Dss Tss bnf =
   430   let
   431     val bnf_rep = rep_bnf bnf;
   432     val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
   433   in
   434     map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
   435       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
   436   end;
   437 val rel_of_bnf = #rel o rep_bnf;
   438 fun mk_rel_of_bnf Ds Ts Us bnf =
   439   let val bnf_rep = rep_bnf bnf;
   440   in
   441     Term.subst_atomic_types
   442       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
   443   end;
   444 
   445 (*thms*)
   446 val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
   447 val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
   448 val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
   449 val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
   450 val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
   451 val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf;
   452 val in_bd_of_bnf = Lazy.force o #in_bd o #facts o rep_bnf;
   453 val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
   454 val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
   455 val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
   456 val inj_map_of_bnf = Lazy.force o #inj_map o #facts o rep_bnf;
   457 val inj_map_strong_of_bnf = Lazy.force o #inj_map_strong o #facts o rep_bnf;
   458 val map_def_of_bnf = #map_def o #defs o rep_bnf;
   459 val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf;
   460 val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf;
   461 val map_ident0_of_bnf = Lazy.force o #map_ident0 o #facts o rep_bnf;
   462 val map_ident_of_bnf = Lazy.force o #map_ident o #facts o rep_bnf;
   463 val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf;
   464 val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf;
   465 val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
   466 val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
   467 val map_cong_simp_of_bnf = Lazy.force o #map_cong_simp o #facts o rep_bnf;
   468 val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf;
   469 val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf;
   470 val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
   471 val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf;
   472 val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf;
   473 val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
   474 val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
   475 val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf;
   476 val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf;
   477 val set_transfer_of_bnf = Lazy.force o #set_transfer o #facts o rep_bnf;
   478 val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
   479 val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
   480 val rel_mono_strong0_of_bnf = Lazy.force o #rel_mono_strong0 o #facts o rep_bnf;
   481 val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf;
   482 val rel_transfer_of_bnf = Lazy.force o #rel_transfer o #facts o rep_bnf;
   483 val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf;
   484 val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf;
   485 val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf;
   486 val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf;
   487 val wit_thms_of_bnf = maps #prop o wits_of_bnf;
   488 val wit_thmss_of_bnf = map #prop o wits_of_bnf;
   489 
   490 fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel =
   491   BNF {name = name, T = T,
   492        live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
   493        map = map, sets = sets, bd = bd,
   494        axioms = axioms, defs = defs, facts = facts,
   495        nwits = length wits, wits = wits, rel = rel};
   496 
   497 fun map_bnf f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16
   498   (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
   499   dead = dead, deads = deads, map = map, sets = sets, bd = bd,
   500   axioms = axioms, defs = defs, facts = facts,
   501   nwits = nwits, wits = wits, rel = rel}) =
   502   BNF {name = f1 name, T = f2 T,
   503        live = f3 live, lives = f4 lives, lives' = f5 lives', dead = f6 dead, deads = f7 deads,
   504        map = f8 map, sets = f9 sets, bd = f10 bd,
   505        axioms = f11 axioms, defs = f12 defs, facts = f13 facts,
   506        nwits = f14 nwits, wits = f15 wits, rel = f16 rel};
   507 
   508 fun morph_bnf phi =
   509   let
   510     val Tphi = Morphism.typ phi;
   511     val tphi = Morphism.term phi;
   512   in
   513     map_bnf (Morphism.binding phi) Tphi I (map Tphi) (map Tphi) I (map Tphi) tphi (map tphi) tphi
   514       (morph_axioms phi) (morph_defs phi) (morph_facts phi) I (map (morph_witness phi)) tphi
   515   end;
   516 
   517 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;
   518 
   519 val transfer_bnf = morph_bnf o Morphism.transfer_morphism;
   520 
   521 structure Data = Generic_Data
   522 (
   523   type T = bnf Symtab.table;
   524   val empty = Symtab.empty;
   525   val extend = I;
   526   fun merge data : T = Symtab.merge (K true) data;
   527 );
   528 
   529 fun bnf_of_generic context =
   530   Option.map (transfer_bnf (Context.theory_of context)) o Symtab.lookup (Data.get context);
   531 
   532 val bnf_of = bnf_of_generic o Context.Proof;
   533 val bnf_of_global = bnf_of_generic o Context.Theory;
   534 
   535 
   536 (* Utilities *)
   537 
   538 fun normalize_set insts instA set =
   539   let
   540     val (T, T') = dest_funT (fastype_of set);
   541     val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
   542     val params = Term.add_tvar_namesT T [];
   543   in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
   544 
   545 fun normalize_rel ctxt instTs instA instB rel =
   546   let
   547     val thy = Proof_Context.theory_of ctxt;
   548     val tyenv =
   549       Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB))
   550         Vartab.empty;
   551   in Envir.subst_term (tyenv, Vartab.empty) rel end
   552   handle Type.TYPE_MATCH => error "Bad relator";
   553 
   554 fun normalize_wit insts CA As wit =
   555   let
   556     fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
   557         if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
   558       | strip_param x = x;
   559     val (Ts, T) = strip_param ([], fastype_of wit);
   560     val subst = Term.add_tvar_namesT T [] ~~ insts;
   561     fun find y = find_index (fn x => x = y) As;
   562   in
   563     (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
   564   end;
   565 
   566 fun minimize_wits wits =
   567  let
   568    fun minimize done [] = done
   569      | minimize done ((I, wit) :: todo) =
   570        if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
   571        then minimize done todo
   572        else minimize ((I, wit) :: done) todo;
   573  in minimize [] wits end;
   574 
   575 fun mk_map live Ts Us t =
   576   let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   577     Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   578   end;
   579 
   580 fun mk_rel live Ts Us t =
   581   let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
   582     Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   583   end;
   584 
   585 fun build_map_or_rel mk const of_bnf dest pre_cst_table ctxt simple_Ts build_simple =
   586   let
   587     fun build (TU as (T, U)) =
   588       if exists (curry (op =) T) simple_Ts then
   589         build_simple TU
   590       else if T = U andalso not (exists_subtype_in simple_Ts T) then
   591         const T
   592       else
   593         (case TU of
   594           (Type (s, Ts), Type (s', Us)) =>
   595           if s = s' then
   596             let
   597               val (live, cst0) =
   598                 (case AList.lookup (op =) pre_cst_table s of
   599                   NONE => let val bnf = the (bnf_of ctxt s) in (live_of_bnf bnf, of_bnf bnf) end
   600                 | SOME p => p);
   601               val cst = mk live Ts Us cst0;
   602               val TUs' = map dest (fst (strip_typeN live (fastype_of cst)));
   603             in Term.list_comb (cst, map build TUs') end
   604           else
   605             build_simple TU
   606         | _ => build_simple TU);
   607   in build end;
   608 
   609 val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT [];
   610 val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T o append
   611   [(@{type_name set}, (1, @{term rel_set})), (@{type_name fun}, (2, @{term rel_fun}))];
   612 
   613 fun map_flattened_map_args ctxt s map_args fs =
   614   let
   615     val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
   616     val flat_fs' = map_args flat_fs;
   617   in
   618     permute_like_unique (op aconv) flat_fs fs flat_fs'
   619   end;
   620 
   621 
   622 (* Names *)
   623 
   624 val mapN = "map";
   625 val setN = "set";
   626 fun mk_setN i = setN ^ nonzero_string_of_int i;
   627 val bdN = "bd";
   628 val witN = "wit";
   629 fun mk_witN i = witN ^ nonzero_string_of_int i;
   630 val relN = "rel";
   631 
   632 val bd_card_orderN = "bd_card_order";
   633 val bd_cinfiniteN = "bd_cinfinite";
   634 val bd_Card_orderN = "bd_Card_order";
   635 val bd_CinfiniteN = "bd_Cinfinite";
   636 val bd_CnotzeroN = "bd_Cnotzero";
   637 val collect_set_mapN = "collect_set_map";
   638 val in_bdN = "in_bd";
   639 val in_monoN = "in_mono";
   640 val in_relN = "in_rel";
   641 val inj_mapN = "inj_map";
   642 val inj_map_strongN = "inj_map_strong";
   643 val map_id0N = "map_id0";
   644 val map_idN = "map_id";
   645 val map_identN = "map_ident";
   646 val map_comp0N = "map_comp0";
   647 val map_compN = "map_comp";
   648 val map_cong0N = "map_cong0";
   649 val map_congN = "map_cong";
   650 val map_cong_simpN = "map_cong_simp";
   651 val map_transferN = "map_transfer";
   652 val rel_eqN = "rel_eq";
   653 val rel_flipN = "rel_flip";
   654 val set_map0N = "set_map0";
   655 val set_mapN = "set_map";
   656 val set_bdN = "set_bd";
   657 val set_transferN = "set_transfer"
   658 val rel_GrpN = "rel_Grp";
   659 val rel_conversepN = "rel_conversep";
   660 val rel_mapN = "rel_map"
   661 val rel_monoN = "rel_mono"
   662 val rel_mono_strong0N = "rel_mono_strong0"
   663 val rel_mono_strongN = "rel_mono_strong"
   664 val rel_transferN = "rel_transfer"
   665 val rel_comppN = "rel_compp";
   666 val rel_compp_GrpN = "rel_compp_Grp";
   667 
   668 datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
   669 
   670 datatype fact_policy = Dont_Note | Note_Some | Note_All;
   671 
   672 val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
   673 val bnf_timing = Attrib.setup_config_bool @{binding bnf_timing} (K false);
   674 
   675 fun user_policy policy ctxt = if Config.get ctxt bnf_note_all then Note_All else policy;
   676 
   677 val smart_max_inline_term_size = 25; (*FUDGE*)
   678 
   679 fun note_bnf_thms fact_policy qualify0 bnf_b bnf lthy =
   680   let
   681     val axioms = axioms_of_bnf bnf;
   682     val facts = facts_of_bnf bnf;
   683     val wits = wits_of_bnf bnf;
   684     val qualify =
   685       let val (_, qs, _) = Binding.dest bnf_b;
   686       in fold_rev (fn (s, mand) => Binding.qualify mand s) qs #> qualify0 end;
   687 
   688     fun note_if_note_all (noted0, lthy0) =
   689       let
   690         val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
   691         val notes =
   692           [(bd_card_orderN, [#bd_card_order axioms]),
   693            (bd_cinfiniteN, [#bd_cinfinite axioms]),
   694            (bd_Card_orderN, [#bd_Card_order facts]),
   695            (bd_CinfiniteN, [#bd_Cinfinite facts]),
   696            (bd_CnotzeroN, [#bd_Cnotzero facts]),
   697            (collect_set_mapN, [Lazy.force (#collect_set_map facts)]),
   698            (in_bdN, [Lazy.force (#in_bd facts)]),
   699            (in_monoN, [Lazy.force (#in_mono facts)]),
   700            (map_comp0N, [#map_comp0 axioms]),
   701            (rel_mono_strong0N, [Lazy.force (#rel_mono_strong0 facts)]),
   702            (set_map0N, #set_map0 axioms),
   703            (set_bdN, #set_bd axioms)] @
   704           (witNs ~~ wit_thmss_of_bnf bnf)
   705           |> map (fn (thmN, thms) =>
   706             ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), []),
   707              [(thms, [])]));
   708       in
   709         Local_Theory.notes notes lthy0 |>> append noted0
   710       end;
   711 
   712     fun note_unless_dont_note (noted0, lthy0) =
   713       let
   714         val notes =
   715           [(in_relN, [Lazy.force (#in_rel facts)], []),
   716            (inj_mapN, [Lazy.force (#inj_map facts)], []),
   717            (inj_map_strongN, [Lazy.force (#inj_map_strong facts)], []),
   718            (map_compN, [Lazy.force (#map_comp facts)], []),
   719            (map_cong0N, [#map_cong0 axioms], []),
   720            (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
   721            (map_cong_simpN, [Lazy.force (#map_cong_simp facts)], []),
   722            (map_idN, [Lazy.force (#map_id facts)], []),
   723            (map_id0N, [#map_id0 axioms], []),
   724            (map_transferN, [Lazy.force (#map_transfer facts)], []),
   725            (map_identN, [Lazy.force (#map_ident facts)], []),
   726            (rel_comppN, [Lazy.force (#rel_OO facts)], []),
   727            (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
   728            (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
   729            (rel_eqN, [Lazy.force (#rel_eq facts)], []),
   730            (rel_flipN, [Lazy.force (#rel_flip facts)], []),
   731            (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
   732            (rel_mapN, Lazy.force (#rel_map facts), []),
   733            (rel_monoN, [Lazy.force (#rel_mono facts)], mono_attrs),
   734            (rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)], []),
   735            (rel_transferN, [Lazy.force (#rel_transfer facts)], []),
   736            (set_mapN, map Lazy.force (#set_map facts), []),
   737            (set_transferN, Lazy.force (#set_transfer facts), [])]
   738           |> filter_out (null o #2)
   739           |> map (fn (thmN, thms, attrs) =>
   740             ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), attrs),
   741              [(thms, [])]));
   742       in
   743         Local_Theory.notes notes lthy0 |>> append noted0
   744       end;
   745   in
   746     ([], lthy)
   747     |> fact_policy = Note_All ? note_if_note_all
   748     |> fact_policy <> Dont_Note ? note_unless_dont_note
   749     |>> (fn [] => bnf | noted => morph_bnf (substitute_noted_thm noted) bnf)
   750   end;
   751 
   752 
   753 (* Define new BNFs *)
   754 
   755 fun define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b set_bs
   756   ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy =
   757   let
   758     val live = length set_rhss;
   759 
   760     val def_qualify = Binding.conceal o Binding.qualify false (Binding.name_of bnf_b);
   761 
   762     fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b;
   763 
   764     fun maybe_define user_specified (b, rhs) lthy =
   765       let
   766         val inline =
   767           (user_specified orelse fact_policy = Dont_Note) andalso
   768           (case const_policy of
   769             Dont_Inline => false
   770           | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
   771           | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_term_size
   772           | Do_Inline => true)
   773       in
   774         if inline then
   775           ((rhs, Drule.reflexive_thm), lthy)
   776         else
   777           let val b = b () in
   778             apfst (apsnd snd)
   779               ((if internal then Local_Theory.define_internal else Local_Theory.define)
   780                 ((b, NoSyn), ((Thm.def_binding b, []), rhs)) lthy)
   781           end
   782       end;
   783 
   784     fun maybe_restore lthy_old lthy =
   785       lthy |> not (Theory.eq_thy (apply2 Proof_Context.theory_of (lthy_old, lthy)))
   786         ? Local_Theory.restore;
   787 
   788     val map_bind_def =
   789       (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b),
   790          map_rhs);
   791     val set_binds_defs =
   792       let
   793         fun set_name i get_b =
   794           (case try (nth set_bs) (i - 1) of
   795             SOME b => if Binding.is_empty b then get_b else K b
   796           | NONE => get_b) #> def_qualify;
   797         val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)]
   798           else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live);
   799       in bs ~~ set_rhss end;
   800     val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs);
   801 
   802     val ((((bnf_map_term, raw_map_def),
   803       (bnf_set_terms, raw_set_defs)),
   804       (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
   805         no_defs_lthy
   806         |> maybe_define true map_bind_def
   807         ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
   808         ||>> maybe_define true bd_bind_def
   809         ||> `(maybe_restore no_defs_lthy);
   810 
   811     val phi = Proof_Context.export_morphism lthy_old lthy;
   812 
   813     val bnf_map_def = Morphism.thm phi raw_map_def;
   814     val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
   815     val bnf_bd_def = Morphism.thm phi raw_bd_def;
   816 
   817     val bnf_map = Morphism.term phi bnf_map_term;
   818 
   819     (*TODO: handle errors*)
   820     (*simple shape analysis of a map function*)
   821     val ((alphas, betas), (Calpha, _)) =
   822       fastype_of bnf_map
   823       |> strip_typeN live
   824       |>> map_split dest_funT
   825       ||> dest_funT
   826       handle TYPE _ => error "Bad map function";
   827 
   828     val Calpha_params = map TVar (Term.add_tvarsT Calpha []);
   829 
   830     val bnf_T = Morphism.typ phi T_rhs;
   831     val bad_args = Term.add_tfreesT bnf_T [];
   832     val _ = null bad_args orelse error ("Locally fixed type arguments " ^
   833       commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args));
   834 
   835     val bnf_sets =
   836       map2 (normalize_set Calpha_params) alphas (map (Morphism.term phi) bnf_set_terms);
   837     val bnf_bd =
   838       Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ Calpha_params)
   839         (Morphism.term phi bnf_bd_term);
   840 
   841     (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
   842     val deads = (case Ds_opt of
   843       NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
   844     | SOME Ds => map (Morphism.typ phi) Ds);
   845 
   846     (*TODO: further checks of type of bnf_map*)
   847     (*TODO: check types of bnf_sets*)
   848     (*TODO: check type of bnf_bd*)
   849     (*TODO: check type of bnf_rel*)
   850 
   851     fun mk_bnf_map Ds As' Bs' =
   852       Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
   853     fun mk_bnf_t Ds As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
   854     fun mk_bnf_T Ds As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
   855 
   856     val (((As, Bs), Ds), names_lthy) = lthy
   857       |> mk_TFrees live
   858       ||>> mk_TFrees live
   859       ||>> mk_TFrees (length deads);
   860     val RTs = map2 (curry HOLogic.mk_prodT) As Bs;
   861     val pred2RTs = map2 mk_pred2T As Bs;
   862     val (Rs, Rs') = names_lthy |> mk_Frees' "R" pred2RTs |> fst
   863     val CA = mk_bnf_T Ds As Calpha;
   864     val CR = mk_bnf_T Ds RTs Calpha;
   865     val setRs =
   866       @{map 3} (fn R => fn T => fn U =>
   867           HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split R) Rs As Bs;
   868 
   869     (*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO
   870       Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*)
   871     val OO_Grp =
   872       let
   873         val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs);
   874         val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs);
   875         val bnf_in = mk_in setRs (map (mk_bnf_t Ds RTs) bnf_sets) CR;
   876       in
   877         mk_rel_compp (mk_conversep (mk_Grp bnf_in map1), mk_Grp bnf_in map2)
   878         |> fold_rev Term.absfree Rs'
   879       end;
   880 
   881     val rel_rhs = the_default OO_Grp rel_rhs_opt;
   882 
   883     val rel_bind_def =
   884       (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
   885          rel_rhs);
   886 
   887     val wit_rhss =
   888       if null wit_rhss then
   889         [fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As,
   890           map2 (fn T => fn i => Term.absdummy T (Bound i)) As (live downto 1)) $
   891           Const (@{const_name undefined}, CA))]
   892       else wit_rhss;
   893     val nwits = length wit_rhss;
   894     val wit_binds_defs =
   895       let
   896         val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)]
   897           else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
   898       in bs ~~ wit_rhss end;
   899 
   900     val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
   901       lthy
   902       |> maybe_define (is_some rel_rhs_opt) rel_bind_def
   903       ||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs
   904       ||> `(maybe_restore lthy);
   905 
   906     val phi = Proof_Context.export_morphism lthy_old lthy;
   907     val bnf_rel_def = Morphism.thm phi raw_rel_def;
   908     val bnf_rel = Morphism.term phi bnf_rel_term;
   909     fun mk_bnf_rel Ds As' Bs' =
   910       normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha)
   911         bnf_rel;
   912 
   913     val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
   914     val bnf_wits =
   915       map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms;
   916 
   917     fun mk_OO_Grp Ds' As' Bs' =
   918       Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) OO_Grp;
   919   in
   920     (((alphas, betas, deads, Calpha),
   921      (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
   922      (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
   923      (mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_OO_Grp)), lthy)
   924   end;
   925 
   926 fun prepare_def const_policy mk_fact_policy internal qualify prep_typ prep_term Ds_opt map_b rel_b
   927   set_bs ((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt)
   928   no_defs_lthy =
   929   let
   930     val fact_policy = mk_fact_policy no_defs_lthy;
   931     val bnf_b = qualify raw_bnf_b;
   932     val live = length raw_sets;
   933 
   934     val T_rhs = prep_typ no_defs_lthy raw_bnf_T;
   935     val map_rhs = prep_term no_defs_lthy raw_map;
   936     val set_rhss = map (prep_term no_defs_lthy) raw_sets;
   937     val bd_rhs = prep_term no_defs_lthy raw_bd;
   938     val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
   939     val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt;
   940 
   941     fun err T =
   942       error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
   943         " as unnamed BNF");
   944 
   945     val (bnf_b, key) =
   946       if Binding.eq_name (bnf_b, Binding.empty) then
   947         (case T_rhs of
   948           Type (C, Ts) => if forall (can dest_TFree) Ts
   949             then (Binding.qualified_name C, C) else err T_rhs
   950         | T => err T)
   951       else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
   952 
   953     val (((alphas, betas, deads, Calpha),
   954      (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
   955      (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
   956      (mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, mk_OO_Grp)), lthy) =
   957        define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b set_bs
   958          ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy;
   959 
   960     val dead = length deads;
   961 
   962     val (((((((As', Bs'), Cs), Ds), Es), B1Ts), B2Ts), (Ts, T)) = lthy
   963       |> mk_TFrees live
   964       ||>> mk_TFrees live
   965       ||>> mk_TFrees live
   966       ||>> mk_TFrees dead
   967       ||>> mk_TFrees live
   968       ||>> mk_TFrees live
   969       ||>> mk_TFrees live
   970       ||> fst o mk_TFrees 1
   971       ||> the_single
   972       ||> `(replicate live);
   973 
   974     val mk_bnf_map = mk_bnf_map_Ds Ds;
   975     val mk_bnf_t = mk_bnf_t_Ds Ds;
   976     val mk_bnf_T = mk_bnf_T_Ds Ds;
   977 
   978     val pred2RTs = map2 mk_pred2T As' Bs';
   979     val pred2RTsAsCs = map2 mk_pred2T As' Cs;
   980     val pred2RTsBsCs = map2 mk_pred2T Bs' Cs;
   981     val pred2RTsBsEs = map2 mk_pred2T Bs' Es;
   982     val pred2RTsCsBs = map2 mk_pred2T Cs Bs';
   983     val pred2RTsCsEs = map2 mk_pred2T Cs Es;
   984     val pred2RT's = map2 mk_pred2T Bs' As';
   985     val self_pred2RTs = map2 mk_pred2T As' As';
   986     val transfer_domRTs = map2 mk_pred2T As' B1Ts;
   987     val transfer_ranRTs = map2 mk_pred2T Bs' B2Ts;
   988 
   989     val CA' = mk_bnf_T As' Calpha;
   990     val CB' = mk_bnf_T Bs' Calpha;
   991     val CC' = mk_bnf_T Cs Calpha;
   992     val CE' = mk_bnf_T Es Calpha;
   993     val CB1 = mk_bnf_T B1Ts Calpha;
   994     val CB2 = mk_bnf_T B2Ts Calpha;
   995 
   996     val bnf_map_AsAs = mk_bnf_map As' As';
   997     val bnf_map_AsBs = mk_bnf_map As' Bs';
   998     val bnf_map_AsCs = mk_bnf_map As' Cs;
   999     val bnf_map_BsCs = mk_bnf_map Bs' Cs;
  1000     val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
  1001     val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
  1002     val bnf_bd_As = mk_bnf_t As' bnf_bd;
  1003     fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel;
  1004 
  1005     val pre_names_lthy = lthy;
  1006     val ((((((((((((((((((((((fs, fs'), gs), hs), is), x), x'), y), zs), zs'), ys), As),
  1007       As_copy), bs), Rs), Rs_copy), Ss), S_AsCs), S_CsBs), S_BsEs),
  1008       transfer_domRs), transfer_ranRs), names_lthy) = pre_names_lthy
  1009       |> mk_Frees "f" (map2 (curry op -->) As' Bs')
  1010       ||>> mk_Frees "f" (map2 (curry op -->) As' Bs')
  1011       ||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs)
  1012       ||>> mk_Frees "h" (map2 (curry op -->) As' Ts)
  1013       ||>> mk_Frees "i" (map2 (curry op -->) As' Cs)
  1014       ||>> yield_singleton (mk_Frees "x") CA'
  1015       ||>> yield_singleton (mk_Frees "x") CA'
  1016       ||>> yield_singleton (mk_Frees "y") CB'
  1017       ||>> mk_Frees "z" As'
  1018       ||>> mk_Frees "z" As'
  1019       ||>> mk_Frees "y" Bs'
  1020       ||>> mk_Frees "A" (map HOLogic.mk_setT As')
  1021       ||>> mk_Frees "A" (map HOLogic.mk_setT As')
  1022       ||>> mk_Frees "b" As'
  1023       ||>> mk_Frees "R" pred2RTs
  1024       ||>> mk_Frees "R" pred2RTs
  1025       ||>> mk_Frees "S" pred2RTsBsCs
  1026       ||>> mk_Frees "S" pred2RTsAsCs
  1027       ||>> mk_Frees "S" pred2RTsCsBs
  1028       ||>> mk_Frees "S" pred2RTsBsEs
  1029       ||>> mk_Frees "R" transfer_domRTs
  1030       ||>> mk_Frees "S" transfer_ranRTs;
  1031 
  1032     val fs_copy = map2 (retype_const_or_free o fastype_of) fs gs;
  1033     val x_copy = retype_const_or_free CA' y;
  1034 
  1035     val rel = mk_bnf_rel pred2RTs CA' CB';
  1036     val relCsEs = mk_bnf_rel pred2RTsCsEs CC' CE';
  1037     val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
  1038     val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
  1039 
  1040     val map_id0_goal =
  1041       let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
  1042         mk_Trueprop_eq (bnf_map_app_id, HOLogic.id_const CA')
  1043       end;
  1044 
  1045     val map_comp0_goal =
  1046       let
  1047         val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
  1048         val comp_bnf_map_app = HOLogic.mk_comp
  1049           (Term.list_comb (bnf_map_BsCs, gs), Term.list_comb (bnf_map_AsBs, fs));
  1050       in
  1051         fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
  1052       end;
  1053 
  1054     fun mk_map_cong_prem mk_implies x z set f f_copy =
  1055       Logic.all z (mk_implies (mk_Trueprop_mem (z, set $ x), mk_Trueprop_eq (f $ z, f_copy $ z)));
  1056 
  1057     val map_cong0_goal =
  1058       let
  1059         val prems = @{map 4} (mk_map_cong_prem Logic.mk_implies x) zs bnf_sets_As fs fs_copy;
  1060         val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
  1061           Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
  1062       in
  1063         fold_rev Logic.all (x :: fs @ fs_copy) (Logic.list_implies (prems, eq))
  1064       end;
  1065 
  1066     val set_map0s_goal =
  1067       let
  1068         fun mk_goal setA setB f =
  1069           let
  1070             val set_comp_map = HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
  1071             val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
  1072           in
  1073             fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
  1074           end;
  1075       in
  1076         @{map 3} mk_goal bnf_sets_As bnf_sets_Bs fs
  1077       end;
  1078 
  1079     val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
  1080 
  1081     val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
  1082 
  1083     val set_bds_goal =
  1084       let
  1085         fun mk_goal set =
  1086           Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
  1087       in
  1088         map mk_goal bnf_sets_As
  1089       end;
  1090 
  1091     val relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC';
  1092     val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC';
  1093     val relCsBs = mk_bnf_rel pred2RTsCsBs CC' CB';
  1094     val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss);
  1095     val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss));
  1096     val le_rel_OO_goal =
  1097       fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs));
  1098 
  1099     val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs),
  1100       Term.list_comb (mk_OO_Grp Ds As' Bs', Rs)));
  1101 
  1102     val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal
  1103       card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal;
  1104 
  1105     fun mk_wit_goals (I, wit) =
  1106       let
  1107         val xs = map (nth bs) I;
  1108         fun wit_goal i =
  1109           let
  1110             val z = nth zs i;
  1111             val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
  1112             val concl = HOLogic.mk_Trueprop
  1113               (if member (op =) I i then HOLogic.mk_eq (z, nth bs i) else @{term False});
  1114           in
  1115             fold_rev Logic.all (z :: xs) (Logic.mk_implies (mk_Trueprop_mem (z, set_wit), concl))
  1116           end;
  1117       in
  1118         map wit_goal (0 upto live - 1)
  1119       end;
  1120 
  1121     fun triv_wit_tac ctxt = mk_trivial_wit_tac ctxt bnf_wit_defs;
  1122 
  1123     val wit_goalss =
  1124       (if null raw_wits then SOME triv_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
  1125 
  1126     fun after_qed mk_wit_thms thms lthy =
  1127       let
  1128         val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
  1129 
  1130         val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
  1131         val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
  1132         val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
  1133 
  1134         fun mk_collect_set_map () =
  1135           let
  1136             val defT = mk_bnf_T Ts Calpha --> HOLogic.mk_setT T;
  1137             val collect_map = HOLogic.mk_comp (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
  1138               Term.list_comb (mk_bnf_map As' Ts, hs));
  1139             val image_collect = mk_collect
  1140               (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As) defT;
  1141             (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
  1142             val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
  1143           in
  1144             Goal.prove_sorry lthy [] [] goal (K (mk_collect_set_map_tac (#set_map0 axioms)))
  1145             |> Thm.close_derivation
  1146           end;
  1147 
  1148         val collect_set_map = Lazy.lazy mk_collect_set_map;
  1149 
  1150         fun mk_in_mono () =
  1151           let
  1152             val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_leq) As As_copy;
  1153             val in_mono_goal =
  1154               fold_rev Logic.all (As @ As_copy)
  1155                 (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
  1156                   (mk_leq (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
  1157           in
  1158             Goal.prove_sorry lthy [] [] in_mono_goal (K (mk_in_mono_tac live))
  1159             |> Thm.close_derivation
  1160           end;
  1161 
  1162         val in_mono = Lazy.lazy mk_in_mono;
  1163 
  1164         fun mk_in_cong () =
  1165           let
  1166             val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy;
  1167             val in_cong_goal =
  1168               fold_rev Logic.all (As @ As_copy)
  1169                 (Logic.list_implies (prems_cong,
  1170                   mk_Trueprop_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA')));
  1171           in
  1172             Goal.prove_sorry lthy [] [] in_cong_goal
  1173               (K ((TRY o hyp_subst_tac lthy THEN' rtac refl) 1))
  1174             |> Thm.close_derivation
  1175           end;
  1176 
  1177         val in_cong = Lazy.lazy mk_in_cong;
  1178 
  1179         val map_id = Lazy.lazy (fn () => mk_map_id (#map_id0 axioms));
  1180         val map_ident0 = Lazy.lazy (fn () => mk_map_ident lthy (#map_id0 axioms));
  1181         val map_ident = Lazy.lazy (fn () => mk_map_ident lthy (Lazy.force map_id));
  1182         val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms));
  1183 
  1184         fun mk_map_cong mk_implies () =
  1185           let
  1186             val prem0 = mk_Trueprop_eq (x, x_copy);
  1187             val prems = @{map 4} (mk_map_cong_prem mk_implies x_copy) zs bnf_sets_As fs fs_copy;
  1188             val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
  1189               Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
  1190             val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
  1191               (Logic.list_implies (prem0 :: prems, eq));
  1192           in
  1193             Goal.prove_sorry lthy [] [] goal (K (unfold_thms_tac lthy @{thms simp_implies_def} THEN
  1194               mk_map_cong_tac lthy (#map_cong0 axioms)))
  1195             |> Thm.close_derivation
  1196           end;
  1197 
  1198         val map_cong = Lazy.lazy (mk_map_cong Logic.mk_implies);
  1199         val map_cong_simp = Lazy.lazy (mk_map_cong (fn (a, b) => @{term simp_implies} $ a $ b));
  1200 
  1201         fun mk_inj_map () =
  1202           let
  1203             val prems = map (HOLogic.mk_Trueprop o mk_inj) fs;
  1204             val concl = HOLogic.mk_Trueprop (mk_inj (Term.list_comb (bnf_map_AsBs, fs)));
  1205             val goal = fold_rev Logic.all fs (Logic.list_implies (prems, concl));
  1206           in
  1207             Goal.prove_sorry lthy [] [] goal (fn _ => mk_inj_map_tac live (Lazy.force map_id)
  1208               (Lazy.force map_comp) (#map_cong0 axioms) (Lazy.force map_cong))
  1209             |> Thm.close_derivation
  1210           end;
  1211 
  1212         val inj_map = Lazy.lazy mk_inj_map;
  1213 
  1214         val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
  1215 
  1216         val wit_thms =
  1217           if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
  1218 
  1219         fun mk_in_bd () =
  1220           let
  1221             val bdT = fst (dest_relT (fastype_of bnf_bd_As));
  1222             val bdTs = replicate live bdT;
  1223             val bd_bnfT = mk_bnf_T bdTs Calpha;
  1224             val surj_imp_ordLeq_inst = (if live = 0 then TrueI else
  1225               let
  1226                 val ranTs = map (fn AT => mk_sumT (AT, HOLogic.unitT)) As';
  1227                 val funTs = map (fn T => bdT --> T) ranTs;
  1228                 val ran_bnfT = mk_bnf_T ranTs Calpha;
  1229                 val (revTs, Ts) = `rev (bd_bnfT :: funTs);
  1230                 val cTs = map (SOME o Thm.ctyp_of lthy) [ran_bnfT, Library.foldr1 HOLogic.mk_prodT Ts];
  1231                 val tinst = fold (fn T => fn t => HOLogic.mk_split (Term.absdummy T t)) (tl revTs)
  1232                   (Term.absdummy (hd revTs) (Term.list_comb (mk_bnf_map bdTs ranTs,
  1233                     map Bound (live - 1 downto 0)) $ Bound live));
  1234                 val cts = [NONE, SOME (Thm.cterm_of lthy tinst)];
  1235               in
  1236                 Drule.instantiate' cTs cts @{thm surj_imp_ordLeq}
  1237               end);
  1238             val bd = mk_cexp
  1239               (if live = 0 then ctwo
  1240                 else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
  1241               (mk_csum bnf_bd_As (mk_card_of (HOLogic.mk_UNIV bd_bnfT)));
  1242             val in_bd_goal =
  1243               fold_rev Logic.all As
  1244                 (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd));
  1245           in
  1246             Goal.prove_sorry lthy [] [] in_bd_goal
  1247               (fn {context = ctxt, prems = _} => mk_in_bd_tac ctxt live surj_imp_ordLeq_inst
  1248                 (Lazy.force map_comp) (Lazy.force map_id) (#map_cong0 axioms)
  1249                 (map Lazy.force set_map) (#set_bd axioms) (#bd_card_order axioms)
  1250                 bd_Card_order bd_Cinfinite bd_Cnotzero)
  1251             |> Thm.close_derivation
  1252           end;
  1253 
  1254         val in_bd = Lazy.lazy mk_in_bd;
  1255 
  1256         val rel_OO_Grp = #rel_OO_Grp axioms;
  1257         val rel_OO_Grps = no_refl [rel_OO_Grp];
  1258 
  1259         fun mk_rel_Grp () =
  1260           let
  1261             val lhs = Term.list_comb (rel, map2 mk_Grp As fs);
  1262             val rhs = mk_Grp (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
  1263             val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
  1264           in
  1265             Goal.prove_sorry lthy [] [] goal
  1266               (fn {context = ctxt, prems = _} => mk_rel_Grp_tac ctxt rel_OO_Grps (#map_id0 axioms)
  1267                 (#map_cong0 axioms) (Lazy.force map_id) (Lazy.force map_comp)
  1268                 (map Lazy.force set_map))
  1269             |> Thm.close_derivation
  1270           end;
  1271 
  1272         val rel_Grp = Lazy.lazy mk_rel_Grp;
  1273 
  1274         fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
  1275         fun mk_rel_concl f = HOLogic.mk_Trueprop
  1276           (f (Term.list_comb (rel, Rs), Term.list_comb (rel, Rs_copy)));
  1277 
  1278         fun mk_rel_mono () =
  1279           let
  1280             val mono_prems = mk_rel_prems mk_leq;
  1281             val mono_concl = mk_rel_concl (uncurry mk_leq);
  1282           in
  1283             Goal.prove_sorry lthy [] []
  1284               (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
  1285               (K (mk_rel_mono_tac rel_OO_Grps (Lazy.force in_mono)))
  1286             |> Thm.close_derivation
  1287           end;
  1288 
  1289         fun mk_rel_cong () =
  1290           let
  1291             val cong_prems = mk_rel_prems (curry HOLogic.mk_eq);
  1292             val cong_concl = mk_rel_concl HOLogic.mk_eq;
  1293           in
  1294             Goal.prove_sorry lthy [] []
  1295               (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
  1296               (fn _ => (TRY o hyp_subst_tac lthy THEN' rtac refl) 1)
  1297             |> Thm.close_derivation
  1298           end;
  1299 
  1300         val rel_mono = Lazy.lazy mk_rel_mono;
  1301         val rel_cong = Lazy.lazy mk_rel_cong;
  1302 
  1303         fun mk_rel_eq () =
  1304           Goal.prove_sorry lthy [] []
  1305             (mk_Trueprop_eq (Term.list_comb (relAsAs, map HOLogic.eq_const As'),
  1306               HOLogic.eq_const CA'))
  1307             (K (mk_rel_eq_tac live (Lazy.force rel_Grp) (Lazy.force rel_cong) (#map_id0 axioms)))
  1308           |> Thm.close_derivation;
  1309 
  1310         val rel_eq = Lazy.lazy mk_rel_eq;
  1311 
  1312         fun mk_rel_conversep () =
  1313           let
  1314             val relBsAs = mk_bnf_rel pred2RT's CB' CA';
  1315             val lhs = Term.list_comb (relBsAs, map mk_conversep Rs);
  1316             val rhs = mk_conversep (Term.list_comb (rel, Rs));
  1317             val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_leq lhs rhs));
  1318             val le_thm = Goal.prove_sorry lthy [] [] le_goal
  1319               (fn {context = ctxt, prems = _} => mk_rel_conversep_le_tac ctxt rel_OO_Grps
  1320                 (Lazy.force rel_eq) (#map_cong0 axioms) (Lazy.force map_comp)
  1321                 (map Lazy.force set_map))
  1322               |> Thm.close_derivation
  1323             val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
  1324           in
  1325             Goal.prove_sorry lthy [] [] goal
  1326               (K (mk_rel_conversep_tac le_thm (Lazy.force rel_mono)))
  1327             |> Thm.close_derivation
  1328           end;
  1329 
  1330         val rel_conversep = Lazy.lazy mk_rel_conversep;
  1331 
  1332         fun mk_rel_OO () =
  1333           Goal.prove_sorry lthy [] []
  1334             (fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_lhs rel_OO_rhs)))
  1335             (fn {context = ctxt, prems = _} => mk_rel_OO_le_tac ctxt rel_OO_Grps (Lazy.force rel_eq)
  1336               (#map_cong0 axioms) (Lazy.force map_comp) (map Lazy.force set_map))
  1337           |> Thm.close_derivation
  1338           |> (fn thm => @{thm antisym} OF [thm, #le_rel_OO axioms]);
  1339 
  1340         val rel_OO = Lazy.lazy mk_rel_OO;
  1341 
  1342         fun mk_in_rel () = trans OF [rel_OO_Grp, @{thm OO_Grp_alt}] RS @{thm predicate2_eqD};
  1343 
  1344         val in_rel = Lazy.lazy mk_in_rel;
  1345 
  1346         fun mk_rel_flip () =
  1347           let
  1348             val rel_conversep_thm = Lazy.force rel_conversep;
  1349             val cts = map (SOME o Thm.cterm_of lthy) Rs;
  1350             val rel_conversep_thm' = cterm_instantiate_pos cts rel_conversep_thm;
  1351           in
  1352             unfold_thms lthy @{thms conversep_iff} (rel_conversep_thm' RS @{thm predicate2_eqD})
  1353             |> singleton (Proof_Context.export names_lthy pre_names_lthy)
  1354           end;
  1355 
  1356         val rel_flip = Lazy.lazy mk_rel_flip;
  1357 
  1358         fun mk_rel_mono_strong0 () =
  1359           let
  1360             fun mk_prem setA setB R S a b =
  1361               HOLogic.mk_Trueprop
  1362                 (mk_Ball (setA $ x) (Term.absfree (dest_Free a)
  1363                   (mk_Ball (setB $ y) (Term.absfree (dest_Free b)
  1364                     (HOLogic.mk_imp (R $ a $ b, S $ a $ b))))));
  1365             val prems = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs) $ x $ y) ::
  1366               @{map 6} mk_prem bnf_sets_As bnf_sets_Bs Rs Rs_copy zs ys;
  1367             val concl = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs_copy) $ x $ y);
  1368           in
  1369             Goal.prove_sorry lthy [] []
  1370               (fold_rev Logic.all (x :: y :: Rs @ Rs_copy) (Logic.list_implies (prems, concl)))
  1371               (fn {context = ctxt, prems = _} => mk_rel_mono_strong0_tac ctxt (Lazy.force in_rel)
  1372                 (map Lazy.force set_map))
  1373             |> Thm.close_derivation
  1374           end;
  1375 
  1376         val rel_mono_strong0 = Lazy.lazy mk_rel_mono_strong0;
  1377 
  1378         fun mk_rel_mono_strong () = Object_Logic.rulify lthy (Lazy.force rel_mono_strong0)
  1379 
  1380         val rel_mono_strong = Lazy.lazy mk_rel_mono_strong;
  1381 
  1382         fun mk_rel_map () =
  1383           let
  1384             fun mk_goal lhs rhs =
  1385               fold_rev Logic.all ([x, y] @ S_CsBs @ S_AsCs @ is @ gs) (mk_Trueprop_eq (lhs, rhs));
  1386 
  1387             val lhss =
  1388               [Term.list_comb (relCsBs, S_CsBs) $ (Term.list_comb (bnf_map_AsCs, is) $ x) $ y,
  1389                Term.list_comb (relAsCs, S_AsCs) $ x $ (Term.list_comb (bnf_map_BsCs, gs) $ y)];
  1390             val rhss =
  1391               [Term.list_comb (rel, @{map 3} (fn f => fn P => fn T =>
  1392                  mk_vimage2p f (HOLogic.id_const T) $ P) is S_CsBs Bs') $ x $ y,
  1393                Term.list_comb (rel, @{map 3} (fn f => fn P => fn T =>
  1394                  mk_vimage2p (HOLogic.id_const T) f $ P) gs S_AsCs As') $ x $ y];
  1395             val goals = map2 mk_goal lhss rhss;
  1396           in
  1397             goals
  1398             |> map (fn goal => Goal.prove_sorry lthy [] [] goal
  1399               (fn {context = ctxt, prems = _} =>
  1400                  mk_rel_map0_tac ctxt live (Lazy.force rel_OO) (Lazy.force rel_conversep)
  1401                   (Lazy.force rel_Grp) (Lazy.force map_id)))
  1402             |> map (unfold_thms lthy @{thms vimage2p_def[of id, unfolded id_apply]
  1403                  vimage2p_def[of _ id, unfolded id_apply]})
  1404             |> map Thm.close_derivation
  1405           end;
  1406 
  1407         val rel_map = Lazy.lazy mk_rel_map;
  1408 
  1409         fun mk_map_transfer () =
  1410           let
  1411             val rels = map2 mk_rel_fun transfer_domRs transfer_ranRs;
  1412             val rel = mk_rel_fun
  1413               (Term.list_comb (mk_bnf_rel transfer_domRTs CA' CB1, transfer_domRs))
  1414               (Term.list_comb (mk_bnf_rel transfer_ranRTs CB' CB2, transfer_ranRs));
  1415             val concl = HOLogic.mk_Trueprop
  1416               (fold_rev mk_rel_fun rels rel $ bnf_map_AsBs $ mk_bnf_map B1Ts B2Ts);
  1417           in
  1418             Goal.prove_sorry lthy [] []
  1419               (fold_rev Logic.all (transfer_domRs @ transfer_ranRs) concl)
  1420               (fn {context = ctxt, prems = _} => mk_map_transfer_tac ctxt (Lazy.force rel_mono)
  1421                 (Lazy.force in_rel) (map Lazy.force set_map) (#map_cong0 axioms)
  1422                 (Lazy.force map_comp))
  1423             |> Thm.close_derivation
  1424           end;
  1425 
  1426         val map_transfer = Lazy.lazy mk_map_transfer;
  1427 
  1428         fun mk_rel_transfer () =
  1429           let
  1430             val iff = HOLogic.eq_const HOLogic.boolT;
  1431             val prem_rels =
  1432               map2 (fn T1 => fn T2 => mk_rel_fun T1 (mk_rel_fun T2 iff)) S_AsCs S_BsEs;
  1433             val prem_elems =
  1434               mk_rel_fun (Term.list_comb (mk_bnf_rel pred2RTsAsCs CA' CC', S_AsCs))
  1435                 (mk_rel_fun (Term.list_comb (mk_bnf_rel pred2RTsBsEs CB' CE', S_BsEs)) iff);
  1436             val goal =
  1437               HOLogic.mk_Trueprop (fold_rev mk_rel_fun prem_rels prem_elems $ rel $ relCsEs);
  1438           in
  1439             Goal.prove_sorry lthy [] [] goal
  1440               (fn {context = ctxt, prems = _} =>
  1441                 mk_rel_transfer_tac ctxt (Lazy.force in_rel) (Lazy.force rel_map)
  1442                   (Lazy.force rel_mono_strong))
  1443             |> singleton (Proof_Context.export names_lthy lthy)
  1444             |> Thm.close_derivation
  1445           end;
  1446 
  1447         val rel_transfer = Lazy.lazy mk_rel_transfer;
  1448 
  1449         fun mk_set_transfer () =
  1450           let
  1451             val rel_sets = map2 (fn A => fn B => mk_rel 1 [A] [B] @{term rel_set}) As' Bs';
  1452             val rel_Rs = Term.list_comb (rel, Rs);
  1453             val goals = @{map 4} (fn R => fn rel_set => fn setA => fn setB => HOLogic.mk_Trueprop
  1454               (mk_rel_fun rel_Rs (rel_set $ R) $ setA $ setB)) Rs rel_sets bnf_sets_As bnf_sets_Bs;
  1455           in
  1456             if null goals then []
  1457             else
  1458               Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals)
  1459                 (fn {context = ctxt, prems = _} =>
  1460                    mk_set_transfer_tac ctxt (Lazy.force in_rel) (map Lazy.force set_map))
  1461               |> Conjunction.elim_balanced (length goals)
  1462               |> Proof_Context.export names_lthy lthy
  1463               |> map Thm.close_derivation
  1464           end;
  1465 
  1466         val set_transfer = Lazy.lazy mk_set_transfer;
  1467 
  1468         fun mk_inj_map_strong () =
  1469           let
  1470             val assms = @{map 5} (fn setA => fn z => fn f => fn z' => fn f' =>
  1471               fold_rev Logic.all [z, z']
  1472                 (Logic.mk_implies (mk_Trueprop_mem (z, setA $ x),
  1473                    Logic.mk_implies (mk_Trueprop_mem (z', setA $ x'),
  1474                      Logic.mk_implies (mk_Trueprop_eq (f $ z, f' $ z'),
  1475                        mk_Trueprop_eq (z, z')))))) bnf_sets_As zs fs zs' fs';
  1476             val concl = Logic.mk_implies
  1477               (mk_Trueprop_eq
  1478                  (Term.list_comb (bnf_map_AsBs, fs) $ x,
  1479                   Term.list_comb (bnf_map_AsBs, fs') $ x'),
  1480                mk_Trueprop_eq (x, x'));
  1481             val goal = fold_rev Logic.all (x :: x' :: fs @ fs')
  1482               (fold_rev (curry Logic.mk_implies) assms concl);
  1483           in
  1484             Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} =>
  1485               mk_inj_map_strong_tac ctxt (Lazy.force rel_eq) (Lazy.force rel_map)
  1486                 (Lazy.force rel_mono_strong))
  1487             |> Thm.close_derivation
  1488           end;
  1489 
  1490         val inj_map_strong = Lazy.lazy mk_inj_map_strong;
  1491 
  1492         val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def;
  1493 
  1494         val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong
  1495           in_mono in_rel inj_map inj_map_strong map_comp map_cong map_cong_simp map_id map_ident0
  1496           map_ident map_transfer rel_eq rel_flip set_map rel_cong rel_map rel_mono rel_mono_strong0
  1497           rel_mono_strong rel_transfer rel_Grp rel_conversep rel_OO set_transfer;
  1498 
  1499         val wits = map2 mk_witness bnf_wits wit_thms;
  1500 
  1501         val bnf_rel =
  1502           Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
  1503 
  1504         val bnf = mk_bnf bnf_b Calpha live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms
  1505           defs facts wits bnf_rel;
  1506       in
  1507         note_bnf_thms fact_policy qualify bnf_b bnf lthy
  1508       end;
  1509 
  1510     val one_step_defs =
  1511       no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ [bnf_rel_def]);
  1512   in
  1513     (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
  1514   end;
  1515 
  1516 structure BNF_Plugin = Plugin(type T = bnf);
  1517 
  1518 fun bnf_interpretation name f =
  1519   BNF_Plugin.interpretation name
  1520     (fn bnf => fn lthy => f (transfer_bnf (Proof_Context.theory_of lthy) bnf) lthy);
  1521 
  1522 val interpret_bnf = BNF_Plugin.data;
  1523 
  1524 fun register_bnf_raw key bnf =
  1525   Local_Theory.declaration {syntax = false, pervasive = true}
  1526     (fn phi => Data.map (Symtab.update (key, morph_bnf phi bnf)));
  1527 
  1528 fun register_bnf plugins key bnf =
  1529   register_bnf_raw key bnf #> interpret_bnf plugins bnf;
  1530 
  1531 fun bnf_def const_policy fact_policy internal qualify tacs wit_tac Ds map_b rel_b set_bs raw_csts =
  1532   (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
  1533   let
  1534     fun mk_wits_tac ctxt set_maps =
  1535       TRYALL Goal.conjunction_tac THEN
  1536       (case triv_tac_opt of
  1537         SOME tac => tac ctxt set_maps
  1538       | NONE => unfold_thms_tac ctxt one_step_defs THEN wit_tac ctxt);
  1539     val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  1540     fun mk_wit_thms set_maps =
  1541       Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
  1542         (fn {context = ctxt, prems = _} => mk_wits_tac ctxt set_maps)
  1543         |> Conjunction.elim_balanced (length wit_goals)
  1544         |> map2 (Conjunction.elim_balanced o length) wit_goalss
  1545         |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  1546   in
  1547     map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
  1548       goals (map (fn tac => fn {context = ctxt, prems = _} =>
  1549         unfold_thms_tac ctxt one_step_defs THEN tac ctxt) tacs)
  1550     |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
  1551   end) o prepare_def const_policy fact_policy internal qualify (K I) (K I) Ds map_b rel_b set_bs
  1552     raw_csts;
  1553 
  1554 fun bnf_cmd (raw_csts, raw_plugins) =
  1555   (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
  1556   let
  1557     val plugins = raw_plugins lthy;
  1558     val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  1559     fun mk_triv_wit_thms tac set_maps =
  1560       Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
  1561         (fn {context = ctxt, prems = _} => TRYALL Goal.conjunction_tac THEN tac ctxt set_maps)
  1562         |> Conjunction.elim_balanced (length wit_goals)
  1563         |> map2 (Conjunction.elim_balanced o length) wit_goalss
  1564         |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  1565     val (mk_wit_thms, nontriv_wit_goals) =
  1566       (case triv_tac_opt of
  1567         NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
  1568       | SOME tac => (mk_triv_wit_thms tac, []));
  1569   in
  1570     Proof.unfolding ([[(defs, [])]])
  1571       (Proof.theorem NONE (uncurry (register_bnf plugins key) oo after_qed mk_wit_thms)
  1572         (map (single o rpair []) goals @ nontriv_wit_goals) lthy)
  1573   end) o prepare_def Do_Inline (user_policy Note_Some) false I Syntax.read_typ Syntax.read_term
  1574     NONE Binding.empty Binding.empty [] raw_csts;
  1575 
  1576 fun print_bnfs ctxt =
  1577   let
  1578     fun pretty_set sets i = Pretty.block
  1579       [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
  1580           Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
  1581 
  1582     fun pretty_bnf (key, BNF {T, map, sets, bd, live, lives, dead, deads, ...}) =
  1583       Pretty.big_list
  1584         (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
  1585           Pretty.quote (Syntax.pretty_typ ctxt T)]))
  1586         ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
  1587             Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
  1588           Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
  1589             Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
  1590           Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
  1591             Pretty.quote (Syntax.pretty_term ctxt map)]] @
  1592           List.map (pretty_set sets) (0 upto length sets - 1) @
  1593           [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
  1594             Pretty.quote (Syntax.pretty_term ctxt bd)]]);
  1595   in
  1596     Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
  1597     |> Pretty.writeln
  1598   end;
  1599 
  1600 val _ =
  1601   Outer_Syntax.command @{command_spec "print_bnfs"}
  1602     "print all bounded natural functors"
  1603     (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
  1604 
  1605 val _ =
  1606   Outer_Syntax.local_theory_to_proof @{command_spec "bnf"}
  1607     "register a type as a bounded natural functor"
  1608     (parse_opt_binding_colon -- Parse.typ --|
  1609        (Parse.reserved "map" -- @{keyword ":"}) -- Parse.term --
  1610        Scan.optional ((Parse.reserved "sets" -- @{keyword ":"}) |--
  1611          Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) [] --|
  1612        (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term --
  1613        Scan.optional ((Parse.reserved "wits" -- @{keyword ":"}) |--
  1614          Scan.repeat1 (Scan.unless (Parse.reserved "rel" ||
  1615            Parse.reserved "plugins") Parse.term)) [] --
  1616        Scan.option ((Parse.reserved "rel" -- @{keyword ":"}) |-- Parse.term) --
  1617        Scan.optional Plugin_Name.parse_filter (K Plugin_Name.default_filter)
  1618        >> bnf_cmd);
  1619 
  1620 end;