replacementFunction[expr_, rep_, vars_] :=
Module[{num = Numerator[expr], den = Denominator[expr],
hed = Head[expr], base, expon},
If[PolynomialQ[num, vars] &&
PolynomialQ[den, vars] && ! NumberQ[den],
replacementFunction[num, rep, vars]/
replacementFunction[den, rep, vars],
If[hed === Power && Length[expr] == 2,
base = replacementFunction[expr[[1]], rep, vars];
expon = replacementFunction[expr[[2]], rep, vars];
PolynomialReduce[base^expon, rep, vars][[2]],
If[Head[Evaluate[hed]] === Symbol &&
MemberQ[Attributes[Evaluate[hed]], NumericFunction],
Map[replacementFunction[#, rep, vars] &, expr],
PolynomialReduce[expr, rep, vars][[2]]]]]] ;
expr1 = x*y-w*z; res=x*y-w*z-2*A;
Print[replacementFunction[expr1,res,{x,y,w,z}]//Simplify]; (* fails *)
Print[ReplaceAll[expr1,x*y-w*z->(2*A)]]; (* OK *)
Print[ReplaceAll[expr1,-x*y+w*z->-(2*A)]]; (* fails *)
expr2 =(x*y-w*z)^2;
Print[replacementFunction[expr2,res,{x,y,w,z}]//Simplify]; (* OK *)
Print[ReplaceAll[expr2,x*y-w*z->(2*A)]]; (* OK *)
Print[ReplaceAll[expr2,-x*y+w*z->-(2*A)]]; (* fails *)
Summary: it works for expr =(x*y-w*z)^n if n=2,3,4...
also n=-2,-3,... but fails for n=1 or n=-1. Any fix? Thanks.
Rule[Plus[Times[x,y],Times[-1,w,z]],Times[2,A]]
-x*y + w*z -> -2*A // FullForm
Rule[Plus[Times[-1,x,y],Times[w,z]],Times[-2,A]]
The LHS of these rules are different forms and will behave differently than you expect. To get easily understood behaviour, keep the LHS of replacement rules as simple as possible or use multiple rules to address the different forms.
expr = (x*y - w*z)^Range[-2, 2]
{1/(x*y - w*z)^2, 1/(x*y - w*z), 1,
x*y - w*z, (x*y - w*z)^2}
expr /. x -> (2 A + w*z)/y
{1/(4*A^2), 1/(2*A), 1, 2*A, 4*A^2}
expr /. {x*y - w*z -> (2*A), -x*y + w*z -> -2*A}
{1/(4*A^2), 1/(2*A), 1, 2*A, 4*A^2}
Bob Hanlon
---- car...@colorado.edu wrote:
=============
replacementFunction[expr_, rep_, vars_] :=
Module[{num = Numerator[expr], den = Denominator[expr],
hed = Head[expr], base, expon},
If[PolynomialQ[num, vars] &&
PolynomialQ[den, vars] && ! NumberQ[den],
replacementFunction[num, rep, vars]/
replacementFunction[den, rep, vars],
If[hed === Power && Length[expr] == 2,
base = replacementFunction[expr[[1]], rep, vars];
expon = replacementFunction[expr[[2]], rep, vars];
PolynomialReduce[base^expon, rep, vars][[2]],
If[PolynomialQ[expr, vars],
PolynomialReduce[expr, rep, vars][[2]],
If[Head[Evaluate[hed]] === Symbol &&
MemberQ[Attributes[Evaluate[hed]], NumericFunction],
Map[replacementFunction[#, rep, vars] &, expr],
PolynomialReduce[expr, rep, vars][[2]]]]]]]
replacementFunction[x*y - w*z, x*y - w*z - 2*A, {x, y, z, w}]
2 A
Andrzej Kozlowski
Thanks - this fix solved that problem. Now replacementFunction works even for
expr=(x*y-w*z)^n, with symbolic n. Hopefully this will eventually become a
built-in function that implements algebraic substitution instead of
pattern replacement.
I plan to test it in a more ambitious setting: a 12 x 12 matrix, each
entry of which has about 5000 leaves. The idea is to inject geometric
invariants through repeated replacements, finally ending up with shorter
expressions (about 100 leaves) that can be finished up with Simplify.