1595 (union_term (term_vars elhs, List.concat(map term_vars prems)))) |
1595 (union_term (term_vars elhs, List.concat(map term_vars prems)))) |
1596 orelse |
1596 orelse |
1597 not ((term_tvars erhs) subset |
1597 not ((term_tvars erhs) subset |
1598 (term_tvars elhs union List.concat(map term_tvars prems))); |
1598 (term_tvars elhs union List.concat(map term_tvars prems))); |
1599 |
1599 |
1600 (*simple test for looping rewrite*) |
1600 (*Simple test for looping rewrite rules and stupid orientations*) |
1601 fun looptest sign prems lhs rhs = |
1601 fun reorient sign prems lhs rhs = |
1602 rewrite_rule_extra_vars prems lhs rhs |
1602 rewrite_rule_extra_vars prems lhs rhs |
1603 orelse |
1603 orelse |
1604 is_Var (head_of lhs) |
1604 is_Var (head_of lhs) |
1605 orelse |
1605 orelse |
1606 (exists (apl (lhs, Logic.occs)) (rhs :: prems)) |
1606 (exists (apl (lhs, Logic.occs)) (rhs :: prems)) |
1607 orelse |
1607 orelse |
1608 (null prems andalso |
1608 (null prems andalso |
1609 Pattern.matches (#tsig (Sign.rep_sg sign)) (lhs, rhs)) |
1609 Pattern.matches (#tsig (Sign.rep_sg sign)) (lhs, rhs)) |
1610 (*the condition "null prems" in the last cases is necessary because |
1610 (*the condition "null prems" is necessary because conditional rewrites |
1611 conditional rewrites with extra variables in the conditions may terminate |
1611 with extra variables in the conditions may terminate although |
1612 although the rhs is an instance of the lhs. Example: |
1612 the rhs is an instance of the lhs. Example: ?m < ?n ==> f(?n) == f(?m)*) |
1613 ?m < ?n ==> f(?n) == f(?m)*) |
1613 orelse |
|
1614 (is_Const lhs andalso not(is_Const rhs)) |
1614 |
1615 |
1615 fun decomp_simp(thm as Thm {sign_ref, prop, ...}) = |
1616 fun decomp_simp(thm as Thm {sign_ref, prop, ...}) = |
1616 let val sign = Sign.deref sign_ref; |
1617 let val sign = Sign.deref sign_ref; |
1617 val prems = Logic.strip_imp_prems prop; |
1618 val prems = Logic.strip_imp_prems prop; |
1618 val concl = Logic.strip_imp_concl prop; |
1619 val concl = Logic.strip_imp_concl prop; |
1651 end; |
1652 end; |
1652 |
1653 |
1653 fun orient_rrule mss thm = |
1654 fun orient_rrule mss thm = |
1654 let val (sign,prems,lhs,rhs,perm) = decomp_simp thm |
1655 let val (sign,prems,lhs,rhs,perm) = decomp_simp thm |
1655 in if perm then [{thm=thm,lhs=lhs,perm=true}] |
1656 in if perm then [{thm=thm,lhs=lhs,perm=true}] |
1656 else if looptest sign prems lhs rhs |
1657 else if reorient sign prems lhs rhs |
1657 then if looptest sign prems rhs lhs |
1658 then if reorient sign prems rhs lhs |
1658 then mk_eq_True mss thm |
1659 then mk_eq_True mss thm |
1659 else let val Mss{mk_rews={mk_sym,...},...} = mss |
1660 else let val Mss{mk_rews={mk_sym,...},...} = mss |
1660 in case mk_sym thm of |
1661 in case mk_sym thm of |
1661 None => [] |
1662 None => [] |
1662 | Some thm' => rrule_eq_True(thm',rhs,lhs,mss,thm) |
1663 | Some thm' => rrule_eq_True(thm',rhs,lhs,mss,thm) |
2050 val rrules1 = extract_safe_rrules(mss,thm) |
2051 val rrules1 = extract_safe_rrules(mss,thm) |
2051 val lhss1 = if mutsimp then mapfilter uncond rrules1 else [] |
2052 val lhss1 = if mutsimp then mapfilter uncond rrules1 else [] |
2052 val mss1 = foldl insert_rrule (add_prems(mss,[thm]),rrules1) |
2053 val mss1 = foldl insert_rrule (add_prems(mss,[thm]),rrules1) |
2053 in (rrules1, lhss1, mss1) end |
2054 in (rrules1, lhss1, mss1) end |
2054 |
2055 |
2055 fun rebuild(conc2,(shyps2,hyps2,ders2)) = |
2056 fun disch1(conc2,(shyps2,hyps2,ders2)) = |
2056 let val hyps2' = if gen_mem (op aconv) (prem1, hyps1) |
2057 let val hyps2' = if gen_mem (op aconv) (prem1, hyps1) |
2057 then hyps2 else hyps2\prem1 |
2058 then hyps2 else hyps2\prem1 |
2058 val trec = (Logic.mk_implies(prem1,conc2), |
2059 in (Logic.mk_implies(prem1,conc2),(shyps2,hyps2',ders2)) end |
2059 (shyps2,hyps2',ders2)) |
2060 |
|
2061 fun rebuild trec2 = |
|
2062 let val trec = disch1 trec2 |
2060 in case rewritec (prover,sign_ref,maxidx) mss trec of |
2063 in case rewritec (prover,sign_ref,maxidx) mss trec of |
2061 None => (None,trec) |
2064 None => (None,trec) |
2062 | Some(Const("==>",_)$prem$conc,etc) => |
2065 | Some(Const("==>",_)$prem$conc,etc) => |
2063 impc(prems,prem,conc,mss,etc) |
2066 impc(prems,prem,conc,mss,etc) |
2064 | Some(trec') => (None,trec') |
2067 | Some(trec') => (None,trec') |
2066 |
2069 |
2067 fun simpconc() = |
2070 fun simpconc() = |
2068 case conc of |
2071 case conc of |
2069 Const("==>",_)$s$t => |
2072 Const("==>",_)$s$t => |
2070 (case impc(prems@[prem1],s,t,mss1,etc1) of |
2073 (case impc(prems@[prem1],s,t,mss1,etc1) of |
2071 (Some(i,prem),(conc2,etc2)) => |
2074 (Some(i,prem),trec2) => |
2072 let val impl = Logic.mk_implies(prem1,conc2) |
2075 let val trec2' = disch1 trec2 |
2073 in if i=0 then impc1(prems,prem,impl,mss,etc2) |
2076 in if i=0 then impc1(prems,prem,fst trec2',mss,snd trec2') |
2074 else (Some(i-1,prem),(impl,etc2)) |
2077 else (Some(i-1,prem),trec2') |
2075 end |
2078 end |
2076 | (None,trec) => rebuild(trec)) |
2079 | (None,trec) => rebuild(trec)) |
2077 | _ => rebuild(try_botc mss1 (conc,etc1)) |
2080 | _ => rebuild(try_botc mss1 (conc,etc1)) |
2078 |
2081 |
2079 in if mutsimp |
2082 in if mutsimp |