Anonymous

SuperStrict

Global scx:Int = 640
Global scy:Int = 480


Global diameter:Int = scy

Graphics scx, scy
Cls

SetBlend ALPHABLEND
SetAlpha 1.0
SetColor 255, 255, 255
SetClsColor 0, 0, 40

Global sizefactor:Int = 1
SetScale sizefactor, sizefactor
Global planetsize:Int = 480 / sizefactor
Global frames:Int = 60
Global planetid:Int = 8
Global loopimage:TImage = CreateImage(planetsize, planetsize, frames + 1, DYNAMICIMAGE | FILTEREDIMAGE) 
'tplanet.create options:
'in order:


'Frame, Planet ID, Size, cloud coverage, land mass,day>night transition flag, "flare" flag,"Star" flag,cloud colour, land colour,water colour.

'Note that cloud coverage/land mass isnt spot on, you'll need to adjust it to get what you want.
'Higher cloud coverage and land mass increases generation time.

Local x:Float, Frame:Int
Repeat
	Local planet:tplanet = tplanet.Create(x + 1, planetid, planetsize, 0.8, 0.6, 0, 0, 0, $ffffff, $10ff10, $4040ff)     'normal planet
	'Local planet:tplanet = tplanet.Create(x + 1, planetid, planetsize, 1.0, 0.1, 0, 1, 1, $ff0000, $ff0000, $400000)          'red giant
	'Local planet:tplanet = tplanet.Create(x + 1, planetid, planetsize, 1.2, 0.1, 0, 1, 1, $FFFF33, $ff0000, $400000)             'sun
	DrawImage planet.image, 0, 0
	loopimage.SetPixmap(Frame, planet.worldpixmap) 
		SavePixmapPNG(planet.worldpixmap, "output\planet" + String(planetid) + "f" + String(Frame + 1) + ".png", 9) 
	Flip
	Cls
	x = x + Float(planetsize) / Float(frames) 
	Frame = Frame + 1
Until Frame > frames
Repeat
	For Local x:Int = 1 To frames
		DrawImage(loopimage, 0, 0, x) 
		Flip
		Cls
		Delay 1000 / 30
		If KeyHit(KEY_ESCAPE) Then End
	Next
Until KeyDown(KEY_ESCAPE) 




Type tplanet
	Field worldpixmap:TPixmap
	Field image:TImage
	Global heightmap:TBank
	Global cloudmap:TBank
	Global dimensions:Int
	
	Field cloudcolourr:Int
	Field cloudcolourg:Int
	Field cloudcolourb:Int

	Field landcolourr:Int
	Field landcolourg:Int
	Field landcolourb:Int
	
	Field watercolourr:Int
	Field watercolourg:Int
	Field watercolourb:Int
	
	Function Create:Tplanet(rot:Int, seed:Int = 10, diameter:Int, clouddensity:Float = 0.5, landmass:Float = 0.5, DAYNIGHT:Byte = 0, flares:Byte = 0, star:Byte = 0, CLOUDCOLOURRGB:Int = $909090, landcolourRGB:Int = $00FF00, WatercolourRGB:Int = $4040FF) 
	rot = (rot + diameter * 20) mod diameter
		Local planet:tplanet = New tplanet
		
		planet.cloudcolourr = (cloudcolourRGB & $FF0000) Shr 16
		planet.cloudcolourg = (cloudcolourrGB & $FF00) Shr 8
		planet.cloudcolourb = cloudcolourrGB mod 256

		planet.landcolourr = (landcolourRGB & $FF0000) Shr 16
		planet.landcolourg = (landcolourrGB & $FF00) Shr 8
		planet.landcolourb = landcolourrGB mod 256
		planet.watercolourr = (watercolourRGB & $FF0000) Shr 16
		planet.watercolourg = (watercolourrGB & $FF00) Shr 8
		planet.watercolourb = watercolourrGB mod 256
		
		
		planet._Init(rot, seed, diameter, clouddensity, landmass, daynight, flares, star) 
		Return planet
	End Function
	
	Method _init(rot:Int, seed:Int, diameter:Int, clouddensity:Float, landmass:Float, daynight:Byte, flares:Byte,star:byte) 

	Local edge:Float = diameter / 2.5
	Local faredge:Float = diameter / 2.4
	Local nearedge:Float = diameter / 2.6
	Local ms1:Int = MilliSecs() 
	
	'Do wierd pixmap creation as my machine wont allow normal usage ?! 
	Self.worldpixmap = GrabPixmap(0, 0, diameter + 1, diameter + 1) 
	Self.image = LoadImage(worldpixmap) 
	
		
	

	If heightmap = Null Then heightmap = TBank.Create(1) 
	If cloudmap= Null Then cloudmap = TBank.Create(1) 
	
		heightmap.Resize((((diameter + 1) ^ 2) * 4) + 1) 
		cloudmap.Resize((((diameter + 1) ^ 2) * 4) + 1) 

	tplanet.dimensions = diameter
	 	
	

		
	Print "Time till start: " + (MilliSecs() - ms1) 
	SeedRnd(seed) 

	Local colourmapr:Float[diameter + 1, diameter + 1] 
	Local colourmapg:Float[diameter + 1, diameter + 1] 
	Local colourmapb:Float[diameter + 1, diameter + 1] 
	Local x:Int, y:Int
	Local centx:Int = diameter / 2
	Local centy:Int = diameter / 2

	Local dx:Float, dy:Float, val:Int, distance:Float, x1:Int, y1:Int, x2:Int, y2:Int, rx:Int
	Local c:Int, d:Int, cloudavg:Float
	Global maxsize:Int = diameter / 10
	Global maxrocks:Int = landmass * 20
	
	ms1:Int = MilliSecs() 
	For x = 0 To diameter Step 1
		For y = 0 To diameter
			setheightmap(x, y, 0) 
			setcloudmap(x, y, 0) 
		Next
	Next
	Print "Map clear :" + (MilliSecs() - ms1) 
	

