Root systems and Dynkin diagrams(mathematica)

root systems and Dynkin diagrams

1. Clear[Unirt, rt, r, alp]
   Clear[a, b, c, d, e6, e7, e8, f, g]
   (*choose the one of types above*)
   ty := a
   (*define the rank*)
   r := 3
   (* coordinates for roots *)
   Unirt[a, i_] := UnitVector[r + 1, i] - UnitVector[r + 1, i + 1]
   Unirt[b, i_] :=
    If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i], UnitVector[r, r]]
   Unirt[c, i_] :=
    If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i], 2*UnitVector[r, r]]
   Unirt[d, i_] :=
    If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i],
     UnitVector[r, r - 1] + UnitVector[r, r]]
   Unirt[g, 1] := {1, -1, 0}
   Unirt[g, 2] := {-1, 2, -1}
   Unirt[f, 1] := {1, -1, 0, 0}
   Unirt[f, 2] := {0, 1, -1, 0}
   Unirt[f, 3] := {0, 0, 1, 0}
   Unirt[f, 4] := {-1, -1, -1, -1}/2
   Unirt[e6, 1] := {0, 0, 0, 0, 0, 0, 0, 1, \[Minus]1}
   Unirt[e6, 2] := {0, 0, 0, 0, 0, 0, 1, -1, 0}
   Unirt[e6, 3] := {1, -2, 1, -2, 1, 1, -2, 1, 1}/3
   Unirt[e6, 4] := {0, 0, 0, 1, -1, 0, 0, 0, 0}
   Unirt[e6, 5] := {0, 0, 0, 0, 1, -1, 0, 0, 0}
   Unirt[e6, 6] := {0, 1, -1, 0, 0, 0, 0, 0, 0}
   Unirt[e7, i_] :=
    Piecewise[{{UnitVector[r + 1, i + 2] - UnitVector[r + 1, 1 + i],
       i < 7}, {{1/2, 1/2, 1/2, 1/2, -(1/2), -(1/2), -(1/2), -(1/2)},
       i == 7}}, {i, 1, r}]
   Unirt[e8, i_] :=
    Piecewise[{{UnitVector[r, i] - UnitVector[r, 1 + i],
       i < 7}, {UnitVector[r, i] + UnitVector[r, i - 1],
       i == 7}, {{-(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/
           2), -(1/2)}, i == 8}}, {i, Range[r]}]
   rt[i_] := Unirt[ty, i]
   b[i_, j_] := (2 Dot[rt[i], rt[j]])/Dot[rt[j], rt[j]]
   CA := Table[b[i, j], {i, 1, r}, {j, 1, r}]
   Print["root vectors of ", ty, r]
   Table[rt[i], {i, 1, r}] // TableForm
   Print["Cartan matrix of ", ty, r]
   CA // MatrixForm
   Print["Dynkin diagram of ", ty, r]
   ed[i_, j_] := If[i < j, b[i, j] b[j, i], 0]
   Ed := Table[ed[i, j], {i, 1, r}, {j, 1, r}]
   Ed // MatrixForm
   GraphPlot[Ed, VertexLabeling -> True, MultiedgeStyle -> True]
   ls[i_] := Sqrt[Dot[rt[i], rt[i]]]
   Print["length of each root"]
   Table[{\[Alpha][i], ls[i]}, {i, 1, r}] // TableForm
   Print["eigenvalues and eigenvectors of Cartan matrix"]
   Eigenvalues[CA]
   Eigenvectors[CA]
   Print["Incidence matrix"]
   Inc := 2 IdentityMatrix[r] - CA
   Inc // MatrixForm
   Print["eigenvalues of incidence matrix"]
   Eigenvalues[Inc]
   (* coxeter number *)
   Print["Coxeter number"]
   Cox[a, i_] := i + 1
   Cox[b, i_] := 2 i
   Cox[c, i_] := 2 i
   Cox[d, i_] := 2 i - 2
   Cox[e6, i_] := 12
   Cox[e7, i_] := 18
   Cox[e8, i_] := 30
   Cox[f, i_] := 12
   Cox[g, i_] := 6
   Cox[ty, r]
   (* dual coxeter number *)
   Print["dual Coxeter number"]
   dCox[a, i_] := i + 1
   dCox[b, i_] := 2 i - 1
   dCox[c, i_] := i + 1
   dCox[d, i_] := 2 i - 2
   dCox[e6, i_] := 12
   dCox[e7, i_] := 18
   dCox[e8, i_] := 30
   dCox[f, i_] := 9
   dCox[g, i_] := 4
   dCox[ty, r]

 

 

related items

• [[Root Systems and Dynkin diagrams|]]

 

 

encyclopedia

• http://en.wikipedia.org/wiki/root_systems
• http://en.wikipedia.org/wiki/Dynkin_diagram
• http://mathworld.wolfram.com/DynkinDiagram.html