src/HOL/BNF/Tools/bnf_lfp_tactics.ML
author traytel
Tue May 07 14:22:54 2013 +0200 (2013-05-07)
changeset 51893 596baae88a88
parent 51812 329c62d99979
child 51918 3c152334f794
permissions -rw-r--r--
got rid of the set based relator---use (binary) predicate based relator instead
blanchet@49509
     1
(*  Title:      HOL/BNF/Tools/bnf_lfp_tactics.ML
blanchet@48975
     2
    Author:     Dmitriy Traytel, TU Muenchen
blanchet@48975
     3
    Author:     Andrei Popescu, TU Muenchen
blanchet@48975
     4
    Copyright   2012
blanchet@48975
     5
blanchet@48975
     6
Tactics for the datatype construction.
blanchet@48975
     7
*)
blanchet@48975
     8
blanchet@48975
     9
signature BNF_LFP_TACTICS =
blanchet@48975
    10
sig
blanchet@48975
    11
  val mk_alg_min_alg_tac: int -> thm -> thm list -> thm -> thm -> thm list list -> thm list ->
blanchet@48975
    12
    thm list -> tactic
wenzelm@51798
    13
  val mk_alg_not_empty_tac: Proof.context -> thm -> thm list -> thm list -> tactic
blanchet@48975
    14
  val mk_alg_select_tac: thm -> {prems: 'a, context: Proof.context} -> tactic
blanchet@48975
    15
  val mk_alg_set_tac: thm -> tactic
blanchet@48975
    16
  val mk_bd_card_order_tac: thm list -> tactic
blanchet@48975
    17
  val mk_bd_limit_tac: int -> thm -> tactic
blanchet@48975
    18
  val mk_card_of_min_alg_tac: thm -> thm -> thm -> thm -> thm -> tactic
blanchet@48975
    19
  val mk_copy_alg_tac: thm list list -> thm list -> thm -> thm -> thm -> tactic
blanchet@48975
    20
  val mk_copy_str_tac: thm list list -> thm -> thm list -> tactic
wenzelm@51798
    21
  val mk_ctor_induct_tac: Proof.context -> int -> thm list list -> thm -> thm list -> thm ->
wenzelm@51798
    22
    thm list -> thm list -> thm list -> tactic
blanchet@49501
    23
  val mk_ctor_induct2_tac: ctyp option list -> cterm option list -> thm -> thm list ->
blanchet@48975
    24
    {prems: 'a, context: Proof.context} -> tactic
blanchet@49585
    25
  val mk_ctor_set_tac: thm -> thm -> thm list -> tactic
traytel@51893
    26
  val mk_ctor_rel_tac: Proof.context -> thm list -> int -> thm -> thm -> thm -> thm -> thm list ->
wenzelm@51798
    27
    thm -> thm -> thm list -> thm list -> thm list list -> tactic
blanchet@49506
    28
  val mk_dtor_o_ctor_tac: thm -> thm -> thm -> thm -> thm list -> tactic
blanchet@49501
    29
  val mk_ex_copy_alg_tac: int -> thm -> thm -> tactic
blanchet@48975
    30
  val mk_in_bd_tac: thm -> thm -> thm -> thm -> tactic
blanchet@48975
    31
  val mk_incl_min_alg_tac: (int -> tactic) -> thm list list list -> thm list -> thm ->
blanchet@48975
    32
    {prems: 'a, context: Proof.context} -> tactic
blanchet@48975
    33
  val mk_init_ex_mor_tac: thm -> thm -> thm -> thm list -> thm -> thm -> thm ->
blanchet@48975
    34
    {prems: 'a, context: Proof.context} -> tactic
blanchet@48975
    35
  val mk_init_induct_tac: int -> thm -> thm -> thm list -> thm list -> tactic
blanchet@48975
    36
  val mk_init_unique_mor_tac: int -> thm -> thm -> thm list -> thm list -> thm list -> thm list ->
blanchet@48975
    37
    thm list -> tactic
blanchet@48975
    38
  val mk_iso_alt_tac: thm list -> thm -> tactic
blanchet@49504
    39
  val mk_fold_unique_mor_tac: thm list -> thm list -> thm list -> thm -> thm -> thm -> tactic
blanchet@48975
    40
  val mk_least_min_alg_tac: thm -> thm -> tactic
wenzelm@51798
    41
  val mk_lfp_map_wpull_tac: Proof.context -> int -> (int -> tactic) -> thm list -> thm list ->
wenzelm@51798
    42
    thm list list -> thm list list list -> thm list -> tactic
blanchet@48975
    43
  val mk_map_comp_tac: thm list -> thm list -> thm -> int -> tactic
blanchet@48975
    44
  val mk_map_id_tac: thm list -> thm -> tactic
blanchet@48975
    45
  val mk_map_tac: int -> int -> thm -> thm -> thm -> tactic
blanchet@49543
    46
  val mk_ctor_map_unique_tac: int -> thm -> thm -> thm list -> thm list -> tactic
blanchet@48975
    47
  val mk_mcong_tac: (int -> tactic) -> thm list list list -> thm list -> thm list ->
blanchet@48975
    48
    {prems: 'a, context: Proof.context} -> tactic
blanchet@48975
    49
  val mk_min_algs_card_of_tac: ctyp -> cterm -> int -> thm -> thm list -> thm list -> thm -> thm ->
blanchet@51812
    50
    thm -> thm -> thm -> thm -> thm -> tactic
blanchet@48975
    51
  val mk_min_algs_least_tac: ctyp -> cterm -> thm -> thm list -> thm list -> tactic
wenzelm@51798
    52
  val mk_min_algs_mono_tac: Proof.context -> thm -> tactic
blanchet@48975
    53
  val mk_min_algs_tac: thm -> thm list -> tactic
blanchet@48975
    54
  val mk_mor_Abs_tac: thm -> thm list -> thm list -> tactic
blanchet@48975
    55
  val mk_mor_Rep_tac: thm list -> thm -> thm list -> thm list -> thm list ->
blanchet@48975
    56
    {prems: 'a, context: Proof.context} -> tactic
blanchet@48975
    57
  val mk_mor_UNIV_tac: int -> thm list -> thm -> tactic
blanchet@48975
    58
  val mk_mor_comp_tac: thm -> thm list list -> thm list -> tactic
blanchet@48975
    59
  val mk_mor_convol_tac: 'a list -> thm -> tactic
blanchet@48975
    60
  val mk_mor_elim_tac: thm -> tactic
blanchet@48975
    61
  val mk_mor_incl_tac: thm -> thm list -> tactic
blanchet@48975
    62
  val mk_mor_inv_tac: thm -> thm -> thm list list -> thm list -> thm list -> thm list -> tactic
blanchet@49504
    63
  val mk_mor_fold_tac: ctyp -> cterm -> thm list -> thm -> thm -> tactic
blanchet@48975
    64
  val mk_mor_select_tac: thm -> thm -> thm -> thm -> thm -> thm -> thm list -> thm list list ->
blanchet@48975
    65
    thm list -> tactic
blanchet@48975
    66
  val mk_mor_str_tac: 'a list -> thm -> tactic
blanchet@48975
    67
  val mk_rec_tac: thm list -> thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
traytel@51739
    68
  val mk_rec_unique_mor_tac: thm list -> thm list -> thm -> {prems: 'a, context: Proof.context} ->
traytel@51739
    69
    tactic
blanchet@48975
    70
  val mk_set_bd_tac: int -> (int -> tactic) -> thm -> thm list list -> thm list -> int ->
blanchet@48975
    71
    {prems: 'a, context: Proof.context} -> tactic
blanchet@48975
    72
  val mk_set_nat_tac: int -> (int -> tactic) -> thm list list -> thm list -> cterm list ->
blanchet@48975
    73
    thm list -> int -> {prems: 'a, context: Proof.context} -> tactic
blanchet@51766
    74
  val mk_set_map_tac: thm -> tactic
blanchet@48975
    75
  val mk_set_tac: thm -> tactic
wenzelm@51798
    76
  val mk_wit_tac: Proof.context -> int -> thm list -> thm list -> tactic
blanchet@48975
    77
  val mk_wpull_tac: thm -> tactic
blanchet@48975
    78
end;
blanchet@48975
    79
blanchet@48975
    80
structure BNF_LFP_Tactics : BNF_LFP_TACTICS =
blanchet@48975
    81
struct
blanchet@48975
    82
blanchet@48975
    83
open BNF_Tactics
blanchet@48975
    84
open BNF_LFP_Util
blanchet@48975
    85
open BNF_Util
blanchet@48975
    86
blanchet@49306
    87
val fst_snd_convs = @{thms fst_conv snd_conv};
blanchet@49306
    88
val ord_eq_le_trans = @{thm ord_eq_le_trans};
blanchet@49306
    89
val subset_trans = @{thm subset_trans};
blanchet@49306
    90
val trans_fun_cong_image_id_id_apply = @{thm trans[OF fun_cong[OF image_id] id_apply]};
blanchet@49306
    91
blanchet@48975
    92
fun mk_alg_set_tac alg_def =
traytel@49488
    93
  dtac (alg_def RS iffD1) 1 THEN
blanchet@48975
    94
  REPEAT_DETERM (etac conjE 1) THEN
blanchet@48975
    95
  EVERY' [etac bspec, rtac CollectI] 1 THEN
blanchet@48975
    96
  REPEAT_DETERM (etac conjI 1) THEN atac 1;
blanchet@48975
    97
wenzelm@51798
    98
fun mk_alg_not_empty_tac ctxt alg_set alg_sets wits =
wenzelm@51798
    99
  (EVERY' [rtac notI, hyp_subst_tac ctxt, ftac alg_set] THEN'
blanchet@48975
   100
  REPEAT_DETERM o FIRST'
blanchet@49306
   101
    [rtac subset_UNIV,
blanchet@48975
   102
    EVERY' [rtac @{thm subset_emptyI}, eresolve_tac wits],
blanchet@48975
   103
    EVERY' [rtac subsetI, rtac FalseE, eresolve_tac wits],
wenzelm@51798
   104
    EVERY' [rtac subsetI, dresolve_tac wits, hyp_subst_tac ctxt,
blanchet@48975
   105
      FIRST' (map (fn thm => rtac thm THEN' atac) alg_sets)]] THEN'
blanchet@48975
   106
  etac @{thm emptyE}) 1;
blanchet@48975
   107
blanchet@48975
   108
fun mk_mor_elim_tac mor_def =
blanchet@48975
   109
  (dtac (subst OF [mor_def]) THEN'
blanchet@48975
   110
  REPEAT o etac conjE THEN'
blanchet@48975
   111
  TRY o rtac @{thm image_subsetI} THEN'
blanchet@48975
   112
  etac bspec THEN'
blanchet@48975
   113
  atac) 1;
blanchet@48975
   114
blanchet@48975
   115
fun mk_mor_incl_tac mor_def map_id's =
blanchet@48975
   116
  (stac mor_def THEN'
blanchet@48975
   117
  rtac conjI THEN'
blanchet@49306
   118
  CONJ_WRAP' (K (EVERY' [rtac ballI, etac set_mp, stac id_apply, atac])) map_id's THEN'
blanchet@48975
   119
  CONJ_WRAP' (fn thm =>
blanchet@49306
   120
   (EVERY' [rtac ballI, rtac trans, rtac id_apply, stac thm, rtac refl])) map_id's) 1;
blanchet@48975
   121
blanchet@51766
   122
fun mk_mor_comp_tac mor_def set_map's map_comp_ids =
blanchet@48975
   123
  let
blanchet@48975
   124
    val fbetw_tac = EVERY' [rtac ballI, stac o_apply, etac bspec, etac bspec, atac];
blanchet@51766
   125
    fun mor_tac (set_map', map_comp_id) =
blanchet@48975
   126
      EVERY' [rtac ballI, stac o_apply, rtac trans,
blanchet@48975
   127
        rtac trans, dtac @{thm rev_bspec}, atac, etac arg_cong,
blanchet@48975
   128
         REPEAT o eresolve_tac [CollectE, conjE], etac bspec, rtac CollectI] THEN'
blanchet@48975
   129
      CONJ_WRAP' (fn thm =>
blanchet@49306
   130
        FIRST' [rtac subset_UNIV,
blanchet@49306
   131
          (EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm image_subsetI},
blanchet@51766
   132
            etac bspec, etac set_mp, atac])]) set_map' THEN'
blanchet@48975
   133
      rtac (map_comp_id RS arg_cong);
blanchet@48975
   134
  in
blanchet@48975
   135
    (dtac (mor_def RS subst) THEN' dtac (mor_def RS subst) THEN' stac mor_def THEN'
blanchet@48975
   136
    REPEAT o etac conjE THEN'
blanchet@48975
   137
    rtac conjI THEN'
blanchet@51766
   138
    CONJ_WRAP' (K fbetw_tac) set_map's THEN'
blanchet@51766
   139
    CONJ_WRAP' mor_tac (set_map's ~~ map_comp_ids)) 1
