sle/engine2.bas

'Engine 2. Started Saturday 1 August 2020

#include "file.bi"

#define SWIDTH 800
#define SHEIGHT 600
#define PPM (76800 / 23)	'Pixels per meter
#define MAX_VERTICES 1000
#define MAX_TRIANGLES 1000
#define MAX_TRACK_OBJECTS 256
#define MAX_MATERIALS 100
#define MAX_ACTIVE_OBJECTS 100
#define PI 3.14159


Type Vector3D
	x As Double
	y As Double
	z As Double
End Type

Type Camera
	x As Double
	y As Double
	z As Double
	azm As Double	'Azimuth, Z rotation, first
	alt As Double	'Altitude, X rotation, second
	bank As Double	'Bank, Y rotation, last
End Type

Type TrackObject
	fvertex As Short
	vertices As Short
	ftriangle As Short
	triangles As Short
End Type

Type Triangle
	p(1 To 3) As Short
	col As ULong
	twosided As Byte
	textured As Byte
	priority As Byte
End Type

Type Material
	mname As String
	col As ULong
	twosided As Byte
	textured As Byte
	priority As Byte
End Type

Type ActiveObject
	x As Double			'Centre X, Y and Z
	y As Double
	z As Double
	d As Double			'Distance to camera: used during rendering
	rot As Double		'Rotation in Z
	kind As Short		'Object type
End Type


'Pool of vertices, triangles, objects and materials
Dim Shared pv(1 To MAX_VERTICES) As Vector3D, pvs As Short
Dim Shared pt(1 To MAX_TRIANGLES) As Triangle, pts As Short
Dim Shared tob(1 To MAX_TRACK_OBJECTS) As TrackObject, tobs As Short
Dim Shared mat(1 To MAX_MATERIALS) As Material, mats As Short
Dim Shared aob(1 To MAX_ACTIVE_OBJECTS) As ActiveObject, aobs As Short

'Working vertices and triangles (currently working object)
Dim Shared wv(1 To 500) As Vector3D, wvs As Short
Dim Shared wt(1 To 500) As Triangle, wts As Short

Dim Shared cam As Camera, visibility As Short = 1200
Dim Shared As Double SMWIDTH, SMHEIGHT, DTS = .6, CLIP_DISTANCE = .6

'Convert to screen/window coordinates
Sub Screenise
	For i As Short = 1 To wvs
		wv(i).x = wv(i).x * PPM + SWIDTH / 2
		wv(i).z = SHEIGHT / 2 - wv(i).z * PPM
		Swap wv(i).y, wv(i).z
	Next i
End Sub

'Load an object from the object pool as the working object
Sub TakeObject (n As Short)
	Dim i As Short
	
	wvs = tob(n).vertices
	For i = tob(n).fvertex To tob(n).fvertex + tob(n).vertices - 1
		wv(i - tob(n).fvertex + 1) = pv(i)
	Next i
	
	wts = tob(n).triangles
	For i = tob(n).ftriangle To tob(n).ftriangle + tob(n).triangles - 1
		wt(i - tob(n).ftriangle + 1) = pt(i)
	Next i
End Sub

'Move working object
Sub MoveObject (dx As Double, dy As Double, dz As Double)
	For i As Short = 1 To wvs
		wv(i).x += dx
		wv(i).y += dy
		wv(i).z += dz
	Next i
End Sub


Sub RotateX (angle As Double)
	Dim v As Vector3D
	
	For i As Short = 1 To wvs
		v = wv(i)
		wv(i).y = v.y * Cos(angle) - v.z * Sin(angle)
		wv(i).z = v.y * Sin(angle) + v.z * Cos(angle)
	Next i
End Sub


Sub RotateY (angle As Double)
	Dim v As Vector3D
	
	For i As Short = 1 To wvs
		v = wv(i)
		wv(i).x = v.x * Cos(angle) + v.z * Sin(angle)
		wv(i).z = -v.x * Sin(angle) + v.z * Cos(angle)
	Next i
End Sub


