Mathematica Stack Exchange is a question and answer site for users of Mathematica. Join them; it only takes a minute:

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

This is a question based on this answer by halirutan.

Some amazing images can be created with this code, and I was wondering whether it was possible to extend the principle to different shapes.

I would like to create images based on the sculptures of Naum Gabo & Barbara Hepworth as shown below:

Below is an image made with halirutan's code, included to clarify the similarity:

x = 50; drawMe@Table[Mod[i, x], {i, E x}]

My question is threefold really. Is it possible to :

  • extend this principle to other shapes?
  • extend this to 3D?
  • distort the shapes with a mesh distort or similar (see image below)?
  • share|improve this question
    I think this is not related to Graph as you're never using any of the non-trivial layout algorithms. I'd draw these using Graphics primitives only, not Graph. – Szabolcs Mar 27 '14 at 15:15
    OK - title changed accordingly – martin Mar 27 '14 at 15:17
    New mesh-based geometry might be useful. – István Zachar Mar 27 '14 at 20:25
    What version does this work on? Can't seem to get anything from it :/ – martin Mar 27 '14 at 22:00
    Just seen - version 10 – martin Mar 27 '14 at 22:14
    up vote 20 down vote accepted

    I think you should not be looking at Graph, which is for graph plotting. This is really a graphics question.

    Looking at your example, I see one or more curves split into (equal?) segments, and then the division points connected with straight lines.

    So we can base this on this answer (please check there for the code).

    After dividing a single curve into 150 segments (using the referenced answer, just change the /20 to /150 in the Table's step size), I can get the actual division points:

    pts = fun /@ times;

    Find a nice way to connect them:

     Graphics3D@Line@Transpose[{pts, RotateLeft[pts, shift]}],
     {shift, 1, Length[pts] - 1, 1}

    And obtain figures like this:

     ParametricPlot3D[fun[t], {t, 0, 2 Pi}, PlotStyle -> Black],
     Graphics3D@Line@Transpose[{pts, RotateLeft[pts, 96]}],
     Boxed -> False, Axes -> False

    share|improve this answer
    Beautiful! Also pts for fun times! – Jacob Akkerboom Mar 27 '14 at 21:36
    @ Szabolcs, this is really great - beautiful indeed! I had a look at the evenly spaced points on a curve previously, but was unable to even come close (hence not posting!) - thanks again - will have a go at playing around with your code now :) – martin Mar 27 '14 at 21:42
    @martin I didn't copy that code over here, but just ask if you have trouble with it! – Szabolcs Mar 27 '14 at 21:47
    No trouble at all - beautiful - really beautiful! :) – martin Mar 27 '14 at 21:48
    Nice work! We need some color and opacity for fun :) – s.s.o Mar 27 '14 at 22:01

    A highly related concept would be envelope. Ruled surface could be a possible generalization to 3D. A simple way to find a family of lines given thier envelope curve is to use its tangent line family.

    Example 1:

    Suppose we have a curve describe in parameter u:

    pt = {Cos[u/2] Cos[u], Cos[u/2] Sin[u], .8 Sin[u]};
    ParametricPlot3D[pt, {u, 0, 4 π}]

    target curve

    So its tangent vector at point u can be obtained by:

    tang = #/Sqrt[#.#] &@D[pt, u];

    and the corresponding tangent line (with length 10 on both sides):

    tangline = pt + tang # & /@ {-2, 2};

    Draw the tangent lines at different u should give us a primary result:

          Map[NLimit[#, u -> udis] &, tangline, {2}],
          {udis, Rescale[Range[200], {1, 200}, {0, 4 π}]}
         ] //
       Graphics3D[{Line[#], Line[#[[All, 2]]], Line[#[[All, 1]]]}] &

    result envelope

    This should work for 2D curves, too.


    Another approach (which is basically the same method with Szabolcs), where the boundary line(s) is(are) given and the envelope is to be determined, is to draw segment between two points on boundary line(s). While the endpoints travel on boundary line(s) continuously and smoothly, the corresponding segment will travel continuously and smoothly in the 3D space, leaving an envelope (which in general is not a line as the above example, but a surface).

    Example 2:

    pt1 = {Sin[u], Cos[u] Sin[u], -Cos[u] Cos[u]};
    pt2 = {Cos[u/2] Cos[u], Cos[u/2] Sin[u], 1 + .5 Sin[2 u]};
    boarders = ParametricPlot3D[{pt1, pt2}, {u, 0, 4 π}, PlotStyle -> Directive[AbsoluteThickness[3], Brown]];
                   {pt1 /. u -> 2 π t, pt2 /. u -> 4 π t}
          {t, 0, 1, 1/200}] //
       Show[{Graphics3D[Line[#]], boarders}] &

    result envelope 2

    Example 3:

    boarders = ParametricPlot3D[pt2, {u, 0, 4 π}, PlotStyle -> Directive[AbsoluteThickness[3], Brown]];
                   {pt2 /. u -> 4 π t, pt2 /. u -> 4 π (t + (*shift*).4)}
          {t, 0, 1, 1/200}] //
       Show[{Graphics3D[Line[#]], boarders}] &

    result envelope 3

    share|improve this answer
    @ Silvia, this is great :) What is especially nice is that you can generate custom curves with this as opposed to using preexisting knot data. If the curves were closed, could the tangential lines join some other part of the curve (as in Szabolcs' answer)? – martin Mar 28 '14 at 9:57
    @martin I think because of the continuity and smoothness of the original line, the endpoints of the tangential lines will be surely on another continue and smooth curve. Please see my edit. – Silvia Mar 28 '14 at 11:13
    You can use Normalize for tangent versor. +1 ofc ;) – Kuba Mar 28 '14 at 11:24
    @Kuba Thanks. Normalize on symbolic expressions always introduces Abs, which makes me nervous :P – Silvia Mar 28 '14 at 11:26
    @Silvia Agree :) – Kuba Mar 28 '14 at 11:28

    I have made several pictures very similar to this, using code similar to the one below:

    MakePic[f_, g_, off_, nlines_, col_, dim_] := Module[{g1, cf, lines},
       g1 = ParametricPlot[{f[t], g[t + off]}, {t, 0, 2 Pi}, 
         AspectRatio -> 1, Axes -> None, 
         PlotStyle -> {{col, Thick, Opacity[0.2]}}];
       lines = Line@Table[{f[t], g[t + off]}, {t, 0, 2 Pi, 2 Pi/nlines}];
       Show[Graphics[{Opacity[0.2], col, lines}], g1, 
        Background -> Darker[col, 0.85], ImageSize -> dim]
    f[t_] := {2 Cos[t] - 3 Cos[4 t], Sin[t] - 4 Sin[t]};
    g[t_] := {3 Cos[3 t] - Cos[2 t] - 2, 2 Sin[t] - Sin[2 t] + 1};
    (*  600 is the number of lines... *)
    pic = 
     MakePic[f, g, 15.6, 600, RGBColor[0.8, 0.8, 1], {800, 600}]

    Here is a gallery on my personal webpage.

    enter image description here

    share|improve this answer
    +1 great :) I've added a picture from your gallery, hope you don't mind. – Kuba Mar 28 '14 at 20:12
    Thanks! Absolutely not, I was just a bit lazy to add it myself :) – Per Alexandersson Mar 28 '14 at 20:16
    +1 Very neatly done. Added here: – Vitaliy Kaurov Mar 28 '14 at 20:17
    Nice to have some colour! Reminds me of nylon stretched over wire frame (check out Vessna Perunovich's work) :) – martin Mar 28 '14 at 22:39
    Some really beautiful, ghostly images :) – martin Mar 28 '14 at 22:58

    Your Answer


    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.