Computation of the Hilbert series of on-shell invariants of a potentially degenerate O(2) representation

Lawton Walker
Part of a project with coauthors:
Austin Barringer, Hans-Christian Herbig, Daniel Herden, Saad Khalid, Christopher Seaton
Contact seatonc@rhodes.edu

This notebook takes as input a vector a = {(Subscript[a, 1]), (Subscript[a, 2]), . . . , (Subscript[a, n])},  and multiplicity vector p = {(Subscript[p, 1]), (Subscript[p, 2]), . . . , (Subscript[p, n])}  indicating a unitary representation O(2) on a 2n-dimensional vector space where all (Subscript[a, i]) are positive and distinct, and outputs the Hilbert Series of the ring of real regular invariant functions on the associated symplectic quotient. Note that it does not apply to the case of a single (Subscript[a, 1]) (completely degenerate).

To use this notebook, evaluate the definition of the three functions newFactor, manipPoly, and shiftSeries.  Change the definition of the weight vector a = {1, 2} and p = {1,2} as required and evaluate the last commands.

The function newFactor takes a polynomial p = poly in the variable z as input and factors out all factors of the form (1 - z^k) for positive integer k.  The output is a list with two entries; the first entry is a list indicating how many factors occur at each degree (e.g. {0, 1, 0, 2} corresponds to (1 - z)(1 - z^3)^2) and the second entry is the remaining factor of p which is not divisible by any (1 - z^k).