Sub RotateZ (angle As Double)
	Dim v As Vector3D
	
	For i As Short = 1 To wvs
		v = wv(i)
		wv(i).x = v.x * Cos(angle) + v.y * Sin(angle)
		wv(i).y = -v.x * Sin(angle) + v.y * Cos(angle)
	Next i
End Sub

'Apply perspective to working object's X and Z coordinates over Y
Sub ApplyPerspective
	For i As Short = 1 To wvs
		If wv(i).y > .05 Then
			wv(i).x = DTS * wv(i).x / wv(i).y
			wv(i).z = DTS * wv(i).z / wv(i).y
		End If
	Next i
End Sub


Sub LoadMaterials (mlib As String)
	Dim f As Integer, s As String, n As Short, c As String
	
	f = FreeFile
	Open mlib + ".mtl" For Input As f
	While Not EoF(f)
		Line Input #f, s
		n = InStr(s, " ")
		If n Then
			c = Left(s, n - 1)
			s = Trim(Mid(s, n + 1))
		Else
			c = s
			s = ""
		End If
		
		Select Case c
			Case "newmtl"
				mats += 1
				mat(mats).mname = s
				mat(mats).priority = 0
				mat(mats).twosided = 0
			Case "Kd"
				Dim As ULong r, g, b
				
				r = 255 * Val(s)
				s = Mid(s, InStr(s, " ") + 1)
				g = 255 * Val(s)
				s = Mid(s, InStr(s, " ") + 1)
				b = 255 * Val(s)
				mat(mats).col = RGB(r, g, b)
			Case "d"
				If Val(s) = 1 Then
					mat(mats).textured = 0
				Else
					mat(mats).textured = -1
				End If
			Case "#p"	'Priority is a made-up property
				mat(mats).priority = -1
			Case "#2s"	'Two-sided is a made-up property
				mat(mats).twosided = -1
		End Select
	Wend
	Close f
End Sub


Sub LoadObj (oname As String)
	Dim f As Integer, s As String, n As Short, c As String
	Dim curmat As Short = 1
	
	f = FreeFile
	Open oname + ".obj" For Input As f
	
	tobs += 1
	tob(tobs).fvertex = pvs + 1
	tob(tobs).vertices = 0
	tob(tobs).ftriangle = pts + 1
	tob(tobs).triangles = 0
	
	While Not EoF(f)
		Line Input #f, s
		n = InStr(s, " ")
		If n Then
			c = Left(s, n - 1)
			s = Trim(Mid(s, n + 1))
		Else
			c = s
			s = ""
		End If
		
		Select Case c
			Case "v"	'Add vertex to the pool
				pvs += 1
				tob(tobs).vertices += 1
				'For some weird reason, Blender saves Y and Z swapped
				'when exporting OBJ. So we're undoing that here
				pv(pvs).x = Val(s)
				s = Mid(s, InStr(s, " ") + 1)
				pv(pvs).z = Val(s)
				s = Mid(s, InStr(s, " ") + 1)
				pv(pvs).y = Val(s)
			Case "f"
				Dim As Short a, b, c
				
				a = ValInt(s)
				s = Mid(s, InStr(s, " ") + 1)
				b = ValInt(s)
				s = Mid(s, InStr(s, " ") + 1)
				c = ValInt(s)
				
				'If the polygon is not a triangle, decompose
				'in triangles using first vertex as pivot. This
				'will only work if the polygon is convex!
				Do
					pts += 1
					tob(tobs).triangles += 1
					pt(pts).col = mat(curmat).col
					pt(pts).priority = mat(curmat).priority
					pt(pts).textured = mat(curmat).textured
					pt(pts).p(1) = a '+ tob(tobs).ftriangle - 1
					pt(pts).p(2) = b '+ tob(tobs).ftriangle - 1
					pt(pts).p(3) = c '+ tob(tobs).ftriangle - 1
					If InStr(s, " ") = 0 Then Exit Do
					b = c
					s = Mid(s, InStr(s, " ") + 1)
					c = ValInt(s)
				Loop
			Case "usemtl"
				For i As Short = 1 To mats
					If mat(i).mname = s Then
						curmat = i
						Exit For
					End If
				Next i
		End Select
	Wend
	Close f
