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 ...
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)