REM Mapper v0.1
REM Public Domain 1997 Jim Vassilakos
REM San Bernardino, California
REM jimv@empirenet.com
REM Written in Microsoft QuickBasic version 4.5
REM Includes SAVESCR v0.6 by Aaron Zabudsky <zabudsk@ecf.utoronto.ca>

DECLARE SUB savescr (filename$, sx!, sy!, ex!, ey!, nbits!, imgnum!)

DIM smlet(13, 44) AS INTEGER
DIM lglet(30, 70) AS INTEGER
DIM lrow$(13)
DIM length%(70, 2)
DIM col%(1600)
DIM place%(40, 2)
DIM name$(40, 2)
DIM lines%(50, 5)
DIM folk%(100, 4)
DIM folk$(100, 2)
DIM colsum(16)
DIM colname$(16)
DIM ck$(16)
DIM fontfile$(2)
DIM rows(2)
DIM numlet(2)
DIM lets$(2)

DEF FNhex (ft, fu)
   tmp = (fu - 1) * 40
   tmp = tmp + ft
   FNhex = tmp
END DEF

DEF FNzero$ (f6, f7)
   f8$ = LTRIM$(RTRIM$(STR$(f6)))
   FNzero$ = STRING$(f7 - LEN(f8$), "0") + f8$
END DEF

DEF FNfile$ (f1$, f2$)
   REM figure out f3 & f4
   f3 = VAL(MID$(f1$, 2, 3))
   f4 = VAL(MID$(f1$, 6, 3))
   IF MID$(f1$, 1, 1) = "s" THEN f3 = -f3
   IF MID$(f1$, 5, 1) = "w" THEN f4 = -f4
   REM apply f2$
   IF f2$ = "n" THEN f3 = f3 + 1
   IF f2$ = "s" THEN f3 = f3 - 1
   IF f2$ = "e" THEN f4 = f4 + 1
   IF f2$ = "w" THEN f4 = f4 - 1
   REM construct f5$
   IF f3 >= 0 THEN
      f5$ = "n"
   ELSE
      f5$ = "s"
   END IF
   f5$ = f5$ + FNzero$(ABS(f3), 3)
   IF f4 >= 0 THEN
      f5$ = f5$ + "e"
   ELSE
      f5$ = f5$ + "w"
   END IF
   f5$ = f5$ + FNzero$(ABS(f4), 3)
   f5$ = f5$ + ".map"
   FNfile$ = f5$
END DEF

DEF FNsec$ (f1$)
   IF MID$(f1$, 1, 1) = "n" THEN tmp$ = "North-"
   IF MID$(f1$, 1, 1) = "s" THEN tmp$ = "South-"
   tmp$ = tmp$ + MID$(f$, 2, 3) + ", "
   IF MID$(f1$, 5, 1) = "e" THEN tmp$ = tmp$ + "East-"
   IF MID$(f1$, 5, 1) = "w" THEN tmp$ = tmp$ + "West-"
   tmp$ = tmp$ + MID$(f1$, 6, 3)
   FNsec$ = tmp$
END DEF

SCREEN 12
GOSUB 5600: REM read colors.cmd
GOSUB 5700: REM read configuration
GOSUB 5000: REM read fonts
GOSUB 5200: REM calculate video stuff
GOSUB 5750: REM read objects (including starting coordinates)

fp1 = 1: fp2 = 1: fp3old = 7: fp4old = 3
10 REM front page
SCREEN 0: CLS : COLOR 14
PRINT "World Mapper (v0.1)"
PRINT "Public Domain 1997 Jim Vassilakos"
PRINT
COLOR 10: PRINT "Current World: "; nworld$
LOCATE 4, 50: COLOR 13: PRINT "Editor: "; editor$
COLOR 10: PRINT "Coordinates: "; FNsec$(f$);
LOCATE 5, 50: COLOR 13: PRINT "Reader: "; reader$
PRINT : COLOR 11
PRINT "      About this Program         View/Edit Map"
PRINT
PRINT "      Select Text Editor         Read World Notes"
PRINT "      Select Text Reader         Edit World Notes"
PRINT
PRINT "      Quit                       Select/Create World"

14 REM arrow
LOCATE fp3old, fp4old
PRINT "  "
IF fp1 = 1 THEN fp3 = 7
IF fp1 = 2 THEN fp3 = 9
IF fp1 = 3 THEN fp3 = 10
IF fp1 = 4 THEN fp3 = 12
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 900
IF k2 = 0 AND (k1 >= 97 AND k1 <= 122) THEN k1 = k1 - 32
IF k2 = 0 AND k1 = 27 GOTO 10000: REM esc
IF k2 = 0 AND k1 = 81 GOTO 10000: 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 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 = 0
IF fp1 < 1 THEN fp1 = 4
IF fp1 > 4 THEN fp1 = 1
SOUND 10000, .1
GOTO 14

18 REM enter
IF fp1 = 1 AND fp2 = 1 GOTO 19
IF fp1 = 2 AND fp2 = 1 GOTO 21
IF fp1 = 3 AND fp2 = 1 GOTO 22
IF fp1 = 4 AND fp2 = 1 GOTO 10000
IF fp1 = 1 AND fp2 = 2 GOTO 100
IF fp1 = 2 AND fp2 = 2 GOTO 26
IF fp1 = 3 AND fp2 = 2 GOTO 28
IF fp1 = 4 AND fp2 = 2 GOTO 23

19 REM Help
GOSUB 5500: REM egacolor
SHELL "eg help\help.mnu " + reader$
GOTO 10

21 REM change editor
SHELL "cfg 1"
GOSUB 5700
GOTO 10

22 REM change reader
SHELL "cfg 2"
GOSUB 5700
GOTO 10

23 REM change world
SHELL "cfg 3"
GOSUB 5700
GOSUB 5750
GOTO 10

26 REM read world notes
SHELL "eg " + world$ + "\gen\world.mnu " + reader$
GOTO 10

28 REM edit world notes
SHELL "eg " + world$ + "\gen\world.mnu " + editor$
GOTO 10

100 REM load map
GOSUB 5750: REM load objects first
GOSUB 1000: REM load 40*40 sector

140 REM graphics mode
CLS
SCREEN 12

