VB Perlin Noise (32K)
1 Nov 2003
First Posted
vbAccelerator - Contents of code file: frmPerlinNoise.frm
VERSION 5.00
Begin VB.Form frmPerlinNoise
Caption = "vbAccelerator - Perlin Noise Demonstration"
ClientHeight = 7275
ClientLeft = 2070
ClientTop = 2535
ClientWidth = 6480
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmPerlinNoise.frx":0000
LinkTopic = "Form1"
ScaleHeight = 485
ScaleMode = 3 'Pixel
ScaleWidth = 432
Begin VB.HScrollBar hscScale
Height = 255
Left = 4680
Max = 16
Min = 1
TabIndex = 5
Top = 1440
Value = 1
Width = 1695
End
Begin VB.CheckBox chkAbsolute
Caption = "&Use Absolute Value"
Height = 255
Left = 4680
TabIndex = 4
Top = 780
Width = 1695
End
Begin VB.HScrollBar hscOctaves
Height = 255
Left = 4680
Max = 6
Min = 1
TabIndex = 3
Top = 420
Value = 1
Width = 1695
End
Begin VB.CommandButton cmdAnimate
Caption = "&Go"
Height = 495
Left = 5280
TabIndex = 0
Top = 6300
Width = 975
End
Begin VB.Label lblScale
Caption = "&Scale"
Height = 195
Left = 4680
TabIndex = 6
Top = 1200
Width = 1695
End
Begin VB.Label lblOctaves
Caption = "&Octaves"
Height = 195
Left = 4680
TabIndex = 2
Top = 180
Width = 1695
End
Begin VB.Label lblFPS
Caption = "FPS: "
Height = 255
Left = 240
TabIndex = 1
Top = 6360
Width = 4935
End
End
Attribute VB_Name = "frmPerlinNoise"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr()
As Any) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private m_cPerlin As New cPerlin3D
Private m_cDib As New cDIBSection
Private m_calcTime As Long
Private m_totTime As Long
Private m_frames As Long
Private m_z As Double
Private m_zStep As Double
Private m_octaves As Long
Private m_bAbsolute As Boolean
Private m_scale As Double
Private Sub Render()
m_cDib.PaintPicture Me.hdc, 16, 16
End Sub
Private Sub chkAbsolute_Click()
m_bAbsolute = (chkAbsolute.Value = Checked)
End Sub
Private Sub cmdAnimate_Click()
Dim x As Double
Dim y As Double
Dim xStep As Double
Dim yStep As Double
Dim xO As Double
Dim yO As Double
Dim zO As Double
Dim l As Double
Dim i As Double
Dim px As Long
Dim py As Long
Dim pxEnd As Long
Dim pyEnd As Long
Dim lTime As Long
Dim r As Double
Dim g As Double
Dim b As Double
Dim bDib() As Byte
Dim tSA As SAFEARRAY2D
If (cmdAnimate.Caption = "&Go") Then
cmdAnimate.Caption = "&Stop"
pxEnd = m_cDib.BytesPerScanLine
pyEnd = m_cDib.Height
xStep = 1# / (m_cDib.Width / (m_scale * 2#))
yStep = 1# / (m_cDib.Height / (m_scale * 2#))
' Get the bits in the from DIB section:
With tSA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = m_cDib.Height
.Bounds(1).lLbound = 0
.Bounds(1).cElements = m_cDib.BytesPerScanLine
.pvData = m_cDib.DIBSectionBitsPtr
End With
CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
Do
lTime = timeGetTime()
m_z = m_z + m_zStep
px = 0
For x = -m_scale To m_scale Step xStep
py = 0
For y = -m_scale To m_scale Step yStep
l = m_cPerlin.Noise(x, y, m_z)
If (m_bAbsolute) Then
l = Abs(l)
If (m_octaves > 1) Then
xO = x
yO = y
zO = m_z
i = 1#
Do
xO = xO + xO
yO = yO + yO
' 'xO = yO + xO - turn on for streaks
' 'yO = xO + yO - turn on for streaks
zO = zO + zO
i = i + i
l = l + Abs(m_cPerlin.Noise(xO, yO, zO) / i)
Loop While (i < m_octaves)
If (l > 1#) Then l = 1#
End If
r = 255 * l
Else
If (m_octaves > 1) Then
xO = x
yO = y
zO = m_z
i = 1#
Do
xO = xO + xO
yO = yO + yO
' 'xO = yO + xO - turn on for streaks
' 'yO = xO + yO - turn on for streaks
zO = zO + zO
i = i + i
l = l + m_cPerlin.Noise(xO, yO, zO) / i
Loop While (i < m_octaves)
End If
' Adjust colour in range 0-255
r = 128 + 128 * l
' Check for out of bounds
If (r > 255) Then r = 255
If (r < 0) Then r = 0
End If
bDib(px, py) = r
bDib(px + 1, py) = r
bDib(px + 2, py) = r
py = py + 1
If (py >= pyEnd) Then
Exit For
End If
Next y
px = px + 3
If (px >= pxEnd) Then
Exit For
End If
Next x
'm_frames = m_frames + 1
m_calcTime = timeGetTime() - lTime
If (m_calcTime = 0) Then m_calcTime = 1
Render
m_totTime = timeGetTime() - lTime
If (m_totTime = 0) Then m_totTime = 1
' FPS:
lblFPS.Caption = "FPS: Calculation: " & Format$(1000# / m_calcTime,
"00.00") & _
", Total: " & Format$(1000# / m_totTime, "00.00")
DoEvents
Loop While (cmdAnimate.Caption = "&Stop")
' Clear the temporary array descriptor
' (This does not appear to be necessary, but
' for safety do it anyway)
CopyMemory ByVal VarPtrArray(bDib), 0&, 4
Else
cmdAnimate.Caption = "&Go"
End If
End Sub
Private Sub Form_Load()
Set m_cPerlin = New cPerlin3D
Set m_cDib = New cDIBSection
m_cDib.Create 128, 128 ' g256, 256
' Initial Z
m_z = 0.01
' Step in Z direction
m_zStep = 0.03
' Initial Scale
m_scale = 4
hscOctaves_Change
hscScale_Change
End Sub
Private Sub hscOctaves_Change()
lblOctaves.Caption = "Octaves: " & hscOctaves.Value
m_octaves = 2 ^ (hscOctaves.Value - 1)
End Sub
Private Sub hscScale_Change()
lblScale.Caption = "Scale: " & hscScale.Value
m_scale = hscScale.Value
End Sub