A raycasting 3D engine written in EppaBasic

eppa3d.bas

' Pelaajan sijainti

Dim playerAngle As Number = 0
Dim playerX As Number = 1.5
Dim playerY As Number = 1.5

' Näkökentän koko

Dim FOV = ebPi / 2 ' 90°

' Tasojen tallentaminen

Dim LEVEL_COUNT = 2
Dim currentLevel As Integer

Dim LEVEL_WIDTH = 20
Dim LEVEL_HEIGHT = 20
Dim LEVEL_SIZE = LEVEL_WIDTH * LEVEL_HEIGHT

Dim levelData[LEVEL_COUNT, LEVEL_SIZE] As Integer

Function DataAt(x As Number, y As Number) As Integer
    Dim xi = Min(Max(Floor(x), 0), LEVEL_WIDTH-1)
    Dim yi = Min(Max(Floor(y), 0), LEVEL_HEIGHT-1)
    Return levelData[currentLevel, 1 + xi + LEVEL_WIDTH * yi]
End Function

Function IsWall(x As Number, y As Number) As Boolean
    Return DataAt(x, y) <> 0
End Function

Dim pointer As Integer = 1
Sub AddLevel(id As Integer)
    currentLevel = id
    pointer = 1
End Sub
Sub AddLevelData(data As String)
    For i = 1 To Len(data)
        levelData[currentLevel, pointer] = Val(CharAt(data, i))
        pointer = pointer + 1
    Next i
End Sub

' Entiteetit

Dim ENTITY_COUNT = 10
Dim E_X = 1
Dim E_Y = 2

Dim entityCoordinates[ENTITY_COUNT, 2] As Number
Dim entityTextures[ENTITY_COUNT] As Integer

Function EntityX(id As Integer) As Number
    Return entityCoordinates[id, E_X]
End Function

Function EntityY(id As Integer) As Number
    Return entityCoordinates[id, E_Y]
End Function

Function EntityTexture(id As Integer) As Integer
    Return entityTextures[id]
End Function

Function EntityDistance(id As Integer) As Number
    Dim dx = EntityX(id) - playerX
    Dim dy = EntityY(id) - playerY
    Return Sqrt(dx^2 + dy^2)
End Function

Dim entityPointer As Integer = 1
Sub AddEntity(x As Number, y As Number, t As Integer)
    entityCoordinates[entityPointer, E_X] = x
    entityCoordinates[entityPointer, E_Y] = y
    entityTextures[entityPointer] = t
    entityPointer = entityPointer + 1
End Sub
Sub AddEntities()
    entityPointer = 1
End Sub
Sub NoMoreEntities()
    Do While entityPointer <= ENTITY_COUNT
        AddEntity 0, 0, 0
    Loop
End Sub

' Tasojen data

AddLevel 1
AddLevelData "11111111112323232323"
AddLevelData "10000000010000000001"
AddLevelData "10200030010000000001"
AddLevelData "10300020010000000001"
AddLevelData "10200030010000000001"
AddLevelData "10300020010000000001"
AddLevelData "10200030010000000001"
AddLevelData "10304020010000000001"
AddLevelData "10000000010000000001"
AddLevelData "10000000010000000001"
AddLevelData "10000000010000000001"
AddLevelData "10000000010000000001"
AddLevelData "10000000010000000001"
AddLevelData "10232320010000000001"
AddLevelData "10300030000000000001"
AddLevelData "10300020000000000001"
AddLevelData "10234030010000000001"
AddLevelData "10000000010000000001"
AddLevelData "11111111113232323232"

Sub LoadLevel1()
    currentLevel = 1
    entityPointer = 1
    
    AddEntities
    AddEntity 3, 12, 10
    AddEntity 7, 12, 10
    NoMoreEntities
End Sub

AddLevel 2
AddLevelData "13211111112323232323"
AddLevelData "20020000010000000003"
AddLevelData "30030030010000000002"
AddLevelData "20320020010000000003"
AddLevelData "30200030010000000001"
AddLevelData "20300020010000000002"
AddLevelData "30200030010000000003"
AddLevelData "20300020010000000002"
AddLevelData "30000030010023200231"
AddLevelData "20000020010002000002"
AddLevelData "32323230010001000001"
AddLevelData "10000000010001000001"
AddLevelData "10000000010003000003"
AddLevelData "10232320011323200021"
AddLevelData "10300030000000000003"
AddLevelData "10300020000000000002"
AddLevelData "10234030011000000003"
AddLevelData "10000020010000000002"
AddLevelData "11111111113232323231"