'generate other map
Local points:Int = maxrocks
ms1 = MilliSecs() 
Local pointx:Int[points + 1] 
Local pointy:Int[points + 1] 
local pointheight:Float[points + 1] 
Local rad:Int[points + 1] 

For x = 0 To points
	pointx[x] = ((Rand(0, diameter) - rot * 2) + diameter * 10) mod diameter
	pointy[x] = Rand(0, diameter) 
	pointheight[x] = Rand(64, 255) 
	rad[x] = Rand(diameter / 10, maxsize) * 2
	'pointx[x] = pointx[x] - (rot * Abs(pointy[x] - centy) / 100) 
Next

For x2 = 0 To diameter

	For y = 0 To diameter
		x = x2

		val = 64
		For Local z:Int = 0 To points
			dx = Abs(pointx[z] - x) 
			If dx > diameter / 2 Then dx = Abs(dx - diameter) 
			dy = Abs(pointy[z] - y) 
			If dy > diameter / 2 Then dy = Abs(dy - diameter) 
			Distance = (rad[z] - Sqr(dx * dx + dy * dy)) 
			If distance < 1 Then distance = 1 Else val = val + (Float(distance) / Float(rad[z] )) * pointheight[z] 
	
		Next
		setheightmap(x, y, val) 

	Next
Next
Print "Generated ground: " + (MilliSecs() - ms1) 

'now generate clouds
ms1 = MilliSecs() 
points:Int = 6 * clouddensity

pointx = pointx:Int[..points + 1] 
pointy = pointy:Int[..points + 1] 
pointheight = pointheight:Float[..points + 1] 
rad = rad:Int[..points + 1] 
Local cloudxsc:Float[points + 1] 
Local cloudysc:Float[points + 1] 

For x = 0 To points
		Local spd:Int = Rnd(1, 2) 
		Local xmov:Int, ymov:Int
		
		xmov = Sgn(Rnd(- 100, 0)) * Rand(2, 1) 
		ymov = Sgn(Rnd(- 100, 100))*0 
		
	pointx[x] = ((Rand(0, diameter) + (xmov * spd * rot)) + diameter) mod diameter
	pointy[x] = ((Rand(0, diameter) + (ymov * spd * rot)) + diameter) mod diameter

	cloudxsc[x] = Rnd(.1, 1) 
	cloudysc[x] = Rnd(.1, 1) 
	
	pointheight[x] = Rand(- 190, 512) 
	rad[x] = ((diameter / 30) * clouddensity) * (x + 1) 

Next

