3
$\begingroup$

Perhaps a stupid question but I am used to that.

This is a perfect smooth surface with circle contour. How can I add some small noise to it to have an actual moutain look with not so smooth contours

fa = E^-(x^2 + y^2)^.5;

min = 0;
max = 1;

f1 = Plot3D[fa, {x, -3, 3}, {y, -3, 3}, PlotRange -> {min, max}, 
   ClippingStyle -> None, MeshFunctions -> {#3 &}, Mesh -> 15, 
   MeshStyle -> Opacity[.5], 
   MeshShading -> {{Opacity[.3], 
      RGBColor[0.54938, 0.773313, 0.848103]}, {Opacity[.8], 
      RGBColor[0.9, 0.9, 0.9]}}, Lighting -> "Neutral", 
   Boxed -> False, PlotPoints -> 100];
slice = SliceContourPlot3D[fa, 
   z == min - 3, {x, -3, 3}, {y, -3, 3}, {z, min - 3, min + 1}, 
   PlotRange -> {min, max}, Contours -> 20, Axes -> False, 
   PlotPoints -> 50, PlotRangePadding -> 0, 
   ColorFunction -> "LightTerrain"];
Show[f1, slice, PlotRange -> All, BoxRatios -> {1, 1, 1.5}, 
 FaceGrids -> {Back, Left}, AxesLabel -> {"x", "y", "z"}, 
 Ticks -> None, BaseStyle -> {FontFamily -> "Times New Roman"}]

enter image description here

$\endgroup$
  • 4
    $\begingroup$ Please post the minimum code necessary for the problem. Do we really need to know all your RGBColor schemes? Or FaceGrids? Or AxesLabels? Or BoxRatios? Of label Font choices? Or ColorFunction? Or...????? $\endgroup$ – David G. Stork Mar 10 '17 at 21:24
  • 1
    $\begingroup$ Wouldn't Plot3D[E^-(x^2 + y^2)^.5, {x, -3, 3}, {y, -3, 3}] include everything you need for your question? $\endgroup$ – David G. Stork Mar 10 '17 at 21:31
  • $\begingroup$ If you are just interested in adding some random noise you could try something along the lines of Plot3D[E^-Sqrt[x^2 + y^2] RandomReal[{.75, 1.25}], {x, -3, 3}, {y, -3, 3}, PlotRange -> All] $\endgroup$ – Marchi Mar 10 '17 at 23:37
  • $\begingroup$ Not sure what you want to have? You want the conturs (=boundaries) to be NOT smooth? How about a Bessel Function? Plot3D[BesselJ[0, 3*Sqrt[(x^2 + 2*y^2)]], {x, -3, 3}, {y, -3, 3}, PlotRange -> Full] $\endgroup$ – Paul Saturday Mar 11 '17 at 0:00
  • $\begingroup$ The proposed solution of Marchi and Paul Saturday fails to generate mountain like contours $\endgroup$ – cyrille.piatecki Mar 11 '17 at 6:03
7
$\begingroup$

Mandelbrot suggested that the fractal surfaces arising from fractional Brownian motion can be used to model rough surfaces in nature, such as mountains. Luckily, Roman Maeder's The Mathematica Programmer II (1996) has a chapter on fractional Brownian motion which we can use. I wrote new code for this answer, but the idea in the code is the same as in the code Maeder wrote over twenty years ago.

The algorithm is the following:

  1. Generate a grid of values in some manner with $n$ sample points in each direction.
  2. Interpolate the grid linearly and refine the grid by sampling it with $n/r$ points in each direction.
  3. Add a Gaussian random number to each grid point. If a finer grid is desired, go back to (2).

There are two parameters used in this algorithm. The first one is $r$, which is called the lacunarity. For example, if $r = 0.5$ then the number of points is increased by two in each direction every iteration. The other parameter is $h$, the Hurst exponent, which is related to the fractal dimension of the limit surface. The fractal dimension is $3 - h$. Generally, a lower Hurst exponent gives a more noisy surface.

step[r_, h_, {xmin_, xmax_}, {ymin_, ymax_}][{ox_, oy_, interp_}] := 
 Module[{delta, nx, ny, t, T},
  nx = Ceiling[ox/r];
  ny = Ceiling[oy/r];
  t = 1./(Max[{nx, ny}] - 1);
  T = 1./(Max[{ox, oy}] - 1);
  delta = Sqrt[0.5] Sqrt[1 - (t/T)^(2 - 2 h)] t^h;
  {
   nx,
   ny,
   Interpolation[Flatten[Outer[
      {{#, #2}, interp[#, #2] + delta RandomVariate[NormalDistribution[]]} &,
      Subdivide[xmin, xmax, nx],
      Subdivide[ymin, ymax, ny]
      ], 1], InterpolationOrder -> 1]
   }
  ]

Here we create an initial grid with values from the given function and visualize the linear interpolation. There are ten grid points in each direction:

init = Flatten[Outer[
    {{#, #2}, E^-(#^2 + #2^2)^.5} &,
    Subdivide[-3, 3, 10],
    Subdivide[-3, 3, 10]
    ], 1];
interp = Interpolation[init, InterpolationOrder -> 1];

Plot3D[
 interp[x, y], {x, -3, 3}, {y, -3, 3},
 PlotRange -> Full,
 ColorFunction -> ColorData["GreenBrownTerrain"],
 Mesh -> False
 ]

Mathematica graphics

Now we refine the grid four times with $r = 0.5$, i.e. we double the number of grid points in each direction four times. The Hurst exponent is 0.75.

{nx, ny, f} = Nest[step[0.5, 0.75, {-3, 3}, {-3, 3}], {10, 10, interp}, 4];
Plot3D[
 f[x, y], {x, -3, 3}, {y, -3, 3},
 PlotRange -> Full,
 ColorFunction -> ColorData["GreenBrownTerrain"],
 Mesh -> False
 ]

Mathematica graphics

As we can see, new rough detail has appeared on the surface. Setting fa = f[x,y] we can see how this looks with the visualization technique in the OP:

Mathematica graphics

Other parameter values will result in different looking surfaces, depending on what one wants it might be worth it to try a few different ones.

$\endgroup$
3
$\begingroup$

You could use a 2D Gaussian random field taking code from this question. Here I've used the fields function from my own answer but any of them would work.

For this approach you're plotting a dataset instead of a function so use ListPlot3D.

n = 300;    
smooth = Table[E^-(x^2 + y^2)^.5, {x, -3, 3, 6/(n - 1)}, {y, -3, 3, 6/(n - 1)}];
rand = -0.5 + Rescale@First@fields[n, -3.5];

m = smooth + 2 smooth rand;

ListPlot3D[m, Mesh -> None, 
 ColorFunction -> ColorData[{"SandyTerrain", "Reverse"}], 
 PlotRange -> {0.05, Max[m]}, Boxed -> False, Axes -> False,
 ClippingStyle -> RGBColor[0, 0.4, 0.6], BoundaryStyle -> None, 
 BoxRatios -> {1, 1, 0.2}]

enter image description here

$\endgroup$

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.