Skip to main content

plotting - Extrude 2D cross-section to 3D shape with shrinkfactor


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



Answer



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


Comments

Popular posts from this blog

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...

equation solving - Invert and fit implicitly defined curve

I need to fit an implicitly defined curve. I thought I could get some data out of Solve , and then using FindFit . Therefore, I would like to find the relation the parametric curve defined by $F(x,y)=0$: Solve[-(1/2) + 1/2 (0.41202 BesselK[0, 0.1 Sqrt[x^2 + y^2]] + (0.101483 x BesselK[1, 0.1 Sqrt[x^2 + y^2]])/Sqrt[x^2 + y^2]) == 0, y] But I can't get an output: Solve was unable to solve the system with inexact coefficients or the system obtained by direct rationalization of inexact numbers present in the system. Since many of the methods used by Solve require exact input, providing Solve with an exact version of the system may help. >> Edit: In particular, I would like to fit the data coming from the curve with the expression of another curve, and not with a function $f(x)$. In particular, since this clearly looks like a cardioid , I would like it to fit to something like it. What other strategies could I try?

dynamic - How can I make a clickable ArrayPlot that returns input?

I would like to create a dynamic ArrayPlot so that the rectangles, when clicked, provide the input. Can I use ArrayPlot for this? Or is there something else I should have to use? Answer ArrayPlot is much more than just a simple array like Grid : it represents a ranged 2D dataset, and its visualization can be finetuned by options like DataReversed and DataRange . These features make it quite complicated to reproduce the same layout and order with Grid . Here I offer AnnotatedArrayPlot which comes in handy when your dataset is more than just a flat 2D array. The dynamic interface allows highlighting individual cells and possibly interacting with them. AnnotatedArrayPlot works the same way as ArrayPlot and accepts the same options plus Enabled , HighlightCoordinates , HighlightStyle and HighlightElementFunction . data = {{Missing["HasSomeMoreData"], GrayLevel[ 1], {RGBColor[0, 1, 1], RGBColor[0, 0, 1], GrayLevel[1]}, RGBColor[0, 1, 0]}, {GrayLevel[0], GrayLevel...