"Root systems and Dynkin diagrams(mathematica)"의 두 판 사이의 차이

수학노트
둘러보기로 가기 검색하러 가기
5번째 줄: 5번째 줄:
 
<h5>root systems and Dynkin diagrams</h5>
 
<h5>root systems and Dynkin diagrams</h5>
  
Clear[Unirt, rt, r, alp]<br> Clear[a, b, c, d, e6, e7, e8, f, g]<br> (* choose the one of types above *)<br> ty := b<br> (* define the rank *)<br> r := 6<br> Unirt[a, i_] := UnitVector[r + 1, i] - UnitVector[r + 1, i + 1]<br> Unirt[b, i_] :=<br>  If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i], UnitVector[r, r]]<br> Unirt[c, i_] :=<br>  If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i], 2*UnitVector[r, r]]<br> Unirt[d, i_] :=<br>  If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i],<br>   UnitVector[r, r - 1] + UnitVector[r, r]]<br> Unirt[g, 1] := {1, -1, 0}<br> Unirt[g, 2] := {-1, 2, -1}<br> Unirt[f, 1] := {1, -1, 0, 0}<br> Unirt[g, 2] := {0, 1, -1, 0}<br> Unirt[g, 3] := {0, 0, 1, 0}<br> Unirt[g, 4] := {-1, -1, -1, -1}/2<br> Unirt[e6, 1] := {0, 0, 0, 0, 0, 0, 0, 1, \[Minus]1}<br> Unirt[e6, 2] := {0, 0, 0, 0, 0, 0, 1, -1, 0}<br> Unirt[e6, 3] := {1, -2, 1, -2, 1, 1, -2, 1, 1}/3<br> Unirt[e6, 4] := {0, 0, 0, 1, -1, 0, 0, 0, 0}<br> Unirt[e6, 5] := {0, 0, 0, 0, 1, -1, 0, 0, 0}<br> Unirt[e6, 6] := {0, 1, -1, 0, 0, 0, 0, 0, 0}<br> Unirt[e7, i_] :=<br>  Piecewise[{{UnitVector[r + 1, i + 2] - UnitVector[r + 1, 1 + i],<br>     i < 7}, {{1/2, 1/2, 1/2, 1/2, -(1/2), -(1/2), -(1/2), -(1/2)},<br>     i == 7}}, {i, 1, r}]<br> Unirt[e8, i_] :=<br>  Piecewise[{{UnitVector[r, i] - UnitVector[r, 1 + i],<br>     i < 7}, {UnitVector[r, i] + UnitVector[r, i - 1],<br>     i == 7}, {{-(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/<br>       2), -(1/2)}, i == 8}}, {i, Range[r]}]<br> rt[i_] := Unirt[ty, i]<br> b[i_, j_] := (2 Dot[rt[i], rt[j]])/Dot[rt[j], rt[j]]<br> CA := Table[b[i, j], {i, 1, r}, {j, 1, r}]<br> Print["root vectors of ", ty, r]<br> Table[rt[i], {i, 1, r}] // TableForm<br> Print["Cartan matrix of ", ty, r]<br> CA // MatrixForm<br> Print["Dynkin diagram of ", ty, r]<br> ed[i_, j_] := If[i < j, b[i, j] b[j, i], 0]<br> Ed := Table[ed[i, j], {i, 1, r}, {j, 1, r}]<br> Ed // MatrixForm<br> GraphPlot[Ed, DirectedEdges -> True, VertexLabeling -> True,<br>  MultiedgeStyle -> True]
+
Clear[Unirt, rt, r, alp]<br> Clear[a, b, c, d, e6, e7, e8, f, g]<br> (* choose the one of types above *)<br> ty := b<br> (* define the rank *)<br> r := 5<br> Unirt[a, i_] := UnitVector[r + 1, i] - UnitVector[r + 1, i + 1]<br> Unirt[b, i_] :=<br>  If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i], UnitVector[r, r]]<br> Unirt[c, i_] :=<br>  If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i], 2*UnitVector[r, r]]<br> Unirt[d, i_] :=<br>  If[i < r, UnitVector[r, i] - UnitVector[r, 1 + i],<br>   UnitVector[r, r - 1] + UnitVector[r, r]]<br> Unirt[g, 1] := {1, -1, 0}<br> Unirt[g, 2] := {-1, 2, -1}<br> Unirt[f, 1] := {1, -1, 0, 0}<br> Unirt[f, 2] := {0, 1, -1, 0}<br> Unirt[f, 3] := {0, 0, 1, 0}<br> Unirt[f, 4] := {-1, -1, -1, -1}/2<br> Unirt[e6, 1] := {0, 0, 0, 0, 0, 0, 0, 1, \[Minus]1}<br> Unirt[e6, 2] := {0, 0, 0, 0, 0, 0, 1, -1, 0}<br> Unirt[e6, 3] := {1, -2, 1, -2, 1, 1, -2, 1, 1}/3<br> Unirt[e6, 4] := {0, 0, 0, 1, -1, 0, 0, 0, 0}<br> Unirt[e6, 5] := {0, 0, 0, 0, 1, -1, 0, 0, 0}<br> Unirt[e6, 6] := {0, 1, -1, 0, 0, 0, 0, 0, 0}<br> Unirt[e7, i_] :=<br>  Piecewise[{{UnitVector[r + 1, i + 2] - UnitVector[r + 1, 1 + i],<br>     i < 7}, {{1/2, 1/2, 1/2, 1/2, -(1/2), -(1/2), -(1/2), -(1/2)},<br>     i == 7}}, {i, 1, r}]<br> Unirt[e8, i_] :=<br>  Piecewise[{{UnitVector[r, i] - UnitVector[r, 1 + i],<br>     i < 7}, {UnitVector[r, i] + UnitVector[r, i - 1],<br>     i == 7}, {{-(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/<br>       2), -(1/2)}, i == 8}}, {i, Range[r]}]<br> rt[i_] := Unirt[ty, i]<br> b[i_, j_] := (2 Dot[rt[i], rt[j]])/Dot[rt[j], rt[j]]<br> CA := Table[b[i, j], {i, 1, r}, {j, 1, r}]<br> Print["root vectors of ", ty, r]<br> Table[rt[i], {i, 1, r}] // TableForm<br> Print["Cartan matrix of ", ty, r]<br> CA // MatrixForm<br> Print["Dynkin diagram of ", ty, r]<br> ed[i_, j_] := If[i < j, b[i, j] b[j, i], 0]<br> Ed := Table[ed[i, j], {i, 1, r}, {j, 1, r}]<br> Ed // MatrixForm<br> GraphPlot[Ed, VertexLabeling -> True, MultiedgeStyle -> True]<br> ls[i_] := Sqrt[Dot[rt[i], rt[i]]]<br> Print["length of each root"]<br> Table[{\[Alpha][i], ls[i]}, {i, 1, r}] // TableForm

2010년 3월 14일 (일) 16:23 판

 

root systems and Dynkin diagrams

Clear[Unirt, rt, r, alp]
Clear[a, b, c, d, e6, e7, e8, f, g]
(* choose the one of types above *)
ty := b
(* define the rank *)
r := 5
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