DECLARE SUB slopeFromData ()
DECLARE SUB main ()
DECLARE SUB actorDraw (iSlot AS INTEGER)
DECLARE SUB actorMove (iActor AS INTEGER)
DECLARE FUNCTION getInput% ()
DECLARE SUB mapFromData ()
DECLARE SUB mapDraw ()

CONST cActorOnGroundLeft = &H1    ' Left foot on the ground.
CONST cActorOnGroundRight = &H2   ' Right foot on the ground.
CONST cActorOnGround = &H3        ' Actor is on the ground.

CONST cBlockIsSolid = &H8000 ' Block is solid.
CONST cBlockIsSlope = &H4000 ' Block is a slope.

CONST True = -1
CONST False = 0

CONST cCellWidth = 16
CONST cCellHeight = 16
CONST cNumSlopes = 7         ' Number of slope Types
CONST cMaxCells = 512

TYPE blockType
	iColor AS INTEGER
	iFlags AS INTEGER
	iShape AS INTEGER          ' Index (divided by 16) in gSlope()
END TYPE

TYPE ActorType
	iFlags AS INTEGER   ' Special flags.
	fX AS SINGLE        ' Actor's origin, located in the bottom
	fY AS SINGLE        '   center of the bounding box.
	fVelX AS SINGLE     ' Velocity, added to the origin every game
	fVelY AS SINGLE     '   tick, influenced by body type.
	iBBoxW AS INTEGER   ' Bounding box half width and height,
	iBBoxH AS INTEGER   '   relative to the origin.
END TYPE

DIM SHARED gBlock(15) AS blockType
DIM SHARED gActor(0) AS ActorType
DIM SHARED gSlope(cCellWidth * cNumSlopes - 1) AS INTEGER

DIM SHARED gMapData(cMaxCells - 1) AS INTEGER
DIM SHARED gMapWidth               AS INTEGER
DIM SHARED gMapHeight              AS INTEGER

main

' Cells are 16x16 and mode 13 is 320x200. This means we can
' have a one-screen map of 20 columns by 12 rows.
DATA 20, 12

' This is our world data. We got a whole set of blocks: solid,
' non-solid, and several slopes (indices 2 to 7.)
DATA "11000000000000000011"
DATA "11000000000000000011"
DATA "11000000000051167011"
DATA "10000000000011111011"
DATA "11120000000000000011"
DATA "11112003411200000011"
DATA "11111111111110000011"
DATA "10000001100000001111"
DATA "10000001100000051111"
DATA "11167000000000511111"
DATA "11111670000005111111"
DATA "11111111888811111111"

' Slope 0, going down (1 step right = 1 unit down)
' Slope 1 & 2, going down (2 steps right = 1 unit down)
' Slope 3 & 4, going up (2 steps right = 1 unit up)
' Slope 5, going up (1 step right = 1 unit up)
' Slope 6, irregular floor
DATA 15,14,13,12,11,10,09,08,07,06,05,04,03,02,01,00
DATA 15,15,14,14,13,13,12,12,11,11,10,10,09,09,08,08
DATA 07,07,06,06,05,05,04,04,03,03,02,02,01,01,00,00
DATA 00,00,01,01,02,02,03,03,04,04,05,05,06,06,07,07
DATA 08,08,09,09,10,10,11,11,12,12,13,13,14,14,15,15
DATA 00,01,02,03,04,05,06,07,08,09,10,11,12,13,14,15
DATA 15,15,14,14,14,14,13,13,13,13,14,14,14,14,15,15

''
'' Display the actor on screen.
''
SUB actorDraw (iSlot AS INTEGER)
	DIM uActor AS ActorType
	DIM iX AS INTEGER, iY AS INTEGER
	DIM iW AS INTEGER, iH AS INTEGER

	' Shorthand
	uActor = gActor(iSlot)

	iX = INT(uActor.fX) - uActor.iBBoxW
	iY = INT(uActor.fY) - uActor.iBBoxH + 1
	iW = 1 + uActor.iBBoxW * 2
	iH = uActor.iBBoxH

	' Draw actor in current location, draw its origin point.
	LINE (iX, iY)-STEP(iW - 1, iH - 1), 4, B
	PSET (INT(uActor.fX), INT(uActor.fY)), 15
