Code archives/Graphics/2D Procedural World Map Generator

; ID: 3315
; Author: Matty
; Date: 2017-04-27 07:24:50
; Title: 2D Procedural World Map Generator
; Description: Generate a 2D World Map Using a Procedural Technique

;Graphical Map Creator
;
;Objective:
;Create an aesthetically pleasing 2d world map using no external resources and save as a bitmap.
;
;How this works:
;Run in blitzplus or blitz3d.
;Press Space Bar to Generate a New Map
;Images Are Saved In Same Directory As Source 
;
;Have a look in the generatemap() code to see how the map is generated.
;Note: play around with the methodology once you understand it to make nicer maps
;The screen resolution chosen was because I am planning on making something for mobile
;and the aspect ratio is pretty close to most mobile phone aspect ratios.
;
;

SeedRnd MilliSecs()
Graphics 800,480,0,2
Const maxx=200
Const maxy=120
Dim map(0,0)
Dim woods(0,0)
Dim mountains(0,0)
Dim rivers(0,0)
Global saved = False,mapimage
generatemap()
SetBuffer BackBuffer()
Repeat
Cls
If KeyHit(57) Then generatemap()
drawmap()
Color 255,255,255
Text 0,0,"Press Space To Generate New Map"
Flip
Until KeyDown(1)
End

Function drawmap()
If mapimage = 0 Then mapimage = CreateImage(800,480)
ClsColor 200,161,117
Cls
For x = 0 To maxx-1
For y = 0 To maxy-1
	If map(x,y)=0 Then 
		Color 44,127,175
		Rect x*(800/maxx),y*(480/maxy),(800/maxx),(480/maxy),1
	EndIf 
	If x>0 And y>0 And x<maxx-1 And y<maxy-1 Then 
		Color 16,16,24
	If map(x-1,y)<>map(x,y) And (map(x-1,y)=0 ) Then 
		Line x*800/maxx,y*480/maxy,x*800/maxx,(y+1)*480/maxy

	EndIf
	If map(x,y-1)<>map(x,y) And (map(x,y-1)=0 )Then 
		Line x*800/maxx,y*480/maxy,(x+1)*800/maxx,y*480/maxy
	EndIf
	If map(x+1,y)<>map(x,y) And (map(x+1,y)=0 ) Then 
		Line (x+1)*800/maxx,y*480/maxy,(x+1)*800/maxx,(y+1)*480/maxy

	EndIf
	If map(x,y+1)<>map(x,y) And (map(x,y+1)=0 )Then 
		Line x*800/maxx,(y+1)*480/maxy,(x+1)*800/maxx,(y+1)*480/maxy
	EndIf 
	EndIf
	If woods(x,y)>0 Then 
		Color 84,94,30
		Rect x*(800/maxx),y*(480/maxy),(800/maxx),(480/maxy),1
	EndIf 
	If mountains(x,y)>0 Then 
		Color 184,183,203
		Rect x*(800/maxx),y*(480/maxy),(800/maxx),(480/maxy),1
	EndIf 
	If rivers(x,y)>0 Then 
		Color 44,127,175
		Rect x*(800/maxx),y*(480/maxy),(800/maxx),(480/maxy),1
	EndIf 

Next
Next

If Not saved Then postprocess()
If Not saved Then SaveBuffer BackBuffer(),MilliSecs()+".bmp"
If Not saved Then 
	CopyRect 0,0,800,480,0,0,BackBuffer(),ImageBuffer(mapimage)
Else
	DrawBlock mapimage,0,0
EndIf
saved = True

End Function 