Sub LoadLevel2()
    currentLevel = 2
    entityPointer = 1
    
    AddEntities
    AddEntity 3, 11.5, 10
    AddEntity 7, 12.5, 10
    AddEntity 5, 6, 10
    NoMoreEntities
End Sub

' Tekstuurat

Dim TEXTURE_HEIGHT = 20
Dim TEXTURE_WIDTH = 20

Dim texture[10, TEXTURE_HEIGHT, TEXTURE_WIDTH] As Integer

Dim texturePointer As Integer
Dim textureId As Integer

Sub AddTexture(id As Integer)
    texturePointer = 1
    textureId = id
End Sub

Sub AddTextureRow(data As String)
    For i = 1 To TEXTURE_WIDTH
        texture[textureId, texturePointer, i] = Val(CharAt(data, i))
    Next i
    texturePointer = texturePointer + 1
End Sub

AddTexture 1
AddTextureRow "00000000000000000000"
AddTextureRow "00000000000000000000"
AddTextureRow "00001100000000110000"
AddTextureRow "00011110000001111000"
AddTextureRow "00111111000011111100"
AddTextureRow "00111111100111111100"
AddTextureRow "00111111111111111100"
AddTextureRow "00111111111111111100"
AddTextureRow "00111111111111111100"
AddTextureRow "00111111111111111100"
AddTextureRow "00011111111111111000"
AddTextureRow "00001111111111110000"
AddTextureRow "00001111111111110000"
AddTextureRow "00001111111111110000"
AddTextureRow "00000111111111100000"
AddTextureRow "00000011111111000000"
AddTextureRow "00000001111110000000"
AddTextureRow "00000000111100000000"
AddTextureRow "00000000000000000000"
AddTextureRow "00000000000000000000"

AddTexture 2
AddTextureRow "00000000000000000000"
AddTextureRow "00000000000000000000"
AddTextureRow "11111111000000007777"
AddTextureRow "11111111000000007777"
AddTextureRow "00000011000000007700"
AddTextureRow "00000011000000007700"
AddTextureRow "00000022000000007700"
AddTextureRow "00000022000000007700"
AddTextureRow "00000000000000007700"
AddTextureRow "00000000000000007700"
AddTextureRow "00000000000000007700"
AddTextureRow "07777770000000007700"
AddTextureRow "07223370000000007700"
AddTextureRow "07223370000000007700"
AddTextureRow "77445577777777777700"
AddTextureRow "77445577777777777700"
AddTextureRow "07777770000000000000"
AddTextureRow "00000000000000000000"
AddTextureRow "00000000000000223333"
AddTextureRow "00000000000000223333"

AddTexture 3
AddTextureRow "00000000000000000000"
AddTextureRow "00000000000000000000"
AddTextureRow "77777777000000771111"
AddTextureRow "77777777000000771111"
AddTextureRow "00000077000000000000"
AddTextureRow "00000777700000000000"
AddTextureRow "00000722700000000000"
AddTextureRow "00000722700000000000"
AddTextureRow "00000777700000000000"
AddTextureRow "00000000000007777000"
AddTextureRow "00000000000007447000"
AddTextureRow "00000000000007447000"
AddTextureRow "00000000000007777000"
AddTextureRow "00000000000000770000"
AddTextureRow "00001100000000777777"
AddTextureRow "00001100000000777777"
AddTextureRow "00003300000000000000"
AddTextureRow "00003300000000000000"
AddTextureRow "33333300000000000000"
AddTextureRow "33333300000000000000"

AddTexture 4
AddTextureRow "00000000000000000000"
AddTextureRow "00444044404440444000"
AddTextureRow "00400040404040404000"
AddTextureRow "00444044404440444000"
AddTextureRow "00400040004000404000"
AddTextureRow "00444040004000404000"
AddTextureRow "00000000000000000000"
AddTextureRow "00000000000000000000"
AddTextureRow "00111111002222000000"
AddTextureRow "00011111002222220000"
AddTextureRow "00000011002200222000"
AddTextureRow "00000011002200022200"
AddTextureRow "00000011002200002200"
AddTextureRow "00011111002200002200"
AddTextureRow "00000011002200002200"
AddTextureRow "00000011002200022200"
AddTextureRow "00000011002200222000"
AddTextureRow "00011111002222220000"
AddTextureRow "00111111002222000000"
AddTextureRow "00000000000000000000"