End Sub


Sub drawtriangle(ByVal x1 As Short, ByVal y1 As Short, _
				ByVal x2 As Short, ByVal y2 As Short, _
				ByVal x3 As Short, ByVal y3 As Short, col As ULong)
	
	'STEPS TO FOLLOW:
	'Step 1: Sort point by Y
	'Step 2: Drop all triangles out of Y bounds
	'Step 3: Classify as top, bottom or mixed
	'Step 4: If mixed, split the triangle and call the sub twice and exit
	'Step 5: Obtain initial Y and X1 and X2 for first line, plus deltas
	'Step 6: Apply deltas till Y is onscreen
	'Step 7: Draw lines till triangle is complete or out of screen

	Dim currenty As Long
	Dim As Long deltaxi, deltaxf, currentxi, currentxf
	
	'Step 1: Sort point by Y
	If y1 > y2 Then Swap y1, y2 : Swap x1, x2
	If y2 > y3 Then Swap y2, y3 : Swap x2, x3
	If y1 > y2 Then Swap y1, y2 : Swap x1, x2
	
	'Step 2: Drop all triangles out of Y bounds
	If y3 < 0 Or y1 >= SHEIGHT Then Exit Sub
	
	'Step 3: Classify as top, bottom or mixed
	If y1 = y2 AndAlso y2 = y3 Then
		'Just a horizontal line
		'... not drawing anything so far
	ElseIf y2 = y3 Then			'Top
		'Step 5: Obtain initial Y and X1 and X2 for first line, plus deltas
		If x2 > x3 Then Swap x2, x3 : Swap y2, y3	'Sort by X
		currenty = y1
		currentxi = x1 ShL 8 : currentxf = x1 ShL 8
		deltaxi = ((x2 - x1) ShL 8) \ (y2 - y1)	'Add some precision
		deltaxf = ((x3 - x1) ShL 8) \ (y3 - y1)
	ElseIf y1 = y2 Then		'Bottom
		'Step 5: Obtain initial Y and X1 and X2 for first line, plus deltas
		If x1 > x2 Then Swap x1, x2 : Swap y1, y2	'Sort by X
		currenty = y1
		currentxi = x1 ShL 8 : currentxf = x2 ShL 8
		deltaxi = ((x3 - x1) ShL 8) \ (y3 - y1)	'Add some precision
		deltaxf = ((x3 - x2) ShL 8) \ (y3 - y2)
	Else					'Mixed
		'Step 4: If mixed, split the triangle and call the sub twice and exit
		Dim otherx As Short
		
		otherx = (y2 - y1) * (x3 - x1) \ (y3 - y1) + x1
		drawtriangle x1, y1, x2, y2, otherx, y2, col
		drawtriangle x2, y2, otherx, y2, x3, y3, col
		Exit Sub
	End If
	
	'Step 6: Apply deltas till Y is onscreen
	If currenty < 0 Then
		currentxi += Abs(currenty) * deltaxi
		currentxf += Abs(currenty) * deltaxf
		currenty = 0
	End If
	
	'Step 7: Draw lines till triangle is complete or out of screen
	Dim As Short tempxi, tempxf
	Do
		'Only draw if onscreen
		If currentxf >= 0 And (currentxi ShR 8) < SWIDTH Then
			'Clip the line
			If currentxi >= 0 Then tempxi = currentxi ShR 8 Else tempxi = 0
			If (currentxf ShR 8) < SWIDTH Then tempxf = currentxf ShR 8 Else tempxf = SWIDTH - 1
			'Draw it
			If tempxi <> 0 Or tempxf <> 0 Then _ 'Don't know why this IF is necessary to avoid a horrible vertical line
				Line (tempxi, currenty)-(tempxf, currenty), col
		End If
		
		'If triangle is done or we go offscreen, then exit
		If currenty >= y3 OrElse currenty >= SHEIGHT - 1 Then Exit Do
	
		'Update coordinates
		currentxi += deltaxi
		currentxf += deltaxf
		currenty += 1
	Loop
