' Galaxy explorer
' made by Svjatoslav Agejenko
' in 2003.12
' E-Mail: svjatoslav@svjatoslav.eu
' H-Page: svjatoslav.eu
 
DECLARE SUB temp ()
DECLARE SUB mkgalaxy (x!, y!, z!)
DECLARE SUB rndinit ()
DECLARE FUNCTION rn! ()
DECLARE SUB disp ()
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 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


DIM SHARED zoom
DIM SHARED rndval(0 TO 10000)
DIM SHARED rndp


DIM SHARED px(1 TO 12000)
DIM SHARED py(1 TO 12000)
DIM SHARED pz(1 TO 12000)
DIM SHARED pc(1 TO 12000)
DIM SHARED nump

DIM SHARED tempr(0 TO 10)


nl = 0
np = 0

start


cx = 0
cy = 0
cz = 0



nump = 0
mkgalaxy 0, 0, 0
1




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
disp

PCOPY 0, 1
CLS
GOTO 1

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 disp

s1 = SIN(an1)
c1 = COS(an1)
s2 = SIN(an2)
c2 = COS(an2)


FOR a = 1 TO nump

                       
  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
    rpx = x1 / z2 * 130 + 160
    rpy = y1 / z2 * 130 + 100
    PSET (rpx, rpy), pc(a)
 
  END IF


NEXT a
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 mkgalaxy (lx, ly, lz)


n1 = rn * 10
n2 = rn * 10

gs1 = SIN(n1)
gc1 = COS(n1)
gs2 = SIN(n2)
gc2 = COS(n2)



rndp = 0
siz = 100
pi = 3.14
sbm = 3


FOR a = 1 TO 10000

  b = rn * 10
  s = b * b / 30

  v1 = rn * (11.5 - b) / 3
  v1p = v1 / 2

  ane = rn * (s / 2) / sbm * 2
  sba = 2 * pi / sbm * INT(rn * sbm)

  x = (SIN(b - sba + ane) * s + rn * v1 - v1p) * siz
  z = (COS(b - sba + ane) * s + rn * v1 - v1p) * siz
  y = (rn * v1 - v1p) * siz


  x1 = x * gc1 + z * gs1
  z1 = z * gc1 - x * gs1

  y1 = y * gc2 + z1 * gs2
  z2 = z1 * gc2 - y * gs2


  nump = nump + 1

  px(nump) = x1 + lx
  py(nump) = y1 + ly
  pz(nump) = z2 + lz
  pc(nump) = INT(RND * 15) + 1
NEXT a

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 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

FUNCTION rn

rndp = rndp + 1
IF rndp > 10000 THEN rndp = 0
rn = rndval(rndp)

END FUNCTION

SUB rndinit


FOR a = 0 TO 10000
  rndval(a) = RND
NEXT a

rndp = 0
END SUB

SUB start


startext


SCREEN 7, , , 1

maxmove = 50
rndinit

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