Diamant-Square-Algorithmus in VBA (in Excel laufen)

Question

Ich habe ein Skript in VBA geschrieben Random Terrain Generation in Excel zu erstellen, basierend auf diesem folgenden Matlab-Skript (http://knight.temple.edu/~lakamper/courses/cis350_2004/sources/matlabFractal/createFractalTerrain.m)

Nach meinem Skript kompiliert Ich fand keine Fehler, aber wenn Excel ausgeführt wird, wird Zelle A1 nur der Wert Null zugewiesen und das Skript endet.

Nun fragte ich mich, ob jemand Zeit hatte, durch mein VBA-Skript zu sehen und zu sehen, ob sie eine Ahnung haben, was schief läuft. Ich denke, vielleicht bin ich vielleicht mit einem Array namens TR beschäftigt, wenn ich vielleicht direkt von Anfang an auf die Zellen verweisen kann. Jetzt

ist die Code-Bit lang, so ich einen Link zu der Textdatei zur Verfügung gestellt habe, die hier, und so, wenn niemand hat die Zeit mich völlig

https://www.dropbox.com/sh/c2l2ha0awirlowb/AAARGVpidQGP7I9Yu0XRN8yaa?dl=0

auch verstehen, hier ist der Code eingerückt .

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

Ich denke, das Problem, das Sie erleben ist von nicht über das Array iterieren Sie erstellt, wie Sie die tsize Variable 1.

sind Neueinstellung Ihren Code so etwas wie dies ändern:

For ii = 1 To 129 
    For jj = 1 To 129 
     Cells(ii, jj).Value = TR(ii, jj) 
    Next 
Next 

Erzeugt ein Raster von 129 Zeilen und 129 Spalten mit numerischen Werten. Alternativ können Sie auch LBound(TR) und UBound(TR) verwenden, um das gleiche Ergebnis zu erreichen, als würden Sie manuell 1 bis 129 in jedes der For...Loop eingeben. Ich spielte damit herum und verwendete ein bedingtes Format, um die Zellen basierend auf ihrer relativen Größe entweder schwarz oder weiß zu färben. Hier ist das Ergebnis, ich denke, das ist die Art von Ausgabe, die Sie erwarten.