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

Improve this question
$\endgroup$
2
  • 4
    $\begingroup$ Consider modelling an electrostatic potential isosurface, for instance. $\endgroup$ Commented 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$ Commented Nov 18, 2015 at 7:25

4 Answers 4

Reset to default
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

Improve this answer
$\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$ Commented 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$ Commented 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$ Commented 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.

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ Congratulations on the Populist badge. $\endgroup$ Commented 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

Improve this answer
$\endgroup$
5
  • $\begingroup$ Simply put...amazing! $\endgroup$ Commented 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$ Commented Nov 19, 2015 at 11:12
  • $\begingroup$ I'll need to think about it. $\endgroup$ Commented Nov 19, 2015 at 11:26
  • $\begingroup$ Couldn't your ParametricPlot3D be replaced with the slightly easier SphericalPlot3D? $\endgroup$ Commented 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$ Commented 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"}
];
Improve this answer
$\endgroup$
1
  • $\begingroup$ I guess a challenge is to use this approach in order to make 3D graphic. But this is beyond me:-)! $\endgroup$ Commented Nov 18, 2015 at 16:41

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.