150 REM draw world's hex grid
CLS
REM draw blue hexs
COLOR 1
REM LINE (1, 1)-(600, 415), , B
FOR hex = 1 TO 1600
   GOSUB 500: REM get t/u
   GOSUB 550: REM get cent1/cent2
   GOSUB 600: REM draw hex
   pt = t: pu = u
   GOSUB 650: REM fill hex
NEXT hex

REM draw places
IF numplace <> 0 THEN
   FOR np = 1 TO numplace
      hex = place%(np, 1)
      GOSUB 1200: REM draw location
   NEXT np
END IF

IF bmp = 0 THEN
   GOSUB 690: REM map section designation
   GOSUB 700: REM color menu
   GOSUB 750: REM quit/readme hint
   REM show world$ & section$
   IF tog2 = 1 THEN GOSUB 810: REM spam
END IF

REM set starting location for the magenta circle/cursor
hex = starthex
GOSUB 500: REM get t/u
pt = t: pu = u

160 REM return here

GOSUB 1100: REM erase status line

REM draw lines
IF numlines > 0 THEN
   FOR a = 1 TO numlines
      hex = lines%(a, 1)
      GOSUB 500: GOSUB 550: REM find center coords
      v1 = cent1: v2 = cent2
      hex = lines%(a, 2)
      GOSUB 500: GOSUB 550: REM find center coords
      v3 = cent1: v4 = cent2
      v3 = v3 + 480 * lines%(a, 3)
      v4 = v4 + 400.2 * lines%(a, 4)
      LINE (v1, v2)-(v3, v4), lines%(a, 5)
   NEXT a
END IF

REM draw places
IF numplace > 0 THEN
   REM hexnow = FNhex(pt, pu)
   FOR np = 1 TO numplace
      hex = place%(np, 1)
      REM IF hex = hexnow THEN GOSUB 1200: REM draw location
      GOSUB 1200: REM draw location
   NEXT np
END IF
GOSUB 1300: REM draw folks

IF bmp = 1 GOTO 285

GOSUB 800: REM draw circle/cursor
IF tog1 = 1 THEN GOSUB 805: REM hex#

200 GOSUB 900
IF k2 = 0 AND (k1 >= 97 AND k1 <= 122) THEN k1 = k1 - 32
IF k2 = 1 AND k1 = 72 GOTO 210: REM up
IF k2 = 1 AND k1 = 80 GOTO 220: REM down
IF k2 = 1 AND k1 = 75 GOTO 230: REM left
IF k2 = 1 AND k1 = 77 GOTO 240: REM right
IF k2 = 1 AND k1 = 73 GOTO 212: REM pgup
IF k2 = 1 AND k1 = 81 GOTO 222: REM pgdn
IF k2 = 1 AND k1 = 15 GOTO 232: REM shift-tab
IF k2 = 0 AND k1 = 9 GOTO 242: REM tab
IF k2 = 0 AND k1 = 13 GOTO 260: REM enter
IF k2 = 0 AND k1 = 32 GOTO 260: REM space
IF k2 = 1 AND k1 = 82 GOTO 300: REM insert
IF k2 = 1 AND k1 = 83 GOTO 350: REM delete
IF k2 = 0 AND k1 = 11 GOTO 370: REM ctrl-k
IF k2 = 0 AND k1 = 12 GOTO 205: REM ctrl-l
IF k2 = 0 AND k1 = 14 GOTO 680: REM ctrl-n
IF k2 = 0 AND k1 = 15 GOTO 492: REM ctrl-o
IF k2 = 0 AND k1 = 1 GOTO 265: REM ctrl-a
IF k2 = 0 AND k1 = 8 OR k1 = 22 GOTO 290: REM ctrl-h/ctrl-v
IF k2 = 0 AND (k1 = 63 OR k1 = 82) GOTO 490: REM ?/R
IF k2 = 0 AND k1 = 27 GOTO 9900: REM esc
IF k2 = 0 AND k1 >= 65 AND k1 <= 80 GOTO 250: REM A-P
IF k2 = 0 AND k1 = 81 GOTO 9900: REM Q
IF k2 = 0 AND (k1 = 5 OR k1 = 60) GOTO 495: REM ctrl-e or <
IF k2 = 0 AND k1 = 19 THEN
   GOSUB 1050: REM ctrl-s / save map
   GOSUB 5800: REM save objects
END IF
IF k2 = 0 AND k1 = 24 GOTO 9950: REM ctrl-x
IF k2 = 0 AND k1 = 83 GOTO 270: REM S
IF k2 = 1 AND k1 = 59 GOTO 201: REM F1
IF k2 = 1 AND k1 = 60 GOTO 202: REM F2
IF k2 = 1 AND k1 = 61 GOTO 460: REM F3
IF k2 = 1 AND k1 = 62 GOTO 400: REM F4
IF k2 = 1 AND k1 = 63 GOTO 1400: REM F5
IF k2 = 1 AND k1 = 64 GOTO 1500: REM F6
IF k2 = 1 AND k1 = 65 GOTO 1550: REM F7
IF k2 = 0 AND k1 = 6 GOTO 360: REM ctrl-f
IF k2 = 0 AND k1 = 62 GOTO 260: REM >
IF k2 = 1 AND k1 = 68 GOTO 280: REM F10
GOTO 200

201 REM Hex Toggle
tmp = tog1
IF tmp = 1 THEN tog1 = 0
IF tmp = 0 THEN tog1 = 1
IF tog1 = 1 THEN GOSUB 805
IF tog1 = 0 THEN GOSUB 806
GOTO 200

202 REM Spam Toggle
tmp = tog2
IF tmp = 1 THEN tog2 = 0
IF tmp = 0 THEN tog2 = 1
IF tog2 = 1 THEN spam = col%(FNhex(pt, pu))
IF tog2 = 1 THEN GOSUB 810
IF tog2 = 0 THEN GOSUB 811
GOTO 200

205 REM redraw
starthex = FNhex(pt, pu)
GOTO 150

210 REM up
GOSUB 850: REM erase circle
pu = pu - 1
IF pu > 0 GOTO 245
pu = 40
212 starthex = FNhex(pt, pu)
GOSUB 1050: REM save map
f$ = FNfile$(f$, "n")
GOSUB 1000: REM load map
GOTO 150

220 REM down
GOSUB 850: REM erase circle
pu = pu + 1
IF pu < 41 GOTO 245
pu = 1
222 starthex = FNhex(pt, pu)
GOSUB 1050: REM save map
f$ = FNfile$(f$, "s")
GOSUB 1000: REM load map
GOTO 150

