9
$\begingroup$

I'm currently looking for any Mathematica package that involves Schur polynomials and/or Kostka numbers.

More generally, I'd be happy with anything that expands on symmetric polynomials in general. Does such a thing exist? I've had no luck finding any.

$\endgroup$
10
$\begingroup$

I couldn't find a package, so here's my modest attempt at an implementation. I used only the standard identities, and I'm sure there are more efficient implementations (see e.g. this paper for another algorithm for Schur functions, and see this paper on the complexity of computing Kostka numbers).

So, having warned y'all of my implementations being a bit inefficient, here they are:

validPartitionQ[part_] :=
          VectorQ[part, (IntegerQ[#] && NonNegative[#]) &] && Apply[GreaterEqual, part]

SchurPolynomial[part_?validPartitionQ, vars_List] /; Length[part] <= Length[vars] :=
  Module[{n = Length[vars], tmp},
         tmp = C /@ Range[n];
         Cancel[Det[Outer[Power, tmp, PadLeft[Reverse[part], n] + Range[0, n - 1]]]/
                Det[LinearAlgebra`VandermondeMatrix[tmp]]] /. Thread[tmp :> vars]]

MonomialSymmetricPolynomial[part_?validPartitionQ, vars_List] /;
Length[part] <= Length[vars] :=
  Module[{n = Length[vars], tmp},
         tmp = C /@ Range[n];
         Sum[Inner[Power, tmp, perm, Times], {perm, Permutations[PadRight[part, n]]}] /.
         Thread[tmp :> vars]]

reverseLexicographicQ[p1_?validPartitionQ, p2_?validPartitionQ] /;
Total[p1] == Total[p2] := 
      p1 === p2 ||
      Catch[Scan[With[{tmp = Order @@ #}, If[tmp != 0, Throw[tmp == -1]]] &,
                 Flatten[{p1, p2}, {{2}, {1}}]]]

KostkaNumber[p1_, p1_] /; validPartitionQ[p1] := 1

KostkaNumber[{n_Integer}, p2_?validPartitionQ] /; Total[p2] == n := 1

KostkaNumber[p1_?validPartitionQ, p2_?validPartitionQ] /; 
   Total[p1] == Total[p2] && ! reverseLexicographicQ[p1, p2] := 0

KostkaNumber[p1_?validPartitionQ, p2_?validPartitionQ] /; Total[p1] == Total[p2] := 
 KostkaNumber[p1, p2] = Module[{n = Total[p1], m, pl, tmp},
   m = Max[Length[p1], Length[p2]]; tmp = C /@ Range[m]; pl = IntegerPartitions[n, m];
   Extract[First[
      PolynomialReduce[SchurPolynomial[p1, tmp], 
                       Table[MonomialSymmetricPolynomial[ip, tmp], {ip, pl}], tmp, 
                       CoefficientDomain -> Integers, MonomialOrder -> Lexicographic]],
           First[Position[pl, p2]]]]

Some examples:

First[SymmetricReduction[SchurPolynomial[#, {x, y, z}], {x, y, z}, C /@
      Range[3]]] & /@ PadRight[IntegerPartitions[4, 3]]
  {C[1]^4 - 3 C[1]^2 C[2] + C[2]^2 + 2 C[1] C[3],
   C[1]^2 C[2] - C[2]^2 - C[1] C[3], C[2]^2 - C[1] C[3], C[1] C[3]}

With[{pp = IntegerPartitions[5]}, Outer[KostkaNumber, pp, pp, 1]]
   {{1, 1, 1, 1, 1, 1, 1}, {0, 1, 1, 2, 2, 3, 4}, {0, 0, 1, 1, 2, 3, 5},
    {0, 0, 0, 1, 1, 3, 6}, {0, 0, 0, 0, 1, 2, 5}, {0, 0, 0, 0, 0, 1, 4},
    {0, 0, 0, 0, 0, 0, 1}}
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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