31
$\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$
2
  • 4
    $\begingroup$ Consider modelling an electrostatic potential isosurface, for instance. $\endgroup$
    – kirma
    Nov 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 4

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$
3
  • $\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$
    – user484
    Nov 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$
    – user484
    Nov 19, 2015 at 0:17
37
$\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
  • 1
    $\begingroup$ Congratulations on the Populist badge. $\endgroup$
    – Mr.Wizard
    Nov 22, 2015 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$
5
  • $\begingroup$ Simply put...amazing! $\endgroup$
    – Dimitris
    Nov 19, 2015 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, 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 easier SphericalPlot3D? $\endgroup$
    – user484
    Nov 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
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$
1
  • $\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, 2015 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.