Message Boards Message Boards

GROUPS:

[GIF] Inside (Stereographic projection of points on the Clifford torus)

Posted 10 months ago
2537 Views
|
1 Reply
|
6 Total Likes
|

Stereographic projection of points on the Clifford torus

Inside

The basic idea is simple: take $39^2=1521$ small spheres centered at points on the Clifford torus inside the 3-sphere, rotate in the $zw$-plane, and then stereographically project down to 3-space.

One could theoretically accomplish this with ParametricPlot3D[], but with so many spheres I strongly suspect the kernel would crash long before you could actually render it. So instead I had to figure out the following: given a 2-sphere of radius $r$ centered at a point $p$ in the 3-sphere, what is the center and radius of the resulting 2-sphere after stereographically projecting to $\mathbb{R}^3$.

To figure that out, define the stereographic projection map:

Stereo[{x1_, y1_, x2_, y2_}] := {x1/(1 - y2), y1/(1 - y2), x2/(1 - y2)}

And a function which gives an orthonormal basis for the orthogonal complement of a point in the 3-sphere:

ThreeSpherePointPerp[{x_, y_, z_, w_}] := {{-y, x, -w, z}, {-z, w, x, -y}, {-w, -z, y, x}};

(All this is doing is thinking of the point $p = (x,y,z,w)$ as a unit quaternion $q=x + i y + j z + k w$, and then multiplying on the left by $i$, $j$, and $k$, yielding $ip$, $jp$, and $kp$. Then $(p, ip, jp, kp)$ is guaranteed to be an orthonormal basis for $\mathbb{R}^4$, and in particular $(ip, jp, kp)$ is an orthonormal basis for $p^\bot$.)

Next, using spherical coordinates in $p^\bot$, we can define a sphere of radius $r$ centered at $p$:

ThreeSphereSphere[p_, r_, θ_, ϕ_] := 
  With[{b = ThreeSpherePointPerp[p]},
   Cos[r] p + Sin[r] (Cos[ϕ] Sin[θ] b[[1]] + Sin[ϕ] Sin[θ] b[[2]] + Cos[θ] b[[3]])
   ];

