qbasic cool raycaster

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' mvandijk303@gmail.com
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


DECLARE SUB Throw (msg$)
DECLARE SUB SystemInit ()
DECLARE SUB SystemCleanup ()
DECLARE FUNCTION SoundLoad% (filename$)
DECLARE SUB WorldRenderWalls ()
DECLARE SUB WorldRenderSprites ()
DECLARE SUB PaletteLoad (filename$)
DECLARE SUB WorldInit ()
DECLARE SUB InputApply ()
DECLARE SUB VideoSwap ()
DECLARE SUB WorldRender ()
DECLARE SUB WorldLoad (filename$)
DECLARE SUB ASMinitCompiler ()
DECLARE SUB ASMcompile (SOURCE$, target$)
DECLARE FUNCTION ASMload$ (filename$)


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Include library headers and do some system configuring.
' This includes optimizing QB45's float operations.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'$INCLUDE: 'DirectQB.bi'
'$INCLUDE: 'ffix.bi'
DEFINT A-Z
ffix
DQBfpu



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Declare global variables.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'
' World
'
DIM SHARED gWorldWidth%
DIM SHARED gWorldHeight%
DIM SHARED gWorld%(255, 255)
DIM SHARED gWorldSeg%
DIM SHARED gWorldOff%

'
' Camera
'
DIM SHARED gPosX#
DIM SHARED gPosY#
DIM SHARED gDirX#
DIM SHARED gDirY#
DIM SHARED gPlaneX#
DIM SHARED gPlaneY#
gPosX# = 15
gPosY# = 15
gDirX# = -1
gDirY# = 0
gPlaneX# = 0
gPlaneY# = .66

'
' Renderer
'
DIM SHARED gPerpDists!(319)
DIM SHARED gCameraXTable#(319)
FOR i% = 0 TO 319 STEP 4
        gCameraXTable#(i%) = 2 * i% / 320 - 1
NEXT

'
' Audio
'
DIM SHARED gSoundFreq%
DIM SHARED gSoundChannels%
DIM SHARED gSoundNum%
DIM SHARED gSoundSlot%
gSoundFreq% = 9035
gSoundChannels% = 4
gSoundNum% = 4

'
' System
'
DIM SHARED gMemAlloc&



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Initialize engine.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'
' Load ASM routines
'
DIM SHARED gDrawCol$
DIM SHARED gDrawSpr$
gDrawCol$ = ASMload$("DRAWCOL.BIN")
gDrawSpr$ = ASMload$("DRAWSPR.BIN")

'
' Initialize engine and load world
'
SystemInit
WorldLoad "TEST.UMR"

'
' Load sounds
'
DIM SHARED gSndDrone%
'gSndDrone% = SoundLoad(".\ASSETS\SFX\LSD.WAV")
gSndDrone% = SoundLoad(".\ASSETS\SFX\OM_LOOP.WAV")
DQBplaySound gSndDrone%, 4, 9035, LOOPED



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Enter engine main loop.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
WHILE NOT DQBkey(1)

        '
        ' Render
        '
        WorldRenderWalls
        WorldRenderSprites
        VideoSwap

        '
        ' Logic
        '
        InputApply
WEND



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Stop engine gracefully.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

SystemCleanup

REM $DYNAMIC
SUB ASMcompile (SOURCE$, target$)

SOURCE$ = CHR$(34) + SOURCE$ + CHR$(34)
target$ = CHR$(34) + target$ + CHR$(34)

SHELL "ASM\FASM\FASM.EXE " + SOURCE$ + " " + target$

END SUB

REM $STATIC
SUB ASMinitCompiler
SHELL "ASM\CSDPMI5B\CWSDPMI.EXE"
END SUB

FUNCTION ASMload$ (filename$)

' Open file
DIM n%
n% = FREEFILE
OPEN filename$ FOR BINARY AS n%

' Read bytes
' TODO(perf): read the bytes all at once
DIM code$
FOR i% = 0 TO LOF(n%)
        code$ = code$ + INPUT$(1, n%)
NEXT

' Close file and return
CLOSE n%
ASMload$ = code$
END FUNCTION

REM $DYNAMIC
SUB InputApply

spd# = .025 * 2.5
rot# = .025 * 1.5
' TODO: Perhaps use a SIN and COS tables
cosRot# = COS(rot#)
sinRot# = SIN(rot#)
cosMinRot# = COS(-rot#)
sinMinRot# = SIN(-rot#)


