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