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 => |
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, |