230 REM left
GOSUB 850: REM erase circle
pt = pt - 1
IF pt > 0 GOTO 245
pt = 40
232 starthex = FNhex(pt, pu)
GOSUB 1050: REM save map
f$ = FNfile$(f$, "w")
GOSUB 1000: REM load map
GOTO 150

240 REM right
GOSUB 850: REM erase circle
pt = pt + 1
IF pt < 41 GOTO 245
pt = 1
242 starthex = FNhex(pt, pu)
GOSUB 1050: REM save map
f$ = FNfile$(f$, "e")
GOSUB 1000: REM load map
GOTO 150

245 REM to spam or not to spam
IF tog2 = 0 GOTO 160
GOSUB 545: REM cent1/cent2
k1 = spam + 65
GOTO 250

250 REM A-P
IF col%(FNhex(pt, pu)) = 1 THEN
   GOSUB 675: REM clear the hex
END IF
col%(FNhex(pt, pu)) = k1 - 65
IF tog2 = 1 THEN spam = col%(FNhex(pt, pu))
GOSUB 650: REM fill hex
GOTO 160

260 REM enter/space/>
IF numplace = 0 GOTO 160
hexnow = FNhex(pt, pu)
hexfile$ = ""
FOR np = 1 TO numplace
   hex = place%(np, 1)
   IF hex = hexnow THEN
      hexfile$ = name$(np, 2)
   END IF
NEXT np
IF hexfile$ <> "" GOTO 261
IF numfolk = 0 GOTO 160
FOR nf = 1 TO numfolk
   hex = folk%(nf, 3)
   IF hex = hexnow AND ns = folk%(nf, 1) AND ew = folk%(nf, 2) THEN
      hexfile$ = folk$(nf, 2)
   END IF
NEXT nf
IF hexfile$ = "" GOTO 160
261 REM there's something here
IF RIGHT$(hexfile$, 1) = ">" THEN GOTO 262
REM hexfile$ is a menu or file
app$ = reader$
IF k1 = 62 THEN app$ = editor$
ext$ = RIGHT$(hexfile$, 3)
GOSUB 5500: REM egacolor
IF ext$ = "txt" THEN
   SHELL app$ + " " + locdir$ + hexfile$
END IF
IF ext$ = "mnu" THEN
   SHELL "eg " + locdir$ + hexfile$ + " " + app$
END IF
starthex = FNhex(pt, pu)
GOTO 140
262 REM hexfile$ is a link
GOSUB 1050: REM save map
GOSUB 5800: REM save objects
tmp1 = INSTR(hexfile$, "<")
tmp2 = INSTR(hexfile$, ">")
hexfile$ = MID$(hexfile$, tmp1 + 1, tmp2 - tmp1 - 1)
tmp1 = INSTR(hexfile$, "-")
world$ = LEFT$(hexfile$, tmp1 - 1)
GOSUB 5710: REM config stuff
GOSUB 5750: REM objects
hexfile$ = RIGHT$(hexfile$, LEN(hexfile$) - tmp1)
f$ = LEFT$(hexfile$, 8) + ".map"
starthex = VAL(RIGHT$(hexfile$, 4))
GOSUB 1000: REM load map
GOTO 140

265 REM memory report
CLS : COLOR 11
PRINT "Memory Report"
PRINT
PRINT "Variable Memory Available: "; FRE(0)
PRINT "Program Memory Available: "; FRE(-1)
PRINT "Stack Memory Available: "; FRE(-2)
PRINT
PRINT "Locations Used:"; STR$(numplace); "/40"
PRINT "Objects Used:"; STR$(numfolk); "/100"
GOSUB 900
starthex = FNhex(pt, pu)
GOTO 140

270 REM Summary
FOR a = 1 TO 16
   colsum(a) = 0
NEXT a
FOR a = 1 TO 1600
   colsum(col%(a) + 1) = colsum(col%(a) + 1) + 1
NEXT a
SCREEN 0: CLS : COLOR 14
PRINT "Summary Stats"
PRINT "-------------"
PRINT
COLOR 8
PRINT "Black";
LOCATE , 20: PRINT colsum(1); : LOCATE , 30
PRINT STR$(INT(colsum(1) / 1600 * 1000) / 10); "%"
FOR a = 1 TO 15
   COLOR a: PRINT colname$(a + 1);
   LOCATE , 20: PRINT colsum(a + 1); : LOCATE , 30
   PRINT STR$(INT(colsum(a + 1) / 1600 * 1000) / 10); "%"
NEXT a
PRINT : COLOR 11
PRINT "Hit any key to return to the map"
GOSUB 900
starthex = FNhex(pt, pu)
GOTO 140

280 REM save screen
bmpfile$ = LEFT$(f$, LEN(f$) - 4) + ".bmp"
bmp = 1: holdhex = FNhex(pt, pu): GOTO 150
285 bmp = 0
savescr bmpfile$, 0, 0, 599, 414, 4, 0
SCREEN 0: CLS : LOCATE 5: COLOR 11
PRINT
PRINT "World map saved to "; bmpfile$
PRINT
PRINT "Hit any key to return to the map"
PRINT
GOSUB 900
starthex = holdhex
GOTO 140

290 REM horizonal/row fill or vertical/column fill
c = col%(FNhex(pt, pu))
FOR a = 1 TO 40
   IF k1 = 8 THEN col%(FNhex(a, pu)) = c
   IF k1 = 22 THEN col%(FNhex(pt, a)) = c
NEXT a
GOTO 205

300 REM insert
GOSUB 1100: REM erase status line
PRINT "(L)ocation or (O)bject?"
302 GOSUB 900
IF k2 = 1 GOTO 302
IF k1 >= 97 AND k1 <= 122 THEN k1 = k1 - 32
IF k1 = 76 THEN tmp1 = 1: REM Location
IF k1 = 79 THEN tmp1 = 2: REM Object
IF k1 = 76 OR k1 = 79 GOTO 304
GOTO 302
304 GOSUB 1100: REM erase status line
IF tmp1 = 1 THEN INPUT "Location Name: ", tmp$
IF tmp1 = 2 THEN INPUT "Object Name: ", tmp$
tmp$ = RTRIM$(LTRIM$(tmp$))
IF tmp$ = "" GOTO 160
IF tmp1 = 1 THEN
   numplace = numplace + 1
   name$(numplace, 1) = tmp$
   name$(numplace, 2) = ""
   place%(numplace, 1) = FNhex(pt, pu)
