28
$\begingroup$

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.

Blob in 3 dimensions

$\endgroup$
  • 4
    $\begingroup$ Consider modelling an electrostatic potential isosurface, for instance. $\endgroup$ – kirma Nov 18 '15 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 '15 at 7:25
19
$\begingroup$

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

enter image description here

$\endgroup$
  • $\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$ – Rahul Nov 18 '15 at 20:41
  • $\begingroup$ @Rahul : I haven't found a way to drag images from Mathematica to the dialog that pops up... $\endgroup$ – Eric Towers Nov 18 '15 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$ – Rahul Nov 19 '15 at 0:17
34
$\begingroup$

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]

enter image description here

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]

enter image description here

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.

$\endgroup$
  • 1
    $\begingroup$ Congratulations on the Populist badge. $\endgroup$ – Mr.Wizard Nov 22 '15 at 11:33
15
$\begingroup$

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

surprise at the back

$\endgroup$
  • $\begingroup$ Simply put...amazing! $\endgroup$ – Dimitris Nov 19 '15 at 11:10
  • $\begingroup$ Do you think we can use the code from my answer in order to generate a 3D graphic? $\endgroup$ – Dimitris Nov 19 '15 at 11:12
  • $\begingroup$ I'll need to think about it. $\endgroup$ – J. M. will be back soon Nov 19 '15 at 11:26
  • $\begingroup$ Couldn't your ParametricPlot3D be replaced with the slightly easier SphericalPlot3D? $\endgroup$ – Rahul Nov 19 '15 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$ – J. M. will be back soon Nov 19 '15 at 18:05
6
$\begingroup$

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]

enter image description here


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"}
];
$\endgroup$
  • $\begingroup$ I guess a challenge is to use this approach in order to make 3D graphic. But this is beyond me:-)! $\endgroup$ – Dimitris Nov 18 '15 at 16:41

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.