' Renders 3D text within 3D room.
' User can freely fly around the room and observe the text from different angles.
'
' This program is free software: released under Creative Commons Zero (CC0) license
' by Svjatoslav Agejenko.
' Email: svjatoslav@svjatoslav.eu
' Homepage: http://www.svjatoslav.eu
'
' Changelog:
' 2003, Initial version
' 2024 - 2025, Improved program readability
'
' Keyboard controls:
'   cursor keys and to z, w - rotate
'   <SPACE> - slow down
'   q and <ESC> - quit program
'   + / - - move up / down


DECLARE SUB defineOctagon (x!, y!, z!, size!)
DECLARE SUB printText (x AS SINGLE, y AS SINGLE, text AS STRING)
DECLARE SUB renderCharacter (x AS SINGLE, y AS SINGLE, character AS STRING)
DECLARE SUB readFontData ()
DECLARE SUB defineSquare (x AS SINGLE, y AS SINGLE, z AS SINGLE, size AS SINGLE)
DECLARE SUB defineRectangle (x AS SINGLE, y AS SINGLE, z AS SINGLE, size AS SINGLE)
DECLARE SUB createFloor ()
DECLARE SUB addPoint (x AS INTEGER, y AS INTEGER, z AS INTEGER)
DECLARE SUB initializeProgram ()
DECLARE SUB addSquare (x1 AS INTEGER, y1 AS INTEGER, z1 AS INTEGER)
DECLARE SUB defineCubeAndRectangle ()
DECLARE SUB multiplyCoordinates ()
DECLARE SUB render3DScene ()
DECLARE SUB calculateSineCosine ()

DIM SHARED pointX(4000) AS SINGLE, pointY(4000) AS SINGLE, pointZ(4000) AS SINGLE
DIM SHARED x(4000) AS SINGLE, y(4000) AS SINGLE, z(4000) AS SINGLE
DIM SHARED oldPointX(4000) AS SINGLE, oldPointY(4000) AS SINGLE, oldPointZ(4000) AS SINGLE
DIM SHARED lineStart(4000) AS INTEGER, lineEnd(4000) AS INTEGER
DIM SHARED lineColor(4000) AS INTEGER
DIM SHARED numPoints AS INTEGER, numLines AS INTEGER
DIM SHARED userX AS SINGLE, userY AS SINGLE, userZ AS SINGLE, userSpeed AS SINGLE, userDirection AS SINGLE
DIM SHARED fontPointX(0 TO 10, 0 TO 255) AS SINGLE, fontPointY(0 TO 10, 0 TO 255) AS SINGLE
DIM SHARED fontLineStart(0 TO 10, 0 TO 255) AS INTEGER, fontLineEnd(0 TO 10, 0 TO 255) AS INTEGER

userX = 0
userY = 0
userZ = -100

initializeProgram
render3DScene

SUB createFloor
' Create the floor of the 3D room using hexagons and squares
FOR x = -100 TO 0 STEP 12.067 + .3
    FOR z = -100 TO 0 STEP 12.067 + .3
        defineOctagon x, -125, z, 6.53
        defineRectangle x + 6.033 + .15, -125, z + 6.033 + .15, 3.111 + .3
    NEXT z
NEXT x

' Loop to create squares
FOR y = -100 TO 0 STEP 20.3
    FOR x = -100 TO 0 STEP 20.3
        defineSquare x, y, 200, 10
    NEXT x
NEXT y
END SUB

SUB defineCubeAndRectangle
' Define the corners of a cube
pointX(numPoints + 1) = -150
pointY(numPoints + 1) = -125
pointZ(numPoints + 1) = -200
pointX(numPoints + 2) = 150
pointY(numPoints + 2) = -125
pointZ(numPoints + 2) = -200
pointX(numPoints + 3) = 150
pointY(numPoints + 3) = 125
pointZ(numPoints + 3) = -200
pointX(numPoints + 4) = -150
pointY(numPoints + 4) = 125
pointZ(numPoints + 4) = -200
pointX(numPoints + 5) = -150
pointY(numPoints + 5) = -125
pointZ(numPoints + 5) = 200
pointX(numPoints + 6) = 150
pointY(numPoints + 6) = -125
pointZ(numPoints + 6) = 200
pointX(numPoints + 7) = 150
pointY(numPoints + 7) = 125
pointZ(numPoints + 7) = 200
pointX(numPoints + 8) = -150
pointY(numPoints + 8) = 125
pointZ(numPoints + 8) = 200

