Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

NB: By higher-genus surface, I mean a closed orientable surface of genus at least 2.

This question has come up before on math.SE, and even MathOverflow, but most posters suggested using either Blender or Inkscape. However, I would like to draw these higher-genus surfaces in Mathematica, because I am trying to create a Manipulate which takes as input a word in the fundamental group of such a surface, and outputs the corresponding geodesic, drawn on the surface.

So, for example, let's say I am trying to draw a genus 2 surface. What I am doing now is the following:

torus = ParametricPlot3D[{(2 + Cos[s]) Cos[t], (2 + Cos[s]) Sin[t], 
Sin[s]}, {t, 0, 2 Pi}, {s, 0, 2 Pi}, Mesh -> None, Axes -> False, 
Boxed -> False, PlotStyle -> Opacity[.3], 
RegionFunction -> Function[{x, y, z, u, v}, x < 2]];
antitorus = 
Graphics3D[
Translate[
GeometricTransformation[torus[[1]], 
ReflectionTransform[{1, 0, 0}, {2, 0, 0}]], {1, 0, 0}], 
Boxed -> False, Axes -> False];
bound = ParametricPlot3D[{{t, (2 + Cos[s]) Sqrt[
  1 - 4/((2 + Cos[s])^2)], 
Sin[s]}, {t, -(2 + Cos[s]) Sqrt[1 - 4/((2 + Cos[s])^2)], 
Sin[s]}}, {s, 0, 2 Pi}, {t, 2, 3}, PlotStyle -> {Opacity[.7]}, 
Axes -> False, Boxed -> False, Mesh -> None, PlotPoints -> 100];
Show[antitorus,torus,bound,Lighting->"Neutral"]

This gives me this (not-so-bad!) picture:

enter image description here

I am wondering what other methods there are for creating these surfaces, perhaps with a smoother finished product than the one I currently have.

And of course, ideally, I would eventually draw the two "building blocks" of all such surfaces, the once- and twice-punctured tori. Then I could dynamically build these surfaces on the fly...

share|improve this question
    
Presumably, your surface must be connected, too--otherwise there are some obvious and simple solutions :-). –  whuber Mar 8 '13 at 20:56
    
Does Stan Wagon's one-liner double torus look like the sort of thing you are looking for? ContourPlot3D[(x^4 - x^2 + y^2)^2 + 9 z^2 == .04, {x, -1.2, 1.2}, {y, -1, 1}, {z, -.4, .4}, PlotPoints -> 30, Boxed -> False, Axes -> False, ContourStyle -> Yellow] –  David Carraher Mar 8 '13 at 21:01
    
Stan Wagon's 2 double torus's can be found at blog.wolfram.com/2010/12/17/… –  David Carraher Mar 8 '13 at 21:07
add comment

4 Answers

up vote 15 down vote accepted

If you dig through Eric Weisstein notebook you can find this well parametrized version. I changed parameters and styles a bit to get closer to your shape.

With[{R = 1.2, r = 1/2, a = Sqrt[2]}, 
 ContourPlot3D[-a^2 + ((-r^2 + R^2)^2 - 
       2 (r^2 + R^2) ((-r - R + x)^2 + y^2) + 
       2 (-r^2 + R^2) z^2 + ((-r - R + x)^2 + y^2 + z^2)^2) ((-r^2 + 
         R^2)^2 - 2 (r^2 + R^2) ((r + R + x)^2 + y^2) + 
       2 (-r^2 + R^2) z^2 + ((r + R + x)^2 + y^2 + z^2)^2) == 
   0, {x, -2 (r + R), 2 (r + R)}, {y, -(r + R), (r + R)}, {z, -r - a, 
   r + a}, BoxRatios -> Automatic, PlotPoints -> 35, 
  MeshStyle -> Opacity[.2], 
  ContourStyle -> 
   Directive[Orange, Opacity[0.8], Specularity[White, 30]], 
  Boxed -> False, Axes -> False]]

enter image description here

OK digging through Eric Weisstein another notebook I figured a "tentative" generalization, - at least it works with n=3 or n=4. The rest needs more time (also look here):

torusImplicit[{x_, y_, z_}, R_, r_] = (x^2 + y^2 + z^2)^2 - 
   2 (R^2 + r^2) (x^2 + y^2) + 2 (R^2 - r^2) z^2 + (R^2 - r^2)^2;

build[n_] := 
  Module[{f, cp, polys, cartPolys, cartPolys1},(*implicit polynomial*)
   f = Product[
      torusImplicit[{x - 1.5 Cos[i 2 Pi/n], y - 1.5 Sin[i 2 Pi/n], z},
        1, 1/4], {i, 0, n - 1}] - 10;
   cp = ContourPlot3D[
     Evaluate[f == 0], {x, -3, 3}, {y, -3, 3}, {z, -1/2, 1/2}, 
     BoxRatios -> Automatic, PlotPoints -> 35, 
     MeshStyle -> Opacity[.2], 
     ContourStyle -> 
      Directive[Orange, Opacity[0.8], Specularity[White, 30]], 
     Boxed -> False, Axes -> False]];

build[3]

enter image description here

share|improve this answer
    
