# Creating sculptural forms using graphics primitives

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)?
• 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. Commented Mar 27, 2014 at 15:15
• OK - title changed accordingly Commented Mar 27, 2014 at 15:17
• New mesh-based geometry might be useful. Commented Mar 27, 2014 at 20:25
• What version does this work on? Can't seem to get anything from it :/ Commented Mar 27, 2014 at 22:00
• Just seen - version 10 Commented Mar 27, 2014 at 22:14

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:

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


And obtain figures like this:

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


• Beautiful! Also pts for fun times! Commented Mar 27, 2014 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 :) Commented Mar 27, 2014 at 21:42
• @martin I didn't copy that code over here, but just ask if you have trouble with it! Commented Mar 27, 2014 at 21:47
• No trouble at all - beautiful - really beautiful! :) Commented Mar 27, 2014 at 21:48
• Nice work! We need some color and opacity for fun :) Commented Mar 27, 2014 at 22:01

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.

• +1 great :) I've added a picture from your gallery, hope you don't mind.
– Kuba
Commented Mar 28, 2014 at 20:12
• Thanks! Absolutely not, I was just a bit lazy to add it myself :) Commented Mar 28, 2014 at 20:16
• +1 Very neatly done. Added here: pinterest.com/vitaliykaurov/wolfram-language Commented Mar 28, 2014 at 20:17
• Nice to have some colour! Reminds me of nylon stretched over wire frame (check out Vessna Perunovich's work) :) Commented Mar 28, 2014 at 22:39
• Some really beautiful, ghostly images :) Commented Mar 28, 2014 at 22:58

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 π}]


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:

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


This should work for 2D curves, too.

## Edit:

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]];

Table[Evaluate[
{pt1 /. u -> 2 π t, pt2 /. u -> 4 π t}
],
{t, 0, 1, 1/200}] //
Show[{Graphics3D[Line[#]], boarders}] &


Example 3:

boarders = ParametricPlot3D[pt2, {u, 0, 4 π}, PlotStyle -> Directive[AbsoluteThickness[3], Brown]];

Table[Evaluate[
{pt2 /. u -> 4 π t, pt2 /. u -> 4 π (t + (*shift*).4)}
],
{t, 0, 1, 1/200}] //
Show[{Graphics3D[Line[#]], boarders}] &


• @ 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)? Commented Mar 28, 2014 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. Commented Mar 28, 2014 at 11:13
• You can use Normalize for tangent versor. +1 ofc ;)
– Kuba
Commented Mar 28, 2014 at 11:24
• @Kuba Thanks. Normalize on symbolic expressions always introduces Abs, which makes me nervous :P Commented Mar 28, 2014 at 11:26
• @Silvia Agree :)
– Kuba
Commented Mar 28, 2014 at 11:28

Using pt1 and pt2 from Silvia's answer:

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]};


We can use a single ParametricPlot3D with the options MeshFunctions and Mesh and add the option Method -> {"BoundaryOffset" -> False} so that some mesh lines are not cut off.

pta = pt1 /. u -> 4 Pi u;
ptb = pt2 /. u -> 4 Pi u;

ParametricPlot3D[v ptb + (1 - v) pta,
{u, 0, 1}, {v, 0, 1},
PlotStyle -> FaceForm[],
Method -> {"BoundaryOffset" -> False},
MeshFunctions -> {#4 &, #5 &},
Mesh -> {200, Thread[{{0, 1}, Directive[Brown, Thick]}]},
MeshStyle -> Thin,
ImageSize -> Large, Axes -> False, Boxed -> False]


ParametricPlot3D[Evaluate[v ptb + (1 - v) (ptb /. u -> (u + .4))],
{u, 0, 1}, {v, 0, 1},
PlotStyle -> FaceForm[],
Method -> {"BoundaryOffset" -> False},
MeshFunctions -> {#4 &, #5 &},
Mesh -> {200, {{1, Directive[Brown, Thick]}}},
MeshStyle -> Thin, BoundaryStyle -> Thin,
ImageSize -> Large, Axes -> False, Boxed -> False]


Using Szabolcs' example

fun = KnotData[{3, 1}, "SpaceCurve"]

ParametricPlot3D[v fun[4 Pi t] + (1 - v) fun[4 Pi (t + .07)],
{t, 0, 1}, {v, 0, 1},
PlotStyle -> FaceForm[],
Method -> {"BoundaryOffset" -> False},
MeshFunctions -> {#4 &, #5 &},
Mesh -> {200, {{1, Directive[Brown, Thick]}}},
BoundaryStyle -> Thin, MeshStyle -> Thin,
ImageSize -> Large, Axes -> False, Boxed -> False]


Show[ParametricPlot3D[fun[4 Pi t], {t, 0, 1},
ImageSize -> Large, Axes -> False, Boxed -> False, PlotRange -> All,
Background -> Black, Lighting -> "ThreePoint"],
ParametricPlot3D[v fun[4 Pi t] + (1 - v) fun[4 Pi (t + .07)],
{t, 0, 1}, {v, 0, 1},
PlotStyle -> FaceForm[],
MeshFunctions -> {#4 &}, Mesh -> {250},
BoundaryStyle -> Directive[White, Thin],
MeshStyle -> Directive[White, Thin]], SphericalRegion -> True]


Use torus instead of fun

 torus = KnotData[{"TorusKnot", {3, 5}}, "SpaceCurve"];


and replace Mesh -> {250} with Mesh -> {400} to get

Show[
ParametricPlot3D[{torus[4 Pi t],
{.8, .8, .8} torus[4 Pi t],
{.5, .5, .5} torus[4 Pi t]}, {t, 0, 1},
PlotStyle -> ({MaterialShading[{"Glazed", #}], Tube[.1]} & /@
{Red, Green, Orange}),
ImageSize -> Large, Axes -> False,
Boxed -> False, PlotRange -> All, Background -> Black,
Lighting -> "ThreePoint"],
ParametricPlot3D[
{v torus[4 Pi t] + (1 - v) {.8, .8, .8} torus[4 Pi t],
v {.8, .8, .8} torus[4 Pi t] + (1 - v) {.5, .5, .5} torus[4 Pi (t + .01)]},
{t, 0, 1}, {v, 0, 1},
PlotStyle -> FaceForm[],
MeshFunctions -> {#4 &}, Mesh -> {900},
BoundaryStyle -> Directive[White, Thin],
MeshStyle -> Directive[White, Thin]], SphericalRegion -> True]
`