Making multi-linear polynomial change of variables (simplifications) by updating `replacementFunction`

Question

This is an evolution of one of my previous questions; I've got a partial answer to that question and now have a much cleaner question to ask:

Question: What changes to replacementFunction (defined below) are required for it work on determinant-like expressions?

The replacementFunction has shown up multiple times. There's a barebones version of it here. At the bottom of this question, I include a version of it with an optional fourth argument that when set to ON prints what the function is doing (to aid any noble souls who attempt to assist).

replacementFunction uses PolynomialReduce to rewrite sub-expressions in a user-defined way. I am trying to use it on determinant-like expressions, but the iterative structure of replacementFunction appears to miss something on expressions with Head[expr]===Plus.

An example where replacementFunction works:

exprA = (a[1, 1] a[2, 2] + a[1, 2] a[2, 1]);
replacementFunction[exprA^2, {exprA - detA}, Variables[exprA], ON]
(*detA^2*)

and an example where it doesn't work:

exprA = (a[1, 1] a[2, 2] + a[1, 2] a[2, 1]);
replacementFunction[exprA, {exprA - detA}, Variables[exprA], ON]
(* a[1, 1] a[2, 2] + a[1, 2] a[2, 1] *)

The only difference is exprA vs. exprA^2 in the first argument of replacementFunction. I think this has to do with the fact that replacementFunction performs a PolynomialReduce on expressions with hed===Power, but doesn't appear to do so for expressions with hed===Plus, but I can't figure out how to implement this consistently.

Here is the printing version or replacementFunction:

(* Definition of replacement function *)
replacementFunction // ClearAll;
replacementFunction[expr_, rep_, vars_, TS_: 0] :=
  Module[
   {num = Numerator[expr], den = Denominator[expr], hed = Head[expr], 
    base, expon, out, tsp, pr}
   ,
   tsp[x_] := If[TS === ON, Print[x];];
   pr := PolynomialReduce[expr, rep, vars];
   If[
        PolynomialQ[num, vars] && PolynomialQ[den, vars] && ! NumberQ[den]
        ,
        tsp["T1 - A rational function"];
        tsp[expr];
        out = replacementFunction[num, rep, vars, TS]/replacementFunction[den, rep, vars, TS];
        tsp["===T1 out==="];
        tsp[out // Flatten // TableForm];
        out
        ,
        tsp["F1 - Not a rational function"];
        tsp[expr];
        If[
            hed === Power && Length[expr] == 2
            ,
            tsp["T2 - A power function"];
            tsp[expr];
            base = replacementFunction[expr[[1]], rep, vars, TS];
            expon = replacementFunction[expr[[2]], rep, vars, TS];
            out = PolynomialReduce[base^expon, rep, vars];
            tsp["===T2 out==="];
            tsp[out // Flatten // TableForm];
            out[[2]]
            ,
            tsp["F2 - Not a power function"];
            tsp[expr];
            If[
                Head[hed] === Symbol && MemberQ[Attributes[Evaluate[hed]], NumericFunction]
                ,
                tsp["T3 - A numeric function"];
                tsp[expr];
                Map[replacementFunction[#, rep, vars, TS] &, expr]
                ,
                tsp["F3 - Not a numeric function"];
                tsp["***Reduce***"];
                tsp["Divide ", expr];
                tsp["by ", rep];
                out = pr(*PolynomialReduce*);
                tsp["===T3 out==="];
                tsp[out // Flatten // TableForm];
                out[[2]]
                ]
            ]
        ]
   ];

score 1 · Accepted Answer · answered Jun 19 '16 at 06:34

I figured out how to update this function to correctly work on multi-linear expressions.

All that's required is one additional call of PolynomialReduce in the third nested If statement. This mirrors the way the second If statement handles the power case. It might be that there should be a similar treatment for the division case (the first If statement), but I haven't run into problems there.

For completeness, I include an updated version of the function, without the printing option (to increase speed).

replacementFunction // ClearAll;
replacementFunction[expr_, rep_, vars_] :=
  Module[
   {num = Numerator[expr], den = Denominator[expr], hed = Head[expr], 
    base, expon, iterative}
   ,
   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[hed] === Symbol && 
                MemberQ[Attributes[Evaluate[hed]], NumericFunction]
                ,
                (* Alteration here *)
                iterative = Map[replacementFunction[#, rep, vars] &, expr];
                PolynomialReduce[iterative, rep, vars][[2]]
                ,
                PolynomialReduce[expr, rep, vars][[2]]
                ]
            ]
        ]
   ];

Your nested If statements can be written in flattened form using Which — QuantumDot, Jun 19 '16 at 07:01
Agreed! I posted with the Ifs because that's how the function has appeared on here in the past. — jjstankowicz, Jun 19 '16 at 18:30

Making multi-linear polynomial change of variables (simplifications) by updating `replacementFunction`

1 Answers1