src/HOL/BNF/Tools/bnf_def_tactics.ML
changeset 51766 f19a4d0ab1bf
parent 51762 219a3063ed29
child 51798 ad3a241def73
equal deleted inserted replaced
51765:224b6eb2313a 51766:f19a4d0ab1bf
     6 Tactics for definition of bounded natural functors.
     6 Tactics for definition of bounded natural functors.
     7 *)
     7 *)
     8 
     8 
     9 signature BNF_DEF_TACTICS =
     9 signature BNF_DEF_TACTICS =
    10 sig
    10 sig
    11   val mk_collect_set_natural_tac: thm list -> tactic
    11   val mk_collect_set_map_tac: thm list -> tactic
    12   val mk_map_id': thm -> thm
    12   val mk_map_id': thm -> thm
    13   val mk_map_comp': thm -> thm
    13   val mk_map_comp': thm -> thm
    14   val mk_map_cong_tac: thm -> tactic
    14   val mk_map_cong_tac: thm -> tactic
    15   val mk_in_mono_tac: int -> tactic
    15   val mk_in_mono_tac: int -> tactic
    16   val mk_map_wppull_tac: thm -> thm -> thm -> thm -> thm list -> tactic
    16   val mk_map_wppull_tac: thm -> thm -> thm -> thm -> thm list -> tactic
    17   val mk_set_natural': thm -> thm
    17   val mk_set_map': thm -> thm
    18 
    18 
    19   val mk_srel_Gr_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
    19   val mk_srel_Gr_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
    20     {prems: thm list, context: Proof.context} -> tactic
    20     {prems: thm list, context: Proof.context} -> tactic
    21   val mk_srel_Id_tac: int -> thm -> thm -> {prems: 'a, context: Proof.context} -> tactic
    21   val mk_srel_Id_tac: int -> thm -> thm -> {prems: 'a, context: Proof.context} -> tactic
    22   val mk_srel_O_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
    22   val mk_srel_O_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
    37 fun mk_map_id' id = mk_trans (fun_cong OF [id]) @{thm id_apply};
    37 fun mk_map_id' id = mk_trans (fun_cong OF [id]) @{thm id_apply};
    38 fun mk_map_comp' comp = @{thm o_eq_dest_lhs} OF [mk_sym comp];
    38 fun mk_map_comp' comp = @{thm o_eq_dest_lhs} OF [mk_sym comp];
    39 fun mk_map_cong_tac cong0 =
    39 fun mk_map_cong_tac cong0 =
    40   (hyp_subst_tac THEN' rtac cong0 THEN'
    40   (hyp_subst_tac THEN' rtac cong0 THEN'
    41    REPEAT_DETERM o (dtac meta_spec THEN' etac meta_mp THEN' atac)) 1;
    41    REPEAT_DETERM o (dtac meta_spec THEN' etac meta_mp THEN' atac)) 1;
    42 fun mk_set_natural' set_natural = set_natural RS @{thm pointfreeE};
    42 fun mk_set_map' set_map = set_map RS @{thm pointfreeE};
    43 fun mk_in_mono_tac n = if n = 0 then rtac subset_UNIV 1
    43 fun mk_in_mono_tac n = if n = 0 then rtac subset_UNIV 1
    44   else (rtac subsetI THEN'
    44   else (rtac subsetI THEN'
    45   rtac CollectI) 1 THEN
    45   rtac CollectI) 1 THEN
    46   REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN
    46   REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN
    47   REPEAT_DETERM_N (n - 1)
    47   REPEAT_DETERM_N (n - 1)
    48     ((rtac conjI THEN' etac subset_trans THEN' atac) 1) THEN
    48     ((rtac conjI THEN' etac subset_trans THEN' atac) 1) THEN
    49   (etac subset_trans THEN' atac) 1;
    49   (etac subset_trans THEN' atac) 1;
    50 
    50 
    51 fun mk_collect_set_natural_tac set_naturals =
    51 fun mk_collect_set_map_tac set_maps =
    52   (rtac (@{thm collect_o} RS trans) THEN' rtac @{thm arg_cong[of _ _ collect]} THEN'
    52   (rtac (@{thm collect_o} RS trans) THEN' rtac @{thm arg_cong[of _ _ collect]} THEN'
    53   EVERY' (map (fn set_natural =>
    53   EVERY' (map (fn set_map =>
    54     rtac (mk_trans @{thm image_insert} @{thm arg_cong2[of _ _ _ _ insert]}) THEN'
    54     rtac (mk_trans @{thm image_insert} @{thm arg_cong2[of _ _ _ _ insert]}) THEN'
    55     rtac set_natural) set_naturals) THEN'
    55     rtac set_map) set_maps) THEN'
    56   rtac @{thm image_empty}) 1;
    56   rtac @{thm image_empty}) 1;
    57 
    57 
    58 fun mk_map_wppull_tac map_id map_cong0 map_wpull map_comp set_naturals =
    58 fun mk_map_wppull_tac map_id map_cong0 map_wpull map_comp set_maps =
    59   if null set_naturals then
    59   if null set_maps then
    60     EVERY' [rtac @{thm wppull_id}, rtac map_wpull, rtac map_id, rtac map_id] 1
    60     EVERY' [rtac @{thm wppull_id}, rtac map_wpull, rtac map_id, rtac map_id] 1
    61   else EVERY' [REPEAT_DETERM o etac conjE, REPEAT_DETERM o dtac @{thm wppull_thePull},
    61   else EVERY' [REPEAT_DETERM o etac conjE, REPEAT_DETERM o dtac @{thm wppull_thePull},
    62     REPEAT_DETERM o etac exE, rtac @{thm wpull_wppull}, rtac map_wpull,
    62     REPEAT_DETERM o etac exE, rtac @{thm wpull_wppull}, rtac map_wpull,
    63     REPEAT_DETERM o rtac @{thm wpull_thePull}, rtac ballI,
    63     REPEAT_DETERM o rtac @{thm wpull_thePull}, rtac ballI,
    64     REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac CollectI,
    64     REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac CollectI,
    65     CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
    65     CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
    66       rtac @{thm image_subsetI}, rtac conjunct1, etac bspec, etac set_mp, atac])
    66       rtac @{thm image_subsetI}, rtac conjunct1, etac bspec, etac set_mp, atac])
    67       set_naturals,
    67       set_maps,
    68     CONJ_WRAP' (fn thm => EVERY' [rtac (map_comp RS trans), rtac (map_comp RS trans),
    68     CONJ_WRAP' (fn thm => EVERY' [rtac (map_comp RS trans), rtac (map_comp RS trans),
    69       rtac (map_comp RS trans RS sym), rtac map_cong0,
    69       rtac (map_comp RS trans RS sym), rtac map_cong0,
    70       REPEAT_DETERM_N (length set_naturals) o EVERY' [rtac (o_apply RS trans),
    70       REPEAT_DETERM_N (length set_maps) o EVERY' [rtac (o_apply RS trans),
    71         rtac (o_apply RS trans RS sym), rtac (o_apply RS trans), rtac thm,
    71         rtac (o_apply RS trans RS sym), rtac (o_apply RS trans), rtac thm,
    72         rtac conjunct2, etac bspec, etac set_mp, atac]]) [conjunct1, conjunct2]] 1;
    72         rtac conjunct2, etac bspec, etac set_mp, atac]]) [conjunct1, conjunct2]] 1;
    73 
    73 
    74 fun mk_srel_Gr_tac srel_O_Grs map_id map_cong0 map_id' map_comp set_naturals
    74 fun mk_srel_Gr_tac srel_O_Grs map_id map_cong0 map_id' map_comp set_maps
    75   {context = ctxt, prems = _} =
    75   {context = ctxt, prems = _} =
    76   let
    76   let
    77     val n = length set_naturals;
    77     val n = length set_maps;
    78   in
    78   in
    79     if null set_naturals then
    79     if null set_maps then
    80       unfold_thms_tac ctxt srel_O_Grs THEN EVERY' [rtac @{thm Gr_UNIV_id}, rtac map_id] 1
    80       unfold_thms_tac ctxt srel_O_Grs THEN EVERY' [rtac @{thm Gr_UNIV_id}, rtac map_id] 1
    81     else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
    81     else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
    82       EVERY' [rtac equalityI, rtac subsetI,
    82       EVERY' [rtac equalityI, rtac subsetI,
    83         REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
    83         REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
    84         REPEAT_DETERM o dtac Pair_eqD,
    84         REPEAT_DETERM o dtac Pair_eqD,
    91           rtac (@{thm snd_conv} RS sym)],
    91           rtac (@{thm snd_conv} RS sym)],
    92         rtac CollectI,
    92         rtac CollectI,
    93         CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
    93         CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
    94           rtac @{thm image_subsetI}, dtac @{thm set_rev_mp}, atac,
    94           rtac @{thm image_subsetI}, dtac @{thm set_rev_mp}, atac,
    95           REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
    95           REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
    96           stac @{thm fst_conv}, atac]) set_naturals,
    96           stac @{thm fst_conv}, atac]) set_maps,
    97         rtac @{thm subrelI}, etac CollectE, REPEAT_DETERM o eresolve_tac [exE, conjE],
    97         rtac @{thm subrelI}, etac CollectE, REPEAT_DETERM o eresolve_tac [exE, conjE],
    98         REPEAT_DETERM o dtac Pair_eqD,
    98         REPEAT_DETERM o dtac Pair_eqD,
    99         REPEAT_DETERM o etac conjE, hyp_subst_tac,
    99         REPEAT_DETERM o etac conjE, hyp_subst_tac,
   100         rtac @{thm relcompI}, rtac @{thm converseI},
   100         rtac @{thm relcompI}, rtac @{thm converseI},
   101         EVERY' (map2 (fn convol => fn map_id =>
   101         EVERY' (map2 (fn convol => fn map_id =>
   106             REPEAT_DETERM o eresolve_tac [CollectE, conjE],
   106             REPEAT_DETERM o eresolve_tac [CollectE, conjE],
   107             rtac CollectI,
   107             rtac CollectI,
   108             CONJ_WRAP' (fn thm =>
   108             CONJ_WRAP' (fn thm =>
   109               EVERY' [rtac @{thm ord_eq_le_trans}, rtac thm, rtac @{thm image_subsetI},
   109               EVERY' [rtac @{thm ord_eq_le_trans}, rtac thm, rtac @{thm image_subsetI},
   110                 rtac @{thm convol_memI[of id _ "%x. x", OF id_apply refl]}, etac set_mp, atac])
   110                 rtac @{thm convol_memI[of id _ "%x. x", OF id_apply refl]}, etac set_mp, atac])
   111             set_naturals])
   111             set_maps])
   112           @{thms fst_convol snd_convol} [map_id', refl])] 1
   112           @{thms fst_convol snd_convol} [map_id', refl])] 1
   113   end;
   113   end;
   114 
   114 
   115 fun mk_srel_Id_tac n srel_Gr map_id {context = ctxt, prems = _} =
   115 fun mk_srel_Id_tac n srel_Gr map_id {context = ctxt, prems = _} =
   116   unfold_thms_tac ctxt [srel_Gr, @{thm Id_alt}] THEN
   116   unfold_thms_tac ctxt [srel_Gr, @{thm Id_alt}] THEN
   123   unfold_thms_tac ctxt srel_O_Grs THEN
   123   unfold_thms_tac ctxt srel_O_Grs THEN
   124     EVERY' [rtac @{thm relcomp_mono}, rtac @{thm iffD2[OF converse_mono]},
   124     EVERY' [rtac @{thm relcomp_mono}, rtac @{thm iffD2[OF converse_mono]},
   125       rtac @{thm Gr_mono}, rtac in_mono, REPEAT_DETERM o atac,
   125       rtac @{thm Gr_mono}, rtac in_mono, REPEAT_DETERM o atac,
   126       rtac @{thm Gr_mono}, rtac in_mono, REPEAT_DETERM o atac] 1;
   126       rtac @{thm Gr_mono}, rtac in_mono, REPEAT_DETERM o atac] 1;
   127 
   127 
   128 fun mk_srel_converse_le_tac srel_O_Grs srel_Id map_cong0 map_comp set_naturals
   128 fun mk_srel_converse_le_tac srel_O_Grs srel_Id map_cong0 map_comp set_maps
   129   {context = ctxt, prems = _} =
   129   {context = ctxt, prems = _} =
   130   let
   130   let
   131     val n = length set_naturals;
   131     val n = length set_maps;
   132   in
   132   in
   133     if null set_naturals then
   133     if null set_maps then
   134       unfold_thms_tac ctxt [srel_Id] THEN rtac equalityD2 1 THEN rtac @{thm converse_Id} 1
   134       unfold_thms_tac ctxt [srel_Id] THEN rtac equalityD2 1 THEN rtac @{thm converse_Id} 1
   135     else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
   135     else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
   136       EVERY' [rtac @{thm subrelI},
   136       EVERY' [rtac @{thm subrelI},
   137         REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
   137         REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
   138         REPEAT_DETERM o dtac Pair_eqD,
   138         REPEAT_DETERM o dtac Pair_eqD,
   141         EVERY' (map (fn thm => EVERY' [rtac CollectI, rtac exI,
   141         EVERY' (map (fn thm => EVERY' [rtac CollectI, rtac exI,
   142           rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl, rtac trans,
   142           rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl, rtac trans,
   143           rtac map_cong0, REPEAT_DETERM_N n o rtac thm,
   143           rtac map_cong0, REPEAT_DETERM_N n o rtac thm,
   144           rtac (map_comp RS sym), rtac CollectI,
   144           rtac (map_comp RS sym), rtac CollectI,
   145           CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
   145           CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
   146             etac @{thm flip_rel}]) set_naturals]) [@{thm snd_fst_flip}, @{thm fst_snd_flip}])] 1
   146             etac @{thm flip_rel}]) set_maps]) [@{thm snd_fst_flip}, @{thm fst_snd_flip}])] 1
   147   end;
   147   end;
   148 
   148 
   149 fun mk_srel_converse_tac le_converse =
   149 fun mk_srel_converse_tac le_converse =
   150   EVERY' [rtac equalityI, rtac le_converse, rtac @{thm xt1(6)}, rtac @{thm converse_shift},
   150   EVERY' [rtac equalityI, rtac le_converse, rtac @{thm xt1(6)}, rtac @{thm converse_shift},
   151     rtac le_converse, REPEAT_DETERM o stac @{thm converse_converse}, rtac subset_refl] 1;
   151     rtac le_converse, REPEAT_DETERM o stac @{thm converse_converse}, rtac subset_refl] 1;
   152 
   152 
   153 fun mk_srel_O_tac srel_O_Grs srel_Id map_cong0 map_wppull map_comp set_naturals
   153 fun mk_srel_O_tac srel_O_Grs srel_Id map_cong0 map_wppull map_comp set_maps
   154   {context = ctxt, prems = _} =
   154   {context = ctxt, prems = _} =
   155   let
   155   let
   156     val n = length set_naturals;
   156     val n = length set_maps;
   157     fun in_tac nthO_in = rtac CollectI THEN'
   157     fun in_tac nthO_in = rtac CollectI THEN'
   158         CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
   158         CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
   159           rtac @{thm image_subsetI}, rtac nthO_in, etac set_mp, atac]) set_naturals;
   159           rtac @{thm image_subsetI}, rtac nthO_in, etac set_mp, atac]) set_maps;
   160   in
   160   in
   161     if null set_naturals then unfold_thms_tac ctxt [srel_Id] THEN rtac (@{thm Id_O_R} RS sym) 1
   161     if null set_maps then unfold_thms_tac ctxt [srel_Id] THEN rtac (@{thm Id_O_R} RS sym) 1
   162     else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
   162     else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
   163       EVERY' [rtac equalityI, rtac @{thm subrelI},
   163       EVERY' [rtac equalityI, rtac @{thm subrelI},
   164         REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
   164         REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
   165         REPEAT_DETERM o dtac Pair_eqD,
   165         REPEAT_DETERM o dtac Pair_eqD,
   166         REPEAT_DETERM o etac conjE, hyp_subst_tac,
   166         REPEAT_DETERM o etac conjE, hyp_subst_tac,
   188         REPEAT_DETERM o eresolve_tac [CollectE, @{thm relcompE}, @{thm converseE}],
   188         REPEAT_DETERM o eresolve_tac [CollectE, @{thm relcompE}, @{thm converseE}],
   189         REPEAT_DETERM o eresolve_tac [exE, conjE],
   189         REPEAT_DETERM o eresolve_tac [exE, conjE],
   190         REPEAT_DETERM o dtac Pair_eqD,
   190         REPEAT_DETERM o dtac Pair_eqD,
   191         REPEAT_DETERM o etac conjE, hyp_subst_tac,
   191         REPEAT_DETERM o etac conjE, hyp_subst_tac,
   192         rtac allE, rtac subst, rtac @{thm wppull_def}, rtac map_wppull,
   192         rtac allE, rtac subst, rtac @{thm wppull_def}, rtac map_wppull,
   193         CONJ_WRAP' (K (rtac @{thm wppull_fstO_sndO})) set_naturals,
   193         CONJ_WRAP' (K (rtac @{thm wppull_fstO_sndO})) set_maps,
   194         etac allE, etac impE, etac conjI, etac conjI, atac,
   194         etac allE, etac impE, etac conjI, etac conjI, atac,
   195         REPEAT_DETERM o eresolve_tac [bexE, conjE],
   195         REPEAT_DETERM o eresolve_tac [bexE, conjE],
   196         rtac @{thm relcompI}, rtac @{thm converseI},
   196         rtac @{thm relcompI}, rtac @{thm converseI},
   197         EVERY' (map (fn thm => EVERY' [rtac CollectI, rtac exI,
   197         EVERY' (map (fn thm => EVERY' [rtac CollectI, rtac exI,
   198           rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl, rtac sym, rtac trans,
   198           rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl, rtac sym, rtac trans,