How to make a blob in 3D?

Question

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.

Answer 1

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

Answer 2

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.

Answer 3

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

Answer 4

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"}
];