' 3D Universe Explorer
' made by Svjatoslav Agejenko
' in 2003.12
' H-Page: svjatoslav.eu
' E-Mail: svjatoslav@svjatoslav.eu
 
DECLARE SUB loadScript (a$)

DECLARE SUB timerAdd (element!, time!, value!)
DECLARE SUB timerinit ()
DECLARE SUB timerprocess ()

DECLARE SUB getCloudXYZ (a!, x1!, y1!, z2!)
DECLARE FUNCTION gdist! (x!, y!, z!)
DECLARE SUB mkworld ()
DECLARE SUB galacloud (rx!, ry!, rz!)
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 10000)
DIM SHARED py(1 TO 10000)
DIM SHARED pz(1 TO 10000)
DIM SHARED pc(1 TO 10000)
DIM SHARED nump
DIM SHARED myspd

DIM SHARED tempr(0 TO 10)

DIM SHARED vd


DIM SHARED oftcloud(0 TO 3)


DIM SHARED oftGalaX(0 TO 19)
DIM SHARED oftGalaY(0 TO 19)
DIM SHARED oftGalaZ(0 TO 19)


DIM SHARED timerTime(0 TO 50, 0 TO 100)
DIM SHARED timerValue(0 TO 50, 0 TO 100)

DIM SHARED timerCplace(0 TO 50)
DIM SHARED timerCtime(0 TO 50)
DIM SHARED timerCvalue(0 TO 50)
DIM SHARED timerLast

DIM SHARED timerStartScript
DIM SHARED ScriptRunning


start


cx = 0
cy = 0
cz = 0

myx = 123456
myy = 321
myz = 23

nump = 9999
1
mkworld






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

timerprocess

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$ = "1" THEN myspd = .1
IF a$ = "2" THEN myspd = 1
IF a$ = "3" THEN myspd = 10
IF a$ = "4" THEN myspd = 100
IF a$ = "5" THEN myspd = 1000
IF a$ = "6" THEN myspd = 10000
IF a$ = "7" THEN myspd = 100000
IF a$ = "8" THEN myspd = 1000000

IF a$ = "q" THEN SYSTEM

IF a$ = " " THEN
  IF timerStartScript = 0 THEN
    OPEN "script.dat" FOR OUTPUT AS #1
    timerStartScript = TIMER
  END IF
  PRINT #1, TIMER - timerStartScript;
  PRINT #1, myx; myy; myz; an1; an2
  SOUND 2000, .1
END IF

IF a$ = "r" THEN
  IF ScriptRunning = 0 THEN
    timerinit
    loadScript "script.dat"
  ELSE
    ScriptRunning = 0
 
  END IF
END IF


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

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


IF ScriptRunning = 1 THEN
'DIM SHARED timerCvalue(0 TO 50)
  myx = timerCvalue(1)
  myy = timerCvalue(2)
  myz = timerCvalue(3)
  an1 = timerCvalue(4)
  an2 = timerCvalue(5)

  LOCATE 20, 1
'  PRINT "demo"
END IF

END SUB

SUB disp

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

vdn = 100000000

FOR a = 1 TO nump

  x = px(a) - myx
  y = py(a) - myy
  z = pz(a) - myz
  

  IF ABS(x) < vdn THEN
    IF ABS(y) < vdn THEN
      IF ABS(z) < vdn THEN vdn = SQR(x * x + y * y + z * z)
    END IF
  END IF

  x1 = x * c1 + z * s1
  z1 = z * c1 - x * s1

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


  IF z2 > 3 THEN
    PSET (x1 / z2 * 130 + 160, y1 / z2 * 130 + 100), pc(a)
  END IF


NEXT a

vd = (vd * 5 + vdn) / 6


LOCATE 1, 1
'PRINT vdn
LOCATE 1, 20
'PRINT vd

END SUB

SUB galacloud (rx, ry, rz)


a = INT(RND * 100)


d = (a + 30) * 500


x = d
y = 0
z = 0

a1 = SIN(a * (123.45 - (rx MOD 1235))) * 100
a2 = SIN(a * 324 + (ry MOD 5431)) * 120


s1 = SIN(a1)
c1 = COS(a1)
s2 = SIN(a2)
c2 = COS(a2)


x1 = x * c1 + z * s1
z1 = z * c1 - x * s1

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

fx = x1 + rx
fy = y1 + ry
fz = z2 + rz

dist = gdist(fx, fy, fz)

IF dist < 20000 THEN
  pl = INT(RND * 20)
  oftGalaX(pl) = fx
  oftGalaY(pl) = fy
  oftGalaZ(pl) = fz
  mkgalaxy fx, fy, fz
ELSE
  IF (RND * 100 < 10) OR (vd > 500000) THEN
    mkgalaxy fx, fy, fz
  END IF
END IF


END SUB

FUNCTION gdist (x, y, z)
gdist = SQR((x - myx) ^ 2 + (y - myy) ^ 2 + (z - myz) ^ 2)

END FUNCTION

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

SUB getCloudXYZ (a, x1, y1, z2)


d = a * 1000000


x = d
y = 0
z = 0

a1 = SIN(a * 123) * 100
a2 = SIN(a * 975) * 120


s1 = SIN(a1)
c1 = COS(a1)
s2 = SIN(a2)
c2 = COS(a2)


x1 = x * c1 + z * s1
z1 = z * c1 - x * s1

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


END SUB

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 loadScript (a$)
ScriptRunning = 1
rt = 2

OPEN "script.dat" FOR INPUT AS #2
5
IF EOF(2) <> 0 THEN GOTO 6