For x2 = 0 To diameter
	For y = 0 To diameter
		x = x2
		val = 64
		For Local z:Int = 0 To points
			Local snx:Int = Sgn(Rnd(- 100, 100)) 
			Local sny:Int = Sgn(Rnd(- 100, 100)) 
			Local xsc:Float = 1
			Local ysc:Float = 1
			Local px:Int = pointx[z] 
			Local py:Int = pointy[z] 
			If (px - x) < - diameter / 2 Then px = px + diameter
			If (px - x) > diameter / 2 Then px = px - diameter
			If (py - y) < - diameter / 2 Then py = py + diameter
			If (py - y) > diameter / 2 Then py = py - diameter
			dx = Abs(px - x) / xsc * cloudxsc[z] 
			dy = Abs(py - y) / ysc * cloudysc[z] 
			dx = dx + Rand(- diameter, diameter) / 40
			dy = dy + Rand(- diameter, diameter) / 40
			If Sgn(px - x) = snx Then dx = dx + 2
			If Sgn(px - y) = sny Then dy = dy + 2
			Local Distance:Float = rad[z] - Sqr(dx * dx + dy * dy) 
			If distance < 0 Then distance = 0
			If distance < 1 Then distance = 1 Else val = val + (Float(distance) / Float(rad[z] )) * pointheight[z] 
		Next
		setcloudmap(x, y, val) 

	Next
Next

Print "INitial cloud generation: " + (MilliSecs() - ms1) 

	
	'smooth now
	ms1:Int = MilliSecs() 
	Local smoothtype:Int = Rand(1, 2) 
	Local smooth:Int, avg:Float

	For Local smooth:Int = 1 To 5
		Local sm1:Int = Rand(0, 2) 
		Local sm2:Int = Rand(0, 2) 
		For x:Int = (centx - (faredge + 5)) To centx + (faredge + 5) Step 1
			For y:Int = (centy - (faredge + 5)) To (centy + (faredge + 5)) Step 1
				If getheightmapfast(x, y) <> 0 Then
				Local count:Float = 0
				avg = 0
				For c = -1 To 1
					For d = -1 To 1
						avg = avg + getheightmap(x + c, y + d) 
					Next
				Next
					setheightmap(x, y, avg / 9) 
					If getheightmap(x, y) > 512 Then setheightmap(x, y, 512) 
				EndIf
			Next
		Next
	Next

	Print "Blur ground: " + (MilliSecs() - ms1) 
	
	ms1 = MilliSecs() 
	'smooth clouds:
	
	
	For Local smooth:Int = 1 To 3
		For x:Int = (centx - faredge - 15) To centx + faredge Step 1
			For y:Int = centy - faredge To centy + faredge Step 1
				cloudavg:Float = 0
				For c:Int = -2 To - 0
					For d:Int = -1 To 1 Step 1

						cloudavg = cloudavg + getcloudmap(x + c, y + d) 
					Next
				Next
				dx:Float = centx - x
				dy:Float = centy - y
				distance = Sqr(dx * dx + dy * dy) 

				setcloudmap(x, y, cloudavg / 9) 

			Next
		Next
	Next

	'remove extra clouds
	
	For x = 0 To diameter
	For y = 0 To diameter
		dx:Float = centx - x
		dy:Float = centy - y
		Local distance:Float = Sqr(dx * dx + dy * dy) 
		Local v2:Float = (faredge * 1.5) - distance'('distance + (diameter / 18)) - (edge) 
		Local v3:Float = (v2 / (faredge)) * 2
		If v3 < 0 Then v3 = 0
		If v3 > 1 Then v3 = 1
		setcloudmap(x,y,getcloudmapfast(x,y)*v3)
	Next
	Next
	
	'Print "Blur clouds: " + (MilliSecs() - ms1) 

	'shadows:
	ms1 = MilliSecs() 
	For x = 0 To diameter
		For y = 0 To diameter
			Local diff:Float = getheightmap(x, y) - getheightmap(x + 1, y) 
			Local mul:Float
			colourmapg[x, y] = landcolourg
			colourmapr[x, y] = landcolourr
			colourmapb[x, y] = landcolourb
			
			If getheightmap(x, y) < 128 Then
				colourmapb[x, y] = watercolourb * 2;colourmapg[x, y] = watercolourg * 2;colourmapr[x, y] = watercolourr * 2

			Else
				If getheightmap(x, y) <= getheightmap(x + 1, y) Then
				Else
					mul:Float = 1.15
					If Abs(getheightmap(x, y) - getheightmap(x + 1, y)) < 10 Then mul = Rnd(1, 1.1) 
				EndIf
				mul = mul * Float((x - (centx / 2)) / 100.0) ;If mul < 1 Then mul = 1
					If Abs(getheightmap(x, y) - getheightmap(x + 1, y)) < 10 Then mul = mul * Rnd(1, 1.1) 
				
				
				setheightmap(x, y, getheightmap(x, y) * mul) 
				setheightmap(x, y, getheightmap(x, y) + diff * 10)  ' 250) 
				If getheightmap(x, y) < 0 Then setheightmap(x, y, 0) 
			EndIf
		Next
	Next
	'Print "Processing shadows: " + (MilliSecs() - ms1) 



	ms1 = MilliSecs() 
	'atmosphere and smoothing
	Local ox:Int, oy:Int
	For Local ang:Int = 0 To 360
		x = (Sin(ang) * (edge)) + centx
		y = (Cos(ang) * (edge)) + centy

		Local sz:Int = diameter / 240
		Local val:Int = 255
		For x2:Int = x - sz To x + sz / 2
			For y2:Int = y - sz To y + sz
				Local newval:Int = getcloudmap(x2, y2) + val
				If newval > 512 Then newval = 512
				setcloudmap(x2, y2, 128) 
			
			Next
		Next
	
	Next
	
	
	For Local ang:Int = 0 To 360
		x = (Sin(ang) * (faredge)) + centx
		y = (Cos(ang) * (faredge)) + centy
		If x <> ox Or y <> oy Then
		ox = x;oy = y
		Local sz:Int = Float(diameter / 20) 
		Local val:Int = 255
		For Local x2:Int = x - sz To x + sz
			For Local y2:Int = y - sz To y + sz

				Local cloudavg:Float = 0
				Local cloudcnt:Float = 0
				For Local c:Int = -1 To 1
					For Local d:Int = -1 To 1

						If c <> 0 Or d <> 0 Then
							'If (x2 + c) > 0 And (x2 + c) < diameter And (y2 + d) > 0 And (y2 + d) < diameter Then
							cloudavg = cloudavg + getcloudmap(x2 + c, y2 + d) 
							cloudcnt = cloudcnt + 1
							'endif
						EndIf
					Next
				Next
				setcloudmap(x2, y2, cloudavg / (cloudcnt - 0)) 
			Next
		Next
		EndIf
	Next
	Print "Atmosphere: " + (MilliSecs() - ms1) 

	worldpixmap = LockImage(image) 
	

