# Random polyhedra walk

I would like to recreate ssch's random polyhedra random walk, which he posted in the chat. For convenience here it is again:

This is my best attempt so far:

You can download the notebook with the code for this animation by running this code (problems? ask here):

Import["http://goo.gl/NaH6rM"]["http://i.stack.imgur.com/BNmSG.png"]


As you can see it's not a random polyhedra random walk like ssch's but a polyhedra random walk. It can only do regular faces and it is quite cumbersome to adapt the code to add more of them, as you will see this simple cube requires a lot of code already.

I would appreciate any answers with elegant implementations of a polyhedra random walk with more faces, and I would appreciate even more an implementation of a random polyhedra random walk as in ssch's animation.

• Certainly one of the most beautyful questions I have ever seen here. I cannot answer it, that's for sure.
– eldo
Apr 5 '15 at 15:59
• Wonderful question... beautiful, fascinating, and leads to so many interesting mathematical questions, such as average distance traversed, average distance from origin, etc., versus number of face-steps. +1 Apr 5 '15 at 16:09
• When trying to download I receive following error message: SEDecodeImage::hash: The security hash indicates that the data is corrupted. Can you help on this? Apr 5 '15 at 16:10
• I think the solution should be in object-oriented style containing 'polyhedron object' that includes information abought it's current state and some transition graph that says in which directions 'random step' is possible. 'random step' function to be responsible for changing the state of 'polyhedron object'
– k_v
Apr 5 '15 at 16:10

### Usage

• Just use this function with any polyhedron in in form:

GraphicsComplex[pts_, Polygon[vertices_, ___]].


When I find time and motivation maybe I will add more DownValues so it can be more general.

At the moment you can play with solids given by PolyhedronData[... "Faces"]:

polyhedronRandomWalk[
]


• It should automatically select the proper bottom face but if you want you can take any one you like:

polyhedronRandomWalk[
]


• You don't have to be restricted to the movement on one plane!

polyhedronRandomWalk[
]


### Code

It can be golfed down but I wanted to leave it more descriptive form. I can add some explanations if questions arise.

ClearAll[polyhedronRandomWalk];

Options[polyhedronRandomWalk] = {"BottomInd" -> Automatic,
"PlaneMovement" -> True};

polyhedronRandomWalk[
GraphicsComplex[vertices_, Polygon[indices_, ___]],
OptionsPattern[]
] := DynamicModule[{
pts, faces, bottomface, step, t, task, traces, transformation,
whichIsBottom
},

Panel@Grid[{{
Column[{
Button["Run",
If[t == 1, pts = transformation[1] /@ pts;
step[bottomface]; t = 0;];,
.05],
ImageSize -> 200],
t = 0;, ImageSize -> 200]
}]
,
Graphics3D[
{Opacity@.5,
Dynamic@
GraphicsComplex[transformation[t] /@ pts, Polygon[faces]],
Dynamic@traces

}
, PlotRange -> All, ImageSize -> {500, 500}
]
}
}, Alignment -> Top]
,
Initialization :> (
pts = N@vertices;
faces = indices;
whichIsBottom =
OptionValue["BottomInd"] /.
Automatic -> (Position[#, Min[#]] &[
Mean[pts[[#]][[;; , 3]]] & /@ faces][[1, 1]]);
bottomface = faces[[whichIsBottom]];
traces = {};
Print[bottomface];
SetAttributes[step, HoldFirst];

step[bottomface_] := Module[{pivot, nextface, nn, nb, angle},
traces =
Join[traces, {Hue@RandomReal[], Polygon@pts[[bottomface]]}];
pivot =
RandomChoice@Partition[bottomface, 2, 1, {1, 1}, bottomface];
nextface = Composition[
First,
DeleteCases[#, bottomface] &,
Select[#, Count[#, Alternatives @@ pivot] == 2 &] &
]@faces;

{nb, nn} = Function[{meanBF, meanP, pivotV, meanNF},
{
{meanP, meanP + # - Projection[#, pivotV - meanP]} &[
meanP - meanBF],
{meanP, meanP + # - Projection[#, pivotV - meanP]} &[
meanNF - meanP]
}
][
Mean@pts[[bottomface]],
Mean@pts[[pivot]],
pts[[First@pivot]],
Mean@pts[[nextface]]
];

angle = VectorAngle @@ (#2 - # & @@@ {nn, nb});

bottomface = If[
TrueQ@OptionValue["PlaneMovement"],
nextface,
Composition[
First,
Select[#, Length[Intersection[#, nextface]] == 2 &] &
]@faces
];

transformation[t_] :=
Evaluate@
RotationTransform[angle t, Cross @@ (#2 - # & @@@ {nn, nb}),
Mean@pts[[pivot]]];

];

step[bottomface];
t = 0;
)
]

• Amazing, thank you! Apr 11 '15 at 22:10
• @Pickett Thanks ;) If you have any quesitons/suggestions/wishes, don't hesitate.
– Kuba
Apr 11 '15 at 22:13
• Found this through a post in community.wolfram.com. Really nice! May 1 '16 at 14:44