Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question

1 Answer 1

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}}
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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