10
$\begingroup$

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:

enter image description here

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

enter image description here

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

Made this mess:

enter image description here

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

enter image description here

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

enter image description here

(*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]]];
Improve this question
$\endgroup$
2
  • 4
    $\begingroup$ Very nice video; it made my day! Thank you very much! (+1) $\endgroup$
    – Henrik Schumacher
    Jul 28, 2021 at 10:23
  • 1
    $\begingroup$ @HenrikSchumacher "Very nice, very nice, very nice" (in a German accent) $\endgroup$
    – Chris K
    Jul 30, 2021 at 13:34

0

Reset to default

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.