blanchet@48975
   140
  end;
blanchet@48975
   141
blanchet@51766
   142
fun mk_mor_inv_tac alg_def mor_def set_map's morEs map_comp_ids map_cong0Ls =
blanchet@48975
   143
  let
blanchet@49306
   144
    val fbetw_tac = EVERY' [rtac ballI, etac set_mp, etac imageI];
blanchet@51766
   145
    fun Collect_tac set_map' =
blanchet@48975
   146
      CONJ_WRAP' (fn thm =>
blanchet@49306
   147
        FIRST' [rtac subset_UNIV,
blanchet@49306
   148
          (EVERY' [rtac ord_eq_le_trans, rtac thm, rtac subset_trans,
blanchet@51766
   149
            etac @{thm image_mono}, atac])]) set_map';
blanchet@51766
   150
    fun mor_tac (set_map', ((morE, map_comp_id), map_cong0L)) =
blanchet@48975
   151
      EVERY' [rtac ballI, ftac @{thm rev_bspec}, atac,
blanchet@48975
   152
         REPEAT o eresolve_tac [CollectE, conjE], rtac sym, rtac trans, rtac sym,
blanchet@51766
   153
         etac @{thm inverE}, etac bspec, rtac CollectI, Collect_tac set_map',
blanchet@51766
   154
         rtac trans, etac (morE RS arg_cong), rtac CollectI, Collect_tac set_map',
blanchet@51761
   155
         rtac trans, rtac (map_comp_id RS arg_cong), rtac (map_cong0L RS arg_cong),
blanchet@48975
   156
         REPEAT_DETERM_N (length morEs) o
blanchet@48975
   157
           (EVERY' [rtac subst, rtac @{thm inver_pointfree}, etac @{thm inver_mono}, atac])];
blanchet@48975
   158
  in
blanchet@48975
   159
    (stac mor_def THEN'
traytel@49488
   160
    dtac (alg_def RS iffD1) THEN'
traytel@49488
   161
    dtac (alg_def RS iffD1) THEN'
blanchet@48975
   162
    REPEAT o etac conjE THEN'
blanchet@48975
   163
    rtac conjI THEN'
blanchet@51766
   164
    CONJ_WRAP' (K fbetw_tac) set_map's THEN'
blanchet@51766
   165
    CONJ_WRAP' mor_tac (set_map's ~~ (morEs ~~ map_comp_ids ~~ map_cong0Ls))) 1
blanchet@48975
   166
  end;
blanchet@48975
   167
blanchet@48975
   168
fun mk_mor_str_tac ks mor_def =
blanchet@48975
   169
  (stac mor_def THEN' rtac conjI THEN'
blanchet@48975
   170
  CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) ks THEN'
blanchet@48975
   171
  CONJ_WRAP' (K (EVERY' [rtac ballI, rtac refl])) ks) 1;
blanchet@48975
   172
blanchet@48975
   173
fun mk_mor_convol_tac ks mor_def =
blanchet@48975
   174
  (stac mor_def THEN' rtac conjI THEN'
blanchet@48975
   175
  CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) ks THEN'
blanchet@48975
   176
  CONJ_WRAP' (K (EVERY' [rtac ballI, rtac trans, rtac @{thm fst_convol'}, rtac o_apply])) ks) 1;
blanchet@48975
   177
blanchet@48975
   178
fun mk_mor_UNIV_tac m morEs mor_def =
blanchet@48975
   179
  let
blanchet@48975
   180
    val n = length morEs;
blanchet@48975
   181
    fun mor_tac morE = EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, etac morE,
blanchet@49306
   182
      rtac CollectI, CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto m + n),
blanchet@48975
   183
      rtac sym, rtac o_apply];
blanchet@48975
   184
  in
blanchet@48975
   185
    EVERY' [rtac iffI, CONJ_WRAP' mor_tac morEs,
blanchet@48975
   186
    stac mor_def, rtac conjI, CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) morEs,
blanchet@48975
   187
    REPEAT_DETERM o etac conjE, REPEAT_DETERM_N n o dtac (@{thm fun_eq_iff} RS subst),
blanchet@48975
   188
    CONJ_WRAP' (K (EVERY' [rtac ballI, REPEAT_DETERM o etac allE, rtac trans,
blanchet@48975
   189
      etac (o_apply RS subst), rtac o_apply])) morEs] 1
blanchet@48975
   190
  end;
blanchet@48975
   191
blanchet@48975
   192
fun mk_iso_alt_tac mor_images mor_inv =
blanchet@48975
   193
  let
blanchet@48975
   194
    val n = length mor_images;
blanchet@48975
   195
    fun if_wrap_tac thm =
blanchet@48975
   196
      EVERY' [rtac ssubst, rtac @{thm bij_betw_iff_ex}, rtac exI, rtac conjI,
blanchet@48975
   197
        rtac @{thm inver_surj}, etac thm, etac thm, atac, etac conjI, atac]
blanchet@48975
   198
    val if_tac =
blanchet@48975
   199
      EVERY' [etac thin_rl, etac thin_rl, REPEAT o eresolve_tac [conjE, exE],
blanchet@48975
   200
        rtac conjI, atac, CONJ_WRAP' if_wrap_tac mor_images];
blanchet@48975
   201
    val only_if_tac =
blanchet@48975
   202
      EVERY' [rtac conjI, etac conjunct1, EVERY' (map (fn thm =>
blanchet@48975
   203
        EVERY' [rtac exE, rtac @{thm bij_betw_ex_weakE}, etac (conjunct2 RS thm)])
blanchet@48975
   204
        (map (mk_conjunctN n) (1 upto n))), REPEAT o rtac exI, rtac conjI, rtac mor_inv,
blanchet@48975
   205
        etac conjunct1, atac, atac, REPEAT_DETERM_N n o atac,
blanchet@48975
   206
        CONJ_WRAP' (K (etac conjunct2)) mor_images];
blanchet@48975
   207
  in
blanchet@48975
   208
    (rtac iffI THEN' if_tac THEN' only_if_tac) 1
blanchet@48975
   209
  end;
blanchet@48975
   210
blanchet@51766
   211
fun mk_copy_str_tac set_map's alg_def alg_sets =
blanchet@48975
   212
  let
blanchet@48975
   213
    val n = length alg_sets;
blanchet@48975
   214
    val bij_betw_inv_tac =
blanchet@48975
   215
      EVERY' [etac thin_rl, REPEAT_DETERM_N n o EVERY' [dtac @{thm bij_betwI}, atac, atac],
blanchet@48975
   216
        REPEAT_DETERM_N (2 * n) o etac thin_rl, REPEAT_DETERM_N (n - 1) o etac conjI, atac];
