graphics/3D/3dexplor/explgala.bas

   1 ' Galaxy explorer\r
   2 ' made by Svjatoslav Agejenko\r
   3 ' in 2003.12\r
   4 ' E-Mail: svjatoslavagejenko@gmail.com\r
   5 ' H-Page: svjatoslav.eu\r
   6  \r
   7 DECLARE SUB temp ()\r
   8 DECLARE SUB mkgalaxy (x!, y!, z!)\r
   9 DECLARE SUB rndinit ()\r
  10 DECLARE FUNCTION rn! ()\r
  11 DECLARE SUB disp ()\r
  12 DECLARE SUB startext ()\r
  13 DECLARE SUB control ()\r
  14 DECLARE SUB putbyte (addr!, dat!)\r
  15 DECLARE SUB putword (addr!, dat!)\r
  16 DECLARE FUNCTION getword! (addr!)\r
  17 DECLARE FUNCTION getbyte! (addr!)\r
  18 DECLARE SUB start ()\r
  19 DECLARE SUB animate ()\r
  20 \r
  21 \r
  22 DIM SHARED an1, an2, an3\r
  23 \r
  24 DIM SHARED tim\r
  25 \r
  26 DIM SHARED extSEG, extADDR\r
  27 \r
  28 DIM SHARED myx, myy, myz\r
  29 DIM SHARED myxs, myys, myzs\r
  30 DIM SHARED buttL, buttR\r
  31 DIM SHARED maxmove\r
  32 \r
  33 \r
  34 DIM SHARED zoom\r
  35 DIM SHARED rndval(0 TO 10000)\r
  36 DIM SHARED rndp\r
  37 \r
  38 \r
  39 DIM SHARED px(1 TO 12000)\r
  40 DIM SHARED py(1 TO 12000)\r
  41 DIM SHARED pz(1 TO 12000)\r
  42 DIM SHARED pc(1 TO 12000)\r
  43 DIM SHARED nump\r
  44 \r
  45 DIM SHARED tempr(0 TO 10)\r
  46 \r
  47 \r
  48 nl = 0\r
  49 np = 0\r
  50 \r
  51 start\r
  52 \r
  53 \r
  54 cx = 0\r
  55 cy = 0\r
  56 cz = 0\r
  57 \r
  58 \r
  59 \r
  60 nump = 0\r
  61 mkgalaxy 0, 0, 0\r
  62 1\r
  63 \r
  64 \r
  65 \r
  66 \r
  67 va = INT(RND * 3)\r
  68 \r
  69 SELECT CASE va\r
  70 CASE 0\r
  71   cx = RND * 500 - 250\r
  72 CASE 1\r
  73   cy = RND * 100 - 50\r
  74 CASE 2\r
  75   cz = RND * 500 - 250\r
  76 END SELECT\r
  77 \r
  78 \r
  79 control\r
  80 disp\r
  81 \r
  82 PCOPY 0, 1\r
  83 CLS\r
  84 GOTO 1\r
  85 \r
  86 SUB control\r
  87 \r
  88 \r
  89 IF getbyte(8) <> 0 THEN\r
  90   putbyte 8, 0\r
  91   xp = getword(2)\r
  92   putword 2, 0\r
  93   yp = getword(4)\r
  94   putword 4, 0\r
  95   butt = getword(6)\r
  96   putword 6, 0\r
  97   buttL = 0\r
  98   buttR = 0\r
  99   IF butt = 1 THEN buttL = 1\r
 100   IF butt = 2 THEN buttR = 1\r
 101   IF butt = 3 THEN buttL = 1: buttR = 1\r
 102 \r
 103 \r
 104   IF buttR = 1 THEN\r
 105     IF buttL = 1 THEN\r
 106       myxs = myxs + SIN(an1) * yp / 4\r
 107       myzs = myzs - COS(an1) * yp / 4\r
 108       GOTO 3\r
 109     END IF\r
 110     myys = myys + yp / 4\r
 111 3\r
 112     yp = 0\r
 113   END IF\r
 114 \r
 115 END IF\r
 116 \r
 117 \r
 118 \r
 119 \r
 120 IF xp < -maxmove THEN xp = -maxmove\r
 121 IF xp > maxmove THEN xp = maxmove\r
 122 an1 = an1 - xp / 150\r
 123 \r
 124 IF yp < -maxmove THEN yp = -maxmove\r
 125 IF yp > maxmove THEN yp = maxmove\r
 126 an2 = an2 - yp / 150\r
 127 \r
 128 \r
 129 \r
 130 a$ = INKEY$\r
 131 \r
 132 IF a$ = "a" THEN myxs = myxs - COS(an1): myzs = myzs - SIN(an1)\r
 133 IF a$ = "d" THEN myxs = myxs + COS(an1): myzs = myzs + SIN(an1)\r
 134 IF a$ = "w" THEN myxs = myxs - SIN(an1): myzs = myzs + COS(an1)\r
 135 IF a$ = "s" THEN myxs = myxs + SIN(an1): myzs = myzs - COS(an1)\r
 136 IF a$ = "q" THEN SYSTEM\r
 137 \r
 138 \r
 139 myxs = myxs / 1.1\r
 140 myys = myys / 1.1\r
 141 myzs = myzs / 1.1\r
 142 \r
 143 myx = myx + myxs\r
 144 myz = myz + myzs\r
 145 myy = myy + myys\r
 146 \r
 147 END SUB\r
 148 \r
 149 SUB disp\r
 150 \r
 151 s1 = SIN(an1)\r
 152 c1 = COS(an1)\r
 153 s2 = SIN(an2)\r
 154 c2 = COS(an2)\r
 155 \r
 156 \r
 157 FOR a = 1 TO nump\r
 158 \r
 159                        \r
 160   x = px(a) - myx\r
 161   y = py(a) - myy\r
 162   z = pz(a) - myz\r
 163   \r
 164 \r
 165   x1 = x * c1 + z * s1\r
 166   z1 = z * c1 - x * s1\r
 167 \r
 168   y1 = y * c2 + z1 * s2\r
 169   z2 = z1 * c2 - y * s2\r
 170 \r
 171 \r
 172 '  z2 = z2 + 10\r
 173  \r
 174   IF z2 > 3 THEN\r
 175     rpx = x1 / z2 * 130 + 160\r
 176     rpy = y1 / z2 * 130 + 100\r
 177     PSET (rpx, rpy), pc(a)\r
 178  \r
 179   END IF\r
 180 \r
 181 \r
 182 NEXT a\r
 183 END SUB\r
 184 \r
 185 FUNCTION getbyte (addr)\r
 186 getbyte = PEEK(extADDR + addr)\r
 187 END FUNCTION\r
 188 \r
 189 FUNCTION getword (addr)\r
 190 a = PEEK(extADDR + addr)\r
 191 b = PEEK(extADDR + addr + 1)\r
 192 \r
 193 \r
 194 c$ = HEX$(a)\r
 195 IF LEN(c$) = 1 THEN c$ = "0" + c$\r
 196 IF LEN(c$) = 0 THEN c$ = "00"\r
 197 \r
 198 \r
 199 c = VAL("&H" + HEX$(b) + c$)\r
 200 \r
 201 getword = c\r
 202 END FUNCTION\r
 203 \r
 204 SUB mkgalaxy (lx, ly, lz)\r
 205 \r
 206 \r
 207 n1 = rn * 10\r
 208 n2 = rn * 10\r
 209 \r
 210 gs1 = SIN(n1)\r
 211 gc1 = COS(n1)\r
 212 gs2 = SIN(n2)\r
 213 gc2 = COS(n2)\r
 214 \r
 215 \r
 216 \r
 217 rndp = 0\r
 218 siz = 100\r
 219 pi = 3.14\r
 220 sbm = 3\r
 221 \r
 222 \r
 223 FOR a = 1 TO 10000\r
 224 \r
 225   b = rn * 10\r
 226   s = b * b / 30\r
 227 \r
 228   v1 = rn * (11.5 - b) / 3\r
 229   v1p = v1 / 2\r
 230 \r
 231   ane = rn * (s / 2) / sbm * 2\r
 232   sba = 2 * pi / sbm * INT(rn * sbm)\r
 233 \r
 234   x = (SIN(b - sba + ane) * s + rn * v1 - v1p) * siz\r
 235   z = (COS(b - sba + ane) * s + rn * v1 - v1p) * siz\r
 236   y = (rn * v1 - v1p) * siz\r
 237 \r
 238 \r
 239   x1 = x * gc1 + z * gs1\r
 240   z1 = z * gc1 - x * gs1\r
 241 \r
 242   y1 = y * gc2 + z1 * gs2\r
 243   z2 = z1 * gc2 - y * gs2\r
 244 \r
 245 \r
 246   nump = nump + 1\r
 247 \r
 248   px(nump) = x1 + lx\r
 249   py(nump) = y1 + ly\r
 250   pz(nump) = z2 + lz\r
 251   pc(nump) = INT(RND * 15) + 1\r
 252 NEXT a\r
 253 \r
 254 END SUB\r
 255 \r
 256 SUB mousedemo\r
 257 \r
 258 \r
 259 \r
 260 cx = 150\r
 261 cy = 100\r
 262 maxmove = 50\r
 263 100\r
 264 frm = frm + 1\r
 265 \r
 266 \r
 267 LOCATE 1, 1\r
 268 PRINT cx, cy\r
 269 PRINT frm\r
 270 \r
 271 CIRCLE (cx, cy), 10, 0\r
 272 xp = getword(2)\r
 273 putword 2, 0\r
 274 yp = getword(4)\r
 275 putword 4, 0\r
 276 \r
 277 \r
 278 IF xp < -maxmove THEN xp = -maxmove\r
 279 IF xp > maxmove THEN xp = maxmove\r
 280 cx = cx + xp\r
 281 \r
 282 IF yp < -maxmove THEN yp = -maxmove\r
 283 IF yp > maxmove THEN yp = maxmove\r
 284 cy = cy + yp\r
 285 \r
 286 \r
 287 CIRCLE (cx, cy), 10, 10\r
 288 \r
 289 \r
 290 \r
 291 SOUND 0, .05\r
 292 GOTO 100\r
 293 \r
 294 \r
 295 END SUB\r
 296 \r
 297 SUB putbyte (addr, dat)\r
 298 \r
 299 POKE (extADDR + addr), dat\r
 300 END SUB\r
 301 \r
 302 SUB putword (addr, dat)\r
 303 \r
 304 b$ = HEX$(dat)\r
 305 \r
 306 2\r
 307 IF LEN(b$) < 4 THEN b$ = "0" + b$: GOTO 2\r
 308 \r
 309 n1 = VAL("&H" + LEFT$(b$, 2))\r
 310 n2 = VAL("&H" + RIGHT$(b$, 2))\r
 311 \r
 312 \r
 313 POKE (extADDR + addr), n2\r
 314 POKE (extADDR + addr + 1), n1\r
 315 \r
 316 END SUB\r
 317 \r
 318 FUNCTION rn\r
 319 \r
 320 rndp = rndp + 1\r
 321 IF rndp > 10000 THEN rndp = 0\r
 322 rn = rndval(rndp)\r
 323 \r
 324 END FUNCTION\r
 325 \r
 326 SUB rndinit\r
 327 \r
 328 \r
 329 FOR a = 0 TO 10000\r
 330   rndval(a) = RND\r
 331 NEXT a\r
 332 \r
 333 rndp = 0\r
 334 END SUB\r
 335 \r
 336 SUB start\r
 337 \r
 338 \r
 339 startext\r
 340 \r
 341 \r
 342 SCREEN 7, , , 1\r
 343 \r
 344 maxmove = 50\r
 345 rndinit\r
 346 \r
 347 END SUB\r
 348 \r
 349 SUB startext\r
 350 \r
 351 DEF SEG = 0     ' read first from interrupt table\r
 352 \r
 353 extSEG = PEEK(&H79 * 4 + 3) * 256\r
 354 extSEG = extSEG + PEEK(&H79 * 4 + 2)\r
 355 \r
 356 PRINT "Segment is: " + HEX$(extSEG)\r
 357 \r
 358 extADDR = PEEK(&H79 * 4 + 1) * 256\r
 359 extADDR = extADDR + PEEK(&H79 * 4 + 0)\r
 360 \r
 361 PRINT "relative address is:"; extADDR\r
 362 \r
 363 DEF SEG = extSEG\r
 364 \r
 365 IF getword(0) <> 1983 THEN\r
 366   PRINT "FATAL ERROR:  you must load"\r
 367   PRINT "QBasic extension TSR first!"\r
 368   SYSTEM\r
 369 END IF\r
 370 \r
 371 END SUB\r
 372 \r