--- /dev/null
+' by Svjatoslav Agejenko\r
+' homeage: http://svjatoslav.eu\r
+' e-mail: svjatoslav@svjatoslav.eu\r
+\r
+' Before running, make sure include path is correct. See below.\r
+\r
+DECLARE SUB parsel (a$)\r
+DECLARE SUB stat2 (b!)\r
+DECLARE SUB stat ()\r
+DECLARE SUB getchc (a$, b!)\r
+DECLARE SUB start ()\r
+DECLARE SUB qui ()\r
+DECLARE SUB flushpoly (a!)\r
+DECLARE SUB usemtl (a$)\r
+DECLARE SUB flushp ()\r
+DECLARE SUB parse (a$)\r
+DECLARE SUB geth (b!)\r
+DECLARE SUB cmd (a$)\r
+DECLARE SUB getson (a$)\r
+DIM SHARED px(1 TO 1000)\r
+DIM SHARED py(1 TO 1000)\r
+DIM SHARED pz(1 TO 1000)\r
+DIM SHARED nump\r
+DIM SHARED numpa\r
+DIM SHARED numpo\r
+\r
+DIM SHARED fil(1 TO 100)\r
+DIM SHARED mitus\r
+DIM SHARED sona$(1 TO 20)\r
+DIM SHARED res\r
+\r
+DIM SHARED mtlm\r
+DIM SHARED mtl$(1 TO 50)\r
+DIM SHARED mtlp1(1 TO 50, 1 TO 100)\r
+DIM SHARED mtlp2(1 TO 50, 1 TO 100)\r
+DIM SHARED mtlp3(1 TO 50, 1 TO 100)\r
+DIM SHARED mtlp4(1 TO 50, 1 TO 100)\r
+DIM SHARED mtll(1 TO 50)\r
+DIM SHARED cmtl\r
+\r
+DIM SHARED stkf(1 TO 500)\r
+DIM SHARED stks(1 TO 500)\r
+DIM SHARED stkp, fc, ipath$\r
+\r
+DIM SHARED chc$(1 TO 10, 1 TO 500)\r
+DIM SHARED chcl(1 TO 10)\r
+DIM SHARED chcf$(1 TO 10)\r
+DIM SHARED chct(1 TO 10)\r
+DIM SHARED chctim\r
+DIM SHARED mtmprs\r
+DIM SHARED tmr\r
+\r
+DIM SHARED var$(0 TO 100)\r
+DIM SHARED flag(1 TO 50, 0 TO 9)\r
+DIM SHARED cstatt, cstatm\r
+\r
+\r
+ipath$ = "c:\3dgen\include\" ' include path\r
+\r
+\r
+\r
+start\r
+\r
+IF COMMAND$ = "" THEN END\r
+CLS\r
+\r
+cmd "obj ~" + COMMAND$\r
+qui\r
+CLOSE #res\r
+fil(res) = 0\r
+\r
+PRINT "done"\r
+SYSTEM\r
+\r
+SUB cmd (z$)\r
+a$ = z$\r
+IF LEFT$(a$, 1) = "?" THEN\r
+IF flag(mtmprs, VAL(RIGHT$(LEFT$(a$, 2), 1))) = 1 THEN a$ = RIGHT$(a$, LEN(a$) - 3) ELSE GOTO 10\r
+END IF\r
+getson a$\r
+SELECT CASE sona$(1)\r
+CASE "end"\r
+qui\r
+PRINT "terminated from file"\r
+SYSTEM\r
+\r
+CASE "warn"\r
+COLOR 12\r
+PRINT sona$(2)\r
+COLOR 7\r
+b$ = INPUT$(1)\r
+\r
+CASE "p"\r
+nump = nump + 1\r
+numpa = numpa + 1\r
+x = VAL(sona$(2))\r
+y = VAL(sona$(3))\r
+z = VAL(sona$(4))\r
+\r
+FOR b = stkp TO 1 STEP -1\r
+SELECT CASE stkf(b)\r
+CASE 1\r
+c1 = SIN(stks(b) / fc)\r
+s1 = COS(stks(b) / fc)\r
+z1 = x * c1 + z * s1\r
+x1 = x * s1 - z * c1\r
+x = x1\r
+z = z1\r
+\r
+CASE 2\r
+c1 = SIN(stks(b) / fc)\r
+s1 = COS(stks(b) / fc)\r
+z1 = y * c1 + z * s1\r
+y1 = y * s1 - z * c1\r
+y = y1\r
+z = z1\r
+\r
+CASE 3\r
+s1 = SIN(stks(b) / fc)\r
+c1 = COS(stks(b) / fc)\r
+y1 = y * c1 + x * s1\r
+x1 = y * s1 - x * c1\r
+x = x1\r
+y = y1\r
+\r
+CASE 10\r
+x = x + stks(b)\r
+CASE 11\r
+y = y + stks(b)\r
+CASE 12\r
+z = z + stks(b)\r
+CASE 20\r
+x = x - stks(b)\r
+CASE 21\r
+y = y - stks(b)\r
+CASE 22\r
+z = z - stks(b)\r
+CASE 30\r
+x = x * stks(b)\r
+CASE 31\r
+y = y * stks(b)\r
+CASE 32\r
+z = z * stks(b)\r
+END SELECT\r
+NEXT b\r
+\r
+px(nump) = x\r
+py(nump) = y\r
+pz(nump) = z\r
+IF nump > 900 THEN flushp\r
+\r
+CASE "here"\r
+numpo = numpa\r
+\r
+CASE "mtl"\r
+usemtl sona$(2)\r
+\r
+CASE "mtlrnd"\r
+b = INT(RND * (mitus - 1)) + 2\r
+usemtl sona$(b)\r
+\r
+CASE "f"\r
+IF mtll(cmtl) > 90 THEN flushpoly cmtl\r
+b = mtll(cmtl)\r
+b = b + 1\r
+mtll(cmtl) = b\r
+mtlp1(cmtl, b) = VAL(sona$(2)) + numpo\r
+mtlp2(cmtl, b) = VAL(sona$(3)) + numpo\r
+mtlp3(cmtl, b) = VAL(sona$(4)) + numpo\r
+IF sona$(5) = "" THEN mtlp4(cmtl, b) = -32000 ELSE mtlp4(cmtl, b) = VAL(sona$(5)) + numpo\r
+\r
+CASE "obj"\r
+d = stkp\r
+FOR a = mitus TO 3 STEP -1\r
+b$ = LEFT$(sona$(a), 2)\r
+c = VAL(RIGHT$(sona$(a), LEN(sona$(a)) - 2))\r
+stkp = stkp + 1\r
+stks(stkp) = c\r
+SELECT CASE b$\r
+CASE "xz"\r
+stkf(stkp) = 1\r
+CASE "yz"\r
+stkf(stkp) = 2\r
+CASE "xy"\r
+stkf(stkp) = 3\r
+CASE "x+"\r
+stkf(stkp) = 10\r
+CASE "y+"\r
+stkf(stkp) = 11\r
+CASE "z+"\r
+stkf(stkp) = 12\r
+CASE "x-"\r
+stkf(stkp) = 20\r
+CASE "y-"\r
+stkf(stkp) = 21\r
+CASE "z-"\r
+stkf(stkp) = 22\r
+CASE "x*"\r
+stkf(stkp) = 30\r
+CASE "y*"\r
+stkf(stkp) = 31\r
+CASE "z*"\r
+stkf(stkp) = 32\r
+END SELECT\r
+NEXT a\r
+\r
+a$ = sona$(2)\r
+mtmprs = mtmprs + 1\r
+cstatt = cstatt + 1\r
+LOCATE 10 + mtmprs, 1\r
+PRINT a$\r
+getchc a$, b\r
+c = 1\r
+2\r
+d$ = chc$(b, c)\r
+cmd d$\r
+IF chcf$(b) <> a$ THEN getchc a$, b\r
+c = c + 1\r
+IF c <= chcl(b) THEN GOTO 2\r
+tmr = tmr + 1\r
+IF tmr > 20 THEN tmr = 0: stat\r
+LOCATE 10 + mtmprs, 1\r
+PRINT SPACE$(LEN(a$))\r
+mtmprs = mtmprs - 1\r
+\r
+stkp = d\r
+\r
+CASE "#"\r
+\r
+CASE "out"\r
+geth res\r
+OPEN sona$(2) + ".obj" FOR OUTPUT AS #res\r
+PRINT #res, "mtllib result.mtl"\r
+\r
+CASE "rnd"\r
+b = INT(RND * (mitus - 1)) + 2\r
+c$ = sona$(b)\r
+f$ = ""\r
+FOR d = 1 TO LEN(c$)\r
+e$ = RIGHT$(LEFT$(c$, d), 1)\r
+IF e$ = "^" THEN e$ = " "\r
+f$ = f$ + e$\r
+NEXT d\r
+cmd f$\r
+\r
+CASE "set"\r
+var$(VAL(sona$(2))) = sona$(3)\r
+\r
+CASE "cmp"\r
+IF sona$(3) = sona$(4) THEN b = 1 ELSE b = 0\r
+flag(mtmprs, VAL(sona$(2))) = b\r
+END SELECT\r
+\r
+10\r
+END SUB\r
+\r
+SUB flushp\r
+\r
+FOR a = 1 TO nump\r
+PRINT #res, "v " + STR$(px(a)) + " " + STR$(py(a)) + " " + STR$(-pz(a))\r
+NEXT a\r
+nump = 0\r
+\r
+END SUB\r
+\r
+SUB flushpoly (a)\r
+IF mtll(a) = 0 THEN GOTO 5\r
+\r
+PRINT #res, "usemtl " + mtl$(a)\r
+FOR b = 1 TO mtll(a)\r
+c$ = "f " + STR$(mtlp1(a, b) + 1) + STR$(mtlp2(a, b) + 1) + STR$(mtlp3(a, b) + 1)\r
+IF mtlp4(a, b) <> -32000 THEN c$ = c$ + STR$(mtlp4(a, b) + 1)\r
+PRINT #res, c$\r
+NEXT b\r
+mtll(a) = 0\r
+\r
+5\r
+END SUB\r
+\r
+SUB getchc (a$, b)\r
+'DIM SHARED cstatt, cstatm\r
+FOR c = 1 TO 10\r
+IF chcf$(c) = a$ THEN b = c: GOTO 6\r
+NEXT c\r
+\r
+d = 32000\r
+FOR c = 1 TO 10\r
+IF chct(c) < d THEN d = chct(c): e = c\r
+NEXT c\r
+g = 0\r
+geth f\r
+'PRINT "file " + a$ + " loaded"\r
+cstatm = cstatm + 1\r
+b$ = a$\r
+IF LEFT$(b$, 1) = "~" THEN b$ = RIGHT$(b$, LEN(b$) - 1) ELSE b$ = ipath$ + b$\r
+OPEN b$ + ".3d" FOR INPUT AS #f\r
+8\r
+IF EOF(f) <> 0 THEN GOTO 7\r
+LINE INPUT #f, c$\r
+IF (LEFT$(c$, 1) <> "#") AND (c$ <> SPACE$(LEN(c$))) THEN g = g + 1: chc$(e, g) = c$\r
+GOTO 8\r
+7\r
+CLOSE #f\r
+fil(f) = 0\r
+chcl(e) = g\r
+b = e\r
+chcf$(e) = a$\r
+stat\r
+6\r
+chctim = chctim + 1\r
+chct(b) = chctim\r
+\r
+IF chctim > 10000 THEN\r
+FOR c = 1 TO 10\r
+chct(c) = chct(c) / 2\r
+NEXT c\r
+chctim = chctim / 2\r
+END IF\r
+END SUB\r
+\r
+SUB geth (b)\r
+\r
+FOR a = 1 TO 100\r
+IF fil(a) = 0 THEN fil(a) = 1: b = a: GOTO 1\r
+NEXT a\r
+1\r
+'PRINT "handle ", b, " allocated"\r
+\r
+END SUB\r
+\r
+SUB getson (a$)\r
+b$ = a$ + " "\r
+\r
+FOR a = 1 TO 20\r
+sona$(a) = ""\r
+NEXT a\r
+\r
+mitus = 0\r
+e = 1\r
+FOR c = 1 TO LEN(b$)\r
+d$ = RIGHT$(LEFT$(b$, c), 1)\r
+IF d$ = " " OR d$ = CHR$(9) THEN\r
+e = 1\r
+ELSE\r
+IF e = 1 THEN mitus = mitus + 1\r
+sona$(mitus) = sona$(mitus) + d$\r
+e = 0\r
+END IF\r
+NEXT c\r
+\r
+FOR c = 1 TO mitus\r
+IF LEFT$(sona$(c), 1) = "%" THEN\r
+sona$(c) = var$(VAL(RIGHT$(sona$(c), LEN(sona$(c)) - 1)))\r
+END IF\r
+NEXT c\r
+END SUB\r
+\r
+SUB qui\r
+\r
+flushp\r
+FOR a = 1 TO mtlm\r
+flushpoly a\r
+NEXT a\r
+stat\r
+END SUB\r
+\r
+SUB start\r
+RANDOMIZE TIMER\r
+\r
+FOR a = 1 TO 50\r
+FOR b = 0 TO 9\r
+flag(a, b) = 0\r
+NEXT b\r
+NEXT a\r
+\r
+FOR a = 0 TO 100\r
+var$(a) = ""\r
+NEXT a\r
+\r
+FOR a = 1 TO 10\r
+FOR b = 1 TO 500\r
+chc$(a, b) = ""\r
+NEXT b\r
+chcl(a) = 0\r
+chcf$(a) = ""\r
+chct(a) = 0\r
+NEXT a\r
+\r
+FOR a = 1 TO 50\r
+mtll(a) = 0\r
+NEXT a\r
+\r
+FOR a = 1 TO 100\r
+fil(a) = 0\r
+NEXT a\r
+nump = 0\r
+numpa = 0\r
+numpo = 0\r
+mtlm = 0\r
+stkp = 0\r
+fc = 180 / 3.141285\r
+chctim = 0\r
+mtmprs = 0\r
+cstatt = 0\r
+cstatm = 0\r
+END SUB\r
+\r
+SUB stat\r
+LOCATE 1, 1\r
+FOR a = 1 TO 10\r
+PRINT a, chcf$(a), chct(a), chcl(a)\r
+NEXT a\r
+COLOR 10\r
+LOCATE 1, 50\r
+PRINT cstatt; "parsed"\r
+LOCATE 2, 50\r
+PRINT cstatm; "chache miss"\r
+LOCATE 3, 50\r
+PRINT INT(cstatm / cstatt * 100); "% chache miss "\r
+\r
+COLOR 7\r
+\r
+END SUB\r
+\r
+SUB stat2 (b)\r
+CLS\r
+FOR a = 1 TO chcl(b)\r
+PRINT chc$(b, a)\r
+NEXT a\r
+\r
+c$ = INPUT$(1)\r
+END SUB\r
+\r
+SUB usemtl (a$)\r
+FOR b = 1 TO mtlm\r
+IF mtl$(b) = a$ THEN cmtl = b: GOTO 4\r
+NEXT b\r
+\r
+mtlm = mtlm + 1\r
+mtl$(mtlm) = a$\r
+cmtl = mtlm\r
+4\r
+END SUB\r
+\r
projects / qbasicapps.git / blobdiff