34 val insert_facts: Proof.method |
34 val insert_facts: Proof.method |
35 val unfold: thm list -> Proof.method |
35 val unfold: thm list -> Proof.method |
36 val fold: thm list -> Proof.method |
36 val fold: thm list -> Proof.method |
37 val multi_resolve: thm list -> thm -> thm Seq.seq |
37 val multi_resolve: thm list -> thm -> thm Seq.seq |
38 val multi_resolves: thm list -> thm list -> thm Seq.seq |
38 val multi_resolves: thm list -> thm list -> thm Seq.seq |
|
39 val debug_rules: bool ref |
|
40 val rules_tac: Proof.context -> int option -> int -> tactic |
39 val rule_tac: thm list -> thm list -> int -> tactic |
41 val rule_tac: thm list -> thm list -> int -> tactic |
40 val some_rule_tac: thm list -> Proof.context -> thm list -> int -> tactic |
42 val some_rule_tac: thm list -> Proof.context -> thm list -> int -> tactic |
41 val rule: thm list -> Proof.method |
43 val rule: thm list -> Proof.method |
42 val erule: int -> thm list -> Proof.method |
44 val erule: int -> thm list -> Proof.method |
43 val drule: int -> thm list -> Proof.method |
45 val drule: int -> thm list -> Proof.method |
197 fun multi_resolves facts rules = Seq.flat (Seq.map (multi_resolve facts) (Seq.of_list rules)); |
199 fun multi_resolves facts rules = Seq.flat (Seq.map (multi_resolve facts) (Seq.of_list rules)); |
198 |
200 |
199 end; |
201 end; |
200 |
202 |
201 |
203 |
202 (* single rules *) |
204 (* rules_tac *) |
203 |
205 |
204 local |
206 local |
205 |
207 |
206 fun may_unify t nets = RuleContext.orderlist (flat (map (fn net => Net.unify_term net t) nets)); |
208 fun remdups_tac i thm = |
|
209 let val prems = Logic.strip_assums_hyp (Library.nth_elem (i - 1, Thm.prems_of thm)) |
|
210 in REPEAT_DETERM_N (length prems - length (gen_distinct op aconv prems)) |
|
211 (Tactic.ematch_tac [Drule.remdups_rl] i THEN Tactic.eq_assume_tac i) thm |
|
212 end; |
|
213 |
|
214 fun REMDUPS tac = tac THEN_ALL_NEW remdups_tac; |
|
215 |
|
216 fun gen_eq_set e s1 s2 = |
|
217 length s1 = length s2 andalso |
|
218 gen_subset e (s1, s2) andalso gen_subset e (s2, s1); |
|
219 |
|
220 val bires_tac = Tactic.biresolution_from_nets_tac RuleContext.orderlist; |
|
221 |
|
222 fun safe_step_tac ctxt = |
|
223 RuleContext.Swrap ctxt (eq_assume_tac ORELSE' bires_tac true (RuleContext.Snetpair ctxt)); |
|
224 |
|
225 fun unsafe_step_tac ctxt = |
|
226 RuleContext.wrap ctxt (assume_tac APPEND' |
|
227 bires_tac false (RuleContext.Snetpair ctxt) APPEND' |
|
228 bires_tac false (RuleContext.netpair ctxt)); |
|
229 |
|
230 fun step_tac ctxt i = |
|
231 REPEAT_DETERM1 (REMDUPS (safe_step_tac ctxt) i) ORELSE |
|
232 REMDUPS (unsafe_step_tac ctxt) i; |
|
233 |
|
234 fun intpr_tac ctxt gs d lim = SUBGOAL (fn (g, i) => if d > lim then no_tac else |
|
235 let |
|
236 val ps = Logic.strip_assums_hyp g; |
|
237 val c = Logic.strip_assums_concl g; |
|
238 in |
|
239 if gen_mem (fn ((ps1, c1), (ps2, c2)) => |
|
240 c1 aconv c2 andalso gen_eq_set op aconv ps1 ps2) ((ps, c), gs) then no_tac |
|
241 else (step_tac ctxt THEN_ALL_NEW intpr_tac ctxt ((ps, c) :: gs) (d + 1) lim) i |
|
242 end); |
|
243 |
|
244 in |
|
245 |
|
246 val debug_rules = ref false; |
|
247 |
|
248 fun rules_tac ctxt opt_lim = |
|
249 (conditional (! debug_rules) (fn () => RuleContext.print_local_rules ctxt); |
|
250 DEEPEN (2, if_none opt_lim 20) (intpr_tac ctxt [] 0) 4); |
|
251 |
|
252 end; |
|
253 |
|
254 |
|
255 (* rule_tac etc. *) |
|
256 |
|
257 local |
|
258 |
|
259 fun may_unify t nets = RuleContext.orderlist_no_weight |
|
260 (flat (map (fn net => Net.unify_term net t) nets)); |
207 |
261 |
208 fun find_erules [] = K [] |
262 fun find_erules [] = K [] |
209 | find_erules (fact :: _) = may_unify (Logic.strip_assums_concl (#prop (Thm.rep_thm fact))); |
263 | find_erules (fact :: _) = may_unify (Logic.strip_assums_concl (#prop (Thm.rep_thm fact))); |
210 |
264 |
211 fun find_rules goal = may_unify (Logic.strip_assums_concl goal); |
265 fun find_rules goal = may_unify (Logic.strip_assums_concl goal); |
435 fun thm_args f = thms_args (fn [thm] => f thm | _ => error "Single theorem expected"); |
489 fun thm_args f = thms_args (fn [thm] => f thm | _ => error "Single theorem expected"); |
436 |
490 |
437 end; |
491 end; |
438 |
492 |
439 |
493 |
|
494 (* rules syntax *) |
|
495 |
|
496 local |
|
497 |
|
498 val introN = "intro"; |
|
499 val elimN = "elim"; |
|
500 val destN = "dest"; |
|
501 val ruleN = "rule"; |
|
502 |
|
503 fun modifier name kind kind' att = |
|
504 Args.$$$ name |-- (kind >> K None || kind' |-- Args.nat --| Args.colon >> Some) |
|
505 >> (pair (I: Proof.context -> Proof.context) o att); |
|
506 |
|
507 val rules_modifiers = |
|
508 [modifier destN Args.query_colon Args.query RuleContext.dest_query_local, |
|
509 modifier destN Args.bang_colon Args.bang RuleContext.dest_bang_local, |
|
510 modifier destN Args.colon (Scan.succeed ()) RuleContext.dest_local, |
|
511 modifier elimN Args.query_colon Args.query RuleContext.elim_query_local, |
|
512 modifier elimN Args.bang_colon Args.bang RuleContext.elim_bang_local, |
|
513 modifier elimN Args.colon (Scan.succeed ()) RuleContext.elim_local, |
|
514 modifier introN Args.query_colon Args.query RuleContext.intro_query_local, |
|
515 modifier introN Args.bang_colon Args.bang RuleContext.intro_bang_local, |
|
516 modifier introN Args.colon (Scan.succeed ()) RuleContext.intro_local, |
|
517 Args.del -- Args.colon >> K (I, RuleContext.rule_del_local)]; |
|
518 |
|
519 in |
|
520 |
|
521 fun rules_args m = bang_sectioned_args' rules_modifiers (Scan.lift (Scan.option Args.nat)) m; |
|
522 |
|
523 fun rules_meth n prems ctxt = METHOD (fn facts => |
|
524 HEADGOAL (insert_tac (prems @ facts) THEN' rules_tac ctxt n)); |
|
525 |
|
526 end; |
|
527 |
|
528 |
440 (* tactic syntax *) |
529 (* tactic syntax *) |
441 |
530 |
442 fun nat_thms_args f = uncurry f oo |
531 fun nat_thms_args f = uncurry f oo |
443 (#2 oo syntax (Scan.lift (Scan.optional (Args.parens Args.nat) 0) -- Attrib.local_thmss)); |
532 (#2 oo syntax (Scan.lift (Scan.optional (Args.parens Args.nat) 0) -- Attrib.local_thmss)); |
444 |
533 |
557 ("insert", thms_args insert, "insert theorems, ignoring facts (improper)"), |
646 ("insert", thms_args insert, "insert theorems, ignoring facts (improper)"), |
558 ("unfold", thms_args unfold, "unfold definitions"), |
647 ("unfold", thms_args unfold, "unfold definitions"), |
559 ("fold", thms_args fold, "fold definitions"), |
648 ("fold", thms_args fold, "fold definitions"), |
560 ("atomize", no_args (SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o ObjectLogic.atomize_tac)), |
649 ("atomize", no_args (SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o ObjectLogic.atomize_tac)), |
561 "present local premises as object-level statements"), |
650 "present local premises as object-level statements"), |
|
651 ("rules", rules_args rules_meth, "apply many rules, including proof search"), |
562 ("rule", thms_ctxt_args some_rule, "apply some rule"), |
652 ("rule", thms_ctxt_args some_rule, "apply some rule"), |
563 ("erule", nat_thms_args erule, "apply rule in elimination manner (improper)"), |
653 ("erule", nat_thms_args erule, "apply rule in elimination manner (improper)"), |
564 ("drule", nat_thms_args drule, "apply rule in destruct manner (improper)"), |
654 ("drule", nat_thms_args drule, "apply rule in destruct manner (improper)"), |
565 ("frule", nat_thms_args frule, "apply rule in forward manner (improper)"), |
655 ("frule", nat_thms_args frule, "apply rule in forward manner (improper)"), |
566 ("this", no_args this, "apply current facts as rules"), |
656 ("this", no_args this, "apply current facts as rules"), |