blanchet@48975
   217
    fun set_tac thms =
blanchet@49306
   218
      EVERY' [rtac ord_eq_le_trans, resolve_tac thms, rtac subset_trans,
blanchet@48975
   219
          etac @{thm image_mono}, rtac equalityD1, etac @{thm bij_betw_imageE}];
blanchet@48975
   220
    val copy_str_tac =
blanchet@48975
   221
      CONJ_WRAP' (fn (thms, thm) =>
blanchet@49306
   222
        EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac set_mp,
blanchet@48975
   223
          rtac equalityD1, etac @{thm bij_betw_imageE}, rtac imageI, etac thm,
blanchet@49306
   224
          REPEAT_DETERM o rtac subset_UNIV, REPEAT_DETERM_N n o (set_tac thms)])
blanchet@51766
   225
      (set_map's ~~ alg_sets);
blanchet@48975
   226
  in
blanchet@48975
   227
    (rtac rev_mp THEN' DETERM o bij_betw_inv_tac THEN' rtac impI THEN'
blanchet@48975
   228
    stac alg_def THEN' copy_str_tac) 1
blanchet@48975
   229
  end;
blanchet@48975
   230
blanchet@51766
   231
fun mk_copy_alg_tac set_map's alg_sets mor_def iso_alt copy_str =
blanchet@48975
   232
  let
blanchet@48975
   233
    val n = length alg_sets;
blanchet@48975
   234
    val fbetw_tac = CONJ_WRAP' (K (etac @{thm bij_betwE})) alg_sets;
blanchet@48975
   235
    fun set_tac thms =
blanchet@49306
   236
      EVERY' [rtac ord_eq_le_trans, resolve_tac thms, rtac subset_trans,
blanchet@48975
   237
        REPEAT_DETERM o etac conjE, etac @{thm image_mono},
blanchet@48975
   238
        rtac equalityD1, etac @{thm bij_betw_imageE}];
blanchet@48975
   239
    val mor_tac =
blanchet@48975
   240
      CONJ_WRAP' (fn (thms, thm) =>
blanchet@48975
   241
        EVERY' [rtac ballI, etac CollectE, etac @{thm inverE}, etac thm,
blanchet@49306
   242
          REPEAT_DETERM o rtac subset_UNIV, REPEAT_DETERM_N n o (set_tac thms)])
blanchet@51766
   243
      (set_map's ~~ alg_sets);
blanchet@48975
   244
  in
blanchet@48975
   245
    (rtac (iso_alt RS @{thm ssubst[of _ _ "%x. x"]}) THEN'
blanchet@48975
   246
    etac copy_str THEN' REPEAT_DETERM o atac THEN'
blanchet@48975
   247
    rtac conjI THEN' stac mor_def THEN' rtac conjI THEN' fbetw_tac THEN' mor_tac THEN'
blanchet@48975
   248
    CONJ_WRAP' (K atac) alg_sets) 1
blanchet@48975
   249
  end;
blanchet@48975
   250
blanchet@48975
   251
fun mk_ex_copy_alg_tac n copy_str copy_alg =
blanchet@48975
   252
  EVERY' [REPEAT_DETERM_N n o rtac exI, rtac conjI, etac copy_str,
blanchet@48975
   253
    REPEAT_DETERM_N n o atac,
blanchet@48975
   254
    REPEAT_DETERM_N n o etac @{thm bij_betw_inver2},
blanchet@48975
   255
    REPEAT_DETERM_N n o etac @{thm bij_betw_inver1}, etac copy_alg,
blanchet@48975
   256
    REPEAT_DETERM_N n o atac,
blanchet@48975
   257
    REPEAT_DETERM_N n o etac @{thm bij_betw_inver2},
blanchet@48975
   258
    REPEAT_DETERM_N n o etac @{thm bij_betw_inver1}] 1;
blanchet@48975
   259
blanchet@48975
   260
fun mk_bd_limit_tac n bd_Cinfinite =
blanchet@48975
   261
  EVERY' [REPEAT_DETERM o etac conjE, rtac rev_mp, rtac @{thm Cinfinite_limit_finite},
blanchet@48975
   262
    REPEAT_DETERM_N n o rtac @{thm finite.insertI}, rtac @{thm finite.emptyI},
blanchet@48975
   263
    REPEAT_DETERM_N n o etac @{thm insert_subsetI}, rtac @{thm empty_subsetI},
blanchet@48975
   264
    rtac bd_Cinfinite, rtac impI, etac bexE, rtac bexI,
blanchet@48975
   265
    CONJ_WRAP' (fn i =>
blanchet@48975
   266
      EVERY' [etac bspec, REPEAT_DETERM_N i o rtac @{thm insertI2}, rtac @{thm insertI1}])
blanchet@48975
   267
      (0 upto n - 1),
blanchet@48975
   268
    atac] 1;
blanchet@48975
   269
blanchet@48975
   270
fun mk_min_algs_tac worel in_congs =
blanchet@48975
   271
  let
blanchet@48975
   272
    val minG_tac = EVERY' [rtac @{thm UN_cong}, rtac refl, dtac bspec, atac, etac arg_cong];
blanchet@48975
   273
    fun minH_tac thm =
blanchet@48975
   274
      EVERY' [rtac @{thm Un_cong}, minG_tac, rtac @{thm image_cong}, rtac thm,
blanchet@48975
   275
        REPEAT_DETERM_N (length in_congs) o minG_tac, rtac refl];
blanchet@48975
   276
  in
blanchet@48975
   277
    (rtac (worel RS (@{thm wo_rel.worec_fixpoint} RS fun_cong)) THEN' rtac ssubst THEN'
blanchet@48975
   278
    rtac meta_eq_to_obj_eq THEN' rtac (worel RS @{thm wo_rel.adm_wo_def}) THEN'
blanchet@48975
   279
    REPEAT_DETERM_N 3 o rtac allI THEN' rtac impI THEN'
traytel@49488
   280
    CONJ_WRAP_GEN' (EVERY' [rtac Pair_eqI, rtac conjI]) minH_tac in_congs) 1
blanchet@48975
   281
  end;
blanchet@48975
   282
wenzelm@51798
   283
fun mk_min_algs_mono_tac ctxt min_algs = EVERY' [stac @{thm relChain_def}, rtac allI, rtac allI,
blanchet@48975
   284
  rtac impI, rtac @{thm case_split}, rtac @{thm xt1(3)}, rtac min_algs, etac @{thm FieldI2},
blanchet@48975
   285
  rtac subsetI, rtac UnI1, rtac @{thm UN_I}, etac @{thm underS_I}, atac, atac,
wenzelm@51798
   286
  rtac equalityD1, dtac @{thm notnotD}, hyp_subst_tac ctxt, rtac refl] 1;
blanchet@48975
   287
blanchet@48975
   288
fun mk_min_algs_card_of_tac cT ct m worel min_algs in_bds bd_Card_order bd_Cnotzero
blanchet@51812
   289
  suc_Card_order suc_Cinfinite suc_Cnotzero suc_Asuc Asuc_Cinfinite =
blanchet@48975
   290
  let
blanchet@48975
   291
    val induct = worel RS
blanchet@48975
   292
      Drule.instantiate' [SOME cT] [NONE, SOME ct] @{thm well_order_induct_imp};
blanchet@48975
   293
    val src = 1 upto m + 1;
blanchet@48975
   294
    val dest = (m + 1) :: (1 upto m);
blanchet@48975
   295
    val absorbAs_tac = if m = 0 then K (all_tac)
blanchet@48975
   296
      else EVERY' [rtac @{thm ordIso_transitive}, rtac @{thm csum_cong1},
blanchet@48975
   297
        rtac @{thm ordIso_transitive},
blanchet@48975
   298
        BNF_Tactics.mk_rotate_eq_tac (rtac @{thm ordIso_refl} THEN'
blanchet@48975
   299
          FIRST' [rtac @{thm card_of_Card_order}, rtac @{thm Card_order_csum},
blanchet@48975
   300
            rtac @{thm Card_order_cexp}])
blanchet@48975
   301
        @{thm ordIso_transitive} @{thm csum_assoc} @{thm csum_com} @{thm csum_cong}
blanchet@48975
   302
        src dest,
blanchet@48975
   303
        rtac @{thm csum_absorb1}, rtac Asuc_Cinfinite, rtac ctrans, rtac @{thm ordLeq_csum1},
blanchet@48975
   304
        FIRST' [rtac @{thm Card_order_csum}, rtac @{thm card_of_Card_order}],
blanchet@48975
   305
        rtac @{thm ordLeq_cexp1}, rtac suc_Cnotzero, rtac @{thm Card_order_csum}];
blanchet@48975
   306
blanchet@48975
   307
    val minG_tac = EVERY' [rtac @{thm UNION_Cinfinite_bound}, rtac @{thm ordLess_imp_ordLeq},
blanchet@48975
   308
      rtac @{thm ordLess_transitive}, rtac @{thm card_of_underS}, rtac suc_Card_order,
blanchet@48975
   309
      atac, rtac suc_Asuc, rtac ballI, etac allE, dtac mp, etac @{thm underS_E},
blanchet@48975
   310
      dtac mp, etac @{thm underS_Field}, REPEAT o etac conjE, atac, rtac Asuc_Cinfinite]
blanchet@48975
   311
