[GIF] Going Nowhere (Sphere with loxodromic trajectories)

Posted 2 years ago
3464 Views
|
|
5 Total Likes
|
 Going NowhereThis uses the same basic code as Inner Light and Renewable Resource, though making use of the excellent suggestion of @Patrick Scheibe from the discussion on Interlock to use a compiled function for the inverse stereographic projection and rotation. The curved tubes in the animation are the trajectories of a loxodromic Möbius transformation of the Riemann sphere (as opposed to the purely hyperbolic Möbius transformations of Inner Light and Renewable Resource), corresponding to scaling and rotating the complex plane. Once the trajectories are built (using very small steps away from the poles where things are spread out, and relatively large scaling steps near the poles; hence the funny business with all the Joins), I'm just shining two lights, one from above and one from below, and then rotating everything.Here's the code: InverseStereo3D[{x_, y_}] := {2 x/(1 + x^2 + y^2), 2 y/(1 + x^2 + y^2), (1 - x^2 - y^2)/(1 + x^2 + y^2)}; InverseStereoC = Compile[{{r, _Real, 0}, {s, _Real, 0}, {θ, _Real, 0}}, #, Parallelization -> True, RuntimeAttributes -> {Listable}] &[InverseStereo3D[RotationTransform[π If[r < 1, r, -1/r] + s][ r {Cos[θ], Sin[θ]}]]] With[{n = 10, d = 1/50., m = 100, θ = 0., viewpoint = 100 {1, 0, 0}, cols = RGBColor /@ {"#00ADB5", "#FF5722", "#303841"}}, Manipulate[ Graphics3D[{Tube[#, .03] & /@ Table[InverseStereoC[r, s - t, θ], {s, 0, 2 π, 2 π/n}, {r, Join[Reverse@Join[Range[1, 10, d], Range[10, m, 1]], Join[Table[1/p, {p, 1 + d, 10, d}], Table[1/p, {p, 10, m, 1}]]]}]}, PlotRange -> 1.4, Boxed -> False, ImageSize -> 540, ViewPoint -> viewpoint, Background -> cols[[-1]], Lighting -> {{"Directional", cols[[1]], {0, 0, -2}}, {"Directional", cols[[2]], {0, 0, 2}}, {"Ambient", cols[[-1]], viewpoint}}], {t, 0, 2 π/n}] ]