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.

I am trying to draw a picture using Mathematica of three loops linking together in 3D as follows.

3D visualization

Module[{r = 0.03, col1, col2, col3}, {col1, col2, col3} = 
ColorData["HTML"] /@ {"Firebrick", "ForestGreen", "RoyalBlue"};
Graphics3D[{{{{col2, 
    Rotate[#, π/12, {0, 0, 1}, {0, 0, 0}]}, {col3, 
    Rotate[#, -π/12, {0, 0, 1}, {0, 0, 0}]}} &@
 Translate[
  Tube[Table[
    0.5 {Cos[θ], 0, Sin[θ]}, {θ, 0, 
     2 π, π/24}], r], {1, 0, 0}]}, {col1, 
Tube[Table[{Cos[θ], Sin[θ], 0}, {θ, 0, 
   2 π, π/24}], r]}},
ViewPoint -> {5, 0, 2}, Boxed -> False, Lighting -> "Neutral"]]

I used Graphics3D and Tube to draw the above picture. But I found that it is not easy to see which line is in front of which.

So then I use Graphics and Circle to draw the following 2D picture, in which the overlapping relation is represented by a small gap of the underlying line at the intersection.

2D visualization

Module[{col1, col2, col3},
{col1, col2, col3} = 
ColorData["HTML"] /@ {"Firebrick", "ForestGreen", "RoyalBlue"}; 
Graphics[{{col1, Circle[{0, 0}, {2, 1}]}, 
Translate[{{White, Disk[{-0.47, -0.08}, 0.15]}, col2, 
 Circle[{0, 0}, {0.5, 1}, {0.07 π, 1.97 π}]}, {0.6, -0.9}],
Translate[{{White, Disk[{-0.47, 0.12}, 0.15]}, col3, 
 Circle[{0, 0}, {0.5, 1}, {0.02 π, 
   1.92 π}]}, {-0.8, -0.9}]}]]

I think the 2D picture is nicer and can be saved as the vectorized image with a much smaller size compared to the 3D version. However I need to explicitly tell Mathematica where and how to break the lines.

My question is: is there a method to have Mathematica automatically draw links or knots in the 2D style with the underlying lines broken at the intersections.

share|improve this question
3  
Please share your code for the images, it might help people get started. –  Pickett May 20 at 7:01
    
If you need 3D figure, you can try making torus using ParametricPlot3D[] reference.wolfram.com/mathematica/ref/ParametricPlot3D.html use the third example and reduce the tube radius. –  Sumit May 20 at 8:46
    
I must agree with Pickett. It would be much easier to provide a useful answer if we knew your input. –  Mark McClure May 20 at 15:31

2 Answers 2

up vote 17 down vote accepted

For 3D curves, you can use an old trick sometimes used for toon-style rendering. Render each curve twice: once normally to show the curve itself; once thicker and in pure white, with only the backward-facing polygons drawn, creating an outline around the curve that occludes other curves passing behind it.

(P.S. The trick is called the two-pass method in Gooch et al.'s survey of silhouette algorithms.)

torusKnot[p_, q_, t_] := With[{r = Cos[q t] + 2}, {r Cos[p t], r Sin[p t], Sin[q t]}]
points = Table[torusKnot[2, 3, t], {t, 0, 2 π, 2 π/200}];
Graphics3D[{CapForm[None], 
  Lighter@Orange, Tube[points, 0.05], 
  FaceForm[None, Glow[White]], Tube[points, 0.15]}]

enter image description here

You can even rotate this interactively and the gaps still work.

(P.P.S. If you want a 2D flat-colour look, replace Lighter@Orange with Glow[Orange], Black.)

share|improve this answer

There must be a better way to do this, but...

Here's a 3D image of a trefoil knot

trefoil[t_] = {Sin[3 t], Sin[t] + 2 Sin[2 t], Cos[t] - 2 Cos[2 t]};
Show[ParametricPlot3D[trefoil[t],{t, 0, 2 Pi}, 
  ViewPoint -> {25, 0, 0}, Boxed -> False, Axes -> False] /. 
  Line[pts_] :>Tube[pts, 0.4], PlotRange -> All, ImageSize -> 500]

enter image description here

We get a plain plane image by projecting along the $x$-axis.

trefoil2d[t_] = {Sin[t] + 2 Sin[2 t], Cos[t] - 2 Cos[2 t]};
{plot2d, {ts}} = Reap[
  ParametricPlot[{Sin[t] + 2 Sin[2 t], Cos[t] - 2 Cos[2 t]},
   {t, 0, 2 Pi}, Axes -> False, EvaluationMonitor :> Sow[t], 
    ImageSize -> 500]];
ts = Sort[ts];
plot2d

enter image description here

Note that ts now contains the $t$ values used by ParametricPlot to generate the image.

ts // Short

(* Out: {0., 0.00192704, 0.00385407, <<1226>>, 6.27887, 6.28103, 6.28319} *)

We'll use these to manually construct a sequence of striped strips that create the effect you want. Here is such a striped strip expressed in terms of a time pair.

{xprime[t_], yprime[t_]} = trefoil2d'[t];
normal[t_] = {yprime[t], -xprime[t]};
normal[t_] = Simplify[normal[t]/Norm[normal[t]], Element[t, Reals]];
thickness = 0.1;
strip[{t1_, t2_}] := {
   {White, EdgeForm[White], Polygon[{
      trefoil2d[t1] + thickness*normal[t1],
      trefoil2d[t2] + thickness*normal[t2],
      trefoil2d[t2] - thickness*normal[t2],
      trefoil2d[t1] - thickness*normal[t1]}]},
   {Thickness[0.004], Line[{trefoil2d[t1], trefoil2d[t2]}]}};

Now, we lay those down sorted by the $x$ component of the 3D position

pointTimePairs = Table[{trefoil[ts[[i]]], {ts[[i]], ts[[i + 1]]}}, 
  {i, 1, Length[ts] - 1}];
xSortedTimes = Last /@ SortBy[pointTimePairs, #[[1, 1]] &];
Graphics[strip /@ xSortedTimes, ImageSize -> 500]

enter image description here

Perhaps, we can see what's going on a bit better by generating a shaded background, rather than a white background and creating an animation showing the order in which the pieces are laid down.

shadedStrip[{t1_, t2_}, {x_}] := {
   {GrayLevel[1 - x/(1.2 Length[xSortedTimes])], 
    EdgeForm[GrayLevel[1 - x/(1.2 Length[xSortedTimes])]], Polygon[{
      trefoil2d[t1] + thickness*normal[t1],
      trefoil2d[t2] + thickness*normal[t2],
      trefoil2d[t2] - thickness*normal[t2],
      trefoil2d[t1] - thickness*normal[t1]}]},
   {Thickness[0.004], Line[{trefoil2d[t1], trefoil2d[t2]}]}};
pic[n_] := Graphics[MapIndexed[shadedStrip, xSortedTimes[[1 ;; n]]],
  PlotRange -> {{-3, 3}, {-3.5, 2.5}}, ImageSize -> 500];
pics = Table[pic[n], {n, 1, Length[xSortedTimes], 30}];
pics = Join[pics, Table[Last[pics], {10}]];
Export["anim.gif", pics]

enter image description here

share|improve this answer
    
A nice general approach for 2D curves! But if I'm not mistaken, it doesn't take into account the under/over-ness of the original knot's crossings? –  Rahul Narain May 20 at 12:24
    
@RahulNarain Better? –  Mark McClure May 20 at 12:55
    
Looks good to me. Unfortunately I already gave you a +1. :) –  Rahul Narain May 20 at 13:03
    
You might do with fewer strips if you could compute the $t$ values of the crossings themselves and draw curve segments around them. I tried doing Solve[Rest@Thread[trefoil[t1] == trefoil[t2]], {t1, t2}] but it only gives the $t_1=t_2$ solution. –  Rahul Narain May 20 at 23:22
    
@RahulNarain We can find all the crossings as follows: N[{ToRules[Reduce[{trefoil2d[t1] == trefoil2d[t2], 0 < t1 < 2 Pi, 0 < t2 < 2 Pi, t1 < t2}, {t1, t2}]]}]. –  Mark McClure May 21 at 9:04

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.