END SUB

''
'' Adjust the actor's coordinates using its horizontal and
'' vertical velocity (fVelX, fVelY.) Test for collisions against
'' vertical edges first (left/right moves) and then against
'' horizontal edges (up/down moves.)
''
SUB actorMove (iActor AS INTEGER)
	DIM fIdealX AS SINGLE, fIdealY AS SINGLE, iAdr AS INTEGER
	DIM iCol AS INTEGER, iColLf AS INTEGER, iColRt AS INTEGER
	DIM iRow AS INTEGER, iRowUp AS INTEGER, iRowDn AS INTEGER
	DIM iRelX AS INTEGER, iCelX AS INTEGER, iCelY AS INTEGER
	DIM iFeetFlags AS INTEGER, iClipTo AS INTEGER
	DIM iBBoxLf AS INTEGER, iBBoxUp AS INTEGER
	DIM iBBoxRt AS INTEGER, iBBoxDn AS INTEGER

	' If the vertical velocity of the actor is not Null, it is
	' either jumping or falling, which means it cannot be on the
	' ground.
	IF (gActor(iActor).fVelY) THEN
		gActor(iActor).iFlags = gActor(iActor).iFlags AND NOT cActorOnGround
	END IF

	' The actor is on the ground. Check left or right collisions,
	' slope elevation, feet position.
	IF (gActor(iActor).iFlags AND cActorOnGround) THEN

		' When on ground, the actor can only move left or right. If
		' the horizontal velocity is null, then there's nothing else
		' to check.
		IF (gActor(iActor).fVelX = 0) THEN
			EXIT SUB
		END IF

		' Compute the bounding box at the target coordinates.
		fIdealX = gActor(iActor).fX + gActor(iActor).fVelX
		fIdealY = gActor(iActor).fY
		GOSUB actorMoveBBox

		' Not the same as airbound physics: since the actor's origin
		' (iBBoxDn) is inside a solid block or slope, and we know we
		' never want to check that row when walking, we just compute
		' using iBBoxDn (without the minus 4) and then discard the
		' block. actorMoveWallCheck will pick the proper column
		' according to the velocity and bounding box coordinates.
		iRowUp = (iBBoxUp + 4) \ cCellHeight
		iRowDn = (iBBoxDn \ cCellHeight) - 1
		GOSUB actorMoveWallCheck

		' Update X coordinate. actorMoveWallCheck may have updated
		' fIdealX if it caught a collision.
		gActor(iActor).fX = fIdealX

		' Nothing is blocking the actor on either side and the
		' horizontal coordinate has been updated. This means we may
		' have to follow the shape of the floor and update feet
		' status, just in case the actor walked off a ledge.

		' Compute the bounding box with the updated coordinates.
		GOSUB actorMoveBBox

		' Test for slopes first and foremost. This is going to get
		' messy. First we check the tile one unit above the origin
		' point and see if it's a slope (going up a slope.) If it
		' isn't, we check the tile one unit below the origin and see
		' if it is a slope. There's a catch however: the tile below
		' may be a solid block if we are leaving a downward hill. If
		' the vertical coordinate is not adjusted when leaving the
		' hill, then the actor will hover one unit above the floor!
		iRow = (iBBoxDn - 1) \ cCellHeight
		iAdr = iRow * gMapWidth + (fIdealX \ cCellWidth)
		IF ((gBlock(gMapData(iAdr)).iFlags AND cBlockIsSlope) = 0) THEN
			iRow = (iBBoxDn + 1) \ cCellHeight
			iAdr = iRow * gMapWidth + (fIdealX \ cCellWidth)
		END IF

		' If the actor is walking on a slope, we have to adjust its
		' vertical coordinate, and we don't care where its feet are
		' at all.
		IF (gBlock(gMapData(iAdr)).iFlags AND cBlockIsSlope) THEN

			' Get the left and bottom coordinates of the slope cell.
			iCelX = (iAdr MOD gMapWidth) * cCellWidth
			iCelY = (iAdr \ gMapWidth) * cCellHeight + (cCellHeight - 1)

			' Get the horizontal location of the actor, relative to
			' the left edge of the tile.
			iRelX = fIdealX - iCelX

			' Get the floor elevation.
			fIdealY = iCelY - gSlope(gBlock(gMapData(iAdr)).iShape * cCellWidth + iRelX)

		' The actor is not on a slope, check both feet.
		ELSE
			fIdealY = (iAdr \ gMapWidth) * cCellHeight
			GOSUB actorMoveFeet
			gActor(iActor).iFlags = (gActor(iActor).iFlags AND NOT cActorOnGround) OR iFeetFlags
		END IF

		' Set the actor's vertical location.
		gActor(iActor).fY = fIdealY

	' The actor is in the air. Check left or right collisions,
	' head bonk or landing.
	ELSE

		' Test collisions against vertical edges (left or right
		' walls) first.
		IF (gActor(iActor).fVelX) THEN

			' Compute the bounding box at the target coordinates.
			fIdealX = gActor(iActor).fX + gActor(iActor).fVelX
			fIdealY = gActor(iActor).fY
			GOSUB actorMoveBBox

			' The bounding box is made slightly shorter to be more
			' forgiving with tight jumps. actorMoveWallCheck will
			' select the proper column to check according to the
			' velocity and bounding box coordinates. If the actor's
			' origin is in a slope block, we must discard one tile.
			' Not doing so could trigger unintended collisions when
			' landing on (or jumping off) slopes.
			iRowUp = (iBBoxUp + 4) \ cCellHeight
			iRow = iBBoxDn \ cCellHeight
			iAdr = iRow * gMapWidth + (fIdealX \ cCellWidth)
			IF (gBlock(gMapData(iAdr)).iFlags AND cBlockIsSlope) THEN
				iRowDn = iRow - 1
			ELSE
				iRowDn = (iBBoxDn - 4) \ cCellHeight
			END IF
			GOSUB actorMoveWallCheck

			' Update X coordinate. actorMoveWallCheck may have updated
			' fIdealX if it caught a collision.
			gActor(iActor).fX = fIdealX
		END IF

		' Test collisions against horizontal edges (ceiling and
		' floor,) catch possible slope landing.
		IF (gActor(iActor).fVelY) THEN

			' Compute the would-be target coordinates and bounding box.
			fIdealX = gActor(iActor).fX
			fIdealY = gActor(iActor).fY + gActor(iActor).fVelY
			GOSUB actorMoveBBox

			' If the actor is going up, check head bump.
			IF (0 > gActor(iActor).fVelY) THEN
				iRow = iBBoxUp \ cCellHeight

				' We cannot use the full width of the bounding box as
				' the actor would get stuck at the horizontal seams of
				' solid cells that make up the walls.
				iColLf = (iBBoxLf + 1) \ cCellWidth
				iColRt = (iBBoxRt - 1) \ cCellWidth
				iAdr = iRow * gMapWidth

				' Test ceiling collision. If we got a collision, adjust
				' the ideal Y coordinate, cancel velocity and exit the
				' loop.
				FOR iCol = iColLf TO iColRt
					IF (gBlock(gMapData(iAdr + iCol)).iFlags AND cBlockIsSolid) THEN
						fIdealY = ((iRow + 1) * cCellHeight) - 1 + (gActor(iActor).iBBoxH - 1)
						gActor(iActor).fVelY = 0
						EXIT FOR
					END IF
				NEXT iCol

			' The actor is falling, test slopes and floor (in that
			' order.)
			ELSE

				' Feet are located on the same tile row.
				iRow = (iBBoxDn \ cCellHeight)

				' Slopes have the priority.
				iAdr = iRow * gMapWidth + (gActor(iActor).fX \ cCellWidth)
				IF (gBlock(gMapData(iAdr)).iFlags AND cBlockIsSlope) THEN

					' Get the left and bottom coordinates of the slope cell.
					iCelX = (iAdr MOD gMapWidth) * cCellWidth
					iCelY = (iAdr \ gMapWidth) * cCellHeight + (cCellHeight - 1)

					' Get the horizontal location of the actor, relative to
					' the left edge of the tile.
					iRelX = fIdealX - iCelX

					' Get the floor elevation.
					iRelY = iCelY - gSlope(gBlock(gMapData(iAdr)).iShape * cCellWidth + iRelX)

					' If the actor's origin is below the floor level, adjust
					' the ideal Y coordinate.
					IF (gActor(iActor).fY >= iRelY) THEN
						fIdealY = iRelY
						gActor(iActor).iFlags = gActor(iActor).iFlags OR cActorOnGround
						gActor(iActor).fVelY = 0
					END IF

				' The actor is not landing on a slope, it may be landing
				' on a solid block. If either foot is on a solid block,
				' clear vertical velocity, adjust the actor's vertical
				' location, and update feet flags (if we made it this
				' far, both flags are currently clear.)
				ELSE
					GOSUB actorMoveFeet
					IF (iFeetFlags AND cActorOnGround) THEN
						fIdealY = (iRow * cCellHeight)
						gActor(iActor).iFlags = gActor(iActor).iFlags OR iFeetFlags
						gActor(iActor).fVelY = 0
					END IF
				END IF
			END IF

			' Update Y coordinate.
			gActor(iActor).fY = fIdealY
		END IF

	END IF

	EXIT SUB

