These mathematical objects representing supersymmetric particles, in physics oh my goodness!
AdinkraVertexCoordinates[vertices_, vertexweights_] := Module[
{coords, ids, coordsList},
coords = Table[{i, j}, {i, -2, 2}, {j, -2, 2}];
ids = Flatten[Position[vertexweights, #]] & /@ {-4, -3, -2, -1, 1,
2, 3, 4};
coordsList = vertices[[#]] -> coords[[#]] & /@ ids;
coordsList]
AdinkraGraph[vertices_, vertexweights_, edges_, edgeweights_,
colors_] :=
Graph[Style[vertices[[#]],
If[Sign[vertexweights[[#]]] > 0, White, Black]] & /@
Range[Length[vertices]],
Style[edges[[#]], colors[edges[[#]][[1]]], Thick] & /@
Range[Length[edges]], VertexWeight -> vertexweights,
EdgeWeight -> edgeweights,
VertexCoordinates ->
AdinkraVertexCoordinates[vertices, vertexweights],
DirectedEdges -> False, ImageSize -> Medium]
vertices = {A, B, F,
G, \[CapitalPsi]1, \[CapitalPsi]2, \[CapitalPsi]3, \
\[CapitalPsi]4};
vertexweights = {1, 2, 3, 4, -2, -1, -3, -4};
edges = {A -> \[CapitalPsi]2,
B -> \[CapitalPsi]4, \[CapitalPsi]3 -> F, \[CapitalPsi]1 -> G,
A -> \[CapitalPsi]4,
B -> \[CapitalPsi]2, \[CapitalPsi]1 -> F, \[CapitalPsi]3 -> G,
A -> \[CapitalPsi]1,
B -> \[CapitalPsi]3, \[CapitalPsi]4 -> F, \[CapitalPsi]2 -> G,
A -> \[CapitalPsi]3,
B -> \[CapitalPsi]1, \[CapitalPsi]2 -> F, \[CapitalPsi]4 -> G};
edgeweights = {2, -1, 4, 3, 4, -3, -2, -1, 1, 2, -3, 2, 3, 4, 1, -2};
colors = <|1 -> Green, 2 -> Purple, 3 -> Orange, 4 -> Red|>;
HorizontalSpacing[n_] := Range[n] - (n + 1)/2;
GraphPlot3D[
AdinkraGraph[vertices, vertexweights, edges, edgeweights, colors]]
Swapping pairs of original pairings that's the kind of thing it's like word within the word.
AdinkraGraph[vertices_, edges_] :=
Module[{n = Length[vertices], coordsList},
coordsList = vertices[[#]] -> CirclePoints[n][[#]] & /@ Range[n];
Graph3D[vertices, edges,
VertexStyle ->
Table[vertices[[i]] -> Directive[EdgeForm[Black], White], {i, n}],
VertexCoordinates -> coordsList, ImageSize -> Medium]]
vertices = {A, B, F,
G, \[CapitalPsi]1, \[CapitalPsi]2, \[CapitalPsi]3, \
\[CapitalPsi]4};
edges = {A -> \[CapitalPsi]2,
B -> \[CapitalPsi]4, \[CapitalPsi]3 -> F, \[CapitalPsi]1 -> G,
A -> \[CapitalPsi]4,
B -> \[CapitalPsi]2, \[CapitalPsi]1 -> F, \[CapitalPsi]3 -> G,
A -> \[CapitalPsi]1,
B -> \[CapitalPsi]3, \[CapitalPsi]4 -> F, \[CapitalPsi]2 -> G,
A -> \[CapitalPsi]3,
B -> \[CapitalPsi]1, \[CapitalPsi]2 -> F, \[CapitalPsi]4 -> G};
GraphPlot3D[AdinkraGraph[vertices, edges]]
I love your visually accurate Adinkra, it's like the number of re-writing operations just isn't enough so you've got these re-writing rules.
LMatricesToAdinkraGraph[L1_, X1_, Y1_, Z1_, bosons_ : {A, B, F, G},
fermions_ : {Subscript[\[CapitalPsi], 1],
Subscript[\[CapitalPsi], 2], Subscript[\[CapitalPsi], 3],
Subscript[\[CapitalPsi], 4]}, n_ : 2] :=
Module[{states, vertices, edges},
states =
MatrixToAdinkraStates[L1, X1, Y1, bosons, fermions, n][[n + 1]];
vertices = DeleteDuplicates@Flatten@states;
edges = Rule @@@ states;
AdinkraGraph[vertices, edges]]
L1 = {{1, x}, {2, w}, {3, y}, {4, z}};
X1 = {{1, z}, {2, w}, {3, x}, {4, y}};
Y1 = {{1, w}, {2, z}, {3, y}, {4, x}};
Z1 = {{-1, 0, 0, 0}, {0, -1, 0, 0}, {0, 0, -1, 0}, {0, 0, 0, -1}};
GraphPlot3D[LMatricesToAdinkraGraph[L1, X1, Y1, Z1], Boxed -> False,
EdgeStyle -> Directive[Thickness[0.005], Opacity[0.5]],
VertexSize -> Large,
VertexLabelStyle -> Directive[Black, FontSize -> 16],
PlotRange -> All, ViewPoint -> {0, -2, 1}]
It's the supersymmetric physics from the set of L-matrices, that generate this visually accurate one and we can make smaller & larger adinkras. We could do the WolframModel
rules or a multi-way system setup. I think that this is one of the best things that my eyes have ever seen.