' Walk forward
IF DQBkey(72) THEN
        gPosX# = gPosX# + gDirX# * spd#
        gPosY# = gPosY# + gDirY# * spd#
END IF

' Walk backward
IF DQBkey(80) THEN
        gPosX# = gPosX# - gDirX# * spd#
        gPosY# = gPosY# - gDirY# * spd#
END IF

' Turn right
IF DQBkey(77) THEN
        oldDirX# = gDirX#
        gDirX# = oldDirX# * cosMinRot# - gDirY# * sinMinRot#
        gDirY# = oldDirX# * sinMinRot# + gDirY# * cosMinRot#

        oldPlaneX# = gPlaneX#
        gPlaneX# = oldPlaneX# * cosMinRot# - gPlaneY# * sinMinRot#
        gPlaneY# = oldPlaneX# * sinMinRot# + gPlaneY# * cosMinRot#
END IF

' Turn left
IF DQBkey(75) THEN
        oldDirX# = gDirX#
        gDirX# = oldDirX# * cosRot# - gDirY# * sinRot#
        gDirY# = oldDirX# * sinRot# + gDirY# * cosRot#

        oldPlaneX# = gPlaneX#
        gPlaneX# = oldPlaneX# * cosRot# - gPlaneY# * sinRot#
        gPlaneY# = oldPlaneX# * sinRot# + gPlaneY# * cosRot#
END IF

END SUB

REM $STATIC
SUB PaletteLoad (filename$)
n% = FREEFILE
OPEN filename$ FOR BINARY AS n%
OUT &H3C8, 0
FOR i% = 0 TO 765
        GET n%, , a%
        OUT &H3C9, a%
NEXT
CLOSE n%
END SUB

FUNCTION SoundLoad% (filename$) STATIC

'
' See if DQB has problems loading the sound.
'
status% = DQBloadSound(gSoundSlot% + 1, filename$)
IF status% > 0 THEN
        Throw "Could not load sound '" + filename$ + "': " + DQBerror$ + "."
        EXIT FUNCTION
END IF

'
' Mark the sound slot as used.
'
gSoundSlot% = gSoundSlot% + 1


SoundLoad% = gSoundSlot%
END FUNCTION

SUB SystemCleanup

'
' Cleanup DirectQB
'
DQBremoveKeyboard
DQBremoveSB
DQBclose

'
' Deallocate memory
'
gMemAlloc& = SETMEM(65536)

'
' Prepare screen for normal rendering
'
DQBinitText

END SUB

SUB SystemInit

'
' Allocate extra memory
'
gMemAlloc& = SETMEM(-65536)

'
' Initialize DirectQB and check for errors
'
status% = DQBinit(1, gSoundNum%, 0)
IF status% > 0 THEN
        ERR$ = "DQBinit failed: "
        SELECT CASE status%
        CASE 1: Throw ERR$ + "386 or better CPU not detected."
        CASE 2: Throw ERR$ + "Unable to find an expanded memory manager."
        CASE 3: Throw ERR$ + "Not enough free EMS memory to allocate specified number of layers."
        CASE 4: Throw ERR$ + "Library has already been initialized."
        END SELECT
END IF

'
' Start sound engine
'
status% = DQBinstallSB(TRUE, gSoundChannels%, gSoundFreq%, &H220, AUTO, AUTO)
IF status% > 0 THEN
        ERR$ = "DQBinstallSB failed: "
        SELECT CASE status%
        CASE 1: Throw ERR$ + "No sounds were allocated by DQBinit."
        CASE 2: Throw ERR$ + "Soundcard not found or DSP failed to reset."
        CASE 3: Throw ERR$ + "Old soundcard not supported."
        CASE 4: Throw ERR$ + "Specified DMA channel is not supported."
        CASE 5: Throw ERR$ + "Autodetection failed as the BLASTER variable is not set"
        CASE 6: Throw ERR$ + "High mixing speed not supported."
        CASE 7: Throw ERR$ + "Not enough memory to create the volume table."
        END SELECT
END IF

'
' Prepare screen for rendering
'
DQBinitVGA
PaletteLoad "ORANGE.PAL"

'
' Start keyboard listener
'
DQBinstallKeyboard

'
' Initialize the matrix
'
WorldInit

END SUB

SUB Throw (msg$)

SystemCleanup

SCREEN 13
CLS
COLOR &H7: PRINT "An error occured:"
COLOR &HC: PRINT msg$