ELSE
   numfolk = numfolk + 1
   folk$(numfolk, 1) = tmp$
   folk$(numfolk, 2) = ""
   folk%(numfolk, 1) = VAL(MID$(f$, 2, 3))
   IF MID$(f$, 1, 1) = "s" THEN folk%(numfolk, 1) = -folk%(numfolk, 1)
   folk%(numfolk, 2) = VAL(MID$(f$, 6, 3))
   IF MID$(f$, 5, 1) = "w" THEN folk%(numfolk, 2) = -folk%(numfolk, 2)
   folk%(numfolk, 3) = FNhex(pt, pu)
END IF
GOSUB 1100: REM erase status line
PRINT "(L)arge or (S)mall Font?"
306 GOSUB 900
IF k2 = 1 GOTO 306
IF k1 >= 97 AND k1 <= 122 THEN k1 = k1 - 32
IF k1 = 83 THEN tmp2 = 1: REM Small
IF k1 = 76 THEN tmp2 = 2: REM Large
IF k1 = 76 OR k1 = 83 GOTO 308
GOTO 306
308 IF tmp1 = 1 THEN
   place%(numplace, 2) = tmp2
ELSE
   folk%(numfolk, 4) = tmp2
END IF
GOSUB 1100: REM erase status line
PRINT "Do you want to attach a (f)ile, a (m)enu, or (n)othing?"
310 GOSUB 900
IF k2 = 0 AND (k1 >= 97 AND k1 <= 122) THEN k1 = k1 - 32
IF k2 = 0 AND k1 = 70 GOTO 320: REM File
IF k2 = 0 AND k1 = 77 GOTO 330: REM Menu
IF k2 = 0 AND k1 = 78 GOTO 160: REM Nothing
GOTO 310
320 GOSUB 1100: REM erase status line
INPUT "Enter file name (8 chars max, no extension): ", tmp$
tmp$ = RTRIM$(LTRIM$(tmp$))
IF INSTR(tmp$, ".") > 0 GOTO 320
l = LEN(tmp$)
IF l > 8 GOTO 320
IF l = 0 GOTO 320
tmp$ = tmp$ + ".txt"
IF tmp1 = 1 THEN name$(numplace, 2) = tmp$
IF tmp1 = 2 THEN folk$(numfolk, 2) = tmp$
OPEN "r", 1, locdir$ + tmp$
exist = LOF(1)
CLOSE 1
IF exist = 0 THEN
   OPEN "o", 1, locdir$ + tmp$
   IF tmp1 = 1 THEN
      PRINT #1, name$(numplace, 1)
      PRINT #1, STRING$(LEN(name$(numplace, 1)), "-")
   ELSE
      PRINT #1, folk$(numfolk, 1)
      PRINT #1, STRING$(LEN(folk$(numfolk, 1)), "-")
   END IF
   PRINT #1, ""
   PRINT #1, ""
   CLOSE 1
END IF
GOSUB 5500: REM egacolor
SHELL editor$ + " " + locdir$ + tmp$
starthex = FNhex(pt, pu)
GOTO 140
330 GOSUB 1100: REM erase status line
INPUT "Enter menu name (8 chars max, no extension): ", tmp$
tmp$ = RTRIM$(LTRIM$(tmp$))
IF INSTR(tmp$, ".") > 0 GOTO 330
l = LEN(tmp$)
IF l > 8 GOTO 330
IF l = 0 GOTO 330
tmp$ = tmp$ + ".mnu"
IF tmp1 = 1 THEN name$(numplace, 2) = tmp$
IF tmp1 = 2 THEN folk$(numfolk, 2) = tmp$
OPEN "r", 1, locdir$ + tmp$
exist = LOF(1)
CLOSE 1
IF exist = 0 THEN
   OPEN "o", 1, locdir$ + tmp$
   IF locdir$ <> "" THEN
      PRINT #1, "@dir="; LEFT$(locdir$, LEN(locdir$) - 1)
   END IF
   PRINT #1, "@Light Yellow"
   PRINT #1, ""
   PRINT #1, SPACE$(10);
   IF tmp1 = 1 THEN PRINT #1, name$(numplace, 1)
   IF tmp1 = 2 THEN PRINT #1, folk$(numfolk, 1)
   PRINT #1, ""
   PRINT #1, ""
   PRINT #1, "@Light Cyan"
   PRINT #1, "     Topic #1     @topic1.txt"
   PRINT #1, "     Topic #2     @topic2.txt"
   PRINT #1, ""
   CLOSE 1
END IF
GOSUB 5500: REM egacolor
SHELL editor$ + " " + locdir$ + tmp$
starthex = FNhex(pt, pu)
GOTO 140

350 REM delete
b = FNhex(pt, pu)
IF numplace = 0 GOTO 352
FOR a = 1 TO numplace
   IF place%(a, 1) = b THEN
      IF a < numplace THEN
         FOR c = a + 1 TO numplace
            place%(c - 1, 1) = place%(c, 1)
            place%(c - 1, 2) = place%(c, 2)
            name$(c - 1, 1) = name$(c, 1)
            name$(c - 1, 2) = name$(c, 2)
         NEXT c
      END IF
      numplace = numplace - 1
   END IF
NEXT a
352 IF numfolk = 0 GOTO 354
FOR a = 1 TO numfolk
IF ns = folk%(a, 1) AND ew = folk%(a, 2) AND b = folk%(a, 3) THEN
   IF a < numfolk THEN
      FOR c = a + 1 TO numfolk
         FOR d = 1 TO 4
            folk%(c - 1, d) = folk%(c, d)
         NEXT d
         folk$(c - 1, 1) = folk$(c, 1)
         folk$(c - 1, 2) = folk$(c, 2)
      NEXT c
   END IF
   numfolk = numfolk - 1
END IF
NEXT a
354 starthex = FNhex(pt, pu)
GOTO 150

360 REM fill
GOSUB 1100: REM erase status line
PRINT "Fill Map / Choose a Color"
362 GOSUB 900
IF k2 = 0 AND (k1 >= 97 AND k1 <= 122) THEN k1 = k1 - 32
IF k2 = 0 AND k1 >= 65 AND k1 <= 80 GOTO 364: REM A-P
IF k2 = 0 AND (k1 = 81 OR k1 = 27) GOTO 160: REM Q/Esc
GOTO 362
364 REM
FOR a = 1 TO 1600
   col%(a) = k1 - 65
