1 (* Title: Pure/Isar/method.ML |
1 (* Title: Pure/Isar/method.ML |
2 ID: $Id$ |
2 ID: $Id$ |
3 Author: Markus Wenzel, TU Muenchen |
3 Author: Markus Wenzel, TU Muenchen |
4 |
4 |
5 Proof methods. |
5 Isar proof methods. |
6 *) |
6 *) |
7 |
7 |
8 signature BASIC_METHOD = |
8 signature BASIC_METHOD = |
9 sig |
9 sig |
|
10 val FINDGOAL: (int -> thm -> 'a Seq.seq) -> thm -> 'a Seq.seq |
|
11 val HEADGOAL: (int -> thm -> 'a Seq.seq) -> thm -> 'a Seq.seq |
|
12 type method |
10 val trace_rules: bool ref |
13 val trace_rules: bool ref |
11 val print_methods: theory -> unit |
14 val print_methods: theory -> unit |
12 val Method: bstring -> (Args.src -> Proof.context -> Proof.method) -> string -> unit |
15 val Method: bstring -> (Args.src -> ProofContext.context -> method) -> string -> unit |
13 end; |
16 end; |
14 |
17 |
15 signature METHOD = |
18 signature METHOD = |
16 sig |
19 sig |
17 include BASIC_METHOD |
20 include BASIC_METHOD |
18 type src |
|
19 val trace: Proof.context -> thm list -> unit |
|
20 val RAW_METHOD: (thm list -> tactic) -> Proof.method |
|
21 val RAW_METHOD_CASES: (thm list -> RuleCases.tactic) -> Proof.method |
|
22 val METHOD: (thm list -> tactic) -> Proof.method |
|
23 val METHOD_CASES: (thm list -> RuleCases.tactic) -> Proof.method |
|
24 val SIMPLE_METHOD: tactic -> Proof.method |
|
25 val SIMPLE_METHOD': ((int -> tactic) -> tactic) -> (int -> tactic) -> Proof.method |
|
26 val fail: Proof.method |
|
27 val succeed: Proof.method |
|
28 val defer: int option -> Proof.method |
|
29 val prefer: int -> Proof.method |
|
30 val insert_tac: thm list -> int -> tactic |
|
31 val insert: thm list -> Proof.method |
|
32 val insert_facts: Proof.method |
|
33 val unfold: thm list -> Proof.method |
|
34 val fold: thm list -> Proof.method |
|
35 val multi_resolve: thm list -> thm -> thm Seq.seq |
21 val multi_resolve: thm list -> thm -> thm Seq.seq |
36 val multi_resolves: thm list -> thm list -> thm Seq.seq |
22 val multi_resolves: thm list -> thm list -> thm Seq.seq |
37 val rules_tac: Proof.context -> int option -> int -> tactic |
23 val apply: method -> thm list -> RuleCases.tactic; |
|
24 val RAW_METHOD_CASES: (thm list -> RuleCases.tactic) -> method |
|
25 val RAW_METHOD: (thm list -> tactic) -> method |
|
26 val METHOD_CASES: (thm list -> RuleCases.tactic) -> method |
|
27 val METHOD: (thm list -> tactic) -> method |
|
28 val fail: method |
|
29 val succeed: method |
|
30 val insert_tac: thm list -> int -> tactic |
|
31 val insert: thm list -> method |
|
32 val insert_facts: method |
|
33 val SIMPLE_METHOD: tactic -> method |
|
34 val SIMPLE_METHOD': ((int -> tactic) -> tactic) -> (int -> tactic) -> method |
|
35 val defer: int option -> method |
|
36 val prefer: int -> method |
|
37 val intro: thm list -> method |
|
38 val elim: thm list -> method |
|
39 val unfold: thm list -> method |
|
40 val fold: thm list -> method |
|
41 val atomize: bool -> method |
|
42 val this: method |
|
43 val assumption: ProofContext.context -> method |
|
44 val close: bool -> ProofContext.context -> method |
|
45 val trace: ProofContext.context -> thm list -> unit |
38 val rule_tac: thm list -> thm list -> int -> tactic |
46 val rule_tac: thm list -> thm list -> int -> tactic |
39 val some_rule_tac: thm list -> Proof.context -> thm list -> int -> tactic |
47 val some_rule_tac: thm list -> ProofContext.context -> thm list -> int -> tactic |
40 val rule: thm list -> Proof.method |
48 val rule: thm list -> method |
41 val erule: int -> thm list -> Proof.method |
49 val erule: int -> thm list -> method |
42 val drule: int -> thm list -> Proof.method |
50 val drule: int -> thm list -> method |
43 val frule: int -> thm list -> Proof.method |
51 val frule: int -> thm list -> method |
44 val this: Proof.method |
52 val rules_tac: ProofContext.context -> int option -> int -> tactic |
45 val assumption: Proof.context -> Proof.method |
53 val bires_inst_tac: bool -> ProofContext.context -> (indexname * string) list -> |
46 val bires_inst_tac: bool -> Proof.context -> (indexname * string) list -> thm -> int -> tactic |
54 thm -> int -> tactic |
47 val set_tactic: (Proof.context -> thm list -> tactic) -> unit |
55 val set_tactic: (ProofContext.context -> thm list -> tactic) -> unit |
48 val tactic: string -> Proof.context -> Proof.method |
56 val tactic: string -> ProofContext.context -> method |
49 exception METHOD_FAIL of (string * Position.T) * exn |
57 type src |
50 val method: theory -> src -> Proof.context -> Proof.method |
|
51 val add_method: bstring * (src -> Proof.context -> Proof.method) * string |
|
52 -> theory -> theory |
|
53 val add_methods: (bstring * (src -> Proof.context -> Proof.method) * string) list |
|
54 -> theory -> theory |
|
55 val syntax: (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list)) -> |
|
56 src -> Proof.context -> Proof.context * 'a |
|
57 val simple_args: (Args.T list -> 'a * Args.T list) |
|
58 -> ('a -> Proof.context -> Proof.method) -> src -> Proof.context -> Proof.method |
|
59 val ctxt_args: (Proof.context -> Proof.method) -> src -> Proof.context -> Proof.method |
|
60 val no_args: Proof.method -> src -> Proof.context -> Proof.method |
|
61 type modifier |
|
62 val sectioned_args: (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list)) -> |
|
63 (Args.T list -> modifier * Args.T list) list -> |
|
64 ('a -> Proof.context -> 'b) -> src -> Proof.context -> 'b |
|
65 val bang_sectioned_args: |
|
66 (Args.T list -> modifier * Args.T list) list -> |
|
67 (thm list -> Proof.context -> 'a) -> src -> Proof.context -> 'a |
|
68 val bang_sectioned_args': |
|
69 (Args.T list -> modifier * Args.T list) list -> |
|
70 (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list)) -> |
|
71 ('a -> thm list -> Proof.context -> 'b) -> src -> Proof.context -> 'b |
|
72 val only_sectioned_args: |
|
73 (Args.T list -> modifier * Args.T list) list -> |
|
74 (Proof.context -> 'a) -> src -> Proof.context -> 'a |
|
75 val thms_ctxt_args: (thm list -> Proof.context -> 'a) -> src -> Proof.context -> 'a |
|
76 val thms_args: (thm list -> 'a) -> src -> Proof.context -> 'a |
|
77 val thm_args: (thm -> 'a) -> src -> Proof.context -> 'a |
|
78 datatype text = |
58 datatype text = |
79 Basic of (Proof.context -> Proof.method) | |
59 Basic of (ProofContext.context -> method) | |
80 Source of src | |
60 Source of src | |
81 Then of text list | |
61 Then of text list | |
82 Orelse of text list | |
62 Orelse of text list | |
83 Try of text | |
63 Try of text | |
84 Repeat1 of text |
64 Repeat1 of text |
85 val refine: text -> Proof.state -> Proof.state Seq.seq |
65 val default_text: text |
86 val refine_end: text -> Proof.state -> Proof.state Seq.seq |
66 val this_text: text |
87 val proof: text option -> Proof.state -> Proof.state Seq.seq |
67 val done_text: text |
88 val local_qed: bool -> text option |
68 val finish_text: bool -> text option -> text |
89 -> (Proof.context -> string * (string * thm list) list -> unit) * |
69 exception METHOD_FAIL of (string * Position.T) * exn |
90 (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq |
70 val method: theory -> src -> ProofContext.context -> method |
91 val local_terminal_proof: text * text option |
71 val add_methods: (bstring * (src -> ProofContext.context -> method) * string) list |
92 -> (Proof.context -> string * (string * thm list) list -> unit) * |
72 -> theory -> theory |
93 (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq |
73 val add_method: bstring * (src -> ProofContext.context -> method) * string |
94 val local_default_proof: (Proof.context -> string * (string * thm list) list -> unit) * |
74 -> theory -> theory |
95 (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq |
75 val syntax: (ProofContext.context * Args.T list -> 'a * (ProofContext.context * Args.T list)) |
96 val local_immediate_proof: (Proof.context -> string * (string * thm list) list -> unit) * |
76 -> src -> ProofContext.context -> ProofContext.context * 'a |
97 (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq |
77 val simple_args: (Args.T list -> 'a * Args.T list) |
98 val local_done_proof: (Proof.context -> string * (string * thm list) list -> unit) * |
78 -> ('a -> ProofContext.context -> method) -> src -> ProofContext.context -> method |
99 (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq |
79 val ctxt_args: (ProofContext.context -> method) -> src -> ProofContext.context -> method |
100 val global_qed: bool -> text option |
80 val no_args: method -> src -> ProofContext.context -> method |
101 -> Proof.state -> theory * ((string * string) * (string * thm list) list) |
81 type modifier |
102 val global_terminal_proof: text * text option |
82 val sectioned_args: (ProofContext.context * Args.T list -> |
103 -> Proof.state -> theory * ((string * string) * (string * thm list) list) |
83 'a * (ProofContext.context * Args.T list)) -> |
104 val global_default_proof: Proof.state -> theory * ((string * string) * (string * thm list) list) |
84 (Args.T list -> modifier * Args.T list) list -> |
105 val global_immediate_proof: Proof.state -> |
85 ('a -> ProofContext.context -> 'b) -> src -> ProofContext.context -> 'b |
106 theory * ((string * string) * (string * thm list) list) |
86 val bang_sectioned_args: |
107 val global_done_proof: Proof.state -> theory * ((string * string) * (string * thm list) list) |
87 (Args.T list -> modifier * Args.T list) list -> |
|
88 (thm list -> ProofContext.context -> 'a) -> src -> ProofContext.context -> 'a |
|
89 val bang_sectioned_args': |
|
90 (Args.T list -> modifier * Args.T list) list -> |
|
91 (ProofContext.context * Args.T list -> 'a * (ProofContext.context * Args.T list)) -> |
|
92 ('a -> thm list -> ProofContext.context -> 'b) -> src -> ProofContext.context -> 'b |
|
93 val only_sectioned_args: |
|
94 (Args.T list -> modifier * Args.T list) list -> |
|
95 (ProofContext.context -> 'a) -> src -> ProofContext.context -> 'a |
|
96 val thms_ctxt_args: (thm list -> ProofContext.context -> 'a) -> src -> |
|
97 ProofContext.context -> 'a |
|
98 val thms_args: (thm list -> 'a) -> src -> ProofContext.context -> 'a |
|
99 val thm_args: (thm -> 'a) -> src -> ProofContext.context -> 'a |
108 val goal_args: (Args.T list -> 'a * Args.T list) -> ('a -> int -> tactic) |
100 val goal_args: (Args.T list -> 'a * Args.T list) -> ('a -> int -> tactic) |
109 -> src -> Proof.context -> Proof.method |
101 -> src -> ProofContext.context -> method |
110 val goal_args': (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list)) |
102 val goal_args': (ProofContext.context * Args.T list -> |
111 -> ('a -> int -> tactic) -> src -> Proof.context -> Proof.method |
103 'a * (ProofContext.context * Args.T list)) |
112 val goal_args_ctxt: (Args.T list -> 'a * Args.T list) -> (Proof.context -> 'a -> int -> tactic) |
104 -> ('a -> int -> tactic) -> src -> ProofContext.context -> method |
113 -> src -> Proof.context -> Proof.method |
105 val goal_args_ctxt: (Args.T list -> 'a * Args.T list) -> |
114 val goal_args_ctxt': (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list)) |
106 (ProofContext.context -> 'a -> int -> tactic) -> src -> ProofContext.context -> method |
115 -> (Proof.context -> 'a -> int -> tactic) -> src -> Proof.context -> Proof.method |
107 val goal_args_ctxt': (ProofContext.context * Args.T list -> |
|
108 'a * (ProofContext.context * Args.T list)) -> |
|
109 (ProofContext.context -> 'a -> int -> tactic) -> src -> ProofContext.context -> method |
116 end; |
110 end; |
117 |
111 |
118 structure Method: METHOD = |
112 structure Method: METHOD = |
119 struct |
113 struct |
120 |
114 |
121 type src = Args.src; |
115 (** generic tools **) |
|
116 |
|
117 (* goal addressing *) |
|
118 |
|
119 fun FINDGOAL tac st = |
|
120 let fun find i n = if i > n then Seq.fail else Seq.APPEND (tac i, find (i + 1) n) |
|
121 in find 1 (Thm.nprems_of st) st end; |
|
122 |
|
123 fun HEADGOAL tac = tac 1; |
|
124 |
|
125 |
|
126 (* multi_resolve *) |
|
127 |
|
128 local |
|
129 |
|
130 fun res th i rule = |
|
131 Thm.biresolution false [(false, th)] i rule handle THM _ => Seq.empty; |
|
132 |
|
133 fun multi_res _ [] rule = Seq.single rule |
|
134 | multi_res i (th :: ths) rule = Seq.flat (Seq.map (res th i) (multi_res (i + 1) ths rule)); |
|
135 |
|
136 in |
|
137 |
|
138 val multi_resolve = multi_res 1; |
|
139 fun multi_resolves facts rules = Seq.flat (Seq.map (multi_resolve facts) (Seq.of_list rules)); |
|
140 |
|
141 end; |
|
142 |
122 |
143 |
123 |
144 |
124 (** proof methods **) |
145 (** proof methods **) |
125 |
146 |
126 (* tracing *) |
147 (* datatype method *) |
127 |
148 |
128 val trace_rules = ref false; |
149 datatype method = Method of thm list -> RuleCases.tactic; |
129 |
150 |
130 fun trace ctxt rules = |
151 fun apply (Method m) = m; |
131 conditional (! trace_rules andalso not (null rules)) (fn () => |
152 |
132 Pretty.big_list "rules:" (map (ProofContext.pretty_thm ctxt) rules) |
153 val RAW_METHOD_CASES = Method; |
133 |> Pretty.string_of |> tracing); |
154 |
134 |
155 fun RAW_METHOD tac = RAW_METHOD_CASES (NO_CASES o tac); |
135 |
156 |
136 (* make methods *) |
157 fun METHOD_CASES tac = RAW_METHOD_CASES (fn facts => |
137 |
158 Seq.THEN (TRY Tactic.conjunction_tac, tac facts)); |
138 val RAW_METHOD = Proof.method; |
159 |
139 val RAW_METHOD_CASES = Proof.method_cases; |
160 fun METHOD tac = RAW_METHOD (fn facts => |
140 |
161 TRY Tactic.conjunction_tac THEN tac facts); |
141 fun METHOD m = Proof.method (fn facts => TRY Tactic.conjunction_tac THEN m facts); |
|
142 fun METHOD_CASES m = |
|
143 Proof.method_cases (fn facts => Seq.THEN (TRY Tactic.conjunction_tac, m facts)); |
|
144 |
|
145 |
|
146 (* primitive *) |
|
147 |
162 |
148 val fail = METHOD (K no_tac); |
163 val fail = METHOD (K no_tac); |
149 val succeed = METHOD (K all_tac); |
164 val succeed = METHOD (K all_tac); |
150 |
165 |
151 |
166 |
152 (* shuffle *) |
167 (* insert facts *) |
153 |
|
154 fun prefer i = METHOD (K (Tactic.defer_tac i THEN PRIMITIVE (Thm.permute_prems 0 ~1))); |
|
155 fun defer opt_i = METHOD (K (Tactic.defer_tac (if_none opt_i 1))); |
|
156 |
|
157 |
|
158 (* insert *) |
|
159 |
168 |
160 local |
169 local |
161 |
170 |
162 fun cut_rule_tac raw_rule = |
171 fun cut_rule_tac raw_rule = |
163 let |
172 let |
189 |
210 |
190 fun atomize false = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o ObjectLogic.atomize_tac) |
211 fun atomize false = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o ObjectLogic.atomize_tac) |
191 | atomize true = RAW_METHOD (K (HEADGOAL (CHANGED_PROP o ObjectLogic.full_atomize_tac))); |
212 | atomize true = RAW_METHOD (K (HEADGOAL (CHANGED_PROP o ObjectLogic.full_atomize_tac))); |
192 |
213 |
193 |
214 |
194 (* unfold intro/elim rules *) |
215 (* this -- apply facts directly *) |
195 |
216 |
196 fun intro ths = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o REPEAT_ALL_NEW (Tactic.match_tac ths)); |
217 val this = METHOD (EVERY o map (HEADGOAL o Tactic.rtac)); |
197 fun elim ths = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o REPEAT_ALL_NEW (Tactic.ematch_tac ths)); |
218 |
198 |
219 |
199 |
220 (* assumption *) |
200 (* multi_resolve *) |
|
201 |
221 |
202 local |
222 local |
203 |
223 |
204 fun res th i rule = |
224 fun asm_tac ths = |
205 Thm.biresolution false [(false, th)] i rule handle THM _ => Seq.empty; |
225 foldr (op APPEND') (K no_tac) (map (fn th => Tactic.rtac th THEN_ALL_NEW assume_tac) ths); |
206 |
226 |
207 fun multi_res _ [] rule = Seq.single rule |
227 val refl_tac = SUBGOAL (fn (prop, i) => |
208 | multi_res i (th :: ths) rule = Seq.flat (Seq.map (res th i) (multi_res (i + 1) ths rule)); |
228 if can Logic.dest_equals (Logic.strip_assums_concl prop) |
|
229 then Tactic.rtac Drule.reflexive_thm i else no_tac); |
|
230 |
|
231 fun assm_tac ctxt = |
|
232 assume_tac APPEND' |
|
233 asm_tac (ProofContext.prems_of ctxt) APPEND' |
|
234 refl_tac; |
|
235 |
|
236 fun assumption_tac ctxt [] = assm_tac ctxt |
|
237 | assumption_tac _ [fact] = asm_tac [fact] |
|
238 | assumption_tac _ _ = K no_tac; |
209 |
239 |
210 in |
240 in |
211 |
241 |
212 val multi_resolve = multi_res 1; |
242 fun assumption ctxt = METHOD (HEADGOAL o assumption_tac ctxt); |
213 fun multi_resolves facts rules = Seq.flat (Seq.map (multi_resolve facts) (Seq.of_list rules)); |
243 fun close asm ctxt = METHOD (K |
214 |
244 (FILTER Thm.no_prems ((if asm then ALLGOALS (assm_tac ctxt) else all_tac) THEN flexflex_tac))); |
215 end; |
245 |
216 |
246 end; |
217 |
247 |
218 (* rules_tac *) |
248 |
|
249 (* rule etc. -- single-step refinements *) |
|
250 |
|
251 val trace_rules = ref false; |
|
252 |
|
253 fun trace ctxt rules = |
|
254 conditional (! trace_rules andalso not (null rules)) (fn () => |
|
255 Pretty.big_list "rules:" (map (ProofContext.pretty_thm ctxt) rules) |
|
256 |> Pretty.string_of |> tracing); |
|
257 |
|
258 local |
|
259 |
|
260 fun gen_rule_tac tac rules [] i st = tac rules i st |
|
261 | gen_rule_tac tac rules facts i st = |
|
262 Seq.flat (Seq.map (fn rule => (tac o single) rule i st) (multi_resolves facts rules)); |
|
263 |
|
264 fun gen_arule_tac tac j rules facts = |
|
265 EVERY' (gen_rule_tac tac rules facts :: replicate j Tactic.assume_tac); |
|
266 |
|
267 fun gen_some_rule_tac tac arg_rules ctxt facts = SUBGOAL (fn (goal, i) => |
|
268 let |
|
269 val rules = |
|
270 if not (null arg_rules) then arg_rules |
|
271 else List.concat (ContextRules.find_rules false facts goal ctxt) |
|
272 in trace ctxt rules; tac rules facts i end); |
|
273 |
|
274 fun meth tac x = METHOD (HEADGOAL o tac x); |
|
275 fun meth' tac x y = METHOD (HEADGOAL o tac x y); |
|
276 |
|
277 in |
|
278 |
|
279 val rule_tac = gen_rule_tac Tactic.resolve_tac; |
|
280 val rule = meth rule_tac; |
|
281 val some_rule_tac = gen_some_rule_tac rule_tac; |
|
282 val some_rule = meth' some_rule_tac; |
|
283 |
|
284 val erule = meth' (gen_arule_tac Tactic.eresolve_tac); |
|
285 val drule = meth' (gen_arule_tac Tactic.dresolve_tac); |
|
286 val frule = meth' (gen_arule_tac Tactic.forward_tac); |
|
287 |
|
288 end; |
|
289 |
|
290 |
|
291 (* rules -- intuitionistic proof search *) |
219 |
292 |
220 local |
293 local |
221 |
294 |
222 val remdups_tac = SUBGOAL (fn (g, i) => |
295 val remdups_tac = SUBGOAL (fn (g, i) => |
223 let val prems = Logic.strip_assums_hyp g in |
296 let val prems = Logic.strip_assums_hyp g in |
246 |
319 |
247 fun step_tac ctxt i = |
320 fun step_tac ctxt i = |
248 REPEAT_DETERM1 (REMDUPS (safe_step_tac ctxt) i) ORELSE |
321 REPEAT_DETERM1 (REMDUPS (safe_step_tac ctxt) i) ORELSE |
249 REMDUPS (unsafe_step_tac ctxt) i; |
322 REMDUPS (unsafe_step_tac ctxt) i; |
250 |
323 |
251 fun intpr_tac ctxt gs d lim = SUBGOAL (fn (g, i) => if d > lim then no_tac else |
324 fun intprover_tac ctxt gs d lim = SUBGOAL (fn (g, i) => if d > lim then no_tac else |
252 let |
325 let |
253 val ps = Logic.strip_assums_hyp g; |
326 val ps = Logic.strip_assums_hyp g; |
254 val c = Logic.strip_assums_concl g; |
327 val c = Logic.strip_assums_concl g; |
255 in |
328 in |
256 if gen_mem (fn ((ps1, c1), (ps2, c2)) => |
329 if gen_mem (fn ((ps1, c1), (ps2, c2)) => |
257 c1 aconv c2 andalso gen_eq_set op aconv ps1 ps2) ((ps, c), gs) then no_tac |
330 c1 aconv c2 andalso gen_eq_set op aconv ps1 ps2) ((ps, c), gs) then no_tac |
258 else (step_tac ctxt THEN_ALL_NEW intpr_tac ctxt ((ps, c) :: gs) (d + 1) lim) i |
331 else (step_tac ctxt THEN_ALL_NEW intprover_tac ctxt ((ps, c) :: gs) (d + 1) lim) i |
259 end); |
332 end); |
260 |
333 |
261 in |
334 in |
262 |
335 |
263 fun rules_tac ctxt opt_lim = |
336 fun rules_tac ctxt opt_lim = |
264 SELECT_GOAL (DEEPEN (2, if_none opt_lim 20) (intpr_tac ctxt [] 0) 4 1); |
337 SELECT_GOAL (DEEPEN (2, if_none opt_lim 20) (intprover_tac ctxt [] 0) 4 1); |
265 |
338 |
266 end; |
339 end; |
267 |
340 |
268 |
341 |
269 (* rule_tac etc. *) |
342 (* rule_tac etc. -- refer to dynamic goal state!! *) |
270 |
|
271 local |
|
272 |
|
273 fun gen_rule_tac tac rules [] i st = tac rules i st |
|
274 | gen_rule_tac tac rules facts i st = |
|
275 Seq.flat (Seq.map (fn rule => (tac o single) rule i st) (multi_resolves facts rules)); |
|
276 |
|
277 fun gen_arule_tac tac j rules facts = |
|
278 EVERY' (gen_rule_tac tac rules facts :: replicate j Tactic.assume_tac); |
|
279 |
|
280 fun gen_some_rule_tac tac arg_rules ctxt facts = SUBGOAL (fn (goal, i) => |
|
281 let |
|
282 val rules = |
|
283 if not (null arg_rules) then arg_rules |
|
284 else List.concat (ContextRules.find_rules false facts goal ctxt) |
|
285 in trace ctxt rules; tac rules facts i end); |
|
286 |
|
287 fun meth tac x = METHOD (HEADGOAL o tac x); |
|
288 fun meth' tac x y = METHOD (HEADGOAL o tac x y); |
|
289 |
|
290 in |
|
291 |
|
292 val rule_tac = gen_rule_tac Tactic.resolve_tac; |
|
293 val rule = meth rule_tac; |
|
294 val some_rule_tac = gen_some_rule_tac rule_tac; |
|
295 val some_rule = meth' some_rule_tac; |
|
296 |
|
297 val erule = meth' (gen_arule_tac Tactic.eresolve_tac); |
|
298 val drule = meth' (gen_arule_tac Tactic.dresolve_tac); |
|
299 val frule = meth' (gen_arule_tac Tactic.forward_tac); |
|
300 |
|
301 end; |
|
302 |
|
303 |
|
304 (* this *) |
|
305 |
|
306 val this = METHOD (EVERY o map (HEADGOAL o Tactic.rtac)); |
|
307 |
|
308 |
|
309 (* assumption *) |
|
310 |
|
311 fun asm_tac ths = |
|
312 foldr (op APPEND') (K no_tac) (map (fn th => Tactic.rtac th THEN_ALL_NEW assume_tac) ths); |
|
313 |
|
314 val refl_tac = SUBGOAL (fn (prop, i) => |
|
315 if can Logic.dest_equals (Logic.strip_assums_concl prop) |
|
316 then Tactic.rtac Drule.reflexive_thm i else no_tac); |
|
317 |
|
318 fun assm_tac ctxt = |
|
319 assume_tac APPEND' |
|
320 asm_tac (ProofContext.prems_of ctxt) APPEND' |
|
321 refl_tac; |
|
322 |
|
323 fun assumption_tac ctxt [] = assm_tac ctxt |
|
324 | assumption_tac _ [fact] = asm_tac [fact] |
|
325 | assumption_tac _ _ = K no_tac; |
|
326 |
|
327 fun assumption ctxt = METHOD (HEADGOAL o assumption_tac ctxt); |
|
328 |
|
329 |
|
330 (* res_inst_tac etc. *) |
|
331 |
|
332 (*Reimplemented to support both static (Isar) and dynamic (proof state) |
|
333 context. By Clemens Ballarin.*) |
|
334 |
343 |
335 fun bires_inst_tac bires_flag ctxt insts thm = |
344 fun bires_inst_tac bires_flag ctxt insts thm = |
336 let |
345 let |
337 val sign = ProofContext.sign_of ctxt; |
346 val thy = ProofContext.theory_of ctxt; |
338 (* Separate type and term insts *) |
347 (* Separate type and term insts *) |
339 fun has_type_var ((x, _), _) = (case Symbol.explode x of |
348 fun has_type_var ((x, _), _) = (case Symbol.explode x of |
340 "'"::cs => true | cs => false); |
349 "'"::cs => true | cs => false); |
341 val Tinsts = List.filter has_type_var insts; |
350 val Tinsts = List.filter has_type_var insts; |
342 val tinsts = filter_out has_type_var insts; |
351 val tinsts = filter_out has_type_var insts; |
415 | THM (msg,_,_) => (warning msg; no_tac st); |
424 | THM (msg,_,_) => (warning msg; no_tac st); |
416 in |
425 in |
417 tac |
426 tac |
418 end; |
427 end; |
419 |
428 |
|
429 local |
|
430 |
420 fun gen_inst _ tac _ (quant, ([], thms)) = |
431 fun gen_inst _ tac _ (quant, ([], thms)) = |
421 METHOD (fn facts => quant (insert_tac facts THEN' tac thms)) |
432 METHOD (fn facts => quant (insert_tac facts THEN' tac thms)) |
422 | gen_inst inst_tac _ ctxt (quant, (insts, [thm])) = |
433 | gen_inst inst_tac _ ctxt (quant, (insts, [thm])) = |
423 METHOD (fn facts => |
434 METHOD (fn facts => |
424 quant (insert_tac facts THEN' inst_tac ctxt insts thm)) |
435 quant (insert_tac facts THEN' inst_tac ctxt insts thm)) |
425 | gen_inst _ _ _ _ = error "Cannot have instantiations with multiple rules"; |
436 | gen_inst _ _ _ _ = error "Cannot have instantiations with multiple rules"; |
426 |
437 |
427 val res_inst_meth = gen_inst (bires_inst_tac false) Tactic.resolve_tac; |
|
428 |
|
429 val eres_inst_meth = gen_inst (bires_inst_tac true) Tactic.eresolve_tac; |
|
430 |
|
431 (* Preserve Var indexes of rl; increment revcut_rl instead. |
438 (* Preserve Var indexes of rl; increment revcut_rl instead. |
432 Copied from tactic.ML *) |
439 Copied from tactic.ML *) |
433 fun make_elim_preserve rl = |
440 fun make_elim_preserve rl = |
434 let val {maxidx,...} = rep_thm rl |
441 let val {maxidx,...} = rep_thm rl |
435 fun cvar xi = cterm_of (Theory.sign_of ProtoPure.thy) (Var(xi,propT)); |
442 fun cvar xi = cterm_of ProtoPure.thy (Var(xi,propT)); |
436 val revcut_rl' = |
443 val revcut_rl' = |
437 instantiate ([], [(cvar("V",0), cvar("V",maxidx+1)), |
444 instantiate ([], [(cvar("V",0), cvar("V",maxidx+1)), |
438 (cvar("W",0), cvar("W",maxidx+1))]) revcut_rl |
445 (cvar("W",0), cvar("W",maxidx+1))]) revcut_rl |
439 val arg = (false, rl, nprems_of rl) |
446 val arg = (false, rl, nprems_of rl) |
440 val [th] = Seq.list_of (bicompose false arg 1 revcut_rl') |
447 val [th] = Seq.list_of (bicompose false arg 1 revcut_rl') |
441 in th end |
448 in th end |
442 handle Bind => raise THM("make_elim_preserve", 1, [rl]); |
449 handle Bind => raise THM("make_elim_preserve", 1, [rl]); |
443 |
450 |
|
451 in |
|
452 |
|
453 val res_inst_meth = gen_inst (bires_inst_tac false) Tactic.resolve_tac; |
|
454 |
|
455 val eres_inst_meth = gen_inst (bires_inst_tac true) Tactic.eresolve_tac; |
|
456 |
444 val cut_inst_meth = |
457 val cut_inst_meth = |
445 gen_inst |
458 gen_inst |
446 (fn ctxt => fn insts => fn thm => |
459 (fn ctxt => fn insts => bires_inst_tac false ctxt insts o make_elim_preserve) |
447 bires_inst_tac false ctxt insts (make_elim_preserve thm)) |
|
448 Tactic.cut_rules_tac; |
460 Tactic.cut_rules_tac; |
449 |
461 |
450 val dres_inst_meth = |
462 val dres_inst_meth = |
451 gen_inst |
463 gen_inst |
452 (fn ctxt => fn insts => fn rule => |
464 (fn ctxt => fn insts => bires_inst_tac true ctxt insts o make_elim_preserve) |
453 bires_inst_tac true ctxt insts (make_elim_preserve rule)) |
|
454 Tactic.dresolve_tac; |
465 Tactic.dresolve_tac; |
455 |
466 |
456 val forw_inst_meth = |
467 val forw_inst_meth = |
457 gen_inst |
468 gen_inst |
458 (fn ctxt => fn insts => fn rule => |
469 (fn ctxt => fn insts => fn rule => |
459 bires_inst_tac false ctxt insts (make_elim_preserve rule) THEN' |
470 bires_inst_tac false ctxt insts (make_elim_preserve rule) THEN' |
460 assume_tac) |
471 assume_tac) |
461 Tactic.forward_tac; |
472 Tactic.forward_tac; |
462 |
473 |
463 fun subgoal_tac ctxt sprop = |
474 fun subgoal_tac ctxt sprop = |
464 DETERM o bires_inst_tac false ctxt [(("psi", 0), sprop)] cut_rl THEN' |
475 DETERM o bires_inst_tac false ctxt [(("psi", 0), sprop)] cut_rl; |
465 SUBGOAL (fn (prop, _) => |
|
466 let val concl' = Logic.strip_assums_concl prop in |
|
467 if null (term_tvars concl') then () |
|
468 else warning "Type variables in new subgoal: add a type constraint?"; |
|
469 all_tac |
|
470 end); |
|
471 |
476 |
472 fun subgoals_tac ctxt sprops = EVERY' (map (subgoal_tac ctxt) sprops); |
477 fun subgoals_tac ctxt sprops = EVERY' (map (subgoal_tac ctxt) sprops); |
473 |
478 |
474 fun thin_tac ctxt s = |
479 fun thin_tac ctxt s = |
475 bires_inst_tac true ctxt [(("V", 0), s)] thin_rl; |
480 bires_inst_tac true ctxt [(("V", 0), s)] thin_rl; |
476 |
481 |
477 |
482 end; |
478 (* simple Prolog interpreter *) |
|
479 |
|
480 fun prolog_tac rules facts = |
|
481 DEPTH_SOLVE_1 (HEADGOAL (Tactic.assume_tac APPEND' Tactic.resolve_tac (facts @ rules))); |
|
482 |
|
483 val prolog = METHOD o prolog_tac; |
|
484 |
483 |
485 |
484 |
486 (* ML tactics *) |
485 (* ML tactics *) |
487 |
486 |
488 val tactic_ref = ref ((fn _ => raise Match): Proof.context -> thm list -> tactic); |
487 val tactic_ref = ref ((fn _ => raise Match): ProofContext.context -> thm list -> tactic); |
489 fun set_tactic f = tactic_ref := f; |
488 fun set_tactic f = tactic_ref := f; |
490 |
489 |
491 fun tactic txt ctxt = METHOD (fn facts => |
490 fun tactic txt ctxt = METHOD (fn facts => |
492 (Context.use_mltext |
491 (Context.use_mltext |
493 ("let fun tactic (ctxt: Proof.context) (facts: thm list) : tactic = \ |
492 ("let fun tactic (ctxt: ProofContext.context) (facts: thm list) : tactic = \ |
494 \let val thm = ProofContext.get_thm_closure ctxt o PureThy.Name\n\ |
493 \let val thm = ProofContext.get_thm_closure ctxt o PureThy.Name\n\ |
495 \ and thms = ProofContext.get_thms_closure ctxt o PureThy.Name in\n" |
494 \ and thms = ProofContext.get_thms_closure ctxt o PureThy.Name in\n" |
496 ^ txt ^ |
495 ^ txt ^ |
497 "\nend in Method.set_tactic tactic end") |
496 "\nend in Method.set_tactic tactic end") |
498 false NONE; |
497 false NONE; |
499 Context.setmp (SOME (ProofContext.theory_of ctxt)) (! tactic_ref ctxt) facts)); |
498 Context.setmp (SOME (ProofContext.theory_of ctxt)) (! tactic_ref ctxt) facts)); |
500 |
499 |
501 |
500 |
502 |
501 |
503 (** methods theory data **) |
502 (** method syntax **) |
504 |
503 |
505 (* data kind 'Isar/methods' *) |
504 (* method text *) |
|
505 |
|
506 type src = Args.src; |
|
507 |
|
508 datatype text = |
|
509 Basic of (ProofContext.context -> method) | |
|
510 Source of src | |
|
511 Then of text list | |
|
512 Orelse of text list | |
|
513 Try of text | |
|
514 Repeat1 of text; |
|
515 |
|
516 val default_text = Source (Args.src (("default", []), Position.none)); |
|
517 val this_text = Basic (K this); |
|
518 val done_text = Basic (K (SIMPLE_METHOD all_tac)); |
|
519 |
|
520 fun finish_text asm NONE = Basic (close asm) |
|
521 | finish_text asm (SOME txt) = Then [txt, Basic (close asm)]; |
|
522 |
|
523 |
|
524 (* method definitions *) |
506 |
525 |
507 structure MethodsData = TheoryDataFun |
526 structure MethodsData = TheoryDataFun |
508 (struct |
527 (struct |
509 val name = "Isar/methods"; |
528 val name = "Isar/methods"; |
510 type T = (((src -> Proof.context -> Proof.method) * string) * stamp) NameSpace.table; |
529 type T = (((src -> ProofContext.context -> method) * string) * stamp) NameSpace.table; |
511 |
530 |
512 val empty = NameSpace.empty_table; |
531 val empty = NameSpace.empty_table; |
513 val copy = I; |
532 val copy = I; |
514 val extend = I; |
533 val extend = I; |
515 fun merge _ tables = NameSpace.merge_tables eq_snd tables handle Symtab.DUPS dups => |
534 fun merge _ tables = NameSpace.merge_tables eq_snd tables handle Symtab.DUPS dups => |
546 | SOME ((mth, _), _) => transform_failure (curry METHOD_FAIL (name, pos)) (mth src)) |
565 | SOME ((mth, _), _) => transform_failure (curry METHOD_FAIL (name, pos)) (mth src)) |
547 end; |
566 end; |
548 in meth end; |
567 in meth end; |
549 |
568 |
550 |
569 |
551 (* add_method(s) *) |
570 (* add method *) |
552 |
571 |
553 fun add_methods raw_meths thy = |
572 fun add_methods raw_meths thy = |
554 let |
573 let |
555 val sg = Theory.sign_of thy; |
|
556 val new_meths = raw_meths |> map (fn (name, f, comment) => |
574 val new_meths = raw_meths |> map (fn (name, f, comment) => |
557 (name, ((f, comment), stamp ()))); |
575 (name, ((f, comment), stamp ()))); |
558 |
576 |
559 fun add meths = NameSpace.extend_table (Sign.naming_of sg) (meths, new_meths) |
577 fun add meths = NameSpace.extend_table (Sign.naming_of thy) (meths, new_meths) |
560 handle Symtab.DUPS dups => |
578 handle Symtab.DUPS dups => |
561 error ("Duplicate declaration of method(s) " ^ commas_quote dups); |
579 error ("Duplicate declaration of method(s) " ^ commas_quote dups); |
562 in MethodsData.map add thy end; |
580 in MethodsData.map add thy end; |
563 |
581 |
564 val add_method = add_methods o Library.single; |
582 val add_method = add_methods o Library.single; |
565 |
583 |
566 (*implicit version*) |
|
567 fun Method name meth cmt = Context.>> (add_methods [(name, meth, cmt)]); |
584 fun Method name meth cmt = Context.>> (add_methods [(name, meth, cmt)]); |
568 |
585 |
569 |
586 |
570 |
587 |
571 (** method syntax **) |
588 (** concrete syntax **) |
572 |
589 |
573 (* basic *) |
590 (* basic *) |
574 |
591 |
575 fun syntax (scan: (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list))) = |
592 fun syntax (scan: |
|
593 (ProofContext.context * Args.T list -> 'a * (ProofContext.context * Args.T list))) = |
576 Args.syntax "method" scan; |
594 Args.syntax "method" scan; |
577 |
595 |
578 fun simple_args scan f src ctxt : Proof.method = |
596 fun simple_args scan f src ctxt : method = |
579 #2 (syntax (Scan.lift (scan >> (fn x => f x ctxt))) src ctxt); |
597 #2 (syntax (Scan.lift (scan >> (fn x => f x ctxt))) src ctxt); |
580 |
598 |
581 fun ctxt_args (f: Proof.context -> Proof.method) src ctxt = |
599 fun ctxt_args (f: ProofContext.context -> method) src ctxt = |
582 #2 (syntax (Scan.succeed (f ctxt)) src ctxt); |
600 #2 (syntax (Scan.succeed (f ctxt)) src ctxt); |
583 |
601 |
584 fun no_args m = ctxt_args (K m); |
602 fun no_args m = ctxt_args (K m); |
585 |
603 |
586 |
604 |
587 (* sections *) |
605 (* sections *) |
588 |
606 |
589 type modifier = (Proof.context -> Proof.context) * Proof.context attribute; |
607 type modifier = (ProofContext.context -> ProofContext.context) * ProofContext.context attribute; |
590 |
608 |
591 local |
609 local |
592 |
610 |
593 fun sect ss = Scan.first (map Scan.lift ss); |
611 fun sect ss = Scan.first (map Scan.lift ss); |
594 fun thms ss = Scan.unless (sect ss) Attrib.local_thms; |
612 fun thms ss = Scan.unless (sect ss) Attrib.local_thms; |
678 fun goal_args_ctxt' args tac src ctxt = |
697 fun goal_args_ctxt' args tac src ctxt = |
679 #2 (syntax (Args.goal_spec HEADGOAL -- args >> |
698 #2 (syntax (Args.goal_spec HEADGOAL -- args >> |
680 (fn (quant, s) => SIMPLE_METHOD' quant (tac ctxt s))) src ctxt); |
699 (fn (quant, s) => SIMPLE_METHOD' quant (tac ctxt s))) src ctxt); |
681 |
700 |
682 fun goal_args_ctxt args tac = goal_args_ctxt' (Scan.lift args) tac; |
701 fun goal_args_ctxt args tac = goal_args_ctxt' (Scan.lift args) tac; |
683 |
|
684 |
|
685 (** method text **) |
|
686 |
|
687 (* datatype text *) |
|
688 |
|
689 datatype text = |
|
690 Basic of (Proof.context -> Proof.method) | |
|
691 Source of src | |
|
692 Then of text list | |
|
693 Orelse of text list | |
|
694 Try of text | |
|
695 Repeat1 of text; |
|
696 |
|
697 |
|
698 (* refine *) |
|
699 |
|
700 fun gen_refine f text state = |
|
701 let |
|
702 val thy = Proof.theory_of state; |
|
703 |
|
704 fun eval (Basic mth) = f mth |
|
705 | eval (Source src) = f (method thy src) |
|
706 | eval (Then txts) = Seq.EVERY (map eval txts) |
|
707 | eval (Orelse txts) = Seq.FIRST (map eval txts) |
|
708 | eval (Try txt) = Seq.TRY (eval txt) |
|
709 | eval (Repeat1 txt) = Seq.REPEAT1 (eval txt); |
|
710 in eval text state end; |
|
711 |
|
712 val refine = gen_refine Proof.refine; |
|
713 val refine_end = gen_refine Proof.refine_end; |
|
714 |
|
715 |
|
716 (* structured proof steps *) |
|
717 |
|
718 val default_text = Source (Args.src (("default", []), Position.none)); |
|
719 val this_text = Basic (K this); |
|
720 val done_text = Basic (K (SIMPLE_METHOD all_tac)); |
|
721 |
|
722 fun close_text asm = Basic (fn ctxt => METHOD (K |
|
723 (FILTER Thm.no_prems ((if asm then ALLGOALS (assm_tac ctxt) else all_tac) THEN flexflex_tac)))); |
|
724 |
|
725 fun finish_text asm NONE = close_text asm |
|
726 | finish_text asm (SOME txt) = Then [txt, close_text asm]; |
|
727 |
|
728 fun proof opt_text state = |
|
729 state |
|
730 |> Proof.assert_backward |
|
731 |> refine (if_none opt_text default_text) |
|
732 |> Seq.map (Proof.goal_facts (K [])) |
|
733 |> Seq.map Proof.enter_forward; |
|
734 |
|
735 fun local_qed asm opt_text = Proof.local_qed (refine (finish_text asm opt_text)); |
|
736 fun local_terminal_proof (text, opt_text) pr = |
|
737 Seq.THEN (proof (SOME text), local_qed true opt_text pr); |
|
738 val local_default_proof = local_terminal_proof (default_text, NONE); |
|
739 val local_immediate_proof = local_terminal_proof (this_text, NONE); |
|
740 fun local_done_proof pr = Seq.THEN (proof (SOME done_text), local_qed false NONE pr); |
|
741 |
|
742 |
|
743 fun global_qeds asm opt_text = Proof.global_qed (refine (finish_text asm opt_text)); |
|
744 |
|
745 fun global_qed asm opt_text state = |
|
746 state |
|
747 |> global_qeds asm opt_text |
|
748 |> Proof.check_result "Failed to finish proof" state |
|
749 |> Seq.hd; |
|
750 |
|
751 fun global_term_proof asm (text, opt_text) state = |
|
752 state |
|
753 |> proof (SOME text) |
|
754 |> Proof.check_result "Terminal proof method failed" state |
|
755 |> (Seq.flat o Seq.map (global_qeds asm opt_text)) |
|
756 |> Proof.check_result "Failed to finish proof (after successful terminal method)" state |
|
757 |> Seq.hd; |
|
758 |
|
759 val global_terminal_proof = global_term_proof true; |
|
760 val global_default_proof = global_terminal_proof (default_text, NONE); |
|
761 val global_immediate_proof = global_terminal_proof (this_text, NONE); |
|
762 val global_done_proof = global_term_proof false (done_text, NONE); |
|
763 |
702 |
764 |
703 |
765 (* misc tactic emulations *) |
704 (* misc tactic emulations *) |
766 |
705 |
767 val subgoal_meth = goal_args_ctxt (Scan.repeat1 Args.name) subgoals_tac; |
706 val subgoal_meth = goal_args_ctxt (Scan.repeat1 Args.name) subgoals_tac; |