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 would like to create a 3D shape from extrusion and scaling of a 2D contour. The 2D contour that I have looks like this:

enter image description here

and it consists of a bunch of points (here plotted with ListPlot with Joined->True).

I have looked at a bunch of questions and answers here on Mathematica.SE, notably this one and this one, but I don't see how to apply those to my problem in any straightforward manner.

For the sake of a MWE I will switch to a circle from this point on:

xdata = Table[x, {x, -1, 1, 0.05}];
ydata = Table[Sqrt[1 - x^2], {x, -1, 1, 0.05}];
circData = {Transpose[{xdata, ydata}], Transpose[{xdata, -ydata}]};
ListPlot[circData, Joined -> True, AspectRatio -> Automatic]

The extruded shape that I would like to make then looks like this:

enter image description here

It is a shape consisting of slices of the contour with constant radius $r_0$ over some range let's say $-1 < z < 1$ and decrease in radius with $z$ at the tips according to $r(z)=r_0\sqrt{1-(z-1)^2}$ and $r(z)=r_0\sqrt{1-(z+1)^2}$ (depending on which tip).

My question is: how can I do this extrusion for the set of listdata that I have?

Just to be clear, to create the 3D shape for the circle I cheated and used the formula for a circle and a sphere like this:

p = Plot3D[{1 + Sqrt[1 - y^2 - x^2 ], -1 - 
     Sqrt[1 - y^2 - x^2 ]}, {x, -2, 2}, {y, -2, 2}, 
   PlotStyle -> {Orange}, Lighting -> Automatic, Mesh -> Automatic, 
   BoxRatios -> Automatic, Boxed -> False, Axes -> None];
q = RegionPlot3D[
   Sqrt[x^2 + y^2] < 1, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}, 
   PlotStyle -> {Orange}, Lighting -> Automatic, Mesh -> Automatic, 
   BoxRatios -> Automatic, Boxed -> False, Axes -> None];
Show[p, q]

Is there a way to achieve the same with the data from a list?


[Adaptation to thicknessFunc by @Halirutan and accompanying re-scaling]

To make the thicknessFunc more generic I adapted it to:

thicknessFunc[z_, body_, 
  b_] := (HeavisideTheta[z] - HeavisideTheta[z - b])*
   Sqrt[b^2 - (z - b)^2] + 
  b (HeavisideTheta[z - b] - 
     HeavisideTheta[z - body - b]) + (HeavisideTheta[z - body - b] - 
     HeavisideTheta[z - body - 2 b])*Sqrt[b^2 - (z - body - b)^2]

such that you can set the radius of the circular parts by setting $b$. A consequence of this is that you have to rescale the thicknessFunc in append with $1/b$ like

Append[1/b thicknessFunc[u,2]*fdata[t], u]

I don't fully understand why, but I guess it has to do with the fact that fdata is multiplied by thicknessFunc and therefore needs the straight ends of thicknessFunc to be at 1

share|improve this question

2 Answers 2

up vote 4 down vote accepted

This is in theory pretty simple. Think of it as two separated steps. First, you need function that models your extrusion-thickness, which has in the middle always the same value and at both ends it should round up like a circle. You can do this with Piecewise or, as I show here, with a combination of Heaviside functions:

thicknessFunc[z_, 
  body_] := (HeavisideTheta[z] - HeavisideTheta[z - 1])*
   Sqrt[1 - (1 - z)^2] + (HeavisideTheta[z - 1] - 
    HeavisideTheta[z - body - 1]) + (HeavisideTheta[z - body - 1] - 
     HeavisideTheta[z - body - 2])*Sqrt[1 - (z - body - 1)^2]

the parameter body is the size of the constant middle part. Here with the size of 2 ranging from 1 to 3:

Plot[thicknessFunc[u, 2], {u, 0, 4}]

Mathematica graphics

The other part is that you can interpolate your points, so that you get a function fdata[t_] which gets a single parameter t and runs along your points for t ranging from 0 to 1 (you can actually use whatever you like here):

data = Table[(1/4 Sin[5 phi]^2 + 1) {Cos[phi], Sin[phi]}, {phi, 0, 2 Pi, Pi/50}];
With[
  {ip = ListInterpolation[#, {{0, 1}}, PeriodicInterpolation -> True] & /@ Transpose[data]},
  fdata[t_] := Through[ip[t]]
 ]

ParametricPlot[fdata[t], {t, 0, 1}]

Mathematica graphics

Note that fdata[t] always returns points {x,y}. Now we turn this into a 3d function by combining the thicknessFunc with fdata. Our final function f3d will have two parameters: t which walks around the contour if increase it and u which defines our height and uses the thicknessFunc to scale the contour:

f3d[t_, u_] := Append[thicknessFunc[u,2]*fdata[t], u]

Note that only the {x,y} points of the contour are scaled and to make this work, your contour points need to lie around the zero point {0,0} as in your example. That's it, the rest is only plotting

ParametricPlot3D[f3d[t, u], {t, 0, 1}, {u, 0, 4}, Exclusions -> None, 
 PlotPoints -> 30, MaxRecursion -> 3, 
 PlotStyle -> {Orange, Specularity[White, 10]}, Axes -> None, 
 Mesh -> None]

Mathematica graphics

share|improve this answer
    
Would there been any way to have "direct edges" in the function thicknessFunc? When looking at the answer I was somehow expected thicknessFunc[u, 4] to give a rectangular shape.. :) –  Öskå Jul 25 at 17:36
    
@Öskå In its current form not. body really gives the length of the constant middle part and the round corners are always added. You have to change thicknessFunc to make the shape more rectangular, but I'm not sure how ParametricPlot3D will handle such an abrupt jumpg. –  halirutan Jul 25 at 23:16
    
This works brilliantly, except for one thing that I cannot figure out: the cross-section for my own data is scaled to half the size in the extruded shape?! If I put a factor 2 inside the append (like Append[2*thicknessFunc[u,2]*fdata[t], u]) then it is fixed, but I really don't understand. I will add this to my question in an edit –  Michiel Jul 26 at 7:37
    
@Michiel Can you include the points of your 2d shape in your question? With this, we can work with your data and see what you see. Or if your data is too large, then put the list of points to pastebin.com –  halirutan Jul 26 at 8:07
    
Thanks, but never mind. I already figured out the issue (see my edit in the question). Of course, the error was due to an adaptation that I made to your code, so I've only got myself to blame. –  Michiel Jul 26 at 8:15

How about this. Generate a list of 2D points:

pts = Table[{Cos[2 \[Pi] k/6], Sin[2 \[Pi] k/6]}, {k, 0, 6}];
ListLinePlot[pts]

enter image description here

and we'll use a scaling function to form the caps.

Plot[Sqrt[1 - (Abs@z - 1)^2], {z, -1, 1}, AspectRatio -> 1]
sfunc[pt_] := Module[{z = Last@pt}, Piecewise[{{pt, -1 < Last@pt < 1}}, 
  {{Sqrt[1 - (Abs@z - 1)^2], Sqrt[1 - (Abs@z - 1)^2], 1}*pt}]]

enter image description here

Create the extrusion

ext = Partition[Flatten@Table[sfunc[Join[#, {z}]] & /@ pts, {z, -2, 2, 0.05}], 3];

and plot it

Graphics3D@(Polygon@ext)

enter image description here

share|improve this answer
    
This is indeed the route that I explored at first, but it is not entirely what I was looking for, because this remains a body of slices instead of a complete surface. –  Michiel Jul 26 at 8:18

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.