Terrain generator - GameCreators Forum

Author

Message

Madscientist

14

Years of Service

User Offline

Joined: 23rd Aug 2009

Location: Between a rock and a hard place

Posted: 17th Oct 2010 04:14

Link

I decided to create a terrain heightmap generator that generates a map based of the Plasma Fractal Algorithm. I got the algorithm to work some what but for some reason the code only generates half the map which probably has to do with it having a recursive function. Any ideas why?

Rem Project: Dark Basic Pro Project
Rem Created: Saturday, October 16, 2010

Rem ***** Main Source File *****

GenerateTerrain(1,5,3.0,128,128)

For X=1 to 128
	For Y=1 to 128
		Ink rgb(255,255,255),rgb(0,0,0)
		col=(TerrainY(X,Y)/20.0)*255
		col=Col*2
		if Col<0 then col=0
		If Col>255 then Col=255
		Ink Rgb(col,col,col),rgb(0,0,0)
		Dot X,Y
	Next Y
Next X

Ink rgb(255,255,255),rgb(0,0,0)
Text 0,256, "DONE"
wait key
end

Function GenerateTerrain(Obj,Iter,Rand#,Wi,He)
	Global Dim TerrainY(Wi,He) as Float
	Global GTRand# as float = Rand#
	
	DivideArray(1,1,Wi,1,1,He,Wi,He,Iter)
Endfunction

Function DivideArray(X1,Y1,X2,Y2,X3,Y3,X4,Y4,Iter)
	Local YV1 as float
	Local YV2 as float
	Local YV3 as float
	Local YV4 as float
		
	YV1=TerrainY(X1,Y1)
	YV2=TerrainY(X2,Y2)
	YV3=TerrainY(X3,Y3)
	YV4=TerrainY(X4,Y4)

NewX=(X2-X1)/2
	NewY=(Y3-Y1)/2
	`Print " "	
	`Print "S:"
	`Print Str$(X1)+", "+str$(Y1)+"   "+Str$(X2)+", "+str$(Y2)
	`Print Str$(X3)+", "+str$(Y3)+"   "+Str$(X4)+", "+str$(Y4)
	`Print Str$(NewX)+", "+str$(NewY)
	`Print "E:"
	
	TerrainY(X1+NewX,Y1)=(YV1+YV2)/2.0+rnd(GTRand#)
	TerrainY(X1,Y1+NewY)=(YV1+YV3)/2.0+rnd(GTRand#)	
	TerrainY(X1+NewX,Y2)=(YV3+YV4)/2.0+rnd(GTRand#)
	TerrainY(X2,Y1+NewY)=(YV2+YV4)/2.0+rnd(GTRand#)
	TerrainY(X2+NewX,Y1+NewY)=(YV1+YV2+YV3+YV4)/4.0+rnd(GTRand#)
				
	If Iter=0 then exitfunction
		
	DivideArray(X1,Y1,X1+NewX,Y1,X1,Y1+NewY,X1+NewX,Y1+NewY,Iter-1)
	DivideArray(X1+NewX,Y1,X2,Y1,X1+NewX,Y1+NewY,X2,Y2,Iter-1)
	DivideArray(X1,Y1+NewY,X1+NewX,Y1+NewY,X1,Y2,X1+NewX,Y2,Iter-1)
	DivideArray(X1+NewX,Y1+NewY,X2,Y1+NewY,X1+NewX,Y2,X2,Y2,Iter-1)

Endfunction

+ Code Snippet

Rem Project: Dark Basic Pro Project
Rem Created: Saturday, October 16, 2010

Rem ***** Main Source File *****

GenerateTerrain(1,5,3.0,128,128)

For X=1 to 128
	For Y=1 to 128
		Ink rgb(255,255,255),rgb(0,0,0)
		col=(TerrainY(X,Y)/20.0)*255
		col=Col*2
		if Col<0 then col=0
		If Col>255 then Col=255
		Ink Rgb(col,col,col),rgb(0,0,0)
		Dot X,Y
	Next Y
Next X

Ink rgb(255,255,255),rgb(0,0,0)
Text 0,256, "DONE"
wait key
end

Function GenerateTerrain(Obj,Iter,Rand#,Wi,He)
	Global Dim TerrainY(Wi,He) as Float
	Global GTRand# as float = Rand#
	
	DivideArray(1,1,Wi,1,1,He,Wi,He,Iter)
Endfunction


Function DivideArray(X1,Y1,X2,Y2,X3,Y3,X4,Y4,Iter)
	Local YV1 as float
	Local YV2 as float
	Local YV3 as float
	Local YV4 as float
		
	YV1=TerrainY(X1,Y1)
	YV2=TerrainY(X2,Y2)
	YV3=TerrainY(X3,Y3)
	YV4=TerrainY(X4,Y4)

	NewX=(X2-X1)/2
	NewY=(Y3-Y1)/2
	`Print " "	
	`Print "S:"
	`Print Str$(X1)+", "+str$(Y1)+"   "+Str$(X2)+", "+str$(Y2)
	`Print Str$(X3)+", "+str$(Y3)+"   "+Str$(X4)+", "+str$(Y4)
	`Print Str$(NewX)+", "+str$(NewY)
	`Print "E:"
	
	TerrainY(X1+NewX,Y1)=(YV1+YV2)/2.0+rnd(GTRand#)
	TerrainY(X1,Y1+NewY)=(YV1+YV3)/2.0+rnd(GTRand#)	
	TerrainY(X1+NewX,Y2)=(YV3+YV4)/2.0+rnd(GTRand#)
	TerrainY(X2,Y1+NewY)=(YV2+YV4)/2.0+rnd(GTRand#)
	TerrainY(X2+NewX,Y1+NewY)=(YV1+YV2+YV3+YV4)/4.0+rnd(GTRand#)
				
	If Iter=0 then exitfunction
		
	DivideArray(X1,Y1,X1+NewX,Y1,X1,Y1+NewY,X1+NewX,Y1+NewY,Iter-1)
	DivideArray(X1+NewX,Y1,X2,Y1,X1+NewX,Y1+NewY,X2,Y2,Iter-1)
	DivideArray(X1,Y1+NewY,X1+NewX,Y1+NewY,X1,Y2,X1+NewX,Y2,Iter-1)
	DivideArray(X1+NewX,Y1+NewY,X2,Y1+NewY,X1+NewX,Y2,X2,Y2,Iter-1)

Endfunction

My computer surpasses all the technologies of the day. What computer do I have?

+ Code Snippet

My Brain

Back to top

Profile PM

Green Gandalf

VIP Member

19

Years of Service

User Offline

Joined: 3rd Jan 2005

Playing: Malevolence:Sword of Ahkranox, Skyrim, Civ6.

Posted: 17th Oct 2010 19:37

Link

Quote: "Any ideas why?"

I'm fairly sure you've got in a muddle with the (X,Y) coordinates of your corner points - and I suspect you calculate the new values more than once in the middle of the edges as soon as you divide.

Also, your code seems unnecessarily elaborate. Any reason why you didn't just use

+ Code Snippet

Function DivideArray(X1,Y1,X2,Y2,Iter)
(etc)

with (X1,Y1) and (X2,Y2) being the top left and bottom right corners?

Back to top

Profile PM Email

Green Gandalf

VIP Member

19

Years of Service

User Offline

Joined: 3rd Jan 2005

Playing: Malevolence:Sword of Ahkranox, Skyrim, Civ6.

Posted: 17th Oct 2010 20:10

Link

Try this. It still isn't quite right - you need to stop the repeated entries which probably cause the loss of continuity. But at least the whole square is filled.

GenerateTerrain(1,6,3.0,128,128)

For X=1 to 128
  For Y=1 to 128
    Ink rgb(255,255,255),rgb(0,0,0)
    col=(TerrainY(X,Y)/20.0)*255
    if col<0 then col=0
    If col>255 then col=255
    Ink Rgb(col,col,col),rgb(0,0,0)
    Dot X,Y
  Next Y
Next X

Ink rgb(255,255,255),rgb(0,0,0)
Text 0,256, "DONE"
wait key
end

Function GenerateTerrain(Obj,Iter,Rand#,Wi,He)
  Global Dim TerrainY(Wi,He) as Float
  Global GTRand# as float = Rand#
  
  DivideArray(1,1,Wi,He,Iter)
Endfunction

Function DivideArray(X1,Y1,X2,Y2,Iter)
  Local H11 as float
  Local H21 as float
  Local H12 as float
  Local H22 as float
    
  H11=TerrainY(X1,Y1)
  H21=TerrainY(X2,Y1)
  H12=TerrainY(X1,Y2)
  H22=TerrainY(X2,Y2)

NewX=X1+(X2-X1)/2
  NewY=Y1+(Y2-Y1)/2
  
  TerrainY(NewX,Y1)=(H11+H21)/2.0+rnd(GTRand#)
  TerrainY(X1,NewY)=(H11+H12)/2.0+rnd(GTRand#)  
  TerrainY(NewX,Y2)=(H12+H22)/2.0+rnd(GTRand#)
  TerrainY(X2,NewY)=(H21+H22)/2.0+rnd(GTRand#)
  TerrainY(NewX,NewY)=(H11+H21+H12+H22)/4.0+rnd(GTRand#)
        
  If Iter=0 then exitfunction
    
  DivideArray(X1,Y1,NewX,NewY,Iter-1)
  DivideArray(NewX,Y1,X2,NewY,Iter-1)
  DivideArray(X1,NewY,NewX,Y2,Iter-1)
  DivideArray(NewX,NewY,X2,Y2,Iter-1)

Endfunction

+ Code Snippet

GenerateTerrain(1,6,3.0,128,128)

For X=1 to 128
  For Y=1 to 128
    Ink rgb(255,255,255),rgb(0,0,0)
    col=(TerrainY(X,Y)/20.0)*255
    if col<0 then col=0
    If col>255 then col=255
    Ink Rgb(col,col,col),rgb(0,0,0)
    Dot X,Y
  Next Y
Next X

Ink rgb(255,255,255),rgb(0,0,0)
Text 0,256, "DONE"
wait key
end

Function GenerateTerrain(Obj,Iter,Rand#,Wi,He)
  Global Dim TerrainY(Wi,He) as Float
  Global GTRand# as float = Rand#
  
  DivideArray(1,1,Wi,He,Iter)
Endfunction


Function DivideArray(X1,Y1,X2,Y2,Iter)
  Local H11 as float
  Local H21 as float
  Local H12 as float
  Local H22 as float
    
  H11=TerrainY(X1,Y1)
  H21=TerrainY(X2,Y1)
  H12=TerrainY(X1,Y2)
  H22=TerrainY(X2,Y2)

  NewX=X1+(X2-X1)/2
  NewY=Y1+(Y2-Y1)/2
  
  TerrainY(NewX,Y1)=(H11+H21)/2.0+rnd(GTRand#)
  TerrainY(X1,NewY)=(H11+H12)/2.0+rnd(GTRand#)  
  TerrainY(NewX,Y2)=(H12+H22)/2.0+rnd(GTRand#)
  TerrainY(X2,NewY)=(H21+H22)/2.0+rnd(GTRand#)
  TerrainY(NewX,NewY)=(H11+H21+H12+H22)/4.0+rnd(GTRand#)
        
  If Iter=0 then exitfunction
    
  DivideArray(X1,Y1,NewX,NewY,Iter-1)
  DivideArray(NewX,Y1,X2,NewY,Iter-1)
  DivideArray(X1,NewY,NewX,Y2,Iter-1)
  DivideArray(NewX,NewY,X2,Y2,Iter-1)

Endfunction

Back to top

Profile PM Email

Madscientist

14

Years of Service

User Offline

Joined: 23rd Aug 2009

Location: Between a rock and a hard place

Posted: 18th Oct 2010 03:46

Link

Thanks GG! I had the 4 corners because I figured it would be easier to keep track of the data. But changing the 4 coords to 2 coords fix it or did you do something else?

My computer surpasses all the technologies of the day. What computer do I have?

+ Code Snippet

My Brain

Back to top

Profile PM

Green Gandalf

VIP Member

19

Years of Service

User Offline

Joined: 3rd Jan 2005

Playing: Malevolence:Sword of Ahkranox, Skyrim, Civ6.

Posted: 18th Oct 2010 12:00

Link

Quote: "or did you do something else"

Yes. I found it easier to write amended code that way - the error was in your referencing of the corners when you called the divide recursion. The recursion idea itself was fine.

I've also made a few other changes to make the results look better. I'm on the wrong machine at the moment but will edit this post with the new code later today.

I did something similar a few years back using the diamond-square algorithm but your method is much simpler and more flexible (for example it is easy to extend to three dimensions). Would you object if I used it? I'll credit the idea to you of course.

Thanks for posting an interesting problem.

Back to top

Profile PM Email

Madscientist

14

Years of Service

User Offline

Joined: 23rd Aug 2009

Location: Between a rock and a hard place

Posted: 18th Oct 2010 13:50

Link

You can use it however you like. Thanks for the help.

Yeah the corner positions were giving me problems before.

My computer surpasses all the technologies of the day. What computer do I have?

+ Code Snippet

My Brain

Back to top

Profile PM

zappi

13

Years of Service

User Offline

Joined: 16th Oct 2010

Location: with your mother

Posted: 18th Oct 2010 15:18

Link

good idea!!

Back to top

Profile PM Email

Green Gandalf

VIP Member

19

Years of Service

User Offline

Joined: 3rd Jan 2005

Playing: Malevolence:Sword of Ahkranox, Skyrim, Civ6.

Posted: 18th Oct 2010 17:47

Link

Here's the revised version. Experiment with different values of reduce# to get rougher or smoother heightmaps.

set display mode desktop width(), desktop height(), 32
objId = 1 ` not implemented yet
scale# = 1.0 ` probably any non-zero value will work
reduce# = 0.7 ` values in the range 0.5 to 1.0 work best
sizeX = 500 ` doesn't need to be square
sizeY = 300
GenerateTerrain(objId,scale#,reduce#,sizeX,sizeY)
ScaleTerrain(sizeX,sizeY)
For X=1 to sizeX
  For Y=1 to sizeY
    Ink rgb(255,255,255),rgb(0,0,0)
    col=TerrainH(X,Y)
    if col<0 then col=0
    If col>255 then col=255
    Ink Rgb(col,col,col),rgb(0,0,0)
    Dot X,Y
  Next Y
Next X

Ink rgb(255,255,255),rgb(0,0,0)
Text 0,sizeY+10, "DONE"
wait key
end

Function GenerateTerrain(Obj,scale#,reduce#,sizeX,sizeY)
  Global Dim terrainH(sizeX,sizeY) as Float
  global dim marker(sizeX,sizeY)
  for x = 1 to sizeX
    for y = 1 to sizeY
      marker(x,y) = 0
    next y
  next x
  InitialiseArray(sizeX,sizeY)
  DivideArray(1,1,sizeX,sizeY,scale#,reduce#)
Endfunction

function InitialiseArray(sizeX,sizeY)
  terrainH(1,1) = 0
  terrainH(1,sizeY) = 0
  terrainH(sizeX,1) = 0
  terrainH(sizeX,sizeY) = 0
endfunction

Function DivideArray(X1,Y1,X2,Y2,scale#,reduce#)
  Local H11 as float
  Local H21 as float
  Local H12 as float
  Local H22 as float
    
  H11=terrainH(X1,Y1)
  H21=terrainH(X2,Y1)
  H12=terrainH(X1,Y2)
  H22=terrainH(X2,Y2)
  
  stepX = X2-X1
  stepY = Y2-Y1

NewX=X1+stepX/2
  NewY=Y1+stepY/2
  
  if marker(NewX,Y1) = 0 then terrainH(NewX,Y1)=(H11+H21)/2.0+(rnd(100)-50)*scale#:marker(NewX,Y1) = 1
  if marker(X1,NewY) = 0 then terrainH(X1,NewY)=(H11+H12)/2.0+(rnd(100)-50)*scale#:marker(X1,NewY) = 1
  if marker(NewX,Y2) = 0 then terrainH(NewX,Y2)=(H12+H22)/2.0+(rnd(100)-50)*scale#:marker(NewX,Y2) = 1
  if marker(X2,NewY) = 0 then terrainH(X2,NewY)=(H21+H22)/2.0+(rnd(100)-50)*scale#:marker(X2,NewY) = 1
  if marker(NewX,NewY) = 0 then terrainH(NewX,NewY)=(H11+H21+H12+H22)/4.0+(rnd(100)-50)*scale#:marker(NewX,NewY) = 1
        
  if (stepX<=2) and (stepY<=2) then exitfunction
  
  scale# = scale#*reduce#
  DivideArray(X1,Y1,NewX,NewY,scale#,reduce#)
  DivideArray(NewX,Y1,X2,NewY,scale#,reduce#)
  DivideArray(X1,NewY,NewX,Y2,scale#,reduce#)
  DivideArray(NewX,NewY,X2,Y2,scale#,reduce#)

Endfunction

function ScaleTerrain(sizeX,sizeY)
  minH = 999999
  maxH = -999999
  for x = 1 to sizeX
    for y = 1 to sizeY
      minH = min(terrainH(x,y), minH)
      maxH = max(terrainH(x,y), maxH)
    next y
  next x
  factor# = 255.0/(maxH-minH)
  for x = 1 to sizeX
    for y = 1 to sizeY
      terrainH(x,y) = factor# * (terrainH(x,y)-minH)
    next y
  next x
endfunction

+ Code Snippet

set display mode desktop width(), desktop height(), 32
objId = 1 ` not implemented yet
scale# = 1.0 ` probably any non-zero value will work
reduce# = 0.7 ` values in the range 0.5 to 1.0 work best
sizeX = 500 ` doesn't need to be square
sizeY = 300
GenerateTerrain(objId,scale#,reduce#,sizeX,sizeY)
ScaleTerrain(sizeX,sizeY)
For X=1 to sizeX
  For Y=1 to sizeY
    Ink rgb(255,255,255),rgb(0,0,0)
    col=TerrainH(X,Y)
    if col<0 then col=0
    If col>255 then col=255
    Ink Rgb(col,col,col),rgb(0,0,0)
    Dot X,Y
  Next Y
Next X

Ink rgb(255,255,255),rgb(0,0,0)
Text 0,sizeY+10, "DONE"
wait key
end

Function GenerateTerrain(Obj,scale#,reduce#,sizeX,sizeY)
  Global Dim terrainH(sizeX,sizeY) as Float
  global dim marker(sizeX,sizeY)
  for x = 1 to sizeX
    for y = 1 to sizeY
      marker(x,y) = 0
    next y
  next x
  InitialiseArray(sizeX,sizeY)
  DivideArray(1,1,sizeX,sizeY,scale#,reduce#)
Endfunction

function InitialiseArray(sizeX,sizeY)
  terrainH(1,1) = 0
  terrainH(1,sizeY) = 0
  terrainH(sizeX,1) = 0
  terrainH(sizeX,sizeY) = 0
endfunction

Function DivideArray(X1,Y1,X2,Y2,scale#,reduce#)
  Local H11 as float
  Local H21 as float
  Local H12 as float
  Local H22 as float
    
  H11=terrainH(X1,Y1)
  H21=terrainH(X2,Y1)
  H12=terrainH(X1,Y2)
  H22=terrainH(X2,Y2)
  
  stepX = X2-X1
  stepY = Y2-Y1

  NewX=X1+stepX/2
  NewY=Y1+stepY/2
  
  if marker(NewX,Y1) = 0 then terrainH(NewX,Y1)=(H11+H21)/2.0+(rnd(100)-50)*scale#:marker(NewX,Y1) = 1
  if marker(X1,NewY) = 0 then terrainH(X1,NewY)=(H11+H12)/2.0+(rnd(100)-50)*scale#:marker(X1,NewY) = 1
  if marker(NewX,Y2) = 0 then terrainH(NewX,Y2)=(H12+H22)/2.0+(rnd(100)-50)*scale#:marker(NewX,Y2) = 1
  if marker(X2,NewY) = 0 then terrainH(X2,NewY)=(H21+H22)/2.0+(rnd(100)-50)*scale#:marker(X2,NewY) = 1
  if marker(NewX,NewY) = 0 then terrainH(NewX,NewY)=(H11+H21+H12+H22)/4.0+(rnd(100)-50)*scale#:marker(NewX,NewY) = 1
        
  if (stepX<=2) and (stepY<=2) then exitfunction
  
  scale# = scale#*reduce#
  DivideArray(X1,Y1,NewX,NewY,scale#,reduce#)
  DivideArray(NewX,Y1,X2,NewY,scale#,reduce#)
  DivideArray(X1,NewY,NewX,Y2,scale#,reduce#)
  DivideArray(NewX,NewY,X2,Y2,scale#,reduce#)

Endfunction

function ScaleTerrain(sizeX,sizeY)
  minH = 999999
  maxH = -999999
  for x = 1 to sizeX
    for y = 1 to sizeY
      minH = min(terrainH(x,y), minH)
      maxH = max(terrainH(x,y), maxH)
    next y
  next x
  factor# = 255.0/(maxH-minH)
  for x = 1 to sizeX
    for y = 1 to sizeY
      terrainH(x,y) = factor# * (terrainH(x,y)-minH)
    next y
  next x
endfunction

Back to top

Profile PM Email

General Jackson

User Banned

Posted: 18th Oct 2010 19:38

Link

Can I use this too?
Pretty please?

Back to top

Profile

Madscientist

14

Years of Service

User Offline

Joined: 23rd Aug 2009

Location: Between a rock and a hard place

Posted: 18th Oct 2010 19:47

Link

Pretty sweet. Yes, you can use this code however you want. Gonna apply the heightmap to a terrain and post a screenshot when I get back to my home computer.

My computer surpasses all the technologies of the day. What computer do I have?

+ Code Snippet

My Brain

Back to top

Profile PM

Madscientist

14

Years of Service

User Offline

Joined: 23rd Aug 2009

Location: Between a rock and a hard place

Posted: 19th Oct 2010 05:10 Edited at: 19th Oct 2010 05:13

Link

Added to it, made image generation faster with memblocks. Also creates a terrain object with it.

set display mode desktop width(), desktop height(), 32
Set window position 0,0

sync on
sync rate 60

objId = 1 ` not implemented yet
scale# = 5.3 ` probably any non-zero value will work
reduce# = 0.5 ` values in the range 0.5 to 1.0 work best
sizeX = 512 ` doesn't need to be square
sizeY = 512
GenerateTerrain(objId,scale#,reduce#,sizeX,sizeY)

Ink rgb(255,255,255),rgb(0,0,0)
Text 0,sizeY+10, "DONE"
load image "Heightmap.jpg",2
Paste image 2,0,0

sync
sync
wait key
position camera 0,100,0

Make object Terrain 1
set terrain heightmap 1, "Heightmap.jpg"
set terrain scale 1,5,1,5
set terrain split 1, 32
set terrain tiling 1, 32
set terrain light 1, 1, -0.25, 0, 1, 1, 0.78, 0.5
build terrain 1
position object 1,0,0,0
      
do
   
   ControlCam(0,5.0)
   sync
loop

Function GenerateTerrain(Obj,scale#,reduce#,sizeX,sizeY)
  Global Dim terrainH(sizeX,sizeY) as Float
  global dim marker(sizeX,sizeY)
  for x = 1 to sizeX
    for y = 1 to sizeY
      marker(x,y) = 0
    next y
  next x
  InitialiseArray(sizeX,sizeY)
  DivideArray(1,1,sizeX,sizeY,scale#,reduce#)
  
  Img=CreateImage(SizeX,SizeY)
  Save image "Heightmap.jpg",Img
Endfunction

function InitialiseArray(sizeX,sizeY)
  terrainH(1,1) = 0
  terrainH(1,sizeY) = 0
  terrainH(sizeX,1) = 0
  terrainH(sizeX,sizeY) = 0
endfunction

Function DivideArray(X1,Y1,X2,Y2,scale#,reduce#)
  Local H11 as float
  Local H21 as float
  Local H12 as float
  Local H22 as float
    
  H11=terrainH(X1,Y1)
  H21=terrainH(X2,Y1)
  H12=terrainH(X1,Y2)
  H22=terrainH(X2,Y2)
  
  stepX = X2-X1
  stepY = Y2-Y1

NewX=X1+stepX/2
  NewY=Y1+stepY/2
  
  if marker(NewX,Y1) = 0 then terrainH(NewX,Y1)=(H11+H21)/2.0+(rnd(100)-50)*scale#:marker(NewX,Y1) = 1
  if marker(X1,NewY) = 0 then terrainH(X1,NewY)=(H11+H12)/2.0+(rnd(100)-50)*scale#:marker(X1,NewY) = 1
  if marker(NewX,Y2) = 0 then terrainH(NewX,Y2)=(H12+H22)/2.0+(rnd(100)-50)*scale#:marker(NewX,Y2) = 1
  if marker(X2,NewY) = 0 then terrainH(X2,NewY)=(H21+H22)/2.0+(rnd(100)-50)*scale#:marker(X2,NewY) = 1
  if marker(NewX,NewY) = 0 then terrainH(NewX,NewY)=(H11+H21+H12+H22)/4.0+(rnd(100)-50)*scale#:marker(NewX,NewY) = 1
        
  if (stepX<=2) and (stepY<=2) then exitfunction
  
  scale# = scale#*reduce#
  DivideArray(X1,Y1,NewX,NewY,scale#,reduce#)
  DivideArray(NewX,Y1,X2,NewY,scale#,reduce#)
  DivideArray(X1,NewY,NewX,Y2,scale#,reduce#)
  DivideArray(NewX,NewY,X2,Y2,scale#,reduce#)

Endfunction

Function CreateImage(SizeX,SizeY)
   mem=FreeMem()
   
   cls
   img=FreeImg()
   get image img,0,0,SizeX,SizeY
   
   make memblock from image mem,img
   MemW=memblock dword(mem,0)
   MemH=memblock dword(mem,4)
   
   For X=1 to sizeX
      For Y=1 to sizeY
         col=int(TerrainH(X,Y))
         Pos=(3+x+y*MemW)*4
         
         if col<0 then col=0
         if col>255 then col=255
         
         if Pos<  Get Memblock Size(mem)
            Write memblock byte mem,Pos,Col
            Write memblock byte mem,Pos+1,Col
            Write memblock byte mem,Pos+2,Col
         endif
      Next Y
   Next X
   
   Delete image img
   Make image from memblock img,mem
   Delete memblock mem   
Endfunction img

Function FreeMem()
   mem=1
   while memblock exist(mem)
      inc mem
   endwhile
endfunction mem

Function FreeImg()
   Img=1
   while Image exist(Img)
      inc Img
   endwhile
endfunction Img

Function ControlCam(cam,Sp#)
   rotate camera Cam,camera angle x(Cam)+(mousemovey()/2),camera angle y(Cam)+(mousemovex()/2.0),0

If keystate(17)=1 then move camera Cam,Sp#
   If keystate(31)=1 then move camera Cam,-Sp#

If keystate(30)=1
      Yrotate camera Cam,Camera angle Y(Cam)-90
      Move camera Cam,Sp#
      Yrotate camera Cam,Camera angle Y(Cam)+90
   endif

If keystate(32)=1
      Yrotate camera Cam,Camera angle Y(Cam)+90
      Move camera Cam,Sp#
      Yrotate camera Cam,Camera angle Y(Cam)-90
   endif

if wrapvalue(camera angle x(Cam))>40 and wrapvalue(camera angle x(Cam))<180 then xrotate camera Cam,40
   if wrapvalue(camera angle x(Cam))>180 and wrapvalue(camera angle x(Cam))<280 then xrotate camera Cam,280

position camera Cam,camera position X(Cam),camera position Y(Cam)-FallVelocity#,camera position Z(Cam)
Endfunction

+ Code Snippet


set display mode desktop width(), desktop height(), 32
Set window position 0,0

sync on
sync rate 60

objId = 1 ` not implemented yet
scale# = 5.3 ` probably any non-zero value will work
reduce# = 0.5 ` values in the range 0.5 to 1.0 work best
sizeX = 512 ` doesn't need to be square
sizeY = 512
GenerateTerrain(objId,scale#,reduce#,sizeX,sizeY)


Ink rgb(255,255,255),rgb(0,0,0)
Text 0,sizeY+10, "DONE"
load image "Heightmap.jpg",2
Paste image 2,0,0


sync
sync
wait key
position camera 0,100,0

Make object Terrain 1
set terrain heightmap 1, "Heightmap.jpg"
set terrain scale 1,5,1,5
set terrain split 1, 32
set terrain tiling 1, 32
set terrain light 1, 1, -0.25, 0, 1, 1, 0.78, 0.5
build terrain 1
position object 1,0,0,0
      
do
   
   ControlCam(0,5.0)
   sync
loop

Function GenerateTerrain(Obj,scale#,reduce#,sizeX,sizeY)
  Global Dim terrainH(sizeX,sizeY) as Float
  global dim marker(sizeX,sizeY)
  for x = 1 to sizeX
    for y = 1 to sizeY
      marker(x,y) = 0
    next y
  next x
  InitialiseArray(sizeX,sizeY)
  DivideArray(1,1,sizeX,sizeY,scale#,reduce#)
  
  Img=CreateImage(SizeX,SizeY)
  Save image "Heightmap.jpg",Img
Endfunction

function InitialiseArray(sizeX,sizeY)
  terrainH(1,1) = 0
  terrainH(1,sizeY) = 0
  terrainH(sizeX,1) = 0
  terrainH(sizeX,sizeY) = 0
endfunction

Function DivideArray(X1,Y1,X2,Y2,scale#,reduce#)
  Local H11 as float
  Local H21 as float
  Local H12 as float
  Local H22 as float
    
  H11=terrainH(X1,Y1)
  H21=terrainH(X2,Y1)
  H12=terrainH(X1,Y2)
  H22=terrainH(X2,Y2)
  
  stepX = X2-X1
  stepY = Y2-Y1

  NewX=X1+stepX/2
  NewY=Y1+stepY/2
  
  if marker(NewX,Y1) = 0 then terrainH(NewX,Y1)=(H11+H21)/2.0+(rnd(100)-50)*scale#:marker(NewX,Y1) = 1
  if marker(X1,NewY) = 0 then terrainH(X1,NewY)=(H11+H12)/2.0+(rnd(100)-50)*scale#:marker(X1,NewY) = 1
  if marker(NewX,Y2) = 0 then terrainH(NewX,Y2)=(H12+H22)/2.0+(rnd(100)-50)*scale#:marker(NewX,Y2) = 1
  if marker(X2,NewY) = 0 then terrainH(X2,NewY)=(H21+H22)/2.0+(rnd(100)-50)*scale#:marker(X2,NewY) = 1
  if marker(NewX,NewY) = 0 then terrainH(NewX,NewY)=(H11+H21+H12+H22)/4.0+(rnd(100)-50)*scale#:marker(NewX,NewY) = 1
        
  if (stepX<=2) and (stepY<=2) then exitfunction
  
  scale# = scale#*reduce#
  DivideArray(X1,Y1,NewX,NewY,scale#,reduce#)
  DivideArray(NewX,Y1,X2,NewY,scale#,reduce#)
  DivideArray(X1,NewY,NewX,Y2,scale#,reduce#)
  DivideArray(NewX,NewY,X2,Y2,scale#,reduce#)

Endfunction

Function CreateImage(SizeX,SizeY)
   mem=FreeMem()
   
   cls
   img=FreeImg()
   get image img,0,0,SizeX,SizeY
   
   make memblock from image mem,img
   MemW=memblock dword(mem,0)
   MemH=memblock dword(mem,4)
   
   For X=1 to sizeX
      For Y=1 to sizeY
         col=int(TerrainH(X,Y))
         Pos=(3+x+y*MemW)*4
         
         if col<0 then col=0
         if col>255 then col=255
         
         if Pos<  Get Memblock Size(mem)
            Write memblock byte mem,Pos,Col
            Write memblock byte mem,Pos+1,Col
            Write memblock byte mem,Pos+2,Col
         endif
      Next Y
   Next X
   
   Delete image img
   Make image from memblock img,mem
   Delete memblock mem   
Endfunction img


Function FreeMem()
   mem=1
   while memblock exist(mem)
      inc mem
   endwhile
endfunction mem

Function FreeImg()
   Img=1
   while Image exist(Img)
      inc Img
   endwhile
endfunction Img


Function ControlCam(cam,Sp#)
   rotate camera Cam,camera angle x(Cam)+(mousemovey()/2),camera angle y(Cam)+(mousemovex()/2.0),0

   If keystate(17)=1 then move camera Cam,Sp#
   If keystate(31)=1 then move camera Cam,-Sp#

   If keystate(30)=1
      Yrotate camera Cam,Camera angle Y(Cam)-90
      Move camera Cam,Sp#
      Yrotate camera Cam,Camera angle Y(Cam)+90
   endif

   If keystate(32)=1
      Yrotate camera Cam,Camera angle Y(Cam)+90
      Move camera Cam,Sp#
      Yrotate camera Cam,Camera angle Y(Cam)-90
   endif

   if wrapvalue(camera angle x(Cam))>40 and wrapvalue(camera angle x(Cam))<180 then xrotate camera Cam,40
   if wrapvalue(camera angle x(Cam))>180 and wrapvalue(camera angle x(Cam))<280 then xrotate camera Cam,280

   position camera Cam,camera position X(Cam),camera position Y(Cam)-FallVelocity#,camera position Z(Cam)
Endfunction

My computer surpasses all the technologies of the day. What computer do I have?

+ Code Snippet

My Brain

Back to top

Profile PM

Green Gandalf

VIP Member

19

Years of Service

User Offline

Joined: 3rd Jan 2005

Playing: Malevolence:Sword of Ahkranox, Skyrim, Civ6.

Posted: 19th Oct 2010 12:43

Link

Nice.

Back to top

Profile PM Email

Madscientist

14

Years of Service

User Offline

Joined: 23rd Aug 2009

Location: Between a rock and a hard place

Posted: 24th Oct 2010 00:53

Link

Need more help GG. My plan is to generate a terrain rgb map for one of your terrain shaders that makes the red textured with a certain image, and green and blue textured with others. So I base each rgb value off a different color range and create a new image. However my equations are somehow off.

Function CreateColorCode(img,rng)
   Local R as Byte
   Local G as Byte
   Local B as Byte
   
   mem=FreeMem()
   Make memblock from image Mem,Img
   
   mem2=FreeMem()
   Make memblock from image Mem2,Img
   
   Size= Get memblock size(Mem)
   
   Set Cursor 0,600
      for p=12 to size step 4
         if p+2<size
              col=memblock byte(Mem,P)
              R=0:G=0:B=0              
              
              Write Memblock Byte mem2,p+2,0
              Write Memblock Byte mem2,p+1,0       
              Write Memblock Byte mem2,p,0      
                            
              If col<=85+rng
                  Perc#=col/(85.0+Rng)
                  Perc#=1.0-Perc#
                  R=Abs(int(Perc#*255.0))
              endif
              If col>=85-Rng and Col<=170+Rng
                  Perc#=(col-(85.0-Rng))/(((170.0+rng)-(85.0-Rng))/2.0)
                  if Perc#>1.0 then Dec Perc#,1.0
                  G=Abs(int(Perc#*255.0))
              endif           
              If col>=170-Rng and col<=255
                  Perc#=(col-(170.0-Rng))/((255.0-(170.0-Rng))/2.0)
                  if Perc#>1.0 then Dec Perc#,1.0
                  B=Abs(int(Perc#*255.0))
              endif
              
              Write Memblock Byte mem2,p+2,R
              Write Memblock Byte mem2,p+1,G       
              Write Memblock Byte mem2,p,B     
         endif
      next p

Img2=FreeImg()
      Make image from memblock Img2,Mem2
      Delete memblock Mem
      Delete Memblock Mem2
Endfunction Img2

+ Code Snippet

Function CreateColorCode(img,rng)
   Local R as Byte
   Local G as Byte
   Local B as Byte
   
   mem=FreeMem()
   Make memblock from image Mem,Img
   
   mem2=FreeMem()
   Make memblock from image Mem2,Img
   
   Size= Get memblock size(Mem)
   
   Set Cursor 0,600
      for p=12 to size step 4
         if p+2<size
              col=memblock byte(Mem,P)
              R=0:G=0:B=0              
              
              Write Memblock Byte mem2,p+2,0
              Write Memblock Byte mem2,p+1,0       
              Write Memblock Byte mem2,p,0      
                            
              If col<=85+rng
                  Perc#=col/(85.0+Rng)
                  Perc#=1.0-Perc#
                  R=Abs(int(Perc#*255.0))
              endif
              If col>=85-Rng and Col<=170+Rng
                  Perc#=(col-(85.0-Rng))/(((170.0+rng)-(85.0-Rng))/2.0)
                  if Perc#>1.0 then Dec Perc#,1.0
                  G=Abs(int(Perc#*255.0))
              endif           
              If col>=170-Rng and col<=255
                  Perc#=(col-(170.0-Rng))/((255.0-(170.0-Rng))/2.0)
                  if Perc#>1.0 then Dec Perc#,1.0
                  B=Abs(int(Perc#*255.0))
              endif
              
              Write Memblock Byte mem2,p+2,R
              Write Memblock Byte mem2,p+1,G       
              Write Memblock Byte mem2,p,B     
         endif
      next p

      Img2=FreeImg()
      Make image from memblock Img2,Mem2
      Delete memblock Mem
      Delete Memblock Mem2
Endfunction Img2

My computer surpasses all the technologies of the day. What computer do I have?

+ Code Snippet

My Brain

Back to top

Profile PM

Sorry your browser is not supported!

DarkBASIC Professional Discussion / Terrain generator