equal
deleted
inserted
replaced
233 fun instantiate i n ({context = ctxt2, prems, ...}: Subgoal.focus) = |
233 fun instantiate i n ({context = ctxt2, prems, ...}: Subgoal.focus) = |
234 let |
234 let |
235 fun term_pair_of (ix, (ty, t)) = (Var (ix, ty), t) |
235 fun term_pair_of (ix, (ty, t)) = (Var (ix, ty), t) |
236 fun inst_of_matches tts = |
236 fun inst_of_matches tts = |
237 fold (Pattern.match thy) tts (Vartab.empty, Vartab.empty) |
237 fold (Pattern.match thy) tts (Vartab.empty, Vartab.empty) |
238 |> snd |> Vartab.dest |> map (apply2 (cterm_of thy) o term_pair_of) |
238 |> snd |> Vartab.dest |> map (apply2 (Thm.cterm_of thy) o term_pair_of) |
239 val (cases, (eqs, prems1)) = apsnd (chop (nargs - nparams)) (chop n prems) |
239 val (cases, (eqs, prems1)) = apsnd (chop (nargs - nparams)) (chop n prems) |
240 val case_th = |
240 val case_th = |
241 rewrite_rule ctxt2 (@{thm Predicate.eq_is_eq} :: map meta_eq_of eqs) (nth cases (i - 1)) |
241 rewrite_rule ctxt2 (@{thm Predicate.eq_is_eq} :: map meta_eq_of eqs) (nth cases (i - 1)) |
242 val prems2 = maps (dest_conjunct_prem o rewrite_rule ctxt2 tuple_rew_rules) prems1 |
242 val prems2 = maps (dest_conjunct_prem o rewrite_rule ctxt2 tuple_rew_rules) prems1 |
243 val pats = |
243 val pats = |
245 (take nargs (Thm.prems_of case_th)) |
245 (take nargs (Thm.prems_of case_th)) |
246 val case_th' = |
246 val case_th' = |
247 Thm.instantiate ([], inst_of_matches pats) case_th |
247 Thm.instantiate ([], inst_of_matches pats) case_th |
248 OF replicate nargs @{thm refl} |
248 OF replicate nargs @{thm refl} |
249 val thesis = |
249 val thesis = |
250 Thm.instantiate ([], inst_of_matches (prems_of case_th' ~~ map prop_of prems2)) case_th' |
250 Thm.instantiate ([], inst_of_matches (Thm.prems_of case_th' ~~ map Thm.prop_of prems2)) |
251 OF prems2 |
251 case_th' OF prems2 |
252 in rtac thesis 1 end |
252 in rtac thesis 1 end |
253 in |
253 in |
254 Goal.prove ctxt (Term.add_free_names cases_rule []) [] cases_rule |
254 Goal.prove ctxt (Term.add_free_names cases_rule []) [] cases_rule |
255 (fn {context = ctxt1, ...} => |
255 (fn {context = ctxt1, ...} => |
256 eresolve_tac ctxt1 [pre_cases_rule] 1 THEN (fn st => |
256 eresolve_tac ctxt1 [pre_cases_rule] 1 THEN (fn st => |
275 val thy = Proof_Context.theory_of ctxt |
275 val thy = Proof_Context.theory_of ctxt |
276 |
276 |
277 val pos = Position.thread_data () |
277 val pos = Position.thread_data () |
278 fun is_intro_of intro = |
278 fun is_intro_of intro = |
279 let |
279 let |
280 val (const, _) = strip_comb (HOLogic.dest_Trueprop (concl_of intro)) |
280 val (const, _) = strip_comb (HOLogic.dest_Trueprop (Thm.concl_of intro)) |
281 in (fst (dest_Const const) = name) end; |
281 in (fst (dest_Const const) = name) end; |
282 val intros = map (preprocess_intro thy) (filter is_intro_of (#intrs result)) |
282 val intros = map (preprocess_intro thy) (filter is_intro_of (#intrs result)) |
283 val index = find_index (fn s => s = name) (#names (fst info)) |
283 val index = find_index (fn s => s = name) (#names (fst info)) |
284 val pre_elim = nth (#elims result) index |
284 val pre_elim = nth (#elims result) index |
285 val pred = nth (#preds result) index |
285 val pred = nth (#preds result) index |
328 in PredData.map cons_intro thy end |
328 in PredData.map cons_intro thy end |
329 |
329 |
330 fun set_elim thm = |
330 fun set_elim thm = |
331 let |
331 let |
332 val (name, _) = |
332 val (name, _) = |
333 dest_Const (fst (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm))))) |
333 dest_Const (fst (strip_comb (HOLogic.dest_Trueprop (hd (Thm.prems_of thm))))) |
334 in |
334 in |
335 PredData.map (Graph.map_node name (map_pred_data (apsnd (apfst (apfst (apsnd (K (SOME thm)))))))) |
335 PredData.map (Graph.map_node name (map_pred_data (apsnd (apfst (apfst (apsnd (K (SOME thm)))))))) |
336 end |
336 end |
337 |
337 |
338 fun register_predicate (constname, intros, elim) thy = |
338 fun register_predicate (constname, intros, elim) thy = |