Code archives/3D Graphics - Misc/Shadow Mapper

; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; 			ULTRA FAST TERRAIN SHADOW MAPPER
;	       bY Tim Fisher a.k.a Flynn (C) 2003 v0.2
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

; I am sure this can be optimised!!!! :)


Graphics 640,480,16,2


; Load Your Terrain bitmap file
Global termap = LoadImage("terrain01.bmp")
Global LMSize = ImageWidth(termap)

; Initialise the mapping arrays
Dim ter#(1,1)
Dim Lmap#(1,1)


time1 = MilliSecs()

; Initialise the arrays
Initialise(termap,LMSize)


; Render the LightMap/Shadowmap. RenderLMAP(SunXPos,SunYPos,SunZPos,Lightmapsize)
shadow = RenderLMAP(4000,-1000,7000,LMSize)


SetBuffer BackBuffer()

; Do some blurring of the image (makes it look better!!)
LMBLurIMage(shadow,1)




DrawImage termap,0,0
DrawImage shadow,260,0
time2 = MilliSecs() - time1
Text 0,0,"FINISHED in "+time2 + "ms"
Text 0,10,"Hit Any Key to Save Image"
Flip

WaitKey
SaveImage (shadow,"shadow.bmp")

End

; ---------------------------------------------------------------
; Renders the Light Map according to the position of the sun
; sunX,SunY,sunZ	=	Suns Position relative to image origin
; LMAPSize			=   Size in Pixels of the Terrain Image
; ---------------------------------------------------------------

Function RenderLMAP(sunX,sunY,sunZ,LMAPSize)

	shadow = CreateImage(LMAPSize,LMAPSize)
	SetBuffer ImageBuffer(shadow)
	ClsColor 255,255,255
	Cls
	
	For x = 0 To LMAPSize
		For y = 0 To LMAPSize
			If LockedLine(x,y,ter(x,y),sunX,sunY,sunZ) Then LMAP(x,y) = 100
			
		Next
	Next

	SetBuffer ImageBuffer(shadow)
	LockBuffer ImageBuffer(shadow)
	For x = 0 To LMAPSize
		For y = 0 To LMAPSize
			col = lmap(x,y)
			If col <> 255 Then WritePixelFast (x,y,col Shl 16 Or col Shl 8 Or col)
		Next
		Next
	UnlockBuffer ImageBuffer(shadow)
	Return shadow
End Function

; ------------------------------------------------------------------------
; Initialises the arrays and popultates according to the terrain map data
; termap			=	the terrain map to use
; LMAPSize			=   Size in Pixels of the Terrain Image
; I have used arrays since I need to do many look ups and if I used 
; ReadPixelFast everytime I needed some info then the whole thing would 
; take minutes and not seconds!!!!
; ------------------------------------------------------------------------

Function Initialise(termap,LMapSize)
	Dim ter#(LMapSize,LMapSize)
	Dim Lmap#(LMapSize,LMapSize)
	
	SetBuffer ImageBuffer(termap)
	LockBuffer ImageBuffer(termap)

	For x = 0 To LMapSize
		For y = 0 To LMapSize
			col = ReadPixelFast( x,y)
			ter(x,y) = col Shr 16 And $FF
			Lmap(x,y) = 255
		Next
	Next
	UnlockBuffer ImageBuffer(termap)
End Function

; ---------------------------------------------------------------
; This creates a ray from the specific pixel to the sun,
; if the ray hits a point on the Terrainmap that is higher than
; the projected pixels vector then that pixel is shadowed. 
; x1,y1,z1 			=   The Pixel to check for Shadows
; x2,y2,z2			=   The position of the sun
; ---------------------------------------------------------------

Function LockedLine(x1#,y1#,z1#,x2#,y2#,z2#)
	
	Local steps,xI#
	
	x2 = x2-x1
	y2 = y2-y1
	z2 = z2-z1
	If Abs(x2)>Abs(y2) steps = Abs(x2) Else steps = Abs(y2)
	xI = x2 / steps
	y2 = Y2 / steps
	z2 = z2 / steps
	
	While (x1 <= LMSize) And (y1 <= LMSize) And (z1 <= LMSize) And (x1 => 0) And (y1 => 0) And (z1 => 0)
	
		; does the ray collide with the terrain??
		If (ter#(x1,y1) > z1) Then Return True
	
		x1=x1+xI:y1=y1+y2:z1=z1+z2
		
	Wend
	Return False
End Function

; --------------------------------------------------------------------
; An image blur routine I borrowed off of BlitzBasic
; -------------------------------------------------------------------

Function LMBlurImage(Image, radius = 1)

	ImgBuf = ImageBuffer(Image)
	
	LockBuffer(ImgBuf)
	
	W% = ImageWidth(Image)
	H% = ImageHeight(Image)

	; Go thru all the pixels
	For y% = 0 To H-1
		For x% = 0 To W-1
		
			; Measure the box to get the pixel samples from
			ix1 = x - radius
			iy1 = y - radius
			ix2 = x + radius
			iy2 = y + radius
			
			; Prevent it going out of bound
			If ix1 < 0 Then ix1 = 0
			If iy1 < 0 Then iy1 = 0
			If ix2 > W-1 Then ix2 = W-1
			If iy2 > H-1 Then iy2 = H-1
			
			r = 0 : g = 0 : b = 0
			num = 0
			
			; Run thru all the sampled box
			For y2% = iy1 To iy2
				For x2% = ix1 To ix2
					
					; Sum the sampled pixel 
					argb = ReadPixelFast(x2, y2, ImgBuf) And $FFFFFF
					ar = (argb Shr 16 And %11111111)
					ag = (argb Shr 8 And %11111111)
					ab = (argb And %11111111)
					
					r = r + ar
					g = g + ag
					b = b + ab
					
					num = num + 1
				Next	
			Next
			
			; Get the average value
			r = r / num
			g = g / num
			b = b / num

			rgb = b Or (g Shl 8) Or (r Shl 16)
			WritePixelFast(x, y, rgb, ImgBuf)

		Next
	Next
	
	UnlockBuffer(ImgBuf)
	
End Function