32 val FIRST1 : (int -> tactic) list -> tactic |
32 val FIRST1 : (int -> tactic) list -> tactic |
33 val FIRSTGOAL : (int -> tactic) -> tactic |
33 val FIRSTGOAL : (int -> tactic) -> tactic |
34 val INTLEAVE : tactic * tactic -> tactic |
34 val INTLEAVE : tactic * tactic -> tactic |
35 val INTLEAVE' : ('a -> tactic) * ('a -> tactic) -> 'a -> tactic |
35 val INTLEAVE' : ('a -> tactic) * ('a -> tactic) -> 'a -> tactic |
36 val METAHYPS : (thm list -> tactic) -> int -> tactic |
36 val METAHYPS : (thm list -> tactic) -> int -> tactic |
|
37 val metahyps_thms : int -> thm -> thm list option |
37 val no_tac : tactic |
38 val no_tac : tactic |
38 val ORELSE : tactic * tactic -> tactic |
39 val ORELSE : tactic * tactic -> tactic |
39 val ORELSE' : ('a -> tactic) * ('a -> tactic) -> 'a -> tactic |
40 val ORELSE' : ('a -> tactic) * ('a -> tactic) -> 'a -> tactic |
40 val pause_tac : tactic |
41 val pause_tac : tactic |
41 val print_tac : string -> tactic |
42 val print_tac : string -> tactic |
408 T) |
409 T) |
409 |
410 |
410 fun mk_inst (var as Var(v,T)) = (var, free_of "METAHYP1_" (v,T)) |
411 fun mk_inst (var as Var(v,T)) = (var, free_of "METAHYP1_" (v,T)) |
411 in |
412 in |
412 |
413 |
413 fun metahyps_aux_tac tacf (prem,i) state = |
414 (*Common code for METAHYPS and metahyps_thms*) |
414 let val {sign,maxidx,...} = rep_thm state |
415 fun metahyps_split_prem prem = |
415 val cterm = cterm_of sign |
416 let (*find all vars in the hyps -- should find tvars also!*) |
416 (*find all vars in the hyps -- should find tvars also!*) |
|
417 val hyps_vars = foldr add_term_vars [] (Logic.strip_assums_hyp prem) |
417 val hyps_vars = foldr add_term_vars [] (Logic.strip_assums_hyp prem) |
418 val insts = map mk_inst hyps_vars |
418 val insts = map mk_inst hyps_vars |
419 (*replace the hyps_vars by Frees*) |
419 (*replace the hyps_vars by Frees*) |
420 val prem' = subst_atomic insts prem |
420 val prem' = subst_atomic insts prem |
421 val (params,hyps,concl) = strip_context prem' |
421 val (params,hyps,concl) = strip_context prem' |
|
422 in (insts,params,hyps,concl) end; |
|
423 |
|
424 fun metahyps_aux_tac tacf (prem,gno) state = |
|
425 let val (insts,params,hyps,concl) = metahyps_split_prem prem |
|
426 val {sign,maxidx,...} = rep_thm state |
|
427 val cterm = cterm_of sign |
|
428 val chyps = map cterm hyps |
|
429 val hypths = map assume chyps |
|
430 val subprems = map (forall_elim_vars 0) hypths |
422 val fparams = map Free params |
431 val fparams = map Free params |
423 val cparams = map cterm fparams |
432 val cparams = map cterm fparams |
424 and chyps = map cterm hyps |
|
425 val hypths = map assume chyps |
|
426 fun swap_ctpair (t,u) = (cterm u, cterm t) |
433 fun swap_ctpair (t,u) = (cterm u, cterm t) |
427 (*Subgoal variables: make Free; lift type over params*) |
434 (*Subgoal variables: make Free; lift type over params*) |
428 fun mk_subgoal_inst concl_vars (var as Var(v,T)) = |
435 fun mk_subgoal_inst concl_vars (var as Var(v,T)) = |
429 if var mem concl_vars |
436 if var mem concl_vars |
430 then (var, true, free_of "METAHYP2_" (v,T)) |
437 then (var, true, free_of "METAHYP2_" (v,T)) |
458 map mk_subgoal_swap_ctpair subgoal_insts) |
465 map mk_subgoal_swap_ctpair subgoal_insts) |
459 (*discharge assumptions from state in same order*) |
466 (*discharge assumptions from state in same order*) |
460 (implies_intr_list emBs |
467 (implies_intr_list emBs |
461 (forall_intr_list cparams (implies_intr_list chyps Cth))) |
468 (forall_intr_list cparams (implies_intr_list chyps Cth))) |
462 end |
469 end |
463 val subprems = map (forall_elim_vars 0) hypths |
|
464 and st0 = trivial (cterm concl) |
|
465 (*function to replace the current subgoal*) |
470 (*function to replace the current subgoal*) |
466 fun next st = bicompose false (false, relift st, nprems_of st) |
471 fun next st = bicompose false (false, relift st, nprems_of st) |
467 i state |
472 gno state |
468 in Seq.maps next (tacf subprems st0) end; |
473 in Seq.maps next (tacf subprems (trivial (cterm concl))) end; |
|
474 |
469 end; |
475 end; |
|
476 |
|
477 (*Returns the theorem list that METAHYPS would supply to its tactic*) |
|
478 fun metahyps_thms i state = |
|
479 let val prem = Logic.nth_prem (i, Thm.prop_of state) |
|
480 val (insts,params,hyps,concl) = metahyps_split_prem prem |
|
481 val cterm = cterm_of (#sign (rep_thm state)) |
|
482 in SOME (map (forall_elim_vars 0 o assume o cterm) hyps) end |
|
483 handle TERM ("nth_prem", [A]) => NONE; |
470 |
484 |
471 fun METAHYPS tacf = SUBGOAL (metahyps_aux_tac tacf); |
485 fun METAHYPS tacf = SUBGOAL (metahyps_aux_tac tacf); |
472 |
486 |
473 (*Makes a tactic whose effect on a state is given by thmfun: thm->thm seq.*) |
487 (*Makes a tactic whose effect on a state is given by thmfun: thm->thm seq.*) |
474 fun PRIMSEQ thmfun st = thmfun st handle THM _ => Seq.empty; |
488 fun PRIMSEQ thmfun st = thmfun st handle THM _ => Seq.empty; |