www.darkbasic.es :: Ver tema - Terrenos Fractales

Os dejo un ejemplo de terrenos fractales que he creado; no se porqué motivo en el portátil me genera el terreno 4 veces más rápido, sin envargo los FPS del portátil van a 80 mientras que en el de casa pasan sobradamente los 200.

Teclas:
< Espacio > Genera un nuevo terreno
< Enter > Quita / Pone el agua
< Cursor > Moverse por el terreno

Código:

Set Display Mode 1024,768,32
Hide Mouse: AutoCam Off
Sync On: Sync Rate 0

RemStart
Esto es porque lo uso desde un fichero exterior, en este caso no hace falta
#Include "GeneradorPlanetaF.dba"
RemEnd

Generador_Terrenos(1)

Cx# = 0
Cy# = Nivel_Agua + 50
Cz# = 0

Set Camera Range 1,10000
Position Camera Cx#, Cy#, Cz#
Point Camera MaximaX,Cy#,Cz#

tot# = 0.02

Angulo# = 45
Do
If Screen FPs() > 0
Teclado# = Teclado# + (Screen FPS() / 30)
Set Cursor 500,0
Print "Fps: "; Screen FPS()
Set Cursor 500,20
Print "Polígonos: ";Statistic(1)
Set Cursor 500,40
Print "Altura: ";Cy#; ", Nivel del Agua: "; Nivel_Agua

EndIF

If Teclado# > 10
If LeftKey() Then Angulo# = Angulo# - 10: Teclado# = 0
If RightKey() Then Angulo# = Angulo# + 10: Teclado# = 0
If UpKey() Then Move Camera 10
If DownKey() Then Move Camera -10
Rotate Camera 0, Angulo#,0
Cx# = Camera Position X(0)
Cz# = Camera Position Z(0)
Cy# = Get Ground Height(1,Cx#,Cz#) + 50
If Cy# < Nivel_Agua + 50 Then Cy# = Nivel_Agua + 50
Position Camera Cx#,Cy#,Cz#
EndIF
If Teclado# > 30
If SpaceKey()
Teclado# = 0
Generador_Terrenos(1)
Cy# = Altura_Maxima
EndIF
If ReturnKey()
If Object Visible(Objeto_Agua) Then Hide Object Objeto_Agua: Else Show Object Objeto_Agua
Teclado# = 0
EndIF
EndIF

Position Object Objeto_Agua,12800/2,Nivel_Agua+au#,6400/2
au#= au# + tot#
if au# > 2 or au# < -2 then tot# = - tot#
` scroll Object Texture Objeto_Agua,0.00003,0.00001

Sync
Loop

End

Function Generador_Terrenos(Matriz_Numero)
Gosub Iniciando
Cuadrado:
`El Centro
Nx = Dx + Divisor
Ny = Dy + Divisor
Sumas = 0
Altura = 0
If Nx-Divisor >= 0 and Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax and Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx+Divisor,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx-Divisor >= 0 and Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx-Divisor,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax and Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx+Divisor,Ny+Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Altura = 0
Sumas = 0
Nx = Dx+Divisor
Ny = Dy
If Nx-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax
Altura = Altura + Terreno#(Nx+Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx,Ny+Divisor)
Sumas = Sumas + 1
EndIf
If Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx,Ny-Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Nx = Dx
Ny = Dy+Divisor
Sumas = 0
Altura = 0
If Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax
Altura = Altura + Terreno#(Nx+Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx,Ny+Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Nx = Dx+(Divisor*2)
Ny = Dy+Divisor
Sumas = 0
Altura = 0
If Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax
Altura = Altura + Terreno#(Nx+Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx,Ny+Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Nx = Dx+Divisor
Ny = Dy+Divisor*2
Sumas = 0
Altura = 0
If Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax
Altura = Altura + Terreno#(Nx+Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx,Ny+Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Return

