# Rotating stacks of cubes

I've created a function that takes a list of stack heights and returns a stack of cubes:

visualize[toR_, t_] := (arr = Sort[toR, Greater];
orTh = Flatten[
Map[Table[{Flatten[Position[arr, #]][], 0, n}, {n, 1, #}] &,
arr], 1];
Graphics3D[Map[Cuboid[#] &, orTh], Boxed -> False])
visualize[{5,3,1}] Now I want to "visualize" them doing two things, according to some timestep $t$:

• The bottom row of cubes sliding to the left $1$
• The entire bottom row "pivoting" around the first cube and swinging up to become the new first column.

I can model the first fine:

visualizeROFE[toR_, t_] := (arr = Sort[toR, Greater];
orTh = Flatten[
Map[Table[{If[ n == 1, Flatten[Position[arr, #]][] - t,
Flatten[Position[arr, #]][]], 0, n}, {n, 1, #}] &, arr],
1];
Graphics3D[Map[Cuboid[#] &, orTh], Boxed -> False])


But the second I'm having trouble with. My initial idea was to model the stack as two Graphics3D objects, one for the bottom row and one for the rest, and I can do that, but I can't seem to get the rotation right:

visualizeROFE[toR_, t_] := (arr = Sort[toR, Greater];
orTh = Flatten[
Map[Table[{Flatten[Position[arr, #]][], 0, n}, {n, 1, #}] &,
arr], 1];
nTh = Select[orTh, #[] == 1 &];
orTh = DeleteCases[orTh, Alternatives @@ nTh];
nGraph =
Graphics3D[
Rotate[Graphics3D[Map[Cuboid[#] &, nTh]][],
t Degree, {1, 0, 0}, nTh[]]];
Show[{nGraph, Graphics3D[Map[Cuboid[#] &, orTh], Boxed -> False]}])


I believe what this Rotate is doing is rotating the bottom row along the x-axis with the first cube as a fixed point. But it definitely doesn't do this. How can I accomplish this fixed-pivot rotation?

Well, this was fun. Perhaps somewhat pointless, but fun nonetheless :-)

I started out by rewriting a function to generate the starting stack:

Clear[stack]
stack[heights_List] := Module[{sorted},
sorted = Reverse@Sort[heights];
Table[
Cuboid[{column, 0, startZ}],
{column, Length[heights]},
{startZ, Range[sorted[[column]]]}
] ~ Flatten ~ Length[heights]
]

cubes = stack[{2, 3, 5, 7, 1}];
Graphics3D[cubes, Boxed -> False]; I then used this code in a function that generates a series of "frames" for your animations. First the sliding left, then rotation, then sliding up. The function first focuses on the cubes that are actually moving and calculates the new objects. Finally, the moved cubes are joined with the stationary ones to generate each full frame, each as a Graphics3D object. That is what the rototranslate function returns.

ListAnimate can then be used to generate the actual animation from these frames. I chose to leave the animation part separate, rather than wrapping it into the generator function, to allow for finer external control.

Clear[rototranslate]
rototranslate[heights_List] := Module[
{sorted, cubes,
firstRow, others, firstColumn,
horizontalSliding, rotation, upsliding},

sorted = Reverse@Sort[heights];

cubes = Table[
Cuboid[{column, 0, startZ}],
{column, Length[heights]},
{startZ, Range[sorted[[column]]]}
] ~ Flatten ~ Length[heights];

firstRow = Cases[cubes, Cuboid[{_, 0, 1}]];
others = Complement[cubes, firstRow];

(* horizontal sliding *)
horizontalSliding =
Table[
firstRow /. Cuboid[{x_, 0, 1}] :> Cuboid[{x - translation, 0, 1}],
{translation, 0, 1, 0.01}
];

(* rotation *)
firstRow = Cases[Last@horizontalSliding, Cuboid[{x_, 0, 1}]];
rotation =
With[
{centerofFirstCube = RegionCentroid@First@firstRow},
Table[
GeometricTransformation[
#,
RotationTransform[-theta, {{1, 0, 0}, {0, 0, 1}}, centerofFirstCube]
] & /@ firstRow,
{theta, 0, Pi/2, Pi/200}
]
];

(* up sliding *)
firstColumn = Last@rotation;
upsliding =
Table[
GeometricTransformation[#, TranslationTransform[{0, 0, up}]] & /@ firstColumn,
{up, 0, Length[heights], 0.05}
];

(* build up the full show *)
With[{
g3D = (Graphics3D[#, Boxed -> False,
PlotRange -> {
{-1, Length[heights] + 1},
Automatic,
{-Length[heights] + 1, Max[Max[heights] + 1, Length[heights] + 1]}
}] &),
join = (Join[#, others] &)
},
Join[
g3D /@ (join /@ horizontalSliding),
g3D /@ (join /@ rotation),
g3D /@ (join /@ upsliding)
]
]
]


We can then use this function together with ListAnimate to generate the desired movements:

ListAnimate[
rototranslate[{3, 5, 2}],
AnimationRepetitions -> 1
] • Thank you very much! One question, I'm trying to edit your code to not automatically sort the cube stacks, but when I try to replace sorted=Reverse@Sort[heights]; with sorted=heights; I get very weird and wrong results. Do you have any idea why? – TreFox Jun 14 '18 at 19:10
• Try having sorted=heights and then ListAnimate[rototranslate[{3, 5, 1}]]. It still animates but the stack heights are off and it kind of morphs into itself at the end. – TreFox Jun 14 '18 at 19:48
• @TreFox I edited the code in the answer to include a better method to calculate the PlotRange. This should fix the weirdness you were observing. – MarcoB Jun 14 '18 at 20:08
• @TreFox Thank you for the accept! – MarcoB Jun 16 '18 at 16:01

This is just to show how you could make the parameter-dependent graphics you are looking for, not reproducing the exact path described in the OP.

Here I will take a single cube, and use GeometricTransformation to make 3 copies of it and have their position and rotation be determined by a single parameter.

cube = Cuboid[{-(1 / 2), -(1 / 2), -(1 / 2)},
{1 / 2, 1 / 2, 1 / 2}
];
path1[x_] := TranslationTransform @ {x, 0, Sin @ x};
path2[x_] := TranslationTransform[{5 * Sin[x], 5 * Cos[x], 0}];
path3[x_] := Composition[
TranslationTransform[{x + Sin[x], x + -Cos[x], x}],
RotationTransform[x, {1, 0, 0}]
]


To view the cubes at a certain parameter value, say 3,

Graphics3D[
GeometricTransformation[
cube,
{path1, path2, path3}
]
] This manipulate should give an idea of what you could do with GeometricTransformation and a list of paths,

Manipulate[
Graphics3D[
GeometricTransformation[cube, {path1 @ x, path2 @ x, path3 @ x}],
PlotRange -> {{-6, 15}, {-6, 15}, {-6, 15}}
],
{{x, 0}, 0, 20, 0.1}
] 