Random polyhedra walk

Question

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"]["https://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.

Answer 1

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[
   PolyhedronData["DuerersSolid", "Faces"]
  ]
  

---

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

  polyhedronRandomWalk[
   PolyhedronData["DuerersSolid", "Faces"], "BottomInd" -> 1
   ]
  

---

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

  polyhedronRandomWalk[
   PolyhedronData["DuerersSolid", "Faces"], "PlaneMovement" -> False
   ]
  

  

---

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",
         task = 
          RunScheduledTask[t += .1; 
           If[t == 1, pts = transformation[1] /@ pts; 
            step[bottomface]; t = 0;];,
           .05],
         ImageSize -> 200],
        Button["Stop", StopScheduledTask[task], ImageSize -> 200],
        Button["Forget", RemoveScheduledTask[task]; traces = {}; 
         t = 0;, ImageSize -> 200]
        }]
      ,
      Graphics3D[
       {[email protected],
        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;
    )
  ]