The recent video on 3Blue1Brown is something I enjoyed after a long time in the channel. While any post, article or video about Burnside's Lemma is always a delight, the introduction of Sol Lewitt and his mathematical art made the video all the more satisfying to me.
Naturally, I too wanted to explore this idea. I was interested in couple of things - what if we include reflections as well? what about cubes that are unconnected?
While I tried to find the answers mathematically, I realized that I'm both stupid and lazy to figure these myself. I decided to take the easy way and use Mathematica to aid myself, and these results form the crux of this post.
While I understand that from an artist's perpective, Sol might have been interested about (only) connected cubes, we don't have to constrain ourselves with that. With a straightforward bruteforce approach, Mathematica gave me the following.
![]() |
Count of Sol LeWitt's cubes by Connected Components and Number of Edges |
Rows in the above matrix gives the number of connected components and the Columns represents the number of edges. For example, the top left value shows that there is exactly one cube that has $0$ connected components and $0$ edges - (obviously) the empty cube. Similarly, we can see that $23$ cubes have $6$ edges and $2$ connected components.
![]() |
Some examples of Sol LeWitt's Incomplete cubes |
The second row of the matrix (representing the number of cubes with exactly one connected component) was what Sol was interested. We see the two sums to $127$ of which $4$ are planar and $1$ is the complete cube giving the $122$ cubes that Sol found.
From here, I realized that the code I wrote should be easily extendable to identify reflections as well. With the assumption that the Octahedral group (3D equivalent to Dihedral group) is a combination of rotation and point reflection, I modified the same and got the following 'count' matrix.
![]() |
Count of Sol LeWitt's cubes by Connected Components and Number of Edges with reflections identified |
We see that there are a total of $144$ unique cubes after identifying rotations and reflections. Summing the second row, we see that there are $82$ cubes that have exactly one connected component of which we know $4$ are planar and one is the complete cube.
![]() |
All $82$ connected cubes identifying reflections and rotations |
Clear["Global`*"];
vertexcoordinates = {1 -> {-1, -1, -1}, 2 -> {1, -1, -1}, 3 -> {1, 1, -1}, 4 -> {-1, 1, -1},
5 -> {-1, -1, 1}, 6 -> {1, -1, 1}, 7 -> {1, 1, 1}, 8 -> {-1, 1, 1}};
cubegraph = {UndirectedEdge[1, 2], UndirectedEdge[2, 3], UndirectedEdge[1, 4], UndirectedEdge[3, 4],
UndirectedEdge[1, 5], UndirectedEdge[2, 6], UndirectedEdge[5, 6], UndirectedEdge[3, 7],
UndirectedEdge[6, 7], UndirectedEdge[4, 8], UndirectedEdge[5, 8], UndirectedEdge[7, 8]};
ReOrderGraph[g0_] := Module[{g = g0, temp},
temp = Table[UndirectedEdge[Min[First[k], Last[k]], Max[First[k], Last[k]]], {k, g}];
temp = SortBy[temp, {First, Last}];
temp
];
cubegraph = ReOrderGraph[cubegraph];
cubegraphsubsets = Subsets[cubegraph];
cubegraphsubsets = Rest[cubegraphsubsets];
RotateGraph[g0_, p0_] := Module[{g = g0, p = p0, res},
If[Length[g] <= 0, Return[{}];];
res = Table[UndirectedEdge[p[[First[k]]], p[[Last[k]]]], {k, g}];
res = ReOrderGraph[res];
res
];
cuberotations = {
{1, 2, 3, 4, 5, 6, 7, 8},
{2, 3, 4, 1, 6, 7, 8, 5},
{4, 1, 2, 3, 8, 5, 6, 7},
{5, 6, 2, 1, 8, 7, 3, 4},
{4, 3, 7, 8, 1, 2, 6, 5},
{5, 1, 4, 8, 6, 2, 3, 7},
{2, 6, 7, 3, 1, 5, 8, 4},
{3, 4, 1, 2, 7, 8, 5, 6},
{6, 5, 8, 7, 2, 1, 4, 3},
{8, 7, 6, 5, 4, 3, 2, 1},
{1, 4, 8, 5, 2, 3, 7, 6},
{1, 5, 6, 2, 4, 8, 7, 3},
{6, 2, 1, 5, 7, 3, 4, 8},
{3, 2, 6, 7, 4, 1, 5, 8},
{6, 7, 3, 2, 5, 8, 4, 1},
{8, 4, 3, 7, 5, 1, 2, 6},
{3, 7, 8, 4, 2, 6, 5, 1},
{8, 5, 1, 4, 7, 6, 2, 3},
{7, 3, 2, 6, 8, 4, 1, 5},
{5, 8, 7, 6, 1, 4, 3, 2},
{2, 1, 5, 6, 3, 4, 8, 7},
{4, 8, 5, 1, 3, 7, 6, 2},
{7, 6, 5, 8, 3, 2, 1, 4},
{7, 8, 4, 3, 6, 5, 1, 2}
};
isomorphcounts = Association[{}];
While[Length[cubegraphsubsets] > 0,
k = First[cubegraphsubsets];
temp = Table[RotateGraph[k, j], {j, cuberotations}];
temp = DeleteDuplicates[temp];
isomorphcounts[k] = Length[temp];
cubegraphsubsets = Complement[cubegraphsubsets, temp];
];
isomorphgraphedgelist = Keys[isomorphcounts];
graphcnt = Table[0, {5}, {13}];
graphcnt[[1, 1]] += 1;
Do[
graphcnt[[1 + Length[ConnectedComponents[k]], 1 + EdgeCount[k]]] += 1;
, {k, isomorphgraphedgelist}
];
graphcnt // MatrixForm
(* isomorphgraphs = Table[GraphPlot3D[k, VertexCoordinates -> vertexcoordinates, ViewProjection -> "Orthographic", VertexLabels -> "Name", Boxed -> True, PlotRange -> {{-17/16, 17/16}, {-17/16, 17/16}, {-17/16, 17/16}}], {k, isomorphgraphedgelist}]; *)
(* isomorphgraphs = Table[GraphPlot3D[k, VertexCoordinates -> vertexcoordinates, ViewProjection -> "Orthographic", Boxed -> False, PlotRange -> {{-17/16, 17/16}, {-17/16, 17/16}, {-17/16, 17/16}}], {k, isomorphgraphedgelist}]; *)
isomorphgraphs = Table[GraphPlot3D[k, VertexCoordinates -> vertexcoordinates, ViewProjection -> "Orthographic", Boxed -> True, BoxStyle -> Directive[Dashed, White], PlotRange -> {{-17/16, 17/16}, {-17/16, 17/16}, {-17/16, 17/16}}], {k, isomorphgraphedgelist}];
(* GraphicsGrid[Partition[isomorphgraphs, 15]] *)
(* GraphicsGrid[{Take[isomorphgraphs, {200, 202}]}] *)
(* Table[GraphPlot3D[k, VertexCoordinates -> vertexcoordinates, ViewProjection -> "Orthographic", VertexLabels -> "Name", Boxed -> True, PlotRange -> {{-17/16, 17/16}, {-17/16, 17/16}, {-17/16, 17/16}}], {k, Take[isomorphgraphedgelist, 140]}] *)
(* GraphPlot3D[isomorphgraphedgelist[[3]], VertexCoordinates -> vertexcoordinates, ViewProjection -> "Orthographic", VertexLabels -> "Name"] *)
(* GraphicsGrid[Partition[Take[isomorphgraphs, {200, 210}], 4]] *)
Take[isomorphgraphs, {200, 211}]
Second Version:
Clear["Global`*"];
vertexcoordinates = {1 -> {-1, -1, -1}, 2 -> {1, -1, -1}, 3 -> {1, 1, -1}, 4 -> {-1, 1, -1},
5 -> {-1, -1, 1}, 6 -> {1, -1, 1}, 7 -> {1, 1, 1}, 8 -> {-1, 1, 1}};
cubegraph = {UndirectedEdge[1, 2], UndirectedEdge[2, 3], UndirectedEdge[1, 4], UndirectedEdge[3, 4],
UndirectedEdge[1, 5], UndirectedEdge[2, 6], UndirectedEdge[5, 6], UndirectedEdge[3, 7],
UndirectedEdge[6, 7], UndirectedEdge[4, 8], UndirectedEdge[5, 8], UndirectedEdge[7, 8]};
ReOrderGraph[g0_] := Module[{g = g0, temp},
temp = Table[UndirectedEdge[Min[First[k], Last[k]], Max[First[k], Last[k]]], {k, g}];
temp = SortBy[temp, {First, Last}];
temp
];
cubegraph = ReOrderGraph[cubegraph];
cubegraphsubsets = Subsets[cubegraph];
cubegraphsubsets = Rest[cubegraphsubsets];
RotateGraph[g0_, p0_] := Module[{g = g0, p = p0, res},
If[Length[g] <= 0, Return[{}];];
res = Table[UndirectedEdge[p[[First[k]]], p[[Last[k]]]], {k, g}];
res = ReOrderGraph[res];
res
];
cuberotations = {
{1, 2, 3, 4, 5, 6, 7, 8},
{2, 3, 4, 1, 6, 7, 8, 5},
{4, 1, 2, 3, 8, 5, 6, 7},
{5, 6, 2, 1, 8, 7, 3, 4},
{4, 3, 7, 8, 1, 2, 6, 5},
{5, 1, 4, 8, 6, 2, 3, 7},
{2, 6, 7, 3, 1, 5, 8, 4},
{3, 4, 1, 2, 7, 8, 5, 6},
{6, 5, 8, 7, 2, 1, 4, 3},
{8, 7, 6, 5, 4, 3, 2, 1},
{1, 4, 8, 5, 2, 3, 7, 6},
{1, 5, 6, 2, 4, 8, 7, 3},
{6, 2, 1, 5, 7, 3, 4, 8},
{3, 2, 6, 7, 4, 1, 5, 8},
{6, 7, 3, 2, 5, 8, 4, 1},
{8, 4, 3, 7, 5, 1, 2, 6},
{3, 7, 8, 4, 2, 6, 5, 1},
{8, 5, 1, 4, 7, 6, 2, 3},
{7, 3, 2, 6, 8, 4, 1, 5},
{5, 8, 7, 6, 1, 4, 3, 2},
{2, 1, 5, 6, 3, 4, 8, 7},
{4, 8, 5, 1, 3, 7, 6, 2},
{7, 6, 5, 8, 3, 2, 1, 4},
{7, 8, 4, 3, 6, 5, 1, 2}
};
ReflectVertex[k_] := {7, 8, 5, 6, 3, 4, 1, 2}[[k]];
cubereflections = Table[Map[ReflectVertex, k], {k, cuberotations}];
cuberotations = Join[cuberotations, cubereflections];
isomorphcounts = Association[{}];
While[Length[cubegraphsubsets] > 0,
k = First[cubegraphsubsets];
temp = Table[RotateGraph[k, j], {j, cuberotations}];
temp = DeleteDuplicates[temp];
isomorphcounts[k] = Length[temp];
cubegraphsubsets = Complement[cubegraphsubsets, temp];
];
isomorphgraphedgelist = Keys[isomorphcounts];
graphcnt = Table[0, {5}, {13}];
graphcnt[[1, 1]] += 1;
Do[
graphcnt[[1 + Length[ConnectedComponents[k]], 1 + EdgeCount[k]]] += 1;
, {k, isomorphgraphedgelist}
];
graphcnt // MatrixForm
lewitts = Select[isomorphgraphedgelist, Length[ConnectedComponents[#]] == 1 &];
isomorphgraphs = Table[GraphPlot3D[k, VertexCoordinates -> vertexcoordinates, ViewProjection -> "Orthographic", Boxed -> True, BoxStyle -> Directive[Dashed, White], PlotRange -> {{-17/16, 17/16}, {-17/16, 17/16}, {-17/16, 17/16}}], {k, lewitts}];
isomorphgraphs
Yours Aye
Me