RootsOfUnity package

A subpackage for QuantumGroups v2.
Version 2.0, September 18, 2008, Scott Morrison

Introduction

Implementation

BeginPackage["QuantumGroups`Steinberg`",{"QuantumGroups`","QuantumGroups`RootsOfUnity`","QuantumGroups`RootsOfUnity`","QuantumGroups`Representations`","QuantumGroups`RootSystems`"}];

SteinbergDecomposeRepresentation;

Begin["`Private`"];

SteinbergFold[Γ_,i_][c_]/;1≤i≤Rank[Γ]:=Module[{root,innerproduct},
root=SimpleRoots[Γ][[i]];
innerproduct[λ_]:=innerproduct[λ]=KillingForm[Γ][λ+ρ[Γ],root];
c/.{Irrep[Γ][λ_]/;(innerproduct[λ]==0):>0,Irrep[Γ][λ_]/;(innerproduct[λ]<0):>(f[λ];-Irrep[Γ][λ-(2((innerproduct[λ])/(innerproduct[root-ρ[Γ]])))root])}
]

SteinbergAlcoveFold[Γ_,l_][c_]:=Module[{root,innerproduct,wall},
root=-AlcoveDefiningRoot[Γ,l];
innerproduct[λ_]:=innerproduct[λ]=KillingForm[Γ][λ+ρ[Γ],root];
wall=-If[EvenQ[l],l/2,l];
c/.{Irrep[Γ][λ_]/;(innerproduct[λ]==wall):>0,Irrep[Γ][λ_]/;(innerproduct[λ]<wall):>-Irrep[Γ][λ-(2((innerproduct[λ]-wall)/(innerproduct[root-ρ[Γ]])))root]}
]

SteinbergFoldAll[Γ_,l_:0][c_]:=
Fold[#2[#1]&,c,If[l>0,{SteinbergAlcoveFold[Γ,l]},{}]~Join~Table[SteinbergFold[Γ,i],{i,1,Rank[Γ]}]]

SteinbergDecomposeRepresentation[Γ_,l_:0][Irrep[Γ_][λ_]⊗Irrep[Γ_][μ_]]:=SteinbergDecomposeRepresentation[Γ,l][Irrep[Γ][λ]⊗Irrep[Γ][μ]]=FixedPoint[SteinbergFoldAll[Γ,l],
Plus@@(WeightMultiplicities[Γ,Irrep[Γ][μ]]/.{κ:{___Integer},n_Integer}:>n Irrep[Γ][κ+λ])]/.{n_Integer V:Irrep[Γ][_]/;n>0:>DirectSum@@Table[V,{n}]}/.Plus->DirectSum

End[];

EndPackage[];