End Sub


Sub SortTriangles
	Dim As Short i, j
	Dim tz(1 To wts) As Double
	
	For i = 1 To wts
		tz(i) = wv(wt(i).p(1)).z + wv(wt(i).p(2)).z + wv(wt(i).p(3)).z
	Next i
	
	Dim farthest As Short, fdistance As Double
		
	For i = 1 To wts - 1
		fdistance = 0
		For j = i To wts
			If tz(j) > fdistance Then
				fdistance = tz(j)
				farthest = j
			End If
		Next j
		
		If farthest <> i Then
			Swap wt(farthest), wt(i)
			Swap tz(farthest), tz(i)
		End If
	Next i
End Sub


Function TFront(t As Triangle) As Boolean
	Dim As Double r, r2
	
	'This works fine, but unless the operation is performed
	'AFTER perspective was applied, the result will look
	'awkward.
	
	r = wv(t.p(1)).x * wv(t.p(2)).y
	r += wv(t.p(2)).x * wv(t.p(3)).y
	r += wv(t.p(3)).x * wv(t.p(1)).y
	
	r2 = wv(t.p(2)).x * wv(t.p(1)).y
	r2 += wv(t.p(3)).x * wv(t.p(2)).y
	r2 += wv(t.p(1)).x * wv(t.p(3)).y
	
	Return r > r2
End Function


Sub DrawObject
	For i As Short = 1 To wts
		If TFront(wt(i)) Then
			drawtriangle wv(wt(i).p(1)).x, wv(wt(i).p(1)).y, _
				wv(wt(i).p(2)).x, wv(wt(i).p(2)).y, _
				wv(wt(i).p(3)).x, wv(wt(i).p(3)).y, wt(i).col			
		End If		
	Next i
End Sub


