46
$\begingroup$

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

ssch's random polyhedra random walk

This is my best attempt so far:

Pickett's random polyhedra walk

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.

$\endgroup$
  • 1
    $\begingroup$ Certainly one of the most beautyful questions I have ever seen here. I cannot answer it, that's for sure. $\endgroup$ – eldo Apr 5 '15 at 15:59
  • 1
    $\begingroup$ 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 $\endgroup$ – David G. Stork Apr 5 '15 at 16:09
  • $\begingroup$ 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? $\endgroup$ – penguin77 Apr 5 '15 at 16:10
  • $\begingroup$ 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' $\endgroup$ – k_v Apr 5 '15 at 16:10
  • $\begingroup$ @penguin77 Please report any issues with downloading the code here. $\endgroup$ – C. E. Apr 5 '15 at 16:19
38
$\begingroup$

enter image description here

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
     ]
    

    enter image description here


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[
       {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;
    )
  ]
$\endgroup$
  • $\begingroup$ Amazing, thank you! $\endgroup$ – C. E. Apr 11 '15 at 22:10
  • $\begingroup$ @Pickett Thanks ;) If you have any quesitons/suggestions/wishes, don't hesitate. $\endgroup$ – Kuba Apr 11 '15 at 22:13
  • $\begingroup$ Found this through a post in community.wolfram.com. Really nice! $\endgroup$ – Anton Antonov May 1 '16 at 14:44
  • $\begingroup$ @AntonAntonov Thanks! that's flattering :) I could've made this more compact but I had chosen readability for readers sake, and to mask imperfections :P $\endgroup$ – Kuba May 11 '16 at 7:09

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.