src/HOL/BNF/Tools/bnf_def.ML
author blanchet
Mon May 06 21:20:54 2013 +0200 (2013-05-06)
changeset 51884 2928fda12661
parent 51837 087498724486
child 51893 596baae88a88
permissions -rw-r--r--
factor out construction of iterator
     1 (*  Title:      HOL/BNF/Tools/bnf_def.ML
     2     Author:     Dmitriy Traytel, TU Muenchen
     3     Author:     Jasmin Blanchette, TU Muenchen
     4     Copyright   2012
     5 
     6 Definition of bounded natural functors.
     7 *)
     8 
     9 signature BNF_DEF =
    10 sig
    11   type bnf
    12   type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
    13 
    14   val morph_bnf: morphism -> bnf -> bnf
    15   val eq_bnf: bnf * bnf -> bool
    16   val bnf_of: Proof.context -> string -> bnf option
    17   val register_bnf: string -> (bnf * local_theory) -> (bnf * local_theory)
    18 
    19   val name_of_bnf: bnf -> binding
    20   val T_of_bnf: bnf -> typ
    21   val live_of_bnf: bnf -> int
    22   val lives_of_bnf: bnf -> typ list
    23   val dead_of_bnf: bnf -> int
    24   val deads_of_bnf: bnf -> typ list
    25   val nwits_of_bnf: bnf -> int
    26 
    27   val mapN: string
    28   val relN: string
    29   val setN: string
    30   val mk_setN: int -> string
    31   val srelN: string
    32 
    33   val map_of_bnf: bnf -> term
    34   val sets_of_bnf: bnf -> term list
    35   val rel_of_bnf: bnf -> term
    36 
    37   val mk_T_of_bnf: typ list -> typ list -> bnf -> typ
    38   val mk_bd_of_bnf: typ list -> typ list -> bnf -> term
    39   val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    40   val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    41   val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list
    42   val mk_srel_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    43   val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list
    44 
    45   val bd_Card_order_of_bnf: bnf -> thm
    46   val bd_Cinfinite_of_bnf: bnf -> thm
    47   val bd_Cnotzero_of_bnf: bnf -> thm
    48   val bd_card_order_of_bnf: bnf -> thm
    49   val bd_cinfinite_of_bnf: bnf -> thm
    50   val collect_set_map_of_bnf: bnf -> thm
    51   val in_bd_of_bnf: bnf -> thm
    52   val in_cong_of_bnf: bnf -> thm
    53   val in_mono_of_bnf: bnf -> thm
    54   val in_srel_of_bnf: bnf -> thm
    55   val map_comp'_of_bnf: bnf -> thm
    56   val map_comp_of_bnf: bnf -> thm
    57   val map_cong0_of_bnf: bnf -> thm
    58   val map_cong_of_bnf: bnf -> thm
    59   val map_def_of_bnf: bnf -> thm
    60   val map_id'_of_bnf: bnf -> thm
    61   val map_id_of_bnf: bnf -> thm
    62   val map_wppull_of_bnf: bnf -> thm
    63   val map_wpull_of_bnf: bnf -> thm
    64   val rel_def_of_bnf: bnf -> thm
    65   val rel_eq_of_bnf: bnf -> thm
    66   val rel_flip_of_bnf: bnf -> thm
    67   val rel_srel_of_bnf: bnf -> thm
    68   val set_bd_of_bnf: bnf -> thm list
    69   val set_defs_of_bnf: bnf -> thm list
    70   val set_map'_of_bnf: bnf -> thm list
    71   val set_map_of_bnf: bnf -> thm list
    72   val srel_def_of_bnf: bnf -> thm
    73   val srel_Gr_of_bnf: bnf -> thm
    74   val srel_Id_of_bnf: bnf -> thm
    75   val srel_O_of_bnf: bnf -> thm
    76   val srel_O_Gr_of_bnf: bnf -> thm
    77   val srel_cong_of_bnf: bnf -> thm
    78   val srel_converse_of_bnf: bnf -> thm
    79   val srel_mono_of_bnf: bnf -> thm
    80   val wit_thms_of_bnf: bnf -> thm list
    81   val wit_thmss_of_bnf: bnf -> thm list list
    82 
    83   val mk_witness: int list * term -> thm list -> nonemptiness_witness
    84   val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
    85   val wits_of_bnf: bnf -> nonemptiness_witness list
    86 
    87   val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a -> 'a list
    88 
    89   datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
    90   datatype fact_policy = Dont_Note | Note_Some | Note_All
    91 
    92   val bnf_note_all: bool Config.T
    93   val user_policy: fact_policy -> Proof.context -> fact_policy
    94 
    95   val print_bnfs: Proof.context -> unit
    96   val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
    97     ({prems: thm list, context: Proof.context} -> tactic) list ->
    98     ({prems: thm list, context: Proof.context} -> tactic) -> typ list option -> binding ->
    99     binding -> binding list ->
   100     ((((binding * term) * term list) * term) * term list) * term option ->
   101     local_theory -> bnf * local_theory
   102 end;
   103 
   104 structure BNF_Def : BNF_DEF =
   105 struct
   106 
   107 open BNF_Util
   108 open BNF_Tactics
   109 open BNF_Def_Tactics
   110 
   111 val fundef_cong_attrs = @{attributes [fundef_cong]};
   112 
   113 type axioms = {
   114   map_id: thm,
   115   map_comp: thm,
   116   map_cong0: thm,
   117   set_map: thm list,
   118   bd_card_order: thm,
   119   bd_cinfinite: thm,
   120   set_bd: thm list,
   121   in_bd: thm,
   122   map_wpull: thm,
   123   srel_O_Gr: thm
   124 };
   125 
   126 fun mk_axioms' (((((((((id, comp), cong), nat), c_o), cinf), set_bd), in_bd), wpull), srel) =
   127   {map_id = id, map_comp = comp, map_cong0 = cong, set_map = nat, bd_card_order = c_o,
   128    bd_cinfinite = cinf, set_bd = set_bd, in_bd = in_bd, map_wpull = wpull, srel_O_Gr = srel};
   129 
   130 fun dest_cons [] = raise Empty
   131   | dest_cons (x :: xs) = (x, xs);
   132 
   133 fun mk_axioms n thms = thms
   134   |> map the_single
   135   |> dest_cons
   136   ||>> dest_cons
   137   ||>> dest_cons
   138   ||>> chop n
   139   ||>> dest_cons
   140   ||>> dest_cons
   141   ||>> chop n
   142   ||>> dest_cons
   143   ||>> dest_cons
   144   ||> the_single
   145   |> mk_axioms';
   146 
   147 fun zip_axioms mid mcomp mcong snat bdco bdinf sbd inbd wpull srel =
   148   [mid, mcomp, mcong] @ snat @ [bdco, bdinf] @ sbd @ [inbd, wpull, srel];
   149 
   150 fun dest_axioms {map_id, map_comp, map_cong0, set_map, bd_card_order, bd_cinfinite, set_bd, in_bd,
   151   map_wpull, srel_O_Gr} =
   152   zip_axioms map_id map_comp map_cong0 set_map bd_card_order bd_cinfinite set_bd in_bd map_wpull
   153     srel_O_Gr;
   154 
   155 fun map_axioms f {map_id, map_comp, map_cong0, set_map, bd_card_order, bd_cinfinite, set_bd,
   156   in_bd, map_wpull, srel_O_Gr} =
   157   {map_id = f map_id,
   158     map_comp = f map_comp,
   159     map_cong0 = f map_cong0,
   160     set_map = map f set_map,
   161     bd_card_order = f bd_card_order,
   162     bd_cinfinite = f bd_cinfinite,
   163     set_bd = map f set_bd,
   164     in_bd = f in_bd,
   165     map_wpull = f map_wpull,
   166     srel_O_Gr = f srel_O_Gr};
   167 
   168 val morph_axioms = map_axioms o Morphism.thm;
   169 
   170 type defs = {
   171   map_def: thm,
   172   set_defs: thm list,
   173   rel_def: thm,
   174   srel_def: thm
   175 }
   176 
   177 fun mk_defs map sets rel srel = {map_def = map, set_defs = sets, rel_def = rel, srel_def = srel};
   178 
   179 fun map_defs f {map_def, set_defs, rel_def, srel_def} =
   180   {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def, srel_def = f srel_def};
   181 
   182 val morph_defs = map_defs o Morphism.thm;
   183 
   184 type facts = {
   185   bd_Card_order: thm,
   186   bd_Cinfinite: thm,
   187   bd_Cnotzero: thm,
   188   collect_set_map: thm lazy,
   189   in_cong: thm lazy,
   190   in_mono: thm lazy,
   191   in_srel: thm lazy,
   192   map_comp': thm lazy,
   193   map_cong: thm lazy,
   194   map_id': thm lazy,
   195   map_wppull: thm lazy,
   196   rel_eq: thm lazy,
   197   rel_flip: thm lazy,
   198   rel_srel: thm lazy,
   199   set_map': thm lazy list,
   200   srel_cong: thm lazy,
   201   srel_mono: thm lazy,
   202   srel_Id: thm lazy,
   203   srel_Gr: thm lazy,
   204   srel_converse: thm lazy,
   205   srel_O: thm lazy
   206 };
   207 
   208 fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_cong in_mono in_srel
   209     map_comp' map_cong map_id' map_wppull rel_eq rel_flip rel_srel set_map' srel_cong srel_mono
   210     srel_Id srel_Gr srel_converse srel_O = {
   211   bd_Card_order = bd_Card_order,
   212   bd_Cinfinite = bd_Cinfinite,
   213   bd_Cnotzero = bd_Cnotzero,
   214   collect_set_map = collect_set_map,
   215   in_cong = in_cong,
   216   in_mono = in_mono,
   217   in_srel = in_srel,
   218   map_comp' = map_comp',
   219   map_cong = map_cong,
   220   map_id' = map_id',
   221   map_wppull = map_wppull,
   222   rel_eq = rel_eq,
   223   rel_flip = rel_flip,
   224   rel_srel = rel_srel,
   225   set_map' = set_map',
   226   srel_cong = srel_cong,
   227   srel_mono = srel_mono,
   228   srel_Id = srel_Id,
   229   srel_Gr = srel_Gr,
   230   srel_converse = srel_converse,
   231   srel_O = srel_O};
   232 
   233 fun map_facts f {
   234   bd_Card_order,
   235   bd_Cinfinite,
   236   bd_Cnotzero,
   237   collect_set_map,
   238   in_cong,
   239   in_mono,
   240   in_srel,
   241   map_comp',
   242   map_cong,
   243   map_id',
   244   map_wppull,
   245   rel_eq,
   246   rel_flip,
   247   rel_srel,
   248   set_map',
   249   srel_cong,
   250   srel_mono,
   251   srel_Id,
   252   srel_Gr,
   253   srel_converse,
   254   srel_O} =
   255   {bd_Card_order = f bd_Card_order,
   256     bd_Cinfinite = f bd_Cinfinite,
   257     bd_Cnotzero = f bd_Cnotzero,
   258     collect_set_map = Lazy.map f collect_set_map,
   259     in_cong = Lazy.map f in_cong,
   260     in_mono = Lazy.map f in_mono,
   261     in_srel = Lazy.map f in_srel,
   262     map_comp' = Lazy.map f map_comp',
   263     map_cong = Lazy.map f map_cong,
   264     map_id' = Lazy.map f map_id',
   265     map_wppull = Lazy.map f map_wppull,
   266     rel_eq = Lazy.map f rel_eq,
   267     rel_flip = Lazy.map f rel_flip,
   268     rel_srel = Lazy.map f rel_srel,
   269     set_map' = map (Lazy.map f) set_map',
   270     srel_cong = Lazy.map f srel_cong,
   271     srel_mono = Lazy.map f srel_mono,
   272     srel_Id = Lazy.map f srel_Id,
   273     srel_Gr = Lazy.map f srel_Gr,
   274     srel_converse = Lazy.map f srel_converse,
   275     srel_O = Lazy.map f srel_O};
   276 
   277 val morph_facts = map_facts o Morphism.thm;
   278 
   279 type nonemptiness_witness = {
   280   I: int list,
   281   wit: term,
   282   prop: thm list
   283 };
   284 
   285 fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
   286 fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
   287 fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
   288 
   289 datatype bnf = BNF of {
   290   name: binding,
   291   T: typ,
   292   live: int,
   293   lives: typ list, (*source type variables of map, only for composition*)
   294   lives': typ list, (*target type variables of map, only for composition*)
   295   dead: int,
   296   deads: typ list, (*only for composition*)
   297   map: term,
   298   sets: term list,
   299   bd: term,
   300   axioms: axioms,
   301   defs: defs,
   302   facts: facts,
   303   nwits: int,
   304   wits: nonemptiness_witness list,
   305   rel: term,
   306   srel: term
   307 };
   308 
   309 (* getters *)
   310 
   311 fun rep_bnf (BNF bnf) = bnf;
   312 val name_of_bnf = #name o rep_bnf;
   313 val T_of_bnf = #T o rep_bnf;
   314 fun mk_T_of_bnf Ds Ts bnf =
   315   let val bnf_rep = rep_bnf bnf
   316   in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
   317 val live_of_bnf = #live o rep_bnf;
   318 val lives_of_bnf = #lives o rep_bnf;
   319 val dead_of_bnf = #dead o rep_bnf;
   320 val deads_of_bnf = #deads o rep_bnf;
   321 val axioms_of_bnf = #axioms o rep_bnf;
   322 val facts_of_bnf = #facts o rep_bnf;
   323 val nwits_of_bnf = #nwits o rep_bnf;
   324 val wits_of_bnf = #wits o rep_bnf;
   325 
   326 (*terms*)
   327 val map_of_bnf = #map o rep_bnf;
   328 val sets_of_bnf = #sets o rep_bnf;
   329 fun mk_map_of_bnf Ds Ts Us bnf =
   330   let val bnf_rep = rep_bnf bnf;
   331   in
   332     Term.subst_atomic_types
   333       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
   334   end;
   335 fun mk_sets_of_bnf Dss Tss bnf =
   336   let val bnf_rep = rep_bnf bnf;
   337   in
   338     map2 (fn (Ds, Ts) => Term.subst_atomic_types
   339       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
   340   end;
   341 val bd_of_bnf = #bd o rep_bnf;
   342 fun mk_bd_of_bnf Ds Ts bnf =
   343   let val bnf_rep = rep_bnf bnf;
   344   in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
   345 fun mk_wits_of_bnf Dss Tss bnf =
   346   let
   347     val bnf_rep = rep_bnf bnf;
   348     val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
   349   in
   350     map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
   351       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
   352   end;
   353 val rel_of_bnf = #rel o rep_bnf;
   354 fun mk_rel_of_bnf Ds Ts Us bnf =
   355   let val bnf_rep = rep_bnf bnf;
   356   in
   357     Term.subst_atomic_types
   358       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
   359   end;
   360 val srel_of_bnf = #srel o rep_bnf;
   361 fun mk_srel_of_bnf Ds Ts Us bnf =
   362   let val bnf_rep = rep_bnf bnf;
   363   in
   364     Term.subst_atomic_types
   365       ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#srel bnf_rep)
   366   end;
   367 
   368 (*thms*)
   369 val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
   370 val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
   371 val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
   372 val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
   373 val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
   374 val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf;
   375 val in_bd_of_bnf = #in_bd o #axioms o rep_bnf;
   376 val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
   377 val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
   378 val in_srel_of_bnf = Lazy.force o #in_srel o #facts o rep_bnf;
   379 val map_def_of_bnf = #map_def o #defs o rep_bnf;
   380 val map_id_of_bnf = #map_id o #axioms o rep_bnf;
   381 val map_id'_of_bnf = Lazy.force o #map_id' o #facts o rep_bnf;
   382 val map_comp_of_bnf = #map_comp o #axioms o rep_bnf;
   383 val map_comp'_of_bnf = Lazy.force o #map_comp' o #facts o rep_bnf;
   384 val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
   385 val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
   386 val map_wppull_of_bnf = Lazy.force o #map_wppull o #facts o rep_bnf;
   387 val map_wpull_of_bnf = #map_wpull o #axioms o rep_bnf;
   388 val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
   389 val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf;
   390 val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf;
   391 val rel_srel_of_bnf = Lazy.force o #rel_srel o #facts o rep_bnf;
   392 val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
   393 val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
   394 val set_map_of_bnf = #set_map o #axioms o rep_bnf;
   395 val set_map'_of_bnf = map Lazy.force o #set_map' o #facts o rep_bnf;
   396 val srel_cong_of_bnf = Lazy.force o #srel_cong o #facts o rep_bnf;
   397 val srel_mono_of_bnf = Lazy.force o #srel_mono o #facts o rep_bnf;
   398 val srel_def_of_bnf = #srel_def o #defs o rep_bnf;
   399 val srel_Id_of_bnf = Lazy.force o #srel_Id o #facts o rep_bnf;
   400 val srel_Gr_of_bnf = Lazy.force o #srel_Gr o #facts o rep_bnf;
   401 val srel_converse_of_bnf = Lazy.force o #srel_converse o #facts o rep_bnf;
   402 val srel_O_of_bnf = Lazy.force o #srel_O o #facts o rep_bnf;
   403 val srel_O_Gr_of_bnf = #srel_O_Gr o #axioms o rep_bnf;
   404 val wit_thms_of_bnf = maps #prop o wits_of_bnf;
   405 val wit_thmss_of_bnf = map #prop o wits_of_bnf;
   406 
   407 fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel srel =
   408   BNF {name = name, T = T,
   409        live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
   410        map = map, sets = sets, bd = bd,
   411        axioms = axioms, defs = defs, facts = facts,
   412        nwits = length wits, wits = wits, rel = rel, srel = srel};
   413 
   414 fun morph_bnf phi (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
   415   dead = dead, deads = deads, map = map, sets = sets, bd = bd,
   416   axioms = axioms, defs = defs, facts = facts,
   417   nwits = nwits, wits = wits, rel = rel, srel = srel}) =
   418   BNF {name = Morphism.binding phi name, T = Morphism.typ phi T,
   419     live = live, lives = List.map (Morphism.typ phi) lives,
   420     lives' = List.map (Morphism.typ phi) lives',
   421     dead = dead, deads = List.map (Morphism.typ phi) deads,
   422     map = Morphism.term phi map, sets = List.map (Morphism.term phi) sets,
   423     bd = Morphism.term phi bd,
   424     axioms = morph_axioms phi axioms,
   425     defs = morph_defs phi defs,
   426     facts = morph_facts phi facts,
   427     nwits = nwits,
   428     wits = List.map (morph_witness phi) wits,
   429     rel = Morphism.term phi rel, srel = Morphism.term phi srel};
   430 
   431 fun eq_bnf (BNF {T = T1, live = live1, dead = dead1, ...},
   432   BNF {T = T2, live = live2, dead = dead2, ...}) =
   433   Type.could_unify (T1, T2) andalso live1 = live2 andalso dead1 = dead2;
   434 
   435 structure Data = Generic_Data
   436 (
   437   type T = bnf Symtab.table;
   438   val empty = Symtab.empty;
   439   val extend = I;
   440   val merge = Symtab.merge eq_bnf;
   441 );
   442 
   443 val bnf_of = Symtab.lookup o Data.get o Context.Proof;
   444 
   445 
   446 
   447 (* Utilities *)
   448 
   449 fun normalize_set insts instA set =
   450   let
   451     val (T, T') = dest_funT (fastype_of set);
   452     val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
   453     val params = Term.add_tvar_namesT T [];
   454   in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
   455 
   456 fun normalize_rel ctxt instTs instA instB rel =
   457   let
   458     val thy = Proof_Context.theory_of ctxt;
   459     val tyenv =
   460       Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB))
   461         Vartab.empty;
   462   in Envir.subst_term (tyenv, Vartab.empty) rel end
   463   handle Type.TYPE_MATCH => error "Bad predicator";
   464 
   465 fun normalize_srel ctxt instTs instA instB srel =
   466   let
   467     val thy = Proof_Context.theory_of ctxt;
   468     val tyenv =
   469       Sign.typ_match thy (fastype_of srel, Library.foldr (op -->) (instTs, mk_relT (instA, instB)))
   470         Vartab.empty;
   471   in Envir.subst_term (tyenv, Vartab.empty) srel end
   472   handle Type.TYPE_MATCH => error "Bad relator";
   473 
   474 fun normalize_wit insts CA As wit =
   475   let
   476     fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
   477         if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
   478       | strip_param x = x;
   479     val (Ts, T) = strip_param ([], fastype_of wit);
   480     val subst = Term.add_tvar_namesT T [] ~~ insts;
   481     fun find y = find_index (fn x => x = y) As;
   482   in
   483     (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
   484   end;
   485 
   486 fun minimize_wits wits =
   487  let
   488    fun minimize done [] = done
   489      | minimize done ((I, wit) :: todo) =
   490        if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
   491        then minimize done todo
   492        else minimize ((I, wit) :: done) todo;
   493  in minimize [] wits end;
   494 
   495 
   496 
   497 (* Names *)
   498 
   499 val mapN = "map";
   500 val setN = "set";
   501 fun mk_setN i = setN ^ nonzero_string_of_int i;
   502 val bdN = "bd";
   503 val witN = "wit";
   504 fun mk_witN i = witN ^ nonzero_string_of_int i;
   505 val relN = "rel";
   506 val srelN = "srel";
   507 
   508 val bd_card_orderN = "bd_card_order";
   509 val bd_cinfiniteN = "bd_cinfinite";
   510 val bd_Card_orderN = "bd_Card_order";
   511 val bd_CinfiniteN = "bd_Cinfinite";
   512 val bd_CnotzeroN = "bd_Cnotzero";
   513 val collect_set_mapN = "collect_set_map";
   514 val in_bdN = "in_bd";
   515 val in_monoN = "in_mono";
   516 val in_srelN = "in_srel";
   517 val map_idN = "map_id";
   518 val map_id'N = "map_id'";
   519 val map_compN = "map_comp";
   520 val map_comp'N = "map_comp'";
   521 val map_cong0N = "map_cong0";
   522 val map_congN = "map_cong";
   523 val map_wpullN = "map_wpull";
   524 val rel_eqN = "rel_eq";
   525 val rel_flipN = "rel_flip";
   526 val rel_srelN = "rel_srel";
   527 val set_mapN = "set_map";
   528 val set_map'N = "set_map'";
   529 val set_bdN = "set_bd";
   530 val srel_IdN = "srel_Id";
   531 val srel_GrN = "srel_Gr";
   532 val srel_converseN = "srel_converse";
   533 val srel_monoN = "srel_mono"
   534 val srel_ON = "srel_comp";
   535 val srel_O_GrN = "srel_comp_Gr";
   536 
   537 datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
   538 
   539 datatype fact_policy = Dont_Note | Note_Some | Note_All;
   540 
   541 val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
   542 
   543 fun user_policy policy ctxt = if Config.get ctxt bnf_note_all then Note_All else policy;
   544 
   545 val smart_max_inline_size = 25; (*FUDGE*)
   546 
   547 
   548 (* Define new BNFs *)
   549 
   550 fun prepare_def const_policy mk_fact_policy qualify prep_term Ds_opt map_b rel_b set_bs
   551   (((((raw_b, raw_map), raw_sets), raw_bd_Abs), raw_wits), raw_rel_opt) no_defs_lthy =
   552   let
   553     val fact_policy = mk_fact_policy no_defs_lthy;
   554     val b = qualify raw_b;
   555     val live = length raw_sets;
   556     val nwits = length raw_wits;
   557 
   558     val map_rhs = prep_term no_defs_lthy raw_map;
   559     val set_rhss = map (prep_term no_defs_lthy) raw_sets;
   560     val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
   561       Abs (_, T, t) => (T, t)
   562     | _ => error "Bad bound constant");
   563     val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
   564 
   565     fun err T =
   566       error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
   567         " as unnamed BNF");
   568 
   569     val (b, key) =
   570       if Binding.eq_name (b, Binding.empty) then
   571         (case bd_rhsT of
   572           Type (C, Ts) => if forall (is_some o try dest_TFree) Ts
   573             then (Binding.qualified_name C, C) else err bd_rhsT
   574         | T => err T)
   575       else (b, Local_Theory.full_name no_defs_lthy b);
   576 
   577     fun maybe_define user_specified (b, rhs) lthy =
   578       let
   579         val inline =
   580           (user_specified orelse fact_policy = Dont_Note) andalso
   581           (case const_policy of
   582             Dont_Inline => false
   583           | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
   584           | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_size
   585           | Do_Inline => true)
   586       in
   587         if inline then
   588           ((rhs, Drule.reflexive_thm), lthy)
   589         else
   590           let val b = b () in
   591             apfst (apsnd snd) (Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), rhs))
   592               lthy)
   593           end
   594       end;
   595 
   596     fun maybe_restore lthy_old lthy =
   597       lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
   598 
   599     val map_bind_def =
   600       (fn () => if Binding.is_empty map_b then Binding.suffix_name ("_" ^ mapN) b else map_b,
   601        map_rhs);
   602     val set_binds_defs =
   603       let
   604         fun set_name i get_b =
   605           (case try (nth set_bs) (i - 1) of
   606             SOME b => if Binding.is_empty b then get_b else K b
   607           | NONE => get_b);
   608         val bs =
   609           if live = 1 then
   610             [set_name 1 (fn () => Binding.suffix_name ("_" ^ setN) b)]
   611           else
   612             map (fn i => set_name i (fn () => Binding.suffix_name ("_" ^ mk_setN i) b))
   613               (1 upto live);
   614       in bs ~~ set_rhss end;
   615     val bd_bind_def = (fn () => Binding.suffix_name ("_" ^ bdN) b, bd_rhs);
   616     val wit_binds_defs =
   617       let
   618         val bs = if nwits = 1 then [fn () => Binding.suffix_name ("_" ^ witN) b]
   619           else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_witN i) b) (1 upto nwits);
   620       in bs ~~ wit_rhss end;
   621 
   622     val (((((bnf_map_term, raw_map_def),
   623       (bnf_set_terms, raw_set_defs)),
   624       (bnf_bd_term, raw_bd_def)),
   625       (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
   626         no_defs_lthy
   627         |> maybe_define true map_bind_def
   628         ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
   629         ||>> maybe_define true bd_bind_def
   630         ||>> apfst split_list o fold_map (maybe_define true) wit_binds_defs
   631         ||> `(maybe_restore no_defs_lthy);
   632 
   633     val phi = Proof_Context.export_morphism lthy_old lthy;
   634 
   635     val bnf_map_def = Morphism.thm phi raw_map_def;
   636     val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
   637     val bnf_bd_def = Morphism.thm phi raw_bd_def;
   638     val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
   639 
   640     val bnf_map = Morphism.term phi bnf_map_term;
   641 
   642     (*TODO: handle errors*)
   643     (*simple shape analysis of a map function*)
   644     val ((alphas, betas), (CA, _)) =
   645       fastype_of bnf_map
   646       |> strip_typeN live
   647       |>> map_split dest_funT
   648       ||> dest_funT
   649       handle TYPE _ => error "Bad map function";
   650 
   651     val CA_params = map TVar (Term.add_tvarsT CA []);
   652 
   653     val bnf_sets = map2 (normalize_set CA_params) alphas (map (Morphism.term phi) bnf_set_terms);
   654     val bdT = Morphism.typ phi bd_rhsT;
   655     val bnf_bd =
   656       Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
   657     val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
   658 
   659     (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
   660     val deads = (case Ds_opt of
   661       NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
   662     | SOME Ds => map (Morphism.typ phi) Ds);
   663     val dead = length deads;
   664 
   665     (*TODO: further checks of type of bnf_map*)
   666     (*TODO: check types of bnf_sets*)
   667     (*TODO: check type of bnf_bd*)
   668     (*TODO: check type of bnf_rel*)
   669 
   670     val ((((((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), domTs), ranTs), ranTs'), ranTs''),
   671       (Ts, T)) = lthy
   672       |> mk_TFrees live
   673       ||>> mk_TFrees live
   674       ||>> mk_TFrees live
   675       ||>> mk_TFrees dead
   676       ||>> mk_TFrees live
   677       ||>> mk_TFrees live
   678       ||>> mk_TFrees live
   679       ||>> mk_TFrees live
   680       ||>> mk_TFrees live
   681       ||>> mk_TFrees live
   682       ||> fst o mk_TFrees 1
   683       ||> the_single
   684       ||> `(replicate live);
   685 
   686     fun mk_bnf_map As' Bs' =
   687       Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
   688     fun mk_bnf_t As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
   689     fun mk_bnf_T As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
   690 
   691     val (setRTs, RTs) = map_split (`HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Bs');
   692     val setRTsAsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Cs);
   693     val setRTsBsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ Cs);
   694     val setRT's = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ As');
   695     val self_setRTs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ As');
   696     val QTs = map2 mk_pred2T As' Bs';
   697 
   698     val CA' = mk_bnf_T As' CA;
   699     val CB' = mk_bnf_T Bs' CA;
   700     val CC' = mk_bnf_T Cs CA;
   701     val CRs' = mk_bnf_T RTs CA;
   702     val CA'CB' = HOLogic.mk_prodT (CA', CB');
   703 
   704     val bnf_map_AsAs = mk_bnf_map As' As';
   705     val bnf_map_AsBs = mk_bnf_map As' Bs';
   706     val bnf_map_AsCs = mk_bnf_map As' Cs;
   707     val bnf_map_BsCs = mk_bnf_map Bs' Cs;
   708     val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
   709     val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
   710     val bnf_bd_As = mk_bnf_t As' bnf_bd;
   711     val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
   712 
   713     val pre_names_lthy = lthy;
   714     val ((((((((((((((((((((((((fs, gs), hs), p), (x, x')), (y, y')), (z, z')), zs), As),
   715       As_copy), Xs), B1s), B2s), f1s), f2s), e1s), e2s), p1s), p2s), bs), (Rs, Rs')), Rs_copy), Ss),
   716       (Qs, Qs')), names_lthy) = pre_names_lthy
   717       |> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
   718       ||>> mk_Frees "g" (map2 (curry (op -->)) Bs' Cs)
   719       ||>> mk_Frees "h" (map2 (curry (op -->)) As' Ts)
   720       ||>> yield_singleton (mk_Frees "p") CA'CB'
   721       ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "x") CA'
   722       ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "y") CB'
   723       ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "z") CRs'
   724       ||>> mk_Frees "z" As'
   725       ||>> mk_Frees "A" (map HOLogic.mk_setT As')
   726       ||>> mk_Frees "A" (map HOLogic.mk_setT As')
   727       ||>> mk_Frees "A" (map HOLogic.mk_setT domTs)
   728       ||>> mk_Frees "B1" (map HOLogic.mk_setT B1Ts)
   729       ||>> mk_Frees "B2" (map HOLogic.mk_setT B2Ts)
   730       ||>> mk_Frees "f1" (map2 (curry (op -->)) B1Ts ranTs)
   731       ||>> mk_Frees "f2" (map2 (curry (op -->)) B2Ts ranTs)
   732       ||>> mk_Frees "e1" (map2 (curry (op -->)) B1Ts ranTs')
   733       ||>> mk_Frees "e2" (map2 (curry (op -->)) B2Ts ranTs'')
   734       ||>> mk_Frees "p1" (map2 (curry (op -->)) domTs B1Ts)
   735       ||>> mk_Frees "p2" (map2 (curry (op -->)) domTs B2Ts)
   736       ||>> mk_Frees "b" As'
   737       ||>> mk_Frees' "r" setRTs
   738       ||>> mk_Frees "r" setRTs
   739       ||>> mk_Frees "s" setRTsBsCs
   740       ||>> mk_Frees' "P" QTs;
   741 
   742     val fs_copy = map2 (retype_free o fastype_of) fs gs;
   743     val x_copy = retype_free CA' y;
   744 
   745     (*Gr (in R1 .. Rn) (map fst .. fst)^-1 O Gr (in R1 .. Rn) (map snd .. snd)*)
   746     val O_Gr =
   747       let
   748         val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
   749         val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
   750         val bnf_in = mk_in (map Free Rs') (map (mk_bnf_t RTs) bnf_sets) CRs';
   751       in
   752         mk_rel_comp (mk_converse (mk_Gr bnf_in map1), mk_Gr bnf_in map2)
   753       end;
   754 
   755     fun mk_predicate_of_set x_name y_name t =
   756       let
   757         val (T, U) = HOLogic.dest_prodT (HOLogic.dest_setT (fastype_of t));
   758         val x = Free (x_name, T);
   759         val y = Free (y_name, U);
   760       in fold_rev Term.lambda [x, y] (HOLogic.mk_mem (HOLogic.mk_prod (x, y), t)) end;
   761 
   762     val sQs =
   763       map3 (fn Q => fn T => fn U =>
   764           HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split Q) Qs As' Bs';
   765 
   766     val rel_rhs = (case raw_rel_opt of
   767         NONE =>
   768         fold_rev absfree Qs' (mk_predicate_of_set (fst x') (fst y')
   769           (Term.list_comb (fold_rev Term.absfree Rs' O_Gr, sQs)))
   770       | SOME raw_rel => prep_term no_defs_lthy raw_rel);
   771 
   772     val rel_bind_def =
   773       (fn () => if Binding.is_empty rel_b then Binding.suffix_name ("_" ^ relN) b else rel_b,
   774        rel_rhs);
   775 
   776     val ((bnf_rel_term, raw_rel_def), (lthy, lthy_old)) =
   777       lthy
   778       |> maybe_define (is_some raw_rel_opt) rel_bind_def
   779       ||> `(maybe_restore lthy);
   780 
   781     val phi = Proof_Context.export_morphism lthy_old lthy;
   782     val bnf_rel_def = Morphism.thm phi raw_rel_def;
   783     val bnf_rel = Morphism.term phi bnf_rel_term;
   784 
   785     fun mk_bnf_rel QTs CA' CB' = normalize_rel lthy QTs CA' CB' bnf_rel;
   786 
   787     val rel = mk_bnf_rel QTs CA' CB';
   788 
   789     val srel_rhs =
   790       fold_rev Term.absfree Rs' (HOLogic.Collect_const CA'CB' $
   791         Term.lambda p (Term.list_comb (rel, map (mk_predicate_of_set (fst x') (fst y')) Rs) $
   792         HOLogic.mk_fst p $ HOLogic.mk_snd p));
   793 
   794     val srel_bind_def = (fn () => Binding.suffix_name ("_" ^ srelN) b, srel_rhs);
   795 
   796     val ((bnf_srel_term, raw_srel_def), (lthy, lthy_old)) =
   797       lthy
   798       |> maybe_define false srel_bind_def
   799       ||> `(maybe_restore lthy);
   800 
   801     val phi = Proof_Context.export_morphism lthy_old lthy;
   802     val bnf_srel_def = Morphism.thm phi raw_srel_def;
   803     val bnf_srel = Morphism.term phi bnf_srel_term;
   804 
   805     fun mk_bnf_srel setRTs CA' CB' = normalize_srel lthy setRTs CA' CB' bnf_srel;
   806 
   807     val srel = mk_bnf_srel setRTs CA' CB';
   808 
   809     val _ = case no_reflexive (raw_map_def :: raw_set_defs @ [raw_bd_def] @
   810         raw_wit_defs @ [raw_rel_def, raw_srel_def]) of
   811         [] => ()
   812       | defs => Proof_Display.print_consts true lthy_old (K false)
   813           (map (dest_Free o fst o Logic.dest_equals o prop_of) defs);
   814 
   815     val map_id_goal =
   816       let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
   817         mk_Trueprop_eq (bnf_map_app_id, HOLogic.id_const CA')
   818       end;
   819 
   820     val map_comp_goal =
   821       let
   822         val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
   823         val comp_bnf_map_app = HOLogic.mk_comp
   824           (Term.list_comb (bnf_map_BsCs, gs), Term.list_comb (bnf_map_AsBs, fs));
   825       in
   826         fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
   827       end;
   828 
   829     fun mk_map_cong_prem x z set f f_copy =
   830       Logic.all z (Logic.mk_implies
   831         (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
   832         mk_Trueprop_eq (f $ z, f_copy $ z)));
   833 
   834     val map_cong0_goal =
   835       let
   836         val prems = map4 (mk_map_cong_prem x) zs bnf_sets_As fs fs_copy;
   837         val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
   838           Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
   839       in
   840         fold_rev Logic.all (x :: fs @ fs_copy) (Logic.list_implies (prems, eq))
   841       end;
   842 
   843     val set_maps_goal =
   844       let
   845         fun mk_goal setA setB f =
   846           let
   847             val set_comp_map =
   848               HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
   849             val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
   850           in
   851             fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
   852           end;
   853       in
   854         map3 mk_goal bnf_sets_As bnf_sets_Bs fs
   855       end;
   856 
   857     val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
   858 
   859     val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
   860 
   861     val set_bds_goal =
   862       let
   863         fun mk_goal set =
   864           Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
   865       in
   866         map mk_goal bnf_sets_As
   867       end;
   868 
   869     val in_bd_goal =
   870       let
   871         val bd = mk_cexp
   872           (if live = 0 then ctwo
   873             else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
   874           bnf_bd_As;
   875       in
   876         fold_rev Logic.all As
   877           (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd))
   878       end;
   879 
   880     val map_wpull_goal =
   881       let
   882         val prems = map HOLogic.mk_Trueprop
   883           (map8 mk_wpull Xs B1s B2s f1s f2s (replicate live NONE) p1s p2s);
   884         val CX = mk_bnf_T domTs CA;
   885         val CB1 = mk_bnf_T B1Ts CA;
   886         val CB2 = mk_bnf_T B2Ts CA;
   887         val bnf_sets_CX = map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
   888         val bnf_sets_CB1 = map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
   889         val bnf_sets_CB2 = map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
   890         val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
   891         val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
   892         val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
   893         val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
   894 
   895         val map_wpull = mk_wpull (mk_in Xs bnf_sets_CX CX)
   896           (mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
   897           bnf_map_app_f1 bnf_map_app_f2 NONE bnf_map_app_p1 bnf_map_app_p2;
   898       in
   899         fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
   900           (Logic.list_implies (prems, HOLogic.mk_Trueprop map_wpull))
   901       end;
   902 
   903     val srel_O_Gr_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (srel, Rs), O_Gr));
   904 
   905     val goals = zip_axioms map_id_goal map_comp_goal map_cong0_goal set_maps_goal card_order_bd_goal
   906       cinfinite_bd_goal set_bds_goal in_bd_goal map_wpull_goal srel_O_Gr_goal;
   907 
   908     fun mk_wit_goals (I, wit) =
   909       let
   910         val xs = map (nth bs) I;
   911         fun wit_goal i =
   912           let
   913             val z = nth zs i;
   914             val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
   915             val concl = HOLogic.mk_Trueprop
   916               (if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
   917               else @{term False});
   918           in
   919             fold_rev Logic.all (z :: xs)
   920               (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
   921           end;
   922       in
   923         map wit_goal (0 upto live - 1)
   924       end;
   925 
   926     val wit_goalss = map mk_wit_goals bnf_wit_As;
   927 
   928     fun after_qed thms lthy =
   929       let
   930         val (axioms, wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
   931 
   932         val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
   933         val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
   934         val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
   935 
   936         fun mk_collect_set_map () =
   937           let
   938             val defT = mk_bnf_T Ts CA --> HOLogic.mk_setT T;
   939             val collect_map = HOLogic.mk_comp
   940               (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
   941               Term.list_comb (mk_bnf_map As' Ts, hs));
   942             val image_collect = mk_collect
   943               (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
   944               defT;
   945             (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
   946             val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
   947           in
   948             Goal.prove_sorry lthy [] [] goal (K (mk_collect_set_map_tac (#set_map axioms)))
   949             |> Thm.close_derivation
   950           end;
   951 
   952         val collect_set_map = Lazy.lazy mk_collect_set_map;
   953 
   954         fun mk_in_mono () =
   955           let
   956             val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_subset) As As_copy;
   957             val in_mono_goal =
   958               fold_rev Logic.all (As @ As_copy)
   959                 (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
   960                   (mk_subset (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
   961           in
   962             Goal.prove_sorry lthy [] [] in_mono_goal (K (mk_in_mono_tac live))
   963             |> Thm.close_derivation
   964           end;
   965 
   966         val in_mono = Lazy.lazy mk_in_mono;
   967 
   968         fun mk_in_cong () =
   969           let
   970             val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy;
   971             val in_cong_goal =
   972               fold_rev Logic.all (As @ As_copy)
   973                 (Logic.list_implies (prems_cong,
   974                   mk_Trueprop_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA')));
   975           in
   976             Goal.prove_sorry lthy [] [] in_cong_goal
   977               (K ((TRY o hyp_subst_tac lthy THEN' rtac refl) 1))
   978             |> Thm.close_derivation
   979           end;
   980 
   981         val in_cong = Lazy.lazy mk_in_cong;
   982 
   983         val map_id' = Lazy.lazy (fn () => mk_map_id' (#map_id axioms));
   984         val map_comp' = Lazy.lazy (fn () => mk_map_comp' (#map_comp axioms));
   985 
   986         fun mk_map_cong () =
   987           let
   988             val prem0 = mk_Trueprop_eq (x, x_copy);
   989             val prems = map4 (mk_map_cong_prem x_copy) zs bnf_sets_As fs fs_copy;
   990             val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
   991               Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
   992             val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
   993               (Logic.list_implies (prem0 :: prems, eq));
   994           in
   995             Goal.prove_sorry lthy [] [] goal (fn _ => mk_map_cong_tac lthy (#map_cong0 axioms))
   996             |> Thm.close_derivation
   997           end;
   998 
   999         val map_cong = Lazy.lazy mk_map_cong;
  1000 
  1001         val set_map' = map (fn thm => Lazy.lazy (fn () => mk_set_map' thm)) (#set_map axioms);
  1002 
  1003         fun mk_map_wppull () =
  1004           let
  1005             val prems = if live = 0 then [] else
  1006               [HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
  1007                 (map8 mk_wpull Xs B1s B2s f1s f2s (map SOME (e1s ~~ e2s)) p1s p2s))];
  1008             val CX = mk_bnf_T domTs CA;
  1009             val CB1 = mk_bnf_T B1Ts CA;
  1010             val CB2 = mk_bnf_T B2Ts CA;
  1011             val bnf_sets_CX =
  1012               map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
  1013             val bnf_sets_CB1 =
  1014               map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
  1015             val bnf_sets_CB2 =
  1016               map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
  1017             val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
  1018             val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
  1019             val bnf_map_app_e1 = Term.list_comb (mk_bnf_map B1Ts ranTs', e1s);
  1020             val bnf_map_app_e2 = Term.list_comb (mk_bnf_map B2Ts ranTs'', e2s);
  1021             val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
  1022             val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
  1023 
  1024             val concl = mk_wpull (mk_in Xs bnf_sets_CX CX)
  1025               (mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
  1026               bnf_map_app_f1 bnf_map_app_f2 (SOME (bnf_map_app_e1, bnf_map_app_e2))
  1027               bnf_map_app_p1 bnf_map_app_p2;
  1028 
  1029             val goal =
  1030               fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ e1s @ e2s @ p1s @ p2s)
  1031                 (Logic.list_implies (prems, HOLogic.mk_Trueprop concl))
  1032           in
  1033             Goal.prove_sorry lthy [] [] goal
  1034               (fn _ => mk_map_wppull_tac (#map_id axioms) (#map_cong0 axioms)
  1035                 (#map_wpull axioms) (Lazy.force map_comp') (map Lazy.force set_map'))
  1036             |> Thm.close_derivation
  1037           end;
  1038 
  1039         val map_wppull = Lazy.lazy mk_map_wppull;
  1040 
  1041         val srel_O_Grs = no_refl [#srel_O_Gr axioms];
  1042 
  1043         fun mk_srel_Gr () =
  1044           let
  1045             val lhs = Term.list_comb (srel, map2 mk_Gr As fs);
  1046             val rhs = mk_Gr (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
  1047             val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
  1048           in
  1049             Goal.prove_sorry lthy [] [] goal
  1050               (mk_srel_Gr_tac srel_O_Grs (#map_id axioms) (#map_cong0 axioms) (Lazy.force map_id')
  1051                 (Lazy.force map_comp') (map Lazy.force set_map'))
  1052             |> Thm.close_derivation
  1053           end;
  1054 
  1055         val srel_Gr = Lazy.lazy mk_srel_Gr;
  1056 
  1057         fun mk_srel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
  1058         fun mk_srel_concl f = HOLogic.mk_Trueprop
  1059           (f (Term.list_comb (srel, Rs), Term.list_comb (srel, Rs_copy)));
  1060 
  1061         fun mk_srel_mono () =
  1062           let
  1063             val mono_prems = mk_srel_prems mk_subset;
  1064             val mono_concl = mk_srel_concl (uncurry mk_subset);
  1065           in
  1066             Goal.prove_sorry lthy [] []
  1067               (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
  1068               (mk_srel_mono_tac srel_O_Grs (Lazy.force in_mono))
  1069             |> Thm.close_derivation
  1070           end;
  1071 
  1072         fun mk_srel_cong () =
  1073           let
  1074             val cong_prems = mk_srel_prems (curry HOLogic.mk_eq);
  1075             val cong_concl = mk_srel_concl HOLogic.mk_eq;
  1076           in
  1077             Goal.prove_sorry lthy [] []
  1078               (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
  1079               (fn _ => (TRY o hyp_subst_tac lthy THEN' rtac refl) 1)
  1080             |> Thm.close_derivation
  1081           end;
  1082 
  1083         val srel_mono = Lazy.lazy mk_srel_mono;
  1084         val srel_cong = Lazy.lazy mk_srel_cong;
  1085 
  1086         fun mk_srel_Id () =
  1087           let val srelAsAs = mk_bnf_srel self_setRTs CA' CA' in
  1088             Goal.prove_sorry lthy [] []
  1089               (mk_Trueprop_eq (Term.list_comb (srelAsAs, map Id_const As'), Id_const CA'))
  1090               (mk_srel_Id_tac live (Lazy.force srel_Gr) (#map_id axioms))
  1091             |> Thm.close_derivation
  1092           end;
  1093 
  1094         val srel_Id = Lazy.lazy mk_srel_Id;
  1095 
  1096         fun mk_srel_converse () =
  1097           let
  1098             val srelBsAs = mk_bnf_srel setRT's CB' CA';
  1099             val lhs = Term.list_comb (srelBsAs, map mk_converse Rs);
  1100             val rhs = mk_converse (Term.list_comb (srel, Rs));
  1101             val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_subset lhs rhs));
  1102             val le_thm = Goal.prove_sorry lthy [] [] le_goal
  1103               (mk_srel_converse_le_tac srel_O_Grs (Lazy.force srel_Id) (#map_cong0 axioms)
  1104                 (Lazy.force map_comp') (map Lazy.force set_map'))
  1105               |> Thm.close_derivation
  1106             val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
  1107           in
  1108             Goal.prove_sorry lthy [] [] goal (fn _ => mk_srel_converse_tac le_thm)
  1109             |> Thm.close_derivation
  1110           end;
  1111 
  1112         val srel_converse = Lazy.lazy mk_srel_converse;
  1113 
  1114         fun mk_srel_O () =
  1115           let
  1116             val srelAsCs = mk_bnf_srel setRTsAsCs CA' CC';
  1117             val srelBsCs = mk_bnf_srel setRTsBsCs CB' CC';
  1118             val lhs = Term.list_comb (srelAsCs, map2 (curry mk_rel_comp) Rs Ss);
  1119             val rhs = mk_rel_comp (Term.list_comb (srel, Rs), Term.list_comb (srelBsCs, Ss));
  1120             val goal = fold_rev Logic.all (Rs @ Ss) (mk_Trueprop_eq (lhs, rhs));
  1121           in
  1122             Goal.prove_sorry lthy [] [] goal
  1123               (mk_srel_O_tac srel_O_Grs (Lazy.force srel_Id) (#map_cong0 axioms)
  1124                 (Lazy.force map_wppull) (Lazy.force map_comp') (map Lazy.force set_map'))
  1125             |> Thm.close_derivation
  1126           end;
  1127 
  1128         val srel_O = Lazy.lazy mk_srel_O;
  1129 
  1130         fun mk_in_srel () =
  1131           let
  1132             val bnf_in = mk_in Rs (map (mk_bnf_t RTs) bnf_sets) CRs';
  1133             val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
  1134             val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
  1135             val map_fst_eq = HOLogic.mk_eq (map1 $ z, x);
  1136             val map_snd_eq = HOLogic.mk_eq (map2 $ z, y);
  1137             val lhs = HOLogic.mk_mem (HOLogic.mk_prod (x, y), Term.list_comb (srel, Rs));
  1138             val rhs =
  1139               HOLogic.mk_exists (fst z', snd z', HOLogic.mk_conj (HOLogic.mk_mem (z, bnf_in),
  1140                 HOLogic.mk_conj (map_fst_eq, map_snd_eq)));
  1141             val goal =
  1142               fold_rev Logic.all (x :: y :: Rs) (mk_Trueprop_eq (lhs, rhs));
  1143           in
  1144             Goal.prove_sorry lthy [] [] goal (mk_in_srel_tac srel_O_Grs (length bnf_sets))
  1145             |> Thm.close_derivation
  1146           end;
  1147 
  1148         val in_srel = Lazy.lazy mk_in_srel;
  1149 
  1150         val eqset_imp_iff_pair = @{thm eqset_imp_iff_pair};
  1151         val mem_Collect_etc = @{thms fst_conv mem_Collect_eq prod.cases snd_conv};
  1152         val mem_Collect_etc' = @{thms fst_conv mem_Collect_eq pair_in_Id_conv snd_conv};
  1153 
  1154         fun mk_rel_srel () =
  1155           unfold_thms lthy mem_Collect_etc
  1156             (funpow live (fn thm => thm RS @{thm fun_cong_pair}) (bnf_srel_def RS meta_eq_to_obj_eq)
  1157                RS eqset_imp_iff_pair RS sym)
  1158           |> Drule.zero_var_indexes;
  1159 
  1160         val rel_srel = Lazy.lazy mk_rel_srel;
  1161 
  1162         fun mk_rel_eq () =
  1163           unfold_thms lthy (bnf_srel_def :: mem_Collect_etc')
  1164             (Lazy.force srel_Id RS @{thm arg_cong[of _ _ "%A x y. (x, y) : A"]})
  1165           |> Drule.eta_contraction_rule;
  1166 
  1167         val rel_eq = Lazy.lazy mk_rel_eq;
  1168 
  1169         fun mk_rel_flip () =
  1170           let
  1171             val srel_converse_thm = Lazy.force srel_converse;
  1172             val cts = map (SOME o certify lthy) sQs;
  1173             val srel_converse_thm' = cterm_instantiate_pos cts srel_converse_thm;
  1174           in
  1175             unfold_thms lthy (bnf_srel_def :: @{thm converse_iff} :: mem_Collect_etc)
  1176               (srel_converse_thm' RS eqset_imp_iff_pair)
  1177             |> singleton (Proof_Context.export names_lthy pre_names_lthy)
  1178           end;
  1179 
  1180         val rel_flip = Lazy.lazy mk_rel_flip;
  1181 
  1182         val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def bnf_srel_def;
  1183 
  1184         val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_cong in_mono
  1185           in_srel map_comp' map_cong map_id' map_wppull rel_eq rel_flip rel_srel set_map'
  1186           srel_cong srel_mono srel_Id srel_Gr srel_converse srel_O;
  1187 
  1188         val wits = map2 mk_witness bnf_wits wit_thms;
  1189 
  1190         val bnf_rel =
  1191           Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
  1192         val bnf_srel =
  1193           Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) srel;
  1194 
  1195         val bnf = mk_bnf b CA live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms defs facts
  1196           wits bnf_rel bnf_srel;
  1197       in
  1198         (bnf, lthy
  1199           |> (if fact_policy = Note_All then
  1200                 let
  1201                   val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
  1202                   val notes =
  1203                     [(bd_card_orderN, [#bd_card_order axioms]),
  1204                     (bd_cinfiniteN, [#bd_cinfinite axioms]),
  1205                     (bd_Card_orderN, [#bd_Card_order facts]),
  1206                     (bd_CinfiniteN, [#bd_Cinfinite facts]),
  1207                     (bd_CnotzeroN, [#bd_Cnotzero facts]),
  1208                     (collect_set_mapN, [Lazy.force (#collect_set_map facts)]),
  1209                     (in_bdN, [#in_bd axioms]),
  1210                     (in_monoN, [Lazy.force (#in_mono facts)]),
  1211                     (in_srelN, [Lazy.force (#in_srel facts)]),
  1212                     (map_compN, [#map_comp axioms]),
  1213                     (map_idN, [#map_id axioms]),
  1214                     (map_wpullN, [#map_wpull axioms]),
  1215                     (set_mapN, #set_map axioms),
  1216                     (set_bdN, #set_bd axioms)] @
  1217                     (witNs ~~ wit_thms)
  1218                     |> map (fn (thmN, thms) =>
  1219                       ((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
  1220                       [(thms, [])]));
  1221                 in
  1222                   Local_Theory.notes notes #> snd
  1223                 end
  1224               else
  1225                 I)
  1226           |> (if fact_policy <> Dont_Note then
  1227                 let
  1228                   val notes =
  1229                     [(map_comp'N, [Lazy.force (#map_comp' facts)], []),
  1230                     (map_cong0N, [#map_cong0 axioms], []),
  1231                     (map_congN, [Lazy.force (#map_cong facts)], fundef_cong_attrs),
  1232                     (map_id'N, [Lazy.force (#map_id' facts)], []),
  1233                     (rel_eqN, [Lazy.force (#rel_eq facts)], []),
  1234                     (rel_flipN, [Lazy.force (#rel_flip facts)], []),
  1235                     (rel_srelN, [Lazy.force (#rel_srel facts)], []),
  1236                     (set_map'N, map Lazy.force (#set_map' facts), []),
  1237                     (srel_O_GrN, srel_O_Grs, []),
  1238                     (srel_IdN, [Lazy.force (#srel_Id facts)], []),
  1239                     (srel_GrN, [Lazy.force (#srel_Gr facts)], []),
  1240                     (srel_converseN, [Lazy.force (#srel_converse facts)], []),
  1241                     (srel_monoN, [Lazy.force (#srel_mono facts)], []),
  1242                     (srel_ON, [Lazy.force (#srel_O facts)], [])]
  1243                     |> filter_out (null o #2)
  1244                     |> map (fn (thmN, thms, attrs) =>
  1245                       ((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)),
  1246                         attrs), [(thms, [])]));
  1247                 in
  1248                   Local_Theory.notes notes #> snd
  1249                 end
  1250               else
  1251                 I))
  1252       end;
  1253 
  1254     val one_step_defs =
  1255       no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ [bnf_rel_def,
  1256         bnf_srel_def]);
  1257   in
  1258     (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
  1259   end;
  1260 
  1261 fun register_bnf key (bnf, lthy) =
  1262   (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
  1263     (fn phi => Data.map (Symtab.update_new (key, morph_bnf phi bnf))) lthy);
  1264 
  1265 (* TODO: Once the invariant "nwits > 0" holds, remove "mk_conjunction_balanced'" and "rtac TrueI"
  1266    below *)
  1267 fun mk_conjunction_balanced' [] = @{prop True}
  1268   | mk_conjunction_balanced' ts = Logic.mk_conjunction_balanced ts;
  1269 
  1270 fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds map_b rel_b set_bs =
  1271   (fn (_, goals, wit_goalss, after_qed, lthy, one_step_defs) =>
  1272   let
  1273     val wits_tac =
  1274       K (TRYALL Goal.conjunction_tac) THEN' K (TRYALL (rtac TrueI)) THEN'
  1275       mk_unfold_thms_then_tac lthy one_step_defs wit_tac;
  1276     val wit_goals = map mk_conjunction_balanced' wit_goalss;
  1277     val wit_thms =
  1278       Goal.prove_sorry lthy [] [] (mk_conjunction_balanced' wit_goals) wits_tac
  1279       |> Conjunction.elim_balanced (length wit_goals)
  1280       |> map2 (Conjunction.elim_balanced o length) wit_goalss
  1281       |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  1282   in
  1283     map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
  1284       goals (map (mk_unfold_thms_then_tac lthy one_step_defs) tacs)
  1285     |> (fn thms => after_qed (map single thms @ wit_thms) lthy)
  1286   end) oo prepare_def const_policy fact_policy qualify (K I) Ds map_b rel_b set_bs;
  1287 
  1288 val bnf_cmd = (fn (key, goals, wit_goals, after_qed, lthy, defs) =>
  1289   Proof.unfolding ([[(defs, [])]])
  1290     (Proof.theorem NONE (snd o register_bnf key oo after_qed)
  1291       (map (single o rpair []) goals @ map (map (rpair [])) wit_goals) lthy)) oo
  1292   prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_term NONE Binding.empty Binding.empty
  1293     [];
  1294 
  1295 fun print_bnfs ctxt =
  1296   let
  1297     fun pretty_set sets i = Pretty.block
  1298       [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
  1299           Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
  1300 
  1301     fun pretty_bnf (key, BNF {T = T, map = map, sets = sets, bd = bd,
  1302       live = live, lives = lives, dead = dead, deads = deads, ...}) =
  1303       Pretty.big_list
  1304         (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
  1305           Pretty.quote (Syntax.pretty_typ ctxt T)]))
  1306         ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
  1307             Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
  1308           Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
  1309             Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
  1310           Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
  1311             Pretty.quote (Syntax.pretty_term ctxt map)]] @
  1312           List.map (pretty_set sets) (0 upto length sets - 1) @
  1313           [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
  1314             Pretty.quote (Syntax.pretty_term ctxt bd)]]);
  1315   in
  1316     Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
  1317     |> Pretty.writeln
  1318   end;
  1319 
  1320 val _ =
  1321   Outer_Syntax.improper_command @{command_spec "print_bnfs"}
  1322     "print all BNFs (bounded natural functors)"
  1323     (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
  1324 
  1325 val _ =
  1326   Outer_Syntax.local_theory_to_proof @{command_spec "bnf"}
  1327     "register a type as a BNF (bounded natural functor)"
  1328     ((parse_opt_binding_colon -- Parse.term --
  1329        (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Parse.term --
  1330        (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Scan.option Parse.term)
  1331        >> bnf_cmd);
  1332 
  1333 end;