Improve my implementation of the Diamond square algorithm

I found the algorithm interesting, so I played around with it. This is my implementation of the algorithm. I try to leverage in-place modification of the global matrix and as many vectorized operations as possible. That's why further compilation into a CompiledFunction won't lead to any improvements. (Since CompiledFunctions are not allowed to perform in-place modification, Compile would lead to a loss in performance.)

First, a fused variant of a diamond-square iteration; note the attribute HoldAll that allows us to call diamondsquare by reference. Moreover, we submit an iteration counter and a reservoir of random numbers to this function. The latter allows the user to modify the noise model easily. I cheat a little bit at the boundaries by reflecting the matrix along its boundary edges; that's why I construct a helper list.

ClearAll[diamondsquare]
SetAttributes[diamondsquare, HoldAll];
diamondsquare[A_, iter_, rand_] := 
  Module[{d, d2, n, r, shift, ilist, jlist, list, m},
   n = Length[A];
   m = Ceiling[Log2[n - 1]];
   r = 2^(iter - 1);
   d = 2^(m - iter);
   shift = 1 + d;
   d2 = 2 d;
   (*diamond step*)
   ilist = Range[shift, n, d2];
   jlist = Range[shift, n, d2];
   A[[ilist, jlist]] = 0.25 Plus[
       A[[ilist + d, jlist + d]],
       A[[ilist - d, jlist + d]],
       A[[ilist - d, jlist - d]],
       A[[ilist + d, jlist - d]]
       ] + rand[[1 ;; r, 1 ;; r]];
   (*square step*)
   ilist = Range[shift, n, d2];
   jlist = Range[1, n, d2];
   A[[ilist, jlist]] = 0.25 Plus[
       A[[ilist - d, jlist]],
       A[[ilist + d, jlist]],
       list = jlist - d; list[[1]] = list[[2]]; A[[ilist, list]],
       list = jlist + d; list[[-1]] = list[[-2]]; A[[ilist, list]]
       ] + rand[[r + 1 ;; 2 r, 1 ;; r + 1]];
   ilist = Range[1, n, d2];
   jlist = Range[shift, n, d2];
   A[[ilist, jlist]] = 0.25 Plus[
       A[[ilist, jlist - d]],
       A[[ilist, jlist + d]],
       list = ilist - d; list[[1]] = list[[2]]; A[[list, jlist]],
       list = ilist + d; list[[-1]] = list[[-2]]; A[[list, jlist]]
       ] + rand[[2 r + 1 ;; 3 r + 1, 1 ;; r]];
   ];

Here is a usage example. First, we set up a noise level σ, an altitute and the starting matrix A:

m = 8;
n = 2^m + 1;
σ = 1.;
altitude = 1.;
SeedRandom[123];
AbsoluteTiming[
  A = ConstantArray[0., {n, n}];
  A[[{1, n}, {1, n}]] = RandomReal[{-altitude, altitude}, {2, 2}];
  ][[1]]

0.000119

Do[
    rand = RandomReal[
      {-σ 2^-iter, σ 2^-iter}, 
      {3 2^(iter - 1) + 1, 2^(iter - 1) + 1}
      ];
    diamondsquare[A, iter, rand];
    , {iter, 1, m}]; // AbsoluteTiming // First

0.004468

And here is the result:

ArrayPlot[Rescale[A], DataReversed -> {True, False}, ColorFunction -> "AlpineColors"]
ListPlot3D[A, Axes -> False, Boxed -> False, Mesh -> None, 
 ColorFunction -> ColorData["AlpineColors"], Background -> Black, 
 PlotRange -> All]

enter image description here

enter image description here


Another implementation (of course less efficient than that of the king of optimisation, Henrik Schumacher):

init := {mat[[1, 1]], mat[[-1, 1]], mat[[-1, -1]], mat[[1, -1]]} = 
  RandomReal[1, 4]
diamond[p_?EvenQ, e_] := Block[{},
  coordsCenters = 
   Flatten[Table[{p/2 + 1 + i*p, p/2 + 1 + j*p}, {i, 0, nn/p - 1}, {j,
       0, nn/p - 1}], 1];
  coordsCorners = 
   Table[coordsCenters[[i]] + p/2*# & /@ {{1, 1}, {-1, 
       1}, {-1, -1}, {1, -1}}, {i, Length@coordsCenters}];
  Table[mat[[Sequence @@ coordsCenters[[i]]]] = 
    Mean[mat[[Sequence @@ #]] & /@ coordsCorners[[i]]] + 
     RandomReal[{-e, e}], {i, Length@coordsCenters}];
  ]
square[p_?EvenQ, e_] := Block[{},
  coordsCenters = 
   Select[Flatten[
     Table[{1 + p/2*i, 1 + (1 + (-1)^(i))*p/4 + p*j}, {i, 0, 
       2 nn/p}, {j, 0, nn/p}], 1], Max[#] <= nn &];
  coordsVertices = 
   Table[coordsCenters[[i]] + p/2*# & /@ {{-1, 0}, {0, 1}, {1, 
       0}, {0, -1}}, {i, Length@coordsCenters}];
  Table[mat[[Sequence @@ coordsCenters[[i]]]] = 
    Mean[mat[[Sequence @@ #]] & /@ 
       Select[coordsVertices[[i]], 1 <= Min@# && Max@# <= nn &]] + 
     RandomReal[{-e, e}], {i, Length@coordsCenters}];
  ]

 show[i_] := 
 Block[{}, diamond[2^i, e*2.^(i - n)]; square[2^i, 0.5*2^(i - n)];
  ListPlot3D[mat, Axes -> False, Boxed -> False, Mesh -> None, 
   ColorFunction -> ColorData["AlpineColors"], Background -> Black, 
   PlotRange -> All]]

Use as

n = 8;
e = 1;
nn = 2^n + 1;
mat = ConstantArray[0, {nn, nn}];
init
tab = Table[show[i], {i, n, 1, -1}]

enter image description here

enter image description here

Note: I used's Henrik's code for the visualisation.

Note 2: The only non-obvious thing is that the noise amplitude e should decrease with the step. I've taken this idea from Henrik's answer (again) but I don't know if this is part of the regular algorithm.