DEFINT A-Z' vsnchrt9 DECLARE SUB bmp (dest$) DECLARE FUNCTION dumper% (siz%) CONST ss$ = "dir--cht.tmp", alim = 32767, blim& = 2000000, xc = 190, yc = 256 CONST ls = 10, ts = 50, rs = 370, bs = 460, xfact! = 1.125, rxlim = 632 CONST cmp$ = "ABCDEFGHJKLMNPQRSTUWXYZ", rex$ = "reletter=", lx = 68, ly = 17 CONST big! = .06, sml! = .003 DIM SHARED ff, rmax, byte AS STRING * 1 f = FREEFILE: ff = 0: ON ERROR GOTO perr OPEN "i", #f, "vsnalph.bin": IF ff = 0 THEN q1& = LOF(f) CLOSE #f: ON ERROR GOTO 0 IF q1& <> 3463 THEN PRINT "vsnalph.bin not readable": END REDIM car(1727), cur(103) DEF SEG = VARSEG(car(0)): BLOAD "vsnalph.bin", VARPTR(car(0)) DEF SEG TYPE comparison xp AS LONG yp AS LONG mp AS INTEGER up AS INTEGER END TYPE ext$ = "*.CHT" SHELL "dir " + ext$ + "/o/b > " + ss$: q1& = 0 OPEN "i", #f, ss$: q1& = LOF(f): CLOSE #f IF q1& < 1 THEN PRINT "no "; ext$; " files... hit a key": g$ = INPUT$(1): KILL ss$: END n = 0: OPEN "i", #f, ss$ DO: LINE INPUT #f, b$: n = n + 1: LOOP UNTIL EOF(f): CLOSE #f REDIM name$(n): OPEN "i", #f, ss$ FOR x = 1 TO n: LINE INPUT #f, b$: name$(x) = b$: NEXT: CLOSE #f: KILL ss$ REDIM SHARED byt(479, 2), ps2(7, 2), c16(15) FOR x = 0 TO 7: ps2(x, 1) = 2 ^ (7 - x): NEXT FOR x = 0 TO 3: ps2(x, 0) = ps2(x * 2, 1) * 1.5: NEXT FOR y = 1 TO 2: FOR x = 0 TO 7: READ ps2(x, y): NEXT: NEXT FOR x = 0 TO 15: READ c16(x): NEXT cc = 1: f0 = 2: f4 = 0: flp = 1 DO: SCREEN 0, 0, 0: COLOR 14: CLS PRINT "VSNET chart plotter by Dave McAdam": COLOR 11 PRINT ; n; "files... scroll and select with the TAB key, or ESC to end" VIEW PRINT 4 TO 15 DO: CLS FOR y = 4 TO 14: x = y + cc - 9 IF x > 0 AND x <= n THEN LOCATE y, 1: COLOR 7 - (y = 9) * 3: PRINT ; name$(x) NEXT DO: g$ = INKEY$: LOOP UNTIL g$ <> "": f3 = 0 IF LEN(g$) = 1 THEN q = ASC(UCASE$(g$)) ELSE q = -ASC(RIGHT$(g$, 1)) SELECT CASE q CASE 27: f3 = 2 CASE -71: cc = 1 CASE -79: cc = n CASE -72: cc = cc + (cc > 1) CASE -80: cc = cc - (cc < n) CASE -73: cc = cc + (cc > 10) * 10 CASE -81: cc = cc - (cc < n - 10) * 10 CASE 9: tc = 0: scale! = .02: t3$ = "": VIEW PRINT: COLOR 7: CLS OPEN "i", #f, name$(cc) DO: LINE INPUT #f, b$: b$ = LTRIM$(RTRIM$(b$)) k = INSTR(b$, "1950") OR INSTR(b$, "2000") IF k > 16 THEN t3$ = LTRIM$(RTRIM$(b$)) k = INSTR(b$, "frame"): IF k > 2 THEN k = 0 IF LEN(b$) > 0 THEN PRINT b$ LOOP UNTIL EOF(f) OR k > 0 IF k > 0 THEN LINE INPUT #f, b$: g$ = UCASE$(b$): j = INSTR(g$, "SCALE") IF j > 0 THEN k = LEN(b$) DO: j = j + 1: LOOP UNTIL ASC(MID$(b$, j, 1)) < 33 OR j >= k IF j < k THEN DO: j = j + 1: LOOP UNTIL ASC(MID$(b$, j, 1)) > 32 OR j >= k IF j < k THEN scale! = VAL(RIGHT$(b$, k - j + 1)) IF scale! < .00001 THEN scale! = .02 END IF END IF END IF DO: LINE INPUT #f, b$: b$ = LTRIM$(RTRIM$(b$)) k = LEN(b$): f1 = 1 IF k > 0 THEN j = INSTR(b$, " ") IF j > 1 THEN x0& = VAL(LEFT$(b$, j - 1)) k = INSTR(j + 1, b$, " ") IF k > j THEN y0& = VAL(MID$(b$, j + 1, k - j - 1)) j = INSTR(k + 1, b$, " ") IF j > k THEN m0 = VAL(MID$(b$, k + 1, j - k - 1)) k = INSTR(j + 1, b$, " ") IF k > j THEN t0 = VAL(MID$(b$, j + 1, k - j - 1)) ELSE t0 = VAL(RIGHT$(b$, LEN(b$) - j)) END IF f1 = 0: tc = tc + 1 END IF END IF END IF END IF LOOP UNTIL EOF(f) OR f1 > 0 IF f1 > 0 THEN PRINT b$ DO WHILE NOT EOF(f): LINE INPUT #f, b$: b$ = LTRIM$(RTRIM$(b$)) IF LEN(b$) > 0 THEN PRINT b$ LOOP ELSE BEEP END IF CLOSE #f IF tc > 0 THEN REDIM par(tc) AS comparison, m3$(tc), l2$(tc), c2$(tc), ix(tc) OPEN "i", #f, name$(cc): bright = alim: faint = 0 lr& = blim&: rr& = 0: tr& = blim&: br& = 0 DO: LINE INPUT #f, t1$: k = INSTR(t1$, "frame"): IF k > 2 THEN k = 0 LOOP UNTIL k > 0 LINE INPUT #f, t2$: i = 0 DO: LINE INPUT #f, b$: b$ = LTRIM$(RTRIM$(b$)) k = LEN(b$) IF k > 0 THEN j = INSTR(b$, " ") IF j > 1 THEN x0& = VAL(LEFT$(b$, j - 1)) k = INSTR(j + 1, b$, " ") IF k > j THEN y0& = VAL(MID$(b$, j + 1, k - j - 1)) j = INSTR(k + 1, b$, " ") IF j > k THEN m4$ = MID$(b$, k + 1, j - k - 1): m0 = VAL(m4$) k = INSTR(j + 1, b$, " ") IF k > j THEN t0 = VAL(MID$(b$, j + 1, k - j - 1)): l0$ = RIGHT$(b$, LEN(b$) - k) ELSE t0 = VAL(RIGHT$(b$, LEN(b$) - j)): l0$ = "" END IF i = i + 1 par(i).xp = x0&: par(i).yp = y0&: par(i).mp = m0: par(i).up = t0 m3$(i) = m4$: l2$(i) = l0$: c2$(i) = "" IF x0& < lr& THEN lr& = x0& IF x0& > rr& THEN rr& = x0& IF y0& < tr& THEN tr& = y0& IF y0& > br& THEN br& = y0& IF m0 > 1 THEN IF m0 > faint THEN faint = m0 IF m0 < bright THEN bright = m0 END IF END IF END IF END IF END IF LOOP UNTIL EOF(f) OR i >= tc f8 = 0 IF NOT EOF(f) THEN DO: LINE INPUT #f, b$: i = INSTR(b$, rex$): LOOP UNTIL EOF(f) OR i > 0 IF i > 0 THEN y = LEN(b$): x = 0: f7 = 1: f2 = 1: f0 = 4 DO: i = INSTR(i + 1, b$, "=") IF i > 0 AND i < y THEN k = INSTR(i + 1, b$, "=") IF k > i THEN x = x + 1: c2$(x) = MID$(b$, i + 1, k - i - 1) END IF LOOP UNTIL i < 2 OR k < i k = INSTR(b$, "@") IF k > 0 THEN f8 = VAL(RIGHT$(b$, y - k)) ELSE FOR i = 1 TO tc: c2$(i) = "": NEXT: f7 = 0: f2 = 0: IF f0 = 4 THEN f0 = 2 END IF END IF CLOSE #f IF tc > 1 THEN ' sort putting zero mags at end PRINT "Sorting... "; FOR x = 1 TO tc - 1: xx = x FOR y = x + 1 TO tc IF par(y).mp > par(xx).mp THEN xx = y NEXT IF xx <> x THEN SWAP par(x), par(xx): SWAP m3$(x), m3$(xx): SWAP l2$(x), l2$(xx) NEXT z = tc + 1 DO: z = z - 1: LOOP UNTIL par(z).mp > 0 OR z < 2 IF z > 1 THEN ' sort positive mags FOR x = 1 TO z - 1: xx = x FOR y = x + 1 TO z IF par(y).mp < par(xx).mp THEN xx = y NEXT IF xx <> x THEN SWAP par(x), par(xx): SWAP m3$(x), m3$(xx): SWAP l2$(x), l2$(xx) NEXT END IF END IF IF LEN(t1$) > 0 THEN DO: x = INSTR(t1$, " ") IF x > 0 THEN t1$ = LEFT$(t1$, x) + RIGHT$(t1$, LEN(t1$) - x - 1) LOOP UNTIL x < 1 END IF IF LEN(t2$) > 0 THEN DO: x = INSTR(t2$, " ") IF x > 0 THEN t2$ = LEFT$(t2$, x) + RIGHT$(t2$, LEN(t2$) - x - 1) LOOP UNTIL x < 1 END IF IF LEN(t3$) > 0 THEN DO: x = INSTR(t3$, " ") IF x > 0 THEN t3$ = LEFT$(t3$, x) + RIGHT$(t3$, LEN(t3$) - x - 1) LOOP UNTIL x < 1 END IF mlim = faint: w& = FRE(t3$) wfact! = (rs - ls) / ((rr& - lr&) * xfact!) w& = rr& + lr&: xr& = INT(w& / 2) rfact! = (bs - ts) / ((br& - tr&) * xfact!) w& = br& + tr&: yr& = INT(w& / 2) IF wfact! < rfact! THEN rfact! = wfact! wfact! = rfact!: xw& = xr&: yw& = yr& f6 = 0: PRINT ; "hit a key": g$ = INPUT$(1) SCREEN 12: WIDTH 80, 30: f1 = 0 IF cur(0) < 1 THEN LINE (0, 0)-(16, 16), 14: LINE (0, 16)-(16, 0), 14 GET (0, 0)-(16, 16), cur(0) END IF DO: magfac! = 8 / (mlim - bright) IF f0 = 9 THEN COLOR 11: CLS : f0 = 2: f2 = 0: f6 = 2: tc2 = 0: f9 = 0 PRINT "re-lettering - scroll and select Comparison, Legend, None, or Var, C,L,N,V" PRINT "when finished press ENTER to retain the lettering or ESC to discard" LINE (ls - 2, ts - 2)-(rs + 2, bs + 2), , B FOR x = 1 TO tc xx = (par(x).xp - xw&) * wfact! * flp + xc: yy = (par(x).yp - yw&) * wfact! * flp + yc mag = par(x).mp: IF mag < 2 THEN mag = faint IF xx > ls AND xx < rs AND yy > ts AND yy < bs THEN IF mag <= mlim THEN tc2 = tc2 + 1: ix(tc2) = x: mag = (mlim - mag) * magfac! + 2 CIRCLE (xx, yy), mag, 2 - (c2$(x) > "") * 9, , , 1 END IF IF x = f8 THEN PUT (xx - 8, yy - 8), cur(0): f9 = 1 ELSE c2$(x) = "" END IF NEXT IF f9 = 0 THEN f8 = 0 IF tc2 > 0 THEN y = 1 DO: x = ix(y) xx = (par(x).xp - xw&) * wfact! * flp + xc: yy = (par(x).yp - yw&) * wfact! * flp + yc mag = par(x).mp: IF mag < 2 THEN mag = faint mag = (mlim - mag) * magfac! + 2: CIRCLE (xx, yy), mag, 15, , , 1 LOCATE 8, 50: COLOR 7: PRINT "mag= "; m3$(x); SPC(81 - POS(0)); LOCATE 9, 50: PRINT "Legend= "; l2$(x); SPC(81 - POS(0)); LOCATE 11, 50: COLOR 10 IF c2$(x) = "" THEN PRINT ; " None"; ELSEIF LEFT$(c2$(x), 1) = "*" THEN PRINT ; " Legend"; ELSE PRINT ; "Comparison"; END IF PRINT ; " selected" DO: g$ = INKEY$: LOOP UNTIL g$ <> "" IF LEN(g$) = 1 THEN q = ASC(UCASE$(g$)) ELSE q = -ASC(RIGHT$(g$, 1)) SELECT CASE q CASE -80, -77 CIRCLE (xx, yy), mag, 2 - (c2$(x) > "") * 9, , , 1 y = y + 1: IF y > tc2 THEN y = 1 CASE -72, -75 CIRCLE (xx, yy), mag, 2 - (c2$(x) > "") * 9, , , 1 y = y - 1: IF y < 1 THEN y = tc2 CASE 67: c2$(x) = "C" CASE 76: c2$(x) = "*" CASE 78: c2$(x) = "" CASE 86 IF f9 > 0 THEN jj = (par(f8).xp - xw&) * wfact! * flp + xc kk = (par(f8).yp - yw&) * wfact! * flp + yc: PUT (jj - 8, kk - 8), cur(0) END IF f8 = x: PUT (xx - 8, yy - 8), cur(0): f9 = 1 CASE ELSE END SELECT LOOP UNTIL q = 13 OR q = 27 wc = 0: wl = 0 FOR x = 1 TO tc IF q = 13 AND c2$(x) > "" THEN IF LEFT$(c2$(x), 1) = "*" THEN wc = wc + 1: c2$(x) = "*" + LTRIM$(RTRIM$(STR$(wc))) ELSE wl = wl + 1: o$ = MID$(cmp$, ((wl - 1) MOD 23) + 1, 1) g$ = "": i = INT((wl - 1) / 23) DO: g$ = g$ + o$: i = i - 1: LOOP UNTIL i < 0 c2$(x) = g$ END IF ELSE c2$(x) = "" END IF NEXT IF q = 13 THEN f0 = 4: f2 = 1: f6 = 1 ELSE IF f7 = 0 THEN f6 = 0 ELSE BEEP: IF f7 = 0 THEN f6 = 0 END IF END IF COLOR 15: CLS : PRINT ; t3$: PRINT t1$: PRINT t2$: rmax = rs + 10 bm = mlim: fm = 0: x = LEN(t3$) * 8: IF x > rmax THEN rmax = x LINE (ls - 2, ts - 2)-(rs + 2, bs + 2), , B: x = 0: u! = 0 DO: y = bs - x + 2: LINE (ls - 2, y)-(ls + 2, y) xx = ls - 2 + x: IF xx < rs THEN LINE (xx, bs + 2)-(xx, bs - 2) u! = u! + 60 / scale!: x = CINT(u! * wfact!) LOOP UNTIL x > bs - ts FOR x = 1 TO tc: xx = (par(x).xp - xw&) * wfact! * flp + xc IF xx > ls AND xx < rs THEN yy = (par(x).yp - yw&) * wfact! * flp + yc IF yy > ts AND yy < bs THEN mag = par(x).mp: IF mag < 2 THEN mag = faint IF mag <= mlim THEN IF mag < bm THEN bm = mag IF mag > fm THEN fm = mag mag = (mlim - mag) * magfac! + 2 IF f4 = 0 THEN CIRCLE (xx, yy), mag + 1, 2, , , 1: PAINT (xx, yy), 0, 2 CIRCLE (xx, yy), mag + 1, 0, , , 1 END IF CIRCLE (xx, yy), mag, 15, , , 1: IF f4 = 0 THEN PAINT (xx, yy), 15 END IF IF x = f8 THEN PUT (xx - 8, yy - 8), cur(0) END IF END IF g$ = INKEY$ IF g$ > "" THEN f1 = 0 IF LEN(g$) = 1 THEN xx = INSTR("ZXCNMLBRQFDI" + CHR$(9) + CHR$(27), UCASE$(g$)) IF xx < 1 OR ((xx = 1) AND (wfact! >= big!)) OR ((xx = 2) AND (wfact! <= sml!)) OR ((xx = 3) AND (f2 < 1)) THEN g$ = "" ELSE xx = INSTR("HKMP", RIGHT$(g$, 1)): IF xx < 1 THEN g$ = "" END IF IF g$ > "" THEN EXIT FOR END IF NEXT IF g$ > "" THEN GOTO over IF f0 > 0 THEN FOR x = 1 TO tc: yy = (par(x).yp - yw&) * wfact! * flp + yc - 3 IF yy > ts AND yy < bs - 4 THEN mag = par(x).mp: IF mag < 2 THEN mag = faint IF mag <= mlim THEN mag = (mlim - mag) * magfac! + 2 xx = (par(x).xp - xw&) * wfact! * flp + xc + mag + 3 IF xx > ls AND xx < rs THEN IF par(x).mp > 0 AND (f0 = 1 OR f0 = 3) THEN FOR y = 1 TO LEN(m3$(x)) PUT (xx, yy), car((ASC(MID$(m3$(x), y, 1)) - 32) * 18): xx = xx + 8 NEXT END IF IF LEN(l2$(x)) > 0 THEN IF par(x).mp > 0 AND f0 = 3 THEN PUT (xx, yy), car((ASC("=") - 32) * 18): xx = xx + 8 IF f0 = 2 OR f0 = 3 THEN FOR y = 1 TO LEN(l2$(x)) PUT (xx, yy), car((ASC(MID$(l2$(x), y, 1)) - 32) * 18): xx = xx + 8 NEXT END IF END IF IF f0 = 4 AND LEN(c2$(x)) > 0 THEN FOR y = 1 TO LEN(c2$(x)) PUT (xx, yy), car((ASC(MID$(c2$(x), y, 1)) - 32) * 18): xx = xx + 8 NEXT END IF END IF END IF END IF IF xx > rmax THEN rmax = xx NEXT IF f0 = 4 THEN i = ts FOR x = 1 TO tc IF LEN(c2$(x)) > 0 THEN xx = rs + 12 FOR y = 1 TO LEN(c2$(x)) PUT (xx, i), car((ASC(MID$(c2$(x), y, 1)) - 32) * 18): xx = xx + 8 NEXT: xx = xx + 8 IF par(x).mp > 0 THEN FOR y = 1 TO LEN(m3$(x)) IF xx < rxlim THEN PUT (xx, i), car((ASC(MID$(m3$(x), y, 1)) - 32) * 18): xx = xx + 8 NEXT: xx = xx + 8 END IF IF LEN(l2$(x)) > 0 THEN FOR y = 1 TO LEN(l2$(x)) IF xx < rxlim THEN PUT (xx, i), car((ASC(MID$(l2$(x), y, 1)) - 32) * 18): xx = xx + 8 NEXT END IF i = i + 9 END IF IF xx > rmax THEN rmax = xx IF i > 470 THEN EXIT FOR NEXT END IF END IF IF fm > 0 THEN LOCATE 30, 1: PRINT ; "mags"; bm; "to"; fm; LOCATE 30, 24: IF flp > 0 THEN PRINT ; "S"; ELSE PRINT ; "N"; over: COLOR 10 IF f1 = 0 THEN IF g$ = "" THEN LOCATE ly, lx: PRINT "No text" LOCATE ly + 1, lx: PRINT "Mags" LOCATE ly + 2, lx: PRINT "Legends" LOCATE ly + 3, lx: PRINT "Both M+L" LOCATE ly + 4, lx: PRINT "Re-letter" IF f2 > 0 THEN LOCATE ly + 5, lx: PRINT "Comparisons" LOCATE ly + 6, lx: PRINT "Q mag limit" LOCATE ly + 7, lx: PRINT "Flip N/S" LOCATE ly + 8, lx: PRINT "Dot fill" LOCATE ly + 9, lx: PRINT "Zoom X=out" LOCATE ly + 10, lx: PRINT "Initialize" LOCATE ly + 11, lx: PRINT "Plot" LOCATE ly + 12, lx: PRINT " or TAB/ESC"; END IF DO: f5 = 0: IF g$ = "" THEN DO: g$ = INKEY$: LOOP UNTIL g$ <> "" IF LEN(g$) = 1 THEN q = ASC(UCASE$(g$)) ELSE q = -ASC(RIGHT$(g$, 1)) SELECT CASE q CASE 9, 27: f3 = 1 IF f6 > 0 THEN LINE (lx * 8 - 8, ly * 16 - 16)-(639, 479), 0, BF BEEP: COLOR 15: LOCATE 22, 60 IF f6 > 1 THEN PRINT "delete the filed" ELSE PRINT "save the new" LOCATE 23, 60: PRINT "lettering?... Y/N" DO: g$ = UCASE$(INPUT$(1)): LOOP UNTIL g$ = "Y" OR g$ = "N" IF g$ = "Y" THEN aa$ = rex$ FOR x = 1 TO tc: aa$ = aa$ + c2$(x) + "=": NEXT IF f8 > 0 THEN aa$ = aa$ + "@" + LTRIM$(RTRIM$(STR$(f8))) IF f7 = 0 AND f6 = 1 THEN OPEN "a", #f, name$(cc): PRINT #f, aa$: CLOSE #f ELSE nnam$ = LEFT$(name$(cc), LEN(name$(cc)) - 3) + "tmp" OPEN "i", #f, name$(cc): f7 = FREEFILE OPEN "o", #f7, nnam$ DO: LINE INPUT #f, b$: i = INSTR(b$, rex$) IF i < 1 THEN PRINT #f7, b$ ELSEIF f6 = 1 THEN PRINT #f7, aa$ END IF LOOP UNTIL EOF(f) OR i > 0 CLOSE #f: CLOSE #f7: KILL name$(cc) b$ = "ren " + nnam$ + " " + name$(cc): SHELL b$ END IF END IF END IF CASE 78: f0 = 0 CASE 77: f0 = 1 CASE 76: f0 = 2 CASE 66: f0 = 3 CASE 67: IF f2 > 0 THEN f0 = 4 ELSE f5 = 1 CASE 82: f0 = 9 CASE 68: f4 = NOT f4 CASE 70: flp = -flp CASE 80: LINE (lx * 8 - 8, ly * 16 - 16)-(639, 479), 0, BF: COLOR 15 LOCATE 20, 60: PRINT "BMP file, or..." LOCATE 21, 60: PRINT "?Epson compatible?" LOCATE 22, 60: PRINT "Large, Small print" LOCATE 23, 60: PRINT " ...or Abandon" DO: g$ = UCASE$(INPUT$(1)): f1 = INSTR("LSBA", g$) LOOP UNTIL f1 > 0 IF f1 > 3 THEN f1 = 0 ELSEIF f1 = 3 THEN dest$ = LEFT$(name$(cc), LEN(name$(cc)) - 3) + "BMP": ff = 0 ON ERROR GOTO perr: OPEN "i", #f, dest$: CLOSE #f: ON ERROR GOTO 0 IF ff = 0 THEN COLOR 13: LOCATE 25, 20 PRINT dest$; " exists... Overwrite, or Abandon [O/A] "; DO: g$ = UCASE$(INPUT$(1)): LOOP UNTIL g$ = "A" OR g$ = "O" PRINT ; g$: IF g$ = "A" THEN f1 = 0 ELSE KILL dest$ END IF END IF CASE 73: wfact! = rfact!: xw& = xr&: yw& = yr& CASE -80: yw& = yw& + 500 * flp CASE -72: yw& = yw& - 500 * flp CASE -77: xw& = xw& + 500 * flp CASE -75: xw& = xw& - 500 * flp CASE 90: IF wfact! < big! THEN wfact! = wfact! * xfact! ELSE f5 = 1 CASE 88: IF wfact! > sml! THEN wfact! = wfact! / xfact! ELSE f5 = 1 CASE 81: LINE (lx * 8 - 8, ly * 16 - 16)-(639, 479), 0, BF COLOR 15: LOCATE 22, 60: PRINT "brightest"; bright LOCATE 23, 60: PRINT "faintest"; faint LOCATE 24, 60: PRINT "scroll, then Enter" DO: LOCATE 25, 60: PRINT "limit"; mlim; " " DO: g$ = INKEY$: LOOP UNTIL g$ <> "": f5 = 0 IF LEN(g$) = 1 THEN q = ASC(UCASE$(g$)) ELSE q = -ASC(RIGHT$(g$, 1)) SELECT CASE q CASE -72: mlim = mlim + (mlim > bright + 50) CASE -80: mlim = mlim - (mlim < faint) CASE -75: mlim = mlim + (mlim > bright + 59) * 10 CASE -77: mlim = mlim - (mlim < faint - 9) * 10 CASE -115: mlim = mlim + (mlim > bright + 149) * 100 CASE -116: mlim = mlim - (mlim < faint - 99) * 100 CASE ELSE END SELECT LOOP UNTIL q = 13 CASE ELSE: f5 = 1 END SELECT g$ = "" LOOP UNTIL f5 = 0 ELSEIF f1 = 3 THEN bmp dest$: f1 = 0 ELSE f1 = dumper(f1 - 1) IF f1 <> 0 THEN COLOR 15: LOCATE 27, 60: PRINT "printer error": BEEP LOCATE 28, 60: PRINT "hit a key": g$ = INPUT$(1): f1 = 0 END IF END IF LOOP UNTIL f3 > 0 ELSE PRINT : PRINT "Can't read data lines": BEEP: g$ = INPUT$(1) END IF CASE ELSE END SELECT LOOP UNTIL f3 > 0 LOOP UNTIL f3 > 1 END perr: ff = -1: RESUME NEXT ON ERROR GOTO 0 'plot masks for X3 pixels DATA 224,28,3,112,14,1,56,7 DATA 0,0,128,0,0,192,0,0 'colours DATA 0,4,2,6,1,5,3,7,8,12,10,14,9,13,11,15 SUB bmp (dest$) fff = FREEFILE: OPEN dest$ FOR BINARY AS #fff x9 = rmax: IF x9 > 640 THEN x9 = 640 y9 = 480 r0 = &H4D42: PUT #fff, 1, r0' BM xl = INT((x9 + 7) / 8) * 8 iz& = xl: iz& = iz& / 2 * y9 + 118: PUT #fff, 3, iz&'length of file iz& = 0: PUT #fff, 7, iz&' reserved iz& = 118&: PUT #fff, 11, iz&' offset to map data iz& = &H28&: PUT #fff, 15, iz&' header size iz& = x9: PUT #fff, 19, iz&' x pix iz& = y9: PUT #fff, 23, iz&' y pix iz& = &H40001: PUT #fff, 27, iz&' 1 plane 4 bits iz& = 0: PUT #fff, 31, iz&' no compression iz& = x9: iz& = iz& * y9: PUT #fff, 35, iz&' size of image iz& = 0: PUT #fff, 39, iz&: PUT #fff, 43, iz&'x&y pelspermeter iz& = 16&: PUT #fff, 47, iz&: PUT #fff, 51, iz&'colours used & important iz& = 0: PUT #fff, 55, iz&: iz& = &H800000: PUT #fff, 59, iz& iz& = &H8000&: PUT #fff, 63, iz&: iz& = &H808000: PUT #fff, 67, iz& iz& = &H80&: PUT #fff, 71, iz&: iz& = &H800080: PUT #fff, 75, iz& iz& = &H8080&: PUT #fff, 79, iz&: iz& = &H808080: PUT #fff, 83, iz& iz& = &HC0C0C0: PUT #fff, 87, iz&: iz& = &HFF0000: PUT #fff, 91, iz& iz& = &HFF00&: PUT #fff, 95, iz&: iz& = &HFFFF00: PUT #fff, 99, iz& iz& = &HFF&: PUT #fff, 103, iz&: iz& = &HFF00FF: PUT #fff, 107, iz& iz& = &HFFFF&: PUT #fff, 111, iz&: iz& = &HFFFFFF: PUT #fff, 115, iz& iz& = 119: byte = CHR$(0) FOR y8 = y9 - 1 TO 0 STEP -1 FOR x8 = 0 TO xl - 2 STEP 2 IF x8 >= x9 THEN byte = CHR$(0) ELSE r0 = POINT(x8, y8): IF r0 = 0 THEN PSET (x8, y8), 8 IF x8 + 1 = x9 THEN q0 = 0 ELSE q0 = POINT(x8 + 1, y8): IF q0 = 0 THEN PSET (x8 + 1, y8), 8 END IF byte = CHR$(c16(q0) + c16(r0) * 16) END IF PUT #fff, iz&, byte: iz& = iz& + 1 NEXT NEXT CLOSE #fff END SUB FUNCTION dumper (siz) ' 0=double pixels, 1=triple pixels v0 = 12 - siz * 4: v1 = 2 + siz IF siz = 0 AND rmax > 624 THEN rmax = 624 rmax = INT((rmax + v0 - 1) / v0) * v0 dbw = 480 * (2 + siz): dbl = dbw MOD 256: dbh = INT(dbw / 256) fyl = FREEFILE: ff = 0: ON ERROR GOTO perr WIDTH "lpt1:", 255: OPEN "lpt1:BIN" FOR OUTPUT AS #fyl PRINT #fyl, CHR$(27); CHR$(64); CHR$(27); CHR$(51); CHR$(24); CHR$(27); CHR$(115); CHR$(1); ON ERROR GOTO 0 IF ff THEN GOTO eek FOR x9 = 0 TO rmax STEP v0 FOR y9 = 479 TO 0 STEP -1: FOR v2 = 0 TO 2: byt(y9, v2) = 0: NEXT FOR uu = 0 TO v0 - 1: v2 = x9 + uu IF POINT(v2, y9) > 0 THEN IF siz = 0 THEN v3 = INT(uu / 4): byt(y9, v3) = byt(y9, v3) OR ps2(uu MOD 4, 0) ELSE v3 = INT(uu / 3): byt(y9, v3) = byt(y9, v3) OR ps2(uu, 1) IF v3 < 2 THEN byt(y9, v3 + 1) = byt(y9, v3 + 1) OR ps2(uu, 2) END IF PSET (v2, y9), 7 END IF NEXT: NEXT ON ERROR GOTO perr PRINT #fyl, CHR$(27); CHR$(42); CHR$(39); CHR$(dbl); CHR$(dbh); FOR y9 = 479 TO 0 STEP -1: FOR v2 = 1 TO v1: FOR v3 = 0 TO 2 PRINT #fyl, CHR$(byt(y9, v3)); NEXT: NEXT: NEXT PRINT #fyl, CHR$(10); ON ERROR GOTO 0 IF ff < 0 THEN ELSE g$ = INKEY$: IF g$ <> "" THEN ff = -2 IF ff < 0 THEN EXIT FOR NEXT eek: CLOSE #fyl: IF ff = -1 THEN dumper = -1 END FUNCTION