23
$\begingroup$

enter image description here

The above puzzle has been a recent source of amusement in my clique.

I decided to provide a visualization to motivate solution (here):

My code:

s[x_] := Piecewise[{{4 Mod[x, 3]/3, 
    EvenQ[Quotient[x, 3]]}, {4 Mod[x, 3]/3, True}}]
plot = Plot[s[x], {x, 0, 12}, ExclusionsStyle -> Dashed, 
  Epilog -> {{Green, Arrowheads[{-0.03, 0.03}], 
     Arrow[{{0, 0.1}, {3, 0.1}}], Text["3 cm", {1.5, 0.2}]}, {Purple, 
     Arrowheads[{-0.03, 0.03}], Text["4 cm", {3.7, 2}], 
     Arrow[{{3.2, 0}, {3.2, 4}}], Text["3 cm", {1.5, 0.2}]}, {Orange, 
     Arrowheads[{-0.03, 0.03}], Arrow[{{-0.2, 0}, {2.8, 4}}], 
     Text["5 cm", {1, 2.2}]}}, Frame -> True, 
  Background -> LightYellow, ImageSize -> 400];
r = 2./Pi;
tf[u_, v_, n_] := {u, n Cos[Pi r  v/(2 n)], n Sin[ Pi r v /(2 n)]};
dat = Table[{j, s[j]}, {j, 0, 2.9, 0.1}]~Join~
   Table[{j, s[j]}, {j, 3, 5.9, 0.1}]~Join~
   Table[{j, s[j]}, {j, 6, 8.9, 0.1}]~Join~
   Table[{j, s[j]}, {j, 9, 11.9, 0.1}];

culminating in:

Manipulate[
 Panel[Column[{Show[
     ParametricPlot3D[{u, a Cos[Pi r v/(2 a)] - a, 
       a Sin[Pi r v/(2 a)]}, {u, 0, 12}, {v, 0, 4}, Mesh -> False, 
      BoundaryStyle -> Red, PlotStyle -> Opacity[0.5]], 
     Graphics3D[{Blue, Thick, 
       Line /@ Map[{#[[1]], #[[2]] - a, #[[
            3]]} &, (tf[#1, #2, a] & @@@ # & /@ 
           Partition[dat, 10]), {2}]}], BoxRatios -> {1, 1, 1}, 
     Boxed -> False, Axes -> False, Background -> Black, 
     PlotRange -> {{0, 12}, {-5, 5}, {-5, 5}}, ImageSize -> 400], 
    plot}]], {a, r, 10}]

This does achieve the aim (I think). However, I would value correction or alternatives that improve things such as:

  • better ways to draw lines and curl plane into cylinder
  • smoother ways to deal with/speed flatter phase (can obviously vary step size)
  • using Tube for rope and texturing
  • combining the plot which has annotations referring to puzzle dimensions on the 3D plot (obviously could use texture).

Of course, if and when I get time to play I will, but I wondered whether this would be a fun contemplation for someone here.

$\endgroup$

2 Answers 2

29
$\begingroup$

Since you want the animation to have explanatory content, I thought it might be best to incorporate the explanatory 2D diagram into the 3D scene.

So I imagine the 2D plot as a "sticker" that can be put onto the cylinder, like a label on a bottle. That way, you can see the explanatory diagram itself wrap around the cylinder and become identical to the solution:

length = 12;
circumference = 4;
radius = circumference/(2 Pi);

s[x_] := Piecewise[{{4 Mod[x, 3]/3, 
    EvenQ[Quotient[x, 3]]}, {4 Mod[x, 3]/3, True}}]
plot = Plot[s[x], {x, 0, 12}, ExclusionsStyle -> Dashed, 
   Epilog -> {{Green, Arrowheads[{-0.03, 0.03}], 
      Arrow[{{0, 0.1}, {3, 0.1}}], Text["3 cm", {1.5, 0.2}]}, {Purple,
       Arrowheads[{-0.03, 0.03}], Text["4 cm", {3.7, 2}], 
      Arrow[{{3.2, 0}, {3.2, 4}}], Text["3 cm", {1.5, 0.2}]}, {Orange,
       Arrowheads[{-0.03, 0.03}], Arrow[{{-0.2, 0}, {2.8, 4}}], 
      Text["5 cm", {1, 2.2}]}}, Axes -> None, Frame -> None, 
   BaseStyle -> {Thick, Larger}, Background -> LightYellow, 
   ImageSize -> 400, AspectRatio -> circumference/length, 
   ImagePadding -> 0, PlotRangePadding -> 0, FrameTicks -> None];

