Heightmaps using midpoint displacement

eesau · Post by **eesau** » Wed Mar 11, 2009 5:12 pm

Here's something I needed recently, something to create heightmaps. It uses random midpoint displacement to make the heightmap, so it's not always very natural looking, but good enough!

Code: Select all

EnableExplicit

; <<<<<<<<<<<<<<<<<<<<<
; <<<<             <<<<
; <<<<    Enums    <<<<
; <<<<             <<<<
; <<<<<<<<<<<<<<<<<<<<<

#Width = 513
#Height = 513

; <<<<<<<<<<<<<<<<<<<
; <<<<           <<<<
; <<<<    Map    <<<<
; <<<<           <<<<
; <<<<<<<<<<<<<<<<<<<

Procedure MapHeightGet ( Array Map ( 2 ) , X , Y )

	If X => 1 And X <= #Width
	
		If Y => 1 And Y <= #Height

			ProcedureReturn Map ( X , Y )

		EndIf
		
	EndIf

EndProcedure

Procedure MapHeightSet ( Array Map ( 2 ) , X , Y , Value )

	If Value < 0
	
		Value = 0
		
	ElseIf Value > 255
	
		Value = 255
		
	EndIf

	If X => 1 And X <= #Width
	
		If Y => 1 And Y <= #Height
			
			Map ( X , Y ) = Value
			
		EndIf
		
	EndIf

EndProcedure

Procedure MapDrawGrayscale ( Array Map ( 2 ) , Image )

	Protected X , Y , Color

	If StartDrawing ( ImageOutput ( Image ) )
	
		For Y = 1 To #Height
		
			For X = 1 To #Width
			
				Color = MapHeightGet ( Map ( ) , X , Y )

				Plot ( X , Y , RGB ( Color , Color , Color ) )
			
			Next
			
		Next

		StopDrawing ( )
	
	EndIf

EndProcedure

Procedure MapDrawColor ( Array Map ( 2 ) , Image )

	Protected X , Y , Z , Color

	If StartDrawing ( ImageOutput ( Image ) )
	
		For Y = 1 To #Height
		
			For X = 1 To #Width
			
				Z = MapHeightGet ( Map ( ) , X , Y )
									
				Select Z
				
					; Water
				
					Case 0 To 15 : Color = RGB ( 0 , 0 , 100 )
					Case 16 To 31 : Color = RGB ( 0 , 0 , 120 )
					Case 32 To 63 : Color = RGB ( 0 , 0 , 140 )
		
					; Beach
						
					Case 64 To 70 : Color = RGB ( 64 , 95 , 134 )
					Case 71 To 95 : Color = RGB ( 128 , 190 , 128 )
					Case 96 To 127 : Color = RGB ( 140 , 210 , 140 )

					; Lowland
				
					Case 128 To 159 : Color = RGB ( 160 , 210 , 140 )
					Case 160 To 180 : Color = RGB ( 180 , 210 , 140 )
					Case 181 To 199 : Color = RGB ( 190 , 220 , 150 )
					
					; Hills

					Case 200 To 219 : Color = RGB ( 185 , 185 , 130 )
					Case 220 To 229 : Color = RGB ( 182 , 177 , 130 )
					Case 230 To 239 : Color = RGB ( 180 , 170 , 130 )
					
					; Mountains
							
					Case 240 To 244 : Color = RGB ( 215 , 215 , 215 )
					Case 245 To 249 : Color = RGB ( 230 , 230 , 230 )
					Case 250 To 253 : Color = RGB ( 250 , 250 , 250 )
					Case 254 To 255 : Color = RGB ( 255 , 255 , 255 )
				
				EndSelect
								
				Plot ( X , Y , Color )
			
			Next
			
		Next

		StopDrawing ( )
	
	EndIf

EndProcedure

; <<<<<<<<<<<<<<<<<<<<<<<<<
; <<<<                 <<<<
; <<<<    Heightmap    <<<<
; <<<<                 <<<<
; <<<<<<<<<<<<<<<<<<<<<<<<<

Procedure HeightmapInvert ( Array Map ( 2 ) )

	Protected X , Y

	For Y = 1 To #Height
	
		For X = 1 To #Width
		
			MapHeightSet ( Map ( ) , X , Y , 255 - MapHeightGet ( Map ( ) , X , Y ) )
			
		Next
		
	Next

EndProcedure

Procedure HeightmapBlur ( Array Map ( 2 ) )

	Protected X , CX
	Protected Y , CY
	Protected Z
	
	For Y = 3 To #Height - 4
	
		For X = 3 To #Width - 4

			For CY = Y - 2 To Y + 2
			
				For CX = X - 2 To X + 2
				
					Z + MapHeightGet ( Map ( ) , CX , CY )
					
				Next
				
			Next
			
			MapHeightSet ( Map ( ) , X , Y , Z / 25 )
			
			Z = 0
				
		Next
		
	Next

EndProcedure

Procedure HeightmapNoise ( Array Map ( 2 ) , Amount , Intensity )

	Protected X
	Protected Y
	Protected Z
	Protected Q

	Protected Alpha . f
	Protected Omega . f

	If Amount < 0
		
		Amount = 0
		
	ElseIf Amount > 255
	
		Amount = 255
		
	EndIf
	
	If Intensity < 0
	
		Intensity = 0
	
	ElseIf Intensity > 255
	
		Intensity = 255
		
	EndIf

	Alpha = Intensity
	Omega = 255 - Alpha

	For Y = 1 To #Height
	
		For X = 1 To #Width
		
			If Random ( 255 ) < Amount
			
				Z = MapHeightGet ( Map ( ) , X , Y )
				
				Q = Z + ( Intensity - Random ( Intensity ) )
				
				If Q < 0
				
					Q = 0
					
				ElseIf Q > 255
				
					Q = 255
					
				EndIf
				
				Z = ( Z * Alpha + Q * Omega ) / 256
						
				MapHeightSet ( Map ( ) , X , Y , Z )
				
			EndIf
								
		Next
		
	Next	