Oh this is pretty! –  Steve D Mar 8 '13 at 21:16
    
How hard would it be to generalize to higher genus? –  Steve D Mar 8 '13 at 21:18
    
@SteveD thx :P well i added some stuff about higher order –  Vitaliy Kaurov Mar 8 '13 at 21:40
    
Oh wow, the answers on this thread are incredible! –  Steve D Mar 8 '13 at 21:49
1  
As an alternative, if you replace f with f = Product[torusImplicit[{x - 2.35 i, y, z}, 1, 1/4], {i, 0, n - 1}] - 10, you get the holes in a line. –  Michael E2 Mar 9 '13 at 20:05
show 1 more comment

Quick and dirty: look at the boundary of a tubular neighborhood of a union of circles.

circle[x_, n_: 32] := {x + Cos[#], Sin[#], 0} & /@ Range[0, 2 \[Pi], 2 \[Pi]/n];
Graphics3D[Tube[circle[#, 72], .5] & /@ Range[-3, 3, 2], Boxed -> False]

Image

Space them approximately two units apart (using x) and keep their radii less than $1/2$.


For smooth surfaces--albeit at a price--we may subvert RegionPlot3D to do our work. It's a similar idea, only now we apply a 3D buffer to a circular skeleton rather than using tubular neighborhoods of fixed radius:

d[{x_, y_, z_}, x0_: 0] := Block[{u, v}, {u, v} = {x0, 0} + Normalize[{x - x0, y}]; 
  Norm[{u, v, 0} - {x, y, z}]^2];
RegionPlot3D[Min[d[{x, y, z}, #] & /@ Range[-2, 2, 2]] <= 1/2, {x, -4,4}, {y, -2,2}, {z, -2,2}, 
  BoxRatios -> {4, 2, 2}, Mesh -> None, PlotPoints -> 50, Boxed -> False, Axes -> False]

Genus 3

The argument x0 to d shifts the skeleton's center to x0 along the x-axis. Taking a contour of the shortest distance to a collection of circular skeletons does the job.

share|improve this answer
    
Set n to $4$ in circle[#, 4] to get an interesting version. –  whuber Mar 8 '13 at 21:10
    
This is a quick, nice way to do it. But the "joins" aren't very smooth. :) –  Steve D Mar 8 '13 at 21:18
1  
I'll get you smoother joins, Steve--just a minute. –  whuber Mar 8 '13 at 21:18
    
Oh, I wish I could upvote again for the smooth version! –  Steve D Mar 8 '13 at 21:34
    
Actually, if you do some algebraic manipulation of the smooth version, you will obtain a solution almost identical (if not identical) to that of Vitaliy Kaurov. That shows how solutions like his can readily be derived and why they do generalize--and how to generalize them. You can also have some fun here by modifying my function d to draw circles in arbitrary locations with arbitrary orientations: with that you can draw pictures to your heart's content, spacing and sizing the holes as you wish, twisting the figure, and so on. –  whuber Mar 8 '13 at 21:50
add comment

Here's a double torus by Stan Wagon from the 2010 one-liner competition

ContourPlot3D[(x^4 - x^2 + y^2)^2 + 9 z^2 == .04, {x, -1.2, 1.2}, {y, -1, 1}, {z, -.4, .4}]

Mathematica graphics

With Boxed, Axes, and Mesh set to False and the equation = .03.

enter image description here

share|improve this answer
    
I find this slightly ugly; it is not the usual, voluptuous double-torus I know and love. :) –  Steve D Mar 8 '13 at 21:17
    
I know what you mean. It will look slightly better without the mesh, but the shape is more like a bee-stung 8. –  David Carraher Mar 8 '13 at 21:52
add comment

The following pokes n holes in flattish blob:

genus[n_] := Module[{pts, fn},
  pts = If[n == 1, {0, 0}, 
    Table[2 {Cos[t], Sin[t]}, {t, 2 \[Pi]/n, 2 \[Pi], 2 \[Pi]/n}]];
  fn = 10 z^2 + 
    Total[Join[#/n, (2 + 2/n)/#] &[#.# &[{x, y} - #] & /@ pts]]; 
  ContourPlot3D[fn == 18, {x, -4, 4}, {y, -4, 4}, {z, -2.5, 2.5}, 
   Mesh -> None, ContourStyle -> Yellow, BoxRatios -> Automatic, 
   Boxed -> False, Axes -> False]
  ]

Array of genus 2,..,7 surfaces

Note: The expression fn is $10\,z^2$ plus the sum over all points pts of $k\,d^2 + l/d^2$, where $d$ is the distance to the point (dropping $z$ coordinates) and $k$, $l$ are coefficients depending on the number of holes $n$. The upshot is that the function goes to infinity at the vertical lines through the points and as $(x,y,z)$ moves away from the points.

With[{n = 1}, 
 10 z^2 + Total[Join[#/n, (2 + 2/n)/#] &[#.# &[{x, y} - #] & /@ {{a, b}}]]]

(* -> (-a + x)^2 + (-b + y)^2 + 4/((-a + x)^2 + (-b + y)^2) + 10 z^2 *)
share|improve this answer
    
+1 Creative and simple. –  whuber Mar 10 '13 at 5:49
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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