1 (* Title: HOL/Codatatype/Tools/bnf_def.ML
2 Author: Dmitriy Traytel, TU Muenchen
3 Author: Jasmin Blanchette, TU Muenchen
6 Definition of bounded natural functors.
12 type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
14 val bnf_of: Proof.context -> string -> BNF option
15 val name_of_bnf: BNF -> binding
16 val T_of_bnf: BNF -> typ
17 val live_of_bnf: BNF -> int
18 val lives_of_bnf: BNF -> typ list
19 val dead_of_bnf: BNF -> int
20 val deads_of_bnf: BNF -> typ list
21 val nwits_of_bnf: BNF -> int
27 val mk_setN: int -> string
28 val rel_unfoldN: string
29 val pred_unfoldN: string
31 val mk_T_of_bnf: typ list -> typ list -> BNF -> typ
32 val mk_bd_of_bnf: typ list -> typ list -> BNF -> term
33 val mk_map_of_bnf: typ list -> typ list -> typ list -> BNF -> term
34 val mk_pred_of_bnf: typ list -> typ list -> typ list -> BNF -> term
35 val mk_rel_of_bnf: typ list -> typ list -> typ list -> BNF -> term
36 val mk_sets_of_bnf: typ list list -> typ list list -> BNF -> term list
37 val mk_wits_of_bnf: typ list list -> typ list list -> BNF -> (int list * term) list
39 val bd_Card_order_of_bnf: BNF -> thm
40 val bd_Cinfinite_of_bnf: BNF -> thm
41 val bd_Cnotzero_of_bnf: BNF -> thm
42 val bd_card_order_of_bnf: BNF -> thm
43 val bd_cinfinite_of_bnf: BNF -> thm
44 val collect_set_natural_of_bnf: BNF -> thm
45 val in_bd_of_bnf: BNF -> thm
46 val in_cong_of_bnf: BNF -> thm
47 val in_mono_of_bnf: BNF -> thm
48 val in_rel_of_bnf: BNF -> thm
49 val map_comp'_of_bnf: BNF -> thm
50 val map_comp_of_bnf: BNF -> thm
51 val map_cong_of_bnf: BNF -> thm
52 val map_def_of_bnf: BNF -> thm
53 val map_id'_of_bnf: BNF -> thm
54 val map_id_of_bnf: BNF -> thm
55 val map_wppull_of_bnf: BNF -> thm
56 val map_wpull_of_bnf: BNF -> thm
57 val pred_def_of_bnf: BNF -> thm
58 val rel_Gr_of_bnf: BNF -> thm
59 val rel_Id_of_bnf: BNF -> thm
60 val rel_O_of_bnf: BNF -> thm
61 val rel_cong_of_bnf: BNF -> thm
62 val rel_converse_of_bnf: BNF -> thm
63 val rel_def_of_bnf: BNF -> thm
64 val rel_mono_of_bnf: BNF -> thm
65 val set_bd_of_bnf: BNF -> thm list
66 val set_defs_of_bnf: BNF -> thm list
67 val set_natural'_of_bnf: BNF -> thm list
68 val set_natural_of_bnf: BNF -> thm list
69 val sets_of_bnf: BNF -> term list
70 val wit_thms_of_bnf: BNF -> thm list
71 val wit_thmss_of_bnf: BNF -> thm list list
73 val mk_witness: int list * term -> thm list -> nonemptiness_witness
74 val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
75 val wits_of_bnf: BNF -> nonemptiness_witness list
77 datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
78 datatype fact_policy =
79 Derive_Some_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms
80 val bnf_note_all: bool Config.T
81 val user_policy: Proof.context -> fact_policy
83 val print_bnfs: Proof.context -> unit
84 val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
85 ({prems: thm list, context: Proof.context} -> tactic) list ->
86 ({prems: thm list, context: Proof.context} -> tactic) -> typ list option ->
87 (((binding * term) * term list) * term) * term list -> local_theory ->
90 val filter_refl: thm list -> thm list
91 val bnf_def_cmd: (((binding * string) * string list) * string) * string list -> local_theory ->
95 structure BNF_Def : BNF_DEF =
105 set_natural: thm list,
113 fun mk_axioms' ((((((((id, comp), cong), nat), c_o), cinf), set_bd), in_bd), wpull) =
114 {map_id = id, map_comp = comp, map_cong = cong, set_natural = nat, bd_card_order = c_o,
115 bd_cinfinite = cinf, set_bd = set_bd, in_bd = in_bd, map_wpull = wpull};
117 fun dest_cons [] = raise Empty
118 | dest_cons (x :: xs) = (x, xs);
120 fun mk_axioms n thms = thms
133 fun dest_axioms {map_id, map_comp, map_cong, set_natural,
134 bd_card_order, bd_cinfinite, set_bd, in_bd, map_wpull} =
135 [map_id, map_comp, map_cong] @ set_natural @ [bd_card_order, bd_cinfinite] @
136 set_bd @ [in_bd, map_wpull];
139 {map_id = map_id, map_comp = map_comp, map_cong = map_cong, set_natural = set_natural,
140 bd_card_order = bd_card_order, bd_cinfinite = bd_cinfinite,
141 set_bd = set_bd, in_bd = in_bd, map_wpull = map_wpull} =
143 map_comp = f map_comp,
144 map_cong = f map_cong,
145 set_natural = map f set_natural,
146 bd_card_order = f bd_card_order,
147 bd_cinfinite = f bd_cinfinite,
148 set_bd = map f set_bd,
150 map_wpull = f map_wpull};
152 val morph_axioms = map_axioms o Morphism.thm;
161 fun mk_defs map sets rel pred = {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred};
163 fun map_defs f {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred} =
164 {map_def = f map, set_defs = List.map f sets, rel_def = f rel, pred_def = f pred};
166 val morph_defs = map_defs o Morphism.thm;
172 collect_set_natural: thm lazy,
178 map_wppull: thm lazy,
183 rel_converse: thm lazy,
185 set_natural': thm lazy list
188 fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero
189 collect_set_natural in_cong in_mono in_rel map_comp' map_id' map_wppull
190 rel_cong rel_mono rel_Id rel_Gr rel_converse rel_O set_natural' = {
191 bd_Card_order = bd_Card_order,
192 bd_Cinfinite = bd_Cinfinite,
193 bd_Cnotzero = bd_Cnotzero,
194 collect_set_natural = collect_set_natural,
198 map_comp' = map_comp',
200 map_wppull = map_wppull,
205 rel_converse = rel_converse,
207 set_natural' = set_natural'};
227 {bd_Card_order = f bd_Card_order,
228 bd_Cinfinite = f bd_Cinfinite,
229 bd_Cnotzero = f bd_Cnotzero,
230 collect_set_natural = Lazy.map f collect_set_natural,
231 in_cong = Lazy.map f in_cong,
232 in_mono = Lazy.map f in_mono,
233 in_rel = Lazy.map f in_rel,
234 map_comp' = Lazy.map f map_comp',
235 map_id' = Lazy.map f map_id',
236 map_wppull = Lazy.map f map_wppull,
237 rel_cong = Lazy.map f rel_cong,
238 rel_mono = Lazy.map f rel_mono,
239 rel_Id = Lazy.map f rel_Id,
240 rel_Gr = Lazy.map f rel_Gr,
241 rel_converse = Lazy.map f rel_converse,
242 rel_O = Lazy.map f rel_O,
243 set_natural' = map (Lazy.map f) set_natural'};
245 val morph_facts = map_facts o Morphism.thm;
247 type nonemptiness_witness = {
253 fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
254 fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
255 fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
257 datatype BNF = BNF of {
261 lives: typ list, (*source type variables of map, only for composition*)
262 lives': typ list, (*target type variables of map, only for composition*)
264 deads: typ list, (*only for composition*)
272 wits: nonemptiness_witness list,
279 fun rep_bnf (BNF bnf) = bnf;
280 val name_of_bnf = #name o rep_bnf;
281 val T_of_bnf = #T o rep_bnf;
282 fun mk_T_of_bnf Ds Ts bnf =
283 let val bnf_rep = rep_bnf bnf
284 in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
285 val live_of_bnf = #live o rep_bnf;
286 val lives_of_bnf = #lives o rep_bnf;
287 val dead_of_bnf = #dead o rep_bnf;
288 val deads_of_bnf = #deads o rep_bnf;
289 val axioms_of_bnf = #axioms o rep_bnf;
290 val facts_of_bnf = #facts o rep_bnf;
291 val nwits_of_bnf = #nwits o rep_bnf;
292 val wits_of_bnf = #wits o rep_bnf;
295 val map_of_bnf = #map o rep_bnf;
296 val sets_of_bnf = #sets o rep_bnf;
297 fun mk_map_of_bnf Ds Ts Us bnf =
298 let val bnf_rep = rep_bnf bnf;
300 Term.subst_atomic_types
301 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
303 fun mk_sets_of_bnf Dss Tss bnf =
304 let val bnf_rep = rep_bnf bnf;
306 map2 (fn (Ds, Ts) => Term.subst_atomic_types
307 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
309 val bd_of_bnf = #bd o rep_bnf;
310 fun mk_bd_of_bnf Ds Ts bnf =
311 let val bnf_rep = rep_bnf bnf;
312 in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
313 fun mk_wits_of_bnf Dss Tss bnf =
315 val bnf_rep = rep_bnf bnf;
316 val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
318 map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
319 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
321 val rel_of_bnf = #rel o rep_bnf;
322 fun mk_rel_of_bnf Ds Ts Us bnf =
323 let val bnf_rep = rep_bnf bnf;
325 Term.subst_atomic_types
326 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
328 val pred_of_bnf = #pred o rep_bnf;
329 fun mk_pred_of_bnf Ds Ts Us bnf =
330 let val bnf_rep = rep_bnf bnf;
332 Term.subst_atomic_types
333 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#pred bnf_rep)
337 val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
338 val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
339 val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
340 val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
341 val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
342 val collect_set_natural_of_bnf = Lazy.force o #collect_set_natural o #facts o rep_bnf;
343 val in_bd_of_bnf = #in_bd o #axioms o rep_bnf;
344 val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
345 val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
346 val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
347 val map_def_of_bnf = #map_def o #defs o rep_bnf;
348 val map_id_of_bnf = #map_id o #axioms o rep_bnf;
349 val map_id'_of_bnf = Lazy.force o #map_id' o #facts o rep_bnf;
350 val map_comp_of_bnf = #map_comp o #axioms o rep_bnf;
351 val map_comp'_of_bnf = Lazy.force o #map_comp' o #facts o rep_bnf;
352 val map_cong_of_bnf = #map_cong o #axioms o rep_bnf;
353 val map_wppull_of_bnf = Lazy.force o #map_wppull o #facts o rep_bnf;
354 val map_wpull_of_bnf = #map_wpull o #axioms o rep_bnf;
355 val pred_def_of_bnf = #pred_def o #defs o rep_bnf;
356 val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
357 val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
358 val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
359 val rel_Id_of_bnf = Lazy.force o #rel_Id o #facts o rep_bnf;
360 val rel_Gr_of_bnf = Lazy.force o #rel_Gr o #facts o rep_bnf;
361 val rel_converse_of_bnf = Lazy.force o #rel_converse o #facts o rep_bnf;
362 val rel_O_of_bnf = Lazy.force o #rel_O o #facts o rep_bnf;
363 val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
364 val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
365 val set_natural_of_bnf = #set_natural o #axioms o rep_bnf;
366 val set_natural'_of_bnf = map Lazy.force o #set_natural' o #facts o rep_bnf;
367 val wit_thms_of_bnf = maps #prop o wits_of_bnf;
368 val wit_thmss_of_bnf = map #prop o wits_of_bnf;
370 fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel pred =
371 BNF {name = name, T = T,
372 live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
373 map = map, sets = sets, bd = bd,
374 axioms = axioms, defs = defs, facts = facts,
375 nwits = length wits, wits = wits, rel = rel, pred = pred};
377 fun morph_bnf phi (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
378 dead = dead, deads = deads, map = map, sets = sets, bd = bd,
379 axioms = axioms, defs = defs, facts = facts,
380 nwits = nwits, wits = wits, rel = rel, pred = pred}) =
381 BNF {name = Morphism.binding phi name, T = Morphism.typ phi T,
382 live = live, lives = List.map (Morphism.typ phi) lives,
383 lives' = List.map (Morphism.typ phi) lives',
384 dead = dead, deads = List.map (Morphism.typ phi) deads,
385 map = Morphism.term phi map, sets = List.map (Morphism.term phi) sets,
386 bd = Morphism.term phi bd,
387 axioms = morph_axioms phi axioms,
388 defs = morph_defs phi defs,
389 facts = morph_facts phi facts,
391 wits = List.map (morph_witness phi) wits,
392 rel = Morphism.term phi rel, pred = Morphism.term phi pred};
394 fun eq_bnf (BNF {T = T1, live = live1, dead = dead1, ...},
395 BNF {T = T2, live = live2, dead = dead2, ...}) =
396 Type.could_unify (T1, T2) andalso live1 = live2 andalso dead1 = dead2;
398 structure Data = Generic_Data
400 type T = BNF Symtab.table;
401 val empty = Symtab.empty;
403 val merge = Symtab.merge (eq_bnf);
406 val bnf_of = Symtab.lookup o Data.get o Context.Proof;
412 fun normalize_set insts instA set =
414 val (T, T') = dest_funT (fastype_of set);
415 val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
416 val params = Term.add_tvar_namesT T [];
417 in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
419 fun normalize_rel ctxt instTs instA instB rel =
421 val thy = Proof_Context.theory_of ctxt;
423 Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_relT (instA, instB)))
425 in Envir.subst_term (tyenv, Vartab.empty) rel end;
427 fun normalize_pred ctxt instTs instA instB pred =
429 val thy = Proof_Context.theory_of ctxt;
431 Sign.typ_match thy (fastype_of pred,
432 Library.foldr (op -->) (instTs, instA --> instB --> HOLogic.boolT)) Vartab.empty;
433 in Envir.subst_term (tyenv, Vartab.empty) pred end;
435 fun normalize_wit insts CA As wit =
437 fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
438 if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
440 val (Ts, T) = strip_param ([], fastype_of wit);
441 val subst = Term.add_tvar_namesT T [] ~~ insts;
442 fun find y = find_index (fn x => x = y) As;
444 (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
447 fun minimize_wits wits =
449 fun minimize done [] = done
450 | minimize done ((I, wit) :: todo) =
451 if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
452 then minimize done todo
453 else minimize ((I, wit) :: done) todo;
454 in minimize [] wits end;
456 fun unfold_defs_tac lthy defs mk_tac context = Local_Defs.unfold_tac lthy defs THEN mk_tac context;
462 fun nonzero_string_of_int 0 = ""
463 | nonzero_string_of_int n = string_of_int n;
467 fun mk_setN i = setN ^ nonzero_string_of_int i;
470 fun mk_witN i = witN ^ nonzero_string_of_int i;
473 val rel_unfoldN = relN ^ "_unfold";
474 val pred_unfoldN = predN ^ "_unfold";
476 val bd_card_orderN = "bd_card_order";
477 val bd_cinfiniteN = "bd_cinfinite";
478 val bd_Card_orderN = "bd_Card_order";
479 val bd_CinfiniteN = "bd_Cinfinite";
480 val bd_CnotzeroN = "bd_Cnotzero";
481 val collect_set_naturalN = "collect_set_natural";
482 val in_bdN = "in_bd";
483 val in_congN = "in_cong";
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_wppullN = "map_wppull";
492 val map_wpullN = "map_wpull";
493 val rel_congN = "rel_cong";
494 val rel_IdN = "rel_Id";
495 val rel_GrN = "rel_Gr";
496 val rel_converseN = "rel_converse";
497 val rel_ON = "rel_comp";
498 val set_naturalN = "set_natural";
499 val set_natural'N = "set_natural'";
500 val set_bdN = "set_bd";
502 datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
504 datatype fact_policy =
505 Derive_Some_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms;
507 val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
509 fun user_policy ctxt =
510 if Config.get ctxt bnf_note_all then Note_All_Facts_and_Axioms else Derive_All_Facts_Note_Most;
512 val smart_max_inline_size = 25; (*FUDGE*)
514 val no_def = Drule.reflexive_thm;
517 fun is_reflexive th =
518 let val t = Thm.prop_of th;
520 op aconv (Logic.dest_equals t)
521 handle TERM _ => op aconv (HOLogic.dest_eq (HOLogic.dest_Trueprop t))
522 handle TERM _ => false
525 val filter_refl = filter_out is_reflexive;
529 (* Define new BNFs *)
531 fun prepare_def const_policy mk_fact_policy qualify prep_term Ds_opt
532 ((((raw_b, raw_map), raw_sets), raw_bd_Abs), raw_wits) no_defs_lthy =
534 val fact_policy = mk_fact_policy no_defs_lthy;
535 val b = qualify raw_b;
536 val live = length raw_sets;
537 val nwits = length raw_wits;
539 val map_rhs = prep_term no_defs_lthy raw_map;
540 val set_rhss = map (prep_term no_defs_lthy) raw_sets;
541 val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
542 Abs (_, T, t) => (T, t)
543 | _ => error "Bad bound constant");
544 val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
546 val map_bind_def = (fn () => Binding.suffix_name ("_" ^ mapN) b, map_rhs);
549 val bs = if live = 1 then [fn () => Binding.suffix_name ("_" ^ setN) b]
550 else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_setN i) b) (1 upto live)
551 in map2 pair bs set_rhss end;
552 val bd_bind_def = (fn () => Binding.suffix_name ("_" ^ bdN) b, bd_rhs);
555 val bs = if nwits = 1 then [fn () => Binding.suffix_name ("_" ^ witN) b]
556 else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_witN i) b) (1 upto nwits);
557 in map2 pair bs wit_rhss end;
559 fun maybe_define needed_for_extra_facts (b, rhs) lthy =
562 (not needed_for_extra_facts orelse fact_policy = Derive_Some_Facts) andalso
563 (case const_policy of
565 | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
566 | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_size
570 ((rhs, no_def), lthy)
573 apfst (apsnd snd) (Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), rhs))
577 fun maybe_restore lthy0 lthy = lthy |> not (pointer_eq (lthy0, lthy)) ? Local_Theory.restore;
579 val (((((bnf_map_term, raw_map_def),
580 (bnf_set_terms, raw_set_defs)),
581 (bnf_bd_term, raw_bd_def)),
582 (bnf_wit_terms, raw_wit_defs)), (lthy', lthy)) =
584 |> maybe_define false map_bind_def
585 ||>> apfst split_list o fold_map (maybe_define false) set_binds_defs
586 ||>> maybe_define false bd_bind_def
587 ||>> apfst split_list o fold_map (maybe_define false) wit_binds_defs
588 ||> `(maybe_restore no_defs_lthy);
590 (*transforms defined frees into consts (and more)*)
591 val phi = Proof_Context.export_morphism lthy lthy';
593 val bnf_map_def = Morphism.thm phi raw_map_def;
594 val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
595 val bnf_bd_def = Morphism.thm phi raw_bd_def;
596 val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
598 val one_step_defs = filter_refl (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs);
600 val _ = case map_filter (try dest_Free)
601 (bnf_map_term :: bnf_set_terms @ [bnf_bd_term] @ bnf_wit_terms) of
603 | frees => Proof_Display.print_consts true lthy (K false) frees;
605 val bnf_map = Morphism.term phi bnf_map_term;
607 fun iter_split ((Ts, T1), T2) = if length Ts < live then error "Bad map function"
608 else if length Ts = live then ((Ts, T1), T2)
609 else iter_split (split_last Ts, T1 --> T2);
611 (*TODO: handle errors*)
612 (*simple shape analysis of a map function*)
613 val (((alphas, betas), CA), _) =
614 apfst (apfst (map_split dest_funT))
615 (iter_split (apfst split_last (strip_type (fastype_of bnf_map))));
617 val CA_params = map TVar (Term.add_tvarsT CA []);
619 val bnf_sets = map2 (normalize_set CA_params) alphas (map (Morphism.term phi) bnf_set_terms);
620 val bdT = Morphism.typ phi bd_rhsT;
622 Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
623 val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
625 (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
626 val deads = (case Ds_opt of
627 NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
628 | SOME Ds => map (Morphism.typ phi) Ds);
629 val dead = length deads;
631 (*FIXME: check DUP here, not in after_qed*)
632 val key = Name_Space.full_name Name_Space.default_naming b;
634 (*TODO: further checks of type of bnf_map*)
635 (*TODO: check types of bnf_sets*)
636 (*TODO: check type of bnf_bd*)
638 val ((((((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), domTs), ranTs), ranTs'), ranTs''),
650 ||> fst o mk_TFrees 1
652 ||> `(replicate live);
654 fun mk_bnf_map As' Bs' =
655 Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
657 Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As')) t;
659 Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As')) T;
661 val (setRTs, RTs) = map_split (`HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Bs');
662 val setRTsAsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Cs);
663 val setRTsBsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ Cs);
664 val setRT's = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ As');
665 val self_setRTs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ As');
666 val QTs = map2 (fn T => fn U => T --> U --> HOLogic.boolT) As' Bs';
668 val bnf_map_AsAs = mk_bnf_map As' As';
669 val bnf_map_AsBs = mk_bnf_map As' Bs';
670 val bnf_map_AsCs = mk_bnf_map As' Cs;
671 val bnf_map_BsCs = mk_bnf_map Bs' Cs;
672 val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
673 val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
674 val bnf_bd_As = mk_bnf_t As' bnf_bd;
675 val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
676 val CA' = mk_bnf_T As' CA;
677 val CB' = mk_bnf_T Bs' CA;
678 val CC' = mk_bnf_T Cs CA;
679 val CRs' = mk_bnf_T RTs CA;
681 val ((((((((((((((((((((((((fs, fs_copy), gs), hs), (x, x')), (y, y')), (z, z')), zs), As),
682 As_copy), Xs), B1s), B2s), f1s), f2s), e1s), e2s), p1s), p2s), bs),
683 (Rs, Rs')), Rs_copy), Ss), (Qs, Qs')), _) = lthy'
684 |> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
685 ||>> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
686 ||>> mk_Frees "g" (map2 (curry (op -->)) Bs' Cs)
687 ||>> mk_Frees "h" (map2 (curry (op -->)) As' Ts)
688 ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "x") CA'
689 ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "y") CB'
690 ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "z") CRs'
691 ||>> mk_Frees "z" As'
692 ||>> mk_Frees "A" (map HOLogic.mk_setT As')
693 ||>> mk_Frees "A" (map HOLogic.mk_setT As')
694 ||>> mk_Frees "A" (map HOLogic.mk_setT domTs)
695 ||>> mk_Frees "B1" (map HOLogic.mk_setT B1Ts)
696 ||>> mk_Frees "B2" (map HOLogic.mk_setT B2Ts)
697 ||>> mk_Frees "f1" (map2 (curry (op -->)) B1Ts ranTs)
698 ||>> mk_Frees "f2" (map2 (curry (op -->)) B2Ts ranTs)
699 ||>> mk_Frees "e1" (map2 (curry (op -->)) B1Ts ranTs')
700 ||>> mk_Frees "e2" (map2 (curry (op -->)) B2Ts ranTs'')
701 ||>> mk_Frees "p1" (map2 (curry (op -->)) domTs B1Ts)
702 ||>> mk_Frees "p2" (map2 (curry (op -->)) domTs B2Ts)
703 ||>> mk_Frees "b" As'
704 ||>> mk_Frees' "R" setRTs
705 ||>> mk_Frees "R" setRTs
706 ||>> mk_Frees "S" setRTsBsCs
707 ||>> mk_Frees' "Q" QTs;
711 val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As');
714 (HOLogic.mk_eq (bnf_map_app_id, HOLogic.id_const CA'))
719 val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
720 val comp_bnf_map_app = HOLogic.mk_comp
721 (Term.list_comb (bnf_map_BsCs, gs),
722 Term.list_comb (bnf_map_AsBs, fs));
724 fold_rev Logic.all (fs @ gs)
725 (HOLogic.mk_Trueprop (HOLogic.mk_eq (bnf_map_app_comp, comp_bnf_map_app)))
730 fun mk_prem z set f f_copy =
731 Logic.all z (Logic.mk_implies
732 (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
733 HOLogic.mk_Trueprop (HOLogic.mk_eq (f $ z, f_copy $ z))));
734 val prems = map4 mk_prem zs bnf_sets_As fs fs_copy;
735 val eq = HOLogic.mk_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
736 Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
738 fold_rev Logic.all (x :: fs @ fs_copy)
739 (Logic.list_implies (prems, HOLogic.mk_Trueprop eq))
742 val goal_set_naturals =
744 fun mk_goal setA setB f =
747 HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
748 val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
750 fold_rev Logic.all fs
751 (HOLogic.mk_Trueprop (HOLogic.mk_eq (set_comp_map, image_comp_set)))
754 map3 mk_goal bnf_sets_As bnf_sets_Bs fs
757 val goal_card_order_bd = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
759 val goal_cinfinite_bd = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
764 Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
766 map mk_goal bnf_sets_As
772 (if live = 0 then ctwo
773 else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
776 fold_rev Logic.all As
777 (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd))
782 val prems = map HOLogic.mk_Trueprop
783 (map8 mk_wpull Xs B1s B2s f1s f2s (replicate live NONE) p1s p2s);
784 val CX = mk_bnf_T domTs CA;
785 val CB1 = mk_bnf_T B1Ts CA;
786 val CB2 = mk_bnf_T B2Ts CA;
787 val bnf_sets_CX = map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
788 val bnf_sets_CB1 = map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
789 val bnf_sets_CB2 = map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
790 val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
791 val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
792 val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
793 val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
795 val map_wpull = mk_wpull (mk_in Xs bnf_sets_CX CX)
796 (mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
797 bnf_map_app_f1 bnf_map_app_f2 NONE bnf_map_app_p1 bnf_map_app_p2;
799 fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
800 (Logic.list_implies (prems, HOLogic.mk_Trueprop map_wpull))
804 [goal_map_id, goal_map_comp, goal_map_cong] @ goal_set_naturals @
805 [goal_card_order_bd, goal_cinfinite_bd] @ goal_set_bds @
806 [goal_in_bd, goal_map_wpull];
808 fun mk_wit_goals (I, wit) =
810 val xs = map (nth bs) I;
814 val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
815 val concl = HOLogic.mk_Trueprop
816 (if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
819 fold_rev Logic.all (z :: xs)
820 (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
823 map wit_goal (0 upto live - 1)
826 val wit_goalss = map mk_wit_goals bnf_wit_As;
828 fun after_qed thms lthy =
830 val (axioms, wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
832 val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
833 val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
834 val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
836 fun mk_lazy f = if fact_policy <> Derive_Some_Facts then Lazy.value (f ()) else Lazy.lazy f;
838 fun mk_collect_set_natural () =
840 val defT = mk_bnf_T Ts CA --> HOLogic.mk_setT T;
841 val collect_map = HOLogic.mk_comp
842 (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
843 Term.list_comb (mk_bnf_map As' Ts, hs));
844 val image_collect = mk_collect
845 (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
847 (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
849 fold_rev Logic.all hs
850 (HOLogic.mk_Trueprop (HOLogic.mk_eq (collect_map, image_collect)));
852 Skip_Proof.prove lthy [] [] goal
853 (fn {context = ctxt, ...} => mk_collect_set_natural_tac ctxt (#set_natural axioms))
854 |> Thm.close_derivation
857 val collect_set_natural = mk_lazy mk_collect_set_natural;
861 val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_subset) As As_copy;
863 fold_rev Logic.all (As @ As_copy)
864 (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
865 (mk_subset (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
867 Skip_Proof.prove lthy [] [] goal_in_mono (K (mk_in_mono_tac live))
868 |> Thm.close_derivation
871 val in_mono = mk_lazy mk_in_mono;
875 val prems_cong = map2 (HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) As As_copy;
877 fold_rev Logic.all (As @ As_copy)
878 (Logic.list_implies (prems_cong, HOLogic.mk_Trueprop
879 (HOLogic.mk_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA'))));
881 Skip_Proof.prove lthy [] [] goal_in_cong (K ((TRY o hyp_subst_tac THEN' rtac refl) 1))
882 |> Thm.close_derivation
885 val in_cong = mk_lazy mk_in_cong;
887 val map_id' = mk_lazy (fn () => mk_id' (#map_id axioms));
888 val map_comp' = mk_lazy (fn () => mk_comp' (#map_comp axioms));
891 map (fn thm => mk_lazy (fn () => mk_set_natural' thm)) (#set_natural axioms);
895 (*%R1 .. Rn. Gr (in R1 .. Rn) (map fst .. fst)^-1 O Gr (in R1 .. Rn) (map snd .. snd)*)
898 val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
899 val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
900 val bnf_in = mk_in Rs (map (mk_bnf_t RTs) bnf_sets) CRs';
902 fold_rev Term.absfree Rs'
903 (mk_rel_comp (mk_converse (mk_Gr bnf_in map1), mk_Gr bnf_in map2))
905 val rel_bind_def = (fn () => Binding.suffix_name ("_" ^ relN) b, rel_rhs);
907 val ((bnf_rel_term, raw_rel_def), (lthy, lthy_old)) =
909 |> maybe_define true rel_bind_def
910 ||> `(maybe_restore lthy);
912 (*transforms defined frees into consts*)
913 val phi = Proof_Context.export_morphism lthy_old lthy;
914 val bnf_rel = Morphism.term phi bnf_rel_term;
916 fun mk_bnf_rel setRTs CA' CB' = normalize_rel lthy setRTs CA' CB' bnf_rel;
918 val relAsBs = mk_bnf_rel setRTs CA' CB';
919 val bnf_rel_def = Morphism.thm phi raw_rel_def;
921 if fact_policy <> Derive_Some_Facts then
922 mk_unabs_def live (bnf_rel_def RS meta_eq_to_obj_eq)
926 val pred_rhs = fold absfree (y' :: x' :: rev Qs') (HOLogic.mk_mem (HOLogic.mk_prod (x, y),
927 Term.list_comb (relAsBs, map3 (fn Q => fn T => fn U =>
928 HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split Q)
930 val pred_bind_def = (fn () => Binding.suffix_name ("_" ^ predN) b, pred_rhs);
932 val ((bnf_pred_term, raw_pred_def), (lthy, lthy_old)) =
934 |> maybe_define true pred_bind_def
935 ||> `(maybe_restore lthy);
937 (*transforms defined frees into consts*)
938 val phi = Proof_Context.export_morphism lthy_old lthy;
939 val bnf_pred = Morphism.term phi bnf_pred_term;
941 fun mk_bnf_pred QTs CA' CB' = normalize_pred lthy QTs CA' CB' bnf_pred;
943 val pred = mk_bnf_pred QTs CA' CB';
944 val bnf_pred_def = Morphism.thm phi raw_pred_def;
946 if fact_policy <> Derive_Some_Facts then
947 mk_unabs_def (live + 2) (bnf_pred_def RS meta_eq_to_obj_eq)
951 fun mk_map_wppull () =
953 val prems = if live = 0 then [] else
954 [HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
955 (map8 mk_wpull Xs B1s B2s f1s f2s (map SOME (e1s ~~ e2s)) p1s p2s))];
956 val CX = mk_bnf_T domTs CA;
957 val CB1 = mk_bnf_T B1Ts CA;
958 val CB2 = mk_bnf_T B2Ts CA;
960 map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
962 map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
964 map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
965 val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
966 val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
967 val bnf_map_app_e1 = Term.list_comb (mk_bnf_map B1Ts ranTs', e1s);
968 val bnf_map_app_e2 = Term.list_comb (mk_bnf_map B2Ts ranTs'', e2s);
969 val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
970 val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
972 val concl = mk_wpull (mk_in Xs bnf_sets_CX CX)
973 (mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
974 bnf_map_app_f1 bnf_map_app_f2 (SOME (bnf_map_app_e1, bnf_map_app_e2))
975 bnf_map_app_p1 bnf_map_app_p2;
978 fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ e1s @ e2s @ p1s @ p2s)
979 (Logic.list_implies (prems, HOLogic.mk_Trueprop concl))
981 Skip_Proof.prove lthy [] [] goal
982 (fn _ => mk_map_wppull_tac (#map_id axioms) (#map_cong axioms)
983 (#map_wpull axioms) (Lazy.force map_comp') (map Lazy.force set_natural'))
984 |> Thm.close_derivation
987 val map_wppull = mk_lazy mk_map_wppull;
991 val lhs = Term.list_comb (relAsBs, map2 mk_Gr As fs);
992 val rhs = mk_Gr (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
993 val goal = fold_rev Logic.all (As @ fs)
994 (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)));
996 Skip_Proof.prove lthy [] [] goal
997 (mk_rel_Gr_tac bnf_rel_def (#map_id axioms) (#map_cong axioms)
998 (#map_wpull axioms) (Lazy.force in_cong) (Lazy.force map_id')
999 (Lazy.force map_comp') (map Lazy.force set_natural'))
1000 |> Thm.close_derivation
1003 val rel_Gr = mk_lazy mk_rel_Gr;
1005 fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
1006 fun mk_rel_concl f = HOLogic.mk_Trueprop
1007 (f (Term.list_comb (relAsBs, Rs), Term.list_comb (relAsBs, Rs_copy)));
1009 fun mk_rel_mono () =
1011 val mono_prems = mk_rel_prems mk_subset;
1012 val mono_concl = mk_rel_concl (uncurry mk_subset);
1014 Skip_Proof.prove lthy [] []
1015 (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
1016 (mk_rel_mono_tac bnf_rel_def (Lazy.force in_mono))
1017 |> Thm.close_derivation
1020 fun mk_rel_cong () =
1022 val cong_prems = mk_rel_prems (curry HOLogic.mk_eq);
1023 val cong_concl = mk_rel_concl HOLogic.mk_eq;
1025 Skip_Proof.prove lthy [] []
1026 (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
1027 (fn _ => (TRY o hyp_subst_tac THEN' rtac refl) 1)
1028 |> Thm.close_derivation
1031 val rel_mono = mk_lazy mk_rel_mono;
1032 val rel_cong = mk_lazy mk_rel_cong;
1035 let val relAsAs = mk_bnf_rel self_setRTs CA' CA' in
1036 Skip_Proof.prove lthy [] []
1037 (HOLogic.mk_Trueprop
1038 (HOLogic.mk_eq (Term.list_comb (relAsAs, map Id_const As'), Id_const CA')))
1039 (mk_rel_Id_tac live (Lazy.force rel_Gr) (#map_id axioms))
1040 |> Thm.close_derivation
1043 val rel_Id = mk_lazy mk_rel_Id;
1045 fun mk_rel_converse () =
1047 val relBsAs = mk_bnf_rel setRT's CB' CA';
1048 val lhs = Term.list_comb (relBsAs, map mk_converse Rs);
1049 val rhs = mk_converse (Term.list_comb (relAsBs, Rs));
1050 val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_subset lhs rhs));
1051 val le_thm = Skip_Proof.prove lthy [] [] le_goal
1052 (mk_rel_converse_le_tac bnf_rel_def (Lazy.force rel_Id) (#map_cong axioms)
1053 (Lazy.force map_comp') (map Lazy.force set_natural'))
1054 |> Thm.close_derivation
1055 val goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)));
1057 Skip_Proof.prove lthy [] [] goal (fn _ => mk_rel_converse_tac le_thm)
1058 |> Thm.close_derivation
1061 val rel_converse = mk_lazy mk_rel_converse;
1065 val relAsCs = mk_bnf_rel setRTsAsCs CA' CC';
1066 val relBsCs = mk_bnf_rel setRTsBsCs CB' CC';
1067 val lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_comp) Rs Ss);
1068 val rhs = mk_rel_comp (Term.list_comb (relAsBs, Rs), Term.list_comb (relBsCs, Ss));
1070 fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)));
1072 Skip_Proof.prove lthy [] [] goal
1073 (mk_rel_O_tac bnf_rel_def (Lazy.force rel_Id) (#map_cong axioms)
1074 (Lazy.force map_wppull) (Lazy.force map_comp') (map Lazy.force set_natural'))
1075 |> Thm.close_derivation
1078 val rel_O = mk_lazy mk_rel_O;
1082 val bnf_in = mk_in Rs (map (mk_bnf_t RTs) bnf_sets) CRs';
1083 val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
1084 val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
1085 val map_fst_eq = HOLogic.mk_eq (map1 $ z, x);
1086 val map_snd_eq = HOLogic.mk_eq (map2 $ z, y);
1087 val lhs = HOLogic.mk_mem (HOLogic.mk_prod (x, y), Term.list_comb (relAsBs, Rs));
1089 HOLogic.mk_exists (fst z', snd z', HOLogic.mk_conj (HOLogic.mk_mem (z, bnf_in),
1090 HOLogic.mk_conj (map_fst_eq, map_snd_eq)));
1092 fold_rev Logic.all (x :: y :: Rs) (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)));
1094 Skip_Proof.prove lthy [] [] goal (mk_in_rel_tac bnf_rel_def (length bnf_sets))
1095 |> Thm.close_derivation
1098 val in_rel = mk_lazy mk_in_rel;
1100 val defs = mk_defs bnf_map_def bnf_set_defs rel_def_unabs pred_def_unabs;
1102 val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_natural
1103 in_cong in_mono in_rel map_comp' map_id' map_wppull
1104 rel_cong rel_mono rel_Id rel_Gr rel_converse rel_O set_natural';
1106 val wits = map2 mk_witness bnf_wits wit_thms;
1108 val bnf_rel = Term.subst_atomic_types
1109 ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) relAsBs;
1110 val bnf_pred = Term.subst_atomic_types
1111 ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) pred;
1113 val bnf = mk_bnf b CA live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms defs facts
1114 wits bnf_rel bnf_pred;
1117 |> (if fact_policy = Note_All_Facts_and_Axioms then
1119 val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
1121 [(bd_card_orderN, [#bd_card_order axioms]),
1122 (bd_cinfiniteN, [#bd_cinfinite axioms]),
1123 (bd_Card_orderN, [#bd_Card_order facts]),
1124 (bd_CinfiniteN, [#bd_Cinfinite facts]),
1125 (bd_CnotzeroN, [#bd_Cnotzero facts]),
1126 (collect_set_naturalN, [Lazy.force (#collect_set_natural facts)]),
1127 (in_bdN, [#in_bd axioms]),
1128 (in_monoN, [Lazy.force (#in_mono facts)]),
1129 (in_relN, [Lazy.force (#in_rel facts)]),
1130 (map_compN, [#map_comp axioms]),
1131 (map_idN, [#map_id axioms]),
1132 (map_wpullN, [#map_wpull axioms]),
1133 (set_naturalN, #set_natural axioms),
1134 (set_bdN, #set_bd axioms)] @
1135 map2 pair witNs wit_thms
1136 |> map (fn (thmN, thms) =>
1137 ((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
1140 Local_Theory.notes notes #> snd
1144 |> (if fact_policy = Note_All_Facts_and_Axioms orelse
1145 fact_policy = Derive_All_Facts_Note_Most then
1148 [(map_congN, [#map_cong axioms]),
1149 (rel_IdN, [Lazy.force (#rel_Id facts)]),
1150 (rel_GrN, [Lazy.force (#rel_Gr facts)]),
1151 (rel_converseN, [Lazy.force (#rel_converse facts)]),
1152 (rel_ON, [Lazy.force (#rel_O facts)]),
1153 (map_id'N, [Lazy.force (#map_id' facts)]),
1154 (map_comp'N, [Lazy.force (#map_comp' facts)]),
1155 (set_natural'N, map Lazy.force (#set_natural' facts))]
1156 |> map (fn (thmN, thms) =>
1157 ((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
1160 Local_Theory.notes notes #> snd
1161 #> Local_Theory.declaration {syntax = false, pervasive = true}
1162 (fn phi => Data.map (Symtab.update_new (key, morph_bnf phi bnf)))
1168 (goals, wit_goalss, after_qed, lthy', one_step_defs)
1171 fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds =
1172 (fn (goals, wit_goalss, after_qed, lthy, defs) =>
1174 val wits_tac = K (TRYALL Goal.conjunction_tac) THEN' unfold_defs_tac lthy defs wit_tac;
1175 val wit_goals = wit_goalss |> map Logic.mk_conjunction_balanced;
1176 val wit_goal = Logic.mk_conjunction_balanced wit_goals;
1178 Skip_Proof.prove lthy [] [] wit_goal wits_tac
1179 |> Conjunction.elim_balanced (length wit_goals)
1180 |> map2 (Conjunction.elim_balanced o length) wit_goalss
1181 |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0))
1183 map2 (Thm.close_derivation oo Skip_Proof.prove lthy [] [])
1184 goals (map (unfold_defs_tac lthy defs) tacs)
1185 |> (fn thms => after_qed (map single thms @ wit_thms) lthy)
1186 end) oo prepare_def const_policy fact_policy qualify
1187 (singleton o Type_Infer_Context.infer_types) Ds;
1189 val bnf_def_cmd = (fn (goals, wit_goals, after_qed, lthy, defs) =>
1190 Proof.unfolding ([[(defs, [])]])
1191 (Proof.theorem NONE (snd oo after_qed)
1192 (map (single o rpair []) goals @ map (map (rpair [])) wit_goals) lthy)) oo
1193 prepare_def Do_Inline user_policy I Syntax.read_term NONE;
1195 fun print_bnfs ctxt =
1197 fun pretty_set sets i = Pretty.block
1198 [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
1199 Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
1201 fun pretty_bnf (key, BNF {T = T, map = map, sets = sets, bd = bd,
1202 live = live, lives = lives, dead = dead, deads = deads, ...}) =
1204 (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
1205 Pretty.quote (Syntax.pretty_typ ctxt T)]))
1206 ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
1207 Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
1208 Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
1209 Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
1210 Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
1211 Pretty.quote (Syntax.pretty_term ctxt map)]] @
1212 List.map (pretty_set sets) (0 upto length sets - 1) @
1213 [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
1214 Pretty.quote (Syntax.pretty_term ctxt bd)]]);
1216 Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
1221 Outer_Syntax.improper_command @{command_spec "print_bnfs"} "print all BNFs"
1222 (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
1225 Outer_Syntax.local_theory_to_proof @{command_spec "bnf_def"} "define a BNF for an existing type"
1226 (((Parse.binding --| Parse.$$$ "=") -- Parse.term --
1227 (Parse.$$$ "[" |-- Parse.list Parse.term --| Parse.$$$ "]") -- Parse.term --
1228 (Parse.$$$ "[" |-- Parse.list Parse.term --| Parse.$$$ "]")) >> bnf_def_cmd);