' Define the lines connecting the corners
lineStart(numLines + 1) = numPoints + 1
lineEnd(numLines + 1) = numPoints + 2
lineStart(numLines + 2) = numPoints + 2
lineEnd(numLines + 2) = numPoints + 3
lineStart(numLines + 3) = numPoints + 3
lineEnd(numLines + 3) = numPoints + 4
lineStart(numLines + 4) = numPoints + 4
lineEnd(numLines + 4) = numPoints + 1
lineStart(numLines + 5) = numPoints + 5
lineEnd(numLines + 5) = numPoints + 6
lineStart(numLines + 6) = numPoints + 6
lineEnd(numLines + 6) = numPoints + 7
lineStart(numLines + 7) = numPoints + 7
lineEnd(numLines + 7) = numPoints + 8
lineStart(numLines + 8) = numPoints + 8
lineEnd(numLines + 8) = numPoints + 5
lineStart(numLines + 9) = numPoints + 5
lineEnd(numLines + 9) = numPoints + 1
lineStart(numLines + 10) = numPoints + 6
lineEnd(numLines + 10) = numPoints + 2
lineStart(numLines + 11) = numPoints + 7
lineEnd(numLines + 11) = numPoints + 3
lineStart(numLines + 12) = numPoints + 8
lineEnd(numLines + 12) = numPoints + 4

numPoints = numPoints + 8
numLines = numLines + 12

' Define the corners of rectangle
pointX(numPoints + 1) = -150
pointY(numPoints + 1) = -125 + 201
pointZ(numPoints + 1) = 0
pointX(numPoints + 2) = -150
pointY(numPoints + 2) = -125 + 201
pointZ(numPoints + 2) = 89
pointX(numPoints + 3) = -150
pointY(numPoints + 3) = -125
pointZ(numPoints + 3) = 89
pointX(numPoints + 4) = -150
pointY(numPoints + 4) = -125
pointZ(numPoints + 4) = 0

' Define the lines connecting these corners
lineStart(numLines + 1) = numPoints + 1
lineEnd(numLines + 1) = numPoints + 2
lineStart(numLines + 2) = numPoints + 2
lineEnd(numLines + 2) = numPoints + 3
lineStart(numLines + 3) = numPoints + 3
lineEnd(numLines + 3) = numPoints + 4
lineStart(numLines + 4) = numPoints + 4
lineEnd(numLines + 4) = numPoints + 1

numPoints = numPoints + 4
numLines = numLines + 4

printText 0, 0, "three dimensional "
printText 0, -3, "text example"
printText 0, -6, "etc etc etc"
END SUB

SUB defineOctagon (x, y, z, size)
' Initialize variables
b = 0
f = .3925

' Loop to create points of the octagon
FOR a = 0 + f TO 6 + f STEP 6.28 / 8
    x1 = SIN(a) * size
    y1 = COS(a) * size
    b = b + 1
    ' Store the points in the shared arrays
    pointX(numPoints + b) = x1 + x
    pointY(numPoints + b) = y
    pointZ(numPoints + b) = y1 + z
NEXT a

' Define the lines connecting these points
lineStart(numLines + 1) = numPoints + 1
lineEnd(numLines + 1) = numPoints + 2
lineColor(numLines + 1) = 12
lineStart(numLines + 2) = numPoints + 2
lineEnd(numLines + 2) = numPoints + 3
lineColor(numLines + 2) = 12
lineStart(numLines + 3) = numPoints + 3
lineEnd(numLines + 3) = numPoints + 4
lineColor(numLines + 3) = 12
lineStart(numLines + 4) = numPoints + 4
lineEnd(numLines + 4) = numPoints + 5
lineColor(numLines + 4) = 12
lineStart(numLines + 5) = numPoints + 5
lineEnd(numLines + 5) = numPoints + 6
lineColor(numLines + 5) = 12
lineStart(numLines + 6) = numPoints + 6
lineEnd(numLines + 6) = numPoints + 7
lineColor(numLines + 6) = 12
lineStart(numLines + 7) = numPoints + 7
lineEnd(numLines + 7) = numPoints + 8
lineColor(numLines + 7) = 12
lineStart(numLines + 8) = numPoints + 8
lineEnd(numLines + 8) = numPoints + 1
lineColor(numLines + 8) = 12

numPoints = numPoints + b
numLines = numLines + 8
END SUB

SUB defineRectangle (x AS SINGLE, y AS SINGLE, z AS SINGLE, size AS SINGLE)
' Define the corners of the rectangle
pointX(numPoints + 1) = x
pointY(numPoints + 1) = y
pointZ(numPoints + 1) = z + size
pointX(numPoints + 2) = x + size
pointY(numPoints + 2) = y
pointZ(numPoints + 2) = z
pointX(numPoints + 3) = x
pointY(numPoints + 3) = y
pointZ(numPoints + 3) = z - size
pointX(numPoints + 4) = x - size
pointY(numPoints + 4) = y
pointZ(numPoints + 4) = z

' Define the lines connecting these corners
lineStart(numLines + 1) = numPoints + 1
lineEnd(numLines + 1) = numPoints + 2
lineColor(numLines + 1) = 10
lineStart(numLines + 2) = numPoints + 2
lineEnd(numLines + 2) = numPoints + 3
lineColor(numLines + 2) = 10
lineStart(numLines + 3) = numPoints + 3
lineEnd(numLines + 3) = numPoints + 4
lineColor(numLines + 3) = 10
lineStart(numLines + 4) = numPoints + 4
lineEnd(numLines + 4) = numPoints + 1
lineColor(numLines + 4) = 10

' Update the counters
numPoints = numPoints + 4
numLines = numLines + 4
END SUB

SUB defineSquare (x AS SINGLE, y AS SINGLE, z AS SINGLE, size AS SINGLE)
' Define the corners of the square
pointX(numPoints + 1) = x - size
pointY(numPoints + 1) = y - size
pointZ(numPoints + 1) = z
pointX(numPoints + 2) = x + size
pointY(numPoints + 2) = y - size
pointZ(numPoints + 2) = z
pointX(numPoints + 3) = x + size
pointY(numPoints + 3) = y + size
pointZ(numPoints + 3) = z
pointX(numPoints + 4) = x - size
pointY(numPoints + 4) = y + size
pointZ(numPoints + 4) = z

' Define the lines connecting these corners
lineStart(numLines + 1) = numPoints + 1
lineEnd(numLines + 1) = numPoints + 2
lineColor(numLines + 1) = 14
lineStart(numLines + 2) = numPoints + 2
lineEnd(numLines + 2) = numPoints + 3
lineColor(numLines + 2) = 14
lineStart(numLines + 3) = numPoints + 3
lineEnd(numLines + 3) = numPoints + 4
lineColor(numLines + 3) = 14
lineStart(numLines + 4) = numPoints + 4
lineEnd(numLines + 4) = numPoints + 1
lineColor(numLines + 4) = 14

' Update the counters
numPoints = numPoints + 4
numLines = numLines + 4
END SUB

SUB initializeProgram
' Initialize the screen and clear it
SCREEN 12
CLS

' Set the default color for all points
FOR a = 1 TO 4000
    lineColor(a) = 15
NEXT a

' Initialize counters
numPoints = 0
numLines = 0

' Initialize font data
FOR a = 0 TO 255
    FOR b = 0 TO 10
        fontPointX(b, a) = 999
        fontPointY(b, a) = 999
        fontLineStart(b, a) = 999
        fontLineEnd(b, a) = 999
    NEXT b
NEXT a

' Read the font data
readFontData

' Define the corners of the cubes
defineCubeAndRectangle
END SUB

SUB printText (x AS SINGLE, y AS SINGLE, text AS STRING)
' Loop to print each character
FOR b = 1 TO LEN(text)
    c$ = RIGHT$(LEFT$(text, b), 1)
    renderCharacter x + b * 3, y, c$
NEXT b
END SUB

SUB readFontData
' Open the font file
OPEN "font.dat" FOR INPUT AS #1

' Loop to read the font data
3
IF EOF(1) <> 0 THEN GOTO 2
LINE INPUT #1, a$

IF LEFT$(a$, 1) = "#" THEN
  chr = ASC(RIGHT$(LEFT$(a$, 3), 1))
  ' Initialize counters
  pp = 0
  lp = 0
END IF

' Read the points for the character
IF LEFT$(a$, 1) = "p" THEN
    fontPointX(pp, chr) = VAL(RIGHT$(LEFT$(a$, 3), 1))
    fontPointY(pp, chr) = VAL(RIGHT$(LEFT$(a$, 5), 1))
    pp = pp + 1
END IF

' Read the lines for the character
IF LEFT$(a$, 1) = "l" THEN
    fontLineStart(lp, chr) = VAL(RIGHT$(LEFT$(a$, 3), 1))
    fontLineEnd(lp, chr) = VAL(RIGHT$(LEFT$(a$, 5), 1))
    lp = lp + 1
END IF

GOTO 3

' Close the font file
2
CLOSE #1
END SUB

