Island Generator

Generates some islands. The elevation run from 0 to 255.

'Island Generator
'Based on tutorial at:
'http://www.robot-frog.com/3d/index.html
'Richard D. Clark
'Public Domain
'Space to regen, esc to exit
'+++++++++++++++++++++++++++++++++++++++++++

#define sw 320
#define sh 240
#define hiter 400

Dim Shared hm(sw * sh) As Integer
Dim Shared thm(sw * sh) As Integer
Dim Shared nhm(sw * sh) As Single
Dim Shared palmap(sw * sh) As Integer
Dim Shared pal(0 To 255) As Uinteger
Dim Shared As Integer max = 0, min = 100000
Dim Key As String

Function Rand(lowerbound As Integer, upperbound As Integer) As Integer
   Return Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
End Function

Sub GeneratePalette
    Dim As Integer i, r, g, b

    '0 to 50
    r = 0
    g = 0
    b = 100
    For i = 0 To 50
        pal(i) = RGB(r, g, b)
        b += 1
    Next
    '51 to 100
    r = 100
    g = 100
    b = 0
    For i = 51 To 100
        pal(i) = RGB(r, g, b)
        r += 1
        g += 1
        b += 1
    Next
    '101 to 150
    For i = 101 To 150
        pal(i) = RGB(r, g, b)
        r += 1
        g += 1
    Next
    '151 to 200
    r = 255
    g = 199
    b = 122
    For i = 151 To 240
        pal(i) = RGB(r, g, b)
        r -= 1
        g -= 1
        b -= 1
    Next
    '241 to 255
    r = 158
    g = 158
    b = 158
    For i = 241 To 255
        pal(i) = RGB(r, g, b)
        r += 2
        g += 2
        b += 2
    Next

End Sub

Sub GenerateHM
    Dim As Integer i, x, y, r, cx, cy

    For i = 1 To hiter
        r = Rand(5, 60)
        cx = Rand(0, sw - 1)
        cy = Rand(0, sh - 1)
        For x = 0 To sw - 1
            For y = 0 To sh - 1
                thm(x + y * sw) = (r * r) -((x - cx) * (x - cx) + (y - cy) * (y - cy))
                If thm(x + y * sw) < 0 Then thm(x + y * sw) = 0
                hm(x + y * sw) = hm(x + y * sw) + thm(x + y * sw)
                If hm(x + y * sw) >= max Then max = hm(x + y * sw)
                If hm(x + y * sw) <= min Then min = hm(x + y * sw)
            Next
        Next
    Next

End Sub

Sub Normalize
    Dim As Integer x, y

    'Normalize
    For x = 0 To sw - 1
        For y = 0 To sh - 1
            nhm(x + y * sw) = (hm(x + y * sw) - min) / (max - min)
            'Flatten
            nhm(x + y * sw) = nhm(x + y * sw) * nhm(x + y * sw)
            'Generate palmap
            palmap(x + y * sw) =  nhm(x + y * sw) * 255
        Next
    Next

End Sub

Sub ShowMap
    Dim As Integer x, y

    screenlock
    For x = 0 To sw - 1
        For y = 0 To sh - 1
            Pset (x, y), pal(palmap(x + y * sw))
        Next
    Next
    screenunlock
End Sub

Randomize Timer
screenres sw, sh, 32

GeneratePalette
GenerateHM
Normalize
ShowMap

Do
    Key = Inkey
    If Key = Chr(32) Then
        Cls
        Erase hm
        Erase thm
        Erase nhm
        Erase palmap
        GenerateHM
        Normalize
        ShowMap
    End If

Loop Until Key = Chr(27)
Unless otherwise stated, the content of this page is licensed under Creative Commons Attribution-Share Alike 2.5 License.