Diamond Square Algorithm in VBA (to run in excel) - vba

Question

I've written a script in VBA to create random terrain generation in excel, based on this following matlab script (http://knight.temple.edu/~lakamper/courses/cis350_2004/sources/matlabFractal/createFractalTerrain.m)
After compiling my script I found no bugs, but upon running in excel only cell A1 is assigned a value of zero, and then the script ends.
Now, I wondered if anyone had the time to look through my VBA script and see if they have any idea what's going wrong. I think maybe perhaps I mess around with an array called TR quite a bit when I could perhaps refer to the Cells directly from the get go.
Now, the code is bit long so I have provided a link to the text file that here, and so if nobody has the time I completely understand
https://www.dropbox.com/sh/c2l2ha0awirlowb/AAARGVpidQGP7I9Yu0XRN8yaa?dl=0
Also, here is the code indented.
Public TR(1 To 129, 1 To 129) As Double
Sub DiamondSquare()
Dim tsize As Long: tsize = 129
Dim StartRangRange As Double: startRandRange = 64.5
Dim H As Double: H = 0.9
Call createFractalTerrain(tsize, startRandRange, H)
End Sub
Function createFractalTerrain(ByVal tsize As Long, ByVal startRandRange As Double, ByVal H As Double) As Variant
'Function creates fractal terrain by midpoint displacement (diamond square algorithm)
'Output should be a tsize by tsize matrix
'tSize must be a (power of 2) + 1 ie 129
'startRandRange defines the overall elevation; size/2 gives natural images
'Roughness H (between 0 and 1); 0.9 is a natural value
'H=0 is max roughness
'Initiate Terrain
Dim i As Long
Dim j As Long
Dim ii As Long
Dim jj As Long
For i = 1 To tsize
For j = 1 To tsize
TR(i, j) = 10000
Next
Next
TR(1, 1) = 0
TR(1, tsize) = 0
TR(tsize, 1) = 0
TR(tsize, tsize) = 0
tsize = tsize - 1
randRange = startRandRange
'Main Loop
While tsize > 1
Call diamondStep(tsize, randRange)
Call squareStep(tsize, randRange)
tsize = tsize / 2
randRange = randRange * (1 / (2 ^ H))
Wend
For ii = 1 To tsize
For jj = 1 To tsize
Cells(ii, jj).Value = TR(ii, jj)
Next
Next
End Function
Sub diamondStep(ByVal tsize As Integer, ByVal randRange As Double)
sh = tsize / 2
maxIndex = UBound(TR, 1)
RowVal = 1 + sh
ColVal = 1 + sh
While RowVal < maxIndex
While ColVal < maxIndex
'Average height value of 4 cornerpoints
ValueH = TR(RowVal - sh, ColVal - sh) + TR(RowVal - sh, ColVal + sh) + TR(RowVal + sh, ColVal - sh) + TR(RowVal + sh, ColVal + sh)
ValueH = ValueH / 4
'Displacement
displacement = Int((1 - 0 + 1) * Rnd + 0) * randRange - randRange / 2
ValueH = ValueH + displacement
'Set diamond point
If TR(RowVal, ColVal) = 10000 Then TR(RowVal, ColVal) = ValueH
'Next square in same row
ColVal = ColVal + tsize
Wend
'Next row
ColVal = 1 + sh
RowVal = RowVal + tsize
Wend
End Sub
Sub squareStep(ByVal tsize As Integer, ByVal randRange As Double)
sh = tsize / 2
maxIndex = UBound(TR, 1)
colStart = 1 + sh
RowVal = 1
ColVal = colStart
While (RowVal <= maxIndex)
While (ColVal <= maxIndex)
ValueH = 0
nop = 4 'number of points
'the following cases handle the boundary points,
'i.e. the incomplete diamonds
'north
If RowVal > 1 Then
ValueH = ValueH + TR(RowVal - sh, ColVal)
Else
nop = nop - 1
End If
'east
If ColVal < maxIndex Then
ValueH = ValueH + TR(RowVal, ColVal + sh)
Else
nop = nop - 1
End If
'south
If RowVal < maxIndex Then
ValueH = ValueH + TR(RowVal + sh, ColVal)
Else
nop = nop - 1
End If
'west
If ColVal > 1 Then
ValueH = ValueH + TR(RowVal, ColVal - sh)
Else
nop = nop - 1
End If
'displacement
displacement = Int((1 - 0 + 1) * Rnd + 0) * randRange - randRange / 2
ValueH = ValueH / nop + displacement
'set square point (if not predefined)
If TR(RowVal, ColVal) = 10000 Then TR(RowVal, ColVal) = ValueH
'next diamond in same row
ColVal = ColVal + sh
Wend
'next row
'the starting column alternates between 1 and sh
If colStart = 1 Then
colStart = sh + 1
Else
colStart = 1
End If
ColVal = colStart
RowVal = RowVal + sh
Wend
End Sub

Answer 1

I think the issue you are experiencing is from not iterating over the array you created as you are resetting the tsize variable to 1.
Changing your code to something like this:
For ii = 1 To 129
For jj = 1 To 129
Cells(ii, jj).Value = TR(ii, jj)
Next
Next
Produces a grid of 129 Rows and 129 columns with numeric values. Alternatively you could use the LBound(TR) and UBound(TR) to achieve the same result as manually typing 1 to 129 in each of the For...Loop. I played around with this, and used a conditional format to color the cells based on their relative size either black or white. Here is the result, I think this is the type of output you are expecting.