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