Island Generator

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
rdc
Posts: 1741
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Island Generator

Post by rdc »

Came across the tutorial listed in source and hacked his together. Needs a lot of improvement though.

Code: Select all

'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)
steven522
Posts: 265
Joined: May 27, 2005 13:02
Location: Alabama, USA
Contact:

Post by steven522 »

Interesting. Some of the "island" edges seem to actually go off the edge of the window. It would look better if it were always completely surrounded by water.
rdc
Posts: 1741
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Post by rdc »

Yeah, that is in the tutorial, but I didn't add it in. It is pretty slow as it is right now. This was just a quickie to see how the algo worked. Feel free to improve and use.
tinram
Posts: 89
Joined: Nov 30, 2006 13:35
Location: UK

Post by tinram »

Nice colour palette.
Yes it is quite slow for a 320 x 240 window with screenlock (using a P4 3.2) (and it maxes the processor between plots).

I tried it with 8bpp to see how much faster it might be...

Code: Select all

screenres sw, sh, 8
...didn't make much difference, but did produce psychedelic colours.

groovy!
1000101
Posts: 2556
Joined: Jun 13, 2005 23:14
Location: SK, Canada

Post by 1000101 »

It's the large 32-bit element (integer) arrays which make it slow. It spends most of it's time in the "GenerateHM" function.
rdc
Posts: 1741
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Post by rdc »

Actually, I did this for an ascii game I am working on, so it is fast enough for my purposes:

Image
cha0s
Site Admin
Posts: 5319
Joined: May 27, 2005 6:42
Location: USA
Contact:

Post by cha0s »

Nice, thanks for that
rdc
Posts: 1741
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Post by rdc »

Thanks man. What stuck me about this was the simplicity of the algo. I have seen other methods that were much more complicated, but didn't produce much better results. This would probably work much better using OGL since you wouldn't have to work with such a big array.
cha0s
Site Admin
Posts: 5319
Joined: May 27, 2005 6:42
Location: USA
Contact:

Post by cha0s »

Code: Select all

'Island Generator
'Based on tutorial at:
'http://www.robot-frog.com/3d/index.html
'Richard D. Clark and cha0s
'Public Domain
'Space to regen, esc to exit
'+++++++++++++++++++++++++++++++++++++++++++


#define sw 400
#define sh 400
#define hiter 300
#define rad_low 10
#define rad_high 40

#define minsize (sh*.5)

