# Visualising 'The Moessner Miracle' in higher dimensions

I thought it would be interesting to try and represent "The Moessner Miracle" in higher dimensions. This is my first attempt for higher dimensions anywhere so I'm not sure if the logic is correct.

The principles are explained nicely here

The 3D case

Table[1, 15]
Accumulate[%]
Accumulate[Drop[%, {3, Length[%], 3}]]

out[]:
{1,1,1,1,1,1,1,1,1,1,1,1,1,1,1}
{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}
{1,3,7,12,19,27,37,48,61,75}


We can visualise using:

ListAnimate[
Show[{{Graphics3D[Cuboid[#]] & /@ Tuples[Range[0, #], 3]}}] & /@
Range[5]]


The 4D case

The individual cubes don't seem to behave as the 3D, each being made of increasing number of cubes

ListAnimate[Show[{
{Graphics3D[
Cuboid[#]] & /@ (Map[# + {#[[-1]], #[[-1]], #[[-1]], 0} &,
Tuples[Range[0, #], 4], {1}][[All, ;; 3]]*2 #)}
}] & /@ Range[5]]


The 5D case

I'm not sure if I can change tact in higher dimensions, although for the 5th, I hoped to have an increasing speed with the cubes orbiting their original position




I thought maybe it could rotate with increasing speed, couldn't figure it out

Warning can take a while to run:

ListAnimate[Show[{
{Graphics3D[
GeometricTransformation[Cuboid[#],
RotationTransform[
Pi/Length[Tuples[Range[0, 1], 4]], {1, 1,
1}]]] & /@ (Map[# + {#[[-1]], #[[-1]], #[[-1]], 0} &,
Tuples[Range[0, #], 4], {1}][[All, ;; 3]]*2 #)}
}] & /@ Range[5]]


Update

3D -> 4D -> 5D (ish)

It's a little hard to see & the speed doesn't change with the 5D pattern. Reaching the limit of my PC, thought it would be interesting if with the 4D distribution there was some form of ripple pattern as the speed increases and cubes multiply

(*Accumulate[Drop[%,{5,Length[%],5}]] *)
Accumulate[Drop[%, {4, Length[%], 4}]]
Accumulate[Drop[%, {3, Length[%], 3}]]
a0 = Accumulate[Drop[%, {2, Length[%], 2}]]

i0=Append[1]/@CirclePoints[x0[[1,1,;;2]],2,50]//N;

Table[Show[Table[{Graphics3D[Cuboid[(#+n)*i0[[i]]],Boxed->False]&/@Tuples[Range[0,#],3]},{n,1,2*a0[[#]],5}]]&/@{1,2,3},{i,Length[i0]}];
Transpose@%;
d5=Join[%[[1]],%[[2]],%[[3]]];

• Very nice video; it made my day! Thank you very much! (+1) Jul 28, 2021 at 10:23
• @HenrikSchumacher "Very nice, very nice, very nice" (in a German accent) Jul 30, 2021 at 13:34