ms1 = MilliSecs() 
	For x = 0 To diameter
		For y = 0 To diameter
			Local dx:Float = centx - x
			Local dy:Float = centy - y
			
			Local Distance:Float = Sqr(dx * dx + dy * dy) 
			If distance > edge Then setheightmap(x, y, 127) ;colourmapr[x, y] = 0;colourmapg[x, y] = 0;colourmapb[x, y] = 255
			Local colour:Float = getheightmap(x, y) / 2

			If daynight <> 0 Then colour = colour * ((x - diameter / 2) / Float(diameter)) * 1.3
			if colour<0 then colour=0
			colour = colour / 256
			Local colour1r:Float = colour * colourmapr[x, y] 
			Local colour1g:Float = colour * colourmapg[x, y] 
			Local colour1b:Float = colour * colourmapb[x, y] 
			
			
			
			Local colourmix:Float = (getcloudmap(x, y) - 0) / 255
			'colourmix = (colourmix -.2) * 0.8
			Local colour2r:Float = ((1 - colourmix) * cloudcolourr) + (colourmix * cloudcolourr) / 3
			Local colour2g:Float = ((1 - colourmix) * cloudcolourg) + (colourmix * cloudcolourg) / 3
			Local colour2b:Float = ((1 - colourmix) * cloudcolourb) + (colourmix * cloudcolourb) / 3
			If star = True Then
				colour2r:Float = ((colourmix) * cloudcolourr) + ((1 - colourmix) * cloudcolourr) / 3
				colour2g:Float = ((colourmix) * cloudcolourg) + ((1 - colourmix) * cloudcolourg) / 3
				colour2b:Float = ((colourmix) * cloudcolourb) + ((1 - colourmix) * cloudcolourb) / 3
			EndIf
					
			colourmix = (colourmix -.2) * 4.5
			If colourmix < 0 Then colourmix = 0
			If colourmix > 1 Then colourmix = 1

			Local finalcolourr:Int = (colour1r * (1 - colourmix)) + (colour2r * colourmix) 
			Local finalcolourg:Int = (colour1g * (1 - colourmix)) + (colour2g * colourmix) 
			Local finalcolourb:Int = (colour1b * (1 - colourmix)) + (colour2b * colourmix) 

			
			Local alpha:Int = 255
			alpha = Float(colourmix * 255) 
		

			Local v2:Float = (nearedge - distance) 
			Local v3:Float = v2 / (edge - distance) 
			If distance < faredge Then v3 = 0
			If v3 < 0 Then v3 = 0
			If v3 > 1 Then v3 = 1

			alpha = ((1 - v3))  ' * 255
			If alpha < 0 Then alpha = 0

			If finalcolourr > 255 Then finalcolourr = 255
			If finalcolourg > 255 Then finalcolourg = 255
			If finalcolourb > 255 Then finalcolourb = 255
			If finalcolourr < 0 Then finalcolourr = 0
			If finalcolourg < 0 Then finalcolourg = 0
			If finalcolourb < 0 Then finalcolourb = 0
			alpha = (alpha * 255) + (colourmix * 255) 
			If colourmix > 0 Then
				Local alpha2:Float = ((diameter / 20) - (distance - faredge)) 
				If flares Then alpha2 = alpha2 / 1.3
				If alpha2 < 0 Then alpha2 = 0
				alpha = alpha * (alpha2 / (diameter / 20)) 
				alpha = alpha - colourmix
			EndIf
			Local alpha2:Float = ((Float(distance - edge)) / (edge - faredge)) +.95
			If alpha2 < 0 Then alpha2 = 0 Else If alpha2 > 1 Then alpha2 = 1
			If flares = 0 Then alpha = alpha * alpha2  ' * 255
			If alpha < 0 Then alpha = 0 Else If alpha > 255 Then alpha = 255
			Local pixel:Int = (finalcolourb | finalcolourg Shl 8 | finalcolourr Shl 16 | alpha Shl 24) 
			worldpixmap.WritePixel(x, y, pixel) 
		Next
	Next
	ms1 = MilliSecs() 
	UnlockImage(image) 
	Print "Unlocking image:" + (MilliSecs() - ms1) 
