graphics/3D/KHK Intellektika 2004 demo/khkdemo5.BAS

   1 ' 3D Maze 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 startext ()\r
   8 DECLARE SUB control ()\r
   9 DECLARE SUB putbyte (addr!, dat!)\r
  10 DECLARE SUB putword (addr!, dat!)\r
  11 DECLARE FUNCTION getword! (addr!)\r
  12 DECLARE FUNCTION getbyte! (addr!)\r
  13 DECLARE SUB start ()\r
  14 DECLARE SUB animate ()\r
  15 \r
  16 DIM SHARED px(1 TO 5000)\r
  17 DIM SHARED py(1 TO 5000)\r
  18 DIM SHARED pz(1 TO 5000)\r
  19 DIM SHARED rpx(1 TO 5000)\r
  20 DIM SHARED rpy(1 TO 5000)\r
  21 DIM SHARED rpe(1 TO 5000)\r
  22 \r
  23 DIM SHARED l1(1 TO 5000)\r
  24 DIM SHARED l2(1 TO 5000)\r
  25 DIM SHARED lc(1 TO 5000)\r
  26 \r
  27 DIM SHARED nl, np\r
  28 \r
  29 DIM SHARED an1, an2, an3\r
  30 \r
  31 DIM SHARED tim\r
  32 \r
  33 DIM SHARED extSEG, extADDR\r
  34 \r
  35 DIM SHARED myx, myy, myz\r
  36 DIM SHARED myxs, myys, myzs\r
  37 DIM SHARED buttL, buttR\r
  38 DIM SHARED maxmove\r
  39 \r
  40 nl = 0\r
  41 np = 0\r
  42 \r
  43 start\r
  44 \r
  45 \r
  46 cx = 0\r
  47 cy = 0\r
  48 cz = 0\r
  49 \r
  50 np = 1\r
  51 px(1) = 0\r
  52 py(1) = 0\r
  53 pz(1) = 0\r
  54 \r
  55 1\r
  56 frm = frm + 1\r
  57 myx = SIN(frm / 30) * 100\r
  58 myz = COS(frm / 59) * 100\r
  59 myy = SIN(frm / 300)\r
  60 an1 = SIN(frm / 60)\r
  61 an2 = SIN(frm / 36) / 3\r
  62 \r
  63 \r
  64 np = np + 1\r
  65 px(np) = cx\r
  66 py(np) = cy\r
  67 pz(np) = cz\r
  68 \r
  69 \r
  70 \r
  71 nl = nl + 1\r
  72 l1(nl) = np\r
  73 l2(nl) = np - 1\r
  74 lc(nl) = INT(RND * 15) + 1\r
  75 'lc(nl) = ABS(cx / 20)\r
  76 \r
  77 \r
  78 \r
  79 va = INT(RND * 3)\r
  80 \r
  81 SELECT CASE va\r
  82 CASE 0\r
  83   cx = RND * 500 - 250\r
  84 CASE 1\r
  85   cy = RND * 100 - 50\r
  86 CASE 2\r
  87   cz = RND * 500 - 250\r
  88 END SELECT\r
  89 \r
  90 \r
  91 'control\r
  92 animate\r
  93 \r
  94 PCOPY 0, 1\r
  95 CLS\r
  96 \r
  97 IF frm > 1200 THEN GOTO 200\r
  98 GOTO 1\r
  99 200\r
 100 \r
 101 CHAIN "khkdemo6.bas"\r
 102 \r
 103 SUB animate\r
 104 \r
 105 \r
 106 s1 = SIN(an1)\r
 107 s2 = SIN(an2)\r
 108 s3 = SIN(an3)\r
 109 \r
 110 c1 = COS(an1)\r
 111 c2 = COS(an2)\r
 112 c3 = COS(an3)\r
 113 \r
 114 \r
 115 \r
 116 FOR a = 1 TO np\r
 117   x = px(a) - myx\r
 118   y = py(a) - myy\r
 119   z = pz(a) - myz\r
 120    \r
 121  \r
 122   x1 = x * c1 + z * s1\r
 123   z1 = z * c1 - x * s1\r
 124 \r
 125   y1 = y * c2 + z1 * s2\r
 126   z2 = z1 * c2 - y * s2\r
 127 \r
 128 \r
 129 '  z2 = z2 + 10\r
 130   \r
 131   IF z2 > 3 THEN\r
 132     rpe(a) = 1\r
 133     rpx(a) = x1 / z2 * 130 + 160\r
 134     rpy(a) = y1 / z2 * 130 + 100\r
 135   ELSE\r
 136     rpe(a) = 0\r
 137   END IF\r
 138 \r
 139 NEXT a\r
 140 \r
 141 \r
 142 FOR a = 1 TO nl\r
 143 \r
 144   p1 = l1(a)\r
 145   p2 = l2(a)\r
 146   IF (rpe(p1) = 1) AND (rpe(p2) = 1) THEN LINE (rpx(p1), rpy(p1))-(rpx(p2), rpy(p2)), lc(a)\r
 147 \r
 148 NEXT a\r
 149 \r
 150 \r
 151 END SUB\r
 152 \r
 153 SUB control\r
 154 \r
 155 \r
 156 IF getbyte(8) <> 0 THEN\r
 157   putbyte 8, 0\r
 158   xp = getword(2)\r
 159   putword 2, 0\r
 160   yp = getword(4)\r
 161   putword 4, 0\r
 162   butt = getword(6)\r
 163   putword 6, 0\r
 164   buttL = 0\r
 165   buttR = 0\r
 166   IF butt = 1 THEN buttL = 1\r
 167   IF butt = 2 THEN buttR = 1\r
 168   IF butt = 3 THEN buttL = 1: buttR = 1\r
 169 \r
 170 \r
 171   IF buttR = 1 THEN\r
 172     IF buttL = 1 THEN\r
 173       myxs = myxs + SIN(an1) * yp / 4\r
 174       myzs = myzs - COS(an1) * yp / 4\r
 175       GOTO 3\r
 176     END IF\r
 177     myys = myys + yp / 4\r
 178 3\r
 179     yp = 0\r
 180   END IF\r
 181 \r
 182 END IF\r
 183 \r
 184 \r
 185 \r
 186 \r
 187 IF xp < -maxmove THEN xp = -maxmove\r
 188 IF xp > maxmove THEN xp = maxmove\r
 189 an1 = an1 - xp / 150\r
 190 \r
 191 IF yp < -maxmove THEN yp = -maxmove\r
 192 IF yp > maxmove THEN yp = maxmove\r
 193 an2 = an2 - yp / 150\r
 194 \r
 195 \r
 196 \r
 197 a$ = INKEY$\r
 198 \r
 199 IF a$ = "a" THEN myxs = myxs - COS(an1): myzs = myzs - SIN(an1)\r
 200 IF a$ = "d" THEN myxs = myxs + COS(an1): myzs = myzs + SIN(an1)\r
 201 IF a$ = "w" THEN myxs = myxs - SIN(an1): myzs = myzs + COS(an1)\r
 202 IF a$ = "s" THEN myxs = myxs + SIN(an1): myzs = myzs - COS(an1)\r
 203 IF a$ = "q" THEN SYSTEM\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\r
 210 myz = myz + myzs\r
 211 myy = myy + myys\r
 212 \r
 213 END SUB\r
 214 \r
 215 FUNCTION getbyte (addr)\r
 216 getbyte = PEEK(extADDR + addr)\r
 217 END FUNCTION\r
 218 \r
 219 FUNCTION getword (addr)\r
 220 a = PEEK(extADDR + addr)\r
 221 b = PEEK(extADDR + addr + 1)\r
 222 \r
 223 \r
 224 c$ = HEX$(a)\r
 225 IF LEN(c$) = 1 THEN c$ = "0" + c$\r
 226 IF LEN(c$) = 0 THEN c$ = "00"\r
 227 \r
 228 \r
 229 c = VAL("&H" + HEX$(b) + c$)\r
 230 \r
 231 getword = c\r
 232 END FUNCTION\r
 233 \r
 234 SUB mousedemo\r
 235 \r
 236 \r
 237 \r
 238 cx = 150\r
 239 cy = 100\r
 240 maxmove = 50\r
 241 100\r
 242 frm = frm + 1\r
 243 \r
 244 \r
 245 LOCATE 1, 1\r
 246 PRINT cx, cy\r
 247 PRINT frm\r
 248 \r
 249 CIRCLE (cx, cy), 10, 0\r
 250 xp = getword(2)\r
 251 putword 2, 0\r
 252 yp = getword(4)\r
 253 putword 4, 0\r
 254 \r
 255 \r
 256 IF xp < -maxmove THEN xp = -maxmove\r
 257 IF xp > maxmove THEN xp = maxmove\r
 258 cx = cx + xp\r
 259 \r
 260 IF yp < -maxmove THEN yp = -maxmove\r
 261 IF yp > maxmove THEN yp = maxmove\r
 262 cy = cy + yp\r
 263 \r
 264 \r
 265 CIRCLE (cx, cy), 10, 10\r
 266 \r
 267 \r
 268 \r
 269 SOUND 0, .05\r
 270 GOTO 100\r
 271 \r
 272 \r
 273 END SUB\r
 274 \r
 275 SUB putbyte (addr, dat)\r
 276 \r
 277 POKE (extADDR + addr), dat\r
 278 END SUB\r
 279 \r
 280 SUB putword (addr, dat)\r
 281 \r
 282 b$ = HEX$(dat)\r
 283 \r
 284 2\r
 285 IF LEN(b$) < 4 THEN b$ = "0" + b$: GOTO 2\r
 286 \r
 287 n1 = VAL("&H" + LEFT$(b$, 2))\r
 288 n2 = VAL("&H" + RIGHT$(b$, 2))\r
 289 \r
 290 \r
 291 POKE (extADDR + addr), n2\r
 292 POKE (extADDR + addr + 1), n1\r
 293 \r
 294 END SUB\r
 295 \r
 296 SUB start\r
 297 ' startext\r
 298 \r
 299 \r
 300 SCREEN 7, , , 1\r
 301 \r
 302 maxmove = 50\r
 303 \r
 304 END SUB\r
 305 \r
 306 SUB startext\r
 307 \r
 308 DEF SEG = 0     ' read first from interrupt table\r
 309 \r
 310 extSEG = PEEK(&H79 * 4 + 3) * 256\r
 311 extSEG = extSEG + PEEK(&H79 * 4 + 2)\r
 312 \r
 313 PRINT "Segment is: " + HEX$(extSEG)\r
 314 \r
 315 extADDR = PEEK(&H79 * 4 + 1) * 256\r
 316 extADDR = extADDR + PEEK(&H79 * 4 + 0)\r
 317 \r
 318 PRINT "relative address is:"; extADDR\r
 319 \r
 320 DEF SEG = extSEG\r
 321 \r
 322 IF getword(0) <> 1983 THEN\r
 323   PRINT "FATAL ERROR:  you must load"\r
 324   PRINT "QBasic extension TSR first!"\r
 325   SYSTEM\r
 326 END IF\r
 327 \r
 328 END SUB\r
 329 \r