I am trying to make a blob like the one shown below, but in 3D so I can rotate it. I'm trying to use ParametricPlot3D
or SphericalPlot3D
. I can make a sphere easily. But my knowledge of how to modify the sphere to make it bulge out in a few places in limited. Anyone have any suggestions? I'd like to make it non symmetric so it look like a random blob like the one below. If I can create the outside blob I'm sure I can create an inside one. I can than place the vectors in the appropriate places. I am a teacher trying to illustrate how to use the divergence theorem on a region like this. Any suggestions would be appreciated. Thank you.
-
4$\begingroup$ Consider modelling an electrostatic potential isosurface, for instance. $\endgroup$– kirmaNov 18, 2015 at 5:48
-
1$\begingroup$ There was somewhere similar post about marking infinitesimal parts of such surfaces, can't find it :/ $\endgroup$– Kuba ♦Nov 18, 2015 at 7:25
4 Answers
This can also be made a little lumpier with spherical harmonics.
realization[r_] :=
Assuming[{0 <= θ <= π, 0 <= φ <= 2 π},
Simplify[r + Abs[ComplexExpand[Plus @@ Flatten[
Table[ RandomReal[{-1, 1}] 1/(l^2 + m^2)
SphericalHarmonicY[l, m, θ, φ],
{l, 1, 4}, {m, 0, l}]
]]]]]
Block[{inner, outer},
outer = realization[1];
inner = realization[1/2];
Show[
SphericalPlot3D[outer, {θ, 0, π}, {φ, 0, 2 π},
PlotStyle -> Directive[Orange, Opacity[0.2], Specularity[White, 10]],
Mesh -> None, PlotPoints -> 50],
SphericalPlot3D[inner, {θ, 0, π}, {φ, 0, 2 π},
PlotStyle -> Directive[GrayLevel[0.4], Opacity[0.2], Specularity[White, 10]],
Mesh -> None, PlotPoints -> 50],
Axes -> False, Boxed -> False
]]
-
$\begingroup$ Use the "Image" button on the editing toolbar (the one that looks like a picture of a landscape). I've done it for you this time. $\endgroup$– user484Nov 18, 2015 at 20:41
-
$\begingroup$ @Rahul : I haven't found a way to drag images from Mathematica to the dialog that pops up... $\endgroup$ Nov 18, 2015 at 23:39
-
$\begingroup$ Oh, I just right-click, "Save Graphic As...", save it as
whatever.png
, and upload the image file. Not the most luxurious of techniques, I know... $\endgroup$– user484Nov 19, 2015 at 0:17
Here's a function to create a random scalar field:
randomFunction3D[xrange_, yrange_, zrange_] :=
Interpolation[
Flatten[Table[{{x, y, z}, RandomReal[{-1, 1}]},
Evaluate@{x, Sequence @@ xrange},
Evaluate@{y, Sequence @@ yrange},
Evaluate@{z, Sequence @@ zrange}], 2], Method -> "Spline"]
Now instead of drawing a sphere with constant radius $x^2+y^2+z^2=r^2$, let's make the "radius" vary randomly over space, so we get an irregular blobby shape:
SeedRandom[0];
f = randomFunction3D[{-3, 3}, {-3, 3}, {-3, 3}];
ContourPlot3D[
x^2 + y^2 + z^2 == (1 + 0.4 f[x, y, z])^2, {x, -2, 2}, {y, -2,
2}, {z, -2, 2}, Mesh -> None, PlotRange -> All,
BoxRatios -> Automatic, Boxed -> False, Axes -> False]
You can also change the grid spacing to control the size of the bumps:
SeedRandom[0];
f = randomFunction3D[{-3, 3, 0.25}, {-3, 3, 0.25}, {-3, 3, 0.25}];
ContourPlot3D[
x^2 + y^2 + z^2 == (1 + 0.06 f[x, y, z])^2, {x, -2, 2}, {y, -2,
2}, {z, -2, 2}, Mesh -> None, PlotRange -> All,
BoxRatios -> Automatic, Boxed -> False, Axes -> False]
You can have a lot of fun adding a bunch of different random fields with different scalings to create interesting effects, but I'll leave that as an exercise. For inspiration, see Ken Perlin's classic Making Noise talk.
-
1
I swear I've seen potatoes like this:
realSphericalHarmonic[ℓ_Integer?NonNegative, 0, θ_, φ_] :=
SphericalHarmonicY[ℓ, 0, φ, θ];
realSphericalHarmonic[ℓ_Integer?NonNegative, m_Integer, θ_, φ_] /; -ℓ <= m <= ℓ :=
I^Boole[m < 0] (SphericalHarmonicY[ℓ, -Abs[m], φ, θ] + (-1)^(m + Boole[m < 0])
SphericalHarmonicY[ℓ, Abs[m], φ, θ])/Sqrt[2]
BlockRandom[SeedRandom[42, Method -> "Rule50025CA"]; (* for reproducibility *)
n = 3;
ρ[θ_, φ_] = 1 + Sum[RandomVariate[NormalDistribution[]]
realSphericalHarmonic[k, j, θ, φ]/k!,
{k, 0, n}, {j, -k, k},
Method -> "Procedural"] // FunctionExpand;
ParametricPlot3D[ρ[θ, φ] {Sin[φ] Cos[θ], Sin[φ] Sin[θ], Cos[φ]},
{θ, -π, π}, {φ, 0, π}, Axes -> None, Boxed -> False,
Evaluated -> True, Mesh -> False, PlotPoints -> 55,
ViewPoint -> {-1.3, -2.4, 2.}]]
-
-
$\begingroup$ Do you think we can use the code from my answer in order to generate a 3D graphic? $\endgroup$– DimitrisNov 19, 2015 at 11:12
-
$\begingroup$ I'll need to think about it. $\endgroup$ Nov 19, 2015 at 11:26
-
$\begingroup$ Couldn't your
ParametricPlot3D
be replaced with the slightly easierSphericalPlot3D
? $\endgroup$– user484Nov 19, 2015 at 18:01 -
$\begingroup$ @Rahul, it can, but the default convention always confuses and vexes me, since it's not the one I'm accustomed to (that is, $\theta$ is the longitude, and $\varphi$ is the colatitude). Note this bias in how I defined the real spherical harmonics as well. $\endgroup$ Nov 19, 2015 at 18:05
Not exactly what you want but a similar application (demonstration of divergence theorem). I guess it worths. I learnt the code eight years ago when still working with Mathematica 5.2. David Park was responsible for the code.
I tried as possible as I could in order to upgrade it so that it works with recent versions.
partitionfunction[d_][q_] :=
Piecewise[{{Sin[(Pi*q)/(2*d)]^2,
Inequality[0, LessEqual, q, Less, d]}, {1,
Inequality[d, LessEqual, q, Less,
2*Pi - d]}, {Sin[(Pi*(2*Pi - q))/(2*d)]^2,
2*Pi - d <= q <= 2*Pi}}]
radius[d_][q_] :=
1 + 1.5*partitionfunction[d][q]*BesselJ[5, (13/(2*Pi))*q + 5]
curve[d_][q_] := radius[d][q]*{Cos[q], Sin[q]}
tangent[t_] =
N[curve[1][45*Degree] + t*Derivative[1][curve[1]][45*Degree]];
normal[t_] =
N[curve[1][45*Degree] +
t*Reverse[Derivative[1][curve[1]][45*Degree]]*{1, -1}];
n = {1.127382730502271, 1.037382730502271};
g = ParametricPlot[curve[1][q], {q, 0, 2*Pi}, Axes -> False,
PlotPoints -> 50, PlotStyle -> Thickness[0.007],
Exclusions -> None];
line = Cases[g, l_Line :> First@l, Infinity];
g1 = Graphics[{Opacity[0.4], Darker@Orange,
EdgeForm[{Thick, Darker@Orange}], Polygon[line]}, Options[g]];
g2 = Graphics[{Thickness[0.007], Arrowheads[Large],
Arrow[{normal[0], normal[0.3]}]}];
g3 = ParametricPlot[tangent[t], {t, -0.2, 0.2},
PlotStyle -> Thickness[0.006], PlotPoints -> 50];
cir = Graphics[{Circle[normal[0], 0.1, {3.3*(Pi/2), 2.15*Pi}]}];
po = Graphics[{PointSize[0.01], Point[n]}];
tex1 = Graphics[Text[Style["V", 17], {0.0532359, -0.0138103}]];
tex2 = Graphics[Text[Style["S", 17], {0.470751, -1.08655}]];
tex3 = Graphics[Text[Style["n", 17, Italic, Black, Bold], {1.5, 1.2}]];
Show[{g1, g2, g3, cir, po, tex1, tex2, tex3}, PlotRange -> All]
Just for fun: Here is the old good code for 5.2 (!), for anyone interested.
Block[{$DisplayFunction = Identity},
g =
ParametricPlot[curve[1][o1], {o1, 0, 2*Pi},
Axes -> False, PlotPoints -> 50,
PlotStyle -> Thickness[0.007]];
g1 = g /. Line[x_] -> {GrayLevel[0.8], Polygon[x]};
g2 =
ParametricPlot[tangent[t], {t, -0.2, 0.2},
PlotStyle -> Thickness[0.006], PlotPoints -> 50];
g3 =
Graphics[
{Thickness[0.007], Arrow[normal[0], normal[0.3],
HeadLength -> 0.06, HeadCenter -> 0.7]}];
cir =
Graphics[{Circle[normal[0], 0.1, {3.3*(Pi/2), 2.15*Pi}]}];
po = Graphics[{PointSize[0.01], Point[n]}];
tex1 = Graphics[Text["V", {0.0532359, -0.0138103}]];
tex2 = Graphics[Text["S", {0.470751, -1.08655}]];
tex3 =
Graphics[
Text[StyleForm["n", FontSize -> 17, FontFamily -> "Times",
FontColor -> Black, FontWeight -> "Bold"],
{1.7, 1.2}]];
]
Show[
g, g1, g2, g3, tex1, tex2, tex3, cir, po,
AspectRatio -> Automatic,
TextStyle ->
{FontSize -> 17, FontFamily -> "Times", FontWeight -> "Bold"}
];
-
$\begingroup$ I guess a challenge is to use this approach in order to make 3D graphic. But this is beyond me:-)! $\endgroup$– DimitrisNov 18, 2015 at 16:41