inst_subst_tac: match types -- no longer assume that subst rule has exactly one type argument;
authorwenzelm
Sat, 24 May 2008 23:52:35 +0200
changeset 269924508f20818af
parent 26991 2aa686443859
child 26993 b952df8d505b
inst_subst_tac: match types -- no longer assume that subst rule has exactly one type argument;
misc tuning -- more cterm operations, more qualified names;
src/Provers/hypsubst.ML
     1.1 --- a/src/Provers/hypsubst.ML	Sat May 24 22:19:35 2008 +0200
     1.2 +++ b/src/Provers/hypsubst.ML	Sat May 24 23:52:35 2008 +0200
     1.3 @@ -143,33 +143,35 @@
     1.4  
     1.5  val ssubst = standard (Data.sym RS Data.subst);
     1.6  
     1.7 -fun inst_subst_tac b rl = SUBGOAL (fn (Bi, i) => fn st =>
     1.8 +fun inst_subst_tac b rl = CSUBGOAL (fn (cBi, i) =>
     1.9    case try (Logic.strip_assums_hyp #> hd #>
    1.10 -      Data.dest_Trueprop #> Data.dest_eq #> pairself contract) Bi of
    1.11 +      Data.dest_Trueprop #> Data.dest_eq #> pairself contract) (Thm.term_of cBi) of
    1.12      SOME (t, t') =>
    1.13        let
    1.14 +        val Bi = Thm.term_of cBi;
    1.15          val ps = Logic.strip_params Bi;
    1.16 -        val U = fastype_of1 (rev (map snd ps), t);
    1.17 +        val U = Term.fastype_of1 (rev (map snd ps), t);
    1.18          val Q = Data.dest_Trueprop (Logic.strip_assums_concl Bi);
    1.19 -        val rl' = Thm.lift_rule (nth (cprems_of st) (i - 1)) rl;
    1.20 -        val Var (ixn, T) = head_of (Data.dest_Trueprop
    1.21 -          (Logic.strip_assums_concl (prop_of rl')));
    1.22 +        val rl' = Thm.lift_rule cBi rl;
    1.23 +        val Var (ixn, T) = Term.head_of (Data.dest_Trueprop
    1.24 +          (Logic.strip_assums_concl (Thm.prop_of rl')));
    1.25          val (v1, v2) = Data.dest_eq (Data.dest_Trueprop
    1.26 -          (Logic.strip_assums_concl (hd (prems_of rl'))));
    1.27 -        val (Ts, V) = split_last (binder_types T);
    1.28 +          (Logic.strip_assums_concl (hd (Thm.prems_of rl'))));
    1.29 +        val (Ts, V) = split_last (Term.binder_types T);
    1.30          val u = list_abs (ps @ [("x", U)], case (if b then t else t') of
    1.31              Bound j => subst_bounds (map Bound
    1.32                ((1 upto j) @ 0 :: (j + 2 upto length ps)), Q)
    1.33 -          | t => abstract_over (t, incr_boundvars 1 Q));
    1.34 -        val thy = theory_of_thm rl'
    1.35 -      in compose_tac (true, instantiate ([(ctyp_of thy V, ctyp_of thy U)],
    1.36 +          | t => Term.abstract_over (t, Term.incr_boundvars 1 Q));
    1.37 +        val thy = Thm.theory_of_thm rl';
    1.38 +        val (instT, _) = Thm.match (pairself (cterm_of thy o Logic.mk_type) (V, U));
    1.39 +      in compose_tac (true, Drule.instantiate (instT,
    1.40          map (pairself (cterm_of thy))
    1.41            [(Var (ixn, Ts ---> U --> body_type T), u),
    1.42             (Var (fst (dest_Var (head_of v1)), Ts ---> U), list_abs (ps, t)),
    1.43             (Var (fst (dest_Var (head_of v2)), Ts ---> U), list_abs (ps, t'))]) rl',
    1.44 -        nprems_of rl) i st
    1.45 +        nprems_of rl) i
    1.46        end
    1.47 -  | NONE => Seq.empty);
    1.48 +  | NONE => no_tac);
    1.49  
    1.50  val imp_intr_tac = rtac Data.imp_intr;
    1.51