newFactor[p_]:=Module[{poly=p,k, polyFact},
(* Set up a blank table to record the factors. *)
polyFact=Table[0,{i,1, Exponent[poly,z]}];
(* set k = degree of the input polynomial.  We will search for factors starting with the highest possible degree k. *)
k=Exponent[poly,z];
While[k≥1,
(* If 1-z^k divides the polynomial, divide out this factor from poly, record this in the table polyFact, and check again. If not (or if the statement depends on the value of z, i.e. Mathematica interprets it as neither true nor false), increment k down. *)
If[PolynomialRemainder[poly, 1-z^k, z]==0,
polyFact[[k]]++;
poly=PolynomialQuotient[poly,1-z^k,z],
k=k-1,
k=k-1];];
(* Remove 0's at the end of the table polyFact. *)
k=Length[polyFact];
While[polyFact[[k]]==0,polyFact=Delete[polyFact,k];k=k-1;];
{polyFact,poly}]

The function manipPoly takes a list p = poly representing a product of factors of the form (1 - z^k) for positive integer k (identical to the first element of the output of newFactor, e.g. {0, 1, 0, 2} corresponds to (1 - z)(1 - z^3)^2) as well as a positive integer weight w = weight.  It changes each factor (1 - z^k) to (-1)^(gcd(k,w)+1)(1-z^(lcm (k,w)/w)^gcd(k,w).  The output is the resulting polynomial.

manipPoly[p_,weight_]:=Module[{poly=p,w=weight,sign,k,manPolyList,manPoly},
(* Set up a blank table manPolyList to record the factors of the new polynomial. *)
manPolyList=Table[0,{i,1,Length[poly]}];
(* As k changes from 1 to the highest degree of factors in poly, set the kth entry in manPolyList to be that of poly if gcd(k,w)=1 (no changes to the factors in this case).  If gcd(k,w) ≠ 1, then record the sign change (if any) and the new factor in manPolyList. *)
k=1;
While[k≤Length[poly],
If[GCD[k,w]==1,manPolyList[[k]]=manPolyList[[k]]+poly[[k]],
manPolyList[[LCM[w,k]/w]]=manPolyList[[LCM[w,k]/w]]+poly[[k]]*GCD[k,w];
];
k++];
(* Multiply the factors in manPolyList together to return a polynomial expression manPoly. *)
k=1;
manPoly=Product[(1-z^i)^manPolyList[[i]],{i,1,Length[manPolyList]}];
manPoly]

The function shiftSeries takes a rational function r = rat in z and a positive integer weight w = weight.  Letting D denote the degree of the denominator of rat, it computes the Maclaurin series of rat up to degree (D+2 )w.  It then shifts the series with weight a, i.e. replaces the series ∑(Subscript[c, k])(x^k) with the series ∑(Subscript[c, wk])(x^k).  The output is the shifted series (now up to degree (D+2)) as a polynomial.

shiftSeries[rat_,weight_]:=Module[{r=rat,w=weight,k,poly,series},
series=CoefficientList[(Series[r, {z, 0,w*(Exponent[Denominator[r],z])}]),z];
(* A blank list to keep track of shifted series data. *)
newSeries={};
k=1;
(* Record in newSeries the coefficients of the MacLaurin series of rat in degrees divisible by w. *)
While[k≤Length[series],
newSeries=Append[newSeries, series[[k]]];
k+=w];
k=1;
(* Add the terms of the shifted series together in poly. *)
poly=0;
While[k≤(Exponent[Denominator[r],z])&&k≤Length[newSeries],
poly=poly+newSeries[[k]]*z^(k-1);
k++];
poly]
(*Returns the component of the Hilbert Series associated to the term (1/(((1-(tz^(-(Subscript[a, i])))))^(Subscript[p, i])))*)
calcPart[i_] :=Module[{IndicesJ,Phi,PhiList,PhiNum,PhiDen,PhiTilde,PhiTildeNum,PhiTildeDen,PhiShiftedNum,PhiShiftedDen,PhiShiftedSum,k,j,m},
PhiTilde= Simplify[Cancel[1/(Product[(((1-t*(z^(-a[[j]]))))^(p[[j]])),{j,1,i-1}]*Product[(((1-t*(z^(-a[[j]]))))^(p[[j]])),{j,i+1,n}]*(Product[(((1-t*(z^(a[[j]]))))^(p[[j]])),{j,1,n}]))]]; (*Factors out (1/(((1-(tz^(-(Subscript[a, i])))))^(Subscript[p, i]))), to compute Residue*)
PhiTildeNum = Numerator[PhiTilde];
PhiTildeDen=Denominator[PhiTilde];
PhiList={};
For[k=0,k<p[[i]],k++, (*For loop uses Partial Fraction Decomposition to break down the term*)
m=p[[i]]-k;
(*Calculates Phi_i, a rational function that is multiplied by (1/((z(((1-(tz^(Subscript[a, i]))))^(pi-i)))(((1-(tz^(-(Subscript[a, i])))))^(pi-i))))) in the integral*)
Phi = ((-(z^(a[[i]])))^k*(PhiTildeNum/.{t->(z^(a[[i]]))}))/(PhiTildeDen/.{t->(z^(a[[i]]))})/Factorial[k];
PhiNum=Numerator[Phi];
PhiDen=Denominator[Phi];
(*Shifts the numerator and denominator of Phi_i*)
PhiShiftedDen=manipPoly[newFactor[PhiDen][[1]],a[[i]]]*newFactor[PhiDen][[2]]; 
PhiShiftedNum=Normal[Series[shiftSeries[Phi,a[[i]]]*PhiShiftedDen,{z,0,Exponent[PhiShiftedDen,z]}]];
(*Saves results in a list, and performs Derivative component of Partial Fraction Decomposition. The 1st derivative is computing the Residue by the Residue Theorem. The 2nd derivative is for the term in the partial fraction decomposition.*)

PhiList=Append[PhiList,((D[(z^((m-1)))*(PhiShiftedNum/PhiShiftedDen),{z,m-1}])/(Factorial[m-1]))];
PhiTildeNum=Simplify[D[PhiTildeNum,{t,1}]*PhiTildeDen-D[PhiTildeDen,{t,1}]*PhiTildeNum];
PhiTildeDen=Simplify[(PhiTildeDen^2)]];
(*Sum over all the shifted Phi_i*)
PhiShiftedSum=Sum[PhiList[[k]],{k,1,p[[i]]}];
PhiShiftedSum]

After evaluating the four functions above, change the definition of a and p below and evaluate these lines.

a={1,2}; (*Weight Vector*)
p ={1,2}; (*Multiplicity Vector*)
c =Total[p]; (*Total number of weights*)
start=SessionTime[];
n=Length[a];
ResList={};
i=1; 
While[i ≤n,(*While loop runs for all weights*)
PosNew[z_] = calcPart[i]; 
ResList=Append[ResList,PosNew[z]];
i++];
hilbSer=Simplify[Sum[ResList[[j]],{j,1,n}]];

(*Expanding to O(2)*)
Print["Rotational Component: ",Together[hilbSer]];
Print["Reflectional Component: ", (1/(((1-(z^2)))^c))]; 
Print["Combined: ",FullSimplify[(1/2)(hilbSer+(1/(((1-(z^2)))^c)))] ]
Print["Laurent Series: ",Series[FullSimplify[hilbSer(1/(((1-(z^2)))^c))],{z,1,7-2n}]];
fin=SessionTime[];
Print["The duration of this evaluation was ", fin-start, " seconds."];

Series[-(((1+(z^2)) (1+(z^4)))/((((-1+z))^5) (((1+z))^3) (((1+z+(z^2)))^2))),{z,0,12}]