Minimal Polynomials of Linear Torus Actions on (C^n)

Set as many weights as you want. Note: The more weights, the longer the calculations take.

w={{1,2,3}};
Y=Table[(Subscript[y, i]),{i,1,2*Length[w[[1]]]}];(*Exponent matrix*)
B=Table[Dot[w[[i]],Drop[Y,-Length[Y]/2]],{i,1,Length[w]}]-Table[Dot[w[[i]],Drop[Y,Length[Y]/2]],{i,1,Length[w]}];(*Takes the exponent matrix, and turns the exponents for the conjugates negative.*)
f[ϵ_,w__]:=Solve[B==Table[0,{i,1,Length[w]}]&&Sum[Y[[i]],{i,1,Length[Y]}]==ϵ&& Resolve[Flatten[Y,1]≥ 0,Flatten[Y,1],Integers],Flatten[Y,1],Integers];(*This solves for all the distinct invariant polynomials of degree ϵ*)
t[β_,w]:=Table[Table[(Subscript[y, j])/.f[β,w][[i]][[j]],{j,1,Length[Y]}],{i,1,Length[f[β,w]]}](*This will take the solutions from f without the "(Subscript[y, i])"*)

Run the above first!

This solves for minimal polynomials. It starts with just the degree 2 functions which will always be minimal and searches the degree 3 polynomials. It then adds the new minimal polynomials that it finds to its list, then searches the next degree skipping degrees with no polynomials (this occurs when all the weights are odd). It stops searching when there are no minimal polynomials in a degree. We conjecture that you will be done once you hit the degree equal to the sum of all the weights.

