152dacf09b9f8abf62a3d511cca81684b8363dd1
[qbasicapps.git] / graphics / 3D / universe explorer / expluniv.bas
1 ' 3D Universe Explorer\r
2 ' made by Svjatoslav Agejenko\r
3 ' in 2003.12\r
4 ' H-Page: svjatoslav.eu\r
5 ' E-Mail: svjatoslavagejenko@gmail.com\r
6  \r
7 DECLARE SUB loadScript (a$)\r
8 \r
9 DECLARE SUB timerAdd (element!, time!, value!)\r
10 DECLARE SUB timerinit ()\r
11 DECLARE SUB timerprocess ()\r
12 \r
13 DECLARE SUB getCloudXYZ (a!, x1!, y1!, z2!)\r
14 DECLARE FUNCTION gdist! (x!, y!, z!)\r
15 DECLARE SUB mkworld ()\r
16 DECLARE SUB galacloud (rx!, ry!, rz!)\r
17 DECLARE SUB temp ()\r
18 DECLARE SUB mkgalaxy (x!, y!, z!)\r
19 DECLARE SUB rndinit ()\r
20 DECLARE FUNCTION rn! ()\r
21 DECLARE SUB disp ()\r
22 DECLARE SUB startext ()\r
23 DECLARE SUB control ()\r
24 DECLARE SUB putbyte (addr!, dat!)\r
25 DECLARE SUB putword (addr!, dat!)\r
26 DECLARE FUNCTION getword! (addr!)\r
27 DECLARE FUNCTION getbyte! (addr!)\r
28 DECLARE SUB start ()\r
29 DECLARE SUB animate ()\r
30 \r
31 \r
32 DIM SHARED an1, an2, an3\r
33 \r
34 DIM SHARED tim\r
35 \r
36 DIM SHARED extSEG, extADDR\r
37 \r
38 DIM SHARED myx, myy, myz\r
39 DIM SHARED myxs, myys, myzs\r
40 DIM SHARED buttL, buttR\r
41 DIM SHARED maxmove\r
42 \r
43 \r
44 DIM SHARED zoom\r
45 DIM SHARED rndval(0 TO 10000)\r
46 DIM SHARED rndp\r
47 \r
48 \r
49 DIM SHARED px(1 TO 10000)\r
50 DIM SHARED py(1 TO 10000)\r
51 DIM SHARED pz(1 TO 10000)\r
52 DIM SHARED pc(1 TO 10000)\r
53 DIM SHARED nump\r
54 DIM SHARED myspd\r
55 \r
56 DIM SHARED tempr(0 TO 10)\r
57 \r
58 DIM SHARED vd\r
59 \r
60 \r
61 DIM SHARED oftcloud(0 TO 3)\r
62 \r
63 \r
64 DIM SHARED oftGalaX(0 TO 19)\r
65 DIM SHARED oftGalaY(0 TO 19)\r
66 DIM SHARED oftGalaZ(0 TO 19)\r
67 \r
68 \r
69 DIM SHARED timerTime(0 TO 50, 0 TO 100)\r
70 DIM SHARED timerValue(0 TO 50, 0 TO 100)\r
71 \r
72 DIM SHARED timerCplace(0 TO 50)\r
73 DIM SHARED timerCtime(0 TO 50)\r
74 DIM SHARED timerCvalue(0 TO 50)\r
75 DIM SHARED timerLast\r
76 \r
77 DIM SHARED timerStartScript\r
78 DIM SHARED ScriptRunning\r
79 \r
80 \r
81 start\r
82 \r
83 \r
84 cx = 0\r
85 cy = 0\r
86 cz = 0\r
87 \r
88 myx = 123456\r
89 myy = 321\r
90 myz = 23\r
91 \r
92 nump = 9999\r
93 1\r
94 mkworld\r
95 \r
96 \r
97 \r
98 \r
99 \r
100 \r
101 va = INT(RND * 3)\r
102 \r
103 SELECT CASE va\r
104 CASE 0\r
105   cx = RND * 500 - 250\r
106 CASE 1\r
107   cy = RND * 100 - 50\r
108 CASE 2\r
109   cz = RND * 500 - 250\r
110 END SELECT\r
111 \r
112 \r
113 control\r
114 disp\r
115 \r
116 timerprocess\r
117 \r
118 PCOPY 0, 1\r
119 CLS\r
120 GOTO 1\r
121 \r
122 SUB control\r
123 \r
124 \r
125 IF getbyte(8) <> 0 THEN\r
126   putbyte 8, 0\r
127   xp = getword(2)\r
128   putword 2, 0\r
129   yp = getword(4)\r
130   putword 4, 0\r
131   butt = getword(6)\r
132   putword 6, 0\r
133   buttL = 0\r
134   buttR = 0\r
135   IF butt = 1 THEN buttL = 1\r
136   IF butt = 2 THEN buttR = 1\r
137   IF butt = 3 THEN buttL = 1: buttR = 1\r
138 \r
139 \r
140   IF buttR = 1 THEN\r
141     IF buttL = 1 THEN\r
142       myxs = myxs + SIN(an1) * yp / 4\r
143       myzs = myzs - COS(an1) * yp / 4\r
144       GOTO 3\r
145     END IF\r
146     myys = myys + yp / 4\r
147 3\r
148     yp = 0\r
149   END IF\r
150 \r
151 END IF\r
152 \r
153 \r
154 \r
155 \r
156 IF xp < -maxmove THEN xp = -maxmove\r
157 IF xp > maxmove THEN xp = maxmove\r
158 an1 = an1 - xp / 150\r
159 \r
160 IF yp < -maxmove THEN yp = -maxmove\r
161 IF yp > maxmove THEN yp = maxmove\r
162 an2 = an2 - yp / 150\r
163 \r
164 \r
165 \r
166 a$ = INKEY$\r
167 \r
168 IF a$ = "a" THEN myxs = myxs - COS(an1): myzs = myzs - SIN(an1)\r
169 IF a$ = "d" THEN myxs = myxs + COS(an1): myzs = myzs + SIN(an1)\r
170 IF a$ = "w" THEN myxs = myxs - SIN(an1): myzs = myzs + COS(an1)\r
171 IF a$ = "s" THEN myxs = myxs + SIN(an1): myzs = myzs - COS(an1)\r
172 \r
173 IF a$ = "1" THEN myspd = .1\r
174 IF a$ = "2" THEN myspd = 1\r
175 IF a$ = "3" THEN myspd = 10\r
176 IF a$ = "4" THEN myspd = 100\r
177 IF a$ = "5" THEN myspd = 1000\r
178 IF a$ = "6" THEN myspd = 10000\r
179 IF a$ = "7" THEN myspd = 100000\r
180 IF a$ = "8" THEN myspd = 1000000\r
181 \r
182 IF a$ = "q" THEN SYSTEM\r
183 \r
184 IF a$ = " " THEN\r
185   IF timerStartScript = 0 THEN\r
186     OPEN "script.dat" FOR OUTPUT AS #1\r
187     timerStartScript = TIMER\r
188   END IF\r
189   PRINT #1, TIMER - timerStartScript;\r
190   PRINT #1, myx; myy; myz; an1; an2\r
191   SOUND 2000, .1\r
192 END IF\r
193 \r
194 IF a$ = "r" THEN\r
195   IF ScriptRunning = 0 THEN\r
196     timerinit\r
197     loadScript "script.dat"\r
198   ELSE\r
199     ScriptRunning = 0\r
200  \r
201   END IF\r
202 END IF\r
203 \r
204 \r
205 myxs = myxs / 1.1\r
206 myys = myys / 1.1\r
207 myzs = myzs / 1.1\r
208 \r
209 myx = myx + myxs * myspd\r
210 myz = myz + myzs * myspd\r
211 myy = myy + myys * myspd\r
212 \r
213 \r
214 IF ScriptRunning = 1 THEN\r
215 'DIM SHARED timerCvalue(0 TO 50)\r
216   myx = timerCvalue(1)\r
217   myy = timerCvalue(2)\r
218   myz = timerCvalue(3)\r
219   an1 = timerCvalue(4)\r
220   an2 = timerCvalue(5)\r
221 \r
222   LOCATE 20, 1\r
223 '  PRINT "demo"\r
224 END IF\r
225 \r
226 END SUB\r
227 \r
228 SUB disp\r
229 \r
230 s1 = SIN(an1)\r
231 c1 = COS(an1)\r
232 s2 = SIN(an2)\r
233 c2 = COS(an2)\r
234 \r
235 vdn = 100000000\r
236 \r
237 FOR a = 1 TO nump\r
238 \r
239   x = px(a) - myx\r
240   y = py(a) - myy\r
241   z = pz(a) - myz\r
242   \r
243 \r
244   IF ABS(x) < vdn THEN\r
245     IF ABS(y) < vdn THEN\r
246       IF ABS(z) < vdn THEN vdn = SQR(x * x + y * y + z * z)\r
247     END IF\r
248   END IF\r
249 \r
250   x1 = x * c1 + z * s1\r
251   z1 = z * c1 - x * s1\r
252 \r
253   y1 = y * c2 + z1 * s2\r
254   z2 = z1 * c2 - y * s2\r
255 \r
256 \r
257   IF z2 > 3 THEN\r
258     PSET (x1 / z2 * 130 + 160, y1 / z2 * 130 + 100), pc(a)\r
259   END IF\r
260 \r
261 \r
262 NEXT a\r
263 \r
264 vd = (vd * 5 + vdn) / 6\r
265 \r
266 \r
267 LOCATE 1, 1\r
268 'PRINT vdn\r
269 LOCATE 1, 20\r
270 'PRINT vd\r
271 \r
272 END SUB\r
273 \r
274 SUB galacloud (rx, ry, rz)\r
275 \r
276 \r
277 a = INT(RND * 100)\r
278 \r
279 \r
280 d = (a + 30) * 500\r
281 \r
282 \r
283 x = d\r
284 y = 0\r
285 z = 0\r
286 \r
287 a1 = SIN(a * (123.45 - (rx MOD 1235))) * 100\r
288 a2 = SIN(a * 324 + (ry MOD 5431)) * 120\r
289 \r
290 \r
291 s1 = SIN(a1)\r
292 c1 = COS(a1)\r
293 s2 = SIN(a2)\r
294 c2 = COS(a2)\r
295 \r
296 \r
297 x1 = x * c1 + z * s1\r
298 z1 = z * c1 - x * s1\r
299 \r
300 y1 = y * c2 + z1 * s2\r
301 z2 = z1 * c2 - y * s2\r
302 \r
303 fx = x1 + rx\r
304 fy = y1 + ry\r
305 fz = z2 + rz\r
306 \r
307 dist = gdist(fx, fy, fz)\r
308 \r
309 IF dist < 20000 THEN\r
310   pl = INT(RND * 20)\r
311   oftGalaX(pl) = fx\r
312   oftGalaY(pl) = fy\r
313   oftGalaZ(pl) = fz\r
314   mkgalaxy fx, fy, fz\r
315 ELSE\r
316   IF (RND * 100 < 10) OR (vd > 500000) THEN\r
317     mkgalaxy fx, fy, fz\r
318   END IF\r
319 END IF\r
320 \r
321 \r
322 END SUB\r
323 \r
324 FUNCTION gdist (x, y, z)\r
325 gdist = SQR((x - myx) ^ 2 + (y - myy) ^ 2 + (z - myz) ^ 2)\r
326 \r
327 END FUNCTION\r
328 \r
329 FUNCTION getbyte (addr)\r
330 getbyte = PEEK(extADDR + addr)\r
331 END FUNCTION\r
332 \r
333 SUB getCloudXYZ (a, x1, y1, z2)\r
334 \r
335 \r
336 d = a * 1000000\r
337 \r
338 \r
339 x = d\r
340 y = 0\r
341 z = 0\r
342 \r
343 a1 = SIN(a * 123) * 100\r
344 a2 = SIN(a * 975) * 120\r
345 \r
346 \r
347 s1 = SIN(a1)\r
348 c1 = COS(a1)\r
349 s2 = SIN(a2)\r
350 c2 = COS(a2)\r
351 \r
352 \r
353 x1 = x * c1 + z * s1\r
354 z1 = z * c1 - x * s1\r
355 \r
356 y1 = y * c2 + z1 * s2\r
357 z2 = z1 * c2 - y * s2\r
358 \r
359 \r
360 END SUB\r
361 \r
362 FUNCTION getword (addr)\r
363 a = PEEK(extADDR + addr)\r
364 b = PEEK(extADDR + addr + 1)\r
365 \r
366 \r
367 c$ = HEX$(a)\r
368 IF LEN(c$) = 1 THEN c$ = "0" + c$\r
369 IF LEN(c$) = 0 THEN c$ = "00"\r
370 \r
371 \r
372 c = VAL("&H" + HEX$(b) + c$)\r
373 \r
374 getword = c\r
375 END FUNCTION\r
376 \r
377 SUB loadScript (a$)\r
378 ScriptRunning = 1\r
379 rt = 2\r
380 \r
381 OPEN "script.dat" FOR INPUT AS #2\r
382 5\r
383 IF EOF(2) <> 0 THEN GOTO 6\r
384 \r
385 INPUT #2, t\r
386 t = t / 2\r
387 rt = rt + 6\r
388 FOR a = 1 TO 5\r
389   INPUT #2, b\r
390   timerAdd a, rt, b\r
391 NEXT a\r
392 \r
393 GOTO 5\r
394 6\r
395 CLOSE #2\r
396 \r
397 FOR a = 1 TO 5\r
398   timerAdd a, -1, b\r
399 NEXT a\r
400 \r
401 END SUB\r
402 \r
403 SUB mkgalaxy (lx, ly, lz)\r
404 \r
405 IF (lx = 0) AND (ly = 0) AND (lz = 0) THEN GOTO 4\r
406 \r
407 \r
408 rndp = ABS(lx + ly + lz) MOD 9000\r
409 n1 = rn * 100\r
410 n2 = rn * 100\r
411 n3 = rn * 100\r
412 \r
413 gs1 = SIN(n1)\r
414 gc1 = COS(n1)\r
415 gs2 = SIN(n2)\r
416 gc2 = COS(n2)\r
417 gs3 = SIN(n3)\r
418 gc3 = COS(n3)\r
419 \r
420 \r
421 \r
422 siz = rn * 50 + 75\r
423 pi = 3.14\r
424 sbm = INT(rn * 3) + 1\r
425 \r
426 \r
427 dist = gdist(lx, ly, lz)\r
428 amo = 1\r
429 IF dist < 20000 THEN amo = 1\r
430 IF dist < 5000 THEN amo = 2\r
431 IF dist < 1000 THEN amo = 10\r
432 IF dist < 500 THEN amo = 50\r
433 \r
434 \r
435 \r
436 FOR a = 1 TO amo\r
437 \r
438   b = RND * 10\r
439   s = b * b / 30\r
440 \r
441   v1 = RND * (11.5 - b) / 3\r
442   v1p = v1 / 2\r
443 \r
444   ane = RND * (s / 2) / sbm * 2\r
445   sba = 2 * pi / sbm * INT(RND * sbm)\r
446 \r
447   x = (SIN(b - sba + ane) * s + RND * v1 - v1p) * siz\r
448   z = (COS(b - sba + ane) * s + RND * v1 - v1p) * siz\r
449   y = (RND * v1 - v1p) * siz\r
450 \r
451 \r
452   x1 = x * gc1 + z * gs1\r
453   z1 = z * gc1 - x * gs1\r
454 \r
455   y1 = y * gc2 + z1 * gs2\r
456   z2 = z1 * gc2 - y * gs2\r
457  \r
458   y2 = y1 * gc3 + x1 * gs3\r
459   x2 = x1 * gc3 - y1 * gs3\r
460 \r
461 \r
462   pla = INT(RND * nump) + 1\r
463  \r
464   px(pla) = x2 + lx\r
465   py(pla) = y2 + ly\r
466   pz(pla) = z2 + lz\r
467   pc(pla) = INT(RND * 15) + 1\r
468 NEXT a\r
469 \r
470 \r
471 4\r
472 END SUB\r
473 \r
474 SUB mkworld\r
475 \r
476 \r
477 FOR b = 1 TO 10\r
478   a = INT(RND * 100)\r
479   getCloudXYZ a, x, y, z\r
480   IF gdist(x, y, z) < vd * 3 THEN oftcloud(INT(RND * 4)) = a\r
481   galacloud x, y, z\r
482 NEXT b\r
483 \r
484 \r
485 IF vd < 4000000 THEN\r
486   LOCATE 3\r
487 '  PRINT "galaxy cloud zoom";\r
488 \r
489   FOR b = 0 TO 3\r
490     a = oftcloud(b)\r
491 '    PRINT a;\r
492     getCloudXYZ a, x, y, z\r
493     galacloud x, y, z\r
494   NEXT b\r
495 END IF\r
496 \r
497 IF vd < 10000 THEN\r
498   LOCATE 4, 1\r
499 '  PRINT "Galaxy zoom"\r
500   FOR b = 0 TO 19\r
501     x = oftGalaX(b)\r
502     y = oftGalaY(b)\r
503     z = oftGalaZ(b)\r
504 '    PRINT x; y; z\r
505     mkgalaxy x, y, z\r
506   NEXT b\r
507 ELSE\r
508 ' FOR b = 0 TO 3\r
509 '    oftGalaX(b) = 0\r
510 '    oftGalaY(b) = 0\r
511 '    oftGalaZ(b) = 0\r
512 '  NEXT b\r
513 END IF\r
514 \r
515 \r
516 END SUB\r
517 \r
518 SUB mousedemo\r
519 \r
520 \r
521 \r
522 cx = 150\r
523 cy = 100\r
524 maxmove = 50\r
525 100\r
526 frm = frm + 1\r
527 \r
528 \r
529 LOCATE 1, 1\r
530 PRINT cx, cy\r
531 PRINT frm\r
532 \r
533 CIRCLE (cx, cy), 10, 0\r
534 xp = getword(2)\r
535 putword 2, 0\r
536 yp = getword(4)\r
537 putword 4, 0\r
538 \r
539 \r
540 IF xp < -maxmove THEN xp = -maxmove\r
541 IF xp > maxmove THEN xp = maxmove\r
542 cx = cx + xp\r
543 \r
544 IF yp < -maxmove THEN yp = -maxmove\r
545 IF yp > maxmove THEN yp = maxmove\r
546 cy = cy + yp\r
547 \r
548 \r
549 CIRCLE (cx, cy), 10, 10\r
550 \r
551 \r
552 \r
553 SOUND 0, .05\r
554 GOTO 100\r
555 \r
556 \r
557 END SUB\r
558 \r
559 SUB putbyte (addr, dat)\r
560 \r
561 POKE (extADDR + addr), dat\r
562 END SUB\r
563 \r
564 SUB putword (addr, dat)\r
565 \r
566 b$ = HEX$(dat)\r
567 \r
568 2\r
569 IF LEN(b$) < 4 THEN b$ = "0" + b$: GOTO 2\r
570 \r
571 n1 = VAL("&H" + LEFT$(b$, 2))\r
572 n2 = VAL("&H" + RIGHT$(b$, 2))\r
573 \r
574 \r
575 POKE (extADDR + addr), n2\r
576 POKE (extADDR + addr + 1), n1\r
577 \r
578 END SUB\r
579 \r
580 FUNCTION rn\r
581 \r
582 rndp = rndp + 1\r
583 IF rndp > 10000 THEN rndp = 0\r
584 rn = rndval(rndp)\r
585 \r
586 END FUNCTION\r
587 \r
588 SUB rndinit\r
589 \r
590 \r
591 FOR a = 0 TO 10000\r
592   rndval(a) = RND\r
593 NEXT a\r
594 \r
595 rndp = 0\r
596 END SUB\r
597 \r
598 SUB start\r
599 \r
600 PRINT "Universe Explorer"\r
601 PRINT "by Svjatoslav Agejenko, n0@hot.ee"\r
602 PRINT "2003.12"\r
603 PRINT\r
604 PRINT "Use mouse to aim."\r
605 PRINT "Use keys: a, s, d, w  to move around,"\r
606 PRINT "1 2 3 4 5 6 7 to change speed multiplier."\r
607 PRINT "r - to start/stop demo."\r
608 PRINT "q - to quit program."\r
609 \r
610 PRINT "right mouse button, to move UP <> DOWN."\r
611 PRINT "both right & left mouse buttons pressed to move BACK <> FRONT."\r
612 \r
613 PRINT "At least P3 500 MHz, would be nice."\r
614 PRINT "Better CPU, more details and higher framerate."\r
615 PRINT "Requires mouse driver, and QBasic extension TSR"\r
616 PRINT "to be loaded first."\r
617 \r
618 PRINT\r
619 PRINT "In this program:"\r
620 \r
621 PRINT "Several stars, make up galaxy."\r
622 PRINT "Several galaxies makes metagalaxy."\r
623 PRINT "Several metagalaxies makes up universe."\r
624 \r
625 PRINT\r
626 PRINT "Press Any key To Continue."\r
627 a$ = INPUT$(1)\r
628 \r
629 startext\r
630 \r
631 \r
632 SCREEN 7, , , 1\r
633 \r
634 maxmove = 50\r
635 rndinit\r
636 myspd = 1000000\r
637 \r
638 END SUB\r
639 \r
640 SUB startext\r
641 \r
642 DEF SEG = 0     ' read first from interrupt table\r
643 \r
644 extSEG = PEEK(&H79 * 4 + 3) * 256\r
645 extSEG = extSEG + PEEK(&H79 * 4 + 2)\r
646 \r
647 PRINT "Segment is: " + HEX$(extSEG)\r
648 \r
649 extADDR = PEEK(&H79 * 4 + 1) * 256\r
650 extADDR = extADDR + PEEK(&H79 * 4 + 0)\r
651 \r
652 PRINT "relative address is:"; extADDR\r
653 \r
654 DEF SEG = extSEG\r
655 \r
656 IF getword(0) <> 1983 THEN\r
657   PRINT "FATAL ERROR:  you must load"\r
658   PRINT "QBasic extension TSR first!"\r
659   SYSTEM\r
660 END IF\r
661 \r
662 END SUB\r
663 \r
664 SUB timerAdd (element, time, value)\r
665 \r
666 FOR a = 0 TO 100\r
667   IF (timerTime(element, a) = 0) AND (timerValue(element, a) = 0) THEN GOTO timer3\r
668 NEXT a\r
669 timer3:\r
670 \r
671 timerTime(element, a) = time\r
672 timerValue(element, a) = value\r
673 \r
674 END SUB\r
675 \r
676 SUB timerdisp\r
677 LOCATE 1, 1\r
678 \r
679 FOR a = 0 TO 10\r
680   PRINT timerCplace(a), timerCtime(a), timerCvalue(a)\r
681 NEXT a\r
682 \r
683 END SUB\r
684 \r
685 SUB timerinit\r
686 timerLast = TIMER\r
687 \r
688 \r
689 FOR a = 1 TO 50\r
690   FOR b = 1 TO 100\r
691     timerTime(a, b) = 0\r
692     timerValue(a, b) = 0\r
693   NEXT b\r
694 NEXT a\r
695 \r
696 \r
697 END SUB\r
698 \r
699 SUB timerprocess\r
700 \r
701 timerCurrent = TIMER\r
702 timerDiff = timerCurrent - timerLast\r
703 timerLast = timerCurrent\r
704 \r
705 FOR a = 0 TO 50\r
706   ctim = timerCtime(a) + timerDiff\r
707   Cplace = timerCplace(a)\r
708 timer2:\r
709   IF timerTime(a, Cplace + 1) = -1 THEN\r
710     ctim = 0\r
711     Cplace = 0\r
712   END IF\r
713   IF timerTime(a, Cplace + 1) < ctim THEN\r
714     IF timerTime(a, Cplace + 1) = 0 THEN\r
715       timerCvalue(a) = timerValue(a, Cplace)\r
716       GOTO timer1:\r
717     END IF\r
718     Cplace = Cplace + 1\r
719     GOTO timer2\r
720   END IF\r
721 \r
722   v1 = timerValue(a, Cplace)\r
723   t1 = timerTime(a, Cplace)\r
724   v2 = timerValue(a, Cplace + 1)\r
725   t2 = timerTime(a, Cplace + 1)\r
726 \r
727   IF v1 = v2 THEN\r
728     timerCvalue(a) = v1\r
729   ELSE\r
730     Tdiff1 = t2 - t1\r
731     Tdiff2 = ctim - t1\r
732     Vdiff = v2 - v1\r
733     timerCvalue(a) = Tdiff2 / Tdiff1 * Vdiff + v1\r
734   END IF\r
735 timer1:\r
736   timerCplace(a) = Cplace\r
737   timerCtime(a) = ctim\r
738 NEXT a\r
739 \r
740 END SUB\r
741 \r