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