Sub ClipTriangles
	Dim As Short i, n
	Dim isok(1 To 3) As Byte, areok As Byte
	
	n = 1
	Do
		areok = 0
		For i = 1 To 3
			isok(i) = (wv(wt(n).p(i)).y >= CLIP_DISTANCE)
			If isok(i) Then areok += 1
		Next i
		
		Select Case areok
			Case 3
				'Good boy!  Keep this triangle as is. Next triangle
				n += 1
			Case 0
				'Don't draw this triangle. It's behind the fustrum
				Swap wt(n), wt(wts)
				wts -= 1
			Case 1
				'Only one good vertex. Transform the other two
				Dim temp As Short
				
				'First, reorder so that point 1 is the good one
				If isok(2) Then
					temp = wt(n).p(1)
					wt(n).p(1) = wt(n).p(2)
					wt(n).p(2) = wt(n).p(3)
					wt(n).p(3) = temp
				ElseIf isok(3) Then
					temp = wt(n).p(1)
					wt(n).p(1) = wt(n).p(3)
					wt(n).p(3) = wt(n).p(2)
					wt(n).p(2) = temp
				End If
				
				Dim a As Double
				
				'Create the two new points
				a = (CLIP_DISTANCE - wv(wt(n).p(1)).y) / (wv(wt(n).p(2)).y - wv(wt(n).p(1)).y)
				wvs += 1
				wv(wvs).x = a * (wv(wt(n).p(2)).x - wv(wt(n).p(1)).x) + wv(wt(n).p(1)).x
				wv(wvs).y = CLIP_DISTANCE
				wv(wvs).z = a * (wv(wt(n).p(2)).z - wv(wt(n).p(1)).z) + wv(wt(n).p(1)).z
				
				a = (CLIP_DISTANCE - wv(wt(n).p(1)).y) / (wv(wt(n).p(3)).y - wv(wt(n).p(1)).y)
				wvs += 1
				wv(wvs).x = a * (wv(wt(n).p(3)).x - wv(wt(n).p(1)).x) + wv(wt(n).p(1)).x
				wv(wvs).y = CLIP_DISTANCE
				wv(wvs).z = a * (wv(wt(n).p(3)).z - wv(wt(n).p(1)).z) + wv(wt(n).p(1)).z
				
				'Replace points 2 and 3
				wt(n).p(2) = wvs - 1
				wt(n).p(3) = wvs
				
				n += 1
			Case 2
				'Two vertices are OK. We need to split the triangle
				Dim temp As Short
				
				'First, reorder so that point 1 is the bad one
				If Not isok(2) Then
					temp = wt(n).p(1)
					wt(n).p(1) = wt(n).p(2)
					wt(n).p(2) = wt(n).p(3)
					wt(n).p(3) = temp
				ElseIf Not isok(3) Then
					temp = wt(n).p(1)
					wt(n).p(1) = wt(n).p(3)
					wt(n).p(3) = wt(n).p(2)
					wt(n).p(2) = temp
				End If
				
				Dim a As Double
				
				'Create the two new points
				a = (CLIP_DISTANCE - wv(wt(n).p(1)).y) / (wv(wt(n).p(2)).y - wv(wt(n).p(1)).y)
				wvs += 1
				wv(wvs).x = a * (wv(wt(n).p(2)).x - wv(wt(n).p(1)).x) + wv(wt(n).p(1)).x
				wv(wvs).y = CLIP_DISTANCE
				wv(wvs).z = a * (wv(wt(n).p(2)).z - wv(wt(n).p(1)).z) + wv(wt(n).p(1)).z
				
				a = (CLIP_DISTANCE - wv(wt(n).p(1)).y) / (wv(wt(n).p(3)).y - wv(wt(n).p(1)).y)
				wvs += 1
				wv(wvs).x = a * (wv(wt(n).p(3)).x - wv(wt(n).p(1)).x) + wv(wt(n).p(1)).x
				wv(wvs).y = CLIP_DISTANCE
				wv(wvs).z = a * (wv(wt(n).p(3)).z - wv(wt(n).p(1)).z) + wv(wt(n).p(1)).z
				
				'Update point 1 of current triangle
				wt(n).p(1) = wvs - 1
				
				'Create new triangle and assign the points
				wts += 1
				wt(wts).p(1) = wvs
				wt(wts).p(2) = wvs - 1
				wt(wts).p(3) = wt(n).p(3)
				
				'Skip the newly created triangle
				Swap wt(n + 1), wt(wts)
				n += 2
		End Select
	Loop Until n > wts
End Sub


Sub ParseConfig
	Dim f As Integer, s As String, c As String, n As Short
	Dim ar(1 To 10) As String
	
	If Not FileExists("engine2.cfg") Then Exit Sub

	f = FreeFile
	Open "engine2.cfg" For Input As f
	While Not EoF(f)
		Line Input #f, s
		n = InStr(s, "#")
		If n Then s = Left(s, n - 1)
		s = Trim(s)
		n = InStr(s, " ")
		If n Then
			c = RTrim(Left(s, n - 1))
			s = LTrim(Mid(s, n + 1))
		Else
			c = s
			s = ""
		End If
		
		For i As Short = 1 To 10
			n = InStr(s, ",")
			If n Then
				ar(i) = RTrim(Left(s, n - 1))
				s = LTrim(Mid(s, n + 1))
			Else
				ar(i) = s
				Exit For
			End If
		Next i
		
		Select Case LCase(c)
			Case "lm", "mat", "m" : LoadMaterials ar(1)
			Case "lo", "obj", "o" : LoadObj ar(1)
			Case "place", "+"	'place numobj,x,y,z,rot
				aobs += 1
				aob(aobs).kind = ValInt(ar(1))
				aob(aobs).x = Val(ar(2))
				aob(aobs).y = Val(ar(3))
				aob(aobs).z = Val(ar(4))
				aob(aobs).rot = Val(ar(5))
			Case "camera", "cam", "c"	'camera x,y,z,azimuth,altitude,bank
				cam.x = Val(ar(1))
				cam.y = Val(ar(2))
				cam.z = Val(ar(3))
				cam.azm = Val(ar(4))
				cam.alt = Val(ar(5))
				cam.bank = Val(ar(6))
		End Select			
	Wend
	Close f