blanchet@48975
   312
    fun mk_minH_tac (min_alg, in_bd) = EVERY' [rtac @{thm ordIso_ordLeq_trans},
blanchet@48975
   313
      rtac @{thm card_of_ordIso_subst}, etac min_alg, rtac @{thm Un_Cinfinite_bound},
blanchet@48975
   314
      minG_tac, rtac ctrans, rtac @{thm card_of_image}, rtac ctrans, rtac in_bd, rtac ctrans,
traytel@51782
   315
      rtac @{thm cexp_mono1}, rtac @{thm csum_mono1},
blanchet@48975
   316
      REPEAT_DETERM_N m o rtac @{thm csum_mono2},
blanchet@48975
   317
      CONJ_WRAP_GEN' (rtac @{thm csum_cinfinite_bound}) (K minG_tac) min_algs,
blanchet@48975
   318
      REPEAT_DETERM o FIRST'
traytel@51782
   319
        [rtac @{thm card_of_Card_order}, rtac @{thm Card_order_csum},
traytel@51782
   320
        rtac Asuc_Cinfinite, rtac bd_Card_order],
traytel@51782
   321
      rtac @{thm ordIso_ordLeq_trans}, rtac @{thm cexp_cong1}, absorbAs_tac,
blanchet@48975
   322
      rtac @{thm csum_absorb1}, rtac Asuc_Cinfinite, rtac @{thm ctwo_ordLeq_Cinfinite},
blanchet@48975
   323
      rtac Asuc_Cinfinite, rtac bd_Card_order,
blanchet@48975
   324
      rtac @{thm ordIso_imp_ordLeq}, rtac @{thm cexp_cprod_ordLeq},
traytel@51782
   325
      resolve_tac @{thms Card_order_csum Card_order_ctwo}, rtac suc_Cinfinite,
blanchet@48975
   326
      rtac bd_Cnotzero, rtac @{thm cardSuc_ordLeq}, rtac bd_Card_order, rtac Asuc_Cinfinite];
blanchet@48975
   327
  in
blanchet@48975
   328
    (rtac induct THEN'
blanchet@48975
   329
    rtac impI THEN'
blanchet@48975
   330
    CONJ_WRAP' mk_minH_tac (min_algs ~~ in_bds)) 1
blanchet@48975
   331
  end;
blanchet@48975
   332
blanchet@48975
   333
fun mk_min_algs_least_tac cT ct worel min_algs alg_sets =
blanchet@48975
   334
  let
blanchet@48975
   335
    val induct = worel RS
blanchet@48975
   336
      Drule.instantiate' [SOME cT] [NONE, SOME ct] @{thm well_order_induct_imp};
blanchet@48975
   337
blanchet@48975
   338
    val minG_tac = EVERY' [rtac @{thm UN_least}, etac allE, dtac mp, etac @{thm underS_E},
blanchet@48975
   339
      dtac mp, etac @{thm underS_Field}, REPEAT_DETERM o etac conjE, atac];
blanchet@48975
   340
blanchet@49306
   341
    fun mk_minH_tac (min_alg, alg_set) = EVERY' [rtac ord_eq_le_trans, etac min_alg,
blanchet@48975
   342
      rtac @{thm Un_least}, minG_tac, rtac @{thm image_subsetI},
blanchet@48975
   343
      REPEAT_DETERM o eresolve_tac [CollectE, conjE], etac alg_set,
blanchet@48975
   344
      REPEAT_DETERM o FIRST' [atac, etac subset_trans THEN' minG_tac]];
blanchet@48975
   345
  in
blanchet@48975
   346
    (rtac induct THEN'
blanchet@48975
   347
    rtac impI THEN'
blanchet@48975
   348
    CONJ_WRAP' mk_minH_tac (min_algs ~~ alg_sets)) 1
blanchet@48975
   349
  end;
blanchet@48975
   350
blanchet@48975
   351
fun mk_alg_min_alg_tac m alg_def min_alg_defs bd_limit bd_Cinfinite
blanchet@48975
   352
    set_bdss min_algs min_alg_monos =
blanchet@48975
   353
  let
blanchet@48975
   354
    val n = length min_algs;
blanchet@48975
   355
    fun mk_cardSuc_UNION_tac set_bds (mono, def) = EVERY'
blanchet@48975
   356
      [rtac bexE, rtac @{thm cardSuc_UNION_Cinfinite}, rtac bd_Cinfinite, rtac mono,
blanchet@48975
   357
       etac (def RSN (2, @{thm subset_trans[OF _ equalityD1]})), resolve_tac set_bds];
blanchet@48975
   358
    fun mk_conjunct_tac (set_bds, (min_alg, min_alg_def)) =
blanchet@48975
   359
      EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
blanchet@48975
   360
        EVERY' (map (mk_cardSuc_UNION_tac set_bds) (min_alg_monos ~~ min_alg_defs)), rtac bexE,
blanchet@48975
   361
        rtac bd_limit, REPEAT_DETERM_N (n - 1) o etac conjI, atac,
blanchet@48975
   362
        rtac (min_alg_def RS @{thm set_mp[OF equalityD2]}),
blanchet@49306
   363
        rtac @{thm UN_I}, REPEAT_DETERM_N (m + 3 * n) o etac thin_rl, atac, rtac set_mp,
blanchet@48975
   364
        rtac equalityD2, rtac min_alg, atac, rtac UnI2, rtac @{thm image_eqI}, rtac refl,
blanchet@48975
   365
        rtac CollectI, REPEAT_DETERM_N m o dtac asm_rl, REPEAT_DETERM_N n o etac thin_rl,
blanchet@48975
   366
        REPEAT_DETERM o etac conjE,
blanchet@48975
   367
        CONJ_WRAP' (K (FIRST' [atac,
blanchet@48975
   368
          EVERY' [etac subset_trans, rtac subsetI, rtac @{thm UN_I},
blanchet@48975
   369
            etac @{thm underS_I}, atac, atac]]))
blanchet@48975
   370
          set_bds];
blanchet@48975
   371
  in
blanchet@48975
   372
    (rtac (alg_def RS @{thm ssubst[of _ _ "%x. x"]}) THEN'
blanchet@48975
   373
    CONJ_WRAP' mk_conjunct_tac (set_bdss ~~ (min_algs ~~ min_alg_defs))) 1
blanchet@48975
   374
  end;
blanchet@48975
   375
blanchet@48975
   376
fun mk_card_of_min_alg_tac min_alg_def card_of suc_Card_order suc_Asuc Asuc_Cinfinite =
blanchet@48975
   377
  EVERY' [stac min_alg_def, rtac @{thm UNION_Cinfinite_bound},
blanchet@48975
   378
    rtac @{thm ordIso_ordLeq_trans}, rtac @{thm card_of_Field_ordIso}, rtac suc_Card_order,
blanchet@48975
   379
    rtac @{thm ordLess_imp_ordLeq}, rtac suc_Asuc, rtac ballI, dtac rev_mp, rtac card_of,
blanchet@48975
   380
    REPEAT_DETERM o etac conjE, atac, rtac Asuc_Cinfinite] 1;
blanchet@48975
   381
blanchet@48975
   382
fun mk_least_min_alg_tac min_alg_def least =
blanchet@48975
   383
  EVERY' [stac min_alg_def, rtac @{thm UN_least}, dtac least, dtac mp, atac,
blanchet@48975
   384
    REPEAT_DETERM o etac conjE, atac] 1;
blanchet@48975
   385
blanchet@48975
   386
fun mk_alg_select_tac Abs_inverse {context = ctxt, prems = _} =
wenzelm@51798
   387
  EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac ctxt] 1 THEN
blanchet@49504
   388
  unfold_thms_tac ctxt (Abs_inverse :: fst_snd_convs) THEN atac 1;
blanchet@48975
   389
blanchet@48975
   390
fun mk_mor_select_tac mor_def mor_cong mor_comp mor_incl_min_alg alg_def alg_select
blanchet@51766
   391
    alg_sets set_map's str_init_defs =
blanchet@48975
   392
  let
blanchet@48975
   393
    val n = length alg_sets;
blanchet@48975
   394
    val fbetw_tac =
blanchet@48975
   395
      CONJ_WRAP' (K (EVERY' [rtac ballI, etac @{thm rev_bspec}, etac CollectE, atac])) alg_sets;
blanchet@48975
   396
    val mor_tac =
blanchet@48975
   397
      CONJ_WRAP' (fn thm => EVERY' [rtac ballI, rtac thm]) str_init_defs;
blanchet@51766
   398
    fun alg_epi_tac ((alg_set, str_init_def), set_map') =
blanchet@48975
   399
      EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
blanchet@48975
   400
        rtac ballI, ftac (alg_select RS bspec), stac str_init_def, etac alg_set,
blanchet@49306
   401
        REPEAT_DETERM o FIRST' [rtac subset_UNIV,
blanchet@51766
   402
          EVERY' [rtac ord_eq_le_trans, resolve_tac set_map', rtac subset_trans,
blanchet@48975
   403
            etac @{thm image_mono}, rtac @{thm image_Collect_subsetI}, etac bspec, atac]]];
blanchet@48975
   404
  in
blanchet@48975
   405
    (rtac mor_cong THEN' REPEAT_DETERM_N n o (rtac sym THEN' rtac @{thm o_id}) THEN'
blanchet@48975
   406
    rtac (Thm.permute_prems 0 1 mor_comp) THEN' etac (Thm.permute_prems 0 1 mor_comp) THEN'
blanchet@48975
   407
    stac mor_def THEN' rtac conjI THEN' fbetw_tac THEN' mor_tac THEN' rtac mor_incl_min_alg THEN'
