src/Tools/induct.ML
changeset 69593 3dda49e08b9d
parent 69590 e65314985426
child 70520 11d8517d9384
equal deleted inserted replaced
69592:a80d8ec6c998 69593:3dda49e08b9d
   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 =>