2
$\begingroup$

I have polynomials in several variables x[i] and y[j], and I am using First@SymmetricReduce@ twice (first with respect to the x's, then the y's), so that each term of the final result takes the form

symmetric poly in the x[i] * symmetric poly in the y[j].

Now I need to convert the "x" part and "y" part into Schur polynomials separately. I've written the function to do that manually one term at a time, but now how can I map that function at the "x" part of every term simultaneously? (Likewise for the "y" part then.)

Edit: Specifically, given a polynomial in which each term consists of an unspecified number of x[i] factors followed by an unspecified number of y[j] factors, how can I map one function to the "x" part of every term, and then map another function to the "y" part of every term?

The functions I'll be mapping are the following:

    XtoSchur[expr_] := toSchur@(Expand[expr] /. x -> $x);  
    YtoSchur[expr_] := toSchur@(Expand[expr] /. y -> $x);

(The toSchur function is from Coquereaux's SymPol$Package.) But a typical input I begin with looks like this (there are only 6 main terms here):

1 + (x[1]^2 x[2] + x[1] x[2]^2 + x[1]^2 x[3] + x[1] x[2] x[3] + 
       x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2) y[1] y[2] y[3] + 
x[1]^2 x[2]^2 x[3]^2 y[1]^2 y[2]^2 y[3]^2 + 
(-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2) y[1] y[2] y[
   3] (y[1] + y[2] + y[3]) + 
(-x[1] x[2] - x[1] x[3] - x[2] x[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]) + 
x[1] x[2] x[3] (y[1] + y[2] + y[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3])

So every term has an "x" part followed by a "y" part, but I can't figure out how to make a function map at each of the "x" parts at once (and then another function map at all the "y" parts).

Improve this question
$\endgroup$
5
  • 2
    $\begingroup$ An example of some input and the problematic output of your code would be helpful. $\endgroup$
    – Carl Woll
    Commented Feb 25, 2021 at 21:27
  • 1
    $\begingroup$ But what would you do with the parentheses, even if you could get them in the output? Do you need them visually, or do you have further code that would use them, and how? $\endgroup$
    – MarcoB
    Commented Feb 25, 2021 at 23:21
  • $\begingroup$ @MarcoB I mistakenly thought that including the parentheses would cause each term to have exactly two "parts" or "positions," at which I could then map my two functions over the entire polynomial; now I see that's not the case, and have edited above as necessary. The question was, how to map a function at the "x" part of each term, and then map another function at the "y" part of each term? Example is above. $\endgroup$
    – WQE
    Commented Feb 26, 2021 at 1:55
  • 1
    $\begingroup$ I don't know I understand correctly but does this work? ps = Position[eq, _x]; ps2 = Position[eq, _x^_]; MapAt[Test@# &, eq, Join[Complement[ps, Append[#, 1] & /@ ps2], ps2]] For x[1]^2 x[2] + x[1] x[2]^2 output is Test[x[1]^2] Test[x[2]] + Test[x[1]] Test[x[2]^2] $\endgroup$
    – Ben Izd
    Commented Feb 26, 2021 at 7:54
  • $\begingroup$ @Beny Izd This is close -- I think you are right that Position will be the key. I can tell my description was not entirely clear; here is a better example. I am often starting with something like (x[1]^4 x[2] + x[1]^3 x[2]^2 + x[1]^2 x[2]^3 + x[1] x[2]^4) y[1] y[2] y[3] y[4] y[5]. Given two functions TestX and TestY, I need to be able to obtain the output TestX[x[1]^4 x[2] + x[1]^3 x[2]^2 + x[1]^2 x[2]^3 + x[1] x[2]^4] * TestY[y[1] y[2] y[3] y[4] y[5]]. I'm working on modifying your idea to get this result ... $\endgroup$
    – WQE
    Commented Feb 26, 2021 at 15:52

2 Answers 2

Reset to default
1
$\begingroup$

This solution was inspired by this post answered by corey979.

Mathematica has a function called FromCoefficientRules, example:

eq1 = 1 + x[1] + x[2]*y[1] + y[2];
CoefficientRules[eq1]

(*Out: {{1, 0, 0, 0} -> 1, {0, 1, 1, 0} -> 1,
        {0, 0, 0, 1} -> 1, {0, 0, 0, 0} -> 1} *)

The order of numbers in the keys are based on Variables output:

Variables[e1]

(*Out: {x[1], x[2], y[1], y[2]} *)

Since you don't want $y$ parts, replace positions of 3 and 4 in the keys to 0:

CoefficientRules[eq1] /. List[x__Integer] :> ReplacePart[List@x, y_ /; y > 2 -> 0]

(*Out: {{1, 0, 0, 0} -> 1, {0, 1, 0, 0} -> 1, 
        {0, 0, 0, 0} -> 1, {0, 0, 0, 0} -> 1} *)

Now we have two {0, 0, 0, 0} keys in CoefficientRules which will be translated to plain numbers like 1. For removing them use DeleteCases:

DeleteCases[
 CoefficientRules[eq1] /. List[x__Integer] :> ReplacePart[List@x, y_ /; y > 2 -> 0], 
 List[x__Integer] /; Total@List@x == 0 -> _]

(*Out: {{1, 0, 0, 0} -> 1, {0, 1, 0, 0} -> 1} *)

Use FromCoefficientRules to translate back to normal:

FromCoefficientRules[
 DeleteCases[
  CoefficientRules[eq1] /. List[x__Integer] :> ReplacePart[List@x, y_ /; y > 2 -> 0], 
  List[x__Integer] /; Total@List@x == 0 -> _], Variables[eq1]]

FromCoefficientRules needs variable names, use Variables[eq1] as the second argument.

The above workflow can easily apply to your equation (instead of 4 variables, we have 6, make 4,5,6 zero):

eq2 = 1 + (x[1]^2 x[2] + x[1] x[2]^2 + x[1]^2 x[3] + x[1] x[2] x[3] + 
       x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2) y[1] y[2] y[3] + 
x[1]^2 x[2]^2 x[3]^2 y[1]^2 y[2]^2 y[3]^2 + 
(-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2) y[1] y[2] y[
   3] (y[1] + y[2] + y[3]) + 
(-x[1] x[2] - x[1] x[3] - x[2] x[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]) + 
x[1] x[2] x[3] (y[1] + y[2] + y[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]);

xresult = FromCoefficientRules[
 DeleteCases[
  CoefficientRules[eq2] /. 
   List[x__Integer] :> ReplacePart[List@x, y_ /; y > 3 -> 0], 
  List[x__Integer] /; Total@List@x == 0 -> _], Variables[eq2]]

(* for extracting y parts, make 1,2,3 zero*)
yresult = FromCoefficientRules[
 DeleteCases[
  CoefficientRules[eq2] /. 
   List[x__Integer] :> ReplacePart[List@x, y_ /; y <= 3 -> 0], 
  List[x__Integer] /; Total@List@x == 0 -> _], Variables[eq2]]

Outputs:

-3 x[1] x[2] + x[1]^2 x[2] + x[1] x[2]^2 - 3 x[1] x[3] + 
 x[1]^2 x[3] - 3 x[2] x[3] + 10 x[1] x[2] x[3] - 3 x[1]^2 x[2] x[3] + 
 x[2]^2 x[3] - 3 x[1] x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2 - 
 3 x[1] x[2] x[3]^2 + x[1]^2 x[2]^2 x[3]^2


-3 y[1] y[2] + y[1]^2 y[2] + y[1] y[2]^2 - 3 y[1] y[3] + 
 y[1]^2 y[3] - 3 y[2] y[3] + 10 y[1] y[2] y[3] - 3 y[1]^2 y[2] y[3] + 
 y[2]^2 y[3] - 3 y[1] y[2]^2 y[3] + y[1] y[3]^2 + y[2] y[3]^2 - 
 3 y[1] y[2] y[3]^2 + y[1]^2 y[2]^2 y[3]^2

Now apply your function:

XtoSchur @ xresult

YtoSchur @ yresult
Improve this answer
$\endgroup$
1
  • $\begingroup$ This works very well; many thanks. I just had to modify the code slightly because (a) I need to do the separation term-by-term (rather than for the entire polynomial), and (b) the issue of duplicates becomes more delicate depending on how many subterms there are in the opposite variable; e.g., a polynomial in the $x_i$ multiplied by $(y_1+y_2+y_3)$ creates three copies of each desired term in your xresult. But by first sorting the coefficient list and then using DeleteDuplicatesBywith respect to First, everything seems to work out. $\endgroup$
    – WQE
    Commented Feb 27, 2021 at 21:37
1
$\begingroup$

Why not use 3-arg Collect? For example:

expr = 1 + (x[1]^2 x[2] + x[1] x[2]^2 + x[1]^2 x[3] + x[1] x[2] x[3] + 
   x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2) y[1] y[2] y[3] + 
x[1]^2 x[2]^2 x[3]^2 y[1]^2 y[2]^2 y[3]^2 + 
(-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2) y[1] y[2] y[
   3] (y[1] + y[2] + y[3]) + 
(-x[1] x[2] - x[1] x[3] - x[2] x[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]) + 
x[1] x[2] x[3] (y[1] + y[2] + y[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]);

Expand @ Collect[expr, _y, TestX] /. z_TestX w_ :> z TestY[w]

TestX[1] + TestX[-x[1] x[2] - x[1] x[3] - x[2] x[3]] TestY[y[1] y[2]] + TestX[x[1] x[2] x[3]] TestY[y[1]^2 y[2]] + TestX[x[1] x[2] x[3]] TestY[y[1] y[2]^2] + TestX[-x[1] x[2] - x[1] x[3] - x[2] x[3]] TestY[y[1] y[3]] + TestX[x[1] x[2] x[3]] TestY[y[1]^2 y[3]] + TestX[-x[1] x[2] - x[1] x[3] - x[2] x[3]] TestY[y[2] y[3]] + TestX[x[1]^2 x[2] + x[1] x[2]^2 + x[1]^2 x[3] + 4 x[1] x[2] x[3] + x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2] TestY[y[1] y[2] y[3]] + TestX[-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2] TestY[ y[1]^2 y[2] y[3]] + TestX[x[1] x[2] x[3]] TestY[y[2]^2 y[3]] + TestX[-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2] TestY[ y[1] y[2]^2 y[3]] + TestX[x[1] x[2] x[3]] TestY[y[1] y[3]^2] + TestX[x[1] x[2] x[3]] TestY[y[2] y[3]^2] + TestX[-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2] TestY[ y[1] y[2] y[3]^2] + TestX[x[1]^2 x[2]^2 x[3]^2] TestY[y[1]^2 y[2]^2 y[3]^2]

Improve this answer
$\endgroup$
1
  • $\begingroup$ This seems pretty close, and it's certainly far more elegant; I don't think it's quite what I need, since I need to apply TestX to the entire "x" factor in each monomial while applying TestY to the entire "y" factor in each monomial (and then multiply each resulting pair). So, for example, there shouldn't be any occurrences of TestY[y[1] y[2]] since there were no monomials whose only "y" factor was y[1] y[2]. But this idea looks quite promising; I will have to think about modifying it slightly! $\endgroup$
    – WQE
    Commented Mar 7, 2021 at 3:14

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.