'' Test right/left walls collision. If we got a collision,
'' adjust the ideal X coordinate, cancel velocity and exit the
'' loop. This snippet takes iRowUp and iRowDn (the first and
'' last to check,) as well as the absolute coordinates of the
'' bounding box.
actorMoveWallCheck:
	IF (0 < gActor(iActor).fVelX) THEN
		iCol = iBBoxRt \ cCellWidth
		iClipTo = (iCol * cCellWidth) - gActor(iActor).iBBoxW
	ELSE
		iCol = iBBoxLf \ cCellWidth
		iClipTo = ((iCol + 1) * cCellWidth) - 1 + gActor(iActor).iBBoxW
	END IF
	FOR iRow = iRowUp TO iRowDn
		IF (gBlock(gMapData(iCol + iRow * gMapWidth)).iFlags AND cBlockIsSolid) THEN
			fIdealX = iClipTo
			gActor(iActor).fVelX = 0
			RETURN
		END IF
	NEXT iRow
	RETURN

'' Compute the bounding box using the ideal X and Y coordinates,
'' sets iBBoxLf (left edge,) iBBoxRt (right edge,) iBBoxUp (top
'' edge,) and iBBoxDn (bottom edge) of the bounding box.
actorMoveBBox:
	iBBoxLf = fIdealX - gActor(iActor).iBBoxW
	iBBoxRt = fIdealX + gActor(iActor).iBBoxW
	iBBoxUp = fIdealY - (gActor(iActor).iBBoxH - 1)
	iBBoxDn = fIdealY
	RETURN

