[GIF] Reveal (The torus in relief)

Staff Picks
, , ,
1

torus16c.gif

Reveal

A rather different way of producing cross sections . Here a bunch of parallel lines starting at z=1 and z=-1 move towards the xy-plane, getting hung up on a torus of revolution as they go. The end result is a bunch of cross sections of the torus, now realized as a sort of relief.

Here’s the (super-slow) code, which could undoubtedly be streamlined:

?[s_] := 2 + Cos[s]; ?[s_] := Sin[s];

DynamicModule[{torus, cols, r, s},
 torus[x_, 
   y_] := {?[v] Cos[u], ?[v] Sin[u], ?[v]} /. {u -> 
     ArcTan[x, y], v -> ArcCos[Sqrt[x^2 + y^2] - 2]};
 cols = RGBColor /@ {"#5FC9F3", "#081F37"};
 r = 2.7;
 Manipulate[
  s = 1/2 + 1/2 Cos[?]; 
  ParametricPlot3D[
   Table[{x, y, 
     If[1 < x^2 + y^2 < 9, i Max[s, torus[x, y][[3]]], i s]}, {i, {-1,
       1}}, {x, -4.5, 4.5, 1/4}], {y, -4, 4}, 
   PlotStyle -> Directive[Thickness[.003], cols[[1]]], 
   PlotRange -> {{-4.5, 4.5}, {-4.5, 4.5}, {-1.5, 1.5}}, 
   PlotPoints -> 200, Boxed -> False, Axes -> None, 
   ViewPoint -> 100 {1, 0, r}, 
   ViewAngle -> ?/(4*100*Sqrt[1 + r^2]), ImageSize -> 540, 
   Background -> cols[[2]]], {?, 0, ?}]]
5 Likes
[GIF] Separation Anxiety (Level sets of the torus)
2

Clayton, this is a cool animation, I really like the approach.

But the code with the Dynamic and Manipulate ran so slow that I couldn’t even see an animation.

When I try to make a plot for just a single value of theta, it takes about 10 seconds on my machine. I was able to get this to about half a second by simplifying the plotted function and compiling it. It was still too slow for Manipulate in my opinion, so I made a list of images before plotting

funcsc = Compile[{{th, _Real}, {y, _Real}},
   Evaluate@Table[
     With[{x = x, i = i, s = 1/2 + 1/2 Cos[th]},
      {x, y,  
       If[1 < x^2 + y^2 < 9, 
        i Max[s, Sin[ArcCos[Sqrt[x^2 + y^2] - 2]]], i s]}], {i, -1, 
      1}, {x, -4.5, 4.5, 1/4}]
   ];
cols = RGBColor /@ {"#5FC9F3", "#081F37"};
r = 2.7; 
imglist = Table[ParametricPlot3D[funcsc[?, y]
        , {y, -4, 4}, 
        PlotStyle -> Directive[Thickness[.003], cols[[1]]], 
        PlotRange -> {{-4.5, 4.5}, {-4.5, 4.5}, {-1.5, 1.5}}, 
        PlotPoints -> 100, Boxed -> False, Axes -> None, 
        ViewPoint -> 100 {1, 0, r}, 
        ViewAngle -> ?/(4*100*Sqrt[1 + r^2]), ImageSize -> 540, 
        Background -> cols[[2]]], {?, 0, 
     2 ?, .1}];~Monitor~?

torus2.gif

4 Likes
3

@Jason Biggs Ah, yes, compiling the function is smart. One quibble with your definition: you have an extraneous i=0 row in the table that just produces straight lines sitting at z=0. So I would define funcsc like this:

funcsc = Compile[{{th, _Real}, {y, _Real}}, 
   Evaluate@
    Table[With[{x = x, i = i, s = 1/2 + 1/2 Cos[th]}, {x, y, 
       If[1 < x^2 + y^2 < 9, 
        i Max[s, Sin[ArcCos[Sqrt[x^2 + y^2] - 2]]], i s]}], {i, {-1, 
       1}}, {x, -4.5, 4.5, 1/4}]];

But otherwise, your code is definitely faster, which would have come in handy when I was rendering the GIF last night.

4

2015-11-02_10-07-11.png

  • another post of yours has been selected for the Staff Picks group, congratulations !

We are happy to see you at the tops of the “Featured Contributor” board. Thank you for your wonderful contributions, and please keep them coming!

5

@Moderation Team Cool, thanks!