blanchet@51766
   408
    stac alg_def THEN' CONJ_WRAP' alg_epi_tac ((alg_sets ~~ str_init_defs) ~~ set_map's)) 1
blanchet@48975
   409
  end;
blanchet@48975
   410
blanchet@48975
   411
fun mk_init_ex_mor_tac Abs_inverse copy_alg_ex alg_min_alg card_of_min_algs
blanchet@48975
   412
    mor_comp mor_select mor_incl_min_alg {context = ctxt, prems = _} =
blanchet@48975
   413
  let
blanchet@48975
   414
    val n = length card_of_min_algs;
blanchet@48975
   415
    val card_of_ordIso_tac = EVERY' [rtac ssubst, rtac @{thm card_of_ordIso},
blanchet@48975
   416
      rtac @{thm ordIso_symmetric}, rtac conjunct1, rtac conjunct2, atac];
blanchet@48975
   417
    fun internalize_tac card_of = EVERY' [rtac subst, rtac @{thm internalize_card_of_ordLeq2},
blanchet@48975
   418
      rtac @{thm ordLeq_ordIso_trans}, rtac card_of, rtac subst,
blanchet@48975
   419
      rtac @{thm Card_order_iff_ordIso_card_of}, rtac @{thm Card_order_cexp}];
blanchet@48975
   420
  in
blanchet@48975
   421
    (rtac rev_mp THEN'
blanchet@48975
   422
    REPEAT_DETERM_N (2 * n) o (rtac mp THEN' rtac @{thm ex_mono} THEN' rtac impI) THEN'
blanchet@48975
   423
    REPEAT_DETERM_N (n + 1) o etac thin_rl THEN' rtac (alg_min_alg RS copy_alg_ex) THEN'
blanchet@48975
   424
    REPEAT_DETERM_N n o atac THEN'
blanchet@48975
   425
    REPEAT_DETERM_N n o card_of_ordIso_tac THEN'
blanchet@48975
   426
    EVERY' (map internalize_tac card_of_min_algs) THEN'
blanchet@48975
   427
    rtac impI THEN'
blanchet@48975
   428
    REPEAT_DETERM o eresolve_tac [exE, conjE] THEN'
blanchet@48975
   429
    REPEAT_DETERM o rtac exI THEN'
blanchet@48975
   430
    rtac mor_select THEN' atac THEN' rtac CollectI THEN'
blanchet@48975
   431
    REPEAT_DETERM o rtac exI THEN'
blanchet@48975
   432
    rtac conjI THEN' rtac refl THEN' atac THEN'
blanchet@49504
   433
    K (unfold_thms_tac ctxt (Abs_inverse :: fst_snd_convs)) THEN'
blanchet@48975
   434
    etac mor_comp THEN' etac mor_incl_min_alg) 1
blanchet@48975
   435
  end;
blanchet@48975
   436
blanchet@48975
   437
fun mk_init_unique_mor_tac m
blanchet@51761
   438
    alg_def alg_min_alg least_min_algs in_monos alg_sets morEs map_cong0s =
blanchet@48975
   439
  let
blanchet@48975
   440
    val n = length least_min_algs;
blanchet@48975
   441
    val ks = (1 upto n);
blanchet@48975
   442
blanchet@49306
   443
    fun mor_tac morE in_mono = EVERY' [etac morE, rtac set_mp, rtac in_mono,
blanchet@48975
   444
      REPEAT_DETERM_N n o rtac @{thm Collect_restrict}, rtac CollectI,
blanchet@48975
   445
      REPEAT_DETERM_N (m + n) o (TRY o rtac conjI THEN' atac)];
blanchet@51761
   446
    fun cong_tac map_cong0 = EVERY' [rtac (map_cong0 RS arg_cong),
blanchet@48975
   447
      REPEAT_DETERM_N m o rtac refl,
blanchet@48975
   448
      REPEAT_DETERM_N n o (etac @{thm prop_restrict} THEN' atac)];
blanchet@48975
   449
blanchet@51761
   450
    fun mk_alg_tac (alg_set, (in_mono, (morE, map_cong0))) = EVERY' [rtac ballI, rtac CollectI,
blanchet@48975
   451
      REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac (alg_min_alg RS alg_set),
blanchet@49306
   452
      REPEAT_DETERM_N m o rtac subset_UNIV,
blanchet@49306
   453
      REPEAT_DETERM_N n o (etac subset_trans THEN' rtac @{thm Collect_restrict}),
blanchet@48975
   454
      rtac trans, mor_tac morE in_mono,
blanchet@51761
   455
      rtac trans, cong_tac map_cong0,
blanchet@48975
   456
      rtac sym, mor_tac morE in_mono];
blanchet@48975
   457
blanchet@48975
   458
    fun mk_unique_tac (k, least_min_alg) =
blanchet@48975
   459
      select_prem_tac n (etac @{thm prop_restrict}) k THEN' rtac least_min_alg THEN'
blanchet@48975
   460
      stac alg_def THEN'
blanchet@51761
   461
      CONJ_WRAP' mk_alg_tac (alg_sets ~~ (in_monos ~~ (morEs ~~ map_cong0s)));
blanchet@48975
   462
  in
blanchet@48975
   463
    CONJ_WRAP' mk_unique_tac (ks ~~ least_min_algs) 1
blanchet@48975
   464
  end;
blanchet@48975
   465
blanchet@48975
   466
fun mk_init_induct_tac m alg_def alg_min_alg least_min_algs alg_sets =
blanchet@48975
   467
  let
blanchet@48975
   468
    val n = length least_min_algs;
blanchet@48975
   469
blanchet@48975
   470
    fun mk_alg_tac alg_set = EVERY' [rtac ballI, rtac CollectI,
blanchet@48975
   471
      REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac (alg_min_alg RS alg_set),
blanchet@49306
   472
      REPEAT_DETERM_N m o rtac subset_UNIV,
blanchet@49306
   473
      REPEAT_DETERM_N n o (etac subset_trans THEN' rtac @{thm Collect_restrict}),
blanchet@48975
   474
      rtac mp, etac bspec, rtac CollectI,
blanchet@48975
   475
      REPEAT_DETERM_N m o (rtac conjI THEN' atac),
blanchet@49306
   476
      CONJ_WRAP' (K (etac subset_trans THEN' rtac @{thm Collect_restrict})) alg_sets,
blanchet@48975
   477
      CONJ_WRAP' (K (rtac ballI THEN' etac @{thm prop_restrict} THEN' atac)) alg_sets];
blanchet@48975
   478
blanchet@48975
   479
    fun mk_induct_tac least_min_alg =
blanchet@48975
   480
      rtac ballI THEN' etac @{thm prop_restrict} THEN' rtac least_min_alg THEN'
blanchet@48975
   481
      stac alg_def THEN'
blanchet@48975
   482
      CONJ_WRAP' mk_alg_tac alg_sets;
blanchet@48975
   483
  in
blanchet@48975
   484
    CONJ_WRAP' mk_induct_tac least_min_algs 1
blanchet@48975
   485
  end;
blanchet@48975
   486
blanchet@49501
   487
fun mk_mor_Rep_tac ctor_defs copy bijs inver_Abss inver_Reps {context = ctxt, prems = _} =
blanchet@49504
   488
  (K (unfold_thms_tac ctxt ctor_defs) THEN' rtac conjunct1 THEN' rtac copy THEN'
blanchet@48975
   489
  EVERY' (map (fn bij => EVERY' [rtac bij, atac, etac bexI, rtac UNIV_I]) bijs) THEN'
blanchet@48975
   490
  EVERY' (map rtac inver_Abss) THEN'
blanchet@48975
   491
  EVERY' (map rtac inver_Reps)) 1;
blanchet@48975
   492
blanchet@48975
   493
fun mk_mor_Abs_tac inv inver_Abss inver_Reps =
blanchet@48975
   494
  (rtac inv THEN'
blanchet@48975
   495
  EVERY' (map2 (fn inver_Abs => fn inver_Rep =>
blanchet@49306
   496
    EVERY' [rtac conjI, rtac subset_UNIV, rtac conjI, rtac inver_Rep, rtac inver_Abs])
blanchet@48975
   497
    inver_Abss inver_Reps)) 1;
blanchet@48975
   498
blanchet@49504
   499
fun mk_mor_fold_tac cT ct fold_defs ex_mor mor =
blanchet@49504
   500
  (EVERY' (map stac fold_defs) THEN' EVERY' [rtac rev_mp, rtac ex_mor, rtac impI] THEN'
blanchet@49504
   501
  REPEAT_DETERM_N (length fold_defs) o etac exE THEN'
blanchet@48975
   502
  rtac (Drule.instantiate' [SOME cT] [SOME ct] @{thm someI}) THEN' etac mor) 1;
blanchet@48975
   503
blanchet@49504
   504
fun mk_fold_unique_mor_tac type_defs init_unique_mors Reps mor_comp mor_Abs mor_fold =
blanchet@48975
   505
  let
blanchet@48975
   506
    fun mk_unique type_def =
blanchet@48975
   507
      EVERY' [rtac @{thm surj_fun_eq}, rtac (type_def RS @{thm type_definition.Abs_image}),
traytel@49227
   508
        rtac ballI, resolve_tac init_unique_mors,
traytel@49227
   509
        EVERY' (map (fn thm => atac ORELSE' rtac thm) Reps),
blanchet@48975
   510
        rtac mor_comp, rtac mor_Abs, atac,
blanchet@49504
   511
        rtac mor_comp, rtac mor_Abs, rtac mor_fold];
blanchet@48975
   512
  in
blanchet@48975
   513
    CONJ_WRAP' mk_unique type_defs 1
blanchet@48975
   514
  end;
blanchet@48975
   515
blanchet@51761
   516