NEXT a
GOTO 205

370 REM color key
OPEN "i", 1, mapdir$ + "colorkey.dat"
FOR a = 1 TO 16
   LINE INPUT #1, ck$(a)
NEXT a
CLOSE 1
372 SCREEN 0: CLS : COLOR 14
PRINT "Color Key"
PRINT "---------"
PRINT
COLOR 8
PRINT "A) "; colname$(1);
LOCATE , 30: PRINT ck$(1)
FOR a = 1 TO 15
   COLOR a: PRINT CHR$(65 + a); ") "; colname$(a + 1);
   LOCATE , 30: PRINT ck$(a + 1)
NEXT a
PRINT : COLOR 11
PRINT "Select key to modify or hit <esc>"
374 GOSUB 900
IF k2 = 1 GOTO 374
IF k1 >= 97 AND k1 <= 122 THEN k1 = k1 - 32
IF k1 >= 65 AND k1 <= 80 GOTO 376
IF k1 = 27 GOTO 378
GOTO 374
376 REM change color's def
CLS : LOCATE 5, 10
PRINT "What does "; colname$(k1 - 64); " stand for?"
PRINT : INPUT "---> ", t$
t$ = RTRIM$(LTRIM$(t$))
IF t$ <> "" THEN ck$(k1 - 64) = t$
GOTO 372
378 REM save file
OPEN "o", 1, mapdir$ + "colorkey.dat"
FOR a = 1 TO 16
   PRINT #1, ck$(a)
NEXT a
CLOSE 1
starthex = FNhex(pt, pu)
GOTO 140

400 REM general info
GOSUB 5500: REM egacolor
SHELL "eg " + gendir$ + "world.mnu " + reader$
starthex = FNhex(pt, pu)
GOTO 140

460 REM insert line
IF newline <> 0 GOTO 465
newline = FNhex(pt, pu)
newjy = ns
newjx = ew
newjf$ = f$
GOTO 160
465 REM 1st world already selected
IF newline <> FNhex(pt, pu) GOTO 470
newline = 0
GOTO 160
470 REM 1st & 2nd world different
zi = ns
zj = ew
IF ABS(zj - newjx) > 1 OR ABS(zi - newjy) > 1 GOTO 478
GOSUB 1100: REM clear status line
PRINT "Enter Color (A-P):"
472 GOSUB 900
IF k2 = 0 AND (k1 >= 97 AND k1 <= 122) THEN k1 = k1 - 32
IF k2 = 0 AND k1 >= 65 AND k1 <= 80 GOTO 475: REM a-p
IF k2 = 0 AND k1 = 27 OR k1 = 81 GOTO 478: REM esc/q
GOTO 472
475 tmp1$ = CHR$(k1)
REM from 1st to 2nd
tmp2$ = "$" + FNzero$(newline, 4) + "-"
tmp2$ = tmp2$ + FNzero$(FNhex(pt, pu), 4) + "-"
tmp2$ = tmp2$ + LTRIM$(STR$(zj - newjx + 2))
tmp2$ = tmp2$ + LTRIM$(STR$(newjy - zi + 2))
tmp2$ = tmp2$ + "-" + tmp1$
REM from 2nd to 1st
tmp3$ = "$" + FNzero$(FNhex(pt, pu), 4) + "-"
tmp3$ = tmp3$ + FNzero$(newline, 4) + "-"
tmp3$ = tmp3$ + LTRIM$(STR$(newjx - zj + 2))
tmp3$ = tmp3$ + LTRIM$(STR$(zi - newjy + 2))
tmp3$ = tmp3$ + "-" + tmp1$
GOSUB 1050: REM save
tmpfile$ = newjf$: tmp4$ = tmp2$: GOSUB 480
IF ABS(zj - newjx) = 1 OR ABS(zi - newjy) = 1 THEN
   tmpfile$ = f$: tmp4$ = tmp3$: GOSUB 480
END IF
478 newline = 0
GOSUB 1000: REM load
GOTO 205
480 SHELL "copy " + mapdir$ + tmpfile$ + " tmp.map"
OPEN "i", 1, "tmp.map"
OPEN "o", 2, mapdir$ + tmpfile$
DO UNTIL EOF(1)
LINE INPUT #1, tmp$
IF LEFT$(tmp$, 7) = "#Places" THEN PRINT #2, tmp4$
PRINT #2, tmp$
LOOP
CLOSE 1
CLOSE 2
SHELL "erase tmp.map"
RETURN

490 REM hexworld help
GOSUB 5500: REM egacolor
SHELL reader$ + " help\mapper.txt"
starthex = FNhex(pt, pu)
GOTO 140

492 REM edit objects file
GOSUB 5800: REM save objects
GOSUB 5500: REM egacolor
SHELL editor$ + " " + mapdir$ + "objects.dat"
GOSUB 5750: REM load objects
starthex = FNhex(pt, pu)
GOTO 140

495 REM edit map file directly
GOSUB 1050: REM save map
GOSUB 5500: REM egacolor
SHELL editor$ + " " + mapdir$ + f$
tmphex = FNhex(pt, pu)
GOSUB 1000: REM load map
starthex = tmphex
GOTO 140

500 REM get t/u coordinates of the hex
b = hex
u = INT((b - .5) / 40) + 1
t = b - ((u - 1) * 40)
RETURN

545 t = pt: u = pu
550 REM get cent1/cent2 (center of the hex)
cent1 = ((t - 1) * hexb * 2) + 10
cent2 = u * chexa * 1.5
IF u / 2 = INT(u / 2) THEN cent1 = cent1 + hexb
REM minor corrections
IF u > 10 THEN cent2 = cent2 - 1
IF u > 23 THEN cent2 = cent2 - 1
IF u > 35 THEN cent2 = cent2 - 1
RETURN

600 REM draw hex
REM known=> cent1, cent2
REM from one o'clock clockwise
tmp1 = cent1
tmp2 = cent2 - chexa
tmp3 = cent1 + hexb
tmp4 = cent2 - (.5 * chexa)
LINE (tmp1, tmp2)-(tmp3, tmp4)
LINE -STEP(0, chexa)
LINE -STEP(-hexb, .5 * chexa)
LINE -STEP(-hexb, -.5 * chexa)
LINE -STEP(0, -chexa)
LINE -STEP(hexb, -.5 * chexa)
RETURN