openPrism[pts_List, h_] := Module[
  {bottoms, tops, surfacePoints, sidePoints, n},
  surfacePoints = Table[
    Map[PadRight[#, 3, height] &, pts], {height, {0, h}}];
  {bottoms, tops} = {Most[#], Rest[#]} &@surfacePoints;
  sidePoints = 
   Most@Flatten[{bottoms, RotateLeft[bottoms, {0, 1}], 
      RotateLeft[tops, {0, 1}], tops}, {{2, 3}, {1}}];
  n = Length[sidePoints];
  MapThread[
   Polygon[#1, VertexNormals -> (#1 - #2), 
     VertexTextureCoordinates -> #3] &,
   {sidePoints,
    Map[{0, 0, 1} # &, sidePoints, {2}],
    Table[{{i/n, 0}, {(i + 1)/n, 0}, {(i + 1)/n, 1}, {i/n, 1}}, {i, 0,
       n - 1}]
    }]
  ]

openCyl[{pt1_, pt2_}, r_, {θ1_, θ2_}, n_: 90] := 
 Module[{circle = 
    r Table[{Cos[ϕ], 
       Sin[ϕ]}, {ϕ, θ1, θ2, (θ2 - θ1)/n}], 
   h = EuclideanDistance[pt1, pt2]}, 
  GeometricTransformation[openPrism[circle, h], 
   Composition[TranslationTransform[pt1], 
    Quiet[Check[RotationTransform[{{0, 0, 1.}, pt2 - pt1}], 
      Identity]]]]]

img = Rasterize[Rotate[plot, 90 Degree], ImageSize -> 500];

Manipulate[
 With[{r = radius + x^2},
  Graphics3D[{{Opacity[.7], Specularity[White, 20], Darker[Red], 
     Cylinder[{{0, 0, -1}, {0, 0, 13}}, .99 radius]},
    {FaceForm[Texture[img], Gray], EdgeForm[], 
     openCyl[{{radius - r, 0, 0}, {radius - r, 0, 12}}, 
      r, {0, 2 Pi radius/r}]}}, Boxed -> False, 
   Lighting -> "Neutral", ViewPoint -> {4, -2, -4}, 
   ViewVertical -> {0, -1, 0}, SphericalRegion -> True]],
 {x, 0, 5}
 ]

animation

What I did here is modify another answer to How to add texture to solid Graphics3D object such as cylinder? in such a way that the cylinder can be open, by adding the ability to specify an angle interval.

The 2D diagram is rasterized and used as a Texture, inside FaceForm so that I can make the back of the label gray (you only see that if you do a 3D rotation - the ViewPoint by default is chosen so as to show only the front of the label).

Edit

In this animation, the wrapped label is created with the function

openCyl[{pt1, pt2}, r, {θ1, θ2}, n]

It creates a cylindrically warped polygon by extruding a circle segment of radius r beginning at polar angle θ1 and ending at polar angle θ2. The orientation and height of this partial cylinder is dictated by {pt1, pt2} which is a pair of three-dimensional points that form the beginning and end of the cylinder axis. The last argument n is optional and defines the number of polygons along the side wall.

Speed considerations

The Manipulate as defined above runs completely smoothly on my laptop with Mathematica version 8, but it's choppy in version 10. To make the animation more responsive if necessary, here are three methods:

The easiest speed improvement is to decrease the number of polygons in openCyl from its default value 90 to a smaller number, e.g., 30. This will still give a smooth display because openCyl creates the warped polygon with VertexNormals that allow the rendering engine to give the illusion of a smooth surface. With fewer polygons, the rendering speed goes up.

For any kind of animation involving only a single parameter (like the "wrapping stage" x here), Manipulate is usually overkill because Animate and ListAnimate allow you to explore a one-parameter family of plots equally well. When the drawing of each frame is sluggish, it's better to create the frames as a List beforehand, and then feed it into ListAnimate to do the actual animation of the pre-computed frames.

Another factor that can improve the responsiveness is to decrease the ImageSize in the texture img from 500 to a smaller value like 200. I chose a large ImageSize to get a smoothly rendered texture, but there's always a tradeoff between quality and speed.

$\endgroup$
3
  • $\begingroup$ Very nice indeed! $\endgroup$
    – chris
    Apr 26, 2015 at 19:22
  • $\begingroup$ @Jens thank you...I will wait a little but this is beautiful indeed...definitely upvote and likely accept $\endgroup$
    – ubpdqn
    Apr 27, 2015 at 0:30
  • $\begingroup$ @ubpdqn Thanks for the question - it gave me the idea to write a the openCyl function, and I think this may come in handy in other applications as well. $\endgroup$
    – Jens
    Apr 27, 2015 at 3:55
4
$\begingroup$
Show[
 Graphics3D[Cylinder[{{0, 0, 0}, {0, 0, 12}}, 2/π]],
 ParametricPlot3D[
  2/π {Cos[θ], Sin[θ], 3 θ/4}, 
  {θ, 0, 8 π} ,
  PlotStyle -> Red]]

enter image description here

$\endgroup$
2
  • $\begingroup$ Though this is correct for a cylinder of radius 1 and length 4 and could be adapted to the conditions of the puzzle it does not facilitate the insight for someone solving the puzzle...the point of my visualisation I already know the answer and it almost leaps from the graphic $\endgroup$
    – ubpdqn
    Apr 26, 2015 at 13:26
  • $\begingroup$ To be explicit using 4 Sqrt[9+16]= 20 cm $\endgroup$
    – ubpdqn
    Apr 26, 2015 at 13:28

Your Answer

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

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