fun mk_dtor_o_ctor_tac dtor_def foldx map_comp_id map_cong0L ctor_o_folds =
blanchet@49504
   517
  EVERY' [stac dtor_def, rtac ext, rtac trans, rtac o_apply, rtac trans, rtac foldx,
blanchet@51761
   518
    rtac trans, rtac map_comp_id, rtac trans, rtac map_cong0L,
blanchet@49306
   519
    EVERY' (map (fn thm => rtac ballI THEN' rtac (trans OF [thm RS fun_cong, id_apply]))
blanchet@49504
   520
      ctor_o_folds),
blanchet@49306
   521
    rtac sym, rtac id_apply] 1;
blanchet@48975
   522
blanchet@49504
   523
fun mk_rec_tac rec_defs foldx fst_recs {context = ctxt, prems = _}=
blanchet@49504
   524
  unfold_thms_tac ctxt
blanchet@48975
   525
    (rec_defs @ map (fn thm => thm RS @{thm convol_expand_snd}) fst_recs) THEN
blanchet@49504
   526
  EVERY' [rtac trans, rtac o_apply, rtac trans, rtac (foldx RS @{thm arg_cong[of _ _ snd]}),
blanchet@48975
   527
    rtac @{thm snd_convol'}] 1;
blanchet@48975
   528
traytel@51739
   529
fun mk_rec_unique_mor_tac rec_defs fst_recs fold_unique_mor {context = ctxt, prems = _} =
traytel@51739
   530
  unfold_thms_tac ctxt
traytel@51739
   531
    (rec_defs @ map (fn thm => thm RS @{thm convol_expand_snd'}) fst_recs) THEN
traytel@51739
   532
  etac fold_unique_mor 1;
traytel@51739
   533
wenzelm@51798
   534
fun mk_ctor_induct_tac ctxt m set_map'ss init_induct morEs mor_Abs Rep_invs Abs_invs Reps =
blanchet@48975
   535
  let
blanchet@51766
   536
    val n = length set_map'ss;
blanchet@48975
   537
    val ks = 1 upto n;
blanchet@48975
   538
blanchet@51766
   539
    fun mk_IH_tac Rep_inv Abs_inv set_map' =
blanchet@49306
   540
      DETERM o EVERY' [dtac meta_mp, rtac (Rep_inv RS arg_cong RS subst), etac bspec,
blanchet@51766
   541
        dtac set_rev_mp, rtac equalityD1, rtac set_map', etac imageE,
wenzelm@51798
   542
        hyp_subst_tac ctxt, rtac (Abs_inv RS ssubst), etac set_mp, atac, atac];
blanchet@48975
   543
blanchet@51766
   544
    fun mk_closed_tac (k, (morE, set_map's)) =
blanchet@48975
   545
      EVERY' [select_prem_tac n (dtac asm_rl) k, rtac ballI, rtac impI,
blanchet@48975
   546
        rtac (mor_Abs RS morE RS arg_cong RS ssubst), atac,
blanchet@48975
   547
        REPEAT_DETERM o eresolve_tac [CollectE, conjE], dtac @{thm meta_spec},
blanchet@51766
   548
        EVERY' (map3 mk_IH_tac Rep_invs Abs_invs (drop m set_map's)), atac];
blanchet@48975
   549
traytel@49227
   550
    fun mk_induct_tac (Rep, Rep_inv) =
traytel@49227
   551
      EVERY' [rtac (Rep_inv RS arg_cong RS subst), etac (Rep RSN (2, bspec))];
blanchet@48975
   552
  in
blanchet@48975
   553
    (rtac mp THEN' rtac impI THEN'
traytel@49227
   554
    DETERM o CONJ_WRAP_GEN' (etac conjE THEN' rtac conjI) mk_induct_tac (Reps ~~ Rep_invs) THEN'
blanchet@48975
   555
    rtac init_induct THEN'
blanchet@51766
   556
    DETERM o CONJ_WRAP' mk_closed_tac (ks ~~ (morEs ~~ set_map'ss))) 1
blanchet@48975
   557
  end;
blanchet@48975
   558
blanchet@49501
   559
fun mk_ctor_induct2_tac cTs cts ctor_induct weak_ctor_inducts {context = ctxt, prems = _} =
blanchet@48975
   560
  let
blanchet@49501
   561
    val n = length weak_ctor_inducts;
blanchet@48975
   562
    val ks = 1 upto n;
blanchet@48975
   563
    fun mk_inner_induct_tac induct i =
blanchet@48975
   564
      EVERY' [rtac allI, fo_rtac induct ctxt,
blanchet@48975
   565
        select_prem_tac n (dtac @{thm meta_spec2}) i,
blanchet@48975
   566
        REPEAT_DETERM_N n o
blanchet@49306
   567
          EVERY' [dtac meta_mp THEN_ALL_NEW Goal.norm_hhf_tac,
blanchet@49306
   568
            REPEAT_DETERM o dtac @{thm meta_spec}, etac (spec RS meta_mp), atac],
blanchet@48975
   569
        atac];
blanchet@48975
   570
  in
blanchet@49501
   571
    EVERY' [rtac rev_mp, rtac (Drule.instantiate' cTs cts ctor_induct),
blanchet@49501
   572
      EVERY' (map2 mk_inner_induct_tac weak_ctor_inducts ks), rtac impI,
blanchet@48975
   573
      REPEAT_DETERM o eresolve_tac [conjE, allE],
blanchet@48975
   574
      CONJ_WRAP' (K atac) ks] 1
blanchet@48975
   575
  end;
blanchet@48975
   576
blanchet@51761
   577
fun mk_map_tac m n foldx map_comp_id map_cong0 =
blanchet@49504
   578
  EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, rtac foldx, rtac trans, rtac o_apply,
blanchet@51761
   579
    rtac trans, rtac (map_comp_id RS arg_cong), rtac trans, rtac (map_cong0 RS arg_cong),
blanchet@48975
   580
    REPEAT_DETERM_N m o rtac refl,
blanchet@49306
   581
    REPEAT_DETERM_N n o (EVERY' (map rtac [trans, o_apply, id_apply])),
blanchet@48975
   582
    rtac sym, rtac o_apply] 1;
blanchet@48975
   583
blanchet@51761
   584
fun mk_ctor_map_unique_tac m mor_def fold_unique_mor map_comp_ids map_cong0s =
blanchet@48975
   585
  let
blanchet@51761
   586
    val n = length map_cong0s;
blanchet@48975
   587
    fun mk_mor (comp_id, cong) = EVERY' [rtac ballI, rtac trans, etac @{thm pointfreeE},
blanchet@48975
   588
      rtac sym, rtac trans, rtac o_apply, rtac trans, rtac (comp_id RS arg_cong),
blanchet@48975
   589
      rtac (cong RS arg_cong),
blanchet@48975
   590
      REPEAT_DETERM_N m o rtac refl,
blanchet@49306
   591
      REPEAT_DETERM_N n o (EVERY' (map rtac [trans, o_apply, id_apply]))];
blanchet@48975
   592
  in
blanchet@49504
   593
    EVERY' [rtac fold_unique_mor, rtac ssubst, rtac mor_def, rtac conjI,
blanchet@51761
   594
      CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) map_cong0s,
blanchet@51761
   595
      CONJ_WRAP' mk_mor (map_comp_ids ~~ map_cong0s)] 1
blanchet@48975
   596
  end;
blanchet@48975
   597
blanchet@49504
   598
fun mk_set_tac foldx = EVERY' [rtac ext, rtac trans, rtac o_apply,
blanchet@49504
   599
  rtac trans, rtac foldx, rtac sym, rtac o_apply] 1;
blanchet@48975
   600
blanchet@51766
   601
fun mk_ctor_set_tac set set_map' set_map's =
blanchet@48975
   602
  let
blanchet@51766
   603
    val n = length set_map's;
blanchet@48975
   604
    fun mk_UN thm = rtac (thm RS @{thm arg_cong[of _ _ Union]} RS trans) THEN'
blanchet@48975
   605
      rtac @{thm Union_image_eq};
blanchet@48975
   606
  in
blanchet@48975
   607
    EVERY' [rtac (set RS @{thm pointfreeE} RS trans), rtac @{thm Un_cong},
blanchet@51766
   608
      rtac (trans OF [set_map', trans_fun_cong_image_id_id_apply]),
blanchet@48975
   609
      REPEAT_DETERM_N (n - 1) o rtac @{thm Un_cong},
blanchet@51766
   610
      EVERY' (map mk_UN set_map's)] 1
blanchet@48975
   611
  end;
blanchet@48975
   612
blanchet@51766
   613
fun mk_set_nat_tac m induct_tac set_map'ss
blanchet@49542
   614
    ctor_maps csets ctor_sets i {context = ctxt, prems = _} =
blanchet@48975
   615
  let
blanchet@49541
   616
    val n = length ctor_maps;
blanchet@48975
   617
blanchet@48975
   618
    fun useIH set_nat = EVERY' [rtac trans, rtac @{thm image_UN}, rtac trans, rtac @{thm UN_cong},
blanchet@48975
   619
      rtac refl, Goal.assume_rule_tac ctxt, rtac sym, rtac trans, rtac @{thm UN_cong},
blanchet@48975
   620
      rtac set_nat, rtac refl, rtac @{thm UN_simps(10)}];
blanchet@48975
   621
blanchet@49585
   622
    fun mk_set_nat cset ctor_map ctor_set set_nats =
blanchet@49585
   623
      EVERY' [rtac trans, rtac @{thm image_cong}, rtac ctor_set, rtac refl,
blanchet@49585
   624
        rtac sym, rtac (trans OF [ctor_map RS HOL_arg_cong cset, ctor_set RS trans]),
