17 end |
17 end |
18 |
18 |
19 structure Transfer : TRANSFER = |
19 structure Transfer : TRANSFER = |
20 struct |
20 struct |
21 |
21 |
22 structure Data = Named_Thms |
22 (** Theory Data **) |
|
23 |
|
24 structure Data = Generic_Data |
23 ( |
25 ( |
24 val name = @{binding transfer_raw} |
26 type T = |
25 val description = "raw transfer rule for transfer method" |
27 { transfer_raw : thm Item_Net.T, |
|
28 relator_eq : thm Item_Net.T } |
|
29 val empty = |
|
30 { transfer_raw = Thm.full_rules, |
|
31 relator_eq = Thm.full_rules } |
|
32 val extend = I |
|
33 fun merge ({transfer_raw = t1, relator_eq = r1}, |
|
34 {transfer_raw = t2, relator_eq = r2}) = |
|
35 { transfer_raw = Item_Net.merge (t1, t2), |
|
36 relator_eq = Item_Net.merge (r1, r2) } |
26 ) |
37 ) |
27 |
38 |
28 structure Relator_Eq = Named_Thms |
39 fun get_relator_eq ctxt = ctxt |
29 ( |
40 |> (Item_Net.content o #relator_eq o Data.get o Context.Proof) |
30 val name = @{binding relator_eq} |
41 |> map (Thm.symmetric o mk_meta_eq) |
31 val description = "relator equality rule (used by transfer method)" |
42 |
32 ) |
43 fun get_transfer_raw ctxt = ctxt |
33 |
44 |> (Item_Net.content o #transfer_raw o Data.get o Context.Proof) |
34 fun get_relator_eq ctxt = |
45 |
35 map (Thm.symmetric o mk_meta_eq) (Relator_Eq.get ctxt) |
46 fun map_transfer_raw f {transfer_raw, relator_eq} = |
|
47 { transfer_raw = f transfer_raw, relator_eq = relator_eq } |
|
48 |
|
49 fun map_relator_eq f {transfer_raw, relator_eq} = |
|
50 { transfer_raw = transfer_raw, relator_eq = f relator_eq } |
|
51 |
|
52 fun add_transfer_thm thm = Data.map (map_transfer_raw (Item_Net.update thm)) |
|
53 fun del_transfer_thm thm = Data.map (map_transfer_raw (Item_Net.remove thm)) |
|
54 |
|
55 val relator_eq_setup = |
|
56 let |
|
57 val name = @{binding relator_eq} |
|
58 fun add_thm thm = Data.map (map_relator_eq (Item_Net.update thm)) |
|
59 fun del_thm thm = Data.map (map_relator_eq (Item_Net.remove thm)) |
|
60 val add = Thm.declaration_attribute add_thm |
|
61 val del = Thm.declaration_attribute del_thm |
|
62 val text = "declaration of relator equality rule (used by transfer method)" |
|
63 val content = Item_Net.content o #relator_eq o Data.get |
|
64 in |
|
65 Attrib.setup name (Attrib.add_del add del) text |
|
66 #> Global_Theory.add_thms_dynamic (name, content) |
|
67 end |
36 |
68 |
37 (** Conversions **) |
69 (** Conversions **) |
38 |
70 |
39 val Rel_rule = Thm.symmetric @{thm Rel_def} |
71 val Rel_rule = Thm.symmetric @{thm Rel_def} |
40 |
72 |
191 fun transfer_tac equiv ctxt i = |
223 fun transfer_tac equiv ctxt i = |
192 let |
224 let |
193 val pre_simps = @{thms transfer_forall_eq transfer_implies_eq} |
225 val pre_simps = @{thms transfer_forall_eq transfer_implies_eq} |
194 val start_rule = |
226 val start_rule = |
195 if equiv then @{thm transfer_start} else @{thm transfer_start'} |
227 if equiv then @{thm transfer_start} else @{thm transfer_start'} |
196 val rules = Data.get ctxt |
228 val rules = get_transfer_raw ctxt |
197 (* allow unsolved subgoals only for standard transfer method, not for transfer' *) |
229 (* allow unsolved subgoals only for standard transfer method, not for transfer' *) |
198 val end_tac = if equiv then K all_tac else K no_tac |
230 val end_tac = if equiv then K all_tac else K no_tac |
199 in |
231 in |
200 EVERY |
232 EVERY |
201 [rewrite_goal_tac pre_simps i THEN |
233 [rewrite_goal_tac pre_simps i THEN |
212 |
244 |
213 fun transfer_prover_tac ctxt = SUBGOAL (fn (t, i) => |
245 fun transfer_prover_tac ctxt = SUBGOAL (fn (t, i) => |
214 let |
246 let |
215 val rhs = (snd o Term.dest_comb o HOLogic.dest_Trueprop) t |
247 val rhs = (snd o Term.dest_comb o HOLogic.dest_Trueprop) t |
216 val rule1 = transfer_rule_of_term ctxt rhs |
248 val rule1 = transfer_rule_of_term ctxt rhs |
217 val rules = Data.get ctxt |
249 val rules = get_transfer_raw ctxt |
218 in |
250 in |
219 EVERY |
251 EVERY |
220 [CONVERSION prep_conv i, |
252 [CONVERSION prep_conv i, |
221 rtac @{thm transfer_prover_start} i, |
253 rtac @{thm transfer_prover_start} i, |
222 (rtac rule1 THEN_ALL_NEW |
254 (rtac rule1 THEN_ALL_NEW |
243 (* Attribute for transfer rules *) |
275 (* Attribute for transfer rules *) |
244 |
276 |
245 val prep_rule = Conv.fconv_rule prep_conv |
277 val prep_rule = Conv.fconv_rule prep_conv |
246 |
278 |
247 val transfer_add = |
279 val transfer_add = |
248 Thm.declaration_attribute (Data.add_thm o prep_rule) |
280 Thm.declaration_attribute (add_transfer_thm o prep_rule) |
249 |
281 |
250 val transfer_del = |
282 val transfer_del = |
251 Thm.declaration_attribute (Data.del_thm o prep_rule) |
283 Thm.declaration_attribute (del_transfer_thm o prep_rule) |
252 |
284 |
253 val transfer_attribute = |
285 val transfer_attribute = |
254 Attrib.add_del transfer_add transfer_del |
286 Attrib.add_del transfer_add transfer_del |
255 |
287 |
256 (* Theory setup *) |
288 (* Theory setup *) |
257 |
289 |
258 val setup = |
290 val setup = |
259 Data.setup |
291 relator_eq_setup |
260 #> Relator_Eq.setup |
|
261 #> Attrib.setup @{binding transfer_rule} transfer_attribute |
292 #> Attrib.setup @{binding transfer_rule} transfer_attribute |
262 "transfer rule for transfer method" |
293 "transfer rule for transfer method" |
|
294 #> Global_Theory.add_thms_dynamic |
|
295 (@{binding transfer_raw}, Item_Net.content o #transfer_raw o Data.get) |
263 #> Method.setup @{binding transfer} (transfer_method true) |
296 #> Method.setup @{binding transfer} (transfer_method true) |
264 "generic theorem transfer method" |
297 "generic theorem transfer method" |
265 #> Method.setup @{binding transfer'} (transfer_method false) |
298 #> Method.setup @{binding transfer'} (transfer_method false) |
266 "generic theorem transfer method" |
299 "generic theorem transfer method" |
267 #> Method.setup @{binding transfer_prover} transfer_prover_method |
300 #> Method.setup @{binding transfer_prover} transfer_prover_method |