'' Test the location of both feet and sets iFeetFlags. This is
'' used to determine if the actor is walking toward a ledge, or
'' landing on a solid block.
actorMoveFeet:
	iFeetFlags = 0
	iAdr = iRow * gMapWidth + ((iBBoxLf + 1) \ cCellWidth)
	IF (gBlock(gMapData(iAdr)).iFlags AND cBlockIsSolid) THEN
		iFeetFlags = iFeetFlags OR cActorOnGroundLeft
	END IF
	iAdr = iRow * gMapWidth + ((iBBoxRt - 1) \ cCellWidth)
	IF (gBlock(gMapData(iAdr)).iFlags AND cBlockIsSolid) THEN
		iFeetFlags = iFeetFlags OR cActorOnGroundRight
	END IF
	RETURN
END SUB

''
'' Catch keyboard input via INKEY$, return an INTEGER.
''
FUNCTION getInput%
	DIM sTemp AS STRING, iSize AS INTEGER

	sTemp = INKEY$
	iSize = LEN(sTemp)

	IF (iSize = 1) THEN
		getInput% = ASC(sTemp)
	ELSEIF (iSize = 2) THEN
		getInput% = CVI(sTemp)
	END IF
END FUNCTION

''
'' Main routine. Use the arrow keys to move around, and escape
'' to terminate the program. The trickier part is probably the
'' timestepping; long story short: we measure the time elapsed
'' since last game update. For every 0.01 second, we update the
'' game to catch up and reduce the "temporal debt" by 0.01. It's
'' not very useful right now but it will become necessary when
'' we tackle smooth movement.
''
SUB main
	CONST cKeyUp = &H4800
	CONST cKeyDn = &H5000
	CONST cKeyLf = &H4B00
	CONST cKeyRt = &H4D00
	CONST cKeyEsc = &H1B

	' For timestepping...
	DIM fCurrent AS SINGLE, fPrevious AS SINGLE
	DIM fElapsed AS SINGLE, fLag AS SINGLE

	' For clearing the screen
	DIM iBackX AS INTEGER, iBackY AS INTEGER
	DIM iBackW AS INTEGER, iBackH AS INTEGER
	DIM iBackTmpX AS INTEGER, iBackTmpY AS INTEGER
	DIM iBackImg(511) AS INTEGER

	' User input, temporary target cell address.
	DIM iUser AS INTEGER, iAdr AS INTEGER

	' Setup block types.
	gBlock(0).iColor = 0
	gBlock(0).iFlags = 0

	gBlock(1).iColor = 3
	gBlock(1).iFlags = cBlockIsSolid

	gBlock(2).iColor = 2  ' dark green
	gBlock(2).iFlags = cBlockIsSlope
	gBlock(2).iShape = 0

	gBlock(3).iColor = 5  ' dark purple
	gBlock(3).iFlags = cBlockIsSlope
	gBlock(3).iShape = 3

	gBlock(4).iColor = 13 ' bright pink
	gBlock(4).iFlags = cBlockIsSlope
	gBlock(4).iShape = 4

	gBlock(5).iColor = 10 ' light green
	gBlock(5).iFlags = cBlockIsSlope
	gBlock(5).iShape = 5

	gBlock(6).iColor = 1  ' dark blue
	gBlock(6).iFlags = cBlockIsSlope
	gBlock(6).iShape = 1

	gBlock(7).iColor = 9  ' light blue
	gBlock(7).iFlags = cBlockIsSlope
	gBlock(7).iShape = 2

	gBlock(8).iColor = 6
	gBlock(8).iFlags = cBlockIsSlope
	gBlock(8).iShape = 6

	' Load map data
	mapFromData

	' Load slope data
	slopeFromData

	' Set actor's current location and bounding box
	gActor(0).fX = 64
	gActor(0).fY = 48
	gActor(0).iBBoxW = 7
	gActor(0).iBBoxH = 18

	SCREEN 13
	mapDraw

	' Redraw actor (copy background)
	iBackX = INT(gActor(0).fX) - gActor(0).iBBoxW
	iBackY = INT(gActor(0).fY) - gActor(0).iBBoxH
	iBackW = 1 + gActor(0).iBBoxW * 2
	iBackH = gActor(0).iBBoxH
	GET (iBackX, iBackY)-STEP(iBackW, iBackH), iBackImg
	actorDraw 0

	fPrevious = TIMER
	DO
		' Update timer
		fCurrent = TIMER
		fElapsed = fCurrent - fPrevious
		fLag = fLag + fElapsed
		fPrevious = fCurrent

		' Process game logic until we're caught up.
		WHILE (fLag > .01)

			' Catch user input.
			iUser = getInput%
			IF (iUser) THEN

				SELECT CASE (iUser)
				CASE cKeyUp
					' The actor is only allowed to jump when it's on the
					' ground.
					IF (gActor(0).iFlags AND cActorOnGround) THEN
						gActor(0).fVelY = -1.2
					END IF
				CASE cKeyRt
					' Make "walking" a toggle to allow the keyboard buffer
					' to breath (choking happens when the keyboard buffer
					' is filled with too many inputs and we don't have the
					' time to process them all - it happens on genuine
					' hardware but not in DOSBox.) Same logic for cKeyLf.
					IF (gActor(0).fVelX) THEN
						gActor(0).fVelX = 0
					ELSE
						gActor(0).fVelX = .5
					END IF
				CASE cKeyLf
					IF (gActor(0).fVelX) THEN
						gActor(0).fVelX = 0
					ELSE
						gActor(0).fVelX = -.5
					END IF
				CASE cKeyEsc
					EXIT SUB
				END SELECT
			END IF

			' If the actor is not on the ground, apply gravity.
			IF ((gActor(0).iFlags AND cActorOnGround) = 0) THEN
				gActor(0).fVelY = gActor(0).fVelY + .02
			END IF

			' Process actor's physics.
			actorMove 0

			' One game tick is 0.01 second.
			fLag = fLag - .01
		WEND

		' Redraw actor (erase background as necessary)
		iBackTmpX = INT(gActor(0).fX) - gActor(0).iBBoxW
		iBackTmpY = INT(gActor(0).fY) - gActor(0).iBBoxH
		IF (iBackX <> iBackTmpX) OR (iBackY <> iBackTmpY) THEN
			PUT (iBackX, iBackY), iBackImg, PSET
			iBackX = iBackTmpX
			iBackY = iBackTmpY
			GET (iBackX, iBackY)-STEP(iBackW, iBackH), iBackImg
			actorDraw 0
		END IF
	LOOP