blanchet@48975
   625
        rtac sym, EVERY' (map rtac (trans :: @{thms image_Un Un_cong})),
blanchet@48975
   626
        rtac sym, rtac (nth set_nats (i - 1)),
blanchet@48975
   627
        REPEAT_DETERM_N (n - 1) o EVERY' (map rtac (trans :: @{thms image_Un Un_cong})),
blanchet@48975
   628
        EVERY' (map useIH (drop m set_nats))];
blanchet@48975
   629
  in
blanchet@51766
   630
    (induct_tac THEN' EVERY' (map4 mk_set_nat csets ctor_maps ctor_sets set_map'ss)) 1
blanchet@48975
   631
  end;
blanchet@48975
   632
blanchet@49542
   633
fun mk_set_bd_tac m induct_tac bd_Cinfinite set_bdss ctor_sets i {context = ctxt, prems = _} =
blanchet@48975
   634
  let
blanchet@49542
   635
    val n = length ctor_sets;
blanchet@48975
   636
blanchet@48975
   637
    fun useIH set_bd = EVERY' [rtac @{thm UNION_Cinfinite_bound}, rtac set_bd, rtac ballI,
blanchet@48975
   638
      Goal.assume_rule_tac ctxt, rtac bd_Cinfinite];
blanchet@48975
   639
blanchet@49585
   640
    fun mk_set_nat ctor_set set_bds =
blanchet@49585
   641
      EVERY' [rtac @{thm ordIso_ordLeq_trans}, rtac @{thm card_of_ordIso_subst}, rtac ctor_set,
blanchet@48975
   642
        rtac (bd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})), rtac (nth set_bds (i - 1)),
blanchet@48975
   643
        REPEAT_DETERM_N (n - 1) o rtac (bd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})),
blanchet@48975
   644
        EVERY' (map useIH (drop m set_bds))];
blanchet@48975
   645
  in
blanchet@49542
   646
    (induct_tac THEN' EVERY' (map2 mk_set_nat ctor_sets set_bdss)) 1
blanchet@48975
   647
  end;
blanchet@48975
   648
blanchet@51761
   649
fun mk_mcong_tac induct_tac set_setsss map_cong0s ctor_maps {context = ctxt, prems = _} =
blanchet@48975
   650
  let
blanchet@49306
   651
    fun use_asm thm = EVERY' [etac bspec, etac set_rev_mp, rtac thm];
blanchet@48975
   652
blanchet@48975
   653
    fun useIH set_sets = EVERY' [rtac mp, Goal.assume_rule_tac ctxt,
blanchet@48975
   654
      CONJ_WRAP' (fn thm =>
blanchet@49306
   655
        EVERY' [rtac ballI, etac bspec, etac set_rev_mp, etac thm]) set_sets];
blanchet@48975
   656
blanchet@51761
   657
    fun mk_map_cong0 ctor_map map_cong0 set_setss =
blanchet@48975
   658
      EVERY' [rtac impI, REPEAT_DETERM o etac conjE,
blanchet@51761
   659
        rtac trans, rtac ctor_map, rtac trans, rtac (map_cong0 RS arg_cong),
blanchet@48975
   660
        EVERY' (map use_asm (map hd set_setss)),
blanchet@48975
   661
        EVERY' (map useIH (transpose (map tl set_setss))),
blanchet@49541
   662
        rtac sym, rtac ctor_map];
blanchet@48975
   663
  in
blanchet@51761
   664
    (induct_tac THEN' EVERY' (map3 mk_map_cong0 ctor_maps map_cong0s set_setsss)) 1
blanchet@48975
   665
  end;
blanchet@48975
   666
blanchet@48975
   667
fun mk_incl_min_alg_tac induct_tac set_setsss alg_sets alg_min_alg {context = ctxt, prems = _} =
blanchet@48975
   668
  let
blanchet@48975
   669
    fun use_asm thm = etac (thm RS subset_trans);
blanchet@48975
   670
blanchet@48975
   671
    fun useIH set_sets = EVERY' [rtac subsetI, rtac mp, Goal.assume_rule_tac ctxt,
blanchet@48975
   672
      rtac CollectI, CONJ_WRAP' (fn thm => EVERY' [etac (thm RS subset_trans), atac]) set_sets];
blanchet@48975
   673
blanchet@48975
   674
    fun mk_incl alg_set set_setss =
blanchet@48975
   675
      EVERY' [rtac impI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
blanchet@48975
   676
        rtac (alg_min_alg RS alg_set),
blanchet@48975
   677
        EVERY' (map use_asm (map hd set_setss)),
blanchet@48975
   678
        EVERY' (map useIH (transpose (map tl set_setss)))];
blanchet@48975
   679
  in
blanchet@48975
   680
    (induct_tac THEN' EVERY' (map2 mk_incl alg_sets set_setsss)) 1
blanchet@48975
   681
  end;
blanchet@48975
   682
wenzelm@51798
   683
fun mk_lfp_map_wpull_tac ctxt m induct_tac wpulls ctor_maps ctor_setss set_setsss ctor_injects =
blanchet@48975
   684
  let
blanchet@48975
   685
    val n = length wpulls;
blanchet@48975
   686
    val ks = 1 upto n;
blanchet@48975
   687
    val ls = 1 upto m;
blanchet@48975
   688
blanchet@48975
   689
    fun use_pass_asm thm = rtac conjI THEN' etac (thm RS subset_trans);
blanchet@48975
   690
    fun use_act_asm thm = etac (thm RS subset_trans) THEN' atac;
blanchet@48975
   691
blanchet@48975
   692
    fun useIH set_sets i = EVERY' [rtac ssubst, rtac @{thm wpull_def},
blanchet@48975
   693
       REPEAT_DETERM_N m o etac thin_rl, select_prem_tac n (dtac asm_rl) i,
blanchet@48975
   694
       rtac allI, rtac allI, rtac impI, REPEAT_DETERM o etac conjE,
blanchet@48975
   695
       REPEAT_DETERM o dtac @{thm meta_spec},
blanchet@49306
   696
       dtac meta_mp, atac,
blanchet@49306
   697
       dtac meta_mp, atac, etac mp,
blanchet@48975
   698
       rtac conjI, rtac CollectI, CONJ_WRAP' use_act_asm set_sets,
blanchet@48975
   699
       rtac conjI, rtac CollectI, CONJ_WRAP' use_act_asm set_sets,
blanchet@48975
   700
       atac];
blanchet@48975
   701
blanchet@49306
   702
    fun mk_subset thm = EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm Un_least}, atac,
blanchet@48975
   703
      REPEAT_DETERM_N (n - 1) o rtac @{thm Un_least},
blanchet@48975
   704
      REPEAT_DETERM_N n o
blanchet@49306
   705
        EVERY' [rtac @{thm UN_least}, rtac CollectE, etac set_rev_mp, atac,
blanchet@48975
   706
          REPEAT_DETERM o etac conjE, atac]];
blanchet@48975
   707
blanchet@49542
   708
    fun mk_wpull wpull ctor_map ctor_sets set_setss ctor_inject =
blanchet@48975
   709
      EVERY' [rtac impI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
blanchet@48975
   710
        rtac rev_mp, rtac wpull,
blanchet@48975
   711
        EVERY' (map (fn i => REPEAT_DETERM_N (i - 1) o etac thin_rl THEN' atac) ls),
blanchet@48975
   712
        EVERY' (map2 useIH (transpose (map tl set_setss)) ks),
blanchet@48975
   713
        rtac impI, REPEAT_DETERM_N (m + n) o etac thin_rl,
blanchet@48975
   714
        dtac @{thm subst[OF wpull_def, of "%x. x"]}, etac allE, etac allE, etac impE,
blanchet@48975
   715
        rtac conjI, rtac CollectI, EVERY' (map (use_pass_asm o hd) set_setss),
blanchet@48975
   716
          CONJ_WRAP' (K (rtac subset_refl)) ks,
blanchet@48975
   717
        rtac conjI, rtac CollectI, EVERY' (map (use_pass_asm o hd) set_setss),
blanchet@48975
   718
          CONJ_WRAP' (K (rtac subset_refl)) ks,
blanchet@49541
   719
        rtac subst, rtac ctor_inject, rtac trans, rtac sym, rtac ctor_map,
blanchet@49541
   720
        rtac trans, atac, rtac ctor_map, REPEAT_DETERM o eresolve_tac [CollectE, conjE, bexE],
wenzelm@51798
   721
        hyp_subst_tac ctxt, rtac bexI, rtac conjI, rtac ctor_map, rtac ctor_map, rtac CollectI,
blanchet@49542
   722
        CONJ_WRAP' mk_subset ctor_sets];
blanchet@48975
   723
  in
blanchet@49542
   724
    (induct_tac THEN' EVERY' (map5 mk_wpull wpulls ctor_maps ctor_setss set_setsss ctor_injects)) 1
blanchet@48975
   725
  end;
blanchet@48975
   726
blanchet@48975
   727
(* BNF tactics *)
blanchet@48975
   728
blanchet@48975
   729
fun mk_map_id_tac map_ids unique =
blanchet@48975
   730
  (rtac sym THEN' rtac unique THEN'
blanchet@48975
   731
  EVERY' (map (fn thm =>
blanchet@48975
   732
    EVERY' [rtac trans, rtac @{thm id_o}, rtac trans, rtac sym, rtac @{thm o_id},
blanchet@48975
   733
      rtac (thm RS sym RS arg_cong)]) map_ids)) 1;
blanchet@48975
   734
blanchet@49541
   735
fun mk_map_comp_tac map_comps ctor_maps unique iplus1 =
blanchet@48975
   736
  let
blanchet@48975
   737
    val i = iplus1 - 1;
