Weyl Group

Author

Eric W. Weisstein
April 14, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Algebra/WeylGroup.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/WeylGroup.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Code for figures by
Todd Rowland
Wolfram Research, Inc.

Notes

Code could be cleaned up a bit

Figure

<<Graphics`Arrow`;
<<Graphics`Colors`;

a1a1={{2,0},{0,2}};
a2={{2,-1},{-1,2}};
a3={{2,-1,0},{-1,2,-1},{0,-1,2}};
b2={{2,-2},{-1,2}};
b3={{2,-1,0},{-1,2,-2},{0,-1,2}};
c3={{2,-1,0},{-1,2,-1},{0,-2,2}};
g2={{2,-1},{-3,2}};
f4={{2,-1,0,0},{-1,2,-2,0},{0,-1,2,-1},{0,0,-1,2}};

sln[n_]:=2IdentityMatrix[n]-PadLeft[PadRight[IdentityMatrix[n-1],{n,n-1}],{n,n}]-PadLeft[PadRight[IdentityMatrix[n-1],{n-1,n}],{n,n}]

bee[n_]:=ReplacePart[ReplacePart[ReplacePart[PadRight[sln[n-1],{n,n}],-2,{n-1,n}],-1,{n,n-1}],2,{n,n}]
sea[n_]:=ReplacePart[ReplacePart[ReplacePart[PadRight[sln[n-1],{n,n}],-1,{n-1,n}],-2,{n,n-1}],2,{n,n}]
iee[n_]:=ReplacePart[ReplacePart[ReplacePart[PadRight[sln[n-1],{n,n}],-1,{n-3,n}],-1,{n,n-3}],2,{n,n}]
den[n_]:=ReplacePart[ReplacePart[ReplacePart[PadRight[sln[n-1],{n,n}],-1,{n-2,n}],-1,{n,n-2}],2,{n,n}]




(*Efficiently computes the positive roots given Cartan matrix*)
PosRoots[a_List]:=Module[{l=Length[a],news,ck,kvec,ans},
ans=news=kvec=IdentityMatrix[l];
ck[k_,bet_]:=
Module[{nba=Transpose[a][[k]].bet+1},
If[nba≤ 0 || MemberQ[ans,(bet-nba kvec[[k]])],{bet+kvec[[k]]},{}]];
While[news≠{},news=Union[Flatten[Outer[ck,Range[l],news,1],2]];
ans=Join[ans,news];];
ans]



Weylnth[a_List,{n_Integer}]:=
Module[{l=Length[a]},
IdentityMatrix[l]-PadRight[PadLeft[{a},{n,l}],{l,l}]]
WeylGenerators[a_List]:=MapIndexed[Weylnth,Transpose[a]]

(*Generates a finite matrix group.  Over the integers there is no roundoff error, ensuring finite computation.*)