END SUB

''
'' Read data off gMapData() and display on-screen. The top-left
'' corner of the map is located at 0, 0 with positive values
'' going right and down.
''
SUB mapDraw
	DIM iR AS INTEGER, iC AS INTEGER
	DIM iX AS INTEGER, iY AS INTEGER
	DIM iRow AS INTEGER, iShape AS INTEGER
	DIM uBlock AS blockType

	' Read map data.
	FOR iR = 0 TO gMapHeight - 1

		' Get the reading offset to the 1st cell of the row.
		iRow = iR * gMapWidth

		' On-screen vertical offset.
		iY = iR * cCellHeight

		FOR iC = 0 TO gMapWidth - 1
			' On-screen horizontal offset.
			iX = iC * cCellWidth

			' Get block type.
			uBlock = gBlock(gMapData(iRow + iC))

			' Solid, fill and cross.
			IF (uBlock.iFlags AND cBlockIsSolid) THEN
				LINE (iX, iY)-STEP(cCellWidth - 1, cCellHeight - 1), uBlock.iColor, BF
				LINE (iX, iY)-STEP(cCellWidth - 1, cCellHeight - 1), 0
				LINE (iX + cCellWidth - 1, iY)-STEP(-(cCellWidth - 1), cCellHeight - 1), 0

			' Slope.
			ELSEIF (uBlock.iFlags AND cBlockIsSlope) THEN
				iShape = uBlock.iShape * cCellWidth
				FOR iAlt = 0 TO cCellWidth - 1
					LINE (iX + iAlt, iY + cCellHeight - 1)-STEP(0, -gSlope(iShape + iAlt)), uBlock.iColor
				NEXT iAlt

			' Non-solid.
			ELSE
				LINE (iX, iY)-STEP(cCellWidth - 1, cCellHeight - 1), uBlock.iColor, BF
			END IF
		NEXT iC

	NEXT iR
