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