gen1[a_List,g_List]:=Union[a,Flatten[Outer[Dot,a,g,1],1]]
gen2[g_List]:=
FixedPoint[(gen1[#1,g]&),{IdentityMatrix[Length[g[[1]]]]}]

WeylGroup[a_List]:=gen2[WeylGenerators[a]]

(*List the roots in the integral root lattice, given the Cartan matrix:WARNING INEFFICIENT:See PosRoots above*)

RootsList[c_]:=Union[Flatten[Transpose[WeylGroup@c,{1,3,2}],1]]

(*Tests and lists the positive roots in the integral lattice*)
posrotQ[v_]:=UnitStep@@v+DiscreteDelta@@v==1
lisrot[rts_]:=Select[rts,posrotQ]


lr[a_List]:=Rest/@(Rest[a]);
unSquare[{b_}]={b^(1/2)};
unSquare[a_List]:=Module[{jd, jd2,len},
len= a[[1,1]]^(1/2);
jd = {Rest[a[[1]]]/len};
jd2=Transpose[jd].jd;
Join[{PadRight[{len},Length[a]]}, Transpose[Join[jd, Transpose[unSquare[lr[a]-jd2]]]]]]

(*gives simple roots in euclidean space for a cartan matrix*)
tor[a_List]:=
Module[{tmp,tmp2,tmp3,l=Length[a]},
tmp=Table[If[i>j &&a[[i,j]]≠0, a[[i,j]]/a[[j,i]],0],{j,l},{i,l}];
tmp2=DiscreteDelta/@Tr[Sum[MatrixPower[tmp,n],{n,l}],Plus,1];
tmp3=MatrixPower[tmp+PadRight[{tmp2},{l,l}],l][[1]];
unSquare[a.DiagonalMatrix[tmp3/2]]]

poseuclrts[a_List]:=PosRoots[a].tor[a]
allrts[a_List]:=(Join[#1,-#1]&)@poseuclrts[a]
arrposrts[a_List]:=(Arrow[{0,0},#1]&)/@poseuclrts[a]
arrrts[rts_List]:=(Arrow[{0,0},#1]&)/@rts
lines3d[a_List]:=
Show[Graphics3D[Join[{PointSize[.05],Point[{0,0,0}],Blue,PointSize[.03]},Point/@allrts[a],{Purple},
(Line[{{0,0,0},#1}]&)/@allrts[a]
]]]
lg[a_,r_]:=Select[poseuclrts[a],Abs[#1.#1-r]<.1&]
otherlines3d[rts1_List,rts2_List]:=
Show[Graphics3D[Join[{PointSize[.05],Point[{0,0,0}],Green,PointSize[.03]},
Point/@(Join[rts2,-rts2]),{Blue},
Point/@(Join[rts1,-rts1]),{Purple},
(Line[{-#1,#1}]&)/@rts1,{Orange},
(Line[{-#1,#1}]&)/@rts2
]]]

Animation for Weyl Group acting on the roots of (Subscript[g, 2])

(*Weyl Group Animation*)

Clear[wg];
wg=
gen2[{{{-1,0},{0,1}},{{Cos[2Pi/3],Cos[Pi/6]},{Sin[2Pi/3],Sin[Pi/6]}}}]

Clear[shw,wg2,wg3,gps];
shw[mat_,prts_]:=Show[Graphics[Join[{Blue},arrrts[(mat.#1&)/@prts],{Orange},arrrts[-((mat.#1&)/@prts)]
]
],AspectRatio->Automatic,PlotRange->{{-2,2},{-2,2}}]
gps=poseuclrts[g2];
wg2=Prepend[Drop[wg,-1],IdentityMatrix[2]];
wg3=Transpose[{wg2,wg}];
hmt[{a_List,b_List},t_]:=(1-t)a+t b

Export[GIFDirectory<>"weylgr1.gif",Flatten[Table[shw[hmt[#1,t],gps],{t,0,1,.2}]&/@wg3]]

Export[GIFDirectory<>"weylgr2.gif",Flatten[Table[shw[(1-t)IdentityMatrix[2]+t #1,poseuclrts[g2]],{t,0,1,.2}]&/@wg]]

Animation of Weyl Group acting on the roots of a3, i.e., (Subscript[sl, 4])(may be too memory intensive)

Clear[ko1,ko2,ko3,ko4,ko5,ko6,ko7,yose,cnj,shw2,ptnln];
yose=poseuclrts[a3];
ko1=WeylGroup[a3];
ko2=Transpose[tor[a3]];
ko3=Inverse[ko2];

cnj[a_List]:=ko2.a.ko3

ko4=cnj/@ko1;
ko5=RotateLeft[ko4,Position[ko4,IdentityMatrix[3]][[1,1]]];
ko6=RotateRight[ko5];
ko7=Transpose[{ko6,ko5}];

ptnln[v_List]:=Join[Point/@v,Line[{{0,0,0},#1}]&/@v]

shw2[mat_,prts_,r_]:=Show[Graphics3D[Join[{PointSize[.03],Cyan},
ptnln[(mat.#1&)/@prts],{SeaGreen},ptnln[-((mat.#1&)/@prts)]
]],PlotRange->r{{-1,1},{-1,1},{-1,1}}]

hmt[{a_List,b_List},t_]:=(1-t)a+t b

WriteLiveAnimationForm["weylgrp.m",Flatten[(Table[shw2[hmt[#1,t],yose,1],{t,0,1,.2}]&)/@ko7]]