Surface Chart 3D Terrain Generator

As a teenager I owned an Amiga 500 – that’s actually how I started (seriously) programming. Oh, the Motorola 68000 CPU was just great to write code on.
One of the neat things about the Amiga community were the “demos” that would come out. Demos are like a music video for your computer with emphasis on creating real-time graphic effects.
They were all about pushing the boundaries of what the architecture could achieve – quite a lot like the Excel community really.

One of the demos that really stuck in my head was a fractal landscape / terrain generator. I was fascinated that a computer could draw realistic mountains.
I’ve always wanted to make one – just for fun – so recently I set about learning how.
It came as a surprise when I discovered that a terrain generator could be developed using only worksheet functions and a Surface Chart.

Here is a sample picture. It’s actually a Surface Chart! Every time you press F9 a new picture is generated.
3D Terrain

You can download it from my website:
http://www.vangelder.co.nz/excel/

Posted in Uncategorized

13 thoughts on “Surface Chart 3D Terrain Generator

  1. Amgia demo’s!!! lol, Jesus on e’s – classic, there’s a whole world of emulators out there now… good fun if you have the time!

  2. The Amiga was an awesome computer and years ahead of its time. The OS was an excellent example of what could be done with such minimal resources.

    One of the best Amiga demos I ever saw was Phenomena Enigma.

    As for terrain generation, I remember an application called Vista Pro that capable of generating very realistic mountainous scenery.

  3. Steve,

    I agree – absolutely years ahead.
    I’m still very passionate about that computer.
    Copper, Blitter, 3D gfx, 4ch Audio built-in from the start. Not to mention Motorola 68000 – which is a dream to write on. I dont think any other computer has had it’s capabilities explored more than Amiga.

    Enough of that – I’m ranting…

    I saw on J-Walk Blog the other day about a scenery generator called Terragen

    Rob

  4. hi Dick, the terrain.zip file broken link, please new link to donwload terrain file.

  5. I don’t have anything that was stored on Rob’s site. If you can’t get it from webarchive.org, it can’t be got.

  6. Hi Dick,
    you have the terrain.zip Excel file? the link is broken, not have in WebArchive.
    or you hva the email of Rob van Gelder or someone people have this Excel file?
    thank you.
    Flavio

  7. It’s a real pitty that Rob’s site is down for a long time right now. He has posted several codes quite interesting. I could not get my hands on this, but for the sake of future users, here’s a procedure that can do nearly the same thing.

    It’s based on [URL]https://stackoverflow.com/questions/39252967/diamond-square-algorithm-in-vba-to-run-in-excel[/URL] which was previously based on
    [URL]https://cis.temple.edu/~lakamper/courses/cis350_2004/sources/matlabFractal/createFractalTerrain.m[/URL]

    Without relaying on VBA, I think this posts of beeheap on steemit, which is very informative can produce the same only with Excel functions, that was the original Rob Von Gelder concept: [URL]https://steemit.com/map/@beeheap/create-a-fantasy-grid-map-in-excel[/URL]

    [CODE]Option Explicit

    Private Const gSize As Long = 129 ‘ define the size of the grid
    Private TR(1 To gSize, 1 To gSize) As Double ‘ terrain grid

    Public Sub sDiamondSquare_ProceduralTerrainGeneration()
    https://stackoverflow.com/questions/39252967/diamond-square-algorithm-in-vba-to-run-in-excel
    https://cis.temple.edu/~lakamper/courses/cis350_2004/sources/matlabFractal/createFractalTerrain.m

    ‘ create fractal terrain by midpoint displacement (diamond square algorithm)
    ‘ the algorithm is prepared for pre-initialization of terrainpoints,
    ‘ i.e. some first steps could have been preinitialized to give a basic shape.
    ‘ the terrain is created iteratively: for every level the diamond step is
    ‘ performed first for the full terrain, then the square step is performed.
    ‘ input: tSize: size of terrain, (must be [(power of 2) + 1] –> (2^x)+1 ), e.g. 257
    ‘ startRandRange: defines the overall elevation. size/2 gives natural images
    ‘ roughness H: (between 0.0 and 1.0), where:
    ‘ H=0.9 returns a natural value
    ‘ H=0: max. roughness
    ‘ optional: terrain T: T can be a predefined terrain,
    ‘ i.e. every matrix entry ~= inf will NOT be altered.
    ‘ This allows for preshaped terrain building
    ‘ output: terrain T

    Dim Target As Excel.Range
    Dim tSize As Long
    Dim StartRandRange As Double
    Dim H As Double

    Set Target = ActiveSheet.[a1]
    tSize = gSize
    StartRandRange = 64.5 ‘?
    H = 0.9 ‘?

    Call createFractalTerrain(Target, tSize, StartRandRange, H)
    Call PlotSurface(Target)
    End Sub

    Private Sub PlotSurface(ByVal Target As Excel.Range)
    ‘ Paste a 3D surface chart
    Dim oxlWsh As Excel.Worksheet
    Dim oxlChrtObj As Excel.ChartObject
    Dim oxlChrt As Excel.Chart
    Dim oxlShp As Excel.Shape

    With oxlWsh.Parent
    Set Target = .Range(Target, Target.SpecialCells(xlLastCell))

    Set oxlShp = .Shapes.AddChart2(307, xlSurfaceWireframe, 0, 0, 500, 1000)
    Set oxlChrt = oxlShp.Chart
    Set oxlChrtObj = oxlChrt.Parent
    oxlChrt.SetSourceData source:=.Range(“‘” & Target.Parent.Name & “‘!” & Target.Address(True, True))

    With oxlChrtObj
    ‘.Chart.PlotArea
    ‘.Chart.ChartArea
    End With

    With oxlShp
    .Left = 0
    .Top = 0

    ‘ Chart Dimension & Location setting:
    ‘.IncrementLeft -500
    ‘.IncrementTop -100
    ‘.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
    ‘.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft

    .ThreeD.RotationX = -100 ’10
    .ThreeD.RotationY = -170 ‘

    ‘ Top view: X:0 Y=-90
    ‘.ThreeD.RotationX = 0
    ‘.ThreeD.RotationY = 0

    .ThreeD.FieldOfView = 0 ‘ ranges 0 to 120

    .ThreeD.Visible = msoFalse
    End With
    End With
    End Sub

    Private Function createFractalTerrain(ByVal Target As Excel.Range, _
    ByVal gSize As Long, _
    ByVal StartRandRange As Double, _
    ByVal H As Double) As Variant
    ‘ Function creates fractal terrain by midpoint displacement (diamond square algorithm)
    ‘ Outputs a [tsize by tsize] matrix

    Dim i As Long, j As Long
    Dim randRange As Double
    Dim tSize As Long

    With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    End With

    For i = 1 To gSize
    For j = 1 To gSize
    TR(i, j) = 10000
    Next
    Next

    ‘ Set extremes to zero??
    TR(1, 1) = 0 ‘?
    TR(1, gSize) = 0 ‘?
    TR(gSize, 1) = 0 ‘?
    TR(gSize, gSize) = 0 ‘?

    tSize = gSize – 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

    Target.Resize(gSize, gSize).Value2 = TR()

    With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    End With
    End Function

    Private Sub diamondStep(ByVal tSize As Long, ByVal randRange As Double)
    Dim Sh As Long
    Dim maxIndex As Long ‘ size of terrain
    Dim RowVal As Long, ColVal As Long ‘ the indices of each diamond’s centerpoint

    Dim ValueH As Double
    Dim Displacement 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

    Private Sub squareStep(ByVal tSize As Long, ByVal randRange As Double)
    Dim Sh As Long
    Dim maxIndex As Long
    Dim RowVal As Long
    Dim ColVal As Long
    Dim colStart As Long

    Dim ValueH As Double
    Dim Displacement As Double
    Dim NOP As Double

    Sh = tSize \ 2
    maxIndex = UBound(TR, 1)
    colStart = 1 + Sh
    RowVal = 1
    ColVal = colStart

    While (RowVal <= maxIndex)
    While (ColVal 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 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
    [/CODE]

    Enjoy!


Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published. Required fields are marked *