650 REM fill hex w/ normal color
COLOR 1: GOSUB 600: REM draw hex in blue
PAINT (cent1, cent2), col%(FNhex(pt, pu)), 1
RETURN

675 REM clear hex to grey
COLOR 8: GOSUB 600: REM draw hex in grey
PAINT (cent1, cent2), 0, 8
COLOR 1: GOSUB 600: REM draw hex in blue
RETURN

680 REM designate section name
GOSUB 1100: REM clear input line
INPUT "Enter a name for this section of the map: ", section$
GOTO 205

690 REM upper-right stuff
x = 510: y = 10: font = 1: word$ = nworld$: ul = 0
GOSUB 5100
x = 510: y = 20: word$ = section$
GOSUB 5100
x = 510: y = 30: word$ = FNsec$(f$)
GOSUB 5100
RETURN

700 REM color menu
FOR i = 0 TO 15
   CIRCLE (550, i * 20 + 50), 5, 15
   PAINT (550, i * 20 + 50), i, 15
   x = 560: y = i * 20 + 52: font = 1: word$ = (CHR$(i + 65)): ul = 0
   GOSUB 5100: REM draw menu letter
NEXT i
RETURN

750 REM quit/readme hint
x = 510: y = 400: font = 1: ul = 0: word$ = "Q: Quit": GOSUB 5100
x = 510: y = 410: font = 1: word$ = "R: Readme": GOSUB 5100
RETURN

800 REM make circle/cursor
GOSUB 545: REM get center coords
cc = 15: REM circle color
GOSUB 802: REM draw circle
IF newline > 0 THEN GOSUB 801
RETURN
801 REM make line-insertion circle
hex = newline: GOSUB 500
GOSUB 550: REM get center coords
cc = 11: REM circle color
IF newjy = ns AND newjx = ew THEN GOSUB 802: REM draw circle
RETURN
802 REM draw circle
rad = INT(hexa / 2)
CIRCLE (cent1, cent2), rad + 1, 0
CIRCLE (cent1, cent2), rad - 1, 0
CIRCLE (cent1, cent2), rad, cc
RETURN

805 REM hex# display
x = 510: y = 380: font = 1: ul = 0
word$ = "Hex:" + STR$(FNhex(pt, pu)) + " "
GOSUB 5100
RETURN

806 REM hex# undisplay
x = 510: y = 380: font = 1: ul = 0: word$ = SPACE$(10): GOSUB 5100
RETURN

810 REM spam mode display
x = 510: y = 390: font = 1: ul = 0: word$ = "Now Spamming": GOSUB 5100
RETURN

811 REM spam undisplay
x = 510: y = 390: font = 1: ul = 0: word$ = SPACE$(12): GOSUB 5100
RETURN

850 REM erase circle/cursor
GOSUB 545: REM get cent1/cent2
IF col%(FNhex(pt, pu)) = 1 THEN
   GOSUB 675: REM clear hex
ELSE
   CIRCLE (cent1, cent2), hexa / 2, 0
END IF
GOSUB 650: REM fill hex
RETURN

900 REM get character from keyboard
k1 = 0: k2 = 0
910 k$ = INKEY$
IF k$ = "" THEN GOTO 910
k1 = ASC(k$)
IF k1 <> 0 THEN RETURN
k1 = ASC(RIGHT$(k$, 1))
k2 = 1
RETURN

1000 REM load hexmap
ns = VAL(MID$(f$, 2, 3))
IF MID$(f$, 1, 1) = "s" THEN ns = -ns
ew = VAL(MID$(f$, 6, 3))
IF MID$(f$, 5, 1) = "w" THEN ew = -ew
OPEN "r", 1, mapdir$ + f$
exist = LOF(1)
CLOSE 1
IF exist = 0 THEN
   SHELL "erase " + mapdir$ + f$
   FOR a = 1 TO 1600
      col%(a) = 0
   NEXT a
   FOR a = 1 TO 40
      place%(a, 1) = 0
      name$(a, 1) = ""
      name$(a, 2) = ""
   NEXT a
   numplace = 0
   FOR a = 1 TO 50
      FOR b = 1 TO 5
         lines%(a, b) = 0
      NEXT b
   NEXT a
   numlines = 0
   GOSUB 1050
END IF
IF exist = 0 THEN RETURN
OPEN "i", 1, mapdir$ + f$
LINE INPUT #1, section$
FOR a = 1 TO 40
   LINE INPUT #1, tmp$
   FOR b = 1 TO 40
      c = ((a - 1) * 40) + b
      col%(c) = ASC(MID$(tmp$, b, 1)) - 65
   NEXT b
NEXT a
a = 0: b = 0
DO UNTIL EOF(1)
   LINE INPUT #1, tmp$
   IF LEFT$(tmp$, 1) = "$" THEN
      b = b + 1
      lines%(b, 1) = VAL(MID$(tmp$, 2, 4))
      lines%(b, 2) = VAL(MID$(tmp$, 7, 4))
      lines%(b, 3) = VAL(MID$(tmp$, 12, 1)) - 2
      lines%(b, 4) = VAL(MID$(tmp$, 13, 1)) - 2
      lines%(b, 5) = ASC(MID$(tmp$, 15)) - 65
   END IF
   IF LEFT$(tmp$, 1) = "@" THEN
      a = a + 1
      place%(a, 1) = VAL(MID$(tmp$, 2, 4))
      place%(a, 2) = VAL(MID$(tmp$, 7, 1))
      c = INSTR(tmp$, ":")
      l = LEN(tmp$)
      IF c = 0 THEN
         name$(a, 1) = LTRIM$(RTRIM$(RIGHT$(tmp$, l - 8)))
         name$(a, 2) = ""
      ELSE
         name$(a, 1) = LTRIM$(RTRIM$(MID$(tmp$, 9, c - 9)))
         name$(a, 2) = LTRIM$(RTRIM$(RIGHT$(tmp$, l - c)))
      END IF
   END IF
LOOP
CLOSE 1
numplace = a
numlines = b
RETURN

