src/Provers/splitter.ML
changeset 42367 577d85fb5862
parent 42364 8c674b3b8e44
child 45620 f2a587696afb
equal deleted inserted replaced
42366:2305c70ec9b1 42367:577d85fb5862
   220    see Pure/pattern.ML for the full version;
   220    see Pure/pattern.ML for the full version;
   221 *)
   221 *)
   222 local
   222 local
   223   exception MATCH
   223   exception MATCH
   224 in
   224 in
   225   fun typ_match sg (tyenv, TU) = (Sign.typ_match sg TU tyenv)
   225   fun typ_match thy (tyenv, TU) = Sign.typ_match thy TU tyenv
   226                             handle Type.TYPE_MATCH => raise MATCH
   226     handle Type.TYPE_MATCH => raise MATCH;
   227 
   227 
   228   fun fomatch sg args =
   228   fun fomatch thy args =
   229     let
   229     let
   230       fun mtch tyinsts = fn
   230       fun mtch tyinsts = fn
   231           (Ts, Var(_,T), t) =>
   231           (Ts, Var(_,T), t) =>
   232             typ_match sg (tyinsts, (T, fastype_of1(Ts,t)))
   232             typ_match thy (tyinsts, (T, fastype_of1(Ts,t)))
   233         | (_, Free (a,T), Free (b,U)) =>
   233         | (_, Free (a,T), Free (b,U)) =>
   234             if a=b then typ_match sg (tyinsts,(T,U)) else raise MATCH
   234             if a=b then typ_match thy (tyinsts,(T,U)) else raise MATCH
   235         | (_, Const (a,T), Const (b,U)) =>
   235         | (_, Const (a,T), Const (b,U)) =>
   236             if a=b then typ_match sg (tyinsts,(T,U)) else raise MATCH
   236             if a=b then typ_match thy (tyinsts,(T,U)) else raise MATCH
   237         | (_, Bound i, Bound j) =>
   237         | (_, Bound i, Bound j) =>
   238             if i=j then tyinsts else raise MATCH
   238             if i=j then tyinsts else raise MATCH
   239         | (Ts, Abs(_,T,t), Abs(_,U,u)) =>
   239         | (Ts, Abs(_,T,t), Abs(_,U,u)) =>
   240             mtch (typ_match sg (tyinsts,(T,U))) (U::Ts,t,u)
   240             mtch (typ_match thy (tyinsts,(T,U))) (U::Ts,t,u)
   241         | (Ts, f$t, g$u) =>
   241         | (Ts, f$t, g$u) =>
   242             mtch (mtch tyinsts (Ts,f,g)) (Ts, t, u)
   242             mtch (mtch tyinsts (Ts,f,g)) (Ts, t, u)
   243         | _ => raise MATCH
   243         | _ => raise MATCH
   244     in (mtch Vartab.empty args; true) handle MATCH => false end;
   244     in (mtch Vartab.empty args; true) handle MATCH => false end;
   245 end;
   245 end;
   246 
   246 
   247 fun split_posns (cmap : (string * (typ * term * thm * typ * int) list) list) sg Ts t =
   247 fun split_posns (cmap : (string * (typ * term * thm * typ * int) list) list) thy Ts t =
   248   let
   248   let
   249     val T' = fastype_of1 (Ts, t);
   249     val T' = fastype_of1 (Ts, t);
   250     fun posns Ts pos apsns (Abs (_, T, t)) =
   250     fun posns Ts pos apsns (Abs (_, T, t)) =
   251           let val U = fastype_of1 (T::Ts,t)
   251           let val U = fastype_of1 (T::Ts,t)
   252           in posns (T::Ts) (0::pos) ((T, U, pos)::apsns) t end
   252           in posns (T::Ts) (0::pos) ((T, U, pos)::apsns) t end
   257             val a =
   257             val a =
   258               case h of
   258               case h of
   259                 Const(c, cT) =>
   259                 Const(c, cT) =>
   260                   let fun find [] = []
   260                   let fun find [] = []
   261                         | find ((gcT, pat, thm, T, n)::tups) =
   261                         | find ((gcT, pat, thm, T, n)::tups) =
   262                             let val t2 = list_comb (h, take n ts)
   262                             let val t2 = list_comb (h, take n ts) in
   263                             in if Sign.typ_instance sg (cT, gcT)
   263                               if Sign.typ_instance thy (cT, gcT) andalso fomatch thy (Ts, pat, t2)
   264                                   andalso fomatch sg (Ts,pat,t2)
   264                               then mk_split_pack(thm,T,T',n,ts,apsns,pos,type_of1(Ts,t2),t2)
   265                                then mk_split_pack(thm,T,T',n,ts,apsns,pos,type_of1(Ts,t2),t2)
   265                               else find tups
   266                                else find tups
       
   267                             end
   266                             end
   268                   in find (these (AList.lookup (op =) cmap c)) end
   267                   in find (these (AList.lookup (op =) cmap c)) end
   269               | _ => []
   268               | _ => []
   270           in snd (fold iter ts (0, a)) end
   269           in snd (fold iter ts (0, a)) end
   271   in posns Ts [] [] t end;
   270   in posns Ts [] [] t end;
   272 
   271 
   273 fun nth_subgoal i thm = nth (prems_of thm) (i - 1);
       
   274 
       
   275 fun shorter ((_,ps,pos,_,_), (_,qs,qos,_,_)) =
   272 fun shorter ((_,ps,pos,_,_), (_,qs,qos,_,_)) =
   276   prod_ord (int_ord o pairself length) (order o pairself length)
   273   prod_ord (int_ord o pairself length) (order o pairself length)
   277     ((ps, pos), (qs, qos));
   274     ((ps, pos), (qs, qos));
   278 
   275 
   279 
   276 
   280 (************************************************************
   277 (************************************************************
   281    call split_posns with appropriate parameters
   278    call split_posns with appropriate parameters
   282 *************************************************************)
   279 *************************************************************)
   283 
   280 
   284 fun select cmap state i =
   281 fun select cmap state i =
   285   let val sg = Thm.theory_of_thm state
   282   let
   286       val goali = nth_subgoal i state
   283     val thy = Thm.theory_of_thm state
   287       val Ts = rev(map #2 (Logic.strip_params goali))
   284     val goal = term_of (Thm.cprem_of state i);
   288       val _ $ t $ _ = Logic.strip_assums_concl goali;
   285     val Ts = rev (map #2 (Logic.strip_params goal));
   289   in (Ts, t, sort shorter (split_posns cmap sg Ts t)) end;
   286     val _ $ t $ _ = Logic.strip_assums_concl goal;
   290 
   287   in (Ts, t, sort shorter (split_posns cmap thy Ts t)) end;
   291 fun exported_split_posns cmap sg Ts t =
   288 
   292   sort shorter (split_posns cmap sg Ts t);
   289 fun exported_split_posns cmap thy Ts t =
       
   290   sort shorter (split_posns cmap thy Ts t);
   293 
   291 
   294 (*************************************************************
   292 (*************************************************************
   295    instantiate lift theorem
   293    instantiate lift theorem
   296 
   294 
   297    if t is of the form
   295    if t is of the form