187 let val vs = InductAttrib.vars_of concl |
187 let val vs = InductAttrib.vars_of concl |
188 in mapfilter prep_var (Library.drop (length vs - length xs, vs) ~~ xs) end; |
188 in mapfilter prep_var (Library.drop (length vs - length xs, vs) ~~ xs) end; |
189 |
189 |
190 in |
190 in |
191 |
191 |
192 fun gen_induct_tac (varss, opt_rule) i state = |
192 fun gen_induct_tac inst_tac (varss, opt_rule) i state = |
193 let |
193 let |
194 val (_, _, Bi, _) = Thm.dest_state (state, i); |
194 val (_, _, Bi, _) = Thm.dest_state (state, i); |
195 val {sign, ...} = Thm.rep_thm state; |
195 val {sign, ...} = Thm.rep_thm state; |
196 val (rule, rule_name) = |
196 val (rule, rule_name) = |
197 (case opt_rule of |
197 (case opt_rule of |
201 in (#induction (datatype_info_sg_err sign tn), "Induction rule for type " ^ tn) end); |
201 in (#induction (datatype_info_sg_err sign tn), "Induction rule for type " ^ tn) end); |
202 |
202 |
203 val concls = HOLogic.dest_concls (Thm.concl_of rule); |
203 val concls = HOLogic.dest_concls (Thm.concl_of rule); |
204 val insts = flat (map prep_inst (concls ~~ varss)) handle LIST _ => |
204 val insts = flat (map prep_inst (concls ~~ varss)) handle LIST _ => |
205 error (rule_name ^ " has different numbers of variables"); |
205 error (rule_name ^ " has different numbers of variables"); |
206 in occs_in_prems (Tactic.res_inst_tac insts rule) (map #2 insts) i state end; |
206 in occs_in_prems (inst_tac insts rule) (map #2 insts) i state end; |
207 |
207 |
208 fun induct_tac s = gen_induct_tac (map (Library.single o Some) (Syntax.read_idents s), None); |
208 fun induct_tac s = |
|
209 gen_induct_tac Tactic.res_inst_tac |
|
210 (map (Library.single o Some) (Syntax.read_idents s), None); |
209 |
211 |
210 fun induct_thm_tac th s = |
212 fun induct_thm_tac th s = |
211 gen_induct_tac ([map Some (Syntax.read_idents s)], Some th); |
213 gen_induct_tac Tactic.res_inst_tac |
|
214 ([map Some (Syntax.read_idents s)], Some th); |
212 |
215 |
213 end; |
216 end; |
214 |
217 |
215 |
218 |
216 (* generic case tactic for datatypes *) |
219 (* generic case tactic for datatypes *) |
217 |
220 |
218 fun case_inst_tac t rule i state = |
221 fun case_inst_tac inst_tac t rule i state = |
219 let |
222 let |
220 val _ $ Var (ixn, _) $ _ = HOLogic.dest_Trueprop |
223 val _ $ Var (ixn, _) $ _ = HOLogic.dest_Trueprop |
221 (hd (Logic.strip_assums_hyp (hd (Thm.prems_of rule)))); |
224 (hd (Logic.strip_assums_hyp (hd (Thm.prems_of rule)))); |
222 val exh_vname = implode (tl (explode (Syntax.string_of_vname ixn))); |
225 val exh_vname = implode (tl (explode (Syntax.string_of_vname ixn))); |
223 in Tactic.res_inst_tac [(exh_vname, t)] rule i state end; |
226 in inst_tac [(exh_vname, t)] rule i state end; |
224 |
227 |
225 fun gen_case_tac (t, Some rule) i state = case_inst_tac t rule i state |
228 fun gen_case_tac inst_tac (t, Some rule) i state = |
226 | gen_case_tac (t, None) i state = |
229 case_inst_tac inst_tac t rule i state |
|
230 | gen_case_tac inst_tac (t, None) i state = |
227 let val tn = infer_tname state i t in |
231 let val tn = infer_tname state i t in |
228 if tn = HOLogic.boolN then Tactic.res_inst_tac [("P", t)] case_split_thm i state |
232 if tn = HOLogic.boolN then inst_tac [("P", t)] case_split_thm i state |
229 else case_inst_tac t (#exhaustion (datatype_info_sg_err (Thm.sign_of_thm state) tn)) i state |
233 else case_inst_tac inst_tac t |
|
234 (#exhaustion (datatype_info_sg_err (Thm.sign_of_thm state) tn)) |
|
235 i state |
230 end; |
236 end; |
231 |
237 |
232 fun case_tac t = gen_case_tac (t, None); |
238 fun case_tac t = gen_case_tac Tactic.res_inst_tac (t, None); |
233 |
239 |
234 |
240 |
235 |
241 |
236 (** Isar tactic emulations **) |
242 (** Isar tactic emulations **) |
237 |
243 |
240 val rule_spec = Scan.lift (Args.$$$ "rule" -- Args.$$$ ":"); |
246 val rule_spec = Scan.lift (Args.$$$ "rule" -- Args.$$$ ":"); |
241 val opt_rule = Scan.option (rule_spec |-- Attrib.local_thm); |
247 val opt_rule = Scan.option (rule_spec |-- Attrib.local_thm); |
242 |
248 |
243 val varss = Args.and_list (Scan.repeat (Scan.unless rule_spec (Scan.lift Args.name_dummy))); |
249 val varss = Args.and_list (Scan.repeat (Scan.unless rule_spec (Scan.lift Args.name_dummy))); |
244 |
250 |
|
251 fun mk_ixn (vars, s) = (fst (Term.dest_Var (Syntax.read_var ("?" ^ vars))), s) |
|
252 handle _ => error (vars ^ " not a variable name"); |
|
253 fun inst_tac ctxt sinsts = |
|
254 Method.bires_inst_tac false ctxt (map mk_ixn sinsts); |
|
255 |
|
256 fun induct_meth ctxt (varss, opt_rule) = |
|
257 gen_induct_tac (inst_tac ctxt) (varss, opt_rule); |
|
258 fun case_meth ctxt (varss, opt_rule) = |
|
259 gen_case_tac (inst_tac ctxt) (varss, opt_rule); |
|
260 |
245 in |
261 in |
246 |
262 |
247 val tactic_emulations = |
263 val tactic_emulations = |
248 [("induct_tac", Method.goal_args' (varss -- opt_rule) gen_induct_tac, |
264 [("induct_tac", Method.goal_args_ctxt' (varss -- opt_rule) induct_meth, |
249 "induct_tac emulation (dynamic instantiation!)"), |
265 "induct_tac emulation (dynamic instantiation)"), |
250 ("case_tac", Method.goal_args' (Scan.lift Args.name -- opt_rule) gen_case_tac, |
266 ("case_tac", Method.goal_args_ctxt' (Scan.lift Args.name -- opt_rule) case_meth, |
251 "case_tac emulation (dynamic instantiation!)")]; |
267 "case_tac emulation (dynamic instantiation)")]; |
252 |
268 |
253 end; |
269 end; |
254 |
270 |
255 |
271 |
256 |
272 |