Realtime Procedural Planet Generator

This code has been declared by its author to be Public Domain code.

Realtime Procedural Planet Generator by Krischan

2009

This is my own planet texture generator. It is a fake, but a very fast one with nice results. It calculates a unique texture by blending 4 pre-rendered 3D Perlin Noise planets together using image filters. And it is done within the main loop and calculates only a few pixels per loop, so it consumes nearly no CPU power and the planet can be calculated on-the-fly, e.g. while moving toward a planet or a solar system.

In this demo, i am using a 512x256 texture, but it is even possible to create 1024x512 or 2048x1024 textures in realtime (the pre-rendering takes a lot of time but it is worth waiting for the results!). The planet texture maps perfect on a sphere because it is distorted to the poles.

In the demo, press SPACE to calculate a new surface texture and use the mouse and the arrow keys to move while it is forming.

IMPORTANT: first you must create the pre-rendered planet images by using this code (execute it in the same directory as the planet generator code):

prepareplanet.bb

Function DBInt( x# )
	If x >= 0 
		Return Floor(x)
	Else
		Return Ceil(x)
	End If
End Function

xs%=512
ys%=256

start=MilliSecs()

Graphics xs,ys,32,2

; create arrays For perlin generator
Dim s#(15,2)
Dim r#(63,63,63)

For planet=0 To 9
	
	Text 0,0,"Generating Planet "+(planet+1)+"/10"
	
	Flip
	
	; prepare the perlin
	prepare_perlin(planet+1,0.75)

	; multisampling controller
	multi% = 1
	milti% = multi - 1
	malt# = multi ^ 2
	malt# = 1 / malt#

	xsize1% = xs
	ysize1% = ys

	; get the base sizes
	xsize2% = xsize1 * multi
	ysize2% = ysize1 * multi

	; get the scalers
	xscaler1% = 360
	yscaler1% = 180

	xscaler2# = xscaler1*1.0 / xsize2
	yscaler2# = yscaler1*1.0 / ysize2

	width# = 2

	; piece details
	pxs% = xs-1
	pys% = ys-1

	xof% = 0
	yof% = 0

	SetBuffer FrontBuffer()

	image=CreateImage(xs,ys)
	ib=ImageBuffer(image)
	LockBuffer ib

	min=255
	max=0

	; loop the y position
	For posx% = 0 To pxs Step 1
	
		; loop the x
		For posy% = 0 To pys Step 1
		
			; reset colours
			g = 0
			b = 0
		
			; get the scaled sizes
			xp1% = (posx + xof) * multi
			yp1% = (posy + yof) * multi
		
			; do the multisampling
			For posa% = 0 To milti
			
				; get the baring around the sphere
				ba# = xp1 + posa
				ba# = (ba# + 0.5) * xscaler2#
				xp2# = Cos(ba#)
				zp2# = Sin(ba#)
			
				For poss% = 0 To milti
				
					; get the pitch around the sphere
					pa# = yp1 + poss
					pa# = ((pa# + 0.5) * yscaler2#)
					po# = Sin(pa#) * width#
				
					; get the positions in the space
					x# = (xp2# * po#) + 5
					y# = (Cos(pa#) * width#) + 5
					z# = (zp2# * po#) + 5
				
					; get the perlin result For that part
					h = DBInt(perl(x#,y#,z#,6) * 255)
				
					; cap the value
					If h => 255 Then h = 255
					If h <= 0 Then h = 0
				
					If h>max Then max=h
					If h<min Then min=h
				
					; failsafe quit
					If KeyHit(1) Then End
				
				Next
			
			Next	
		
			; scale down the colours
			c=c*malt#
		
			; get the colour
			rgb=h*$10000+h*$100+h
		
			; put a dot there
			WritePixelFast posx,posy,rgb,ib
		
		Next
	
	Next

	For posx = 0 To pxs Step 1
	
		For posy = 0 To pys Step 1
		
			rgb=ReadPixelFast(posx,posy,ib)
			r1=(rgb And $ff0000)/$10000
		
			h=Normalize(r1,min,max,0,255)
		
			rgb=h*$10000+h*$100+h
		
			WritePixelFast posx,posy,rgb,ib
		
		Next
	
	Next

	UnlockBuffer ib

	ende=MilliSecs()
	
	cls

	DrawImage image,0,0
	
	SaveBankImage(image,"planet"+planet+".img",xs,ys)
	
	FreeImage image
	
Next

End

; perlin Function
Function perl#(x#,y#,z#,octaves%)
	
	; make sure the pass value is zerod
	h# = 0
	
	; shift octaves down to Input works from 1 but system works from 0
	octaves=octaves-1
	
	; make sue octaves are an ecceptable value
	If octaves <= 0 Then octaves = 0
	If octaves => 15 Then octaves = 15
	
	; loop the octaves
	For oct% = 0 To octaves
		
		; grab the frequency And amplitude For this
		fre# = s#(oct,0)
		amp# = s#(oct,1)
		
		; convert the co-ordinates into steps
		xx = DBInt(x# * fre#)
		yy = DBInt(y# * fre#)
		zz = DBInt(z# * fre#)
		
		; get the inbetween co-ords
		xb# = sine((x# * fre#) - flo(xx))
		yb# = sine((y# * fre#) - flo(yy))
		zb# = sine((z# * fre#) - flo(zz))
		xa# = 1 - xb#
		ya# = 1 - yb#
		za# = 1 - zb#
		
		; get the values For the 8 corners
		v000# = vil(xx,yy,zz) * xa# * ya# * za#
		v100# = vil(xx+1,yy,zz) * xb# * ya# * za#
		v010# = vil(xx,yy+1,zz) * xa# * yb# * za#
		v001# = vil(xx,yy,zz+1) * xa# * ya# * zb#
		v101# = vil(xx+1,yy,zz+1) * xb# * ya# * zb#
		v110# = vil(xx+1,yy+1,zz) * xb# * yb# * za#
		v011# = vil(xx,yy+1,zz+1) * xa# * yb# * zb#
		v111# = vil(xx+1,yy+1,zz+1) * xb# * yb# * zb#
		
		; add it on
		h#=h#+(v000# + v100# + v010# + v001# + v101# + v110# + v011# + v111#) * amp#
		
	Next
	
	; scale it down
	h# = h# * s#(octaves,2)
	
	Return h#
	
End Function

; Function to get the random value of a co-ordinate
Function vil#(x,y,z)
	
	; control edges
	If x < 0 Then x = x - (DBInt((x / 64) - 1) * 64) Else x = x - (DBInt(x/64) * 64)
	If y < 0 Then y = y - (DBInt((y / 64) - 1) * 64) Else y = y - (DBInt(y/64) * 64)
	If z < 0 Then z = z - (DBInt((z / 64) - 1) * 64) Else z = z - (DBInt(z/64) * 64)
	
	; get the number
	v# = r#(x,y,z)
	
	Return v#
	
End Function


	; Return an integer as a floating point
Function flo#(a)
	
	b# = a*1.0
	
	Return b#
	
End Function

; Function to turn a straight 0 - 1 into a sine curved 0 - 1
Function sine#(v#)
	
	; perform the change
	v# = (1 - Cos(v# * 180)) * 0.5
	
	Return v
	
End Function


; Function to prepare Data For perlin noise
Function prepare_perlin(seed,persistance#)
	
	; set the seed value
	SeedRnd seed
	
	; create seed Data
	For x = 0 To 63
		
		For y = 0 To 63
			
			For z = 0 To 63
				
				zz# = Rnd(10000)
				r#(x,y,z) = (zz# * 0.0001)
				
			Next
			
		Next
		
	Next
	
	; prepare octave Data
	For i = 0 To 15
		
		; work out the frequence of the octave
		s#(i,0) = 2 ^ i
		
		; get the amplitude
		s#(i,1) = persistance# ^ i
		
		; work out the maximum amplitude of
		s#(i,2) = 0.0
		
		For j = 0 To i
			
			s#(i,2)=s#(i,2)+s#(j,1)
			
		Next
		
		s#(i,2) = 1.0 / s#(i,2)
		
	Next
	
End Function

Function Normalize#(value#=128.0,value_min#=0.0,value_max#=255.0,norm_min#=0.0,norm_max#=1.0)
	
	Return ((value-value_min)/(value_max-value_min))*(norm_max-norm_min)+norm_min
	
End Function

Function SaveBankImage(image%,filename$,width%,height%)
	
	Local x%,y%,rgb%,h%,offset%
	
	Local bank%=CreateBank(width*height)
	
	Local buffer%=ImageBuffer(image)
	
	LockBuffer buffer
	
	For x=0 To width-1
		
		For y=0 To height-1
			
			rgb=ReadPixelFast(x,y,buffer)
			h=(rgb And $ff0000)/$10000
			
			offset=(y*width)+x
			PokeByte bank,offset,h
			
		Next
		
	Next
	
	UnlockBuffer buffer
	
	Local f%=WriteFile(filename$)
	
	WriteBytes (bank,f,0,BankSize(bank))
	
	CloseFile f
	
End Function

; Realtime Procedural Planet Generator
; by Krischan webmaster(at)jaas.de
;
; creates a planet out of a combination of 4 pre-rendered planets out of 10 and three blending filters
; it is possible to create ten thousands of unique planet surfaces in 50-100 milliseconds!
; this is done by calculating the planet step by step so it doesn't consume lots of power and whole
; solar systems can be created while moving towards the system or even the planet

Graphics3D 800,600,32,2

; Declarations
Dim GradientR%(0),GradientG%(0),GradientB%(0),Prozent%(0),Rot%(0),Gruen%(0),Blau%(0)
Dim images%(9)
Dim Array%(0)
Global maxx%=512
Global maxy%=256
Global max%=maxx*maxy
Global pixelstep%=16384
Global movespeed#=0.1

; Randomize
SeedRnd MilliSecs()

; Create Color Gradient
Restore ClassMT : CreateGradient(9,255)

; Read source images
For i%=0 To 9 : images(i)=LoadBankImage("planet"+i+".img",maxx,maxy) : Next

; Create random array
CreateRandomArray(max)

; Create target texture
output=CreateTexture(maxx,maxy,16+32)
texbuff=TextureBuffer(output)

; Base color of texture (water)
SetBuffer texbuff
Color 17, 82,112
Rect 0,0,maxx,maxy,1
Color 255,255,255
SetBuffer BackBuffer()

; Planet
planet=CreateSphere(32)
ScaleEntity planet,10,10,10
PositionEntity planet,0,0,10
EntityFX planet,2
EntityTexture planet,output,0,1
TextureBlend output,2
EntityShininess planet,0.25

; Light
light=CreateLight(1)
AmbientLight 8,8,8

; Camera
camera=CreateCamera()
PositionEntity camera,20,0,0
CameraRange camera,0.1,1000

; Cursor centered, cam points to planet
MoveMouse GraphicsWidth()/2,GraphicsHeight()/2
HidePointer()
PointEntity camera,planet

; World creation flag
newworld=True

; Time measurement start
time=MilliSecs()

; Main Loop
While Not KeyHit(1)
	
	; FPS measurement
    FPS_C=FPS_C+1 : If fms<MilliSecs() Then fms=MilliSecs()+1000 : FPS=FPS_C : FPS_C=0
	
	; Frame tweening
	Tween#=Float(MilliSecs()-FrameTime)/10.0 : FrameTime=MilliSecs()
	
	; Simple Steering
	mxs#=MouseXSpeed()
	mys#=MouseYSpeed()
	RotateEntity camera,EntityPitch(camera)+(mys#/5),EntityYaw(camera)-(mxs#/5),0
	If KeyDown(200) Then MoveEntity camera,0,0,movespeed*Tween
	If KeyDown(208) Then MoveEntity camera,0,0,-movespeed*Tween
	MoveMouse GraphicsWidth()/2,GraphicsHeight()/2
	
	; Current time
	ms=MilliSecs()
	
	; SPACE and Newworld-Flag False? create a new map!
	If KeyHit(57) Then
		
		; Measure start time
		starttime=ms
		
		; Reset pixel counters
		i=0
		water%=0
		land%=0
		
		; Select 4 planet maps as base
		map$=ZERO(Rand(0,9999),4)
		
		; Extract Planet Codes
		i1=Int(Left(map,1))
		i2=Int(Mid(map,1,1))
		i2=Int(Mid(map,2,1))
		i4=Int(Right(map,1))
		
		; set Newworld-Flag True
		newworld=True
		
	EndIf
	
	; Turn Planet and Clouds a little bit
	TurnEntity planet,0,-0.1*Tween,0
	
	; SPACE, 30ms gone and Newworld-Flag true? go on!
	If ms>time And newworld Then
		
		roundstart=ms
		
		; Increase time
		time=ms+30
		
		; Calculate number of pixels to set
		adder%=(pixelstep/Tween)
		
		; Start/End for current loop
		start=i
		ende=i+adder
		
		; End greater than pixels? end=pixels
		If ende>max-1 Then ende=max-1
		
		; Lock Texturebuffer
		LockBuffer texbuff
		
		; Current Pixel loop
		For j=start To ende
			
			; Pixelincrement
			i=i+1
			
			; Pixel greater than pixel amount? End!
			If i>max-1 Then
				newworld=False
				Goto skip
			EndIf
				
			; Calculate Pixel X/Y-Position from the randomized array
			y=Int(Array(i)/maxx)
			x=Array(i)-(y*maxx)
			
			; get current pixels from bank
			offset=(y*maxx)+x
			r1=PeekByte(images(i1),offset)
			r2=PeekByte(images(i2),offset)
			r3=PeekByte(images(i3),offset)
			r4=PeekByte(images(i4),offset)
			
			; Mix with Image Filter
			r=Average(r1,r2)
			r=Lighten(r,r3)
			r=HardLight(r,r4)
			
			; Legend of usesful Filter combinations:
			;
			; S = Softlight
			; M = Multiply
			; L = Lighten
			; A = Average
			; H = Hardlight
			; O = Overlay
			; E = exclusion
			; D = Difference
			; N = Negation
			;
			; SSM =  ~ 99% Land
			; SSS = 25-75% Land
			; SSL = 75-25% Land, flat
			; ALH = 35-65% Land, continental
			; AMM =   100% Land, mountaineous
			; OLS = 25-75% Land
			; OLC =   <10% Land, oceancic
			; MMM =   100% Land, snowy mountains
			; EDN = different, earthlike, Archipelagos
			; MNS = different, earthlike, Archipelagos
			
			; Above 128: below water, otherwise Land
			If r>=128 Then water=water+1 Else land=land+1
			
			; Target Color from Gradient
			rgb=GradientR(r)*$10000+GradientG(r)*$100+GradientB(r)
			
			; Write to Texturebuffer
			WritePixelFast x,y,rgb,texbuff
			
		Next
		
		.skip
		
		endtime=MilliSecs()
		
		; Unlock Texturebuffer
		UnlockBuffer texbuff
		
		; Calculate amount of used time
		midtime=(midtime+(endtime-roundstart))/2.0
		
	EndIf
	
	RenderWorld
	
	; Statistics
	Text 0,  0,"Planet Source Maps: "+map
	Text 0, 15,"Pixels blended....: "+(i*100)/max+"%"
	Text 0, 30,"Transition Time...: "+(endtime-starttime)+"ms"
	Text 0, 45,"Used ms per cycle.: "+midtime+"ms"
	Text 0, 60,"Pixels per cycle..: "+adder
	Text 0, 75,"Water coverage....: "+(water*100.0)/max+"%"
	Text 0, 90,"Land coverage.....: "+(land*100.0)/max+"%"
	Text 0,105,"FPS...............: "+FPS
	Text 0,120,"Tris rendered.....: "+TrisRendered()
	
	Flip 0
	
Wend

End

; Soft Light Filter
Function SoftLight(a%,b%)
	Local c%
	c=a*b Shr 8
	Return (c+a*(255-((255-a)*(255-b) Shr 8)-c) Shr 8)
End Function

; Hard Light Filter
Function HardLight(a%,b%)
	If b<128 Then Return (a*b) Shr 7 Else Return 255-((255-b)*(255-a) Shr 7)
End Function

; Difference Filter
Function Difference(a%,b%)
	Return Abs(a-b)
End Function

; Multiply Filter
Function Multiply(a%,b%)
	Return (a*b) Shr 8
End Function

; Average Filter
Function Average(a%,b%)
	Return (a+b) Shr 1
End Function

; Screen Filter
Function Screen(a%,b%)
	Return 255-((255-a)*(255-b) Shr 8)
End Function

; Lighten Filter
Function Lighten(a%,b%)
	If a>b Then Return a Else Return b
End Function

; Darken Filter
Function Darken(a%,b%)
	If a<b Then Return a Else Return b
End Function

; Negative Filter
Function Negation(a%,b%)
	Return 255-Abs(255-a-b)
End Function

; Exclusion Filter
Function Exclusion(a%,b%)
	Return a+b-(a*b Shr 7)
End Function

; Overlay Filter
Function Overlay(a%,b%)
	If a<128 Then Return (a*b) Shr 7 Else Return 255-((255-a)*(255-b) Shr 7)
End Function

; Color Burn Filter
Function ColorDodge(a%,b%)
	If b=255 Then
		Return 255
	Else
		Local c%=Floor((a Shl 8)/(255-b))
		If c>255 Then Return 255 Else Return c
	EndIf
End Function

; Create Gradient
Function CreateGradient(colors%,steps%)
	
	Dim GradientR%(steps),GradientG%(steps),GradientB%(steps),Prozent%(colors),Rot%(colors),Gruen%(colors),Blau%(colors)
	
	Local i%,pos1%,pos2%,pdiff%
	Local rdiff%,gdiff%,bdiff%
	Local rstep#,gstep#,bstep#
	Local counter%=1
	
	; read color codes
	For i=1 To colors : Read Prozent(i),Rot(i),Gruen(i),Blau(i) : Next
	
    ; calculate gradient
	While counter<colors
		
        ; transform percent value into step position
		pos1=Prozent(counter)*steps/100
		pos2=Prozent(counter+1)*steps/100
		
        ; calculate position difference
		pdiff=pos2-pos1
		
        ; calculate color difference
		rdiff%=Rot(counter)-Rot(counter+1)
		gdiff%=Gruen(counter)-Gruen(counter+1)
		bdiff%=Blau(counter)-Blau(counter+1)
		
        ; calculate color steps
		rstep#=rdiff*1.0/pdiff
		gstep#=gdiff*1.0/pdiff
		bstep#=bdiff*1.0/pdiff
		
        ; calculate "in-between" color codes
		For i=0 To pdiff
			
			GradientR(pos1+i)=Int(Rot(counter)-(rstep*i))
			GradientG(pos1+i)=Int(Gruen(counter)-(gstep*i))
			GradientB(pos1+i)=Int(Blau(counter)-(bstep*i))
			
		Next
		
        ; increment counter
		counter=counter+1
		
	Wend
	
End Function

; create a random array where each value appears only once
Function CreateRandomArray(size%)
	
	; Redim Array
	Dim Array(size)
	
	; Fill with values
	For i = 0 To size-1 : Array(i) = i : Next
	
	; play dice
	For N% = 0 To size-2
		
		M% = Rand( N%, size - 1)
		Z% = Array(N%)
		
		Array(N%) = Array(M%)
		Array(M%) = Z%
		
	Next
	
End Function

; Fill a String with prefix Zeros
Function ZERO$(number%,lenght%=2)
	
	Local r$=""
	
	For i=1 To lenght-Len(Str(number))
		
		r$=r$+"0"
		
	Next
	
	Return r$+Str(number)
	
End Function

; Load a raw Image
Function LoadBankImage(filename$,width%,height%)
	
	Local f%=OpenFile(filename$)
	
	Local bank%=CreateBank(width*height)
	
	ReadBytes(bank,f,0,BankSize(bank))
	
	CloseFile f
	
	Return bank
	
End Function

; Color codes for an earthlike Planet
.ClassMT
Data   0,255,255,255
Data   5,179,179,179
Data  10,153,143, 92
Data  25,115,128, 77
Data  48, 42,102, 41
Data  50, 69,108,118
Data  52, 17, 82,112
Data  75,  9, 62, 92
Data 100,  2, 43, 68

Comments

Ian Thompson

2009

Very nice, thank you.

One problem though, rather than increase in size and maintain a good level of detail, the larger images (2048x1024) seem to be very pixelated combined with a blur filter?

Krischan

2009

Hi Ian,

sorry I forgot to mention. In my example with 512x256 i am using 6 noise octaves which is sufficient there. In higher resolutions you should increase the octaves, too. Just search for this line:

; get the perlin result For that part
h = DBInt(perl(x#,y#,z#,6) * 255)

and change it to

; get the perlin result For that part
h = DBInt(perl(x#,y#,z#,7) * 255)

Or use a variable placeholder for that. 7 looks nice, if you want more detail use higher dimensions. For my purpose, 1024x512 is adequate. You can play with the pre-rendered results by using more or less octaves or change the crispness, which you can switch in this line:

prepare_perlin(planet+1,0.75)

The first variable is the seed (here planet+1), the second the crispness, 0.0 is totally blurry and 1.0 is very sharp. It even has multisampling (variable multi%=1), but I don't use it because it increases the calculation time vastly.

Hint: if you're going to use 2048x1024 or even higher texture levels you should decrease the pixelstep% variable in the demo from 16384 to e.g. 4096 or lower. Although it takes more time to "pixelate" the result but uses less CPU power then.

Ian Thompson

2009

Ah I see, thanks for that Christian. I really like the last few code archive posts you have made, all interesting and unique, well done. :)

CloseToPerfect

2009

can you tell me how you are distorting the pole? I made a random map generator using the divided fault method but it doesn't distort the poles or blend the edges to match the other side.

Very nice,
CTP

Krischan

2009

I only ported the code to BB, dunno exactly how it works. I only found out that it creates a 3D Perlin Noise point cloud and the sphere gets cut off like the skin of an orange out of this cloud, imagine the cloud like that:

Graythe

2011

I know I'm a bit late... but that is absolutely awesome.

Code Archives Forum