1050 REM save hexmap
OPEN "o", 1, mapdir$ + f$
PRINT #1, section$
FOR a = 1 TO 40
   tmp$ = ""
   FOR b = 1 TO 40
      c = ((a - 1) * 40) + b
      tmp$ = tmp$ + CHR$(col%(c) + 65)
   NEXT b
   PRINT #1, tmp$
NEXT a
PRINT #1, "#Lines"
IF numlines > 0 THEN
   FOR a = 1 TO numlines
      t$ = "$" + FNzero$(lines%(a, 1), 4) + "-"
      t$ = t$ + FNzero$(lines%(a, 2), 4) + "-"
      t$ = t$ + LTRIM$(STR$(lines%(a, 3) + 2))
      t$ = t$ + LTRIM$(STR$(lines%(a, 4) + 2)) + "-"
      t$ = t$ + CHR$(lines%(a, 5) + 65)
      PRINT #1, t$
   NEXT a
END IF
PRINT #1, "#Places"
IF numplace > 0 THEN
   FOR a = 1 TO numplace
      tmp$ = "@" + FNzero$(place%(a, 1), 4) + "-"
      tmp$ = tmp$ + LTRIM$(STR$(place%(a, 2))) + "-"
      tmp$ = tmp$ + name$(a, 1)
      IF name$(a, 2) <> "" THEN
         tmp$ = tmp$ + ":" + name$(a, 2)
      END IF
      PRINT #1, tmp$
   NEXT a
END IF
CLOSE 1
GOSUB 1100: REM erase status line
PRINT f$
RETURN

1100 REM erase status line
LOCATE 28, 1: PRINT SPACE$(79)
LOCATE 28, 1: COLOR 11
RETURN

1200 REM draw location
GOSUB 500: REM get t/u
GOSUB 550: REM get cent1/cent2
x = cent1: y = cent2: ul = 0
font = place%(np, 2)
IF font = 1 THEN
   LINE (x - 2, y - 2)-(x + 2, y + 2), 11, B
   IF name$(np, 2) = "" THEN
      c = 9
   ELSEIF RIGHT$(name$(np, 2), 1) = ">" THEN
      c = 0
   ELSE
      c = 4
   END IF
   LINE (x - 1, y - 1)-(x + 1, y + 1), c, BF
   x = cent1 + 5: y = cent2 + 5
END IF
IF font = 2 THEN
   x = cent1 - 3
   y = cent2 + 6
   IF name$(np, 2) <> "" THEN ul = 11
END IF
word$ = name$(np, 1)
GOSUB 5100: REM draw word
RETURN

1300 REM draw folk
IF numfolk = 0 THEN RETURN
FOR nf = 1 TO numfolk
   IF ns <> folk%(nf, 1) OR ew <> folk%(nf, 2) GOTO 1320
   hex = folk%(nf, 3)
   GOSUB 500: REM get t/u
   GOSUB 550: REM get cent1/cent2
   x = cent1 + 5: y = cent2 + 5: font = folk%(nf, 4): ul = 0
   IF font = 1 THEN
      CIRCLE (cent1, cent2), 1, 15
      IF folk$(nf, 2) = "" THEN
         PSET (cent1, cent2), 15
      ELSE
         PSET (cent1, cent2), 4
      END IF
   END IF
   IF font = 2 THEN
      x = cent1 - 3
      y = cent2 + 6
      IF folk$(nf, 2) = "" THEN
         ul = 0
      ELSE
         ul = 11
      END IF
   END IF
   word$ = folk$(nf, 1)
   GOSUB 5100
1320 NEXT nf
RETURN

1400 REM pick-up/drop-off folk
IF mv > 0 GOTO 1420
IF numfolk = 0 THEN GOTO 200
FOR nf = 1 TO numfolk
   IF ns = folk%(nf, 1) AND ew = folk%(nf, 2) THEN
      IF FNhex(pt, pu) = folk%(nf, 3) THEN mv = nf
   END IF
NEXT nf
IF mv = 0 GOTO 200
GOSUB 1100: REM status line
PRINT folk$(mv, 1); " on the move"
GOTO 200
1420 REM dropping off
folk%(mv, 1) = ns: folk%(mv, 2) = ew
folk%(mv, 3) = FNhex(pt, pu)
mv = 0
GOTO 205

1500 REM big map
GOSUB 1050: REM save map
GOSUB 5800: REM save objects
SHELL "bigmap 1 " + mapdir$ + f$
GOTO 205

1550 REM really big map
GOSUB 1050: REM save map
GOSUB 5800: REM save objects
SHELL "bigmap 2 " + mapdir$ + f$
GOTO 205

5000 REM get letter image data
CLS : COLOR 14: LOCATE 8, 3
PRINT "Loading Data..."
fontfile$(1) = "data\small.fon"
fontfile$(2) = "data\large.fon"
rows(1) = 5
rows(2) = 13
FOR f = 1 TO 2
   OPEN "i", 1, fontfile$(f)
   numlet(f) = 0: lets$(f) = ""
   DO UNTIL EOF(1)
      numlet(f) = numlet(f) + 1
      INPUT #1, t$
      IF t$ = "" THEN t$ = " "
      lets$(f) = lets$(f) + t$
      FOR a = 1 TO rows(f)
         INPUT #1, lrow$(a)
      NEXT a
      COLOR 11: GOSUB 5005
      IF f = 1 THEN GET (1, 1)-(l, rows(1)), smlet(1, numlet(1))
      IF f = 2 THEN GET (1, 1)-(l, rows(2)), lglet(1, numlet(2))
      COLOR 0: GOSUB 5005
   LOOP
   CLOSE
NEXT f
RETURN
5005 length%(numlet(f), f) = LEN(lrow$(1)) - 2
l = length%(numlet(f), f)
FOR a = 1 TO rows(f)
   FOR b = 1 TO l
      IF MID$(lrow$(a), b + 1, 1) = "*" THEN PSET (b, a)
   NEXT b
NEXT a
RETURN

5100 REM subroutine: print word
x0 = x
y = y - (rows(font) - 1)
l = LEN(word$)
IF l = 0 THEN RETURN
LINE (x - 1, y)-(x - 1, y + rows(font) - 1), 0
FOR a = 1 TO l
   let$ = MID$(word$, a, 1)
   IF font = 1 THEN let$ = UCASE$(let$)
   letnum = INSTR(lets$(font), let$)
   IF letnum > 0 AND x <= 635 AND y <= 479 THEN
      IF font = 1 THEN PUT (x, y), smlet(1, letnum), PSET
      IF font = 2 THEN PUT (x, y), lglet(1, letnum), PSET
   END IF
   x = x + length%(letnum, font) + 1
   LINE (x - 1, y)-(x - 1, y + rows(font) - 1), 0
