(* Littlewood Richarson Rule implemented by Daniel Bump *) (* for Wolfram Mathematica. *) (* Copyright 1996 by Daniel Bump (bump@math.stanford.edu) *) (* http://math.stanford.edu/~bump/ *) (* Right to modify or make copies of this file for *) (* noncommercial use is hereby granted provided this *) (* copyright notice is retained. Sale of this program is *) (* prohibited. Correctness of this program and suitability *) (* for any purpose is not warranted. User assumes all risk. *) (* found at http://sporadic.stanford.edu/bump/match/weight/lwr.m on 17/09/2012 *) (* The Littlewood-Richardson Rule is a rule for multiplying partitions. Characters of symmetric groups and unitary groups are both parametrized by partitions, and the multiplication rule for partitions may be interpreted in either contexts. In the representation theory of the symmetric group, it is induction from subgroups of the form S_n x S_m --> S_{n+m}. In the representation theory of unitary groups, it is tensor product. See Fulton and Harris, `Representation Theory' and Macdonald, `Symmetric Functions and Hall Polynomials' for more information. *) (* There are two alternative usages for this program. Example: LRRule[{2,1},{2,1}] returns {{4, 2}, {4, 1, 1}, {3, 3}, {3, 2, 1}, {3, 2, 1}, {3, 1, 1, 1}, {2, 2, 2}, {2, 2, 1, 1}} . In this list of partitions, {3,2,1} appears twice, as it should, since its coefficient is 2. Alternatively, schur[2,1]*schur[2,1] returns: schur[3,3]+schur[4,2]+schur[2,2,2]+2*schur[3,2,1]+schur[4,1,1]+ schur[2,2,1,1]+schur[3,1,1,1] . Illustrating the Jacobi-Trudi identities, define e[n_]:=If[n<0,0,schur @@ Table[1,{n}]] so e[3]=schur[1,1,1] etc. Then Det[{{e[5],e[6],e[7]}, {e[2],e[3],e[4]}, {0,e[0],e[1]}}] returns schur[3, 2, 2, 1, 1] . *) (* A PARTITION is a list p={p1, p2, ... , pk} where p1>= p2 >= ... >=pk >0. p is a PARTITION OF n (and n is the WEIGHT of p)if p1+ ... +pk=n. k is the LENGTH of p. Actually trailing zeros are permitted in the program --- they are stripped by PartitionTruncate. *) (* The DIAGRAM of p is the set of all points {i,j} with 0=p[[i+1]],{i,1,Length[p]-1}],True, Print["Partition values must descend"];False] (* PartitionConjugate returns the conjugate partition. This is not needed for the Littlewood-Richardson rule but it is such a basic operation on partitions that I included it here. Recall that the conjugate of a partition is obtained by transposing its diagram, under the involution {i,j} -> {j,i}. *) PartitionConjugate[p_]:=Block[{q={}},For[i=1,i<=PartitionEval[p,1],i++, AppendTo[q,Length[Select[Table[j,{j,1,PartitionLength[p]}], p[[#]]>=i&]]]];q] (* PartitionLength returns the length of the partition. *) PartitionLength[p_]:=Length[PartitionTruncate[p]] (* NextPartition returns the partition following p in reverse lexicographic order, or {-1} if p={1,1,1, ...} *) NextPartition[p_]:=If[p[[1]]==1,{-1}, Block[{k,q,l,s},For[k=PartitionLength[p],p[[k]]<=1,k=k-1]; q=Take[p,k-1]; l=p[[k]]-1; While[(s=Plus@@p-Plus@@q)>=l,q=Append[q,l]]; If[s==0,q,Append[q,s]]]] (* Partitions[n] returns a list of partitions of n. *) Partitions[n_]:=Partitions[n]=Block[{l,p},l={{n}}; For[p={n},(p=NextPartition[p])!={-1},,l=Append[l,p]];l] (* PartitionCompare returns True if p is contained in q. *) PartitionCompare[p_,q_]:= (PartitionLength[p]<=PartitionLength[q]&& (And @@ Table[p[[i]]<=q[[i]],{i,1,PartitionLength[p]}])) (* PartitionOrder returns 1 if p preceeds q in reverse lexicographic order, -1 if p follows q, and 0 if they are equal. For partitions of equal order. PartitionOrdered returns true if the elements of l are in reverse lexicographic order *) PartitionOrder[p_,q_]:=If[PartitionTruncate[p]==PartitionTruncate[q],0, If[First[Select[Table[PartitionEval[p,i]-PartitionEval[q,i], {i,1,Max[Length[p],Length[q]]}],#!=0&]]>0,1,-1]] (* PartitionCompareStrict returns True if p is a subset of q, and the difference q-p is a horizontal strip in the sense of Macdonald, Symmetric functions and Hall Polynomials. We say that p is *strictly* contained in q. *) PartitionStrictlyCompare[p_,q_]:=(PartitionCompare[p,q]&& PartitionLength[q]<=PartitionLength[p]+1&& (And @@ Table[p[[i]]==q[[i]]||q[[i+1]]1,Length[Select[Take[w,i],#==w[[i]]-1&]]>= Length[Select[Take[w,i],#==w[[i]]&]],True],{i,1,Length[w]}] (* AppendStrictTableau[t,n] generates all Tableau extending the given one by n. *) AppendStrictTableau[t_,n_]:= (Append[t,#] & /@ Select[Partitions[(Plus @@ t[[-1]])+n], PartitionStrictlyCompare[t[[-1]],#]&]) (* If l is a list of Tableau, then AppendStrictTableauList returns the list of Tableau obtained by applying AppendStrictTableau to each element of l. *) AppendStrictTableauList[l_,n_]:= Join @@ (AppendStrictTableau[#,n]& /@ l) (* LRCandidates generates all tableaux of the form {p_0,p_1,p_2,...,p_k}, where p_0=p and Length[p_i]-Length[p_{i-1}]=q_i. *) LRCandidates[p_,q_]:= Block[{r={{p}}},For[i=1,i<=PartitionLength[q],i++, r=AppendStrictTableauList[r,q[[i]]]];r] (* LRTableau generates all tableau for the Littlewood-Richardson rule. *) LRTableau[p_,q_]:= Select[LRCandidates[PartitionTruncate[p], PartitionTruncate[q]],TestWord[LRWord[#]]&] (* LRRule returns a list of partitions resulting from the partitions p and q by multiplication. Some partitions may appear more than once in the list. Each occurs with its correct multiplicity. The list is in reverse lexicographic order. The function schur implements the Littlewood-Richardson rule as a multiplication law for Schur functions. *) LRRule[p_,q_]:=If[PartitionValidate[p]&&PartitionValidate[q], Sort[#[[-1]]& /@ LRTableau[p,q],PartitionOrder[#1,#2]>=0&],False] schur /: schur[x__]*schur[y__]:=Plus@@ (schur @@ #& /@ LRRule[{x},{y}]) schur /: schur[x__]*(a_+b_):=schur[x]*a+schur[x]*b schur /: (a_+b_)*schur[x__]:=a*schur[x]+b*schur[x] schur /: schur[x__]^(n_/;n>=2):=(schur[x]*schur[x])*schur[x]^(n-2) schur /: schur[]:=1