SLEEP

END SUB

REM $DYNAMIC
SUB VideoSwap
DQBcopyLayer 1, VIDEO

END SUB

REM $STATIC
SUB WorldInit
gWorldSeg% = VARSEG(gWorld%(0, 0))
gWorldOff% = VARPTR(gWorld%(0, 0))
END SUB

REM $DYNAMIC
SUB WorldLoad (filename$)

' Open file
n& = FREEFILE
OPEN filename$ FOR BINARY AS n&

' Read world width and size
DIM v AS STRING * 1
GET n&, , v$
gWorldWidth% = ASC(v$)
GET n&, , v$
gWorldHeight% = ASC(v$)

' Read tiles
FOR y% = 0 TO gWorldHeight% - 1
FOR x% = 0 TO gWorldWidth% - 1
        GET n&, , v$
        gWorld%(x%, y%) = ASC(v$)
NEXT
NEXT

' Close file
CLOSE n&

END SUB

REM $STATIC
SUB WorldRenderSprites
DEF SEG = VARSEG(gDrawSpr$)



DEF SEG
END SUB

SUB WorldRenderWalls
DEF SEG = VARSEG(gDrawCol$)

' Length of ray from current position to next X or Y-side
DIM sideDistX#
DIM sideDistY#

' Perpendicular distance to wall
DIM perpDist!

' Direction to step in X or Y-direction (either +1 or -1)
DIM stepX%
DIM stepY%

' Whether a wall had been hit and which side (NS or EW)
DIM hit%
DIM side%


'
' Iterate through every other even column of the screen
'
FOR x% = 0 TO 319 STEP 4

        '
        ' Calculate ray position and direction
        '
        cameraX# = gCameraXTable#(x%) ' X-coord in camera space
        rayPosX# = gPosX#
        rayPosY# = gPosY#
        rayDirX# = gDirX# + gPlaneX# * cameraX#
        rayDirY# = gDirY# + gPlaneY# * cameraX#

        '
        ' Determine in which tile the camera is positioned
        '
        mapX% = INT(rayPosX#)
        mapY% = INT(rayPosY#)

        '
        ' Length of ray from one X or Y-side to next X or Y-side
        '
        deltaDistX# = SQR(1 + (rayDirY# * rayDirY#) / (rayDirX# * rayDirX#))
        deltaDistY# = SQR(1 + (rayDirX# * rayDirX#) / (rayDirY# * rayDirY#))

        '
        ' Reset wall hit flag
        '
        hit% = 0

        '
        ' Calculate step and initial sideDist
        '
        IF rayDirX# < 0 THEN
                stepX% = -1
                sideDistX# = (rayPosX# - mapX%) * deltaDistX#
        ELSE
                stepX% = 1
                sideDistX# = (mapX% + 1 - rayPosX#) * deltaDistX#
        END IF
        IF rayDirY# < 0 THEN
                stepY% = -1
                sideDistY# = (rayPosY# - mapY%) * deltaDistY#
        ELSE
                stepY% = 1
                sideDistY# = (mapY% + 1 - rayPosY#) * deltaDistY#
        END IF

        '
        ' Perform DDA
        '
        DO
                ' Jump to next map square either in X-direction,
                ' or in Y-direction
                IF sideDistX# < sideDistY# THEN
                        sideDistX# = sideDistX# + deltaDistX#
                        mapX% = mapX% + stepX%
                        side% = 0
                ELSE
                        sideDistY# = sideDistY# + deltaDistY#
                        mapY% = mapY% + stepY%
                        side% = -1
                END IF

                ' Check if the ray has hit a wall
                IF (gWorld%(mapX%, mapY%) > 0) THEN
                        hit% = 1
                END IF
        LOOP UNTIL hit% = 1

        '
        ' Calculate distance projected on camera direction
        ' (Oblique distance will give a fisheye effect)
        '
        IF side% = 0 THEN
                perpDist! = (mapX% - rayPosX# + (1 - stepX%) / 2) / rayDirX#
        ELSE
                perpDist! = (mapY% - rayPosY# + (1 - stepY%) / 2) / rayDirY#
        END IF

        '
        ' Draw wall column
        '
        CALL ABSOLUTE(BYVAL x%, BYVAL perpDist!, BYVAL side%, SADD(gDrawCol$))

        '
        ' Save column distance
        '
        gPerpDists!(x%) = perpDist!
NEXT
DEF SEG

END SUB