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)