It generates pretty nice tileable procedural worlds.
Code: Select all
#include "fbgfx.bi"
Const xres = 1024
Const yres = 768
Screenres xres, yres, 32,, 1
Const Pi = Atn(1) * 4
Const RAD = Pi / 180
Dim Shared As Uinteger texture_tmp(xres - 1, yres - 1)
randomize timer
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
#define GetR(_c) ((_c Shr 16) And &hFF)
#define GetG(_c) ((_c Shr 8) And &hFF)
#define GetB(_c) ((_c ) And &hFF)
#define Blend_Multiply(_a, _b) ((_a * _b) shr 8)
Function Interpolate(y1 As Single, y2 As Single, mu As Single, interpolation_method As Ubyte = 0) As Single
Select Case interpolation_method
Case 0
Return y1 * (1 - mu) + y2 * mu
Case 1
Dim As Single mu2 = (1 - Cos(mu * PI)) * 0.5f
Return (y1 * (1 - mu2)) + (y2 * mu2)
End Select
End Function
Function rand(first As Integer, last As Integer) As Integer
Function = Cint(Rnd * (last - first) + first)
End Function
Function randf(a As Single, b As Single) As Single
Function = Rnd * (b - a) + a
End Function
Function Clamp(x As Integer) As Ubyte
If x < 0 Then x = 0
If x > 255 Then x = 255
Clamp = x
End Function
Function WrapX(x As Integer) As Integer
While x > (xres - 1)
x -= xres
Wend
While x < 0
x += xres
Wend
Return x
End Function
Function WrapY(y As Integer) As Integer
While y > (yres - 1)
y -= yres
Wend
While y < 0
y += yres
Wend
Return y
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Perlin
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
#define FADE(_t) (_t * _t * _t * (_t * (_t * 6 - 15) + 10))
#define NLERP(_t, _a, _b) ((_a) + (_t)*((_b)-(_a)))
Dim Shared As Ubyte perm(512)
For i As Integer = 0 To 255
perm(i) = rand(0, 255)
perm(i + 256) = perm(i)
Next
Dim Shared As Single ms_grad4(512)
Dim As Single kkf(256)
For i As Integer = 0 To 255
kkf(i) = -1.0f + 2.0f * (i / 255.0f)
Next
For i As Integer = 0 To 255
ms_grad4(i) = kkf(perm(i)) * 0.507f
Next
Function Noise(x As Single, y As Single, px As Integer, py As Integer) As Single
Dim As Integer ix0 = Any, iy0 = Any, ix1 = Any, iy1 = Any
Dim As Single fx0 = Any, fy0 = Any
Dim As Single s = Any, t = Any, nx0 = Any, nx1 = Any, n0 = Any, n1 = Any
ix0 = Cint(x - 0.5f)
iy0 = Cint(y - 0.5f)
fx0 = x - ix0
fy0 = y - iy0
If px < 1 Then px = 1
If py < 1 Then py = 1
ix1 = ((ix0 + 1) Mod px) And &hff
iy1 = ((iy0 + 1) Mod py) And &hff
ix0 = (ix0 Mod px) And &hff
iy0 = (iy0 Mod py) And &hff
t = FADE(fy0)
s = FADE(fx0)
nx0 = ms_grad4(perm(ix0 + perm(iy0)))
nx1 = ms_grad4(perm(ix0 + perm(iy1)))
n0 = NLERP( t, nx0, nx1 )
nx0 = ms_grad4(perm(ix1 + perm(iy0)))
nx1 = ms_grad4(perm(ix1 + perm(iy1)))
n1 = NLERP(t, nx0, nx1)
Return NLERP(s, n0, n1)
End Function
Function Turbulence(x As Integer, y As Integer, size As Integer) As Ubyte
' size must be 2 ^ n
Dim As Single value = 0.0
Dim As Integer initialSize = size
While(size >= 1)
value += Noise(x / size, y / size, xres / size, yres / size) * size
size /= 2.0f
Wend
Return (128.0 * value / initialSize) + 127
End Function
Function TurbulenceABS(x As Integer, y As Integer, size As Integer) As Ubyte
' size must be 2 ^ n
Dim As Single value = 0.0
Dim As Integer initialSize = size
While(size >= 1)
value += Noise(x / size, y / size, xres / size, yres / size) * size
size /= 2.0f
Wend
Return Abs(256.0 * value / initialSize)
End Function
Sub Generator_PerlinNoise(array() As Uinteger, size As Integer, ntype As Integer = 1)
Dim As Ubyte bw
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
Select Case ntype
Case 1
bw = Turbulence(x, y, size)
array(x, y) = Rgba(bw, bw, bw, 255)
Case 2
bw = TurbulenceABS(x, y, size)
array(x, y) = Rgba(bw, bw, bw, 255)
End Select
Next
Next
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Blend
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Effect_Blend(texture1() As Uinteger, texture2() As Uinteger)
Dim As Ubyte r1, g1, b1, r2, g2, b2, r, g, b
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
r1 = GetR(texture1(x, y))
g1 = GetG(texture1(x, y))
b1 = GetB(texture1(x, y))
r2 = GetR(texture2(x, y))
g2 = GetG(texture2(x, y))
b2 = GetB(texture2(x, y))
r = Blend_Multiply(r1, r2)
g = Blend_Multiply(g1, g2)
b = Blend_Multiply(b1, b2)
texture1(x, y) = Rgb(r, g, b)
texture2(x, y) = texture1(x, y)
Next
Next
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Uniform Blur
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub BlurHorizontal(texture1() As Uinteger, radius As Integer)
For y As Integer = 0 To yres - 1
Dim As Integer totalR = 0
Dim As Integer totalG = 0
Dim As Integer totalB = 0
' Process entire window for first pixel
For kx As Integer = -radius To radius
Dim As Integer kx2 = kx
If kx2 < 0 Then kx2 += xres
If kx2 >= xres Then kx2 -= xres
totalR += GetR(texture1(kx2, y))
totalG += GetG(texture1(kx2, y))
totalB += GetB(texture1(kx2, y))
Next
texture_tmp(0, y) = Rgb(totalR / (radius * 2 + 1), totalG / (radius * 2 + 1), totalB / (radius * 2 + 1))
' Subsequent pixels just update window total
For x As Integer = 1 To xres - 1
Dim As Integer myrad1 = x - radius - 1
Dim As Integer myrad2 = x + radius
If myrad1 < 0 Then myrad1 += xres
If myrad2 >= xres Then myrad2 -= xres
' Subtract pixel leaving window
totalR -= GetR(texture1(myrad1, y))
totalG -= GetG(texture1(myrad1, y))
totalB -= GetB(texture1(myrad1, y))
' Add pixel entering window
totalR += GetR(texture1(myrad2, y))
totalG += GetG(texture1(myrad2, y))
totalB += GetB(texture1(myrad2, y))
texture_tmp(x, y) = Rgb(totalR / (radius * 2 + 1), totalG / (radius * 2 + 1), totalB / (radius * 2 + 1))
Next
Next
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
texture1(x, y) = texture_tmp(x, y)
Next
Next
End Sub
Sub BlurVertical(texture1() As Uinteger, radius As Integer)
For x As Integer = 0 To xres - 1
Dim As Integer totalR = 0
Dim As Integer totalG = 0
Dim As Integer totalB = 0
' Process entire window for first pixel
For ky As Integer = -radius To radius
Dim As Integer ky2 = ky
If ky2 < 0 Then ky2 += yres
If ky2 >= yres Then ky2 -= yres
totalR += GetR(texture1(x, ky2))
totalG += GetG(texture1(x, ky2))
totalB += GetB(texture1(x, ky2))
Next
texture_tmp(x, 0) = Rgb(totalR / (radius * 2 + 1), totalG / (radius * 2 + 1), totalB / (radius * 2 + 1))
' Subsequent pixels just update window total
For y As Integer = 1 To yres - 1
' Subtract pixel leaving window
Dim As Integer myrad1 = y - radius - 1
Dim As Integer myrad2 = y + radius
If myrad1 < 0 Then myrad1 += yres
If myrad2 >= yres Then myrad2 -= yres
totalR -= GetR(texture1(x, myrad1))
totalG -= GetG(texture1(x, myrad1))
totalB -= GetB(texture1(x, myrad1))
' Add pixel entering window
totalR += GetR(texture1(x, myrad2))
totalG += GetG(texture1(x, myrad2))
totalB += GetB(texture1(x, myrad2))
texture_tmp(x, y) = Rgb(totalR / (radius * 2 + 1), totalG / (radius * 2 + 1), totalB / (radius * 2 + 1))
Next
Next
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
texture1(x, y) = texture_tmp(x, y)
Next
Next
End Sub
Sub Uniform_Blur(texture1() As Uinteger, xradius As Integer, yradius As Integer, iterations As Integer = 1)
For i As Integer = 1 To iterations
If xradius > 0 Then BlurHorizontal(texture1(), xradius)
If yradius > 0 Then BlurVertical(texture1(), yradius)
Next
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Texture Normalization
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Effect_Normalize(array() As Uinteger)
Dim As Integer minvalue = 255
Dim As Integer maxvalue = 0
Dim As Integer current
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
current = GetR(array(x, y))
If current < minvalue Then minvalue = current
If current > maxvalue Then maxvalue = current
current = GetG(array(x, y))
If current < minvalue Then minvalue = current
If current > maxvalue Then maxvalue = current
current = GetB(array(x, y))
If current < minvalue Then minvalue = current
If current > maxvalue Then maxvalue = current
Next
Next
Dim As Single r, g, b
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
r = GetR(array(x, y)) - minvalue
g = GetG(array(x, y)) - minvalue
b = GetB(array(x, y)) - minvalue
array(x, y) = Rgb(r, g, b)
Next
Next
Dim As Single ratio = 255 / (maxvalue - minvalue)
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
r = Clamp(GetR(array(x, y)) * ratio)
g = Clamp(GetG(array(x, y)) * ratio)
b = Clamp(GetB(array(x, y)) * ratio)
array(x, y) = Rgb(r, g, b)
Next
Next
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Colorize Segment
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Effect_ColorizeSegment(array() As Uinteger, minvalue As Uinteger, maxvalue As Uinteger, color1 As Uinteger, color2 As Uinteger, doinvert As Integer = 0, interpolation As Integer = 0)
Dim As Ubyte r1 = GetR(color1), g1 = GetG(color1), b1 = GetB(color1)
Dim As Ubyte r2 = GetR(color2), g2 = GetG(color2), b2 = GetB(color2)
Dim As Ubyte minvaluer = GetR(minvalue), minvalueg = GetG(minvalue), minvalueb = GetB(minvalue)
Dim As Ubyte maxvaluer = GetR(maxvalue), maxvalueg = GetG(maxvalue), maxvalueb = GetB(maxvalue)
If doinvert = 1 Then
Swap r1, r2
Swap g1, g2
Swap b1, b2
End If
Dim As Single ranger = Abs(minvaluer - maxvaluer)
Dim As Single rangeg = Abs(minvalueg - maxvalueg)
Dim As Single rangeb = Abs(minvalueb - maxvalueb)
Dim As Ubyte r, g, b
Dim As Single distr, distg, distb
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
r = GetR(array(x, y))
g = GetG(array(x, y))
b = GetB(array(x, y))
If (r >= minvaluer And r <= maxvaluer) And (g >= minvalueg And g <= maxvalueg) And (b >= minvalueb And b <= maxvalueb) Then
distr = GetR(array(x, y)) - minvaluer
distg = GetG(array(x, y)) - minvalueg
distb = GetB(array(x, y)) - minvalueb
distr /= ranger
distg /= rangeg
distb /= rangeb
array(x, y) = Rgb(Interpolate(r1, r2, distr, interpolation), Interpolate(g1, g2, distg, interpolation), Interpolate(b1, b2, distb, interpolation))
Else
array(x, y) = Rgb(r, g, b)
End If
Next
Next
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Conditional Emboss
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Effect_ConditionalEmboss(texture1() As Uinteger, color1 As Uinteger, color2 As Uinteger, azimuth As Single, elevation As Single, width45 As Single)
Dim As Ubyte r1 = GetR(color1), g1 = GetG(color1), b1 = GetB(color1)
Dim As Ubyte r2 = GetR(color2), g2 = GetG(color2), b2 = GetB(color2)
azimuth *= RAD
elevation *= RAD
Dim As Integer Nx, Ny, Nz, Lx, Ly, Lz, Nz2, NzLz, NdotL, shade
Dim As Ubyte r, g, b
Lx = Cos(azimuth) * Cos(elevation) * 255.9f
Ly = Sin(azimuth) * Cos(elevation) * 255.9f
Lz = Sin(elevation) * 255.9f
Nz = (6 * 255) / width45
Nz2 = Nz * Nz
NzLz = Nz * Lz
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
Dim As Integer a, b, c, d
r = GetR(texture1(x, y))
g = GetG(texture1(x, y))
b = GetB(texture1(x, y))
If (r >= r1 And r <= r2) And (g >= g1 And g <= g2) And (b >= b1 And b <= b2) Then
texture_tmp(x, y) = Rgb(r, g, b)
Else
a = GetR(texture1(WrapX(x + 1), y)) + GetG(texture1(WrapX(x + 1), y)) + GetB(texture1(WrapX(x + 1), y))
b = GetR(texture1(WrapX(x - 1), y)) + GetG(texture1(WrapX(x - 1), y)) + GetB(texture1(WrapX(x - 1), y))
c = GetR(texture1(x, WrapY(y + 1))) + GetG(texture1(x, WrapY(y + 1))) + GetB(texture1(x, WrapY(y + 1)))
d = GetR(texture1(x, WrapY(y - 1))) + GetG(texture1(x, WrapY(y - 1))) + GetB(texture1(x, WrapY(y - 1)))
nx = (a - b)
ny = (c - d)
NdotL = Nx * Lx + Ny * Ly + NzLz
If Nx = 0 And Ny = 0 Then
shade = Lz
Elseif NdotL < 0 Then
shade = 0
Else
shade = NdotL / Sqr(Nx * Nx + Ny * Ny + Nz2)
End If
shade = Clamp(shade)
texture_tmp(x, y) = Rgb(shade, shade, shade)
End If
Next
Next
Effect_Blend texture1(), texture_tmp()
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Render
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Render(texture() As Uinteger)
Dim As Integer counter
Screenlock
For x As Integer = 0 To xres - 1 Step 10
For y As Integer = 0 To yres - 1 Step 10
Dim As Uinteger mycolor
If counter Mod 2 = 1 Then mycolor = Rgb(255, 255, 255) Else mycolor = Rgb(200, 200, 200)
Line(x, y)-(x + 10, y + 10), mycolor, bf
counter += 1
Next
If x Mod 20 = 0 Then counter = 0 Else counter = 1
Next
For x As Integer = 0 To xres - 1
For y As Integer = 0 To yres - 1
Pset(x, y), texture(x, y)
Next
Next
Screenunlock
End Sub
Dim Shared As Uinteger mytexture(xres - 1, yres - 1)
Generator_PerlinNoise mytexture(), 128, 1
Effect_Normalize mytexture()
Effect_ColorizeSegment mytexture(), Rgb(0, 0, 0), Rgb(130, 130, 130), Rgb(19, 153, 210), Rgb(50, 196, 240)
Effect_ColorizeSegment mytexture(), Rgb(131, 131, 131), Rgb(255, 255, 255), Rgb(53, 66, 23), Rgb(90, 94, 57)
Uniform_Blur mytexture(), 1, 1, 2
Effect_ConditionalEmboss mytexture(), Rgb(19, 153, 210), Rgb(50, 196, 240), 145, 10, 200
Effect_Normalize mytexture()
Render mytexture()
Sleep
http://i178.photobucket.com/albums/w247/duke4e/1.jpg