RootSystems package

A subpackage for QuantumGroups v2.
Version 2.0, June 20, 2005, Scott Morrison

Introduction

Implementation

BeginPackage["QuantumGroups`RootSystems`",{"QuantumGroups`"}];

CartanMatrix;
CartanFactors;
LacingNumber;
Rank;
KillingForm;
ρ;
SimpleRoots;
SimpleReflection;
WeylOrbit;
RootWeightQ;
WeightsModRoots;
WeightInLatticeQ;
IntermediateLattices;
PositiveWeightQ;
InWeylPolytopeQ;
SortWeights;
SortWeightMultiplicities;
MinusculeWeightQ;
MinusculeRepresentationQ;
ReflectIntoPositiveWeylChamber;
DominantRoots;
ShortDominantRoots;
LongDominantRoots;
ShortSimpleRoots;
ShortRoots;
ShortDominantRootQ;DualCoxeterNumber;

Begin["`Private`"];

CartanMatrix[(Subscript[A, n_])]:=CartanMatrix[(Subscript[A, n])]=Array[Switch[#1-#2,1,-1,0,2,-1,-1,_,0]&,{n,n}]

ElementaryMatrix[n_,i0_,j0_]:=Table[If[i==i0∧j==j0,1,0],{i,1,n},{j,1,n}]

CartanMatrix[(Subscript[B, n_])]:=CartanMatrix[(Subscript[B, n])]=CartanMatrix[(Subscript[A, n])]-ElementaryMatrix[n,n,n-1]

CartanMatrix[(Subscript[C, n_])]:=CartanMatrix[(Subscript[C, n])]=CartanMatrix[(Subscript[A, n])]-ElementaryMatrix[n,n-1,n]

CartanMatrix[(Subscript[D, n_])]:=CartanMatrix[(Subscript[D, n])]=CartanMatrix[(Subscript[A, n])]+ElementaryMatrix[n,n,n-1]+ElementaryMatrix[n,n-1,n]-ElementaryMatrix[n,n,n-2]-ElementaryMatrix[n,n-2,n]

CartanMatrix[(Subscript[E, 6])]=(({{2, 0, -1, 0, 0, 0}, {0, 2, 0, -1, 0, 0}, {-1, 0, 2, -1, 0, 0}, {0, -1, -1, 2, -1, 0}, {0, 0, 0, -1, 2, -1}, {0, 0, 0, 0, -1, 2}}));

CartanMatrix[(Subscript[E, 7])]=(({{2, 0, -1, 0, 0, 0, 0}, {0, 2, 0, -1, 0, 0, 0}, {-1, 0, 2, -1, 0, 0, 0}, {0, -1, -1, 2, -1, 0, 0}, {0, 0, 0, -1, 2, -1, 0}, {0, 0, 0, 0, -1, 2, -1}, {0, 0, 0, 0, 0, -1, 2}}));

CartanMatrix[(Subscript[E, 8])]=(({{2, 0, -1, 0, 0, 0, 0, 0}, {0, 2, 0, -1, 0, 0, 0, 0}, {-1, 0, 2, -1, 0, 0, 0, 0}, {0, -1, -1, 2, -1, 0, 0, 0}, {0, 0, 0, -1, 2, -1, 0, 0}, {0, 0, 0, 0, -1, 2, -1, 0}, {0, 0, 0, 0, 0, -1, 2, -1}, {0, 0, 0, 0, 0, 0, -1, 2}}));

CartanMatrix[(Subscript[F, 4])]=(({{2, -1, 0, 0}, {-1, 2, -1, 0}, {0, -2, 2, -1}, {0, 0, -1, 2}}));

CartanMatrix[(Subscript[G, 2])]=(({{2, -3}, {-1, 2}}));

CartanFactors[(Subscript[A, n_])]:=CartanFactors[(Subscript[A, n])]=Table[1,{n}]

CartanFactors[(Subscript[B, n_])]:=CartanFactors[(Subscript[B, n])]=Table[2,{n-1}]~Join~{1}

CartanFactors[(Subscript[C, n_])]:=CartanFactors[(Subscript[C, n])]=Table[1,{n-1}]~Join~{2}

CartanFactors[(Subscript[D, n_])]:=CartanFactors[(Subscript[D, n])]=Table[1,{n}]

CartanFactors[(Subscript[G, 2])]={1,3};

CartanFactors[(Subscript[F, 4])]={2,2,1,1};

CartanFactors[(Subscript[E, n_])]:=CartanFactors[(Subscript[E, n])]=Table[1,{n}]

LacingNumber[(Subscript[(A|D|E), _])]=1;
LacingNumber[(Subscript[(B|C|F), _])]=2;
LacingNumber[(Subscript[G, 2])]=3;

Rank[(Subscript[Γ_, n_])]:=n

InverseCartanMatrix[Γ_]:=InverseCartanMatrix[Γ]=Inverse[CartanMatrix[Γ]]

(*KillingForm[Γ_][x_,y_]:=Simplify[x.InverseCartanMatrix[Γ].y]*)

KillingForm[Γ_][x_,y_]:=Simplify[x.Inverse[CartanFactors[Γ]CartanMatrix[Γ]].y]

KillingForm[Γ_][x_,y_]:=Simplify[x.Inverse[Transpose[CartanMatrix[Γ]]].DiagonalMatrix[CartanFactors[Γ]].y]

ρ[Γ_]:=Table[1,{Rank[Γ]}]

SimpleRoots[Γ_]:=Transpose[CartanMatrix[Γ]]

SimpleReflection[Γ_,i_][x_]:=
With[{λ=SimpleRoots[Γ][[i]]},x-2((KillingForm[Γ][λ,x])/(KillingForm[Γ][λ,λ]))λ]

AllSimpleReflections[Γ_][x_]:=Table[SimpleReflection[Γ,i][x],{i,1,Rank[Γ]}]

WeylOrbit[Γ_,λ_]:=FixedPoint[Union[Flatten[AllSimpleReflections[Γ]/@#,1],#]&,{λ}]

RootWeightQ[Γ_,λ_]:=And@@(IntegerQ/@Table[((2KillingForm[Γ][λ,UnitVector[Rank[Γ],k]])/(KillingForm[Γ][SimpleRoots[Γ][[k]],SimpleRoots[Γ][[k]]])),{k,1,Rank[Γ]}])

WeightsModRoots[Γ_]:=WeightsModRoots[Γ]={ZeroVector[Rank[Γ]]}~Join~DeleteCases[IdentityMatrix[Rank[Γ]],λ_/;RootWeightQ[Γ,λ]]

WeightInLatticeQ[Γ_,λ_,sublattice_]:=
Or@@(RootWeightQ[Γ,#+λ]&/@WeightsModRoots[Γ][[sublattice]])

IntermediateLatticeQ[Γ_,subset_]:=And@@Flatten[Outer[WeightInLatticeQ[Γ,WeightsModRoots[Γ][[#1]]+WeightsModRoots[Γ][[#2]],subset]&,subset,subset]]

IntermediateLattices[Γ_]:=Cases[{1}~Join~#&/@Subsets[Range[2,Length[WeightsModRoots[Γ]]]],subset_/;IntermediateLatticeQ[Γ,subset]]

In PositiveWeightQ, we don't ask that the entries be integers, because Littelmann paths have vertices off the weight lattice.

PositiveWeightQ[Γ_][λ_]:=And@@(NonNegative/@λ)

ReflectIntoPositiveWeylChamber[Γ_][λ_]:=With[{p=Position[λ,_?Negative]}, If[Length[p]==0,λ,ReflectIntoPositiveWeylChamber[Γ][SimpleReflection[Γ,p[[1,1]]][λ]]]]

WeightsOrderedQ[Γ_][λ_,μ_]:=And@@(NonNegative[KillingForm[Γ][λ-μ,#]]&/@IdentityMatrix[Rank[Γ]])

InWeylPolytopeQ[Γ_,λ_,μ_]:=InWeylPolytopeQ[Γ,λ,μ]=WeightsOrderedQ[Γ][λ,ReflectIntoPositiveWeylChamber[Γ][μ]]

OrderingWeight[(Subscript[A, n_])]:=OrderingWeight[(Subscript[A, n])]=Table[1+(10^(-5-i)),{i,1,n}]

WeightsOrderedComplete[Γ_][λ_,μ_]:=With[{θ=OrderingWeight[Γ]},KillingForm[Γ][λ,θ]>KillingForm[Γ][μ,θ]]

SortWeights[Γ_][weights_]:=With[{θ=OrderingWeight[Γ]},weights[[Ordering[-KillingForm[Γ][#,θ]&/@(weights/.Irrep[_][λ_]:>λ)]]]]

SortWeightMultiplicities[Γ_][l_]:=With[{θ=OrderingWeight[Γ]},l[[Ordering[-KillingForm[Γ][#[[1]],θ]&/@(l/.Irrep[_][λ_]:>λ)]]]]

MinusculeWeightQ[(Subscript[A, n_]),λ_]:=UnitVectorQ[λ]

MinusculeWeightQ[(Subscript[B, n_]),λ_]:=λ===UnitVector[n,n]
MinusculeWeightQ[(Subscript[C, n_]),λ_]:=λ===UnitVector[n,1]
MinusculeWeightQ[(Subscript[D, n_]),λ_]:=MemberQ[{UnitVector[n,1],UnitVector[n,n-1],UnitVector[n,n]},λ]

MinusculeWeightQ[(Subscript[E, 6]),{1,0,0,0,0,0}]=True;
MinusculeWeightQ[(Subscript[E, 6]),{0,0,0,0,0,1}]=True;

MinusculeWeightQ[(Subscript[E, 7]),{1,0,0,0,0,0,0}]=False;
MinusculeWeightQ[(Subscript[E, 7]),{0,1,0,0,0,0,0}]=False;
MinusculeWeightQ[(Subscript[E, 7]),{0,0,1,0,0,0,0}]=False;
MinusculeWeightQ[(Subscript[E, 7]),{0,0,0,1,0,0,0}]=False;
MinusculeWeightQ[(Subscript[E, 7]),{0,0,0,0,1,0,0}]=False;
MinusculeWeightQ[(Subscript[E, 7]),{0,0,0,0,0,1,0}]=False;
MinusculeWeightQ[(Subscript[E, 7]),{0,0,0,0,0,0,1}]=True;

I don't actually know whether 4 and 5 are minuscule or not. 1,2,3 and 6 aren't. You can use the following to test these:

With[{Γ=(Subscript[B, 4]),k=1},Max[Last/@WeightMultiplicities[Γ,Irrep[Γ][UnitVector[Rank[Γ],k]]]]==1∧WeightMultiplicity[Γ,Irrep[Γ][UnitVector[Rank[Γ],k]],ZeroVector[Rank[Γ]]]==0]

With[{Γ=(Subscript[E, 7]),k=2},Max[Last/@WeightMultiplicities[Γ,Irrep[Γ][UnitVector[Rank[Γ],k]]]]==1∧WeightMultiplicity[Γ,Irrep[Γ][UnitVector[Rank[Γ],k]],ZeroVector[Rank[Γ]]]==0]

MinusculeWeightQ[_,_]:=False

MinusculeRepresentationQ[Γ_,Irrep[Γ_][λ_]]:=MinusculeWeightQ[Γ,λ]

MinusculeRepresentations[Γ_]:=Irrep[Γ]/@Select[IdentityMatrix[Rank[Γ]],MinusculeWeightQ[Γ,#]&]

DominantRoots[Γ_]:=DominantRoots[Γ]=Union[ReflectIntoPositiveWeylChamber[Γ]/@SimpleRoots[Γ]]

ShortDominantRoots[Γ_]:=ShortDominantRoots[Γ]=Module[{dr=DominantRoots[Γ],shortLength},
shortLength=Min[KillingForm[Γ][#,#]&/@dr];
Select[dr,KillingForm[Γ][#,#]==shortLength&]
]

LongDominantRoots[Γ_]:=LongDominantRoots[Γ]=Module[{dr=DominantRoots[Γ],longLength},
longLength=Max[KillingForm[Γ][#,#]&/@dr];
Select[dr,KillingForm[Γ][#,#]==longLength&]
]

ShortSimpleRoots[Γ_]:=ShortSimpleRoots[Γ]=Module[{shortLength},
shortLength=Min[KillingForm[Γ][#,#]&/@SimpleRoots[Γ]];
Select[SimpleRoots[Γ],KillingForm[Γ][#,#]==shortLength&]
]

ShortRoots[Γ_]:=ShortRoots[Γ]=ShortRoots[Γ]=Union@@(WeylOrbit[Γ,#]&/@ShortDominantRoots[Γ])

ShortDominantRootQ[Γ_,λ_]:=MemberQ[ShortDominantRoots[Γ],λ]

DualCoxeterNumber[(Subscript[A, n_])]:=n+1
DualCoxeterNumber[(Subscript[B, n_])]:=2n-1
DualCoxeterNumber[(Subscript[C, n_])]:=n+1
DualCoxeterNumber[(Subscript[D, n_])]:=2n-2
DualCoxeterNumber[(Subscript[E, 6])]=12;
DualCoxeterNumber[(Subscript[E, 7])]=18;
DualCoxeterNumber[(Subscript[E, 8])]=30;
DualCoxeterNumber[(Subscript[F, 4])]=9;
DualCoxeterNumber[(Subscript[G, 2])]=4;

End[];

EndPackage[];

CartanMatrix[(Subscript[G, 2])]

CartanFactors[(Subscript[G, 2])]

CartanFactors[(Subscript[G, 2])]CartanMatrix[(Subscript[G, 2])]//MatrixForm

ShortRoots[(Subscript[F, 4])]

DominantRoots[(Subscript[A, 4])]

ShortDominantRoots[(Subscript[B, 6])]

DominantRoots[(Subscript[B, 6])]

DominantRoots[(Subscript[C, 7])]

DominantRoots[(Subscript[D, 8])]

DominantRoots[(Subscript[G, 2])]

ShortDominantRoots[(Subscript[G, 2])]

ReflectIntoPositiveWeylChamber[(Subscript[B, 3])]/@CartanMatrix[(Subscript[B, 3])]

WeylOrbit[(Subscript[B, 3]),#]&/@Table[SimpleRoot[(Subscript[B, 3]),i],{i,1,3}]