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 |