graphics/3D/3dSynthezier/bin/3dparse.bas

   1 ' by Svjatoslav Agejenko\r
   2 ' homeage: http://svjatoslav.eu\r
   3 ' e-mail: svjatoslav@svjatoslav.eu\r
   4 \r
   5 ' Before running, make sure include path is correct. See below.\r
   6 \r
   7 DECLARE SUB parsel (a$)\r
   8 DECLARE SUB stat2 (b!)\r
   9 DECLARE SUB stat ()\r
  10 DECLARE SUB getchc (a$, b!)\r
  11 DECLARE SUB start ()\r
  12 DECLARE SUB qui ()\r
  13 DECLARE SUB flushpoly (a!)\r
  14 DECLARE SUB usemtl (a$)\r
  15 DECLARE SUB flushp ()\r
  16 DECLARE SUB parse (a$)\r
  17 DECLARE SUB geth (b!)\r
  18 DECLARE SUB cmd (a$)\r
  19 DECLARE SUB getson (a$)\r
  20 DIM SHARED px(1 TO 1000)\r
  21 DIM SHARED py(1 TO 1000)\r
  22 DIM SHARED pz(1 TO 1000)\r
  23 DIM SHARED nump\r
  24 DIM SHARED numpa\r
  25 DIM SHARED numpo\r
  26 \r
  27 DIM SHARED fil(1 TO 100)\r
  28 DIM SHARED mitus\r
  29 DIM SHARED sona$(1 TO 20)\r
  30 DIM SHARED res\r
  31 \r
  32 DIM SHARED mtlm\r
  33 DIM SHARED mtl$(1 TO 50)\r
  34 DIM SHARED mtlp1(1 TO 50, 1 TO 100)\r
  35 DIM SHARED mtlp2(1 TO 50, 1 TO 100)\r
  36 DIM SHARED mtlp3(1 TO 50, 1 TO 100)\r
  37 DIM SHARED mtlp4(1 TO 50, 1 TO 100)\r
  38 DIM SHARED mtll(1 TO 50)\r
  39 DIM SHARED cmtl\r
  40 \r
  41 DIM SHARED stkf(1 TO 500)\r
  42 DIM SHARED stks(1 TO 500)\r
  43 DIM SHARED stkp, fc, ipath$\r
  44 \r
  45 DIM SHARED chc$(1 TO 10, 1 TO 500)\r
  46 DIM SHARED chcl(1 TO 10)\r
  47 DIM SHARED chcf$(1 TO 10)\r
  48 DIM SHARED chct(1 TO 10)\r
  49 DIM SHARED chctim\r
  50 DIM SHARED mtmprs\r
  51 DIM SHARED tmr\r
  52 \r
  53 DIM SHARED var$(0 TO 100)\r
  54 DIM SHARED flag(1 TO 50, 0 TO 9)\r
  55 DIM SHARED cstatt, cstatm\r
  56 \r
  57 \r
  58 ipath$ = "c:\3dgen\include\"                ' include path\r
  59 \r
  60 \r
  61 \r
  62 start\r
  63 \r
  64 IF COMMAND$ = "" THEN END\r
  65 CLS\r
  66 \r
  67 cmd "obj ~" + COMMAND$\r
  68 qui\r
  69 CLOSE #res\r
  70 fil(res) = 0\r
  71 \r
  72 PRINT "done"\r
  73 SYSTEM\r
  74 \r
  75 SUB cmd (z$)\r
  76 a$ = z$\r
  77 IF LEFT$(a$, 1) = "?" THEN\r
  78 IF flag(mtmprs, VAL(RIGHT$(LEFT$(a$, 2), 1))) = 1 THEN a$ = RIGHT$(a$, LEN(a$) - 3) ELSE GOTO 10\r
  79 END IF\r
  80 getson a$\r
  81 SELECT CASE sona$(1)\r
  82 CASE "end"\r
  83 qui\r
  84 PRINT "terminated from file"\r
  85 SYSTEM\r
  86 \r
  87 CASE "warn"\r
  88 COLOR 12\r
  89 PRINT sona$(2)\r
  90 COLOR 7\r
  91 b$ = INPUT$(1)\r
  92 \r
  93 CASE "p"\r
  94 nump = nump + 1\r
  95 numpa = numpa + 1\r
  96 x = VAL(sona$(2))\r
  97 y = VAL(sona$(3))\r
  98 z = VAL(sona$(4))\r
  99 \r
 100 FOR b = stkp TO 1 STEP -1\r
 101 SELECT CASE stkf(b)\r
 102 CASE 1\r
 103 c1 = SIN(stks(b) / fc)\r
 104 s1 = COS(stks(b) / fc)\r
 105 z1 = x * c1 + z * s1\r
 106 x1 = x * s1 - z * c1\r
 107 x = x1\r
 108 z = z1\r
 109 \r
 110 CASE 2\r
 111 c1 = SIN(stks(b) / fc)\r
 112 s1 = COS(stks(b) / fc)\r
 113 z1 = y * c1 + z * s1\r
 114 y1 = y * s1 - z * c1\r
 115 y = y1\r
 116 z = z1\r
 117 \r
 118 CASE 3\r
 119 s1 = SIN(stks(b) / fc)\r
 120 c1 = COS(stks(b) / fc)\r
 121 y1 = y * c1 + x * s1\r
 122 x1 = y * s1 - x * c1\r
 123 x = x1\r
 124 y = y1\r
 125 \r
 126 CASE 10\r
 127 x = x + stks(b)\r
 128 CASE 11\r
 129 y = y + stks(b)\r
 130 CASE 12\r
 131 z = z + stks(b)\r
 132 CASE 20\r
 133 x = x - stks(b)\r
 134 CASE 21\r
 135 y = y - stks(b)\r
 136 CASE 22\r
 137 z = z - stks(b)\r
 138 CASE 30\r
 139 x = x * stks(b)\r
 140 CASE 31\r
 141 y = y * stks(b)\r
 142 CASE 32\r
 143 z = z * stks(b)\r
 144 END SELECT\r
 145 NEXT b\r
 146 \r
 147 px(nump) = x\r
 148 py(nump) = y\r
 149 pz(nump) = z\r
 150 IF nump > 900 THEN flushp\r
 151 \r
 152 CASE "here"\r
 153 numpo = numpa\r
 154 \r
 155 CASE "mtl"\r
 156 usemtl sona$(2)\r
 157 \r
 158 CASE "mtlrnd"\r
 159 b = INT(RND * (mitus - 1)) + 2\r
 160 usemtl sona$(b)\r
 161 \r
 162 CASE "f"\r
 163 IF mtll(cmtl) > 90 THEN flushpoly cmtl\r
 164 b = mtll(cmtl)\r
 165 b = b + 1\r
 166 mtll(cmtl) = b\r
 167 mtlp1(cmtl, b) = VAL(sona$(2)) + numpo\r
 168 mtlp2(cmtl, b) = VAL(sona$(3)) + numpo\r
 169 mtlp3(cmtl, b) = VAL(sona$(4)) + numpo\r
 170 IF sona$(5) = "" THEN mtlp4(cmtl, b) = -32000 ELSE mtlp4(cmtl, b) = VAL(sona$(5)) + numpo\r
 171 \r
 172 CASE "obj"\r
 173 d = stkp\r
 174 FOR a = mitus TO 3 STEP -1\r
 175 b$ = LEFT$(sona$(a), 2)\r
 176 c = VAL(RIGHT$(sona$(a), LEN(sona$(a)) - 2))\r
 177 stkp = stkp + 1\r
 178 stks(stkp) = c\r
 179 SELECT CASE b$\r
 180 CASE "xz"\r
 181 stkf(stkp) = 1\r
 182 CASE "yz"\r
 183 stkf(stkp) = 2\r
 184 CASE "xy"\r
 185 stkf(stkp) = 3\r
 186 CASE "x+"\r
 187 stkf(stkp) = 10\r
 188 CASE "y+"\r
 189 stkf(stkp) = 11\r
 190 CASE "z+"\r
 191 stkf(stkp) = 12\r
 192 CASE "x-"\r
 193 stkf(stkp) = 20\r
 194 CASE "y-"\r
 195 stkf(stkp) = 21\r
 196 CASE "z-"\r
 197 stkf(stkp) = 22\r
 198 CASE "x*"\r
 199 stkf(stkp) = 30\r
 200 CASE "y*"\r
 201 stkf(stkp) = 31\r
 202 CASE "z*"\r
 203 stkf(stkp) = 32\r
 204 END SELECT\r
 205 NEXT a\r
 206 \r
 207 a$ = sona$(2)\r
 208 mtmprs = mtmprs + 1\r
 209 cstatt = cstatt + 1\r
 210 LOCATE 10 + mtmprs, 1\r
 211 PRINT a$\r
 212 getchc a$, b\r
 213 c = 1\r
 214 2\r
 215 d$ = chc$(b, c)\r
 216 cmd d$\r
 217 IF chcf$(b) <> a$ THEN getchc a$, b\r
 218 c = c + 1\r
 219 IF c <= chcl(b) THEN GOTO 2\r
 220 tmr = tmr + 1\r
 221 IF tmr > 20 THEN tmr = 0: stat\r
 222 LOCATE 10 + mtmprs, 1\r
 223 PRINT SPACE$(LEN(a$))\r
 224 mtmprs = mtmprs - 1\r
 225 \r
 226 stkp = d\r
 227 \r
 228 CASE "#"\r
 229 \r
 230 CASE "out"\r
 231 geth res\r
 232 OPEN sona$(2) + ".obj" FOR OUTPUT AS #res\r
 233 PRINT #res, "mtllib result.mtl"\r
 234 \r
 235 CASE "rnd"\r
 236 b = INT(RND * (mitus - 1)) + 2\r
 237 c$ = sona$(b)\r
 238 f$ = ""\r
 239 FOR d = 1 TO LEN(c$)\r
 240 e$ = RIGHT$(LEFT$(c$, d), 1)\r
 241 IF e$ = "^" THEN e$ = " "\r
 242 f$ = f$ + e$\r
 243 NEXT d\r
 244 cmd f$\r
 245 \r
 246 CASE "set"\r
 247 var$(VAL(sona$(2))) = sona$(3)\r
 248 \r
 249 CASE "cmp"\r
 250 IF sona$(3) = sona$(4) THEN b = 1 ELSE b = 0\r
 251 flag(mtmprs, VAL(sona$(2))) = b\r
 252 END SELECT\r
 253 \r
 254 10\r
 255 END SUB\r
 256 \r
 257 SUB flushp\r
 258 \r
 259 FOR a = 1 TO nump\r
 260 PRINT #res, "v " + STR$(px(a)) + " " + STR$(py(a)) + " " + STR$(-pz(a))\r
 261 NEXT a\r
 262 nump = 0\r
 263 \r
 264 END SUB\r
 265 \r
 266 SUB flushpoly (a)\r
 267 IF mtll(a) = 0 THEN GOTO 5\r
 268 \r
 269 PRINT #res, "usemtl " + mtl$(a)\r
 270 FOR b = 1 TO mtll(a)\r
 271 c$ = "f " + STR$(mtlp1(a, b) + 1) + STR$(mtlp2(a, b) + 1) + STR$(mtlp3(a, b) + 1)\r
 272 IF mtlp4(a, b) <> -32000 THEN c$ = c$ + STR$(mtlp4(a, b) + 1)\r
 273 PRINT #res, c$\r
 274 NEXT b\r
 275 mtll(a) = 0\r
 276 \r
 277 5\r
 278 END SUB\r
 279 \r
 280 SUB getchc (a$, b)\r
 281 'DIM SHARED cstatt, cstatm\r
 282 FOR c = 1 TO 10\r
 283 IF chcf$(c) = a$ THEN b = c: GOTO 6\r
 284 NEXT c\r
 285 \r
 286 d = 32000\r
 287 FOR c = 1 TO 10\r
 288 IF chct(c) < d THEN d = chct(c): e = c\r
 289 NEXT c\r
 290 g = 0\r
 291 geth f\r
 292 'PRINT "file " + a$ + " loaded"\r
 293 cstatm = cstatm + 1\r
 294 b$ = a$\r
 295 IF LEFT$(b$, 1) = "~" THEN b$ = RIGHT$(b$, LEN(b$) - 1) ELSE b$ = ipath$ + b$\r
 296 OPEN b$ + ".3d" FOR INPUT AS #f\r
 297 8\r
 298 IF EOF(f) <> 0 THEN GOTO 7\r
 299 LINE INPUT #f, c$\r
 300 IF (LEFT$(c$, 1) <> "#") AND (c$ <> SPACE$(LEN(c$))) THEN g = g + 1: chc$(e, g) = c$\r
 301 GOTO 8\r
 302 7\r
 303 CLOSE #f\r
 304 fil(f) = 0\r
 305 chcl(e) = g\r
 306 b = e\r
 307 chcf$(e) = a$\r
 308 stat\r
 309 6\r
 310 chctim = chctim + 1\r
 311 chct(b) = chctim\r
 312 \r
 313 IF chctim > 10000 THEN\r
 314 FOR c = 1 TO 10\r
 315 chct(c) = chct(c) / 2\r
 316 NEXT c\r
 317 chctim = chctim / 2\r
 318 END IF\r
 319 END SUB\r
 320 \r
 321 SUB geth (b)\r
 322 \r
 323 FOR a = 1 TO 100\r
 324 IF fil(a) = 0 THEN fil(a) = 1: b = a: GOTO 1\r
 325 NEXT a\r
 326 1\r
 327 'PRINT "handle ", b, " allocated"\r
 328 \r
 329 END SUB\r
 330 \r
 331 SUB getson (a$)\r
 332 b$ = a$ + " "\r
 333 \r
 334 FOR a = 1 TO 20\r
 335 sona$(a) = ""\r
 336 NEXT a\r
 337 \r
 338 mitus = 0\r
 339 e = 1\r
 340 FOR c = 1 TO LEN(b$)\r
 341 d$ = RIGHT$(LEFT$(b$, c), 1)\r
 342 IF d$ = " " OR d$ = CHR$(9) THEN\r
 343 e = 1\r
 344 ELSE\r
 345 IF e = 1 THEN mitus = mitus + 1\r
 346 sona$(mitus) = sona$(mitus) + d$\r
 347 e = 0\r
 348 END IF\r
 349 NEXT c\r
 350 \r
 351 FOR c = 1 TO mitus\r
 352 IF LEFT$(sona$(c), 1) = "%" THEN\r
 353 sona$(c) = var$(VAL(RIGHT$(sona$(c), LEN(sona$(c)) - 1)))\r
 354 END IF\r
 355 NEXT c\r
 356 END SUB\r
 357 \r
 358 SUB qui\r
 359 \r
 360 flushp\r
 361 FOR a = 1 TO mtlm\r
 362 flushpoly a\r
 363 NEXT a\r
 364 stat\r
 365 END SUB\r
 366 \r
 367 SUB start\r
 368 RANDOMIZE TIMER\r
 369 \r
 370 FOR a = 1 TO 50\r
 371 FOR b = 0 TO 9\r
 372 flag(a, b) = 0\r
 373 NEXT b\r
 374 NEXT a\r
 375 \r
 376 FOR a = 0 TO 100\r
 377 var$(a) = ""\r
 378 NEXT a\r
 379 \r
 380 FOR a = 1 TO 10\r
 381 FOR b = 1 TO 500\r
 382 chc$(a, b) = ""\r
 383 NEXT b\r
 384 chcl(a) = 0\r
 385 chcf$(a) = ""\r
 386 chct(a) = 0\r
 387 NEXT a\r
 388 \r
 389 FOR a = 1 TO 50\r
 390 mtll(a) = 0\r
 391 NEXT a\r
 392 \r
 393 FOR a = 1 TO 100\r
 394 fil(a) = 0\r
 395 NEXT a\r
 396 nump = 0\r
 397 numpa = 0\r
 398 numpo = 0\r
 399 mtlm = 0\r
 400 stkp = 0\r
 401 fc = 180 / 3.141285\r
 402 chctim = 0\r
 403 mtmprs = 0\r
 404 cstatt = 0\r
 405 cstatm = 0\r
 406 END SUB\r
 407 \r
 408 SUB stat\r
 409 LOCATE 1, 1\r
 410 FOR a = 1 TO 10\r
 411 PRINT a, chcf$(a), chct(a), chcl(a)\r
 412 NEXT a\r
 413 COLOR 10\r
 414 LOCATE 1, 50\r
 415 PRINT cstatt; "parsed"\r
 416 LOCATE 2, 50\r
 417 PRINT cstatm; "chache miss"\r
 418 LOCATE 3, 50\r
 419 PRINT INT(cstatm / cstatt * 100); "% chache miss  "\r
 420 \r
 421 COLOR 7\r
 422 \r
 423 END SUB\r
 424 \r
 425 SUB stat2 (b)\r
 426 CLS\r
 427 FOR a = 1 TO chcl(b)\r
 428 PRINT chc$(b, a)\r
 429 NEXT a\r
 430 \r
 431 c$ = INPUT$(1)\r
 432 END SUB\r
 433 \r
 434 SUB usemtl (a$)\r
 435 FOR b = 1 TO mtlm\r
 436 IF mtl$(b) = a$ THEN cmtl = b: GOTO 4\r
 437 NEXT b\r
 438 \r
 439 mtlm = mtlm + 1\r
 440 mtl$(mtlm) = a$\r
 441 cmtl = mtlm\r
 442 4\r
 443 END SUB\r
 444 \r