INPUT #2, t
t = t / 2
rt = rt + 6
FOR a = 1 TO 5
  INPUT #2, b
  timerAdd a, rt, b
NEXT a

GOTO 5
6
CLOSE #2

FOR a = 1 TO 5
  timerAdd a, -1, b
NEXT a

END SUB

SUB mkgalaxy (lx, ly, lz)

IF (lx = 0) AND (ly = 0) AND (lz = 0) THEN GOTO 4


rndp = ABS(lx + ly + lz) MOD 9000
n1 = rn * 100
n2 = rn * 100
n3 = rn * 100

gs1 = SIN(n1)
gc1 = COS(n1)
gs2 = SIN(n2)
gc2 = COS(n2)
gs3 = SIN(n3)
gc3 = COS(n3)



siz = rn * 50 + 75
pi = 3.14
sbm = INT(rn * 3) + 1


dist = gdist(lx, ly, lz)
amo = 1
IF dist < 20000 THEN amo = 1
IF dist < 5000 THEN amo = 2
IF dist < 1000 THEN amo = 10
IF dist < 500 THEN amo = 50



FOR a = 1 TO amo

  b = RND * 10
  s = b * b / 30

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

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

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


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

  y1 = y * gc2 + z1 * gs2
  z2 = z1 * gc2 - y * gs2
 
  y2 = y1 * gc3 + x1 * gs3
  x2 = x1 * gc3 - y1 * gs3


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


4
END SUB

SUB mkworld


FOR b = 1 TO 10
  a = INT(RND * 100)
  getCloudXYZ a, x, y, z
  IF gdist(x, y, z) < vd * 3 THEN oftcloud(INT(RND * 4)) = a
  galacloud x, y, z
NEXT b


IF vd < 4000000 THEN
  LOCATE 3
'  PRINT "galaxy cloud zoom";

  FOR b = 0 TO 3
    a = oftcloud(b)
'    PRINT a;
    getCloudXYZ a, x, y, z
    galacloud x, y, z
  NEXT b
END IF

IF vd < 10000 THEN
  LOCATE 4, 1
'  PRINT "Galaxy zoom"
  FOR b = 0 TO 19
    x = oftGalaX(b)
    y = oftGalaY(b)
    z = oftGalaZ(b)
'    PRINT x; y; z
    mkgalaxy x, y, z
  NEXT b
ELSE
' FOR b = 0 TO 3
'    oftGalaX(b) = 0
'    oftGalaY(b) = 0
'    oftGalaZ(b) = 0
'  NEXT b
END IF


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

PRINT "Universe Explorer"
PRINT "by Svjatoslav Agejenko, n0@hot.ee"
PRINT "2003.12"
PRINT
PRINT "Use mouse to aim."
PRINT "Use keys: a, s, d, w  to move around,"
PRINT "1 2 3 4 5 6 7 to change speed multiplier."
PRINT "r - to start/stop demo."
PRINT "q - to quit program."

PRINT "right mouse button, to move UP <> DOWN."
PRINT "both right & left mouse buttons pressed to move BACK <> FRONT."

PRINT "At least P3 500 MHz, would be nice."
PRINT "Better CPU, more details and higher framerate."
PRINT "Requires mouse driver, and QBasic extension TSR"
PRINT "to be loaded first."

PRINT
PRINT "In this program:"

PRINT "Several stars, make up galaxy."
PRINT "Several galaxies makes metagalaxy."
PRINT "Several metagalaxies makes up universe."

PRINT
PRINT "Press Any key To Continue."
a$ = INPUT$(1)

startext


SCREEN 7, , , 1

maxmove = 50
rndinit
myspd = 1000000

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

SUB timerAdd (element, time, value)

FOR a = 0 TO 100
  IF (timerTime(element, a) = 0) AND (timerValue(element, a) = 0) THEN GOTO timer3
NEXT a
timer3:

timerTime(element, a) = time
timerValue(element, a) = value

END SUB

SUB timerdisp
LOCATE 1, 1

FOR a = 0 TO 10
  PRINT timerCplace(a), timerCtime(a), timerCvalue(a)
NEXT a

END SUB

SUB timerinit
timerLast = TIMER


FOR a = 1 TO 50
  FOR b = 1 TO 100
    timerTime(a, b) = 0
    timerValue(a, b) = 0
  NEXT b
NEXT a


END SUB

SUB timerprocess

timerCurrent = TIMER
timerDiff = timerCurrent - timerLast
timerLast = timerCurrent

FOR a = 0 TO 50
  ctim = timerCtime(a) + timerDiff
  Cplace = timerCplace(a)
timer2:
  IF timerTime(a, Cplace + 1) = -1 THEN
    ctim = 0
    Cplace = 0
  END IF
  IF timerTime(a, Cplace + 1) < ctim THEN
    IF timerTime(a, Cplace + 1) = 0 THEN
      timerCvalue(a) = timerValue(a, Cplace)
      GOTO timer1:
    END IF
    Cplace = Cplace + 1
    GOTO timer2
  END IF

  v1 = timerValue(a, Cplace)
  t1 = timerTime(a, Cplace)
  v2 = timerValue(a, Cplace + 1)
  t2 = timerTime(a, Cplace + 1)

  IF v1 = v2 THEN
    timerCvalue(a) = v1
  ELSE
    Tdiff1 = t2 - t1
    Tdiff2 = ctim - t1
    Vdiff = v2 - v1
    timerCvalue(a) = Tdiff2 / Tdiff1 * Vdiff + v1
  END IF
timer1:
  timerCplace(a) = Cplace
  timerCtime(a) = ctim
NEXT a

END SUB