l=Transpose[Flatten[Table[t[j,w],{j,2,2}],1]]; (*List of minimal polynomials*)
X=Table[(Subscript[x, i]),{i,1,Length[l[[1]]]}]; (*Keeps track of the number of minimal, used when solving for more minimal polynomials in the function J*)
J[n_]:=Parallelize[Table[Solve[Resolve[Dot[l,X]==t[n,w][[i]]]&&Resolve[X≥0],X,Integers],{i,1,Length[t[n,w]]}]];(*Attemps to solve polynomials of degree k based off of current known minimal polynomials*)
k = 3;(*Starting degree*)
MUP=J[k];(*Saves calculation for efficiency*)
o=1; (*Position in kth degree polynomials*)
P={};(*List of positions of minimal polynomials*)
M=Transpose[l];
(*Do not modify the above*)
start = SessionTime[];
While[k≤Sum[Sum[w[[i]][[j]],{j,1,Length[w[[1]]]}],{i,1,Length[w]}],(*This caps the calculation to the sum of all the weights*)
If[o==0,
o=1;(*Makes sure to not count 0th position of degree k polynomials*)
];
If[Length[f[k,w]]==0,(*Skips degrees with no solutions*)
k++;
MUP=J[k];(*Saves calculation for efficiency, required after each time we go up a degree*)
Print["Skipping degree ",k-1]
o=0;
If[Length[P]≠ 0,
M=Join[M,Table[t[P[[j]][[1]],w][[P[[j]][[2]]]],{j,1,Length[P]}]];(*Adds any new minimal polynomials to the list*)
L=Transpose[M];
X=Table[(Subscript[x, i]),{i,1,Length[L[[1]]]}];(*Updated list with the new minimal polynomials*)
J[n_]:=Parallelize[Table[Solve[Resolve[Dot[L,X]==t[n,w][[i]]]&&Resolve[X≥0],X,Integers],{i,1,Length[t[n,w]]}]];
P={};(*Resets P in order to not add polynomials multiple times*)
Print["Updated minimal polynomials"]
];(*Updates minimal polynomials and resets P. We do this every time we increase a degree in case there are polynomials in the next degree based off of a minimal polynomial which we have found the position of, but not added to the list.*)
];
While[Length[MUP[[o]]]==0&&o≠ 0,(*Checks for minimal polynomials. Length[MUP[[o]]] checks for the number of solutions for the (o^th) Polynomial of degree k. If there are no solutions, then that polynomial is minimal.*)
P=Join[P,{{k,o}}];(*Adds the position of minimal polynomials to the list P, this is done to avoid an error where all of our values in M would get multiplied by Null.*)
If[o==1,
Print["Added the ",o,"st polynomial of degree ",k]
];
If[o==2,
Print["Added the ",o,"nd polynomial of degree ",k]
];
If[o==3,
Print["Added the ",o,"rd polynomial of degree ",k]
];
If[o≠1&&o≠2&&o≠3,
Print["Added the ",o,"th polynomial of degree ",k]
];(*Error checking. Multiple instances for propper grammar*)
If[o==Length[f[k,w]],(*This loop checks to see if we are at the last polynomial of degree k. If we are, it resets position and goes to the next degree*)
o=0;(*This sets o to zero because we must have an o++ at the end of our loop if there isn't a minimal polynomial in a certain position and we have not yet checked all polynomials of degree k*)
Print["Reset the 'o' going to degree ",k+1]
k++;
MUP=J[k];(*Saves calculation for efficiency*)
If[Length[P]≠ 0,
M=Join[M,Table[t[P[[j]][[1]],w][[P[[j]][[2]]]],{j,1,Length[P]}]];
L=Transpose[M];
X=Table[(Subscript[x, i]),{i,1,Length[L[[1]]]}];(*New list with only minimal polynomials*)
J[n_]:=Parallelize[Table[Solve[Resolve[Dot[L,X]==t[n,w][[i]]]&&Resolve[X≥0],X,Integers],{i,1,Length[t[n,w]]}]];
P={};
Print["Updated minimal polynomials"]
];
];(*Goes up to the next degree and resets position in the list of polynomials*)

If[o≠ Length[f[k,w]],(*If current case is minimal, this will move the program to the next position and then the program will check to see if that new position is a minimal polynomial.*)
o++;
];
];
If[o==Length[f[k,w]],
o=0;
Print["Reset the 'o' going to degree ",k+1,o+1]
k++;
MUP=J[k];(*Saves calculation for efficiency*)
If[Length[P]≠ 0,
M=Join[M,Table[t[P[[j]][[1]],w][[P[[j]][[2]]]],{j,1,Length[P]}]];
L=Transpose[M];
X=Table[(Subscript[x, i]),{i,1,Length[L[[1]]]}];(*New list with only minimal polynomials*)
J[n_]:=Parallelize[Table[Solve[Resolve[Dot[L,X]==t[n,w][[i]]]&&Resolve[X≥0],X,Integers],{i,1,Length[t[n,w]]}]];
P={};
Print["Updated minimal polynomials"]
];
];
o++; (*If no minimal polynomial at position o and not at the last polynomial, this will make the program go to the next polynomial in line.*)
];
fin = SessionTime[];
Print[fin-start]
M=Join[M,Table[t[P[[j]][[1]],w][[P[[j]][[2]]]],{j,1,Length[P]}]];
L=Transpose[M];
X=Table[(Subscript[x, i]),{i,1,Length[L[[1]]]}];(*New list with only minimal polynomials*)
J[n_]:=Parallelize[Table[Solve[Resolve[Dot[L,X]==t[n,w][[i]]]&&Resolve[X≥0],X,Integers],{i,1,Length[t[n,w]]}]];
Print[M]

This will check for minimal polynomials. Any 0 will denote a minimal polynomial. You will need to add this to previous lists manually.

POP = J[8];(*Adust the value in J to check whether degrees past the soft cap has minimal polynomials*)
Sum[Table[Length[POP[[i]]],{i,1,Length[POP]}][[j]],{j,1,Length[POP]}]-Length[POP]
Table[Length[POP[[i]]],{i,1,Length[POP]}]
G = {};
k=1;
While[k≤Length[POP],
If[POP[[k]]≠1,
G = Join[G,{POP[[k]]}];
];
k++;
];
Print[G](*Zeros will denote minimal polynomials that have not been added to the list, entries higher than one will denote that there are possible relationships*)