AddTexture 10
AddTextureRow "88888888888888888888"
AddTextureRow "88888884888848888888"
AddTextureRow "88888887888878888888"
AddTextureRow "88888877777777888888"
AddTextureRow "88888872177127888888"
AddTextureRow "88888877777777888888"
AddTextureRow "88888888777788888888"
AddTextureRow "88888888877888888888"
AddTextureRow "88667777777777771188"
AddTextureRow "88667777777777771188"
AddTextureRow "88888777743777788888"
AddTextureRow "88888877443377888888"
AddTextureRow "88888877112277888888"
AddTextureRow "88888877712777888888"
AddTextureRow "88888877777777888888"
AddTextureRow "88888877777777888888"
AddTextureRow "88888877788777888888"
AddTextureRow "88888877888877888888"
AddTextureRow "88888800888800888888"
AddTextureRow "88888880888808888888"

Sub GameLoop()
    Do
        Control
        Render
    Loop
End Sub

Sub Control()
    
    ' Näkökenttä
    If KeyDown(ebKeyF) Then
        FOV = FOV - 0.01
    Else If KeyDown(ebKeyG) Then
        FOV = FOV + 0.01
    End If
    
    ' Suuntaus
    If KeyDown(ebKeyLeft) Then
        playerAngle = playerAngle - 0.05
    Else If KeyDown(ebKeyRight) Then
        playerAngle = playerAngle + 0.05
    End If
    
    ' Liike
    Dim factor As Number = 1
    If KeyDown(ebKeyShift) Then
        factor = 2
    End If
    
    Dim nx As Number = Cos(playerAngle + ebPi/2) / 30 * factor
    Dim ny As Number = Sin(playerAngle + ebPi/2) / 30 * factor
    Dim dx As Number = Cos(playerAngle) / 30 * factor
    Dim dy As Number = Sin(playerAngle) / 30 * factor
    
    Dim newX As Number = playerX
    Dim newY As Number = playerY
    
    If KeyDown(ebKeyA) Then
        newX = newX - nx
        newY = newY - ny
    End If
    If KeyDown(ebKeyD) Then
        newX = newX + nx
        newY = newY + ny
    End If
    If KeyDown(ebKeyUp) Or KeyDown(ebKeyW) Then
        newX = newX + dx
        newY = newY + dy
    End If
    If KeyDown(ebKeyDown) Or KeyDown(ebKeyS) Then
        newX = newX - dx
        newY = newY - dy
    End If
    
    ' Tarkistetaan seinään törmääminen ja päivitetään sijainti
    If Not IsTooNear(newX, newY) Then
        playerX = newX
        playerY = newY
    Else If Not IsTooNear(newX, playerY) Then
        playerX = newX
    Else If Not IsTooNear(playerX, newY) Then
        playerY = newY
    End If
End Sub

Function IsTooNear(px As Number, py As Number) As Boolean
    For dx = -1 To 1
        For dy = -1 To 1
            If IsWall(px+dx/5, py+dy/5) Then
                Return True
            End If
        Next dy
    Next dx
    Return False
End Function

Dim DBG_SIZE = 3
Dim dbg[DBG_SIZE] As String

' Näytön koko

' Näytön koko oikeasti

Dim CANVAS_WIDTH = 1600
Dim CANVAS_HEIGHT = 800

WindowSize CANVAS_WIDTH, CANVAS_HEIGHT
CanvasSize CANVAS_WIDTH, CANVAS_HEIGHT

' Simuloidun näytön koko

Dim SCREEN_WIDTH = 200
Dim SCREEN_HEIGHT = 100

Dim PIXEL_HEIGHT As Integer = Floor(CANVAS_HEIGHT/SCREEN_HEIGHT)
Dim PIXEL_WIDTH As Integer = Floor(CANVAS_WIDTH/SCREEN_WIDTH)

Sub SimDrawLine(column As Integer, y1 As Integer, y2 As Integer)
    FillRect column*PIXEL_WIDTH, y1*PIXEL_HEIGHT, PIXEL_WIDTH, (y2-y1)*PIXEL_HEIGHT
End Sub

' Piirtäminen