End Sub


Sub SortActiveObjects
	'Calculate taxicab distances
	For i As Short = 1 To aobs
		aob(i).d = Abs(aob(i).x - cam.x) + Abs(aob(i).y - cam.y) + Abs(aob(i).z - cam.z)
	Next i
	
	'Sort
	For i As Short = 1 To aobs
		Dim max As Double, who As Short
		
		max = 0 : who = i
		For j As Short = i To aobs
			If aob(j).d > max Then
				max = aob(j).d
				who = j
			End If
		Next j
		
		If who <> i Then Swap aob(i), aob(who)
	Next i
End Sub


Sub Render
	SortActiveObjects
	
	ScreenLock
	CLS
	For i As Short = 1 To aobs
		If aob(i).d <= visibility Then
			TakeObject aob(i).kind
			RotateZ aob(i).rot
			MoveObject aob(i).x - cam.x, aob(i).y - cam.y, aob(i).z - cam.z
			
			'These three can be packed in one matrix multiplication
			RotateZ -cam.azm
			RotateX -cam.alt
			RotateY -cam.bank
			
			ClipTriangles
			ApplyPerspective
			Screenise
			SortTriangles
			
			DrawObject
		End If
	Next i
	ScreenUnlock
End Sub


SMWIDTH = SWIDTH / PPM
SMHEIGHT = SHEIGHT / PPM

ScreenRes SWIDTH, SHEIGHT, 32
WindowTitle "StuntsLegacyEngine v0.2"

ParseConfig

Dim t As Double, theta As Double, phi As Double
Dim akey As String, dist As Double, debug As Byte
Dim speed As Short

t = Timer
Do
	Render
	If debug Then
		Locate 1, 1
		Print Using "(####.###_, ####.###_, ####.###)"; cam.x; cam.y; cam.z
		Print Using "az=#### pt=#### bk=####"; cam.azm * 180 / PI; cam.alt * 180 / PI; cam.bank * 180 / PI
		Print "Dist. to screen: "; DTS;
	End If
	
	Do : Loop Until Timer >= t + .01
	t = Timer
	
	If MultiKey(&H2A) Then	'Shift
		speed = 1
	Else
		speed = 3
	End If
	If MultiKey(&H11) Then	'W
		cam.x += 2 * Sin(cam.azm) * speed
		cam.y += 2 * Cos(cam.azm) * speed
	End If
	If MultiKey(&H1F) Then	'S
		cam.x -= 2 * Sin(cam.azm) * speed
		cam.y -= 2 * Cos(cam.azm) * speed
	End If
	If MultiKey(&H1E) Then	'A
		cam.x -= 1 * Cos(cam.azm) * speed
		cam.y += 1 * Sin(cam.azm) * speed
	End If
	If MultiKey(&H20) Then	'D
		cam.x += 1 * Cos(cam.azm) * speed
		cam.y -= 1 * Sin(cam.azm) * speed
	End If
	If MultiKey(72) Then	'Up
		cam.alt -= .002 * speed
		If cam.alt <= -PI Then cam.alt += 2 * PI
	End If
	If MultiKey(80) Then	'Down
		cam.alt += .002 * speed
		If cam.alt >= PI Then cam.alt -= 2 * PI
	End If
	If MultiKey(77) Then	'Right
		cam.azm += .002 * speed
		If cam.azm >= PI Then cam.azm -= 2 * PI
	End If
	If MultiKey(75) Then	'Left
		cam.azm -= .002 * speed
		If cam.azm <= -PI Then cam.azm += 2 * PI
	End If
	If MultiKey(73) Then	'PgUp
		cam.z += .4 * speed
	End If
	If MultiKey(81) Then	'PgDn
		cam.z -= .4 * speed
	End If
	
	akey = InKey
	Select Case akey
		Case "["
			If DTS > .1 Then DTS /= 1.4142
		Case "]"
			If DTS < 20 Then DTS *= 1.4142
		Case Chr(4)	'CTRL+D - Debug
			debug = Not debug
		Case Chr(27) : Exit Do
	End Select
Loop