REM Starmap v1.0 REM Public Domain 1998 Jim Vassilakos REM San Bernardino, California REM jimv@empirenet.com / JimVassila@aol.com REM Programmed in QuickBasic 4.5 REM Includes SAVESCR v0.6 by Aaron Zabudsky DECLARE SUB savescr (filename$, sx!, sy!, ex!, ey!, nbits!, imgnum!) DIM length(42) DIM image(13, 42, 15) AS INTEGER DIM col(13) DIM gov$(2, 100) DIM govcl(100) DIM sys$(500): REM system info as read from quadrant file DIM name$(500): REM system name DIM xsys(500) DIM ysys(500) DIM zsys(500) DIM csys%(500): REM color of system (based on gov) DIM asys%(500): REM attachment DIM trade(100, 7) DIM close$(21) DIM dist(21) DEF FNfh$ (f4) fhtmp$ = LTRIM$(RTRIM$(STR$(INT(f4 / 10) + 500))) IF LEN(fhtmp$) < 3 THEN fhtmp$ = "0" + fhtmp$ IF LEN(fhtmp$) < 3 THEN fhtmp$ = "0" + fhtmp$ FNfh$ = fhtmp$ END DEF DEF FNsec$ (f1, f2, f3) FNsec$ = FNfh$(f1) + "-" + FNfh$(f2) + "." + FNfh$(f3) END DEF DEF FNadj$ (f5$, f6, f7, f8) f6 = (VAL(LEFT$(f5$, 3)) - 500) * 10 + f6 f7 = (VAL(MID$(f5$, 5, 3)) - 500) * 10 + f7 f8 = (VAL(MID$(f5$, 9, 3)) - 500) * 10 + f8 FNadj$ = FNsec$(f6, f7, f8) END DEF REM general stuff RANDOMIZE INT(TIMER / 2) ON ERROR GOTO 5800 noise = 1 fp1 = 1: fp2 = 1: fp3old = 8: fp4old = 3 scar = (3 / 4) * (640 / 200) pi# = 3.1415926# basea = 320: baseb = 400: REM baseb can vary from 240-900 SCREEN 12: COLOR 11 GOSUB 5000: REM read letters.dat -> image data SCREEN 0 REM title screen CLS SHELL "funky data\title.dat" GOSUB 2260 8 REM configuration/color data/govs GOSUB 5700: REM read config info GOSUB 5480: REM in color data GOSUB 5020: REM read govs 10 REM front page SCREEN 0: CLS : COLOR 14 PRINT "Starmap (v1.0)" PRINT "Public Domain 1998 Jim Vassilakos" PRINT "jimv@empirenet.com / JimVassila@aol.com" PRINT COLOR 10: PRINT "Current Galaxy: "; galname$ LOCATE 5, 50: COLOR 13: PRINT "Editor: "; editor$ COLOR 10: PRINT "Coordinates: "; PRINT LTRIM$(STR$(qx + xx)); ", "; PRINT LTRIM$(STR$(qy + yy)); ", "; PRINT LTRIM$(STR$(qz + zz)) LOCATE 6, 50: COLOR 13: PRINT "Reader: "; reader$ PRINT : COLOR 11 PRINT " About this Program View/Edit Map" PRINT PRINT " Select Text Editor Read Galaxy Notes" PRINT " Select Text Reader Edit Galaxy Notes" PRINT PRINT " Select/Create Galaxy Change X-Coordinate" PRINT " Foreground/Background Change Y-Coordinate" PRINT " Modify Color Chart Change Z-Coordinate" PRINT PRINT " Exit" 14 REM arrow LOCATE fp3old, fp4old PRINT " " IF fp1 = 1 THEN fp3 = 8 IF fp1 = 2 THEN fp3 = 10 IF fp1 = 3 THEN fp3 = 11 IF fp1 = 4 THEN fp3 = 13 IF fp1 = 5 THEN fp3 = 14 IF fp1 = 6 THEN fp3 = 15 IF fp1 = 7 THEN fp3 = 17 IF fp2 = 1 THEN fp4 = 3 IF fp2 = 2 THEN fp4 = 30 fp3old = fp3 fp4old = fp4 COLOR 12 LOCATE fp3, fp4 PRINT CHR$(196); CHR$(26) 15 REM get input GOSUB 2260 IF k2 = 0 AND (k1 >= 97 AND k1 <= 122) THEN k1 = k1 - 32 IF k2 = 0 AND k1 = 27 GOTO 6000: REM esc IF k2 = 0 AND k1 = 81 GOTO 6000: REM Q 6,1 IF k2 = 1 AND (k1 = 75 OR k1 = 77) GOTO 16: REM left/right IF k2 = 1 AND (k1 = 72 OR k1 = 80) GOTO 17: REM up/down IF k2 = 1 AND (k1 = 73 OR k1 = 81) GOTO 17: REM pgup/pgdn IF k2 = 0 AND k1 = 13 GOTO 18: REM enter GOTO 15 16 REM left/right IF fp1 = 7 GOTO 14 IF fp2 = 1 THEN fp2 = 3 IF fp2 = 2 THEN fp2 = 1 IF fp2 = 3 THEN fp2 = 2 SOUND 10000, .1 GOTO 14 17 REM up/down/pgup/pgdn IF k1 = 72 THEN fp1 = fp1 - 1 IF k1 = 80 THEN fp1 = fp1 + 1 IF k1 = 73 THEN fp1 = 1 IF k1 = 81 THEN fp1 = 8 - fp2 IF fp1 < 1 THEN fp1 = 8 - fp2 IF fp1 > 8 - fp2 THEN fp1 = 1 SOUND 10000, .1 GOTO 14 18 REM enter IF fp1 = 1 AND fp2 = 1 GOTO 19 IF fp1 = 7 AND fp2 = 1 GOTO 6000 IF fp1 = 1 AND fp2 = 2 GOTO 40 IF fp1 = 2 AND fp2 = 2 GOTO 26 IF fp1 = 3 AND fp2 = 2 GOTO 28 IF fp1 >= 2 AND fp1 <= 6 AND fp2 = 1 GOTO 21 IF fp1 >= 4 AND fp1 <= 6 AND fp2 = 2 GOTO 21 19 REM Help SHELL "eg help\help.mnu " + reader$ GOTO 10 21 REM call starcfg IF fp1 = 2 AND fp2 = 1 THEN SHELL "starcfg 1": REM change editor IF fp1 = 3 AND fp2 = 1 THEN SHELL "starcfg 2": REM change reader IF fp1 = 4 AND fp2 = 1 THEN SHELL "starcfg 3": REM change galaxy IF fp1 = 4 AND fp2 = 2 THEN SHELL "starcfg 4": REM change x IF fp1 = 5 AND fp2 = 2 THEN SHELL "starcfg 5": REM change y IF fp1 = 6 AND fp2 = 2 THEN SHELL "starcfg 6": REM change z IF fp1 = 5 AND fp2 = 1 THEN SHELL "starcfg 7": REM foreground/background IF fp1 = 6 AND fp2 = 1 THEN SHELL "starcfg 8": REM change color chart GOTO 8 26 REM read world notes SHELL "eg " + gendir$ + "galaxy.mnu " + reader$ GOTO 10 28 REM edit world notes SHELL "eg " + gendir$ + "galaxy.mnu " + editor$ GOTO 10 40 CLS SCREEN 12 GOSUB 5850: REM set palette 50 GOSUB 4000: REM get data for main map 100 REM redraw graph CLS letcol = 14 IF nostar = 1 THEN x = 460: y = 340: word$ = "no star system": GOSUB 5100 x = 460: y = 346: word$ = "in this sector": GOSUB 5100 END IF nostar = 0 COLOR 11 LOCATE 1, 60 IF quadname$ = "" THEN PRINT "Unnamed Quadrant" ELSE PRINT quadname$ END IF LOCATE 2, 60 t = qx + xx: GOSUB 110 PRINT "X: "; t$ LOCATE 3, 60 t = qy + yy: GOSUB 110 PRINT "Y: "; t$ LOCATE 4, 60 t = qz + zz: GOSUB 110 PRINT "Z: "; t$ REM LOCATE 5, 60: print numsys; nt GOTO 120 110 t$ = LTRIM$(STR$(t)) IF t >= 0 THEN t$ = "+" + t$ RETURN 120 REM general grid COLOR 1 FOR a = 0 TO 15 LINE (0, a * 30)-(450, a * 30) LINE (a * 30, 0)-(a * 30, 450) NEXT a letcol = 5 x = 30: y = 470: word$ = galname$: GOSUB 5100 REM sector boundaries COLOR 11 IF yy >= 2 THEN LINE (0, (yy - 2) * 30)-(450, (yy - 2) * 30): REM top IF yy <= 7 THEN LINE (0, (yy + 8) * 30)-(450, (yy + 8) * 30): REM bottom IF xx <= 7 THEN LINE ((7 - xx) * 30, 0)-((7 - xx) * 30, 450): REM left IF xx >= 2 THEN LINE ((17 - xx) * 30, 0)-((17 - xx) * 30, 450): REM right REM chart trade routes FOR s = 1 TO nt x1 = INT(((trade(s, 1) - qx) * 30) + ((-xx + 7) * 30)) y1 = INT((-(trade(s, 3) - qy) * 30) + ((yy + 8) * 30)) z1 = INT(trade(s, 5) - qz - zz + 5) x2 = INT(((trade(s, 2) - qx) * 30) + ((-xx + 7) * 30)) y2 = INT((-(trade(s, 4) - qy) * 30) + ((yy + 8) * 30)) z2 = INT(trade(s, 6) - qz - zz + 5) IF (x1 < 0 OR x1 > 450) AND (x2 < 0 OR x2 > 450) GOTO 170 IF (y1 < 0 OR y1 > 450) AND (y2 < 0 OR y2 > 450) GOTO 170 IF (z1 < -1 OR z1 > 11) AND (z2 < -1 OR z2 > 11) GOTO 170 LINE (x1, y1)-(x2, y2), trade(s, 7) 170 NEXT s 180 REM area of proximity COLOR col(6) LINE (210, 210)-(240, 210) LINE (210, 240)-(240, 240) LINE (210, 210)-(210, 240) LINE (240, 210)-(240, 240) GOSUB 5200: REM z-chart 200 REM chart starsystems FOR s = 1 TO numsys word$ = name$(s) x = INT(((xsys(s) - qx) * 30) + ((-xx + 7) * 30)) y = INT((-(ysys(s) - qy) * 30) + ((yy + 8) * 30)) z = INT(zsys(s) - qz - zz + 5) IF x < 0 OR x > 450 GOTO 250 IF y < 0 OR y > 450 GOTO 250 IF z < -1 OR z > 11 GOTO 250 IF csys%(s) > 99 THEN COLOR csys%(s) - 100 ELSE COLOR csys%(s) END IF CIRCLE (x, y), 3 IF asys%(s) > 0 THEN CIRCLE (x, y), 1 IF csys%(s) > 99 GOTO 250: REM invix x = x + 6: y = y + 6 x2 = x: y2 = y letcol = col(z + 1) GOSUB 5100: REM draw word t = INT((zsys(s) - qz) - zz) word$ = LTRIM$(STR$(t)) IF t >= 0 THEN word$ = "+" + word$ x = x2 y = y2 - 6 GOSUB 5100: REM draw z-coordinate 250 NEXT s REM display comments letcol = 15: yloc = 70 FOR a = 1 TO numsys IF INT(xsys(a)) <> xx + qx GOTO 300 IF INT(ysys(a)) <> yy + qy GOTO 300 IF INT(zsys(a)) <> zz + qz GOTO 300 name$ = RTRIM$(MID$(sys$(a), 9, 21)) + ": " comment$ = RTRIM$(MID$(sys$(a), 48, 32)) IF comment$ = "" GOTO 300 slash = INSTR(comment$, "/") IF slash = 0 THEN word$ = name$ + comment$ x = 470: y = yloc GOSUB 5100 yloc = yloc + 9 END IF IF slash > 0 THEN word$ = name$ + LEFT$(comment$, slash - 1) x = 470: y = yloc GOSUB 5100 yloc = yloc + 7 word$ = RIGHT$(comment$, LEN(comment$) - slash) x = 480: y = yloc GOSUB 5100 yloc = yloc + 9 END IF 300 NEXT a 2220 REM get input GOSUB 2260 IF k2 = 0 AND (k1 >= 97 AND k1 <= 122) THEN k1 = k1 - 32 IF k2 = 0 AND (k1 = 27 OR k1 = 81) GOTO 2222: REM esc/q IF k2 = 1 AND k1 = 72 GOTO 2225: REM up IF k2 = 1 AND k1 = 75 GOTO 2232: REM left IF k2 = 1 AND k1 = 80 GOTO 2230: REM down IF k2 = 1 AND k1 = 77 GOTO 2235: REM right IF k2 = 1 AND k1 = 73 GOTO 2240: REM pgup IF k2 = 1 AND k1 = 81 GOTO 2245: REM pgdn IF k2 = 0 AND (k1 = 13 OR k1 = 32) GOTO 3000: REM enter/space IF k2 = 0 AND k1 = 62 GOTO 3000: REM > (create/edit att) IF k2 = 1 AND k1 = 82 GOTO 3000: REM ins (create/edit att) IF k2 = 0 AND k1 = 68 GOTO 3000: REM (d)istance calculator IF k2 = 0 AND k1 = 71 GOTO 2250: REM (g)overnments IF k2 = 0 AND k1 = 60 GOTO 2257: REM < (edit map) IF k2 = 1 AND k1 = 59 GOTO 2252: REM F1 (read galaxy notes) IF k2 = 1 AND k1 = 60 GOTO 2270: REM F2 (create quadrant) IF k2 = 1 AND k1 = 61 GOTO 2255: REM F3 (view quad) IF k2 = 1 AND k1 = 62 GOTO 2256: REM F4 (toggle noise) IF k2 = 1 AND k1 = 63 GOTO 2253: REM F5 (bigmap) IF k2 = 1 AND k1 = 68 GOTO 2265: REM F10 (savescr) IF k2 = 0 AND (k1 = 72 OR k1 = 63) GOTO 2250: REM H/? (help) letcol = 14 x = 590: y = 470: word$ = "H : Help": GOSUB 5100 GOTO 2220 2222 REM ESC/Q GOSUB 5750: REM write configuration GOTO 10 2225 REM up arrow movement IF yy < 9 GOTO 2226 yy = 0: qy = qy + 10 GOTO 50 2226 yy = yy + 1 GOTO 100 2230 REM down arrow movement IF yy > 0 GOTO 2231 yy = 9: qy = qy - 10 GOTO 50 2231 yy = yy - 1 GOTO 100 2232 REM left arrow movement IF xx > 0 GOTO 2233 xx = 9: qx = qx - 10 GOTO 50 2233 xx = xx - 1 GOTO 100 2235 REM right arrow movement IF xx < 9 GOTO 2236 xx = 0: qx = qx + 10 GOTO 50 2236 xx = xx + 1 GOTO 100 2240 REM pgup IF zz < 9 GOTO 4441 zz = 0: qz = qz + 10 GOTO 50 4441 zz = zz + 1 GOTO 100 2245 REM pgdn IF zz > 0 GOTO 2246 zz = 9: qz = qz - 10 GOTO 50 2246 zz = zz - 1 GOTO 100 2250 REM Help GOSUB 4200: REM egacolor IF k1 = 71 THEN SHELL editor$ + " " + datdir$ + "gov.dat" GOSUB 5020 ELSE SHELL reader$ + " help\starmap.txt" END IF SCREEN 12 IF k1 = 71 GOTO 50 GOTO 100 2252 REM read galaxy notes SCREEN 0 SHELL "eg " + gendir$ + "galaxy.mnu " + reader$ SCREEN 12 GOTO 100 2253 REM bigmap GOSUB 5750: REM write configuration SHELL "bigmap" OPEN "i", 1, "tmp\bigmap.tmp" INPUT #1, qx INPUT #1, qy INPUT #1, qz CLOSE SHELL "erase tmp\bigmap.tmp" GOTO 40 2255 REM View Using Quadrant Projector IF numsys = 0 THEN x = 500: y = 470: word$ = "This Quadrant is Empty" letcol = 12 GOSUB 5100 END IF IF numsys = 0 GOTO 2220 REM write quad.dat OPEN "o", 1, "tmp\quad.tmp" PRINT #1, qx; ","; qy; ","; qz IF nt > 0 THEN FOR a = 1 TO nt PRINT #1, "$"; FOR b = 1 TO 7 PRINT #1, ","; trade(a, b); NEXT b PRINT #1, "" NEXT a END IF FOR a = 1 TO numsys PRINT #1, "*,"; IF csys%(a) < 100 THEN PRINT #1, name$(a); PRINT #1, ","; PRINT #1, xsys(a); ","; PRINT #1, ysys(a); ","; PRINT #1, zsys(a); ","; IF csys%(a) < 100 THEN PRINT #1, csys%(a) ELSE PRINT #1, csys%(a) - 100 END IF NEXT a CLOSE #1 SHELL "quad" SCREEN 12 GOTO 100 2256 REM toggle noise IF noise = 1 THEN noise = 0 ELSE noise = 1 GOTO 2220 2257 REM Modify Sector GOSUB 4200: REM egacolor SHELL editor$ + " " + mapdir$ + FNsec$(qx, qy, qz) SCREEN 12 GOTO 50 2260 REM read keyboard k1 = 0: k2 = 0 2262 k$ = INKEY$ IF k$ = "" THEN GOTO 2262 IF noise = 1 THEN SOUND 10000, .1 k1 = ASC(k$) IF k1 <> 13 THEN GOTO 2263 FOR note = 1 TO 10 IF noise = 1 THEN SOUND note * 200, .1 NEXT note 2263 IF k1 <> 0 THEN GOTO 2264 k1 = ASC(RIGHT$(k$, 1)) k2 = 1 2264 RETURN 2265 REM save screen savescr bmpfile$, 0, 0, 639, 479, 4, 0 CLS : LOCATE 5: COLOR 11 PRINT PRINT "System map saved to "; bmpfile$ PRINT PRINT "Hit any key to return to the map" PRINT GOSUB 2260 GOTO 100 2270 REM create quadrant IF quadname$ <> "Uncharted Territory" GOTO 2220 CLS : COLOR 11 f$ = mapdir$ + FNsec$(qx, qy, qz) PRINT "Quadrant Creation" PRINT "-----------------" PRINT PRINT "file = "; f$ PRINT INPUT "Enter the quadrant's name: ", qn$ PRINT PRINT "How many star systems do you want?" PRINT " (hint: anywhere from 1 - 10 is usually a good number)" PRINT INPUT "---> ", I IF I = 0 GOTO 2295 CLS PRINT "Government Codes:" FOR j = 1 TO numgov PRINT gov$(1, j), gov$(2, j) NEXT j PRINT PRINT "What government code do you want for these systems?" PRINT 2280 INPUT "---> ", gv$ IF LEN(gv$) <> 3 GOTO 2280 PRINT REM verify that we have enough names namesf$ = "solian" namesdat$ = "data\names\" + namesf$ + ".dat" nametmp1$ = "tmp\names1.tmp" nametmp2$ = "tmp\names2.tmp" numnames = 0 OPEN "i", 1, namesdat$ DO UNTIL EOF(1) LINE INPUT #1, t$ numnames = numnames + 1 LOOP CLOSE 1 IF numnames < I THEN PRINT namesf$; ";.dat only has;"; numnames; "names. Do you want to" PRINT "restore this file from its original backup? (y/n)" GOSUB 5900: REM yn$ IF yn$ = "n" GOTO 2285 SHELL "copy data\names\old\solian.old data\names\solian.dat" 2285 END IF: REM numnames 68 THEN purpose$ = "access" IF k1 = 62 OR k1 = 82 THEN browser$ = editor$ ELSE browser$ = reader$ END IF ELSE purpose$ = "distance" END IF aop = 0 FOR a = 1 TO numsys ok = 1 IF INT(xsys(a)) <> xx + qx THEN ok = 0 IF INT(ysys(a)) <> yy + qy THEN ok = 0 IF INT(zsys(a)) <> zz + qz THEN ok = 0 IF ok = 1 THEN aop = aop + 1 st$(aop) = sys$(a) END IF NEXT a IF aop = 0 GOTO 3005 IF aop = 1 GOTO 3010 IF aop > 1 GOTO 3015 3005 nostar = 1 GOTO 100 3010 star$ = st$(1) GOTO 5300 3015 letcol = 14 FOR t = 1 TO aop word$ = CHR$(t + 64) + " : " + RTRIM$(MID$(st$(t), 9, 21)) x = 460: y = 330 + (7 * t) GOSUB 5100: REM print choice on starsystem menu NEXT t 3020 GOSUB 2260: REM get user's input IF k1 >= 97 THEN k1 = k1 - 32: REM convert to upper case IF k0 = 0 AND k1 >= 65 AND k1 <= 64 + aop GOTO 3030: REM A-? IF k0 = 0 AND k1 = 27 GOTO 100: REM esc GOTO 3020 3030 star$ = st$(k1 - 64) GOTO 5300 3100 REM distance calculator IF numsys < 2 GOTO 50 IF numsys < 21 THEN e = numsys ELSE e = 21 CLS b = 0 FOR a = 1 TO numsys IF star$ = sys$(a) THEN b = a NEXT a PRINT COLOR 10 PRINT "Systems close to "; name$(b); ":" COLOR 11 FOR a = 1 TO 20 close$(a) = "": dist(a) = 100000 NEXT a FOR a = 1 TO numsys IF a = b GOTO 3120 tmp = (xsys(a) - xsys(b)) ^ 2 tmp = tmp + (ysys(a) - ysys(b)) ^ 2 tmp = tmp + (zsys(a) - zsys(b)) ^ 2 tmp = INT(SQR(tmp) * 100) / 100 c = 0 FOR d = e TO 1 STEP -1 IF tmp < dist(d) THEN c = d NEXT d IF c > 0 THEN FOR d = e TO c STEP -1 close$(d + 1) = close$(d) dist(d + 1) = dist(d) NEXT d close$(c) = name$(a) dist(c) = tmp END IF 3120 NEXT a FOR a = 1 TO e - 1 LOCATE a + 3, 1: PRINT close$(a) LOCATE a + 3, 30: PRINT dist(a) NEXT a GOSUB 2260 GOTO 100 4000 REM read quadrants REM ditch trade routes nt = 0 REM get rid of starsystems numsys = 0 4020 REM load quadrants percent = 0 f0$ = FNsec$(qx, qy, qz) FOR ux = 1 TO 3 vx = (ux - 2) * 10 FOR uy = 1 TO 3 vy = (uy - 2) * 10 FOR uz = 1 TO 3 vz = (uz - 2) * 10 percent = INT((((ux - 1) * 9) + ((uy - 1) * 3) + (uz)) / 27 * 100) LINE (630, 210)-(631, 210 - percent * 2), 10, B LINE (630, 210 - percent * 2)-(631, 1), 0, B fq$ = FNadj$(f0$, vx, vy, vz) REM does quadrant file exist? quadpath$ = mapdir$ + fq$ testfile$ = quadpath$ GOSUB 5950: REM exist subroutine IF ux = 2 AND uy = 2 AND uz = 2 THEN quadname$ = "Uncharted Territory" IF exist = 0 GOTO 4050 OPEN "i", 1, quadpath$ REM read quadrant data DO UNTIL EOF(1) LINE INPUT #1, t$ IF t$ <> "" THEN key$ = LEFT$(t$, 1) l = LEN(t$) IF key$ = "!" THEN IF ux = 2 AND uy = 2 AND uz = 2 THEN quadname$ = RIGHT$(t$, l - 1) END IF IF key$ = "$" THEN t$ = t$ + ":" + fq$ nt = nt + 1 trade(nt, 1) = VAL(MID$(t$, 2, 2)) / 10 + qx + vx trade(nt, 2) = VAL(MID$(t$, 9, 2)) / 10 + qx + vx trade(nt, 2) = trade(nt, 2) + VAL(MID$(t$, 16, 1)) * 10 - 20 trade(nt, 3) = VAL(MID$(t$, 4, 2)) / 10 + qy + vy trade(nt, 4) = VAL(MID$(t$, 11, 2)) / 10 + qy + vy trade(nt, 4) = trade(nt, 4) + VAL(MID$(t$, 17, 1)) * 10 - 20 trade(nt, 5) = VAL(MID$(t$, 6, 2)) / 10 + qz + vz trade(nt, 6) = VAL(MID$(t$, 13, 2)) / 10 + qz + vz trade(nt, 6) = trade(nt, 6) + VAL(MID$(t$, 18, 1)) * 10 - 20 trade(nt, 7) = ASC(MID$(t$, 20, 1)) - 65 END IF: REM key$="$" IF key$ = "*" THEN t$ = t$ + SPACE$(79 - LEN(t$)) numsys = numsys + 1 sys$(numsys) = t$ xsys(numsys) = VAL(MID$(t$, 2, 2)) / 10 + qx + vx ysys(numsys) = VAL(MID$(t$, 4, 2)) / 10 + qy + vy zsys(numsys) = VAL(MID$(t$, 6, 2)) / 10 + qz + vz name$(numsys) = RTRIM$(MID$(t$, 9, 22)) gsys$ = MID$(t$, 31, 3) GOSUB 4100: REM find csys%(numsys) IF MID$(t$, 8, 1) = "-" THEN csys%(numsys) = csys%(numsys) + 100 attached$ = RTRIM$(MID$(t$, 35, 12)) IF attached$ = "" THEN asys%(numsys) = 0 ELSE asys%(numsys) = 1 END IF END IF: REM key$="*" END IF: REM t$="" LOOP CLOSE 4050 NEXT uz NEXT uy NEXT ux oldqx = qx: oldqy = qy: oldqz = qz LINE (630, 210)-(631, 1), 0, B RETURN 4100 REM find csys%(numsys) = color of gov of system FOR count = 1 TO numgov IF gsys$ = gov$(1, count) THEN csys%(numsys) = govcl(count) NEXT count RETURN 4200 REM egacolor gold on blue SCREEN 0 SHELL "egacolor 00 10" SHELL "egacolor 07 46" RETURN 5000 REM get letter image data COLOR 14 LOCATE 8, 3 PRINT "Reading Data..." OPEN "i", 1, "data\letters0.dat" FOR z = 1 TO 42 INPUT #1, t$ FOR a = 1 TO 5 INPUT #1, lrow$(a) NEXT a FOR z1 = 1 TO 15 REM cls LOCATE 10, 10 COLOR 11 PRINT 43 - z COLOR z1: GOSUB 5005 GET (1, 1)-(l, 5), image(1, z, z1) COLOR 0: GOSUB 5005 NEXT z1 NEXT z CLOSE RETURN 5005 FOR a = 1 TO 5 length(z) = LEN(lrow$(a)) - 2 l = length(z) FOR b = 1 TO l IF MID$(lrow$(a), b + 1, 1) = "*" THEN PSET (b, a) NEXT b NEXT a RETURN 5020 REM subroutine: read in govs OPEN "i", 1, datdir$ + "gov.dat" a = 0 DO UNTIL EOF(1) INPUT #1, t$ t$ = RTRIM$(t$) IF t$ = "" GOTO 5030 IF LEFT$(t$, 1) = "#" GOTO 5030 a = a + 1 gov$(1, a) = LEFT$(t$, 3) govcl(a) = ASC(MID$(t$, 5, 1)) - 65 gov$(2, a) = RIGHT$(t$, LEN(t$) - 6) 5030 LOOP CLOSE numgov = a RETURN 5100 REM subroutine: print word (ver2) y = y - 4 l = LEN(word$) IF l = 0 THEN RETURN word$ = UCASE$(word$) FOR aa = 1 TO l let$ = MID$(word$, aa, 1) REM convert let$ to letnum SELECT CASE ASC(let$) CASE IS > 64 letnum = ASC(let$) - 64 CASE 48 TO 57 letnum = ASC(let$) - 21 CASE 32 letnum = 39 CASE 39 letnum = 38 CASE 43 letnum = 40 CASE 45 letnum = 37 CASE 46 letnum = 42 CASE 58 letnum = 41 CASE ELSE letnum = 0 END SELECT IF x < 1 OR y < 5 OR x > 635 OR y > 475 GOTO 5120 IF letnum = 0 GOTO 5125 PUT (x, y), image(1, letnum, letcol), PSET 5120 x = x + length(letnum) + 1 5125 NEXT aa RETURN 5200 REM layers of color FOR a = 12 TO 0 STEP -1 COLOR col(a) LINE (460, (12 - a) * 10 + 165)-(480, (12 - a) * 10 + 165) NEXT COLOR 7 FOR a = 0 TO 9 LINE (480, 225 + ((zz - a) * 10))-(500, 225 + ((zz - a) * 10)) NEXT a COLOR col(6) LINE (500, 225)-(520, 225) RETURN 5300 REM attachment IF purpose$ = "distance" GOTO 3100 starname$ = RTRIM$(MID$(star$, 9, 22)) attached$ = RTRIM$(MID$(star$, 35, 12)) attext$ = RIGHT$(attached$, 3) comment$ = RTRIM$(MID$(star$, 48, 30)) IF LEFT$(comment$, 1) <> "(" THEN comment$ = "" reread = 0 IF attached$ <> "" THEN SELECT CASE attext$ CASE "txt" GOSUB 4200: REM egacolor SHELL browser$ + " " + locdir$ + attached$ SCREEN 12 CASE "mnu" GOSUB 4200: REM egacolor SHELL "eg " + locdir$ + attached$ + " " + browser$ SCREEN 12 CASE "hex" SHELL "hexworld " + hexdir$ + attached$ CASE "sys" SHELL "sysmap " + sysdir$ + attached$ END SELECT ELSE browser$ = editor$: REM optional line to make proggie more proactive IF browser$ = editor$ THEN CLS LOCATE 5: COLOR 11 PRINT "This star system currently has no attachment. You may" PRINT "create one of four types of attachments at this time." PRINT : COLOR 10 PRINT " (.txt) Text File" PRINT " (.mnu) Menu File" PRINT " (.hex) World Map" PRINT " (.sys) Star System Map" COLOR 11: PRINT PRINT "Because this is a star system to which you are attaching a" PRINT "file, it probably makes most sense to attach a star system" PRINT "map (.sys) file, and then attach world map (.hex) files to" PRINT "the star system map, and finally attach menus (.mnu) and" PRINT "text (.txt) files to the world maps. In any case, the" PRINT "choice is yours." PRINT PRINT "Enter the name of the file (including the three-letter" PRINT "extension) that you want to create as an attachment to" PRINT "this map (or just hit to return to the map)." PRINT : COLOR 13 5310 LOCATE 24, 1: PRINT SPACE$(79): LOCATE 24, 1 INPUT "---> ", t$ t$ = LCASE$(RTRIM$(LTRIM$(t$))) IF t$ = "" GOTO 5350 I = INSTR(t$, ".") IF I <= 1 OR I > 9 GOTO 5310 IF LEN(t$) <> I + 3 GOTO 5310 ext$ = RIGHT$(t$, 3) t = INSTR("txt-mnu-hex-sys", ext$) IF t <> 1 AND t <> 5 AND t <> 9 AND t <> 13 GOTO 5310 reread = 1 SELECT CASE ext$ CASE "txt" testfile$ = locdir$ + t$ GOSUB 5950: REM exist IF exist = 0 THEN OPEN "o", 1, locdir$ + t$ PRINT #1, "" PRINT #1, starname$ PRINT #1, STRING$(LEN(starname$), "-") PRINT #1, "" CLOSE END IF: REM exist=0 GOSUB 4200: REM egacolor SHELL browser$ + " " + locdir$ + t$ SCREEN 12 CASE "mnu" testfile$ = locdir$ + t$ GOSUB 5950: REM exist IF exist = 0 THEN OPEN "o", 1, locdir$ + t$ OPEN "i", 2, "data\start\starter.mnu" PRINT #1, "@dir=" + LEFT$(locdir$, LEN(locdir$) - 1) PRINT #1, "@Light Yellow" PRINT #1, "" PRINT #1, " "; starname$ DO UNTIL EOF(2) LINE INPUT #2, t2$ lstart = LEN(t2$) IF lstart = 1 THEN t2$ = "" IF lstart > 1 THEN t2$ = RIGHT$(t2$, lstart - 1) PRINT #1, t2$ LOOP CLOSE 1 CLOSE 2 END IF: REM exist=0 GOSUB 4200: REM egacolor SHELL "eg " + locdir$ + t$ + " " + browser$ SCREEN 12 CASE "hex" SHELL "hexworld " + hexdir$ + t$ + " " + starmap$ CASE "sys" SHELL "sysmap " + sysdir$ + t$ + " " + starname$ + " " + comment$ END SELECT REM insert attachment-flag into starmap f$ = FNsec$(qx, qy, qz) SHELL "copy " + mapdir$ + f$ + " " + "tmp\tmp.map" OPEN "i", 1, "tmp\tmp.map" OPEN "o", 2, mapdir$ + f$ DO UNTIL EOF(1) LINE INPUT #1, s$ s$ = s$ + SPACE$(79 - LEN(s$)) IF s$ = star$ THEN s$ = LEFT$(star$, 34) + t$ + SPACE$(13 - LEN(t$)) + RIGHT$(star$, 32) IF comment$ <> "" THEN s$ = LEFT$(s$, 47) + SPACE$(32) END IF PRINT #2, RTRIM$(s$) LOOP CLOSE 2 CLOSE 1 SHELL "erase tmp\tmp.map" 5350 END IF: REM browser$=editor$ END IF: REM attached$="" IF reread = 0 GOTO 100 GOTO 50 5440 REM print gov FOR a = 1 TO numgov IF MID$(star$, 62, 2) = gov$(1, a) THEN PRINT gov$(2, a) NEXT a RETURN 5460 REM print coordinates t = VAL(MID$(star$, 1, 2)) / 10 + qx GOSUB 110 PRINT t$; ","; t = VAL(MID$(star$, 3, 2)) / 10 + qy GOSUB 110 PRINT t$; ","; t = VAL(MID$(star$, 5, 2)) / 10 + qz GOSUB 110 PRINT t$ RETURN 5480 REM read in colors layer data OPEN "i", 1, "data\colors.dat" FOR a = 12 TO 0 STEP -1 INPUT #1, t$ col(a) = VAL(LEFT$(t$, 2)) NEXT a CLOSE RETURN 5700 REM read config info bmpfile$ = "tmp\starmap.bmp" OPEN "i", 1, "starmap.cfg" INPUT #1, t$ editor$ = RIGHT$(t$, LEN(t$) - 7) INPUT #1, t$ reader$ = RIGHT$(t$, LEN(t$) - 7) INPUT #1, t$ INPUT #1, tt$ clrmode = VAL(RIGHT$(tt$, 1)) CLOSE 1 dir0$ = RIGHT$(t$, LEN(t$) - 7) galdir$ = dir0$ + "\" gendir$ = galdir$ + "gen\" locdir$ = galdir$ + "loc\" mapdir$ = galdir$ + "map\" hexdir$ = locdir$ sysdir$ = locdir$ datdir$ = galdir$ + "dat\" OPEN "i", 1, datdir$ + "coords.dat" INPUT #1, t$ tx = INT(VAL(RIGHT$(t$, LEN(t$) - 2))) INPUT #1, t$ ty = INT(VAL(RIGHT$(t$, LEN(t$) - 2))) INPUT #1, t$ tz = INT(VAL(RIGHT$(t$, LEN(t$) - 2))) CLOSE 1 qx = INT(tx / 10) * 10: xx = tx - qx qy = INT(ty / 10) * 10: yy = ty - qy qz = INT(tz / 10) * 10: zz = tz - qz OPEN "i", 1, "galaxy.lst" INPUT #1, t$ INPUT #1, t$ DO UNTIL EOF(1) INPUT #1, t$ t$ = RTRIM$(t$) IF t$ <> "" THEN IF LEFT$(t$, LEN(dir0$) + 1) = dir0$ + " " THEN galname$ = RIGHT$(t$, LEN(t$) - 13) END IF END IF LOOP CLOSE RETURN 5750 REM write configuration OPEN "o", 1, "starmap.cfg" PRINT #1, "editor:"; editor$ PRINT #1, "reader:"; reader$ PRINT #1, "galaxy:"; dir0$ PRINT #1, "colors:"; LTRIM$(RTRIM$(STR$(clrmode))) CLOSE 1 OPEN "o", 1, datdir$ + "coords.dat" PRINT #1, "x:"; LTRIM$(STR$(qx + xx)) PRINT #1, "y:"; LTRIM$(STR$(qy + yy)) PRINT #1, "z:"; LTRIM$(STR$(qz + zz)) CLOSE 1 RETURN 5800 REM error trapping IF ERR = 5 THEN RESUME NEXT SCREEN 0: COLOR 7: CLS PRINT "Warning: Error #"; ERR; "detected" PRINT "If you think this is a bug, please email me..." GOTO 6010 5850 REM set palette SELECT CASE clrmode CASE 1 REM colors on black PALETTE CASE 2 REM colors on white PALETTE: PALETTE 0, 4144959: PALETTE 15, 0 CASE 3 REM white on black t = 4144959 PALETTE 0, 0: PALETTE 1, t: PALETTE 2, t: PALETTE 3, t PALETTE 4, t: PALETTE 5, t: PALETTE 6, t: PALETTE 7, t PALETTE 8, t: PALETTE 9, t: PALETTE 10, t: PALETTE 11, t PALETTE 12, t: PALETTE 13, t: PALETTE 14, t: PALETTE 15, t CASE 4 REM black on white PALETTE 0, 4144959: PALETTE 1, 0: PALETTE 2, 0: PALETTE 3, 0 PALETTE 4, 0: PALETTE 5, 0: PALETTE 6, 0: PALETTE 7, 0 PALETTE 8, 0: PALETTE 9, 0: PALETTE 10, 0: PALETTE 11, 0 PALETTE 12, 0: PALETTE 13, 0: PALETTE 14, 0: PALETTE 15, 0 END SELECT RETURN 5900 REM y/n yn$ = "" GOSUB 2260 IF k2 = 0 AND (k1 >= 97 AND k1 <= 122) THEN k1 = k1 - 32 IF k2 = 0 AND k1 = 78 THEN yn$ = "n": REM N IF k2 = 0 AND k1 = 89 THEN yn$ = "y": REM Y IF yn$ = "" GOTO 5900 RETURN 5950 REM does file exist? OPEN "r", 1, testfile$ exist = LOF(1) CLOSE 1 IF exist = 0 THEN SHELL "erase " + testfile$ RETURN 6000 REM end SCREEN 0: COLOR 7: CLS PRINT PRINT "For Assistance and/or Snide Remarks:" 6010 PRINT PRINT " Email: jimv@empirenet.com" PRINT " JimVassila@aol.com" PRINT PRINT " Homepage: http://members.aol.com/jimvassila" PRINT END SUB savescr (filename$, sx, sy, ex, ey, nbits, imgnum) 'SAVESCR V0.6 - Screen Capture Function for Qbasic. 'By: Aaron Zabudsky 'Date: July 17, 1997 'Free - Comments welcome. ' 'Usage: filename$ - Name of the file you want to capture to. Overwrites any ' old image that may be under that name. ' sx - Starting X coordinate ' sy - Starting Y coordinate ' ex - Ending X coordinate ' ey - Ending Y coordinate ' nbits - Number of bits you want in your bitmap. Use 1, 4 or 8. ' Use nbits=1 for SCREEN 11 ' Use nbits=4 for SCREEN 12 ' Use nbits=8 for SCREEN 13 ' imgnum - The current number of the image you are saving to. ' This can be anything if you have specified a filename ' If you have specified a blank filename (""), Autonumbering ' is enabled and if you specify a number here, it will save ' the image as CAP0.BMP, CAP1.BMP,...,CAP1000.BMP,etc. ' If you leave a variable in this spot when you call the ' capture function, the function will automatically increment ' the variable, so you can "auto-capture" a series of ' pictures without worrying about numbers. ' ' e.g. savescr "test.bmp",0,0,639,479,4,0 ' will capture the entire SCREEN 12 screen with 16 colours and save it ' to test.bmp. ' savescr "",0,0,319,199,8,t ' will capture the entire SCREEN 13 screen with 256 colours and save it ' as CAP#.BMP, where # is the current value of t, it will then increment ' t. ' savescr "",0,0,639,479,1,(t) ' will capture the entire SCREEN 11 screen with 2 colours and save it ' as CAP#.BMP as in the previous example, but this time t will not be ' incremented. IF filename$ = "" THEN filename$ = "CAP" + LTRIM$(RTRIM$(STR$(imgnum))) + ".BMP" imgnum = imgnum + 1 END IF OPEN filename$ FOR BINARY AS #1 IF LOF(1) <> 0 THEN 'Alter this code here if you don't want it to overwrite existing files. CLOSE 1 KILL filename$ OPEN filename$ FOR BINARY AS #1 END IF va = &H3C7 'VGA Palette Read Address Register vd = &H3C9 'VGA Palette Data Register zero$ = CHR$(0) + CHR$(0) + CHR$(0) + CHR$(0) 'Check extents to order points. IF sx > ex THEN SWAP sx, ex IF sy > ey THEN SWAP sy, ey 'Use Windows BMP Header. Size=40 headersize = 40 'Calculate Picture width,height picwidth = ex - sx + 1 picheight = ey - sy + 1 'Set Colour Information 'Planes [W] - Must be 1 nplanes = 1 'Calculate offset [LW] to start of data IF nbits = 1 OR nbits = 4 OR nbits = 8 THEN offset = 14 + headersize + 4 * (2 ^ nbits) ELSE offset = 14 + headersize END IF 'Type of file [W] (Should be BM) ft$ = "BM" 'File Size [LW] (excluding header) IF nbits = 1 THEN IF (picwidth MOD 32) <> 0 THEN filesize = 4 * (INT(picwidth / 32) + 1) * picheight ELSE filesize = (picwidth / 8) * picheight END IF ELSEIF nbits = 4 THEN IF (picwidth MOD 8) <> 0 THEN filesize = 4 * (INT(picwidth / 8) + 1) * picheight ELSE filesize = (picwidth / 2) * picheight END IF ELSEIF nbits = 8 THEN IF (picwidth MOD 4) <> 0 THEN filesize = 4 * (INT(picwidth / 4) + 1) * picheight ELSE filesize = picwidth * picheight END IF ELSEIF nbits = 24 THEN IF (3 * picwidth MOD 4) <> 0 THEN filesize = 4 * (INT(3 * picwidth / 4) + 1) * picheight ELSE filesize = 3 * picwidth * picheight END IF END IF 'Set reserved values [W] (both must be zero) r1 = 0 r2 = 0 'Compression type [LW] - None comptype = 0 'Image Size [LW]; Scaling Factors xsize, ysize unused. imagesize = offset + filesize xsize = 0 ysize = 0 'Assume all colours used [LW] - 0 means all colours. coloursused = 0 neededcolours = 0 header$ = ft$ + MKL$(filesize) + MKI$(r1) + MKI$(r2) + MKL$(offset) infoheader$ = MKL$(headersize) + MKL$(picwidth) infoheader$ = infoheader$ + MKL$(picheight) + MKI$(nplanes) infoheader$ = infoheader$ + MKI$(nbits) + MKL$(comptype) + MKL$(imagesize) infoheader$ = infoheader$ + MKL$(xsize) + MKL$(ysize) + MKL$(coloursused) infoheader$ = infoheader$ + MKL$(neededcolours) 'Write headers to BMP File. PUT #1, 1, header$ PUT #1, , infoheader$ 'Add palette - Get colours (Write as B0G0R0(0),B1G1R1(0),...) IF nbits = 1 OR nbits = 4 OR nbits = 8 THEN palet$ = "" OUT va, 0 FOR count = 1 TO 2 ^ nbits zr = INP(vd) * 4 zg = INP(vd) * 4 zb = INP(vd) * 4 palet$ = palet$ + CHR$(zb) + CHR$(zg) + CHR$(zr) + CHR$(0) NEXT count PUT #1, , palet$ palet$ = "" 'Save some memory END IF stpoint = POINT(sx, ey + 1) 'BMPs are arranged with the top of the image at the bottom of the file. 'Get points off the screen and pack into bytes depending on the number of 'bits used. Deal with unused bits at the end of the line. 'Check for invalid range. FOR count2 = ey TO sy STEP -1 lin$ = "" IF nbits = 1 THEN count1 = sx WHILE count1 <= ex IF count1 + 7 > ex THEN t = 0 FOR count0 = 0 TO 7 p = POINT(count1 + count0, count2) IF p < 0 THEN p = 0 t = t + (2 ^ (7 - count0)) * (p MOD 2) NEXT count0 t2 = ex - count1 + 1 t = t AND ((2 ^ t2) - 1) * (2 ^ (8 - t2)) lin$ = lin$ + CHR$(t) ELSE t = 0 FOR count0 = 0 TO 7 p = POINT(count1 + count0, count2) IF p < 0 THEN p = 0 t = t + (2 ^ (7 - count0)) * (p MOD 2) NEXT count0 lin$ = lin$ + CHR$(t) END IF count1 = count1 + 8 WEND ELSEIF nbits = 4 THEN count1 = sx WHILE count1 <= ex IF count1 = ex THEN p = POINT(count1, count2) IF p < 0 THEN p = 0 lin$ = lin$ + CHR$((p MOD 16) * 16) ELSE p = POINT(count1, count2) p2 = POINT(count1 + 1, count2) IF p < 0 THEN p = 0 IF p2 < 0 THEN p2 = 0 lin$ = lin$ + CHR$((p MOD 16) * 16 + p2) END IF count1 = count1 + 2 WEND ELSEIF nbits = 8 THEN FOR count1 = sx TO ex p = POINT(count1, count2) IF p < 0 THEN p = 0 lin$ = lin$ + CHR$(p) NEXT count1 ELSEIF nbits = 24 THEN 'I'm not sure what to put here. QBasic doesn't support truecolour 'Unused for now. END IF 'Pad line to LongWord boundary IF (LEN(lin$) MOD 4) <> 0 THEN lin$ = lin$ + MID$(zero$, 1, 4 - (LEN(lin$) MOD 4)) END IF 'Indicate our status PSET (sx, count2 + 1), stpoint stpoint = POINT(sx, count2) IF nbits = 8 THEN PSET (sx, count2), 255 - stpoint ELSEIF nbits = 4 THEN PSET (sx, count2), 15 - stpoint ELSEIF nbits = 1 THEN PSET (sx, count2), 1 - stpoint END IF 'Write the current line to the BMP file PUT #1, , lin$ NEXT count2 'Save some memory lin$ = "" PSET (sx, count2 + 1), stpoint 'Close the file CLOSE END SUB