Pintar_Planeta:
Create Bitmap 1,MaximaX,MaximaY
Set Current Bitmap 1
ppx= 0
ppy= 0
For Dy = MaximaY to 0 step -1
For Dx = 0 to MaximaX
If Terreno#(ppx,ppy) <= Nivel_Agua
Color = (Terreno#(ppx,ppy) * 255) / Nivel_Agua
If Color < 50 Then Color = 50
Dot dx, dy, rgb(0,0,Color)
EndIf
If Terreno#(ppx,ppy) > Nivel_Agua and Terreno#(ppx,ppy) < Nivel_Agua + 30
Dot dx, dy, rgb(100,200,20)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 30 and Terreno#(ppx,ppy) < Nivel_Agua + 70
Dot dx, dy, rgb(90,150,10)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 70 and Terreno#(ppx,ppy) < Nivel_Agua + 100
Dot dx, dy, rgb(80,130,0)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 100 and Terreno#(ppx,ppy) < Nivel_Agua + 150
Dot dx, dy, rgb(70,130,0)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 150 and Terreno#(ppx,ppy) < Nivel_Agua + 200
Dot dx, dy, rgb(50,110,0)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 200 and Terreno#(ppx,ppy) < Nivel_Agua + 270
Dot dx, dy, rgb(30,90,0)
EndIF
If Terreno#(ppx,ppy) >= Nivel_Agua + 270
Color = (Terreno#(ppx,ppy) * 255) / Altura_Maxima
Dot dx, dy, rgb(Color,Color,Color)
EndIF
ppx=ppx+1
Next Dx
ppx= 0
ppy=ppy+1
Next Dy

Get Image Imagen_Planeta, 0, 0, MaximaX, MaximaY, 1
Set Current Bitmap 0
Delete Bitmap 1

Return

Generador:
Randomize Timer()
For y = Tamano to MaximaY - (Tamano * 2) Step Tamano
For x = Tamano to MaximaX - (Tamano * 2) Step Tamano
Altura = Rnd(Altura_Maxima)
Terreno#(x,y) = Altura
Next x
Next y

Repeat

for Oy = 0 to MaximaY - 1 step Tamano
Dy = Oy
for Ox = 0 to MaximaX - 1 step Tamano
Dx = Ox
Gosub Cuadrado
Next Ox
Next Oy
Divisor = Divisor / 2
Tamano = Tamano / 2
Until Divisor < 1
Return

Iniciando:
Global MaximaX = 160
Global MaximaY = 80
Global Nivel_Agua
Global Imagen_Circulo
Global Objeto_Agua = 696969
Global Altura_Maxima
Global Imagen_Planeta
Local Tamano = 16

Divisor = Tamano / 2

Nivel_Agua = Rnd(200) + 50
Altura_Maxima = rnd(500) + Nivel_Agua + 50
Imagen_Circulo = 200
Imagen_Planeta = 1

Global Dim Terreno#(MaximaX,MaximaY)

Create Bitmap 1,500,500
Set Current Bitmap 1
cls
ink rgb(0,255,0),0
Circle 2,2,2
sync
sync
Get Image Imagen_Circulo,0,0,6,6
Set Current Bitmap 0
cls
box 0,0,500,500,rgb(150,150,200),rgb(50,200,200),rgb(80,0,200),rgb(150,100,200)

`and speckles with white bits
for x=0 to 500
for y=0 to 500
if rnd(5)=0
r=(250)
g=(250)
b=(250)
ink rgb(r,g,b),0
dot x,y
endif
next x
next y
Get Image 90, 0,0,500,500
Delete Bitmap 1

If Object Exist(Objeto_Agua) Then Delete Object Objeto_Agua
Make Object Plain Objeto_Agua,12800, 6400
Color Object Objeto_Agua, rgb(0,0,220)
Rotate Object Objeto_Agua,-90,0,0
Texture Object Objeto_Agua,90
Set Alpha Mapping On Objeto_Agua, 45

Position Object Objeto_Agua,12800/2,Nivel_Agua,6400/2
Gosub Generador

If Matrix Exist(Matriz_Numero) Then Delete Matrix Matriz_Numero
Make Matrix Matriz_Numero, 12800, 6400, MaximaX, MaximaY
For zz = 0 to MaximaY
For xx = 0 to MaximaX
Set Matrix Height Matriz_Numero, xx, zz, Terreno#(xx,zz)
Next xx
Next zz
Update Matrix Matriz_Numero

Gosub Pintar_Planeta

Prepare matrix texture Matriz_Numero,Imagen_Planeta,MaximaX,MaximaY
T = 1
For y = MaximaY - 1 to 0 Step - 1
For x = 0 To MaximaX-1
Set Matrix Tile Matriz_Numero,x,y,t
Inc t
next x
next y
Update Matrix Matriz_Numero
Sprite Imagen_Planeta,0,0,Imagen_Planeta
`If Vampiro = 0 then Flip Sprite Imagen_Planeta:Else Vampiro = 0
Scale Sprite Imagen_Planeta, 100
Vampiro = Vampiro + 1

Color backDrop rgb(0,0,220)

EndFunction

Voy a aprovechar estos dias para meterle mano a los bloques de memoria a ver que tal para crear un sistema Lod para el terreno y más tarde Frustum Culling.

Me da problemas al compilar.
Hay "return" donde deberia haber un "EndFunction" y viceversa.
Sale mensaje de matrix inexistente....
No me va Sad

Salu2.

Tampoco puedo compilarlo. ¿Qué versión del DBpro tienes?

A mi me va bien.
Lo del Return en el lugar de un EndFunction no es posible, pues sólamente hay una función y tienen su endfunction, y dentro de la función he usado varios gosub y por ello hay return.

Mi versión en la 1.071; lo de la matrix inesistente prueva en cambiar Matriz_Numero por un 1 y ya está, pero insisto, lo he copiado del foro al darkbasic y me va bien.

Lo he compilado y guardado en mediafire.com
http://www.mediafire.com/file/2ikxuowj15o/Planeta3.exe
Está limitado a 60fps porque compilado los fps me subia a más de 300, es un terreno pequeño.

< Espacio > Gener a un terreno nuevo
< Enter > Quita / Pone el agua
< Cursor > Moverse por el terreno

Me descargo el archivo, lo ejecuto y no hace nada, absolutamente nada, se ejecuta y se queda pillao Confused

Y se queda pillao porque al darle al F5 para compilar y ejecutar saca un mensaje de error en una linea, pero este compilador es tan chulo que tira pa lante y lo ejecuta.
Lo ejecuta y se queda la pantalla en negro y de ahi no lo sacas.
El codigo tiene varios errores.
Pero lo que mas me ha sorprendido es esas cosa "rara" que ha hecho el programador de crear una funcion con varias subrrutinas anidadas dentro.
Eso son ganas de llamar la atencion y complicar las cosas innecesariamente.
Asi que he sacado las subruinas de dentro de la funcion.
Al hacerlo salta a la vista el primer error.
Falta el "return" de la ultima subrutina.
Asi ya compila, pero da un mensaje de error en tiempo de ejecucion.
La variable "Matriz_numero" vale 0.
Por eso usó una funcion y las subrutinas dentro.
Todo por ahorrarse declarar esa variable, xD.
Bueno, ese codigo se puede escribir de 100 maneras.
Yo lo he "apañao" para que funcione, aunque tampoco se ha quedado de una forma muy correcta.
No entiendo como le puede funcionar a Hosuko, pero si dice que le va, vamos a creerle.
Pero ciertamente a mi y a vosotros no.
Aqui quedara la cosa, como otro de los grandes misterios del siglo XXI.
xD, xD

Código:

Set Display Mode 1024,768,32
Hide Mouse: AutoCam Off
Sync On: Sync Rate 0

RemStart
Esto es porque lo uso desde un fichero exterior, en este caso no hace falta
#Include "GeneradorPlanetaF.dba"
RemEnd

Matriz_Numero=1

Gosub Iniciando

Cx# = 0
Cy# = Nivel_Agua + 50
Cz# = 0

Set Camera Range 1,10000
Position Camera Cx#, Cy#, Cz#
Point Camera MaximaX,Cy#,Cz#

tot# = 0.02

Angulo# = 45
Do
If Screen FPs() > 0
Teclado# = Teclado# + (Screen FPS() / 30)
Set Cursor 500,0
Print "Fps: "; Screen FPS()
Set Cursor 500,20
Print "Polígonos: ";Statistic(1)
Set Cursor 500,40
Print "Altura: ";Cy#; ", Nivel del Agua: "; Nivel_Agua

EndIF

If Teclado# > 10
If LeftKey() Then Angulo# = Angulo# - 10: Teclado# = 0
If RightKey() Then Angulo# = Angulo# + 10: Teclado# = 0
If UpKey() Then Move Camera 10
If DownKey() Then Move Camera -10
Rotate Camera 0, Angulo#,0
Cx# = Camera Position X(0)
Cz# = Camera Position Z(0)
Cy# = Get Ground Height(1,Cx#,Cz#) + 50
If Cy# < Nivel_Agua + 50 Then Cy# = Nivel_Agua + 50
Position Camera Cx#,Cy#,Cz#
EndIF
If Teclado# > 30
If SpaceKey()
Teclado# = 0
Gosub Iniciando
Cy# = Altura_Maxima
EndIF
If ReturnKey()
If Object Visible(Objeto_Agua) Then Hide Object Objeto_Agua: Else Show Object Objeto_Agua
Teclado# = 0
EndIF
EndIF

Position Object Objeto_Agua,12800/2,Nivel_Agua+au#,6400/2
au#= au# + tot#
if au# > 2 or au# < -2 then tot# = - tot#
` scroll Object Texture Objeto_Agua,0.00003,0.00001

Sync
Loop

End

Cuadrado:
`El Centro
Nx = Dx + Divisor
Ny = Dy + Divisor
Sumas = 0
Altura = 0
If Nx-Divisor >= 0 and Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax and Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx+Divisor,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx-Divisor >= 0 and Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx-Divisor,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax and Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx+Divisor,Ny+Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Altura = 0
Sumas = 0
Nx = Dx+Divisor
Ny = Dy
If Nx-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax
Altura = Altura + Terreno#(Nx+Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx,Ny+Divisor)
Sumas = Sumas + 1
EndIf
If Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx,Ny-Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Nx = Dx
Ny = Dy+Divisor
Sumas = 0
Altura = 0
If Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax
Altura = Altura + Terreno#(Nx+Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx,Ny+Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Nx = Dx+(Divisor*2)
Ny = Dy+Divisor
Sumas = 0
Altura = 0
If Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax
Altura = Altura + Terreno#(Nx+Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx,Ny+Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Nx = Dx+Divisor
Ny = Dy+Divisor*2
Sumas = 0
Altura = 0
If Ny-Divisor >= 0
Altura = Altura + Terreno#(Nx,Ny-Divisor)
Sumas = Sumas + 1
EndIf
If Nx-Divisor >= 0
Altura = Altura + Terreno#(Nx-Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Nx+Divisor <= Maximax
Altura = Altura + Terreno#(Nx+Divisor,Ny)
Sumas = Sumas + 1
EndIf
If Ny+Divisor <= Maximay
Altura = Altura + Terreno#(Nx,Ny+Divisor)
Sumas = Sumas + 1
EndIf
Altura = Altura / Sumas
Terreno#(Nx,Ny) = Altura

Return

Pintar_Planeta:
Create Bitmap 1,MaximaX,MaximaY
Set Current Bitmap 1
ppx= 0
ppy= 0
For Dy = MaximaY to 0 step -1
For Dx = 0 to MaximaX
If Terreno#(ppx,ppy) <= Nivel_Agua
Color = (Terreno#(ppx,ppy) * 255) / Nivel_Agua
If Color < 50 Then Color = 50
Dot dx, dy, rgb(0,0,Color)
EndIf
If Terreno#(ppx,ppy) > Nivel_Agua and Terreno#(ppx,ppy) < Nivel_Agua + 30
Dot dx, dy, rgb(100,200,20)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 30 and Terreno#(ppx,ppy) < Nivel_Agua + 70
Dot dx, dy, rgb(90,150,10)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 70 and Terreno#(ppx,ppy) < Nivel_Agua + 100
Dot dx, dy, rgb(80,130,0)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 100 and Terreno#(ppx,ppy) < Nivel_Agua + 150
Dot dx, dy, rgb(70,130,0)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 150 and Terreno#(ppx,ppy) < Nivel_Agua + 200
Dot dx, dy, rgb(50,110,0)
EndIF
If Terreno#(ppx,ppy) => Nivel_Agua + 200 and Terreno#(ppx,ppy) < Nivel_Agua + 270
Dot dx, dy, rgb(30,90,0)
EndIF
If Terreno#(ppx,ppy) >= Nivel_Agua + 270
Color = (Terreno#(ppx,ppy) * 255) / Altura_Maxima
Dot dx, dy, rgb(Color,Color,Color)
EndIF
ppx=ppx+1
Next Dx
ppx= 0
ppy=ppy+1
Next Dy

Get Image Imagen_Planeta, 0, 0, MaximaX, MaximaY, 1
Set Current Bitmap 0
Delete Bitmap 1

Return

Generador:
Randomize Timer()
For y = Tamano to MaximaY - (Tamano * 2) Step Tamano
For x = Tamano to MaximaX - (Tamano * 2) Step Tamano
Altura = Rnd(Altura_Maxima)
Terreno#(x,y) = Altura
Next x
Next y

Repeat

for Oy = 0 to MaximaY - 1 step Tamano
Dy = Oy
for Ox = 0 to MaximaX - 1 step Tamano
Dx = Ox
Gosub Cuadrado
Next Ox
Next Oy
Divisor = Divisor / 2
Tamano = Tamano / 2
Until Divisor < 1
Return

Iniciando:
Global MaximaX = 160
Global MaximaY = 80
Global Nivel_Agua
Global Imagen_Circulo
Global Objeto_Agua = 696969
Global Altura_Maxima
Global Imagen_Planeta
Local Tamano = 16

Divisor = Tamano / 2

Nivel_Agua = Rnd(200) + 50
Altura_Maxima = rnd(500) + Nivel_Agua + 50
Imagen_Circulo = 200
Imagen_Planeta = 1

Global Dim Terreno#(MaximaX,MaximaY)

Create Bitmap 1,500,500
Set Current Bitmap 1
cls
ink rgb(0,255,0),0
Circle 2,2,2
sync
sync
Get Image Imagen_Circulo,0,0,6,6
Set Current Bitmap 0
cls
box 0,0,500,500,rgb(150,150,200),rgb(50,200,200),rgb(80,0,200),rgb(150,100,200)

`and speckles with white bits
for x=0 to 500
for y=0 to 500
if rnd(5)=0
r=(250)
g=(250)
b=(250)
ink rgb(r,g,b),0
dot x,y
endif
next x
next y
Get Image 90, 0,0,500,500
Delete Bitmap 1

If Object Exist(Objeto_Agua) Then Delete Object Objeto_Agua
Make Object Plain Objeto_Agua,12800, 6400
Color Object Objeto_Agua, rgb(0,0,220)
Rotate Object Objeto_Agua,-90,0,0
Texture Object Objeto_Agua,90
Set Alpha Mapping On Objeto_Agua, 45

Position Object Objeto_Agua,12800/2,Nivel_Agua,6400/2
Gosub Generador

If Matrix Exist(Matriz_Numero) Then Delete Matrix Matriz_Numero
Make Matrix Matriz_Numero, 12800, 6400, MaximaX, MaximaY
For zz = 0 to MaximaY
For xx = 0 to MaximaX
Set Matrix Height Matriz_Numero, xx, zz, Terreno#(xx,zz)
Next xx
Next zz
Update Matrix Matriz_Numero

Gosub Pintar_Planeta

Prepare matrix texture Matriz_Numero,Imagen_Planeta,MaximaX,MaximaY
T = 1
For y = MaximaY - 1 to 0 Step - 1
For x = 0 To MaximaX-1
Set Matrix Tile Matriz_Numero,x,y,t
Inc t
next x
next y
Update Matrix Matriz_Numero
Sprite Imagen_Planeta,0,0,Imagen_Planeta
`If Vampiro = 0 then Flip Sprite Imagen_Planeta:Else Vampiro = 0
Scale Sprite Imagen_Planeta, 100
Vampiro = Vampiro + 1

Color backDrop rgb(0,0,220)
return

Por cierto, muy bueno el codigo.

Gracias por mirarte el código Pasky y gracias por llamarme programador pues nada más lejos de mi trabajo.

El codigo tiene varios errores , pues si me cuentas como lo has mirado para ver donde están, pues yo programo un poco a ciegas y por eso mis códigos son un poquito raros.

Pero lo que mas me ha sorprendido es esas cosa "rara" que ha hecho el programador de crear una funcion con varias subrrutinas anidadas dentro. . Fácil de explicar, cuando conseguí que me funcionara, intenté meterlo todo en una función para usarlo desde fuera; yo lo uso simplemente poniendo #Include "GeneradorPlanetaF.dba" y luego llamando a la función.

Falta el "return" de la ultima subrutina. Tiene 3 subrutinas, o subruinas como tu le dices, solamente:
Generador: - Crea las alturas
Cuadrado: - Calcula las alturas medias
Pintar_Planeta: - Pues simplemente eso, es donde vendrían las texturas con el código acabado.
Y todas tienen sus Return.

La variable "Matriz_numero" vale 0.
Por eso usó una funcion y las subrutinas dentro.
Todo por ahorrarse declarar esa variable, xD.
. Pues no va a ser por eso y si, vaya fallo no ponerle el valor a Matriz_Numero, se me pasaría al preparalo todo en un solo código para postearlo aquí.

No entiendo como le puede funcionar a Hosuko, pero si dice que le va, vamos a creerle.
Pero ciertamente a mi y a vosotros no.
Aqui quedara la cosa, como otro de los grandes misterios del siglo XXI.
xD, xD
. No lo entiend, incluso lo compilé y lo pude usar en el ordenador de un amigo sin ningún problema.

Bueno, te agradezco que te tomaras la molestia de mirar el código.

jajaja, perdona si fuy un poco acido en los comentarios pero creia que el codigo era un copy/paste, si llego a saber que era en parte tuyo habria sido mas comedido en mi tono, xD.

Pues hay una subrutina mas que añadir a la lista: "Iniciando". Que es precisamente el primer "gosub" que hay dentro de la funcion en el codigo que posteaste.
Esa subrutina no tiene su "return".

Lo de inicializar la variable, con el sistema de funciones no haria falta, pues le pasas un 1 como parametro, pero al desmantelarte el invento entonces si que hay que asignarle un valor. Digamos que "estaria bien" en tu codigo, aunque en la practica no funcione.

La unica razon que se me ocurre para que a ti no te de errores de compilacion y a nosotros si es que al subir el codigo te "comieras" algo. Vamos, que tu codigo y el codigo que has dejado aqui tengan diferencias.
La prueba es sencilla, no? Subete tu propio codigo y pruebalo. Si te funciona volvere a creer en Papa Noel, jajajaja.

Y si programas, aunque sea poco, eres programador. Wink

Saludos y felices fiestas.

Si, ya vi el gosub iniciando, ha sido un error al crear la función, lo bueno es que a pesar de dicho error a mi me funciona y al crear el ejecutable y usarlo en el ordenador de una amigo que no tienen Darkbasic le va Shocked

. Ciertamente no tendría que funcionar ni compilarlo.

El código es mio menos la textura del agua que la copie de The Games Creator, pues la vi y me gustó cuando buscaba el modo en el cual se texturiza una Matriz, pues no tenía ni idea de como hacerlo.

El Algoritmo se llama Diamond-Square y lo miré aquí: http://www.gameprogrammer.com/fractal.html#diamond , no es muy difiícil de hacer aunque cometí varios fallos.

He creado otro un poco diferente, está en 2d y tiene un zoom que será más o menos lo que usaré para el sistema Lod, lo he echo esta mañana así que no es más que un esbozo a ver si os va bien. Salen demasiadas "puntas" para mi gusto.

Código:

Set Display Mode 1024, 768, 32
AutoCam Off: Hide Mouse
Sync On: Sync Rate 0

Sync

MaximaX = 256
MaximaZ = 256

Dim Altura(MaximaX,MaximaZ)

ZoomX = 320
ZoomZ = 320

Dim Zoom(ZoomX,ZoomZ)

Randomize Timer()

Set Text opaque
Center Text Screen Width() / 2, Screen Height() / 2, "Tranqui, no se ha bloqueado :)"

sync

Dividiendo = 8 `Han de ser 2, 4, 8, 16, 32, .....
Tamano = MaximaX / Dividiendo
Suavidad = 50 `contra más grande más suave y 100 = Suavidad total

For z = 0 to MaximaZ step tamano
For x = 0 to MaximaX step tamano
If Altura(x,z) = 0
Altura(x,z) = rnd(255)
EndIf
next x
next z

repeat
Gosub Algoritmo1
Tamano = Tamano / 2
until Tamano < 2

Gosub Dibuja
TeclaX = -1
TeclaZ = 0
Do

TeclaX = TeclaX + Dividiendo / 2
If TeclaX > MaximaX - 10
TeclaX = 0
TeclaZ = TeclaZ + Dividiendo / 2
If TeclaZ > MaximaZ - 10 then TeclaZ = 0
EndIf
zx = 0
zz = 0
For z = TeclaZ to TeclaZ + 10
For x = TeclaX to TeclaX + 10
Zoom(zx,zz) = Altura(x,z)
zx = zx + 32
next x
zx = 0
zz = zz + 32
next z
Tamano = 32
repeat
Gosub Algoritmo2
Tamano = Tamano / 2
until Tamano < 2

Gosub DibujaZoom

Sync

Loop
End

Dibuja:
cls
For z = 0 to MaximaZ
for x = 0 to MaximaX
Dot x,z, rgb(altura(x,z),altura(x,z),altura(x,z))
next x
next z
Return

DibujaZoom:
For z = 0 to ZoomX
for x = 0 to ZoomZ
Dot x,z+(MaximaX + 10), rgb(zoom(x,z),zoom(x,z),zoom(x,z))
next x
next z
Return

Algoritmo1:
Divisor = Tamano / 2
For z = 0 to MaximaZ - Divisor Step Tamano
For x = 0 to MaximaX - Divisor Step Tamano
`Cuadrado
Neutro = 0: Suma = 0
Neutro = Neutro + Altura(x,z): Suma = Suma + 1
If x + Tamano <= MaximaX then Neutro = Neutro + Altura(x + Tamano,z): Suma = Suma + 1
If x + Tamano <= MaximaX and z + Tamano <= MaximaZ then Neutro = Neutro + Altura(x + Tamano,z + Tamano): Suma = Suma + 1
If z + Tamano <= MaximaZ then Neutro = Neutro + Altura(x,z + Tamano): Suma = Suma + 1
Neutro = Neutro / Suma
AlturaMedia = Neutro / Suavidad
If Suavidad < 100 then Neutro = rnd(Neutro - rnd(AlturaMedia) ) + rnd(AlturaMedia * 2)
Altura(x + Divisor, z + Divisor) = Neutro

`Rombo
Neutro = 0: Suma = 0
If x - Divisor >= 0 then Neutro = Neutro + Altura(x - Divisor, z + Divisor): Suma = Suma + 1
Neutro = Neutro + Altura(x, z): Suma = Suma + 1
if z + Tamano <= MaximaZ then Neutro = Neutro + Altura(x, z + Tamano): Suma = Suma + 1
if x + Divisor <= MaximaX and z + Divisor <= MaximaZ then Neutro = Neutro + Altura(x + Divisor, z + Divisor): Suma = Suma + 1
Neutro = Neutro / 4
AlturaMedia = Neutro / Suavidad
If Suavidad < 100 then Neutro = rnd(Neutro - rnd(AlturaMedia) ) + rnd(AlturaMedia * 2)
Altura(x, z + Divisor) = Neutro

Neutro = 0: Suma = 0
Neutro = Neutro + Altura(x, z): Suma = Suma + 1
if x + Divisor <= MaximaX and z + Divisor <= MaximaZ then Neutro = Neutro + Altura(x + Divisor, z + Divisor): Suma = Suma + 1
if x + Divisor <= MaximaX and z - Divisor >= 0 then Neutro = Neutro + Altura(x + Divisor, z - Divisor): Suma = Suma + 1
if x + Tamano <= MaximaX then Neutro = Neutro + Altura(x + Tamano, z): Suma = Suma + 1
Neutro = Neutro / Suma
AlturaMedia = Neutro / Suavidad
If Suavidad < 100 then Neutro = rnd(Neutro - rnd(AlturaMedia) ) + rnd(AlturaMedia * 2)
Altura(x + Divisor, z) = Neutro

Neutro = 0: Suma = 0
If z + Tamano <= MaximaZ then Neutro = Neutro + Altura(x, z + Tamano): Suma = Suma + 1
if x + Divisor <= MaximaX and z + Divisor <= MaximaZ then Neutro = Neutro + Altura(x + Divisor, z + Divisor): Suma = Suma + 1
if x + Divisor <= MaximaX and z + Divisor + Tamano <= MaximaZ then Neutro = Neutro + Altura(x + Divisor, z + Divisor + Tamano): Suma = Suma + 1
if x + Tamano <= MaximaX and z + Tamano <= MaximaZ then Neutro = Neutro + Altura(x + Tamano, z + Tamano): Suma = Suma + 1
Neutro = Neutro / Suma
AlturaMedia = Neutro / Suavidad
If Suavidad < 100 then Neutro = rnd(Neutro - rnd(AlturaMedia) ) + rnd(AlturaMedia * 2)
Altura(x + Divisor, z + Tamano) = Neutro

Neutro = 0: Suma = 0
If x + Divisor <= MaximaX and z + Divisor <= MaximaZ then Neutro = Neutro + Altura(x + Divisor, z + Divisor): Suma = Suma + 1
if x + Tamano <= MaximaX then Neutro = Neutro + Altura(x + Tamano, z): Suma = Suma + 1
if x + Tamano <= MaximaX and z + Tamano <= MaximaZ then Neutro = Neutro + Altura(x + Tamano, z + Tamano): Suma = Suma + 1
if x + Tamano + Divisor <= MaximaX and z + Divisor <= MaximaZ then Neutro = Neutro + Altura(x + Tamano + Divisor, z + Divisor): Suma = Suma + 1
Neutro = Neutro / Suma
AlturaMedia = Neutro / Suavidad
If Suavidad < 100 then Neutro = rnd(Neutro - rnd(AlturaMedia) ) + rnd(AlturaMedia * 2)
Altura(x + Tamano, z + Divisor) = Neutro

next x
next z

Return

Algoritmo2:
Divisor = Tamano / 2
For z = 0 to ZoomZ - 1 Step Tamano
For x = 0 to ZoomX - 1 Step Tamano
`Cuadrado
Neutro = 0: Suma = 0
Neutro = Neutro + Zoom(x,z): Suma = Suma + 1
If x + Tamano <= ZoomX then Neutro = Neutro + Zoom(x+Tamano,z): Suma = Suma + 1
If x + Tamano <= ZoomX and z + Tamano <= ZoomZ then Neutro = Neutro + Zoom(x + Tamano,z + Tamano): Suma = Suma + 1
If z + Tamano <= ZoomZ then Neutro = Neutro + Zoom(x,z+Tamano): Suma = Suma + 1
Neutro = Neutro / Suma
Zoom(x + Divisor, z + Divisor) = Neutro

`Rombo
Neutro = 0: Suma = 0
If x - Divisor >= 0 then Neutro = Neutro + Zoom(x - Divisor, z + Divisor): Suma = Suma + 1
Neutro = Neutro + Zoom(x, z): Suma = Suma + 1
if z + Tamano <= ZoomZ then Neutro = Neutro + Zoom(x, z + Tamano): Suma = Suma + 1
if x + Divisor <= ZoomX and z + Divisor <= ZoomZ then Neutro = Neutro + Zoom(x + Divisor, z + Divisor): Suma = Suma + 1
Neutro = Neutro / Suma
Zoom(x, z + Divisor) = Neutro

Neutro = 0: Suma = 0
Neutro = Neutro + Zoom(x, z): Suma = Suma + 1
if x + Divisor <= ZoomX and z + Divisor <= ZoomZ then Neutro = Neutro + Zoom(x + Divisor, z + Divisor): Suma = Suma + 1
if x + Divisor <= ZoomX and z - Divisor >= 0 then Neutro = Neutro + Zoom(x + Divisor, z - Divisor): Suma = Suma + 1
if x + Tamano <= ZoomX then Neutro = Neutro + Zoom(x + Tamano, z): Suma = Suma + 1
Neutro = Neutro / Suma
Zoom(x + Divisor, z) = Neutro

Neutro = 0: Suma = 0
If z + Tamano <= ZoomZ then Neutro = Neutro + Zoom(x, z + Tamano): Suma = Suma + 1
if x + Divisor <= ZoomX and z + Divisor <= ZoomZ then Neutro = Neutro + Zoom(x + Divisor, z + Divisor): Suma = Suma + 1
if x + Divisor <= ZoomX and z + Divisor + Tamano <= ZoomZ then Neutro = Neutro + Zoom(x + Divisor, z + Divisor + Tamano): Suma = Suma + 1
if x + Tamano <= ZoomX and z + Tamano <= ZoomZ then Neutro = Neutro + Zoom(x + Tamano, z + Tamano): Suma = Suma + 1
Neutro = Neutro / 4
Zoom(x + Divisor, z + Tamano) = Neutro

Neutro = 0: Suma = 0
If x + Divisor <= ZoomX and z + Divisor <= ZoomZ then Neutro = Neutro + Zoom(x + Divisor, z + Divisor): Suma = Suma + 1
if x + Tamano <= ZoomX then Neutro = Neutro + Zoom(x + Tamano, z): Suma = Suma + 1
if x + Tamano <= ZoomX and z + Tamano <= ZoomZ then Neutro = Neutro + Zoom(x + Tamano, z + Tamano): Suma = Suma + 1
if x + Tamano + Divisor <= ZoomX and z + Divisor <= ZoomZ then Neutro = Neutro + Zoom(x + Tamano + Divisor, z + Divisor): Suma = Suma + 1
Neutro = Neutro / 4
Zoom(x + Tamano, z + Divisor) = Neutro

next x
next z

Return

xD, si llegas aponer ese codigo el dia 28 me creo que es una inocentada.
Me pasao horas mirando como un gili...la pantallica esperando que saliera el terreno. Horas!!!
Al final lo he tenenido que cortar y ver el codigo.
Moraleja: no ejecutar nada sin saber antes que hace.

jajaja, xD, que ridi mas grande he hecho.

Nada que criticar a tu algoritmo excepto una cosa: es leeeeeeeeeeento.

Prueba a hacer lo siguiente.
En las subrutinas "Dibuja" y "DibujaZoom" ponle "lock pixels" y "unlock pixels".
Asi quedarian:

Código:

Dibuja:
cls
lock pixels
For z = 0 to MaximaZ
for x = 0 to MaximaX
Dot x,z, rgb(altura(x,z),altura(x,z),altura(x,z))
next x
next z
unlock pixels
Return

DibujaZoom:
lock pixels
For z = 0 to ZoomX
for x = 0 to ZoomZ
Dot x,z+(MaximaX + 10), rgb(zoom(x,z),zoom(x,z),zoom(x,z))
next x
next z
unlock pixels
Return

Pruebalo asi y ya me comentas que te parece.

Salu2.

La madre que.....a mi me tardaba unos 40 segundos pero ahora va rapidísimo, no tenía ni idea que existiera esa instrucción, muchas gracias, mañana miraré de hecharle un repasito al código. Laughing

.

Yo tengo un Pentium IV a 3.09Ghz, 1`5Gb de ram y una Gforce 8500Gt.

Asunto:
Cuerpo del mensaje:	Add image to post
Opciones:	Deshabilitar BBCode en este mensaje Deshabilitar Smilies en este mensaje Notificarme cuando se publique una respuesta