' 3D Maze explorer
' made by Svjatoslav Agejenko
' in 2003.12
' H-Page: svjatoslav.eu
' E-Mail: svjatoslavagejenko@gmail.com
 
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 animate ()

DIM SHARED px(1 TO 5000)
DIM SHARED py(1 TO 5000)
DIM SHARED pz(1 TO 5000)
DIM SHARED rpx(1 TO 5000)
DIM SHARED rpy(1 TO 5000)
DIM SHARED rpe(1 TO 5000)

DIM SHARED l1(1 TO 5000)
DIM SHARED l2(1 TO 5000)
DIM SHARED lc(1 TO 5000)

DIM SHARED nl, np

DIM SHARED an1, an2, an3

DIM SHARED tim

DIM SHARED extSEG, extADDR

DIM SHARED myx, myy, myz
DIM SHARED myxs, myys, myzs
DIM SHARED buttL, buttR
DIM SHARED maxmove

nl = 0
np = 0

start


cx = 0
cy = 0
cz = 0

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

1




np = np + 1
px(np) = cx
py(np) = cy
pz(np) = cz



nl = nl + 1
l1(nl) = np
l2(nl) = np - 1
lc(nl) = INT(RND * 15) + 1
'lc(nl) = ABS(cx / 20)



va = INT(RND * 3)

SELECT CASE va
CASE 0
  cx = RND * 500 - 250
CASE 1
  cy = RND * 100 - 50
CASE 2
  cz = RND * 500 - 250
END SELECT


control
animate

PCOPY 0, 1
CLS
GOTO 1

SUB animate


s1 = SIN(an1)
s2 = SIN(an2)
s3 = SIN(an3)

c1 = COS(an1)
c2 = COS(an2)
c3 = COS(an3)



FOR a = 1 TO np
  x = px(a) - myx
  y = py(a) - myy
  z = pz(a) - myz
   
 
  x1 = x * c1 + z * s1
  z1 = z * c1 - x * s1

  y1 = y * c2 + z1 * s2
  z2 = z1 * c2 - y * s2


'  z2 = z2 + 10
  
  IF z2 > 3 THEN
    rpe(a) = 1
    rpx(a) = x1 / z2 * 130 + 160
    rpy(a) = y1 / z2 * 130 + 100
  ELSE
    rpe(a) = 0
  END IF

NEXT a


FOR a = 1 TO nl

  p1 = l1(a)
  p2 = l2(a)
  IF (rpe(p1) = 1) AND (rpe(p2) = 1) THEN LINE (rpx(p1), rpy(p1))-(rpx(p2), rpy(p2)), lc(a)

NEXT a


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

FUNCTION getbyte (addr)
getbyte = PEEK(extADDR + addr)
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 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 putbyte (addr, dat)

POKE (extADDR + addr), dat
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 start
startext


SCREEN 7, , , 1

maxmove = 50

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