Procedural World Generator

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Procedural World Generator

Post by duke4e »

This is some fun code I wrote so I wanted to share it with you.
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
Screenshot:
http://i178.photobucket.com/albums/w247/duke4e/1.jpg
KristopherWindsor
Posts: 2428
Joined: Jul 19, 2006 19:17
Location: Sunnyvale, CA
Contact:

Post by KristopherWindsor »

Nice! :-)
KLBear
Posts: 113
Joined: Jul 23, 2008 9:32

Re: Procedural World Generator

Post by KLBear »

Excellent Code
tinram
Posts: 89
Joined: Nov 30, 2006 13:35
Location: UK

Post by tinram »

Good use of Perlin noise. The rendering seems reasonably fast despite all the sub/fn calls.
Voltage
Posts: 110
Joined: Nov 19, 2005 7:36
Location: Sydney, Australia
Contact:

Post by Voltage »

This looks great.

It makes me want to code a little boat to navigate around.
1000101
Posts: 2556
Joined: Jun 13, 2005 23:14
Location: SK, Canada

Post by 1000101 »

I am quite impressed with the results of that. I'm looking for something almost exactly as that, email me if your interested in developing that a bit further.
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Post by duke4e »

thanks for your comments. sorry to not reply sooner, i was on vacation.
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Post by duke4e »

@1000101

i don't see your email in profile. give me your email or mail me at duke4e (at) gmail DOT com
tincrowdor
Posts: 9
Joined: Aug 07, 2008 6:26

Post by tincrowdor »

Nice code for this. I have been working on a more basic version of code for something very similar. I'll try to dig it out and post as an alternative.
Post Reply