'	SetScale 2, 2
	End Method

	Function blurheightmap() 
		Local x:Int, y:Int, x1:Int, y1:Int, c:Int, d:Int
		Local val:Float
		For x = 0 To dimensions
			For y = 0 To dimensions
				For c = -1 To 1
					For d = -1 To 1
						x1 = x + c;y1 = y + d
						If x1 < 1 Or x1 > dimensions - 1 Or y1 < 1 Or y1 > dimensions - 1 Then
							x1 = (x1 + dimensions) mod dimensions
							y1 = (y1 + dimensions) mod dimensions
						EndIf
						val = val + PeekFloat(heightmap, ((x1 * dimensions) + y1) * 4) 
					Next
				Next
				PokeFloat(heightmap, ((x * dimensions) + y) * 4, val / 9.0) 
			Next
		Next
	End Function
	
	Function getcloudmap:Float(x:Int, y:Int) nodebug

		x = (x + dimensions) mod dimensions
		y = (y + dimensions) mod dimensions
		Local add:Int = ((x * dimensions) + y) * 4
		Return cloudmap.PeekFloat(add) 
	
	End Function

	Function setcloudmap(x:Int, y:Int, val:Float) nodebug

		x = (x + dimensions) mod dimensions
		y = (y + dimensions) mod dimensions
		Local add:Int = ((x * dimensions) + y) * 4
		cloudmap.PokeFloat(add, val) 

	End Function
	
	
	Function getheightmap:Float(x:Int, y:Int) nodebug
		x = (x + dimensions) mod dimensions
		y = (y + dimensions) mod dimensions
		Local add:Int = ((x * dimensions) + y) * 4
		Return heightmap.PeekFloat(add) 
	End Function

	Function getheightmapfast:Float(x:Int, y:Int) 
		Return heightmap.PeekFloat(((x * dimensions) + y) * 4) 
	End Function
	
	Function getcloudmapfast:Float(x:Int, y:Int) 
		Return cloudmap.PeekFloat(((x * dimensions) + y) * 4) 
	End Function
	
	Function setheightmap(x:Int, y:Int, val:Float) nodebug
		x = (x + dimensions) mod dimensions
		y = (y + dimensions) mod dimensions
		Local add:Int = ((x * dimensions) + y) * 4
		heightmap.PokeFloat(add, val) 
	End Function
	
End Type