24 val is_equals : term -> bool |
24 val is_equals : term -> bool |
25 val lift_fns : term * int -> (term -> term) * (term -> term) |
25 val lift_fns : term * int -> (term -> term) * (term -> term) |
26 val list_flexpairs : (term*term)list * term -> term |
26 val list_flexpairs : (term*term)list * term -> term |
27 val list_implies : term list * term -> term |
27 val list_implies : term list * term -> term |
28 val list_rename_params: string list * term -> term |
28 val list_rename_params: string list * term -> term |
29 val rewrite_rule_extra_vars: term list -> term -> term -> string option |
|
30 val rewrite_rule_ok : Sign.sg -> term list -> term -> term |
|
31 -> string option * bool |
|
32 val mk_equals : term * term -> term |
29 val mk_equals : term * term -> term |
33 val mk_flexpair : term * term -> term |
30 val mk_flexpair : term * term -> term |
34 val mk_implies : term * term -> term |
31 val mk_implies : term * term -> term |
35 val mk_inclass : typ * class -> term |
32 val mk_inclass : typ * class -> term |
36 val mk_type : typ -> term |
33 val mk_type : typ -> term |
302 | unvarify (Var(ixn,T)) = Var(ixn, Type.unvarifyT T) (*non-0 index!*) |
299 | unvarify (Var(ixn,T)) = Var(ixn, Type.unvarifyT T) (*non-0 index!*) |
303 | unvarify (Abs (a,T,body)) = Abs (a, Type.unvarifyT T, unvarify body) |
300 | unvarify (Abs (a,T,body)) = Abs (a, Type.unvarifyT T, unvarify body) |
304 | unvarify (f$t) = unvarify f $ unvarify t |
301 | unvarify (f$t) = unvarify f $ unvarify t |
305 | unvarify t = t; |
302 | unvarify t = t; |
306 |
303 |
307 |
|
308 |
|
309 (** Test wellformedness of rewrite rules **) |
|
310 |
|
311 fun vperm (Var _, Var _) = true |
|
312 | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t) |
|
313 | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2) |
|
314 | vperm (t, u) = (t = u); |
|
315 |
|
316 fun var_perm (t, u) = |
|
317 vperm (t, u) andalso eq_set_term (term_vars t, term_vars u); |
|
318 |
|
319 (*simple test for looping rewrite*) |
|
320 fun looptest sign prems lhs rhs = |
|
321 is_Var (head_of lhs) |
|
322 orelse |
|
323 (exists (apl (lhs, op occs)) (rhs :: prems)) |
|
324 orelse |
|
325 (null prems andalso |
|
326 Pattern.matches (#tsig (Sign.rep_sg sign)) (lhs, rhs)) |
|
327 (* orelse |
|
328 (case lhs of |
|
329 (f as Free _) $ (Var _) => exists (fn p => f occs p) prems orelse |
|
330 (null prems andalso f occs rhs) |
|
331 | _ => false)*); |
|
332 (*the condition "null prems" in the last cases is necessary because |
|
333 conditional rewrites with extra variables in the conditions may terminate |
|
334 although the rhs is an instance of the lhs. Example: |
|
335 ?m < ?n ==> f(?n) == f(?m)*) |
|
336 (*FIXME: proper test: lhs does not match a subterm of a premise |
|
337 and does not match a subterm of the rhs if null prems *) |
|
338 |
|
339 fun rewrite_rule_extra_vars prems elhs erhs = |
|
340 if not ((term_vars erhs) subset |
|
341 (union_term (term_vars elhs, List.concat(map term_vars prems)))) |
|
342 then Some("extra Var(s) on rhs") else |
|
343 if not ((term_tvars erhs) subset |
|
344 (term_tvars elhs union List.concat(map term_tvars prems))) |
|
345 then Some("extra TVar(s) on rhs") |
|
346 else None; |
|
347 |
|
348 fun rewrite_rule_ok sign prems lhs rhs = |
|
349 let |
|
350 val elhs = Pattern.eta_contract lhs; |
|
351 val erhs = Pattern.eta_contract rhs; |
|
352 val perm = var_perm (elhs, erhs) andalso not (elhs aconv erhs) |
|
353 andalso not (is_Var elhs) |
|
354 in (case rewrite_rule_extra_vars prems elhs erhs of |
|
355 None => if not perm andalso looptest sign prems elhs erhs |
|
356 then Some("loops") |
|
357 else None |
|
358 | some => some |
|
359 ,perm) |
|
360 end; |
|
361 |
|
362 end; |
304 end; |