EndProcedure

Procedure HeightmapNormalize ( Array Map ( 2 ) , Threshold , Amount . f )

	Protected X
	Protected Y
	Protected Z

	If Amount < 0.0
		
		Amount = 0.0
		
	ElseIf Amount > 1.0
	
		Amount = 1.0
		
	EndIf
	
	If Threshold < 0
	
		Threshold = 0
	
	ElseIf Threshold > 255
	
		Threshold = 255
		
	EndIf

	For Y = 1 To #Height
	
		For X = 1 To #Width
		
			Z = MapHeightGet ( Map ( ) , X , Y )
			
			If Z > Threshold
			
				Z - ( Z - Threshold ) * Amount
						
			ElseIf Z < Threshold
			
				Z + ( Threshold - Z ) * Amount
						
			EndIf
		
			If Z < 0
			
				Z = 0
				
			ElseIf Z > 255
			
				Z = 255
				
			EndIf
		
			MapHeightSet ( Map ( ) , X , Y , Z )
		
		Next
		
	Next

EndProcedure

Procedure HeightmapDivider ( Array Map ( 2 ) , X . f , Y . f , Width . f , Height . f , C1 . f , C2 . f , C3 . f , C4 . f )

	Protected Edge1 . f
	Protected Edge2 . f
	Protected Edge3 . f
	Protected Edge4 . f
	Protected Middle . f

	Protected NewWidth . f = Width / 2
	Protected NewHeight . f = Height / 2

	Protected Displacement . f
	Protected Weight . f

	If Width > 2 Or Height > 2
		
		Displacement = ( Random ( 1 ) - 0.5 ) * ( ( NewWidth + NewHeight ) / ( #Width + #Height ) * 3 )
		
		Middle = ( C1 + C2 + C3 + C4 ) / 4 + Displacement
		
		Edge1 = ( C1 + C2 ) / 2
		Edge2 = ( C2 + C3 ) / 2
		Edge3 = ( C3 + C4 ) / 2
		Edge4 = ( C4 + C1 ) / 2
	
		If Middle < 0.0

			Middle = 0.0

		ElseIf Middle > 1.0
		
			Middle = 1.0
		
		EndIf

		HeightmapDivider ( Map ( ) , X , Y , NewWidth , NewHeight , C1 , Edge1 , Middle , Edge4 )
		HeightmapDivider ( Map ( ) , X + NewWidth , Y , NewWidth , NewHeight , Edge1 , C2 , Edge2 , Middle )
		HeightmapDivider ( Map ( ) , X + NewWidth , Y + NewHeight , NewWidth , NewHeight , Middle , Edge2 , C3 , Edge3 )
		HeightmapDivider ( Map ( ) , X , Y + NewHeight , NewWidth , NewHeight , Edge4 , Middle , Edge3 , C4 )

	Else

		Weight = ( C1 + C2 + C3 + C4 ) / 4

		MapHeightSet ( Map ( ) , Int ( X ) , Int ( Y ) , Weight * 255 )
				
	EndIf

EndProcedure

Procedure HeightmapCreate ( Array Map ( 2 ) )

	Protected Width  = ArraySize ( Map ( ) , 1 )
	Protected Height = ArraySize ( Map ( ) , 2 )

	Protected C1 . f = Random ( 1 )
	Protected C2 . f = Random ( 1 )
	Protected C3 . f = Random ( 1 )
	Protected C4 . f = Random ( 1 )

	HeightmapDivider ( Map ( ) , 1 , 1 , Width , Height , C1 , C2 , C3 , C4 )

EndProcedure

; <<<<<<<<<<<<<<<<<<<<
; <<<<            <<<<
; <<<<    Main    <<<<
; <<<<            <<<<
; <<<<<<<<<<<<<<<<<<<<

DisableExplicit

Dim Map ( #Width , #Height )

HeightmapCreate ( Map ( ) )

CreateImage ( 0 , #Width , #Height )

OpenWindow ( 0 , 0 , 0 , #Width , #Height , "Heightmap" , #PB_Window_SystemMenu | #PB_Window_ScreenCentered )

Mode = #True

MapDrawColor ( Map ( ) , 0 )

ImageGadget ( 0 , WindowWidth ( 0 ) / 2 - ImageWidth ( 0 ) / 2 , WindowHeight ( 0 ) / 2 - ImageHeight ( 0 ) / 2 , 0 , 0 , ImageID ( 0 ) )

AddKeyboardShortcut ( 0 , #PB_Shortcut_Return , 0 )
AddKeyboardShortcut ( 0 , #PB_Shortcut_1 , 1 )
AddKeyboardShortcut ( 0 , #PB_Shortcut_2 , 2 )
AddKeyboardShortcut ( 0 , #PB_Shortcut_N , 3 ) ; Normalize
AddKeyboardShortcut ( 0 , #PB_Shortcut_Z , 4 ) ; Noise
AddKeyboardShortcut ( 0 , #PB_Shortcut_B , 5 ) ; Blur
AddKeyboardShortcut ( 0 , #PB_Shortcut_I , 6 ) ; Invert

Repeat

	Event = WaitWindowEvent ( )

	If Event = #PB_Event_Menu
	
		Select EventMenu ( )
	
			Case 0
				
				HeightmapCreate ( Map ( ) )
			
				Draw = #True

			Case 1
			
				Mode = #False
				Draw = #True
			
			Case 2
			
				Mode = #True
				Draw = #True
			
			Case 3
			
				HeightmapNormalize ( Map ( ) , 160 , 0.05 )
				
				Draw = #True
						
			Case 4
			
				HeightmapNoise ( Map ( ) , 128 , 2 )
				
				Draw = #True
					
			Case 5
			
				HeightmapBlur ( Map ( ) )
				
				Draw = #True

			Case 6
			
				HeightmapInvert ( Map ( ) )
				
				Draw = #True
							
		EndSelect
	
		If Draw
		
			If Mode
		
				MapDrawColor ( Map ( ) , 0 )
		
			Else
				
				MapDrawGrayscale ( Map ( ) , 0 )
		
			EndIf
			
			Draw = #False
			
		EndIf
	
		SetGadgetState ( 0 , ImageID ( 0 ) )
	
	EndIf
		
Until Event = #PB_Event_CloseWindow

Keys 1 and 2 switch between grayscale and color heightmap. Enter creates a new heightmap.

Edit: Updated the code to add more functionality, you can now add noise, invert, blur and normalize the heightmap, by using Z, I, B, and N -keys.

dige · Post by **dige** » Thu Mar 12, 2009 9:22 am

That's cool! thx for sharing!

Num3 · Post by **Num3** » Thu Mar 12, 2009 10:48 am

Very nice!

Num3 · Post by **Num3** » Thu Mar 12, 2009 6:37 pm

I made a little change to your code to support procedural texture generation.

I'll clean it up and post it Saturday

eesau · Post by **eesau** » Thu Mar 12, 2009 9:26 pm

Num3: Looks good

I updated the first post to add some more functionality to the code. I will add erosion soon to make more natural-looking heightmaps. And maybe something to create lightmaps as well?

Num3 · Post by **Num3** » Fri Mar 13, 2009 12:18 pm

eesau wrote:Num3: Looks good

I updated the first post to add some more functionality to the code. I will add erosion soon to make more natural-looking heightmaps. And maybe something to create lightmaps as well?

Yeah! That would be nice too!

I've already change my code to work with your update.

Next i'm gonna add 8 texture levels instead of just 4

Here's a 1024x1024 cropped screenshot so you can check the detail on it:

Heathen · Post by **Heathen** » Fri Mar 13, 2009 3:33 pm

Thanks for this, I also have a few landscape generating procedures lying around for a game I've been making.

Diamond Square algorithm (got from a website):

Code: Select all

#MAXPOW = 10
#MAXSZ = ((1<<#MAXPOW)+1)
Global Dim ht.f(#MAXSZ,#MAXSZ)

Procedure.d randf()
  ProcedureReturn (Random(20001)-10000)/10000
EndProcedure

Procedure.f diamond_square(n,falloff.d)
  Protected avg.d,c.d,ulx, uly, Dm,s, i, j, x, y,min.d,max.d
  Dm=1<<(n-2);
; /* seed the first few Array values With reasonable numbers */
  For j = 0 To 4
    For i = 0 To 4
      ht(Dm*i, Dm*j)=0.75+randf()/8;
    Next i
  Next j
; /* run the algorithm */
  c=1.0;
  For s = 2 To n-1
    sv = (1<<s)
    c*falloff;
    Dm=(1<<(n-s));
    For j=0 To sv-1
      For i=0 To sv-1
        uly=j*Dm;
        ulx=i*Dm;
        y=(1<<(n-s-1))+j*(1<<(n-s));
        x=(1<<(n-s-1))+i*(1<<(n-s));
        avg=0;
        avg+ht(ulx, uly);
        avg+ht(ulx+Dm, uly);
        avg+ht(ulx, uly+Dm);
        avg+ht(ulx+Dm, uly+Dm);
        avg/4;
        ht(x, y)=avg+c*randf();
      Next i
    Next j
    Dm=(1<<(n-s-1));
    For j=0 To 1<<(s+1)
      For i=0 To 1<<(s+1)
        If (i+j)%2=0
          Continue;
        EndIf
        y=j*Dm;
        x=i*Dm;
        avg=0;
        If (x-Dm>=0)
          xx = (x-Dm)
        Else
          xx = (x-Dm+(1<<n))
        EndIf
        avg+ht(xx, y);
        If (y-Dm>=0)
          yy = (y-Dm)
        Else
          yy = (y-Dm+(1<<n))
        EndIf
        avg+ht(x, yy);
        If (x+Dm<=(1<<n))
          xx = (x+Dm)
        Else
          xx = (x+Dm-(1<<n))
        EndIf
        avg+ht(xx, y);
        If (y+Dm<=(1<<n))
          yy = (y+Dm)
        Else
          yy = (y+Dm-(1<<n))
        EndIf
        avg+ht(x, yy);
        avg/4;
        ht(x, y)=avg+c*randf();
      Next i
    Next j
  Next s
  sz=(1<<n)+1
  min=ht(0,0)
  max=ht(0,0);
  For y=0 To sz-1
    For x=0 To sz-1
      If (ht(x, y)>max) 
        max=ht(x, y);
      EndIf
      If (ht(x, y)<min) 
        min=ht(x, y);
      EndIf
    Next x
  Next y
  For y = 0 To sz - 1
    For x = 0 To sz - 1
      ht(x, y)=(ht(x, y)-min)/(max-min);
    Next x
  Next y
EndProcedure

I use this and Perlin noise for generating planets in a retro space game.

mpz · Post by **mpz** » Fri Mar 13, 2009 4:23 pm

Hi,

this sound great and i need this for my 3D Engine too. Her comes a little program with my 3D engine for testing this kind of higmaps. Use a,y,cursor (left,up,down,right) for moving and Space for loading grayscale map and color map. i have included the highmap and color map as example...

Highmapdemo:
http://rapidshare.de/files/46062360/MP_ ... o.exe.html

best regards,
Michael

Code: Select all

;////////////////////////////////////////////////////////////////
;//
;// Project Title: MP 3D Engine
;// File Title: Terrain.pb
;// Created On: 2.12.2008
;// Updated On: 
;// Author: Michael Paulwitz
;// OS:Windows
;// 
;// Highmap Demofile
;// 
;////////////////////////////////////////////////////////////////

;-
;- ProgrammStart

MP_Graphics3D (640,480,0,3) ; Erstelle ein WindowsFenster #Window = 0
SetWindowTitle(0, "3D Terrain") ; So soll es heissen

camera=MP_CreateCamera() ; create camera
light=MP_CreateLight(1,90,0,0) ; Es werde Licht

Highmap = MP_CreateTextureFromFileInMemory (?highmap,?highmap-?colormap) ; Include Grafikdatei wird Texture / Include Grafik to Texture 
terrain=MP_TextureToTerrain_Var ( Highmap , 128, 128 , 0 , 6 )
Texture = MP_CreateTextureFromFileInMemory (?colormap,?colormap-?endmap) ; Include Grafikdatei wird Texture / Include Grafik to Texture 
MP_EntityTexture (terrain, Texture )    
max.f = MP_MeshHeight(terrain) ; find Maximum of Mesh
If MP_MeshWidth(terrain) > max
   max = MP_MeshWidth(terrain)
EndIf
If MP_Meshdepth(terrain) > max
   max = MP_Meshdepth(terrain) 
EndIf
scale.f = 4 / max ; 
MP_EntityScaling (terrain,scale,scale,scale)
x.f=0 : y.f=-130 : z.f = 6 ; Start of Mesh


While Not MP_KeyDown(#PB_Key_Escape) And Not MP_WindowEvent() = #PB_Event_CloseWindow; Esc abfrage oder schliessen

 If MP_KeyDown(#PB_Key_Left)=1  : x-1   : EndIf ;links Debug #PB_Key_Left 
 If MP_KeyDown(#PB_Key_Right)=1 : x+1   : EndIf ;rechts #PB_Key_Right 
 If MP_KeyDown(#PB_Key_Down)=1  : y-1   : EndIf ;Runter #PB_Key_Down 
 If MP_KeyDown(#PB_Key_Up)=1    : y+1   : EndIf ;rauf #PB_Key_Up 
 If MP_KeyDown(#PB_Key_Z)=1     : z+0.1 : EndIf ;y Vertauscht bei y-z bei deutscher tastatur 
 If MP_KeyDown(#PB_Key_Y)=1     : z+0.1 : EndIf ;y Vertauscht bei y-z bei deutscher tastatur 
 If MP_KeyDown(#PB_Key_A)=1     : z-0.1 : EndIf ;a #PB_Key_A 
 
 If terrain ; Objekt drehen
    MP_DrawText (2,2,MP_ARGB(255,255,255,255),"Triangles: "+Str(MP_CountTriangles(terrain))+"  Vertices: "+Str(MP_CountVertices(terrain))) 
    MP_PositionEntity (terrain,0,0,z) 
    MP_RotateEntity (terrain,x,y,0)
 EndIf
 
 If MP_KeyDown(#PB_Key_Space)=1

    File$ = OpenFileRequester("Please choose Grayscale Highmap", "", "Picture (*.*)|*.*", 0)
    If terrain:mp_freeentity(terrain):EndIf 
    terrain=MP_LoadTerrain_Var ( File$ , 128, 128 , 0 , 6 )
    
    File$ = OpenFileRequester("Please choose Colormap", "", "Picture (*.*)|*.*", 0)
    If Texture:mp_freeTexture(Texture):EndIf
    Texture = MP_LoadTexture(File$)
    MP_EntityTexture (terrain, Texture )    
    max.f = MP_MeshHeight(terrain) ; find Maximum of Mesh
    If MP_MeshWidth(terrain) > max
      max = MP_MeshWidth(terrain)
    EndIf
    If MP_Meshdepth(terrain) > max
      max = MP_Meshdepth(terrain) 
    EndIf
    scale.f = 4 / max ; 
    MP_EntityScaling (terrain,scale,scale,scale)
    x.f=0 : y.f=-130 : z.f = 6 
 EndIf

    MP_RenderWorld () ; Hier gehts los
    MP_Flip () ; 

Wend

End

highmap:  IncludeBinary "C:\temp\highmap\image2ico.jpg" ; My Grafikfile
colormap: IncludeBinary "C:\temp\highmap\imagetna.jpg" ; My Grafikfile
endmap:

Heathen · Post by **Heathen** » Fri Mar 13, 2009 5:13 pm

Does anyone have any code for handling large 3d terrain? I've been looking into various lod and paging algorithms and it hurts my brain lol.

mpz · Post by **mpz** » Fri Mar 13, 2009 6:24 pm

Hi,

in think Blitzbasic 3D use only a triangle algorythmus for a never ending plane. In this case you change the vertecs information of one row new and sets the trinagle of this vertecs new too...

best michael

Num3 · Post by **Num3** » Sun Mar 15, 2009 1:41 pm

Here we go, with procedural textures!

It uses 8 different textures that are combined according to the height level of the pixel on the heighmap.

Here's a screenshot:

Code: Select all

; <<<<<<<<<<<<<<<<<<<<<
; <<<<             <<<<
; <<<<    Enums    <<<<
; <<<<             <<<<
; <<<<<<<<<<<<<<<<<<<<<

#Width = 64 *4+1
#Height = 64 *4+1
#NB_Textures = 8

UsePNGImageDecoder()
UseJPEGImageDecoder()


Procedure MapHeightGet ( Array map ( 2 ) , x , y )
  
  If x => 1 And x <= #Width
    
    If y => 1 And y <= #Height
      
      ProcedureReturn map ( x , y )
      
    EndIf
    
  EndIf
  
EndProcedure

Procedure.f texfactor(h1.f, h2.f)
  
  value.f=256/#NB_Textures
  
  percent.f;
  percent = (value - Abs(h1 - h2)) / value;
  
  If percent < 0.0
    percent = 0.0;
  ElseIf percent > 1.0
    percent = 1.0;
  EndIf
  
  ProcedureReturn percent
EndProcedure

Procedure MapDrawTexture (Array map ( 2 ) , Image)
  
  LoadImage(5,"ice.jpg")
  LoadImage(6,"stone.jpg")
  LoadImage(7,"rock_01.jpg")
  LoadImage(8,"rock_02.jpg")
  LoadImage(9,"dirt.jpg")
  LoadImage(10,"dirt_1.jpg")
  LoadImage(11,"beach.jpg")
  LoadImage(12,"water.jpg")
  
  For a= 5 To 5+#NB_Textures-1
    ResizeImage(a,#Width,#Height)
  Next
  
  Dim tex_fact.f(#NB_Textures)
  Dim TextureColor(#NB_Textures)
  
  hmap_height.f=0
  
  
  For y = 1 To #Height
    
    For x = 1 To #Width
      
      hmap_height=MapHeightGet ( map ( ) , x , y )
      
      valor=256/#NB_Textures
      
      
      For a=0 To #NB_Textures
        tex_fact(a)=texfactor(valor*(#NB_Textures-a), hmap_height);
      Next
      
      For a=0 To #NB_Textures-1
        StartDrawing(ImageOutput(a+5))
          TextureColor(a)=Point(x,y)
        StopDrawing()
      Next
      
      new_r=0 : new_g=0: new_b=0
      
      For a=0 To #NB_Textures-1
        new_r+(tex_fact(a)*Red(TextureColor(a)))
        new_g+(tex_fact(a)*Green(TextureColor(a)))
        new_b+(tex_fact(a)*Blue(TextureColor(a)))          
      Next
      
      StartDrawing ( ImageOutput ( Image ) )
        Plot ( x , y , RGB(new_r,new_g,new_b) )
      StopDrawing()
      
    Next
  Next
  
  
EndProcedure



Procedure MapHeightSet ( Array map ( 2 ) , x , y , value )
  
  If value < 0
    
    value = 0
    
  ElseIf value > 255
    
    value = 255
    
  EndIf
  
  If x => 1 And x <= #Width
    
    If y => 1 And y <= #Height
      
      map ( x , y ) = value
      
    EndIf
    
  EndIf
  
EndProcedure

Procedure MapDrawGrayscale ( Array map ( 2 ) , Image )
  
  Protected x , y , Color
  
  If StartDrawing ( ImageOutput ( Image ) )
      
      For y = 1 To #Height
        
        For x = 1 To #Width
          
          Color = MapHeightGet ( map ( ) , x , y )
          
          Plot ( x , y , RGB ( Color , Color , Color ) )
          
        Next
        
      Next
      
    StopDrawing ( )
    
  EndIf
  
EndProcedure

Procedure MapDrawColor ( Array map ( 2 ) , Image )
  
  Protected x , y , Z , Color
  
  If StartDrawing ( ImageOutput ( Image ) )
      
      For y = 1 To #Height
        
        For x = 1 To #Width
          
          Z = MapHeightGet ( map ( ) , x , y )
          
          Select Z
              
              ; Water
              
            Case 0 To 15 : Color = RGB ( 0 , 0 , 100 )
            Case 16 To 31 : Color = RGB ( 0 , 0 , 120 )
            Case 32 To 63 : Color = RGB ( 0 , 0 , 140 )
              
              ; Beach
              
            Case 64 To 70 : Color = RGB ( 64 , 95 , 134 )
            Case 71 To 95 : Color = RGB ( 128 , 190 , 128 )
            Case 96 To 127 : Color = RGB ( 140 , 210 , 140 )
              
              ; Lowland
              
            Case 128 To 159 : Color = RGB ( 160 , 210 , 140 )
            Case 160 To 180 : Color = RGB ( 180 , 210 , 140 )
            Case 181 To 199 : Color = RGB ( 190 , 220 , 150 )
              
              ; Hills
              
            Case 200 To 219 : Color = RGB ( 185 , 185 , 130 )
            Case 220 To 229 : Color = RGB ( 182 , 177 , 130 )
            Case 230 To 239 : Color = RGB ( 180 , 170 , 130 )
              
              ; Mountains
              
            Case 240 To 244 : Color = RGB ( 215 , 215 , 215 )
            Case 245 To 249 : Color = RGB ( 230 , 230 , 230 )
            Case 250 To 253 : Color = RGB ( 250 , 250 , 250 )
            Case 254 To 255 : Color = RGB ( 255 , 255 , 255 )
              
          EndSelect
          
          Plot ( x , y , Color )
          
        Next
        
      Next
      
    StopDrawing ( )
    
  EndIf
  
EndProcedure

; <<<<<<<<<<<<<<<<<<<<<<<<<
; <<<<                 <<<<
; <<<<    Heightmap    <<<<
; <<<<                 <<<<
; <<<<<<<<<<<<<<<<<<<<<<<<<

Procedure HeightmapInvert ( Array map ( 2 ) )
  
  Protected x , y
  
  For y = 1 To #Height
    
    For x = 1 To #Width
      
      MapHeightSet ( map ( ) , x , y , 255 - MapHeightGet ( map ( ) , x , y ) )
      
    Next
    
  Next
  
EndProcedure

Procedure HeightmapBlur ( Array map ( 2 ) )
  
  Protected x , CX
  Protected y , CY
  Protected Z
  
  For y = 3 To #Height - 4
    
    For x = 3 To #Width - 4
      
      For CY = y - 2 To y + 2
        
        For CX = x - 2 To x + 2
          
          Z + MapHeightGet ( map ( ) , CX , CY )
          
        Next
        
      Next
      
      MapHeightSet ( map ( ) , x , y , Z / 25 )
      
      Z = 0
      
    Next
    
  Next
  
EndProcedure

Procedure HeightmapNoise ( Array map ( 2 ) , Amount , Intensity )
  
  Protected x
  Protected y
  Protected Z
  Protected Q
  
  Protected Alpha . f
  Protected Omega . f
  
  If Amount < 0
    
    Amount = 0
    
  ElseIf Amount > 255
    
    Amount = 255
    
  EndIf
  
  If Intensity < 0
    
    Intensity = 0
    
  ElseIf Intensity > 255
    
    Intensity = 255
    
  EndIf
  
  Alpha = Intensity
  Omega = 255 - Alpha
  
  For y = 1 To #Height
    
    For x = 1 To #Width
      
      If Random ( 255 ) < Amount
        
        Z = MapHeightGet ( map ( ) , x , y )
        
        Q = Z + ( Intensity - Random ( Intensity ) )
        
        If Q < 0
          
          Q = 0
          
        ElseIf Q > 255
          
          Q = 255
          
        EndIf
        
        Z = ( Z * Alpha + Q * Omega ) / 256
        
        MapHeightSet ( map ( ) , x , y , Z )
        
      EndIf
      
    Next
    
  Next   
  
EndProcedure

Procedure HeightmapNormalize ( Array map ( 2 ) , Threshold , Amount . f )
  
  Protected x
  Protected y
  Protected Z
  
  If Amount < 0.0
    
    Amount = 0.0
    
  ElseIf Amount > 1.0
    
    Amount = 1.0
    
  EndIf
  
  If Threshold < 0
    
    Threshold = 0
    
  ElseIf Threshold > 255
    
    Threshold = 255
    
  EndIf
  
  For y = 1 To #Height
    
    For x = 1 To #Width
      
      Z = MapHeightGet ( map ( ) , x , y )
      
      If Z > Threshold
        
        Z - ( Z - Threshold ) * Amount
        
      ElseIf Z < Threshold
        
        Z + ( Threshold - Z ) * Amount
        
      EndIf
      
      If Z < 0
        
        Z = 0
        
      ElseIf Z > 255
        
        Z = 255
        
      EndIf
      
      MapHeightSet ( map ( ) , x , y , Z )
      
    Next
    
  Next
  
EndProcedure

Procedure HeightmapDivider ( Array map ( 2 ) , x . f , y . f , Width . f , Height . f , C1 . f , C2 . f , C3 . f , C4 . f )
  
  Protected Edge1 . f
  Protected Edge2 . f
  Protected Edge3 . f
  Protected Edge4 . f
  Protected Middle . f
  
  Protected NewWidth . f = Width / 2
  Protected NewHeight . f = Height / 2
  
  Protected Displacement . f
  Protected Weight . f
  
  If Width > 2 Or Height > 2
    
    Displacement = ( Random ( 1 ) - 0.5 ) * ( ( NewWidth + NewHeight ) / ( #Width + #Height ) * 3 )
    
    Middle = ( C1 + C2 + C3 + C4 ) / 4 + Displacement
    
    Edge1 = ( C1 + C2 ) / 2
    Edge2 = ( C2 + C3 ) / 2
    Edge3 = ( C3 + C4 ) / 2
    Edge4 = ( C4 + C1 ) / 2
    
    If Middle < 0.0
      
      Middle = 0.0
      
    ElseIf Middle > 1.0
      
      Middle = 1.0
      
    EndIf
    
    HeightmapDivider ( map ( ) , x , y , NewWidth , NewHeight , C1 , Edge1 , Middle , Edge4 )
    HeightmapDivider ( map ( ) , x + NewWidth , y , NewWidth , NewHeight , Edge1 , C2 , Edge2 , Middle )
    HeightmapDivider ( map ( ) , x + NewWidth , y + NewHeight , NewWidth , NewHeight , Middle , Edge2 , C3 , Edge3 )
    HeightmapDivider ( map ( ) , x , y + NewHeight , NewWidth , NewHeight , Edge4 , Middle , Edge3 , C4 )
    
  Else
    
    Weight = ( C1 + C2 + C3 + C4 ) / 4
    
    MapHeightSet ( map ( ) , Int ( x ) , Int ( y ) , Weight * 255 )
    
  EndIf
  
EndProcedure

Procedure HeightmapCreate ( Array map ( 2 ) )
  
  Protected Width  = ArraySize ( map ( ) , 1 )
  Protected Height = ArraySize ( map ( ) , 2 )
  
  Protected C1 . f = Random ( 1 )
  Protected C2 . f = Random ( 1 )
  Protected C3 . f = Random ( 1 )
  Protected C4 . f = Random ( 1 )
  
  HeightmapDivider ( map ( ) , 1 , 1 , Width , Height , C1 , C2 , C3 , C4 )
  
EndProcedure

; <<<<<<<<<<<<<<<<<<<<
; <<<<            <<<<
; <<<<    Main    <<<<
; <<<<            <<<<
; <<<<<<<<<<<<<<<<<<<<

DisableExplicit

Dim map ( #Width , #Height )

seed=Random(999999)

RandomSeed(seed)

HeightmapCreate ( map ( ) )

CreateImage ( 0 , #Width , #Height )

OpenWindow ( 0 , 0 , 0 , #Width , #Height , "Heightmap - Seed: "+Str(seed) , #PB_Window_SystemMenu | #PB_Window_ScreenCentered )

Mode = #True

MapDrawColor ( map ( ) , 0 )

ImageGadget ( 0 , WindowWidth ( 0 ) / 2 - ImageWidth ( 0 ) / 2 , WindowHeight ( 0 ) / 2 - ImageHeight ( 0 ) / 2 , 0 , 0 , ImageID ( 0 ) )

AddKeyboardShortcut ( 0 , #PB_Shortcut_Return , 0 )
AddKeyboardShortcut ( 0 , #PB_Shortcut_1 , 1 )
AddKeyboardShortcut ( 0 , #PB_Shortcut_2 , 2 )
AddKeyboardShortcut ( 0 , #PB_Shortcut_N , 3 ) ; Normalize
AddKeyboardShortcut ( 0 , #PB_Shortcut_Z , 4 ) ; Noise
AddKeyboardShortcut ( 0 , #PB_Shortcut_B , 5 ) ; Blur
AddKeyboardShortcut ( 0 , #PB_Shortcut_I , 6 ) ; Invert

Repeat
  
  Event = WaitWindowEvent ( )
  
  If Event = #PB_Event_Menu
    
    Select EventMenu ( )
        
      Case 0
        
        HeightmapCreate ( map ( ) )
        
        Draw = #True
        
      Case 1
        
        Mode = #False
        Draw = #True
        
      Case 2
        
        Mode = #True
        Draw = #True
        
      Case 3
        
        HeightmapNormalize ( map ( ) , 160 , 0.05 )
        
        Draw = #False
        
      Case 4
        
        HeightmapNoise ( map ( ) , 128 , 2 )
        
        Draw = #False
        
      Case 5
        
        HeightmapBlur ( map ( ) )
        
        Draw = #False
        
      Case 6
        
        HeightmapInvert ( map ( ) )
        
        Draw = #False
        
    EndSelect
    
    If Draw
      
      If Mode
        
        MapDrawTexture ( map ( ) , 0 )
        
      Else
        
        MapDrawGrayscale ( map ( ) , 0 )
        
      EndIf
      
      Draw = #False
      
    EndIf
    
    SetGadgetState ( 0 , ImageID ( 0 ) )
    
  EndIf
  
Until Event = #PB_Event_CloseWindow

The 1st time it runs it displays the colormap, when you press 2 it will generate the texture, press 1 for greyscale.

WARNING: It's a slow procedure!

The images are here >> x <<

I had to re size them to 512x512, the original size for quality was 2048x2048.
Imageshack also changed their names, please rename them after download and place them in the same directory of the code above!

mpz · Post by **mpz** » Sun Mar 15, 2009 2:25 pm

Hi,

Nice tool now and the idea is very easy and effective. Now i can make a little planet generator with realistic textures (Most of the textures i have as procedurale textures too). Only the speed of the program must be a little bit improved...

Best regards
Michael

zxretrosoft · Post by **zxretrosoft** » Wed Sep 10, 2014 8:52 am

I tried to simplify it.

But I can not understand how to randomly define those peaks?
I need eg., I could define that the mountain has to be on the coordinates XY (50,50) and the sea on the XY (100,100)

Simplified source code:

Code: Select all

EnableExplicit

;enums
#Width=513
#Height=513


Procedure MapHeightGet(Array Map(2),X,Y)
  
  If X=>1 And X<=#Width
    If Y=>1 And Y<=#Height
      ProcedureReturn Map(X,Y)
    EndIf
  EndIf
  
EndProcedure


Procedure MapHeightSet(Array Map(2),X,Y,Value)
  
  If Value<0
    Value=0
  ElseIf Value>255
    Value=255
  EndIf
  
  If X=>1 And X<=#Width
    If Y=>1 And Y<=#Height
      Map(X,Y)=Value
    EndIf
  EndIf
  
EndProcedure


Procedure MapDrawGrayscale(Array Map(2),Image)
  
  Protected X,Y,Color
  
  If StartDrawing(ImageOutput(Image))
    For Y=1 To #Height
      For X=1 To #Width
        Color=MapHeightGet(Map(),X,Y)
        Plot(X-1,Y-1,RGB(Color,Color,Color))
      Next X
    Next Y
    
    StopDrawing()
    
  EndIf
  
EndProcedure


Procedure MapDrawColor(Array Map(2),Image)
  
  Protected X,Y,Z,Color
  
  If StartDrawing(ImageOutput(Image))
    For Y=1 To #Height
      For X=1 To #Width
        Z=MapHeightGet(Map(),X,Y)
        
        Select Z
            
            ;Water
          Case 0 To 15:Color=RGB(0,0,100)
          Case 16 To 31:Color=RGB(0,0,120)
          Case 32 To 63:Color=RGB(0,0,140)
            
            ;Beach
          Case 64 To 70:Color=RGB(64,95,134)
          Case 71 To 95:Color=RGB(128,190,128)
          Case 96 To 127:Color=RGB(140,210,140)
            
            ;Lowland
          Case 128 To 159:Color=RGB(160,210,140)
          Case 160 To 180:Color=RGB(180,210,140)
          Case 181 To 199:Color=RGB(190,220,150)
            
            ;Hills
          Case 200 To 219:Color=RGB(185,185,130)
          Case 220 To 229:Color=RGB(182,177,130)
          Case 230 To 239:Color=RGB(180,170,130)
            
            ;Mountains
          Case 240 To 244:Color=RGB(215,215,215)
          Case 245 To 249:Color=RGB(230,230,230)
          Case 250 To 253:Color=RGB(250,250,250)
          Case 254 To 255:Color=RGB(255,255,255)
            
        EndSelect
        
        Plot(X-1,Y-1,Color)
        
      Next X
    Next Y
    
    StopDrawing()
    
  EndIf
  
EndProcedure



Procedure HeightmapDivider(Array Map(2),X.f,Y.f,Width.f,Height.f,C1.f,C2.f,C3.f,C4.f)
  
  Protected Edge1.f
  Protected Edge2.f
  Protected Edge3.f
  Protected Edge4.f
  Protected Middle.f
  
  Protected NewWidth.f=Width/2
  Protected NewHeight.f=Height/2
  
  Protected Displacement.f
  Protected Weight.f
  
  If Width>2 Or Height>2
    
    Displacement=(Random(1)-0.5)*((NewWidth+NewHeight)/(#Width+#Height)*3)
    
    Middle=(C1+C2+C3+C4)/4+Displacement
    
    Edge1=(C1+C2)/2
    Edge2=(C2+C3)/2
    Edge3=(C3+C4)/2
    Edge4=(C4+C1)/2
    
    If Middle<0.0
      Middle=0.0
    ElseIf Middle>1.0
      Middle=1.0
    EndIf
    
    HeightmapDivider(Map(),X,Y,NewWidth,NewHeight,C1,Edge1,Middle,Edge4)
    HeightmapDivider(Map(),X+NewWidth,Y,NewWidth,NewHeight,Edge1,C2,Edge2,Middle)
    HeightmapDivider(Map(),X+NewWidth,Y+NewHeight,NewWidth,NewHeight,Middle,Edge2,C3,Edge3)
    HeightmapDivider(Map(),X,Y+NewHeight,NewWidth,NewHeight,Edge4,Middle,Edge3,C4)
    
  Else
    
    Weight=(C1+C2+C3+C4)/4
    
    MapHeightSet(Map(),Int(X),Int(Y),Weight*255)
    
  EndIf
  
EndProcedure


Procedure HeightmapCreate(Array Map(2))
  
  Protected Width=ArraySize(Map(),1)
  Protected Height=ArraySize(Map(),2)
  
  Protected C1.f=Random(1)
  Protected C2.f=Random(1)
  Protected C3.f=Random(1)
  Protected C4.f=Random(1)
  
  HeightmapDivider(Map(),1,1,Width,Height,C1,C2,C3,C4)
  
EndProcedure


;Main

DisableExplicit

Dim Map(#Width,#Height)

HeightmapCreate(Map())

CreateImage(0,#Width,#Height)

OpenWindow(0,0,0,#Width,#Height,"Heightmap",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)

Mode=#True

MapDrawColor(Map(),0)

ImageGadget(0,WindowWidth(0)/2-ImageWidth(0)/2,WindowHeight(0)/2-ImageHeight(0)/2,0,0,ImageID(0))

AddKeyboardShortcut(0,#PB_Shortcut_Return,0)
AddKeyboardShortcut(0,#PB_Shortcut_1,1)
AddKeyboardShortcut(0,#PB_Shortcut_2,2)


Repeat
  
  Event=WaitWindowEvent()
  
  If Event=#PB_Event_Menu
    
    Select EventMenu()
      Case 0
        HeightmapCreate(Map())
        Draw=#True
      Case 1
        Mode=#False
        Draw=#True
      Case 2
        Mode=#True
        Draw=#True
    EndSelect
    
    
    If Draw=#True
      If Mode=#True
        MapDrawColor(Map(),0)
      Else
        MapDrawGrayscale(Map(),0)
      EndIf
      Draw=#False
    EndIf
    
    SetGadgetState(0,ImageID(0))
    
  EndIf
  
Until Event=#PB_Event_CloseWindow

PureBasic Forums - English

Heightmaps using midpoint displacement

Heightmaps using midpoint displacement

Re: Heightmaps using midpoint displacement