At this point, leaving $p$ and $r$ symbolic, I just found where the normal lines to two points on the stereographic projection of the above sphere intersected: this is the center of the projected sphere, and its distance from either of the two points is its radius. I then encoded that in the function ProjectedSphere[{x_, y_, z_, w_}, r_], which outputs a Sphere[] object of the appropriate center and radius (the definition is very long and slightly horrifying, so I've deferred it until the end of this post).

With all of that in place, then, here's the Manipulate for the above animation (which undoubtedly could be optimized):

With[{a = 39, b = 39, 
  cols = RGBColor /@ {"#1DCED8", "#F6490D", "#000249"}},
 Manipulate[
  Graphics3D[
   Table[
    ProjectedSphere[1/Sqrt[2] {Cos[θ + 2 π i/(3 a)], Sin[θ + 2 π i/(3 a)], Cos[2 π i/b + t], Sin[2 π i/b + t]}, .05],
    {θ, 0., 2 π - 2 π/a, 2 π/a}, {i, 0, b - 1}],
   PlotRange -> 3, ViewPoint -> {.38, 0, 0}, ViewAngle -> π/2, 
   ImageSize -> 540, Boxed -> False, Background -> cols[[-1]], 
   SphericalRegion -> True,
   Lighting -> {{"Point", cols[[1]], {0, 1, 0}}, {"Point", cols[[2]], {0, -1, 0}}}],
  {t, 0., 3*2 π/b}]
 ]

And, finally, here's the definition of ProjectedSphere. I'm sure there are various simplifications one could do to make this less intimidating, but I didn't have the patience to do much more than apply Simplify[] with some reasonable TimeConstraint.

ProjectedSphere[{x_, y_, z_, w_}, r_] := 
  Sphere[{(-2 x Cos[r] + Sqrt[2] (w + y) Sin[r])/(-2 + 2 w Cos[r] + 
      Sqrt[2] (x + z) Sin[
        r]) - (Sin[
         r]^2 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
          2] + (-w y - x z + y Cos[r])/Sqrt[2] + 
          x Sin[r]) (-((x Cos[r] - y Sin[r])/(
           1 - w Cos[r] - z Sin[r])) + (-2 x Cos[r] + 
           Sqrt[2] (w + y) Sin[r])/(-2 + 2 w Cos[r] + 
           Sqrt[2] (x + z) Sin[r])))/(Sqrt[
        2] (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
          2])^3 √((
           Sin[r]^4 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
              2] + (-w y - x z + y Cos[r])/Sqrt[2] + x Sin[r])^2)/(
           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
              2])^6) + (
           Sin[r]^4 ((w x - y z - x Cos[r])/Sqrt[2] - (
              x y + w z - z Cos[r])/Sqrt[2] + y Sin[r])^2)/(
           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
              2])^6) + (
           Sin[r]^4 ((-1 + x^2 + y^2 + w Cos[r])/Sqrt[
              2] - (-w y + x z + y Cos[r])/Sqrt[2] + z Sin[r])^2)/(
           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[

              2])^6)) (-((Sin[
                r]^2 (-w y - x z + y Cos[r] + x Sin[r]))/((-1 + 
                 w Cos[r] + 
                 z Sin[r])^3 √((
                  Sin[r]^4 (-w y - x z + y Cos[r] + x Sin[r])^2)/(-1 +
                     w Cos[r] + z Sin[r])^6 + (
                  Sin[r]^4 (w x - y z - x Cos[r] + y Sin[r])^2)/(-1 + 
                    w Cos[r] + z Sin[r])^6 + (
                  Sin[r]^4 (-1 + x^2 + y^2 + w Cos[r] + 
                    z Sin[r])^2)/(-1 + w Cos[r] + 
                    z Sin[r])^6))) + (Sin[
              r]^2 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
               2] + (-w y - x z + y Cos[r])/Sqrt[2] + 
               x Sin[r]))/(Sqrt[
             2] (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
               2])^3 √((
                Sin[r]^4 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
                   2] + (-w y - x z + y Cos[r])/Sqrt[2] + 
                   x Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6) + (
                Sin[r]^4 ((w x - y z - x Cos[r])/Sqrt[2] - (
                   x y + w z - z Cos[r])/Sqrt[2] + y Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6) + (
                Sin[r]^4 ((-1 + x^2 + y^2 + w Cos[r])/Sqrt[
                   2] - (-w y + x z + y Cos[r])/Sqrt[2] + 
                   z Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6))))), (
     y Cos[r] + (x/Sqrt[2] - z/Sqrt[2]) Sin[r])/(
     1 - w Cos[r] - (x/Sqrt[2] + z/Sqrt[2]) Sin[
        r]) - (Sin[
         r]^2 ((w x - y z - x Cos[r])/Sqrt[2] - (
          x y + w z - z Cos[r])/Sqrt[2] + 
          y Sin[r]) (-((x Cos[r] - y Sin[r])/(
           1 - w Cos[r] - z Sin[r])) + (-2 x Cos[r] + 
           Sqrt[2] (w + y) Sin[r])/(-2 + 2 w Cos[r] + 
           Sqrt[2] (x + z) Sin[r])))/(Sqrt[
        2] (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
          2])^3 √((
           Sin[r]^4 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
              2] + (-w y - x z + y Cos[r])/Sqrt[2] + x Sin[r])^2)/(
           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
              2])^6) + (
           Sin[r]^4 ((w x - y z - x Cos[r])/Sqrt[2] - (
              x y + w z - z Cos[r])/Sqrt[2] + y Sin[r])^2)/(
           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
              2])^6) + (
           Sin[r]^4 ((-1 + x^2 + y^2 + w Cos[r])/Sqrt[
              2] - (-w y + x z + y Cos[r])/Sqrt[2] + z Sin[r])^2)/(

           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
              2])^6)) (-((Sin[
                r]^2 (-w y - x z + y Cos[r] + x Sin[r]))/((-1 + 
                 w Cos[r] + 
                 z Sin[r])^3 √((
                  Sin[r]^4 (-w y - x z + y Cos[r] + x Sin[r])^2)/(-1 +
                     w Cos[r] + z Sin[r])^6 + (
                  Sin[r]^4 (w x - y z - x Cos[r] + y Sin[r])^2)/(-1 + 
                    w Cos[r] + z Sin[r])^6 + (
                  Sin[r]^4 (-1 + x^2 + y^2 + w Cos[r] + 
                    z Sin[r])^2)/(-1 + w Cos[r] + 
                    z Sin[r])^6))) + (Sin[
              r]^2 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
               2] + (-w y - x z + y Cos[r])/Sqrt[2] + 
               x Sin[r]))/(Sqrt[
             2] (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
               2])^3 √((
                Sin[r]^4 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
                   2] + (-w y - x z + y Cos[r])/Sqrt[2] + 
                   x Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6) + (
                Sin[r]^4 ((w x - y z - x Cos[r])/Sqrt[2] - (
                   x y + w z - z Cos[r])/Sqrt[2] + y Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6) + (
                Sin[r]^4 ((-1 + x^2 + y^2 + w Cos[r])/Sqrt[
                   2] - (-w y + x z + y Cos[r])/Sqrt[2] + 
                   z Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6))))), (
     z Cos[r] + (-(w/Sqrt[2]) + y/Sqrt[2]) Sin[r])/(
     1 - w Cos[r] - (x/Sqrt[2] + z/Sqrt[2]) Sin[
        r]) - (Sin[
         r]^2 ((-1 + x^2 + y^2 + w Cos[r])/Sqrt[
          2] - (-w y + x z + y Cos[r])/Sqrt[2] + 
          z Sin[r]) (-((x Cos[r] - y Sin[r])/(
           1 - w Cos[r] - z Sin[r])) + (-2 x Cos[r] + 
           Sqrt[2] (w + y) Sin[r])/(-2 + 2 w Cos[r] + 
           Sqrt[2] (x + z) Sin[r])))/(Sqrt[
        2] (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
          2])^3 √((
           Sin[r]^4 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
              2] + (-w y - x z + y Cos[r])/Sqrt[2] + x Sin[r])^2)/(
           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
              2])^6) + (
           Sin[r]^4 ((w x - y z - x Cos[r])/Sqrt[2] - (
              x y + w z - z Cos[r])/Sqrt[2] + y Sin[r])^2)/(
           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
              2])^6) + (
           Sin[r]^4 ((-1 + x^2 + y^2 + w Cos[r])/Sqrt[
              2] - (-w y + x z + y Cos[r])/Sqrt[2] + z Sin[r])^2)/(
           2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
              2])^6)) (-((Sin[
                r]^2 (-w y - x z + y Cos[r] + x Sin[r]))/((-1 + 
                 w Cos[r] + 
                 z Sin[r])^3 √((
                  Sin[r]^4 (-w y - x z + y Cos[r] + x Sin[r])^2)/(-1 +
                     w Cos[r] + z Sin[r])^6 + (
                  Sin[r]^4 (w x - y z - x Cos[r] + y Sin[r])^2)/(-1 + 
                    w Cos[r] + z Sin[r])^6 + (
                  Sin[r]^4 (-1 + x^2 + y^2 + w Cos[r] + 
                    z Sin[r])^2)/(-1 + w Cos[r] + 
                    z Sin[r])^6))) + (Sin[
              r]^2 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
               2] + (-w y - x z + y Cos[r])/Sqrt[2] + 
               x Sin[r]))/(Sqrt[
             2] (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
               2])^3 √((
                Sin[r]^4 ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
                   2] + (-w y - x z + y Cos[r])/Sqrt[2] + 
                   x Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6) + (
                Sin[r]^4 ((w x - y z - x Cos[r])/Sqrt[2] - (
                   x y + w z - z Cos[r])/Sqrt[2] + y Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6) + (
                Sin[r]^4 ((-1 + x^2 + y^2 + w Cos[r])/Sqrt[
                   2] - (-w y + x z + y Cos[r])/Sqrt[2] + 
                   z Sin[r])^2)/(
                2 (-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/
                   Sqrt[2])^6)))))}, √(-((Csc[
           r]^4 (-2 + 2 w Cos[r] + 
            Sqrt[2] (x + z) Sin[
              r])^6 ((Sqrt[2] (-1 - w y + y^2 - x z + z^2) + 
              Sqrt[2] (w + y) Cos[r] + 
              2 x Sin[r])^2 + (Sqrt[2] (w (x - z) - y (x + z)) - 
              Sqrt[2] (x - z) Cos[r] + 2 y Sin[r])^2 + 
            4 ((-1 + x^2 + y^2 + w Cos[r])/Sqrt[
               2] - (-w y + x z + y Cos[r])/Sqrt[2] + z Sin[r])^2) ((
            x Cos[r] - y Sin[r])/(-1 + w Cos[r] + 
             z Sin[r]) + (-2 x Cos[r] + Sqrt[2] (w + y) Sin[r])/(-2 + 
             2 w Cos[r] + Sqrt[2] (x + z) Sin[r]))^2)/((-1 + 
            w Cos[r] + (x Sin[r])/Sqrt[2] + (z Sin[r])/Sqrt[
            2])^6 (-4 - 2 w^2 + x^2 - 2 w^2 x^2 - 2 x^4 + 4 y^2 - 
            4 w^2 y^2 - 6 x^2 y^2 - 4 y^4 - 6 x z + 4 w^2 x z + 
            4 x^3 z + 4 x y^2 z + z^2 - 2 w^2 z^2 - 4 x^2 z^2 - 
            6 y^2 z^2 + 4 x z^3 - 2 z^4 + 
            8 w Cos[r] + (-2 w^2 + (x + z)^2) Cos[2 r] + 
            4 Sqrt[2] x Sin[r] + 4 Sqrt[2] z Sin[r] - 
            2 Sqrt[2] w x Sin[2 r] - 
            2 Sqrt[2]
              w z Sin[
              2 r]) ((Sqrt[
               2] ((-1 + y^2 + z^2 + w Cos[r])/Sqrt[
                 2] + (-w y - x z + y Cos[r])/Sqrt[2] + 
                 x Sin[r]))/((-1 + w Cos[r] + (x Sin[r])/Sqrt[2] + (
                 z Sin[r])/Sqrt[
                 2])^3 √((Sin[
                    r]^4 (2 - 2 x^2 + w^2 x^2 + x^4 - 4 y^2 + 
                    2 w^2 y^2 + 3 x^2 y^2 + 2 y^4 + 4 x z - 
                    2 w^2 x z - 2 x^3 z - 2 x y^2 z - 2 z^2 + 
                    w^2 z^2 + 2 x^2 z^2 + 3 y^2 z^2 - 2 x z^3 + z^4 - 
                    4 w Cos[r] + 2 w^2 Cos[r]^2 + x^2 Cos[r]^2 + 
                    2 y^2 Cos[r]^2 - 2 x z Cos[r]^2 + z^2 Cos[r]^2 - 
                    2 Sqrt[2] x Sin[r] - 2 Sqrt[2] z Sin[r] + 
                    2 Sqrt[2] w x Cos[r] Sin[r] + 
                    2 Sqrt[2] w z Cos[r] Sin[r] + 2 x^2 Sin[r]^2 + 
                    2 y^2 Sin[r]^2 + 2 z^2 Sin[r]^2))/(-2 + 
                    2 w Cos[r] + Sqrt[2] x Sin[r] + 
                    Sqrt[2] z Sin[r])^6)) - (8 Sqrt[
               2] (-w y - x z + y Cos[r] + x Sin[r]))/((-1 + 
                 w Cos[r] + 
                 z Sin[r])^3 √((Sin[
                    r]^4 (2 + w^2 - 2 x^2 + 2 w^2 x^2 + 2 x^4 - 
                    2 y^2 + 2 w^2 y^2 + 4 x^2 y^2 + 2 y^4 + z^2 + 
                    2 x^2 z^2 + 2 y^2 z^2 - 
                    4 w Cos[r] + (w^2 - z^2) Cos[2 r] - 4 z Sin[r] + 
                    2 w z Sin[2 r]))/(-1 + w Cos[r] + 
                    z Sin[r])^6)))^2)))];

enter image description here - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming!

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract