DECLARE SUB createLongLine (x1!, y1!, z1!, x2!, y2!, z2!, c!)
DECLARE SUB makeGrid (x1!, y1!, z1!, x2!, y2!, z2!)
DECLARE SUB prn (a$, x!, y!, z!)
DECLARE SUB fill4 ()
DECLARE SUB loadObject (name$, x!, y!, z!)
DECLARE SUB putChar (a$, x!, y!, z!)
' 3D engine
' made by Svjatoslav Agejenko
' last edit 2004.1
' E-Mail: svjatoslavagejenko@gmail.com
' H-Page: svjatoslav.eu
 
DECLARE SUB fill3 ()
DECLARE SUB fill1 ()
DECLARE SUB fill2 ()
DECLARE SUB addMsg (a$)
DECLARE SUB dispmsg ()
DECLARE SUB loadArea (tx1!, ty1!, tz1!, tx2!, ty2!, tz2!)
DECLARE SUB loadCluster (x!, y!, z!)
DECLARE SUB checkVisibility ()
DECLARE SUB decVisibility ()
DECLARE SUB applyBounds ()
DECLARE SUB clearWorld ()
DECLARE SUB createNewLine (x1!, y1!, z1!, x2!, y2!, z2!, c!)
DECLARE SUB createWorld ()
DECLARE FUNCTION getClustName$ (a!, b!, c!)
DECLARE FUNCTION toStr$ (a!)

DECLARE SUB insertLine (x1!, y1!, z1!, x2!, y2!, z2!, c!)
DECLARE SUB startext ()
DECLARE SUB control ()
DECLARE SUB putbyte (addr!, dat!)
DECLARE SUB putword (addr!, dat!)
DECLARE FUNCTION getword! (addr!)
DECLARE FUNCTION getbyte! (addr!)
DECLARE SUB start ()
DECLARE SUB render ()


DIM SHARED an1, an2

DIM SHARED extSEG, extADDR
DIM SHARED buttL, buttR
DIM SHARED maxmove

DIM SHARED linAmo
linAmo = 5000

DIM SHARED linX1(0 TO linAmo) AS INTEGER
DIM SHARED linY1(0 TO linAmo) AS INTEGER
DIM SHARED linZ1(0 TO linAmo) AS INTEGER
DIM SHARED linX2(0 TO linAmo) AS INTEGER
DIM SHARED linY2(0 TO linAmo) AS INTEGER
DIM SHARED linZ2(0 TO linAmo) AS INTEGER
DIM SHARED linC(0 TO linAmo) AS INTEGER

DIM SHARED myx, myy, myz
DIM SHARED myxs, myys, myzs

DIM SHARED curFreeLine
DIM SHARED worldSize

DIM SHARED usedLines
DIM SHARED desMaxLines

DIM SHARED visMaxX, visMaxY, visMaxZ
DIM SHARED visMinX, visMinY, visMinZ

DIM SHARED visDist
DIM SHARED msgs$(1 TO 10)
DIM SHARED frm


'DIM SHARED blkData(1 TO 50) AS STRING * 512
'DIM SHARED blkFrag(1 TO 50) AS STRING * 512




nl = 0
np = 0

start


cx = 0
cy = 0
cz = 0

np = 1
px(1) = 0
py(1) = 0
pz(1) = 0

makeGrid -400, -400, -400, 400, 400, 400

1
frm = frm + 1

'fill1
fill2
fill3
fill4


control

render

LOCATE 1, 1
PRINT usedLines, visDist

checkVisibility

PCOPY 0, 1
CLS
GOTO 1

SUB addMsg (a$)

FOR a = 1 TO 9
  msgs$(a) = msgs$(a + 1)
NEXT a

msgs$(10) = a$
END SUB

SUB applyBounds

FOR a = 0 TO linAmo
  IF linC(a) > 0 THEN


    cx = (linX1(a) + linX2(a)) / 2
    cy = (linY1(a) + linY2(a)) / 2
    cz = (linZ1(a) + linZ2(a)) / 2
   
    clx = INT(cx / 100)
    cly = INT(cy / 100)
    clz = INT(cz / 100)

    IF clx > visMaxX THEN GOTO 8
    IF clx < visMinX THEN GOTO 8
   
    IF cly > visMaxY THEN GOTO 8
    IF cly < visMinY THEN GOTO 8

    IF clz > visMaxZ THEN GOTO 8
    IF clz < visMinZ THEN GOTO 8

    GOTO 7
8   linC(a) = -1
    usedLines = usedLines - 1
  END IF
7
NEXT a

END SUB

SUB checkVisibility

'DIM SHARED visMaxX, visMaxY, visMaxZ
'DIM SHARED visMinX, visMinY, visMinZ


mx = INT(myx / 100)
my = INT(myy / 100)
mz = INT(myz / 100)


IF mx + visDist > visMaxX THEN
  newX = mx + visDist
  loadArea visMaxX + 1, visMinY, visMinZ, newX, visMaxY, visMaxZ
  visMaxX = newX
  LOCATE 1, 30
  PRINT "1"
END IF
IF mx - visDist < visMinX THEN
  newX = mx - visDist
  loadArea visMinX - 1, visMinY, visMinZ, newX, visMaxY, visMaxZ
  visMinX = newX
  LOCATE 1, 30
  PRINT "2"
END IF


IF my + visDist > visMaxY THEN
  newY = my + visDist
  loadArea visMinX, visMaxY + 1, visMinZ, visMaxX, newY, visMaxZ
  visMaxY = newY
  LOCATE 1, 30
  PRINT "3"
END IF
IF my - visDist < visMinY THEN
  newY = my - visDist
  loadArea visMinX, visMinY - 1, visMinZ, visMaxX, newY, visMaxZ
  visMinY = newY
  LOCATE 1, 30
  PRINT "4"
END IF


IF mz + visDist > visMaxZ THEN
  newZ = mz + visDist
  loadArea visMinX, visMinY, visMaxZ + 1, visMaxX, visMaxY, newZ
  visMaxZ = newZ
  LOCATE 1, 30
  PRINT "5"
END IF
IF mz - visDist < visMinZ THEN
  newZ = mz - visDist
  loadArea visMinX, visMinY, visMinZ - 1, visMaxX, visMaxY, newZ
  visMinZ = newZ
  LOCATE 1, 30
  PRINT "6"
END IF


IF usedLines > desMaxLines THEN decVisibility

END SUB

SUB clearWorld


CHDIR "world"

FOR x = -worldSize TO worldSize

  n$ = "X" + toStr$(x)
  CHDIR n$

  FOR y = -worldSize TO worldSize

    n2$ = "Y" + toStr$(y)
    CHDIR n2$

    PRINT x, y
    FOR z = -worldSize TO worldSize

      n3$ = "z" + toStr$(z) + ".dat"
      OPEN n3$ FOR OUTPUT AS #1
'      PRINT #1, "0"
      CLOSE #1
    NEXT z

    CHDIR ".."
  NEXT y

  CHDIR ".."
NEXT x

CHDIR ".."

END SUB

SUB control


IF getbyte(8) <> 0 THEN
  putbyte 8, 0
  xp = getword(2)
  putword 2, 0
  yp = getword(4)
  putword 4, 0
  butt = getword(6)
  putword 6, 0
  buttL = 0
  buttR = 0
  IF butt = 1 THEN buttL = 1
  IF butt = 2 THEN buttR = 1
  IF butt = 3 THEN buttL = 1: buttR = 1


  IF buttR = 1 THEN
    IF buttL = 1 THEN
      myxs = myxs + SIN(an1) * yp / 4
      myzs = myzs - COS(an1) * yp / 4
      GOTO 3
    END IF
    myys = myys + yp / 4
3
    yp = 0
  END IF

END IF




IF xp < -maxmove THEN xp = -maxmove
IF xp > maxmove THEN xp = maxmove
an1 = an1 - xp / 150

IF yp < -maxmove THEN yp = -maxmove
IF yp > maxmove THEN yp = maxmove
an2 = an2 - yp / 150



a$ = INKEY$

IF a$ = "a" THEN myxs = myxs - COS(an1): myzs = myzs - SIN(an1)
IF a$ = "d" THEN myxs = myxs + COS(an1): myzs = myzs + SIN(an1)
IF a$ = "w" THEN myxs = myxs - SIN(an1): myzs = myzs + COS(an1)
IF a$ = "s" THEN myxs = myxs + SIN(an1): myzs = myzs - COS(an1)
IF a$ = "q" THEN SYSTEM

myxs = myxs / 1.1
myys = myys / 1.1
myzs = myzs / 1.1

myx = myx + myxs
myz = myz + myzs
myy = myy + myys

END SUB

SUB createLongLine (x1, y1, z1, x2, y2, z2, c)
d = SQR((x1 - x2) ^ 2 + (y1 - y2) ^ 2 + (z1 - z2) ^ 2)

IF d < 100 THEN
  createNewLine x1, y1, z1, x2, y2, z2, c
ELSE
  xp = (x1 + x2) / 2
  yp = (y1 + y2) / 2
  zp = (z1 + z2) / 2
  createLongLine x1, y1, z1, xp, yp, zp, c
  createLongLine xp, yp, zp, x2, y2, z2, c
END IF
END SUB

SUB createNewLine (x1, y1, z1, x2, y2, z2, c)

cx = (x1 + x2) / 2
cy = (y1 + y2) / 2
cz = (z1 + z2) / 2

clx = INT(cx / 100)
cly = INT(cy / 100)
clz = INT(cz / 100)

IF clx >= visMinX THEN
  IF clx <= visMaxX THEN
    IF cly >= visMinY THEN
      IF cly <= visMaxY THEN
        IF clz >= visMinZ THEN
          IF clz <= visMaxZ THEN
            insertLine x1, y1, z1, x2, y2, z2, c
          END IF
        END IF
      END IF
    END IF
  END IF
END IF

cln$ = getClustName(clx, cly, clz)

OPEN cln$ FOR APPEND AS #1
  PRINT #1, x1; y1; z1; x2; y2; z2; c
CLOSE #1

END SUB

SUB createWorld



CHDIR "world"

FOR x = -worldSize TO worldSize
 
  n$ = "X" + toStr$(x)
  MKDIR n$
  CHDIR n$

  FOR y = -worldSize TO worldSize

    n2$ = "Y" + toStr$(y)
    MKDIR n2$
    CHDIR n2$

    PRINT x, y
    FOR z = -worldSize TO worldSize

      n3$ = "z" + toStr$(z) + ".dat"
      OPEN n3$ FOR OUTPUT AS #1
'      PRINT #1, "0"
      CLOSE #1
    NEXT z

    CHDIR ".."
  NEXT y

  CHDIR ".."
NEXT x

CHDIR ".."

END SUB

SUB decVisibility

mx = INT(myx / 100)
my = INT(myy / 100)
mz = INT(myz / 100)

6
de = 0

IF visMaxX > mx + visDist THEN
  visMaxX = mx + visDist
  de = 1
END IF

IF visMinX < mx - visDist THEN
  visMinX = mx - visDist
  de = 1
END IF


IF visMaxY > my + visDist THEN
  visMaxY = my + visDist
  de = 1
END IF

IF visMinY < my - visDist THEN
  visMinY = my - visDist
  de = 1
END IF


IF visMaxZ > mz + visDist THEN
  visMaxZ = mz + visDist
  de = 1
END IF

IF visMinZ < mz - visDist THEN
  visMinZ = mz - visDist
  de = 1
END IF

IF de = 0 THEN
  IF visDist > 3 THEN visDist = visDist - 1: GOTO 6
ELSE
  addMsg "Visibility decareased"
END IF


applyBounds
END SUB

SUB dispmsg
FOR a = 1 TO 10
  LOCATE a, 39 - LEN(msgs$(a))
  PRINT msgs$(a)
NEXT a
END SUB

SUB fill1

x1 = RND * 800 - 400
y1 = RND * 800 - 400
z1 = RND * 800 - 400

x2 = x1 + RND * 20
y2 = y1 + RND * 20
z2 = z1 + RND * 20

createNewLine x1, y1, z1, x2, y2, z2, INT(RND * 15) + 1

END SUB

SUB fill2


frmt = frm * 15

x1 = SIN(frmt / 533) * 300 + SIN(frmt / 53) * 50
y1 = COS(frmt / 422) * 300 + SIN(frmt / 31) * 20
z1 = SIN(frmt / 133) * 300 + SIN(frmt / 39) * 60

frmt = (frm - 1) * 15

x2 = SIN(frmt / 533) * 300 + SIN(frmt / 53) * 50
y2 = COS(frmt / 422) * 300 + SIN(frmt / 31) * 20
z2 = SIN(frmt / 133) * 300 + SIN(frmt / 39) * 60



createNewLine x1, y1, z1, x2, y2, z2, INT(RND * 15) + 1

END SUB

SUB fill3

IF frm / 10 = frm \ 10 THEN  ELSE GOTO fill31

c = RND * 15 + 1

x = RND * 800 - 400
y = RND * 800 - 400
z = RND * 800 - 400

s = RND * 10 + 3

createNewLine x - s, y - s, z - s, x + s, y - s, z - s, c
createNewLine x + s, y - s, z - s, x + s, y + s, z - s, c
createNewLine x + s, y + s, z - s, x - s, y + s, z - s, c
createNewLine x - s, y + s, z - s, x - s, y - s, z - s, c

createNewLine x - s, y - s, z + s, x + s, y - s, z + s, c
createNewLine x + s, y - s, z + s, x + s, y + s, z + s, c
createNewLine x + s, y + s, z + s, x - s, y + s, z + s, c
createNewLine x - s, y + s, z + s, x - s, y - s, z + s, c

createNewLine x - s, y - s, z - s, x - s, y - s, z + s, c
createNewLine x + s, y - s, z - s, x + s, y - s, z + s, c
createNewLine x + s, y + s, z - s, x + s, y + s, z + s, c
createNewLine x - s, y + s, z - s, x - s, y + s, z + s, c

xo = x
yo = y
zo = z


x = x + RND * 80 - 40
y = y + RND * 80 - 40
z = z + RND * 80 - 40

s = RND * 10 + 3

createNewLine x - s, y - s, z - s, x + s, y - s, z - s, c
createNewLine x + s, y - s, z - s, x + s, y + s, z - s, c
createNewLine x + s, y + s, z - s, x - s, y + s, z - s, c
createNewLine x - s, y + s, z - s, x - s, y - s, z - s, c

createNewLine x - s, y - s, z + s, x + s, y - s, z + s, c
createNewLine x + s, y - s, z + s, x + s, y + s, z + s, c
createNewLine x + s, y + s, z + s, x - s, y + s, z + s, c
createNewLine x - s, y + s, z + s, x - s, y - s, z + s, c

createNewLine x - s, y - s, z - s, x - s, y - s, z + s, c
createNewLine x + s, y - s, z - s, x + s, y - s, z + s, c
createNewLine x + s, y + s, z - s, x + s, y + s, z + s, c
createNewLine x - s, y + s, z - s, x - s, y + s, z + s, c


createNewLine x, y, z, xo, yo, zo, c

fill31:
END SUB

SUB fill4
IF RND * 100 < 2 THEN

b$ = ""
FOR a = 1 TO RND * 3 + 1
b$ = b$ + CHR$(48 + RND * 9)
NEXT a

'b$ = "Hello, world!"
prn b$, RND * 800 - 400, RND * 800 - 400, RND * 800 - 400

END IF
END SUB

FUNCTION getbyte (addr)
getbyte = PEEK(extADDR + addr)
END FUNCTION

FUNCTION getClustName$ (a, b, c)

getClustName$ = "WORLD\X" + toStr$(a) + "\Y" + toStr$(b) + "\Z" + toStr$(c) + ".DAT"

END FUNCTION

FUNCTION getword (addr)
a = PEEK(extADDR + addr)
b = PEEK(extADDR + addr + 1)


c$ = HEX$(a)
IF LEN(c$) = 1 THEN c$ = "0" + c$
IF LEN(c$) = 0 THEN c$ = "00"


c = VAL("&H" + HEX$(b) + c$)

getword = c
END FUNCTION

SUB importCluster (x, y, z)

cln$ = getClustName(x, y, z)
'[PRINT cln$

OPEN cln$ FOR INPUT AS #1
5
IF EOF(1) <> 0 THEN GOTO 4
 
INPUT #1, x1, y1, z1, x2, y2, z2, c
insertLine x1, y1, z1, x2, y2, z2, c

GOTO 5
4
CLOSE #1


END SUB

SUB insertLine (x1, y1, z1, x2, y2, z2, c)

insertLine1:
IF linC(curFreeLine) = -1 THEN
  linX1(curFreeLine) = x1
  linY1(curFreeLine) = y1
  linZ1(curFreeLine) = z1

  linX2(curFreeLine) = x2
  linY2(curFreeLine) = y2
  linZ2(curFreeLine) = z2
 
  linC(curFreeLine) = c
  curFreeLine = curFreeLine + 1
  usedLines = usedLines + 1
  IF curFreeLine > linAmo THEN curFreeLine = 0
ELSE
  curFreeLine = curFreeLine + 1
  IF curFreeLine > linAmo THEN curFreeLine = 0
  GOTO insertLine1
END IF


END SUB

SUB loadArea (tx1, ty1, tz1, tx2, ty2, tz2)

LOCATE 3, 1
addMsg "Loading Area!"
addMsg toStr$(tx1) + " " + toStr$(ty1) + " " + toStr$(tz1)
addMsg toStr$(tx2) + " " + toStr$(ty2) + " " + toStr$(tz2)


'PCOPY 0, 1
'SLEEP

x1 = tx1
x2 = tx2

y1 = ty1
y2 = ty2

z1 = tz1
z2 = tz2

IF x1 > x2 THEN SWAP x1, x2
IF y1 > y2 THEN SWAP y1, y2
IF z1 > z2 THEN SWAP z1, z2

FOR x = x1 TO x2
  FOR y = y1 TO y2
    FOR z = z1 TO z2
      loadCluster x, y, z
    NEXT z
  NEXT y
NEXT x

END SUB

SUB loadCluster (x, y, z)

IF ABS(x) > worldSize THEN GOTO 11
IF ABS(y) > worldSize THEN GOTO 11
IF ABS(z) > worldSize THEN GOTO 11

cln$ = getClustName(x, y, z)

OPEN cln$ FOR INPUT AS #1
10
IF EOF(1) <> 0 THEN GOTO 9

INPUT #1, x1, y1, z1, x2, y2, z2, c
insertLine x1, y1, z1, x2, y2, z2, c

GOTO 10
9
CLOSE #1

11

END SUB

SUB loadObject (name$, x, y, z)

'SCREEN 13
'PRINT "objects\" + name$ + ".3d"
'END

OPEN "OBJECTS\" + name$ + ".3d" FOR INPUT AS #2
13
IF EOF(2) <> 0 THEN GOTO 12
INPUT #2, x1, y1, z1, x2, y2, z2, co
createNewLine x1 + x, y1 + y, z1 + z, x2 + x, y2 + y, z2 + z, co
GOTO 13
12
CLOSE #2

END SUB

SUB makeGrid (x1, y1, z1, x2, y2, z2)

s = 100

FOR x = x1 TO x2 STEP s
  FOR y = y1 TO y2 STEP s
    createLongLine x1, y, x, x2, y, x, 1
    createLongLine x, y1, y, x, y2, y, 1
    createLongLine x, y, z1, x, y, z2, 1
  NEXT y
NEXT x

END SUB

SUB mousedemo



cx = 150
cy = 100
maxmove = 50
100
frm = frm + 1


LOCATE 1, 1
PRINT cx, cy
PRINT frm

CIRCLE (cx, cy), 10, 0
xp = getword(2)
putword 2, 0
yp = getword(4)
putword 4, 0


IF xp < -maxmove THEN xp = -maxmove
IF xp > maxmove THEN xp = maxmove
cx = cx + xp

IF yp < -maxmove THEN yp = -maxmove
IF yp > maxmove THEN yp = maxmove
cy = cy + yp


CIRCLE (cx, cy), 10, 10



SOUND 0, .05
GOTO 100


END SUB

SUB prn (a$, x, y, z)

FOR a = 1 TO LEN(a$)
  b$ = RIGHT$(LEFT$(a$, a), 1)
  putChar b$, x + (a - 1) * 8, y, z
NEXT a
END SUB

SUB putbyte (addr, dat)

POKE (extADDR + addr), dat
END SUB

SUB putChar (a$, x, y, z)

n$ = "FONT\LTR" + toStr(ASC(a$))
loadObject n$, x, y, z

END SUB

SUB putword (addr, dat)

b$ = HEX$(dat)

2
IF LEN(b$) < 4 THEN b$ = "0" + b$: GOTO 2

n1 = VAL("&H" + LEFT$(b$, 2))
n2 = VAL("&H" + RIGHT$(b$, 2))


POKE (extADDR + addr), n2
POKE (extADDR + addr + 1), n1

END SUB

SUB render

s1 = SIN(an1)
c1 = COS(an1)

s2 = SIN(an2)
c2 = COS(an2)


FOR a = 0 TO linAmo

  IF linC(a) > 0 THEN
    x11 = linX1(a) - myx
    y11 = linY1(a) - myy
    z11 = linZ1(a) - myz
 
    x21 = linX2(a) - myx
    y21 = linY2(a) - myy
    z21 = linZ2(a) - myz


    x12 = x11 * c1 + z11 * s1
    z12 = z11 * c1 - x11 * s1


    y12 = y11 * c2 + z12 * s2
    z13 = z12 * c2 - y11 * s2


    IF z13 > 3 THEN
      x22 = x21 * c1 + z21 * s1
      z22 = z21 * c1 - x21 * s1


      y22 = y21 * c2 + z22 * s2
      z23 = z22 * c2 - y21 * s2


      IF z23 > 3 THEN
   
        rx1 = x12 / z13 * 130 + 160
        ry1 = y12 / z13 * 130 + 100
      
        rx2 = x22 / z23 * 130 + 160
        ry2 = y22 / z23 * 130 + 100
     
        LINE (rx1, ry1)-(rx2, ry2), linC(a)
      END IF
    END IF
  END IF
NEXT a


'dispmsg

END SUB

SUB start

RANDOMIZE TIMER

FOR a = 0 TO linAmo
  linC(a) = -1
NEXT a


startext

maxmove = 50
curFreeLine = 0
worldSize = 5
usedLines = 0
desMaxLines = 2000

visMaxX = worldSize
visMaxY = worldSize
visMaxZ = worldSize
visMinX = -worldSize
visMinY = -worldSize
visMinZ = -worldSize

visDist = worldSize

'INPUT "create new world (y/n)", a$
'IF a$ = "y" THEN
'  createWorld
'ELSE
'  INPUT "clear existing world (y/n)", a$
'  IF a$ = "y" THEN clearWorld
'END IF

clearWorld

SCREEN 7, , , 1



END SUB

SUB startext

DEF SEG = 0     ' read first from interrupt table

extSEG = PEEK(&H79 * 4 + 3) * 256
extSEG = extSEG + PEEK(&H79 * 4 + 2)

PRINT "Segment is: " + HEX$(extSEG)

extADDR = PEEK(&H79 * 4 + 1) * 256
extADDR = extADDR + PEEK(&H79 * 4 + 0)

PRINT "relative address is:"; extADDR

DEF SEG = extSEG

IF getword(0) <> 1983 THEN
  PRINT "FATAL ERROR:  you must load"
  PRINT "QBasic extension TSR first!"
  SYSTEM
END IF

END SUB

FUNCTION toStr$ (a)

b$ = STR$(a)
IF LEFT$(b$, 1) = " " THEN b$ = RIGHT$(b$, LEN(b$) - 1)
toStr$ = b$

END FUNCTION