NEXT a
IF ul <> 0 THEN
   IF font = 1 THEN
      y = y + rows(font)
      LINE (x0, y)-(x - 1, y), 0
      LINE (x0, y + 1)-(x - 1, y + 1), ul
      LINE (x0, y + 2)-(x - 1, y + 2), 0
   END IF
   IF font = 2 THEN
      y = y + rows(font) - 2
      LINE (x0, y)-(x - 1, y), ul
   END IF
END IF

RETURN

5200 REM calculate video stuff
xmost = 640
ymost = 500
REM screen aspect ratio
REM scar = 2.4
scar = (3 / 4) * (xmost / ymost)
REM hex radii
hexa = 7
hexb = INT((hexa ^ 2 - (.5 * hexa) ^ 2) ^ .5)
REM corrected for aspect ratio
chexa = hexa * scar
chexb = hexb
RETURN

5500 REM egacolor gold on blue
SCREEN 0
SHELL "egacolor 00 10"
SHELL "egacolor 07 46"
RETURN

5600 REM read colors.cmd
OPEN "i", 1, "colors.cmd"
FOR a = 1 TO 16
   LINE INPUT #1, tmp$
   l = LEN(tmp$)
   tmp$ = RIGHT$(tmp$, l - 4)
   colname$(a) = tmp$
NEXT a
CLOSE 1
RETURN

5700 REM read in settings
REM mapper.cfg
OPEN "i", 1, "mapper.cfg"
INPUT #1, t$: l = LEN(t$)
editor$ = RIGHT$(t$, l - 7)
INPUT #1, t$: l = LEN(t$)
reader$ = RIGHT$(t$, l - 7)
INPUT #1, t$: l = LEN(t$)
world$ = RIGHT$(t$, l - 6)
CLOSE 1
GOSUB 5710
RETURN

5710 REM more settings
gendir$ = world$ + "\gen\"
locdir$ = world$ + "\loc\"
mapdir$ = world$ + "\map\"
CLOSE 1
REM mapper.lst
OPEN "i", 1, "mapper.lst"
LINE INPUT #1, t$
LINE INPUT #1, t$
DO UNTIL EOF(1)
   LINE INPUT #1, t$
   tmp1$ = RTRIM$(LEFT$(t$, 8))
   tmp2$ = RIGHT$(t$, LEN(t$) - 13)
   IF world$ = tmp1$ THEN nworld$ = tmp2$
LOOP
CLOSE 1
RETURN

5750 REM load objects
folkfile$ = mapdir$ + "objects.dat"
OPEN "r", 1, folkfile$
exist = LOF(1)
CLOSE 1
IF exist = 0 THEN
   SHELL "erase " + folkfile$
   f$ = "n000e000.map"
   starthex = 1
END IF
IF exist = 0 THEN RETURN
OPEN "i", 1, folkfile$
LINE INPUT #1, t$
f$ = LEFT$(t$, 8) + ".map"
starthex = VAL(MID$(t$, 10, 4))
a = 0
DO UNTIL EOF(1)
   LINE INPUT #1, t$
   a = a + 1
   folk%(a, 1) = VAL(MID$(t$, 2, 3))
   IF MID$(t$, 1, 1) = "s" THEN folk%(a, 1) = -folk%(a, 1)
   folk%(a, 2) = VAL(MID$(t$, 6, 3))
   IF MID$(t$, 5, 1) = "w" THEN folk%(a, 2) = -folk%(a, 2)
   folk%(a, 3) = VAL(MID$(t$, 10, 4))
   folk%(a, 4) = VAL(MID$(t$, 15, 1))
   b = INSTR(t$, ":")
   IF b > 0 THEN
      folk$(a, 1) = MID$(t$, 17, b - 17)
      folk$(a, 2) = RIGHT$(t$, LEN(t$) - b)
   ELSE
      folk$(a, 1) = RIGHT$(t$, LEN(t$) - 16)
      folk$(a, 2) = ""
   END IF
LOOP
numfolk = a
CLOSE 1
RETURN

5800 REM save objects
OPEN "o", 1, mapdir$ + "objects.dat"
t$ = LEFT$(f$, 8) + "-" + FNzero$(FNhex(pt, pu), 4)
t$ = t$ + "-starthex"
PRINT #1, t$
IF numfolk > 0 THEN
FOR a = 1 TO numfolk
   IF folk%(a, 1) >= 0 THEN
      t$ = "n"
   ELSE
      t$ = "s"
   END IF
   t$ = t$ + FNzero$(ABS(folk%(a, 1)), 3)
   IF folk%(a, 2) >= 0 THEN
      t$ = t$ + "e"
   ELSE
      t$ = t$ + "w"
   END IF
   t$ = t$ + FNzero$(ABS(folk%(a, 2)), 3)
   t$ = t$ + "-" + FNzero$(folk%(a, 3), 4)
   t$ = t$ + "-" + LTRIM$(STR$(folk%(a, 4)))
   t$ = t$ + "-" + folk$(a, 1)
   IF folk$(a, 2) <> "" THEN t$ = t$ + ":" + folk$(a, 2)
   PRINT #1, t$
NEXT a
END IF
CLOSE 1
RETURN

9900 REM quit
GOSUB 1050: REM save hexmap
GOSUB 5800: REM save objects
GOTO 10

9950 REM exit
GOSUB 1000: REM load hexmap
GOSUB 5750: REM load objects
GOTO 10

10000 REM end
SCREEN 0: COLOR 7: CLS
PRINT
PRINT "For Assistance and/or Snide Remarks:"
PRINT
PRINT "     Email:  jimv@empirenet.com"
PRINT "             JimVassila@aol.com"
PRINT "             jimv@cs.ucr.edu"
PRINT "             jimv@silver.lcs.mit.edu"
PRINT
PRINT "  Homepage:  http://www.cs.ucr.edu/~jimv"
PRINT
END

SUB savescr (filename$, sx, sy, ex, ey, nbits, imgnum)
'SAVESCR V0.6 - Screen Capture Function for Qbasic.
'By: Aaron Zabudsky <zabudsk@ecf.utoronto.ca>
'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