(* 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. *)

(* 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<i<=Length[p], 
0<j<p_i.  We say p is contained in q if the diagram of p is contained in the
diagram of q. *)

(* A TABLEAU is a sequence of partitions {p_0,p_1,p_2, ... p_k} where each
p_i is strictly contained in p_{i+1}. Given a tableau, there is associated
with it a word, described in Macdonald's loc. cit. discussion of the
Littlewood Richardson Rule. Word[t] returns the word associated with
the Tableau t. *)

(* PartitionTruncate and PartitionEval are connected to the fact that 
sometimes we want a partition padded with extra zeros. PartitionTruncate
strips these zeros; PartitionEval returns p_i if i<Length[p], or zero
otherwise. *)

PartitionTruncate[p_]:=If[p=={}||p[[-1]]!=0,p,
	PartitionTruncate[Take[p,Length[p]-1]]]

PartitionEval[p_,i_]:=If[i<=Length[p],p[[i]],0]

PartitionValidate[p_]:=If[p=={}||
	And @@Table[p[[i]]>=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]]<p[[i]]+1,
		{i,1,PartitionLength[q]-1}]))

(* PartitionsStrictlyContaining returns the partitions of n strictly 
containing p. *)

PartitionsStrictlyContaining[n_,p_]:=
	Select[Partitions[n],PartitionCompareStrict[p,#]&]

LRWord[t_]:=Join@@Table [Join @@ Table[Table[j-1,
	{PartitionEval[t[[j]],i]-PartitionEval[t[[j-1]],i]}],
		{j,Length[t],2,-1}],{i,1,Length[t[[-1]]]}]

(* TestWord[LRWord[t]] returns true if the tableau t is a lattice partition
in Macdonald's sense *)

TestWord[w_]:=And@@Table[If[w[[i]]>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