Sub Render()
    Dim startTime = Second() + MilliSecond()/1000
    
    ClearScreen
    
    ' Piirrä tausta
    FillColor 150, 150, 150
    FillRect 0, 0, CANVAS_WIDTH, CANVAS_HEIGHT
    
    DrawWalls
    
    ' Piirrä esineet ja oliot
    DrawEntities
    
    Dim fps = 1 / (Second() + MilliSecond()/1000 - startTime)
    
    TextSize 10
    TextAlign 1
    
    DrawText 10, 10, "FPS"
    DrawText 50, 10, Round(fps, 2)
    DrawText 10, 20, "FOV"
    DrawText 50, 20, Round(FOV/2/ebPI*360, 2)
    
    For i = 1 To DBG_SIZE
        DrawText 10, 20+10*i, dbg[i]
    Next i
    
    DrawScreen
End Sub

Dim MAX_DISTANCE = 100
Dim distances[SCREEN_WIDTH] As Number

Dim DISTANCE_ACCURACY = 0.02

Sub DrawWalls()
    For column = 0 To SCREEN_WIDTH-1
        Dim columnAngle = Atan(column/SCREEN_WIDTH - 1/2) * FOV
        
        Dim dx = Cos(playerAngle + columnAngle) * DISTANCE_ACCURACY
        Dim dy = Sin(playerAngle + columnAngle) * DISTANCE_ACCURACY
        
        Dim x = playerX
        Dim y = playerY
        
        Dim distance As Number = 0
        Do While DataAt(x, y) = 0 And distance < MAX_DISTANCE
            x = x + dx
            y = y + dy
            distance = distance + DISTANCE_ACCURACY
        Loop
        distance = distance * Abs(Cos(Sin(columnAngle)))
        
        distances[column+1] = distance
        
        DrawColumn column, x, y, dx, dy, distance
    Next column
End Sub

Sub DrawColumn(column As Integer, x As Number, y As Number, dx As Number, dy As Number, distance As Number)
    Dim textureId = DataAt(x, y)
    
    Dim leftEdge As Number = Floor(x)
    Dim rightEdge As Number = Ceil(x)
    Dim downEdge As Number = Floor(y)
    Dim upEdge As Number = Ceil(y)
    
    Dim leY = dy/dx*(leftEdge-x)+y
    Dim reY = dy/dx*(rightEdge-x)+y
    Dim deX = dx/dy*(downEdge-y)+x
    Dim ueX = dx/dy*(upEdge-y)+x
    
    If dx > 0 And downEdge <= leY And leY < upEdge Then
        DrawColumnTexture textureId, column, distance, leY-downEdge, 0.8
    Else If dx < 0 And downEdge <= reY And reY < upEdge Then
        DrawColumnTexture textureId, column, distance, 1-reY+downEdge, 0.8
    Else If dy > 0 And leftEdge <= deX And deX < rightEdge Then
        DrawColumnTexture textureId, column, distance, 1-deX+leftEdge, 1
    Else If dy < 0 And leftEdge <= ueX And ueX < rightEdge Then
        DrawColumnTexture textureId, column, distance, ueX-leftEdge, 0.7
    Else
        ' Virhe
        DrawColor 255, 0, 0
        SimDrawLine column, 0, SCREEN_HEIGHT
    End If
End sub

Sub DrawColumnTexture(textureId As Integer, column As Integer, distance As Number, pos As Number, light As Number)
    Dim textureColumn As Integer = Ceil(pos*TEXTURE_WIDTH)
    Dim wallHeight As Number = 1/distance * SCREEN_HEIGHT
    Dim blockSize As Number = wallHeight/TEXTURE_HEIGHT
    Dim y As Integer = (SCREEN_HEIGHT-wallHeight)/2
    For i = 1 To TEXTURE_HEIGHT
        Dim ny As Integer = (SCREEN_HEIGHT-wallHeight)/2+i*blockSize
        Dim color As Integer = texture[textureId, i, textureColumn]
        If color = 0 Then
            SetColor light*100, light*100, light*100
        Else If color = 1 Then
            SetColor light*255, light*100, light*100
        Else If color = 2 Then
            SetColor light*100, light*255, light*100
        Else If color = 3 Then
            SetColor light*100, light*100, light*255
        Else If color = 4 Then
            SetColor light*255, light*255, light*100
        Else If color = 5 Then
            SetColor light*255, light*100, light*255
        Else If color = 6 Then
            SetColor light*100, light*255, light*255
        Else If color = 7 Then
            SetColor light*200, light*200, light*200
        End If
        If color <> 8 Then
            SimDrawLine column, y, ny
        End If
        y = ny
    Next i
End Sub