Function postprocess()
image = CreateImage(800,480)
CopyRect 0,0,800,480,0,0,BackBuffer(),ImageBuffer(image)
LockBuffer BackBuffer()
LockBuffer ImageBuffer(image)
x = 0
y = 0
aa = 4
While x<800
	y = 0
	While y < 480
		rgb = ReadPixelFast(x,y,ImageBuffer(image))
		r0 = (rgb Shr 16) And 255
		g0 = (rgb Shr 8) And 255
		b0 = rgb And 255
		r1 = 0
		g1 = 0
		b1 = 0
		s = 0
		For ix = x - aa/2 To x + aa/2
			For iy = y - aa/2 To y + aa/2
				If ix>=0 And iy>=0 And ix<800 And iy<480 Then 
					s = s + 1
					rgb1 = ReadPixelFast(ix,iy,ImageBuffer(image))
					r1 = r1 + ((rgb1 Shr 16) And 255)		
					g1 = g1 + ((rgb1 Shr 8) And 255)
					b1 = b1 + (rgb1 And 255)
				EndIf 
			Next
		Next
		If s>0 Then 
			r1 = r1 / s
			g1 = g1 / s
			b1 = b1 / s
			For ix = x - aa/2 To x + aa/2
				For iy = y - aa/2 To y + aa/2
					If ix>=0 And iy>=0 And ix<800 And iy<480 Then 
						rgb = ReadPixelFast(ix,iy,ImageBuffer(image))
						r0 = (rgb Shr 16) And 255
						g0 = (rgb Shr 8) And 255
						b0 = rgb And 255
						r2 = r0 * 0.2 + r1 * 0.8
						g2 = g0 * 0.2 + g1 * 0.8
						b2 = b0 * 0.2 + b1 * 0.8
						rgb = r2 Shl 16 Or g2 Shl 8 Or b2
						WritePixelFast(ix,iy,rgb,BackBuffer())
					EndIf
				Next
			Next		
		EndIf 
		y = y + aa
	Wend 
	x = x + aa
Wend

UnlockBuffer BackBuffer()
UnlockBuffer ImageBuffer(image)
FreeImage image
End Function


Function generatemap()
saved = False
FreeImage mapimage
mapimage = 0
Dim map(maxx,maxy)
Dim woods(maxx,maxy)
Dim mountains(maxx,maxy)
Dim rivers(maxx,maxy)
np = Rand(48,72)
For p = 1 To np
	ClsColor 0,0,0
	Cls
	Color 255,255,255
	Text 0,0,((100*p)/np)+"% landmass complete"
	Flip
	x = Rand(0,maxx-1)
	y = Rand(0,maxy-1)
	map(x,y)=np
	s = Rand(maxx/4,maxx*4)
	For l = 1 To s/2
		count = 0
		If KeyHit(1) Then End 
		For ix = x - Sqr(s) To x + Sqr(s)
			For iy = y - Sqr(s) To y + Sqr(s)
				If ix>=1 And iy>=1 And ix<maxx-1 And iy<maxy-1 Then 
					If map(ix,iy)=0 And (map(ix-1,iy)<>0 Or map(ix,iy-1)<>0 Or map(ix,iy+1)<>0 Or map(ix+1,iy)<>0) Then 
						count = count + 1
					EndIf 
				EndIf 
			Next
		Next
		index = Rand(1,count)
		For ix = x - Sqr(s) To x + Sqr(s)
			For iy = y - Sqr(s) To y + Sqr(s)
				If ix>=1 And iy>=1 And ix<maxx-1 And iy<maxy-1 Then 
					If map(ix,iy)=0 And (map(ix-1,iy)<>0 Or map(ix,iy-1)<>0 Or map(ix,iy+1)<>0 Or map(ix+1,iy)<>0) Then 
						index = index - 1
						If index <= 0 Then 
							map(ix,iy)=p		
							Exit
						EndIf 
					EndIf
				EndIf
			Next
			If index<=0 Then Exit
		Next
	Next
Next
nw = Rand(10,20)
For w = 1 To nw
	For x = 1 To maxx-2
		For y = 1 To maxy-2
			If map(x,y)<>0 And map(x+1,y)<>0 And map(x-1,y)<>0 And map(x,y-1)<>0 And map(x,y+1)<>0 And map(x-1,y-1)<>0 And map(x-1,y+1)<>0 And map(x+1,y-1)<>0 And map(x+1,y+1)<>0 Then
				woods(x,y)=woods(x,y)+Rand(-15,20)
			EndIf
		Next
	Next
Next
For x = 1 To maxx-2
	For y = 1 To maxy - 2
		If map(x,y)<>map(x-1,y) And map(x,y)<>0 And map(x-1,y)<>0 Then 
			If map(x,y) Mod 7 < 1 Or map(x,y) Mod 8 > 6 Then 
				mountains(x,y)=1
				mountains(x-1,y)=1
			EndIf 
		EndIf 
		If mountains(x,y)=0 And mountains(x-1,y)=0 Then 
			If map(x,y)<>map(x-1,y) And Abs(map(x,y)-map(x-1,y)) Mod 9 < 2 Then 
				rivers(x,y)=1
			EndIf 
			If map(x,y)<>map(x+1,y) And Abs(map(x,y)-map(x+1,y)) Mod 9 < 2 Then 
				rivers(x,y)=1
			EndIf 
		EndIf 
	Next
Next
End Function