169 (case find_eq ctxt (Thm.term_of ct) of |
169 (case find_eq ctxt (Thm.term_of ct) of |
170 NONE => NONE |
170 NONE => NONE |
171 | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct)); |
171 | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct)); |
172 |
172 |
173 val rearrange_eqs_simproc = |
173 val rearrange_eqs_simproc = |
174 Simplifier.make_simproc @{context} "rearrange_eqs" |
174 Simplifier.make_simproc \<^context> "rearrange_eqs" |
175 {lhss = [@{term \<open>Pure.all (t :: 'a::{} \<Rightarrow> prop)\<close>}], |
175 {lhss = [\<^term>\<open>Pure.all (t :: 'a::{} \<Rightarrow> prop)\<close>], |
176 proc = fn _ => fn ctxt => fn ct => mk_swap_rrule ctxt ct}; |
176 proc = fn _ => fn ctxt => fn ct => mk_swap_rrule ctxt ct}; |
177 |
177 |
178 |
178 |
179 (* rotate k premises to the left by j, skipping over first j premises *) |
179 (* rotate k premises to the left by j, skipping over first j premises *) |
180 |
180 |
229 type T = (rules * rules) * (rules * rules) * (rules * rules) * simpset; |
229 type T = (rules * rules) * (rules * rules) * (rules * rules) * simpset; |
230 val empty = |
230 val empty = |
231 ((init_rules (left_var_prem o #2), init_rules (Thm.major_prem_of o #2)), |
231 ((init_rules (left_var_prem o #2), init_rules (Thm.major_prem_of o #2)), |
232 (init_rules (right_var_concl o #2), init_rules (Thm.major_prem_of o #2)), |
232 (init_rules (right_var_concl o #2), init_rules (Thm.major_prem_of o #2)), |
233 (init_rules (left_var_concl o #2), init_rules (Thm.concl_of o #2)), |
233 (init_rules (left_var_concl o #2), init_rules (Thm.concl_of o #2)), |
234 simpset_of (empty_simpset @{context} |
234 simpset_of (empty_simpset \<^context> |
235 addsimprocs [rearrange_eqs_simproc] addsimps [Drule.norm_hhf_eq])); |
235 addsimprocs [rearrange_eqs_simproc] addsimps [Drule.norm_hhf_eq])); |
236 val extend = I; |
236 val extend = I; |
237 fun merge (((casesT1, casesP1), (inductT1, inductP1), (coinductT1, coinductP1), simpset1), |
237 fun merge (((casesT1, casesP1), (inductT1, inductP1), (coinductT1, coinductP1), simpset1), |
238 ((casesT2, casesP2), (inductT2, inductP2), (coinductT2, coinductP2), simpset2)) = |
238 ((casesT2, casesP2), (inductT2, inductP2), (coinductT2, coinductP2), simpset2)) = |
239 ((Item_Net.merge (casesT1, casesT2), Item_Net.merge (casesP1, casesP2)), |
239 ((Item_Net.merge (casesT1, casesT2), Item_Net.merge (casesP1, casesP2)), |
660 |
660 |
661 (* arbitrary_tac *) |
661 (* arbitrary_tac *) |
662 |
662 |
663 local |
663 local |
664 |
664 |
665 fun goal_prefix k ((c as Const (@{const_name Pure.all}, _)) $ Abs (a, T, B)) = |
665 fun goal_prefix k ((c as Const (\<^const_name>\<open>Pure.all\<close>, _)) $ Abs (a, T, B)) = |
666 c $ Abs (a, T, goal_prefix k B) |
666 c $ Abs (a, T, goal_prefix k B) |
667 | goal_prefix 0 _ = Term.dummy_prop |
667 | goal_prefix 0 _ = Term.dummy_prop |
668 | goal_prefix k ((c as Const (@{const_name Pure.imp}, _)) $ A $ B) = |
668 | goal_prefix k ((c as Const (\<^const_name>\<open>Pure.imp\<close>, _)) $ A $ B) = |
669 c $ A $ goal_prefix (k - 1) B |
669 c $ A $ goal_prefix (k - 1) B |
670 | goal_prefix _ _ = Term.dummy_prop; |
670 | goal_prefix _ _ = Term.dummy_prop; |
671 |
671 |
672 fun goal_params k (Const (@{const_name Pure.all}, _) $ Abs (_, _, B)) = goal_params k B + 1 |
672 fun goal_params k (Const (\<^const_name>\<open>Pure.all\<close>, _) $ Abs (_, _, B)) = goal_params k B + 1 |
673 | goal_params 0 _ = 0 |
673 | goal_params 0 _ = 0 |
674 | goal_params k (Const (@{const_name Pure.imp}, _) $ _ $ B) = goal_params (k - 1) B |
674 | goal_params k (Const (\<^const_name>\<open>Pure.imp\<close>, _) $ _ $ B) = goal_params (k - 1) B |
675 | goal_params _ _ = 0; |
675 | goal_params _ _ = 0; |
676 |
676 |
677 fun meta_spec_tac ctxt n (x, T) = SUBGOAL (fn (goal, i) => |
677 fun meta_spec_tac ctxt n (x, T) = SUBGOAL (fn (goal, i) => |
678 let |
678 let |
679 val v = Free (x, T); |
679 val v = Free (x, T); |
685 |-> (fn pred $ arg => |
685 |-> (fn pred $ arg => |
686 infer_instantiate ctxt |
686 infer_instantiate ctxt |
687 [(#1 (dest_Var (head_of pred)), Thm.cterm_of ctxt (Logic.rlist_abs (xs, body))), |
687 [(#1 (dest_Var (head_of pred)), Thm.cterm_of ctxt (Logic.rlist_abs (xs, body))), |
688 (#1 (dest_Var (head_of arg)), Thm.cterm_of ctxt (Logic.rlist_abs (xs, v)))]); |
688 (#1 (dest_Var (head_of arg)), Thm.cterm_of ctxt (Logic.rlist_abs (xs, v)))]); |
689 |
689 |
690 fun goal_concl k xs (Const (@{const_name Pure.all}, _) $ Abs (a, T, B)) = |
690 fun goal_concl k xs (Const (\<^const_name>\<open>Pure.all\<close>, _) $ Abs (a, T, B)) = |
691 goal_concl k ((a, T) :: xs) B |
691 goal_concl k ((a, T) :: xs) B |
692 | goal_concl 0 xs B = |
692 | goal_concl 0 xs B = |
693 if not (Term.exists_subterm (fn t => t aconv v) B) then NONE |
693 if not (Term.exists_subterm (fn t => t aconv v) B) then NONE |
694 else SOME (xs, absfree (x, T) (Term.incr_boundvars 1 B)) |
694 else SOME (xs, absfree (x, T) (Term.incr_boundvars 1 B)) |
695 | goal_concl k xs (Const (@{const_name Pure.imp}, _) $ _ $ B) = |
695 | goal_concl k xs (Const (\<^const_name>\<open>Pure.imp\<close>, _) $ _ $ B) = |
696 goal_concl (k - 1) xs B |
696 goal_concl (k - 1) xs B |
697 | goal_concl _ _ _ = NONE; |
697 | goal_concl _ _ _ = NONE; |
698 in |
698 in |
699 (case goal_concl n [] goal of |
699 (case goal_concl n [] goal of |
700 SOME concl => |
700 SOME concl => |