Island Generator

Source-code only - please, don't post questions here.
rdc
Posts: 1713
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Island Generator

Postby rdc » Apr 05, 2007 18:21

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:

Postby steven522 » Apr 05, 2007 19:48

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: 1713
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Postby rdc » Apr 05, 2007 21:02

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: 86
Joined: Nov 30, 2006 13:35
Location: UK

Postby tinram » Apr 05, 2007 22:02

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

Postby 1000101 » Apr 05, 2007 22:34

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: 1713
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Postby rdc » Apr 05, 2007 23:02

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: 5317
Joined: May 27, 2005 6:42
Location: Illinois
Contact:

Postby cha0s » Apr 06, 2007 2:28

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

Postby rdc » Apr 06, 2007 2:34

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: 5317
Joined: May 27, 2005 6:42
Location: Illinois
Contact:

Postby cha0s » Apr 06, 2007 13:09

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: 618
Joined: Feb 07, 2006 15:29
Location: France / Luxemburg
Contact:

Postby redcrab » Apr 06, 2007 13:40

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: 5317
Joined: May 27, 2005 6:42
Location: Illinois
Contact:

Postby cha0s » Apr 06, 2007 14:11

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

Postby rdc » Apr 06, 2007 14:33

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

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

Postby redcrab » Apr 06, 2007 16:25

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

Postby Peter » Apr 06, 2007 17:09

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

Postby 1000101 » Apr 06, 2007 17:21

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

Return to “Tips and Tricks”

Who is online

Users browsing this forum: Bing [Bot] and 0 guests