112 |
112 |
113 (** datatype simpset **) |
113 (** datatype simpset **) |
114 |
114 |
115 (* rewrite rules *) |
115 (* rewrite rules *) |
116 |
116 |
117 type rrule = {thm: thm, name: string, lhs: term, elhs: cterm, fo: bool, perm: bool}; |
117 type rrule = |
118 |
118 {thm: thm, (*the rewrite rule*) |
119 (*thm: the rewrite rule; |
119 name: string, (*name of theorem from which rewrite rule was extracted*) |
120 name: name of theorem from which rewrite rule was extracted; |
120 lhs: term, (*the left-hand side*) |
121 lhs: the left-hand side; |
121 elhs: cterm, (*the etac-contracted lhs*) |
122 elhs: the etac-contracted lhs; |
122 extra: bool, (*extra variables outside of elhs*) |
123 fo: use first-order matching; |
123 fo: bool, (*use first-order matching*) |
124 perm: the rewrite rule is permutative; |
124 perm: bool}; (*the rewrite rule is permutative*) |
125 |
125 |
|
126 (* |
126 Remarks: |
127 Remarks: |
127 - elhs is used for matching, |
128 - elhs is used for matching, |
128 lhs only for preservation of bound variable names; |
129 lhs only for preservation of bound variable names; |
129 - fo is set iff |
130 - fo is set iff |
130 either elhs is first-order (no Var is applied), |
131 either elhs is first-order (no Var is applied), |
131 in which case fo-matching is complete, |
132 in which case fo-matching is complete, |
132 or elhs is not a pattern, |
133 or elhs is not a pattern, |
133 in which case there is nothing better to do;*) |
134 in which case there is nothing better to do; |
|
135 *) |
134 |
136 |
135 fun eq_rrule ({thm = thm1, ...}: rrule, {thm = thm2, ...}: rrule) = |
137 fun eq_rrule ({thm = thm1, ...}: rrule, {thm = thm2, ...}: rrule) = |
136 Drule.eq_thm_prop (thm1, thm2); |
138 Drule.eq_thm_prop (thm1, thm2); |
137 |
139 |
138 |
140 |
372 theory_context thy ss); |
374 theory_context thy ss); |
373 |
375 |
374 |
376 |
375 (* maintain simp rules *) |
377 (* maintain simp rules *) |
376 |
378 |
|
379 (* FIXME: it seems that the conditions on extra variables are too liberal if |
|
380 prems are nonempty: does solving the prems really guarantee instantiation of |
|
381 all its Vars? Better: a dynamic check each time a rule is applied. |
|
382 *) |
|
383 fun rewrite_rule_extra_vars prems elhs erhs = |
|
384 let |
|
385 val elhss = elhs :: prems; |
|
386 val tvars = fold Term.add_tvars elhss []; |
|
387 val vars = fold Term.add_vars elhss []; |
|
388 in |
|
389 erhs |> Term.exists_type (Term.exists_subtype |
|
390 (fn TVar v => not (member (op =) tvars v) | _ => false)) orelse |
|
391 erhs |> Term.exists_subterm |
|
392 (fn Var v => not (member (op =) vars v) | _ => false) |
|
393 end; |
|
394 |
|
395 fun rrule_extra_vars elhs thm = |
|
396 rewrite_rule_extra_vars [] (term_of elhs) (Thm.full_prop_of thm); |
|
397 |
377 fun mk_rrule2 {thm, name, lhs, elhs, perm} = |
398 fun mk_rrule2 {thm, name, lhs, elhs, perm} = |
378 let |
399 let |
379 val fo = Pattern.first_order (term_of elhs) orelse not (Pattern.pattern (term_of elhs)) |
400 val t = term_of elhs; |
380 in {thm = thm, name = name, lhs = lhs, elhs = elhs, fo = fo, perm = perm} end; |
401 val fo = Pattern.first_order t orelse not (Pattern.pattern t); |
|
402 val extra = rrule_extra_vars elhs thm; |
|
403 in {thm = thm, name = name, lhs = lhs, elhs = elhs, extra = extra, fo = fo, perm = perm} end; |
381 |
404 |
382 fun del_rrule (rrule as {thm, elhs, ...}) ss = |
405 fun del_rrule (rrule as {thm, elhs, ...}) ss = |
383 ss |> map_simpset1 (fn (rules, prems, bounds, context) => |
406 ss |> map_simpset1 (fn (rules, prems, bounds, context) => |
384 (Net.delete_term eq_rrule (term_of elhs, rrule) rules, prems, bounds, context)) |
407 (Net.delete_term eq_rrule (term_of elhs, rrule) rules, prems, bounds, context)) |
385 handle Net.DELETE => (cond_warn_thm "Rewrite rule not in simpset:" ss thm; ss); |
408 handle Net.DELETE => (cond_warn_thm "Rewrite rule not in simpset:" ss thm; ss); |
386 |
409 |
387 fun insert_rrule (rrule as {thm, name, lhs, elhs, perm}) ss = |
410 fun insert_rrule (rrule as {thm, name, elhs, ...}) ss = |
388 (trace_named_thm "Adding rewrite rule" ss (thm, name); |
411 (trace_named_thm "Adding rewrite rule" ss (thm, name); |
389 ss |> map_simpset1 (fn (rules, prems, bounds, context) => |
412 ss |> map_simpset1 (fn (rules, prems, bounds, context) => |
390 let |
413 let |
391 val rrule2 as {elhs, ...} = mk_rrule2 rrule; |
414 val rrule2 as {elhs, ...} = mk_rrule2 rrule; |
392 val rules' = Net.insert_term eq_rrule (term_of elhs, rrule2) rules; |
415 val rules' = Net.insert_term eq_rrule (term_of elhs, rrule2) rules; |
398 | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2) |
421 | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2) |
399 | vperm (t, u) = (t = u); |
422 | vperm (t, u) = (t = u); |
400 |
423 |
401 fun var_perm (t, u) = |
424 fun var_perm (t, u) = |
402 vperm (t, u) andalso gen_eq_set (op =) (Term.add_vars t [], Term.add_vars u []); |
425 vperm (t, u) andalso gen_eq_set (op =) (Term.add_vars t [], Term.add_vars u []); |
403 |
|
404 (* FIXME: it seems that the conditions on extra variables are too liberal if |
|
405 prems are nonempty: does solving the prems really guarantee instantiation of |
|
406 all its Vars? Better: a dynamic check each time a rule is applied. |
|
407 *) |
|
408 fun rewrite_rule_extra_vars prems elhs erhs = |
|
409 not (Term.add_vars erhs [] subset fold Term.add_vars (elhs :: prems) []) |
|
410 orelse |
|
411 not (Term.add_tvars erhs [] subset (fold Term.add_tvars (elhs :: prems) [])); |
|
412 |
426 |
413 (*simple test for looping rewrite rules and stupid orientations*) |
427 (*simple test for looping rewrite rules and stupid orientations*) |
414 fun default_reorient thy prems lhs rhs = |
428 fun default_reorient thy prems lhs rhs = |
415 rewrite_rule_extra_vars prems lhs rhs |
429 rewrite_rule_extra_vars prems lhs rhs |
416 orelse |
430 orelse |
455 |
469 |
456 fun mk_eq_True (Simpset (_, {mk_rews = {mk_eq_True, ...}, ...})) (thm, name) = |
470 fun mk_eq_True (Simpset (_, {mk_rews = {mk_eq_True, ...}, ...})) (thm, name) = |
457 (case mk_eq_True thm of |
471 (case mk_eq_True thm of |
458 NONE => [] |
472 NONE => [] |
459 | SOME eq_True => |
473 | SOME eq_True => |
460 let val (_, _, lhs, elhs, _, _) = decomp_simp eq_True |
474 let |
|
475 val (_, _, lhs, elhs, _, _) = decomp_simp eq_True; |
|
476 val extra = rrule_extra_vars elhs eq_True; |
461 in [{thm = eq_True, name = name, lhs = lhs, elhs = elhs, perm = false}] end); |
477 in [{thm = eq_True, name = name, lhs = lhs, elhs = elhs, perm = false}] end); |
462 |
478 |
463 (*create the rewrite rule and possibly also the eq_True variant, |
479 (*create the rewrite rule and possibly also the eq_True variant, |
464 in case there are extra vars on the rhs*) |
480 in case there are extra vars on the rhs*) |
465 fun rrule_eq_True (thm, name, lhs, elhs, rhs, ss, thm2) = |
481 fun rrule_eq_True (thm, name, lhs, elhs, rhs, ss, thm2) = |
466 let val rrule = {thm = thm, name = name, lhs = lhs, elhs = elhs, perm = false} in |
482 let val rrule = {thm = thm, name = name, lhs = lhs, elhs = elhs, perm = false} in |
467 if Term.add_vars rhs [] subset Term.add_vars lhs [] andalso |
483 if rewrite_rule_extra_vars [] lhs rhs then |
468 Term.add_tvars rhs [] subset Term.add_tvars lhs [] then [rrule] |
484 mk_eq_True ss (thm2, name) @ [rrule] |
469 else mk_eq_True ss (thm2, name) @ [rrule] |
485 else [rrule] |
470 end; |
486 end; |
471 |
487 |
472 fun mk_rrule ss (thm, name) = |
488 fun mk_rrule ss (thm, name) = |
473 let val (_, prems, lhs, elhs, rhs, perm) = decomp_simp thm in |
489 let val (_, prems, lhs, elhs, rhs, perm) = decomp_simp thm in |
474 if perm then [{thm = thm, name = name, lhs = lhs, elhs = elhs, perm = true}] |
490 if perm then [{thm = thm, name = name, lhs = lhs, elhs = elhs, perm = true}] |
830 let |
846 let |
831 val Simpset ({rules, ...}, {congs, procs, termless, ...}) = ss; |
847 val Simpset ({rules, ...}, {congs, procs, termless, ...}) = ss; |
832 val eta_thm = Thm.eta_conversion t; |
848 val eta_thm = Thm.eta_conversion t; |
833 val eta_t' = rhs_of eta_thm; |
849 val eta_t' = rhs_of eta_thm; |
834 val eta_t = term_of eta_t'; |
850 val eta_t = term_of eta_t'; |
835 fun rew {thm, name, lhs, elhs, fo, perm} = |
851 fun rew {thm, name, lhs, elhs, extra, fo, perm} = |
836 let |
852 let |
837 val {thy, prop, maxidx, ...} = rep_thm thm; |
853 val {thy, prop, maxidx, ...} = rep_thm thm; |
838 val (rthm, elhs') = if maxt = ~1 then (thm, elhs) |
854 val (rthm, elhs') = |
|
855 if maxt = ~1 orelse not extra then (thm, elhs) |
839 else (Thm.incr_indexes (maxt+1) thm, Thm.cterm_incr_indexes (maxt+1) elhs); |
856 else (Thm.incr_indexes (maxt+1) thm, Thm.cterm_incr_indexes (maxt+1) elhs); |
840 val insts = if fo then Thm.cterm_first_order_match (elhs', eta_t') |
857 val insts = if fo then Thm.cterm_first_order_match (elhs', eta_t') |
841 else Thm.cterm_match (elhs', eta_t'); |
858 else Thm.cterm_match (elhs', eta_t'); |
842 val thm' = Thm.instantiate insts (Thm.rename_boundvars lhs eta_t rthm); |
859 val thm' = Thm.instantiate insts (Thm.rename_boundvars lhs eta_t rthm); |
843 val prop' = Thm.prop_of thm'; |
860 val prop' = Thm.prop_of thm'; |