SUB render3DScene
' Main loop for the 3D rendering
1
SOUND 0, .5

userX = userX + SIN(rotationAngleX) * userSpeed
userZ = userZ + COS(rotationAngleX) * userSpeed
userX = userX + COS(rotationAngleX) * userDirection
userZ = userZ - SIN(rotationAngleX) * userDirection
rotationAngleX = rotationAngleX + angleIncrementX
rotationAngleY = rotationAngleY + angleIncrementY
cosAngleX = COS(rotationAngleX): sinAngleX = SIN(rotationAngleX)
cosAngleY = COS(rotationAngleY): sinAngleY = SIN(rotationAngleY)

' Transform the coordinates
FOR a = 1 TO numPoints
    oldPointX(a) = pointX(a) - userX
    oldPointY(a) = -pointY(a) - userY
    oldPointZ(a) = pointZ(a) - userZ
    x1 = (oldPointX(a) * cosAngleX - oldPointZ(a) * sinAngleX)
    z1 = (oldPointX(a) * sinAngleX + oldPointZ(a) * cosAngleX)
    y1 = (oldPointY(a) * cosAngleY - z1 * sinAngleY)
    z2 = (oldPointY(a) * sinAngleY + z1 * cosAngleY)

    ' Store the transformed coordinates
    oldPointX(a) = x(a)
    oldPointY(a) = y(a)

    ' Check if the point is within the view
    IF z2 < 20 THEN
        x(a) = -1
    ELSE
        ' Apply perspective transformation
        x(a) = 320 + (x1 / z2 * 500)
        y(a) = 240 + (y1 / z2 * 500)
    END IF
NEXT

' Draw the lines
FOR a = 1 TO numLines
    p1 = lineStart(a)
    p2 = lineEnd(a)

    ' Check if the points are within the view
    IF oldPointX(p1) = -1 OR oldPointX(p2) = -1 THEN
        ' Do nothing
    ELSE
        ' Erase line at old coordinates
        LINE (oldPointX(p1), oldPointY(p1))-(oldPointX(p2), oldPointY(p2)), 0
    END IF

    IF x(p1) = -1 OR x(p2) = -1 THEN
        ' Do nothing
    ELSE
        ' Draw line at new coordinates
        LINE (x(p1), y(p1))-(x(p2), y(p2)), lineColor(a)
    END IF
NEXT

' Handle user input
userInput$ = INKEY$

IF userInput$ <> "" THEN
    SELECT CASE userInput$
        CASE CHR$(0) + "P"
            userSpeed = userSpeed - 1
        CASE CHR$(0) + "H"
            userSpeed = userSpeed + 1
        CASE CHR$(0) + "M"
            userDirection = userDirection + 1
        CASE CHR$(0) + "K"
            userDirection = userDirection - 1
        CASE "+"
            userY = userY + 3
        CASE "-"
            userY = userY - 3
        CASE "6"
            angleIncrementX = angleIncrementX + .01
        CASE "4"
            angleIncrementX = angleIncrementX - .01
        CASE "8"
            angleIncrementY = angleIncrementY - .01
        CASE "2"
            angleIncrementY = angleIncrementY + .01
        CASE " "
            angleIncrementX = angleIncrementX / 2
            angleIncrementY = angleIncrementY / 2
            angleIncrementZ = angleIncrementZ / 2
            userSpeed = userSpeed / 2
            userDirection = userDirection / 2
        CASE "q"
            SYSTEM
        CASE CHR$(27)
            SYSTEM
    END SELECT
END IF

GOTO 1
END SUB

SUB renderCharacter (x AS SINGLE, y AS SINGLE, character AS STRING)
' Initialize variables
b = ASC(character)
up = 0
ul = 0

' Loop to create points for the character
FOR c = 0 TO 100
    IF fontPointX(c, b) = 999 THEN GOTO 4
    up = up + 1
    pointX(numPoints + up) = x + fontPointX(c, b)
    pointY(numPoints + up) = y - fontPointY(c, b)
    pointZ(numPoints + up) = 0
NEXT c

4
' Loop to define the lines for the character
FOR c = 0 TO 100
    IF fontLineStart(c, b) = 999 THEN GOTO 5
    ul = ul + 1
    lineStart(numLines + ul) = fontLineStart(c, b) + numPoints + 1
    lineEnd(numLines + ul) = fontLineEnd(c, b) + numPoints + 1
    lineColor(numLines + ul) = 4
NEXT c

5
' Update the counters
numPoints = numPoints + up
numLines = numLines + ul
END SUB