Procedural World Generator

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

Procedural World Generator

Postby duke4e » Jul 28, 2008 1:37

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:

Postby KristopherWindsor » Jul 28, 2008 5:34

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

Re: Procedural World Generator

Postby KLBear » Jul 29, 2008 0:24

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

Postby tinram » Jul 30, 2008 20:45

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:

Postby Voltage » Jul 30, 2008 23:08

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

Postby 1000101 » Jul 31, 2008 1:28

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:

Postby duke4e » Aug 04, 2008 22:46

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:

Postby duke4e » Aug 05, 2008 22:44

@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

Postby tincrowdor » Aug 09, 2008 6:40

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.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 2 guests