END SUB

''
'' Setup the world via DATA statements.
''
SUB mapFromData
	DIM iR AS INTEGER, iC AS INTEGER
	DIM sDta AS STRING, iRow AS INTEGER

	' Read map width and height in cells. If you use custom
	' values, make sure they do not overflow the buffer we
	' allocated for the map data earlier.
	READ gMapWidth, gMapHeight

	' Start reading DATA statements. If you use custom values,
	' make sure there's enough data available to fill the map or
	' this will crash.
	FOR iR = 0 TO gMapHeight - 1

		' Read one row.
		READ sDta

		' Get the writing offset to the 1st cell of the row.
		iRow = iR * gMapWidth

		' Decode each cell and write to gMapData(). If you use
		' custom values, make sure each DATA statement contains the
		' proper number of cells or this may crash.
		FOR iC = 0 TO gMapWidth - 1
			gMapData(iRow + iC) = VAL(MID$(sDta, 1 + iC, 1))
		NEXT iC

	NEXT iR
END SUB

''
'' Setup slope types via DATA statements.
''
SUB slopeFromData
	DIM iSlope AS INTEGER, iFloor AS INTEGER, iIndex AS INTEGER

	' Read the floor offset of each slope.
	FOR iSlope = 0 TO cNumSlopes - 1
		iIndex = iSlope * cCellWidth
		FOR iFloor = 0 TO cCellWidth - 1
			READ gSlope(iIndex + iFloor)
		NEXT iFloor
	NEXT iSlope
END SUB