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