src/Pure/tctical.ML
changeset 19153 0864119a9611
parent 17969 7262f4a45190
child 19229 7183628d7b29
equal deleted inserted replaced
19152:d81fae81f385 19153:0864119a9611
    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;