17
$\begingroup$

A Seifert surface for the (3,4) torus knot is defined by the intersection of $S^3 \subset \mathbb{C}^2$ with the set $\arg(z^4-w^3)=0$. The boundary is at $z^4=w^3$ and this is the torus knot. Here is a picture of its stereographic projection into $\mathbb{R}^3$:

Seifert surface for (3,4) torus knot

If you replace $w\to e^{\frac{2\pi i}{3}}w$, this surface is unchanged. In the picture, the point in the middle gets mapped to the point at the top, the point at the top gets mapped to the point at the bottom, and the point at the bottom gets mapped to the point in the middle.

I want to use Mathematica to make a smooth animation of this happening. I've tried using ContourPlot3D and ParametricPlot3D but both produce surfaces that are joined up in a different way to the picture. I've also tried generating some random points on $S^3$, selecting those that satisfy $|\arg(z^4-w^3)|<\epsilon$ for a small $\epsilon$ and that does produce points looking like the picture. I've put the code for doing that at the bottom. If I use ListSurfacePlot3D instead of ListPointPlot3D, it gives the wrong picture. I can't believe this is the best Mathematica can do.

Explicit Definition of the Surface

The surface is the set of points $(z,w)\in \mathbb{C}^2$ such that

$|z|^2+|w|^2=1$ and $\arg(z^4-(e^{i\theta} w)^3)=0$,

where $\theta$ is a parameter that I want to vary for the animation. This surface is projected into $\mathbb{R}^3$ by stereographic projection

$f(z,w)=\left(\frac{\Re(z)}{1-\Im(w)},\frac{\Im(z)}{1-\Im(w)},\frac{\Re(w)}{1-\Im(w)}\right)$

Mathematica Code

  n = 100; ε = 0.01;

  R4pts = RandomVariate[
     MultinormalDistribution[ConstantArray[0, 4], IdentityMatrix[4]], 
     300000];

  S3pts = #/Norm[#] & /@ R4pts;

  R3proj[a_] = {x/(1 - w), y/(1 - w), z/(1 - w)} /. {x -> a[[1]], 
      y -> a[[2]], z -> a[[3]], w -> a[[4]]};

  complexify[
     a_] = {x + I y, z + I w} /. {x -> a[[1]], y -> a[[2]], 
      z -> a[[3]], w -> a[[4]]};

  C2pts = complexify /@ S3pts;

  C2ptsSel = 
    Select[C2pts, (Abs[
          Arg[z^4 - Exp[(I π)/2] w^3]] < ε) /. {z -> #[[
          1]], w -> #[[2]]} &];

  C2colours = Im[#[[2]]] & /@ C2ptsSel;

  realify[a_] = {x, y, z, w} /. {x -> Re[a[[1]]], y -> Im[a[[1]]], 
      z -> Re[a[[2]]], w -> Im[a[[2]]]};

  S3ptsSel = realify /@ C2ptsSel;

  R3pts = R3proj /@ S3ptsSel;

  ListPointPlot3D[{#} & /@ R3pts, 
   PlotRange -> {{-2, 2}, {-2, 2}, {-2, 2}}, 
   PlotStyle -> ((Hue[(# - Min[C2colours])/(
         Max[C2colours] - Min[C2colours])] &) /@ C2colours), 
   AspectRatio -> 1, ViewPoint -> {2, 1, 0.7}, ImageSize -> 400]

points on the Seifert surface

EDIT: The same code with ListSurfacePlot3D gives this picture: Fitted Surface

$\endgroup$
  • $\begingroup$ …i.e., $\Im\left(z^4-(w\exp(i\theta))^3\right)=0$? $\endgroup$ – J. M. is away Jun 30 '15 at 11:52
  • $\begingroup$ No, $\arg(X)=0$ means X is a positive real, not just a real number (at least in my convention). $\endgroup$ – octopus Jun 30 '15 at 16:26
  • $\begingroup$ Ah yes, that. Have you tried using e.g. the hyperspherical or Hopf parametrizations of the 3-sphere? $\endgroup$ – J. M. is away Jun 30 '15 at 16:27
  • $\begingroup$ I have tried something like that and Mathematica gave me a funny looking plot that was not smooth. I've tried lots of way to write the surface as explicitly as I can in coordinates on $\mathbb{R}^3$ and Mathematica doesn't seem to like any of them. I'm a mathematician, not a programmer. Maybe there is something I am missing. $\endgroup$ – octopus Jun 30 '15 at 16:32
  • $\begingroup$ You can pick values for z=r1*exp(i*theta1) with r1<1 and then use the two equations to solve for w=r2*exp(i*theta2). That might make the point selection process easier at least. $\endgroup$ – Daniel Lichtblau Jul 2 '15 at 16:55
16
+100
$\begingroup$

Suppose you have a set of points $S=\{a\in A:f(a)=0\}$ lying in some abstract space $A$. To visualize it, you consider a map $g:A\to\mathbb R^3$, and you wish to draw $g(S)$, the image of your set under $g$. If $g$ is invertible, this is the same as drawing the set $\{x\in\mathbb R^3:f(g^{-1}(x))=0\}$, and ContourPlot3D can do that.

In your case, $A=\mathbb S^3$, $f(a)=\arg(a_1^4-a_2^3)=\arg(\phi(a))$, and $g$ is stereographic projection, which you call R3proj. Let us define $g^{-1}$:

s4proj[{x_, y_, z_}] := 
 Evaluate[{a, b, c, d} /. 
   First@Solve[{R3proj[{a, b, c, d}] == {x, y, z}, 
      a^2 + b^2 + c^2 + d^2 == 1}, {a, b, c, d}]]

This results in the usual formula for the inverse of stereographic projection, $$g^{-1}([x,\ y,\ z])=\frac{[2 x,\ 2 y,\ 2 z,\ x^2+y^2+z^2-1]}{x^2+y^2+z^2+1}.$$

Let us also define $\phi$ explicitly:

ϕ[z_, w_] := z^4 - I w^3 (* what your example code is actually doing *)

Recall that we want to plot $\arg\circ\phi\circ g^{-1}=0$. Unfortunately, $\arg$ has a branch cut along the negative real axis, which will confuse ContourPlot3D. To plot $\arg=0$, it is better to use the conditions $\Im=0,\Re\ge0$ instead.

ϕginv[x_, y_, z_] := ϕ @@ complexify[s4proj[{x, y, z}]]
ContourPlot3D[
 Im[ϕginv[x, y, z]] == 0, {x, -2, 2}, {y, -2, 2}, {z, -2, 2}, 
 RegionFunction -> Function[{x, y, z}, Re[ϕginv[x, y, z]] >= 0], 
 Evaluated -> True, ViewPoint -> {2, 1, 0.7}, PlotPoints -> 10, 
 MaxRecursion -> 1, ContourStyle -> White, Mesh -> None]

enter image description here

The surface you desire extends beyond the bounds of your chosen PlotRange, it seems.

$\endgroup$
  • $\begingroup$ Blah, it was the RegionFunction that I missed in my attempts. Nice work! $\endgroup$ – J. M. is away Jul 4 '15 at 2:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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