blanchet@48975
   738
    val unique' = Thm.permute_prems 0 i unique;
blanchet@48975
   739
    val map_comps' = drop i map_comps @ take i map_comps;
blanchet@49541
   740
    val ctor_maps' = drop i ctor_maps @ take i ctor_maps;
blanchet@48975
   741
    fun mk_comp comp simp =
blanchet@48975
   742
      EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, rtac o_apply,
blanchet@48975
   743
        rtac trans, rtac (simp RS arg_cong), rtac trans, rtac simp,
blanchet@48975
   744
        rtac trans, rtac (comp RS arg_cong), rtac sym, rtac o_apply];
blanchet@48975
   745
  in
blanchet@49541
   746
    (rtac sym THEN' rtac unique' THEN' EVERY' (map2 mk_comp map_comps' ctor_maps')) 1
blanchet@48975
   747
  end;
blanchet@48975
   748
blanchet@51766
   749
fun mk_set_map_tac set_nat =
blanchet@48975
   750
  EVERY' (map rtac [ext, trans, o_apply, sym, trans, o_apply, set_nat]) 1;
blanchet@48975
   751
blanchet@48975
   752
fun mk_in_bd_tac sum_Card_order sucbd_Cnotzero incl card_of_min_alg =
blanchet@48975
   753
  EVERY' [rtac ctrans, rtac @{thm card_of_mono1}, rtac subsetI, etac rev_mp,
blanchet@48975
   754
    rtac incl, rtac ctrans, rtac card_of_min_alg, rtac @{thm cexp_mono2_Cnotzero},
traytel@51782
   755
    rtac @{thm cardSuc_ordLeq_cpow}, rtac sum_Card_order, rtac @{thm Card_order_csum},
traytel@51782
   756
    rtac sucbd_Cnotzero] 1;
blanchet@48975
   757
blanchet@48975
   758
fun mk_bd_card_order_tac bd_card_orders =
blanchet@48975
   759
  (rtac @{thm card_order_cpow} THEN'
blanchet@48975
   760
    CONJ_WRAP_GEN' (rtac @{thm card_order_csum}) rtac bd_card_orders) 1;
blanchet@48975
   761
blanchet@48975
   762
fun mk_wpull_tac wpull =
blanchet@48975
   763
  EVERY' [rtac ssubst, rtac @{thm wpull_def}, rtac allI, rtac allI,
blanchet@48975
   764
    rtac wpull, REPEAT_DETERM o atac] 1;
blanchet@48975
   765
wenzelm@51798
   766
fun mk_wit_tac ctxt n ctor_set wit =
blanchet@48975
   767
  REPEAT_DETERM (atac 1 ORELSE
blanchet@49585
   768
    EVERY' [dtac set_rev_mp, rtac equalityD1, resolve_tac ctor_set,
blanchet@48975
   769
    REPEAT_DETERM o
blanchet@48975
   770
      (TRY o REPEAT_DETERM o etac UnE THEN' TRY o etac @{thm UN_E} THEN'
blanchet@48975
   771
        (eresolve_tac wit ORELSE'
blanchet@48975
   772
        (dresolve_tac wit THEN'
blanchet@48975
   773
          (etac FalseE ORELSE'
wenzelm@51798
   774
          EVERY' [hyp_subst_tac ctxt, dtac set_rev_mp, rtac equalityD1, resolve_tac ctor_set,
blanchet@48975
   775
            REPEAT_DETERM_N n o etac UnE]))))] 1);
blanchet@48975
   776
traytel@51893
   777
fun mk_ctor_rel_tac ctxt in_Irels i in_rel map_comp map_cong0 ctor_map ctor_sets ctor_inject
blanchet@51766
   778
  ctor_dtor set_maps ctor_set_incls ctor_set_set_inclss =
blanchet@48975
   779
  let
blanchet@49544
   780
    val m = length ctor_set_incls;
blanchet@49544
   781
    val n = length ctor_set_set_inclss;
blanchet@48975
   782
blanchet@51766
   783
    val (passive_set_maps, active_set_maps) = chop m set_maps;
traytel@51893
   784
    val in_Irel = nth in_Irels (i - 1);
blanchet@49501
   785
    val le_arg_cong_ctor_dtor = ctor_dtor RS arg_cong RS ord_eq_le_trans;
blanchet@49501
   786
    val eq_arg_cong_ctor_dtor = ctor_dtor RS arg_cong RS trans;
blanchet@48975
   787
    val if_tac =
traytel@51893
   788
      EVERY' [dtac (in_Irel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
traytel@51893
   789
        rtac (in_rel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
blanchet@51766
   790
        EVERY' (map2 (fn set_map => fn ctor_set_incl =>
blanchet@51766
   791
          EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac set_map,
blanchet@49306
   792
            rtac ord_eq_le_trans, rtac trans_fun_cong_image_id_id_apply,
blanchet@49544
   793
            rtac (ctor_set_incl RS subset_trans), etac le_arg_cong_ctor_dtor])
blanchet@51766
   794
        passive_set_maps ctor_set_incls),
traytel@51893
   795
        CONJ_WRAP' (fn (in_Irel, (set_map, ctor_set_set_incls)) =>
traytel@51893
   796
          EVERY' [rtac ord_eq_le_trans, rtac set_map, rtac @{thm image_subsetI}, rtac CollectI,
traytel@51893
   797
            rtac @{thm prod_caseI}, rtac (in_Irel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
blanchet@48975
   798
            CONJ_WRAP' (fn thm =>
blanchet@49501
   799
              EVERY' (map etac [thm RS subset_trans, le_arg_cong_ctor_dtor]))
blanchet@49544
   800
            ctor_set_set_incls,
blanchet@48975
   801
            rtac conjI, rtac refl, rtac refl])
traytel@51893
   802
        (in_Irels ~~ (active_set_maps ~~ ctor_set_set_inclss)),
blanchet@48975
   803
        CONJ_WRAP' (fn conv =>
blanchet@51761
   804
          EVERY' [rtac trans, rtac map_comp, rtac trans, rtac map_cong0,
blanchet@48975
   805
          REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
blanchet@48975
   806
          REPEAT_DETERM_N n o EVERY' (map rtac [trans, o_apply, conv]),
blanchet@49541
   807
          rtac (ctor_inject RS iffD1), rtac trans, rtac sym, rtac ctor_map,
blanchet@49501
   808
          etac eq_arg_cong_ctor_dtor])
blanchet@49306
   809
        fst_snd_convs];
blanchet@48975
   810
    val only_if_tac =
traytel@51893
   811
      EVERY' [dtac (in_rel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
traytel@51893
   812
        rtac (in_Irel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
blanchet@51766
   813
        CONJ_WRAP' (fn (ctor_set, passive_set_map) =>
blanchet@49585
   814
          EVERY' [rtac ord_eq_le_trans, rtac ctor_set, rtac @{thm Un_least},
blanchet@49306
   815
            rtac ord_eq_le_trans, rtac @{thm box_equals[OF _ refl]},
blanchet@51766
   816
            rtac passive_set_map, rtac trans_fun_cong_image_id_id_apply, atac,
blanchet@48975
   817
            CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
traytel@51893
   818
              (fn (active_set_map, in_Irel) => EVERY' [rtac ord_eq_le_trans,
blanchet@51766
   819
                rtac @{thm UN_cong[OF _ refl]}, rtac active_set_map, rtac @{thm UN_least},
blanchet@49306
   820
                dtac set_rev_mp, etac @{thm image_mono}, etac imageE,
traytel@51893
   821
                dtac @{thm ssubst_mem[OF pair_collapse]},
traytel@51893
   822
                REPEAT_DETERM o eresolve_tac (CollectE :: conjE ::
traytel@51893
   823
                  @{thms prod_caseE iffD1[OF Pair_eq, elim_format]}),
traytel@51893
   824
                hyp_subst_tac ctxt,
traytel@51893
   825
                dtac (in_Irel RS iffD1), dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE,
traytel@51893
   826
                TRY o
traytel@51893
   827
                  EVERY' [dtac (Thm.permute_prems 0 1 @{thm ssubst_mem}), atac, hyp_subst_tac ctxt],
traytel@51893
   828
                REPEAT_DETERM o eresolve_tac [CollectE, conjE], atac])
traytel@51893
   829
            (rev (active_set_maps ~~ in_Irels))])
blanchet@51766
   830
        (ctor_sets ~~ passive_set_maps),
blanchet@48975
   831
        rtac conjI,
blanchet@49541
   832
        REPEAT_DETERM_N 2 o EVERY' [rtac trans, rtac ctor_map, rtac (ctor_inject RS iffD2),
blanchet@51761
   833
          rtac trans, rtac map_comp, rtac trans, rtac map_cong0,
blanchet@48975
   834
          REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
traytel@51893
   835
          EVERY' (map (fn in_Irel => EVERY' [rtac trans, rtac o_apply, dtac set_rev_mp, atac,
traytel@51893
   836
            dtac @{thm ssubst_mem[OF pair_collapse]},
traytel@51893
   837
            REPEAT_DETERM o
traytel@51893
   838
              eresolve_tac (CollectE :: conjE :: @{thms prod_caseE iffD1[OF Pair_eq, elim_format]}),
traytel@51893
   839
            hyp_subst_tac ctxt,
traytel@51893
   840
            dtac (in_Irel RS iffD1), dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE, atac])
traytel@51893
   841
          in_Irels),
blanchet@48975
   842
          atac]]
blanchet@48975
   843
  in
blanchet@48975
   844
    EVERY' [rtac iffI, if_tac, only_if_tac] 1
blanchet@48975
   845
  end;
blanchet@48975
   846
blanchet@48975
   847
end;