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