Sub DrawEntities()
    ' Luodaan järjestetty lista entiteeteistä
    Dim sortedEntities[ENTITY_COUNT] As Integer
    For entityId = 1 To ENTITY_COUNT
        sortedEntities[entityId] = entityId
    Next entityId
    For i = 2 To ENTITY_COUNT
        Dim j = i
        Do While j > 1 And EntityDistance(sortedEntities[j-1]) < EntityDistance(sortedEntities[j])
            Dim tmp = sortedEntities[j-1]
            sortedEntities[j-1] = sortedEntities[j]
            sortedEntities[j] = tmp
            j = j - 1
        Loop
    Next i
    
    For i = 1 To ENTITY_COUNT
        Dim entityId = sortedEntities[i]
        
        Dim x = EntityX(entityId)
        Dim y = EntityY(entityId)
        Dim t = EntityTexture(entityId)
        
        Dim dx = x - playerX
        Dim dy = y - playerY
        
        Dim angle = NormalizeAngle(Atan2(dy,dx) - playerAngle)
        Dim distance = Sqrt(dx^2 + dy^2) * Abs(Cos(Sin(angle)))'Max(Min(angle, 1), -1))) ' Rajoitetaan kulma, jotta ei tule vääristymää kun kulma on suuri
        Dim screenX = (Tan(angle / FOV) + 1/2) * SCREEN_WIDTH
        
        DrawEntity t, distance, screenX
    Next i
End Sub

Sub DrawEntity(texture As Integer, distance As Number, screenX As Integer)
    Dim size = 1/distance * SCREEN_HEIGHT
    If screenX > -size/2 And screenX < SCREEN_WIDTH+size/2 Then
        For entityColumn = 1 To size
            Dim pos = entityColumn/size
            Dim column As Integer = screenX+entityColumn-size/2
            If column >= 0 And column < SCREEN_WIDTH Then
                If distances[column+1] > distance Then
                    DrawColumnTexture texture, column, distance, pos, 1
                End If
            End If
        Next entityColumn
    End If
End Sub

' Apufunktiot

Sub SetColor(r As Integer, g As Integer, b As Integer)
    FillColor r, g, b
    DrawColor r, g, b
End Sub

Function CharAt(str As String, index As Integer) As String
    Return Right(Left(str, index), 1)
End Function

Function NormalizeAngle(angle As Number) As Number
    angle = angle Mod (ebPi*2)
    If angle > ebPI Then
        Return angle - 2*ebPi
    Else If angle < -ebPi Then
        Return angle + 2*ebPi
    Else
        Return angle
    End If
End Function

' Päävalikko

Dim MENU_ITEM_COUNT = 3
Dim menuItems[MENU_ITEM_COUNT] As String
menuItems[1] = "Taso 1"
menuItems[2] = "Taso 2"
menuItems[3] = "Poistu"

Dim selectedMenuItem As Integer = 1

Sub MenuLoop()
    Do
        MenuControl
        MenuRender
    Loop
End Sub

Sub MenuControl()
    If KeyDown(ebKeyUp) And selectedMenuItem > 1 Then
        selectedMenuItem = selectedMenuItem - 1
        MenuRender
        Wait 0.2
    Else If KeyDown(ebKeyDown) And selectedMenuItem < MENU_ITEM_COUNT Then
        selectedMenuItem = selectedMenuItem + 1
        MenuRender
        Wait 0.2
    Else If KeyDown(ebKeyEnter) Then
        MenuClick
    End If
End Sub

Sub MenuRender()
    ClearScreen
    
    TextSize 50
    TextAlign 3
    TextFont "Monospace"
    
    Dim y = (CANVAS_HEIGHT - 50*MENU_ITEM_COUNT - 100) / 2
    
    TextColor 100, 100, 255
    DrawText CANVAS_WIDTH/2, y, "EPPA 3D: Robottilinna"
    y = y + 100
    
    For i = 1 To MENU_ITEM_COUNT
        If i = selectedMenuItem Then
            TextColor 255, 0, 0
        Else
            TextColor 255, 255, 255
        End If
        DrawText CANVAS_WIDTH/2, y, menuItems[i]
        y = y + 50
    Next i
    
    DrawScreen
End Sub

Sub MenuClick()
    If selectedMenuItem = 1 Then
        LoadLevel1
        GameLoop
    Else If selectedMenuItem = 2 Then
        LoadLevel2
        GameLoop
    Else If selectedMenuItem = 3 Then
        End()
    End If
End Sub

' Käynnistetään ohjelma

MenuLoop