Dim Shared hm(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(byref lowerbound As double, byref upperbound As double) As double
   function = ((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)
        if (i and 1) = 0 then
        	 b += 1
       	end if
    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 double ox, oy, cx, cy, bx, by
    dim as double r, theta, distance, ti
    dim as integer tmp
	
    For i as integer = 1 To hiter
        r = Rand(rad_low, rad_high)
	    theta = rand(0, atn(1) * 8)
	    distance = rand((rad_high-rad_low)*1, minsize - r)
        r *= r
        ox = 0-((sw/2) + cos(theta) * distance)
        oy = 0-((sh/2) + sin(theta) * distance)
        cy = oy
       	by = oy * oy
        for row as integer = 0 to sw*sh-1 step sw
	       	cx = ox
        	bx = cx * cx
	        For loc_ as integer ptr = @hm(row) To @hm(row) + (sw) - 1
	        	tmp = *loc_
	        	ti = r -(bx + by)
	            If ti < 0 Then ti = 0
	            tmp += ti
	            max = iif( tmp > max, tmp, max )
	            min = iif( tmp < min, tmp, min )
	            *loc_ = tmp
		        bx += cx
		        cx += 1
		        bx += cx
	        Next
	        by += cy
	        cy += 1
	        by += cy
	    next
    Next
   
End Sub

Sub Normalize
    Dim As Integer x, y, idx
   
    'Normalize
    For x = 0 To sw - 1
        For y = 0 To sh - 1
        	idx = x + y * sw
            nhm(idx) = (hm(idx) - min) / (max - min)
            'Flatten
            'nhm(idx) = nhm(idx) * nhm(idx)
            'Generate palmap
            palmap(idx) =  nhm(idx) * 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', , 1

var t = timer
GeneratePalette
GenerateHM
Normalize
ShowMap
? timer - t

Do
    Key = Inkey
    If Key = Chr(32) Then
        Cls
        Erase hm
        Erase nhm
        Erase palmap
        GenerateHM
        Normalize
        ShowMap
    End If
   
Loop Until Key = Chr(27)

Some optimizations and added the polar coordinates calculation to make them true islands ^^. Enjoy, but beware I made the code pretty weird to try to make it faster.
redcrab
Posts: 623
Joined: Feb 07, 2006 15:29
Location: France / Luxemburg
Contact:

Post by redcrab »

I've just change the palette a little bit
-coast and low deep water
-High altitude little bit more snowy

Hope that please


That's fun

Code: Select all

'Island Generator
'Based on tutorial at:
'http://www.robot-frog.com/3d/index.html
'Richard D. Clark and cha0s
'Public Domain
'Space to regen, esc to exit
'+++++++++++++++++++++++++++++++++++++++++++


#define sw 400
#define sh 400
#define hiter 300
#define rad_low 10
#define rad_high 40

#define minsize (sh*.5)

Dim Shared hm(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(Byref lowerbound As Double, Byref upperbound As Double) As Double
   Function = ((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)
        If (i And 1) = 0 Then
        			If i >40 Then 
        			  r += 30 : g +=30	
        			  b += 1
        			Else
        				b+= 1
        			End If
        End If
        
    Next
    '51 to 100
    r = 50
    g = 50
    b = 0
    For i = 51 To 100
        pal(i) = RGB(r, g, b)
        r += 2
        g += 2
        b += 1
    Next
    '101 to 150
    For i = 101 To 150
        pal(i) = RGB(r, g, b)
        r += 1
        g += 1
        b -= 1
    Next
    '151 to 240
    r = 255
    g = 200 '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 = 194
    g = 194
    b = 194
    For i = 241 To 255
        pal(i) = RGB(r, g, b)
        r += 4
        g += 4
        b += 4
    Next
   
End Sub


Sub GenerateHM

        Dim As Double ox, oy, cx, cy, bx, by
    Dim As Double r, theta, distance, ti
    Dim As Integer tmp
       
    For i As Integer = 1 To hiter
        r = Rand(rad_low, rad_high)
            theta = rand(0, Atn(1) * 8)
            distance = rand((rad_high-rad_low)*1, minsize - r)
        r *= r
        ox = 0-((sw/2) + Cos(theta) * distance)
        oy = 0-((sh/2) + Sin(theta) * distance)
        cy = oy
               by = oy * oy
        For row As Integer = 0 To sw*sh-1 Step sw
                       cx = ox
                bx = cx * cx
                For loc_ As Integer Ptr = @hm(row) To @hm(row) + (sw) - 1
                        tmp = *loc_
                        ti = r -(bx + by)
                    If ti < 0 Then ti = 0
                    tmp += ti
                    max = iif( tmp > max, tmp, max )
                    min = iif( tmp < min, tmp, min )
                    *loc_ = tmp
                        bx += cx
                        cx += 1
                        bx += cx
                Next
                by += cy
                cy += 1
                by += cy
            Next
    Next
   
End Sub

Sub Normalize
    Dim As Integer x, y, idx
   
    'Normalize
    For x = 0 To sw - 1
        For y = 0 To sh - 1
                idx = x + y * sw
            nhm(idx) = (hm(idx) - min) / (max - min)
            'Flatten
            'nhm(idx) = nhm(idx) * nhm(idx)
            'Generate palmap
            palmap(idx) =  nhm(idx) * 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', , 1

var t = Timer
GeneratePalette
GenerateHM
Normalize
ShowMap
? Timer - t

Do
    Key = Inkey
    If Key = Chr(32) Then
        Cls
        Erase hm
        Erase nhm
        Erase palmap
        GenerateHM
        Normalize
        ShowMap
    End If
   
Loop Until Key = Chr(27)
cha0s
Site Admin
Posts: 5319
Joined: May 27, 2005 6:42
Location: USA
Contact:

Post by cha0s »

It looks very good, my friend. ;)
rdc
Posts: 1741
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Post by rdc »

cha0s: Excellent work. That is much faster, and looks quite a bit better.

redcrab: Very nice color scheme. Looks very realistic.
redcrab
Posts: 623
Joined: Feb 07, 2006 15:29
Location: France / Luxemburg
Contact:

Post by redcrab »

It's quick and dirty
but I'm not experimented with OpenGL

I pray Dr_D or Relsoft gods to forgive me of my horrible OGL usage

When a Island is nice enough for you press "o" key to see the island in 3D
(3D accelerated card needed: 80000 triangles !)

then press Z or z to rotate the island (you may press X-x or Y-y as well)
if you wanna a new island just press ESC then press space or "o" when desired.


Don't know if it will works on all 3D cards ...

Enjoy !

Code: Select all

'option explicit

#include once "GL/gl.bi"
#include once "GL/glu.bi"
#define SC_ESCAPE &h01
#define SC_1 &h02
#define SC_2 &h03
#define SC_3 &h04
#define SC_4 &h05
#define SC_5 &h06
#define SC_6 &h07
#define SC_7 &h08
#define SC_8 &h09
#define SC_9 &h0A
#define SC_0 &h0B
#define SC_MINUS &h0C
#define SC_EQUALS &h0D
#define SC_BACKSPACE &h0E
#define SC_TAB &h0F
#define SC_Q &h10
#define SC_W &h11
#define SC_E &h12
#define SC_R &h13
#define SC_T &h14
#define SC_Y &h15
#define SC_U &h16
#define SC_I &h17
#define SC_O &h18
#define SC_P &h19
#define SC_LEFTBRACKET &h1A
#define SC_RIGHTBRACKET &h1B
#define SC_ENTER &h1C
#define SC_CONTROL &h1D
#define SC_A &h1E
#define SC_S &h1F
#define SC_D &h20
#define SC_F &h21
#define SC_G &h22
#define SC_H &h23
#define SC_J &h24
#define SC_K &h25
#define SC_L &h26
#define SC_SEMICOLON &h27
#define SC_QUOTE &h28
#define SC_TILDE &h29
#define SC_LSHIFT &h2A
#define SC_BACKSLASH &h2B
#define SC_Z &h2C
#define SC_X &h2D
#define SC_C &h2E
#define SC_V &h2F
#define SC_B &h30
#define SC_N &h31
#define SC_M &h32
#define SC_COMMA &h33
#define SC_PERIOD &h34
#define SC_SLASH &h35
#define SC_RSHIFT &h36
#define SC_MULTIPLY &h37
#define SC_ALT &h38
#define SC_SPACE &h39
#define SC_CAPSLOCK &h3A
#define SC_F1 &h3B
#define SC_F2 &h3C
#define SC_F3 &h3D
#define SC_F4 &h3E
#define SC_F5 &h3F
#define SC_F6 &h40
#define SC_F7 &h41
#define SC_F8 &h42
#define SC_F9 &h43
#define SC_F10 &h44
#define SC_NUMLOCK &h45
#define SC_SCROLLLOCK &h46
#define SC_HOME &h47
#define SC_UP &h48
#define SC_PAGEUP &h49
#define SC_LEFT &h4B
#define SC_RIGHT &h4D
#define SC_PLUS &h4E
#define SC_END &h4F
#define SC_DOWN &h50
#define SC_PAGEDOWN &h51
#define SC_INSERT &h52
#define SC_DELETE &h53
#define SC_F11 &h57
#define SC_F12 &h58

#define sw 400
#define sh 400
#define hiter 300
#define rad_low 10
#define rad_high 40
#define minsize (sh*.5)
Dim Shared palmap(sw * sh) As Integer
Dim Shared pal(0 To 255) As Uinteger


Dim Shared colormap(0 To 65536*3-1) As UByte
Dim Shared texture (0 To 0) As UInteger

Sub Init()
	screen 18, 16, , 3
	dim LightAmbient(0 to 3) as single => {0.1, 0.1, 0.1, 1.0}  
	dim LightDiffuse(0 to 3) as single => {1.0, 1.0, 1.0, 1.0} 
	dim LightPosition(0 to 3) as single => {0.0, 0.0, -3.0, 1.0}
	dim as single LightSpc(0 to 3) => {0, 0, 0, 1.0}   
	dim as single MatAmb(0 to 3) => {0.1, 0.1, 0.1, 1.0}
	dim as single MatDif(0 to 3) => {1.0, 1.0, 1.0, 1.0}
	dim as single MatSpc(0 to 3) => {1.0, 1.0, 1.0, 1.0}
	dim as single MatShn(0) => {0}  
	Dim As UInteger x,y,c
	 ' create color map
	For y = 0 To 127
		For x = 0 To 255
			c = x or (y Shl 8)
			colormap(c*3 + 0) = Cast(UByte,(c and &h00007c00) Shr 7)  'red
			colormap(c*3 + 1) = Cast(UByte,(c And &h000003e0) Shr 2) ' green 
			colormap(c*3 + 2) = Cast(UByte,(c And &h0000001f) Shl 3) ' blue 
		Next x
	Next y	                    
	
	glViewport 0, 0, 640, 480                      
	glMatrixMode GL_PROJECTION                     
	glLoadIdentity                                 
	gluPerspective 22.0, 640.0/480.0, 0.1, 100.0   
	glMatrixMode GL_MODELVIEW                      
	glLoadIdentity                                 
	
	glGenTextures 1, @texture(0)                    '' Create The Texture
	
	' Create Nearest Filtered Texture
	glBindTexture GL_TEXTURE_2D, texture(0)
	glTexParameteri GL_TEXTURE_2D,GL_TEXTURE_MAG_FILTER, GL_NEAREST
	glTexParameteri GL_TEXTURE_2D,GL_TEXTURE_MIN_FILTER, GL_NEAREST
	glTexImage2D GL_TEXTURE_2D, 0, 3, 256, 256, 0, GL_RGB, GL_UNSIGNED_BYTE, @colormap(0) ' TextureImage(0)->buffer

	glShadeModel GL_SMOOTH 
  	glEnable GL_TEXTURE_2D                         '' Enable Texture Mapping
	glClearColor 0.2, 0.2, 0.2, 0.5                
	glClearDepth 1.0                               
	glEnable GL_DEPTH_TEST                         
	glDepthFunc GL_LEQUAL                          
	glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST
    
	glLightfv GL_LIGHT1, GL_AMBIENT, @LightAmbient(0)
	glLightfv GL_LIGHT1, GL_DIFFUSE, @LightDiffuse(0)
    glLightfv GL_LIGHT1, GL_POSITION, @LightPosition(0)
	glLightfv(GL_LIGHT1, GL_SPECULAR, @LightSpc(0))
	glEnable GL_LIGHT1
    glEnable(GL_LIGHTING) 
    
	glMaterialfv(GL_FRONT, GL_AMBIENT, @MatAmb(0))
	glMaterialfv(GL_FRONT, GL_DIFFUSE, @MatDif(0))
	glMaterialfv(GL_FRONT, GL_SPECULAR, @MatSpc(0))
	glMaterialfv(GL_FRONT, GL_SHININESS, @MatShn(0))
	'glCullFace(GL_BACK)
	'glEnable(GL_CULL_FACE) 
   'glPolygonMode GL_FRONT, GL_LINE 
end sub

'************* DATA ****************
type t_vector
   as single x,y,z
end type

type t_face
    as t_vector p1,p2,p3,pn
    as single red,green,blue
end type

Type t_model
  faces as t_face ptr
  nbfaces as integer
End Type
' MESH DATA for land
dim shared land(1 to  80000) as t_face 
enum modelID
   _land_ = 1
end enum

dim shared models(1 to 1) as t_model

models(_land_).faces = @land(1)
models(_land_).nbfaces = ubound(land)


  
sub DrawModel(aModel as t_model)
dim as uinteger index,c,ub
Dim As Single u,v

ub = aModel.nbfaces-1
glBegin(GL_TRIANGLES)

for index = 0 to ub 
	with aModel.faces[index]
		c = int(.red*31.0) Shl 10 + Int(.green*31.0) Shl 5 + int(.blue*31.0)
		u = Cast(Single,c And &h0ff)/256.0 
		v = Cast(Single, (c Shr 8) And &h0ff)/256.0
		glNormal3f(.pn.x,.pn.y,.pn.z)
		glTexCoord2f u,v
		glVertex3f(.p1.x,.p1.y,.p1.z)
		glVertex3f(.p2.x,.p2.y,.p2.z)
		glVertex3f(.p3.x,.p3.y,.p3.z)
	end with
next index
glEnd()
end sub

sub DrawObject(aModel as t_model,x as single ,y as single , z as single, byval rx as single, byval ry as single ,byval  rz as single)
	dim as GLUquadricObj ptr q
	glPushMatrix
	glTranslatef x, y, z 
	'glRotatef 1, rx, ry, rz 
	' 1st : rotation gisement (perpendicular axis from the ground)
	' 2nd : rotation azimut   (axis paralle to the ground )
	' 3rd : rotation for vertical adjustement
	glRotatef ry, 0.0, 1.0, 0.0 
	glRotatef rx, 1.0, 0.0, 0.0 
	glRotatef rz, 0.0, 0.0, 1.0 
	DrawModel(aModel)
	glPopMatrix
end sub
#Define __Point(x,y)  palmap((x) + (y) * sw)

'************* Show me the land ****
sub OGLmain
	dim as single rx,ry,rz,coefxy,coefz,xu,yu,zu,xv,yv,zv,xn,yn,zn,length
	dim as integer i,j,k,ub,xs,ys,r,g,b,p,p2,p3,p4,t
	dim kb as string
	dim m as Integer
	
	coefxy = 1.0/200.0
	coefz = 1.0/512
	t = 1
	For ys = 0 To 399 Step 2
		For xs = 0 To 399 Step 2
			p = __Point(xs,ys) : p2 = __Point(xs,ys+2) : p3 = __Point(xs+2,ys+2): : p4 = __Point(xs+2,ys)
			r = (pal(p) And &hFF0000) Shr 16
			g =  (pal(p) And &hFF00) Shr 8
			b =  pal(p) And &hFF
			'Palette Get p,r,g,b
			'r = 255:g= 255: b= 255
			p = p -50 : p = IIf(p<0 ,0,p) 
			p2 = p2 - 50 : p2 = IIf(p2<0 ,0,p2)
			p3 = p3 - 50 : p3 = IIf(p3<0 ,0,p3)
			p4 = p4 - 50 : p4 = IIf(p4<0 ,0,p4)
			land(t).p1.x = (xs - 200)*coefxy
			land(t).p1.y = (ys - 200)*coefxy
			land(t).p1.z = (p - 128)*coefz
			land(t).p3.x = (xs - 200)*coefxy
			land(t).p3.y = (ys+2 -200)*coefxy
			land(t).p3.z = (p2 - 128)*coefz
			land(t).p2.x = (xs + 2 - 200)*coefxy
			land(t).p2.y = (ys + 2 - 200)*coefxy
			land(t).p2.z = (p3 - 128)*coefz
			With land(t)
          xu = .p1.x - .p2.x : yu = .p1.y - .p2.y : zu = .p1.z - .p2.z
          xv = .p2.x - .p3.x : yv = .p2.y - .p3.y : zv = .p2.z - .p3.z
          xn = yu * zv - zu * yv : yn = zu * xv - xu * zv : zn = xu * yv - yu * xv
          length = sqr(xn^2 + yn^2 + zn^2)
          if length = 0.0f then length = 1.0f
          xn /= length : yn /= length : zn /= length
          .pn.x = xn : .pn.y = yn : .pn.z = zn
			End with
			land(t).red = csng(r)/255.0
			land(t).green = csng(g)/255.0
			land(t).blue = CSng(b)/255.0
			t +=1
			land(t).p1.x = land(t-1).p1.x
			land(t).p1.y = land(t-1).p1.y
			land(t).p1.z = land(t-1).p1.z
			land(t).p3.x = land(t-1).p2.x
			land(t).p3.y = land(t-1).p2.y
			land(t).p3.z = land(t-1).p2.z
			land(t).p2.x = (xs +2 - 200)*coefxy
			land(t).p2.y = (ys - 200) * coefxy
			land(t).p2.z = (p4 - 128)*coefz
			With land(t)
          xu = .p1.x - .p2.x : yu = .p1.y - .p2.y : zu = .p1.z - .p2.z
          xv = .p2.x - .p3.x : yv = .p2.y - .p3.y : zv = .p2.z - .p3.z
          xn = yu * zv - zu * yv : yn = zu * xv - xu * zv : zn = xu * yv - yu * xv
          length = sqr(xn^2 + yn^2 + zn^2)
          if length = 0.0f then length = 1.0f
          xn /= length : yn /= length : zn /= length
          .pn.x = xn : .pn.y = yn : .pn.z = zn
			End with
			land(t).red = csng(r)/255.0
			land(t).green = csng(g)/255.0
			land(t).blue = CSng(b)/255.0
			t +=1
		Next xs
	Next ys
	init
	rx = -75 : ry = 0 : rz = 0
	m = 1
	ub = ubound(models)
    
	do
		kb = inkey$
		sleep 1
		'While Inkey <> "": Wend
		glClear GL_COLOR_BUFFER_BIT OR GL_DEPTH_BUFFER_BIT
		k = 0
		if kb = chr(255)+"k" then kb = chr(27)
		if multikey(SC_X) then rx+=1
		if multikey(SC_Y) then ry+=1
		if multikey(SC_Z) then rz+=1
		if multikey(SC_X) and (multikey(SC_LSHIFT) or multikey(SC_RSHIFT)) then rx-=2
		if multikey(SC_Y) and (multikey(SC_LSHIFT) or multikey(SC_RSHIFT)) then ry-=2
		if multikey(SC_Z) and (multikey(SC_LSHIFT) or multikey(SC_RSHIFT)) then rz-=2
		if multikey(SC_M) and (multikey(SC_LSHIFT) or multikey(SC_RSHIFT)) then
			m-=1 : Sleep 100,1
			'while multikey(SC_M) : sleep 1,1 :kb = inkey: wend
		Else
			if multikey(SC_M) then
				m+=1 : Sleep 100,1
				'while multikey(SC_M) : sleep 1,1 : kb = InKey : wend
			end If
		End If
		
		if multikey(SC_SPACE) then
			rx = 0 : ry = 0 : rz = 0
		end if
		if multikey(SC_ESCAPE) then kb = chr(27)
		if m > ub then m = lbound(models)
		if m < 1 then m = ub
		'end if    
		for i = -0 to 0
			for j = -0 to 0
				drawObject(models(m),i*2, j*2, -5.0 ,rx,ry,rz)
			next j
		next i
		flip
	loop while kb <> chr(27)
end sub 

'Island Generator
'Based on tutorial at:
'http://www.robot-frog.com/3d/index.html
'Richard D. Clark and cha0s
'Public Domain
'Space to regen, esc to exit
'+++++++++++++++++++++++++++++++++++++++++++


Dim Shared hm(sw * sh) As Integer
Dim Shared nhm(sw * sh) As Single
Dim Shared As Integer max = 0, min = 100000
Dim Key As String

Function Rand(Byref lowerbound As Double, Byref upperbound As Double) As Double
   Function = ((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)
        If (i And 1) = 0 Then
        			If i >40 Then 
        			  r += 30 : g +=30	
        			  b += 1
        			Else
        				b+= 1
        			End If
        End If
        
    Next
    '51 to 100
    r = 50
    g = 50
    b = 0
    For i = 51 To 100
        pal(i) = RGB(r, g, b)
        r += 2
        g += 2
        b += 1
    Next
    '101 to 150
    For i = 101 To 150
        pal(i) = RGB(r, g, b)
        r += 1
        g += 1
        b -= 1
    Next
    '151 to 240
    r = 255
    g = 200 '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 = 194
    g = 194
    b = 194
    For i = 241 To 255
        pal(i) = RGB(r, g, b)
        r += 4
        g += 4
        b += 4
    Next
   
End Sub


Sub GenerateHM

        Dim As Double ox, oy, cx, cy, bx, by
    Dim As Double r, theta, distance, ti
    Dim As Integer tmp
       
    For i As Integer = 1 To hiter
        r = Rand(rad_low, rad_high)
            theta = rand(0, Atn(1) * 8)
            distance = rand((rad_high-rad_low)*1, minsize - r)
        r *= r
        ox = 0-((sw/2) + Cos(theta) * distance)
        oy = 0-((sh/2) + Sin(theta) * distance)
        cy = oy
               by = oy * oy
        For row As Integer = 0 To sw*sh-1 Step sw
                       cx = ox
                bx = cx * cx
                For loc_ As Integer Ptr = @hm(row) To @hm(row) + (sw) - 1
                        tmp = *loc_
                        ti = r -(bx + by)
                    If ti < 0 Then ti = 0
                    tmp += ti
                    max = iif( tmp > max, tmp, max )
                    min = iif( tmp < min, tmp, min )
                    *loc_ = tmp
                        bx += cx
                        cx += 1
                        bx += cx
                Next
                by += cy
                cy += 1
                by += cy
            Next
    Next
   
End Sub

Sub Normalize
    Dim As Integer x, y, idx
   
    'Normalize
    For x = 0 To sw - 1
        For y = 0 To sh - 1
                idx = x + y * sw
            nhm(idx) = (hm(idx) - min) / (max - min)
            'Flatten
            'nhm(idx) = nhm(idx) * nhm(idx)
            'Generate palmap
            palmap(idx) =  nhm(idx) * 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', , 1

var t = Timer
GeneratePalette
GenerateHM
Normalize
ShowMap
? int((Timer - t)*100.0)/100.0;
? " press O to get OGL ! "

Do
    Key = InKey
    If Key = "o" Then
    	OGLmain
         key = inkey
    	screenres sw, sh, 32', , 1
    	GeneratePalette
    	Key = Chr(32)
    EndIf
    If Key = Chr(32) Then
        Cls
        Erase hm
        Erase nhm
        Erase palmap
        GenerateHM
        Normalize
        ShowMap
    End If
   
Loop Until Key = Chr(27)




Peter
Posts: 66
Joined: May 29, 2006 22:16

Post by Peter »

That looks great Redcrab!
1000101
Posts: 2556
Joined: Jun 13, 2005 23:14
Location: SK, Canada

Post by 1000101 »

Next time just include "fbgfx.bi" instead of cut'n'pasting the contents of it.
Post Reply