51
$\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["https://tinyurl.com/2v9ph7hj"]["https://i.sstatic.net/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.

Improve this question
$\endgroup$
10
  • 2
    $\begingroup$ Certainly one of the most beautyful questions I have ever seen here. I cannot answer it, that's for sure. $\endgroup$ Commented Apr 5, 2015 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$ Commented Apr 5, 2015 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$ Commented Apr 5, 2015 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$ Commented Apr 5, 2015 at 16:10
  • $\begingroup$ @penguin77 Please report any issues with downloading the code here. $\endgroup$ Commented Apr 5, 2015 at 16:19

1 Answer 1

Reset to default
46
$\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[ {[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; ) ]
Improve this answer
$\endgroup$
3
  • $\begingroup$ @Pickett Thanks ;) If you have any quesitons/suggestions/wishes, don't hesitate. $\endgroup$ Commented Apr 11, 2015 at 22:13
  • $\begingroup$ Found this through a post in community.wolfram.com. Really nice! $\endgroup$ Commented May 1, 2016 at 14:44
  • 1
    $\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$ Commented May 11, 2016 at 7:09

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.