DECLARE SUB achain (lindx&(), datf$, nseg%, npts%)
DECLARE SUB fltest (good%)
DECLARE SUB fsel (path AS STRING, nf AS INTEGER)
DECLARE SUB utm (x#, y#, utmz!)
DECLARE FUNCTION decode! (a$)
DECLARE SUB init (mapf AS STRING, datf AS STRING, path AS STRING, nf AS INTEGER, UB%)
DECLARE SUB fbook (finx%, F AS STRING, path AS STRING, bcolor%, suffix AS STRING)
DECLARE SUB Test (rcno&, rstop&, ratt&, testflg%, icolor%, lab AS STRING)
DECLARE SUB redraw (cmaxrec&, datf AS STRING)
'Code to make APRS maps from USGS 100K:1 dlg CD optional data
' Version 1.0  23 Oct 95 - KB4XF - Initial release
' Written by John F. Cavanagh, KB4XF in 1995
' In keeping with the spirit or making APRS maps available to all, the
' author waives all copyright and dedicates to the public domain.
' The author waives all responsibility too!
' 2.0 Added BLOCK/UNBLOCK using variable UB% in init subroutine (WB4APR)
DEFSTR A-Z
COMMON SHARED lat0!, long0!, ymax!, xmax!, scfy!, scfx!, rds%, mradm!
COMMON SHARED lfac!, ppdy!, mpernm!, latmax!, longmin!, Hfac!, drady!, dradx!
COMMON SHARED ymin!, xmin!, yy0#, xx0#, utmz!, sr!, cr!, dir() AS STRING * 35
DIM u#(3), v#(3), lindx&(2000)
DIM xs(1200) AS INTEGER, ys(1200) AS INTEGER
' $DYNAMIC
DIM SHARED hdtail(2048, 2) AS STRING * 11 '*** YOU MUST USE QB.exe/AH.  This
                                          '*** PGM is too big for Qbasic!
                                          '*** Or download MKMAPHK1.EXE ****
ON ERROR GOTO punt
CLEAR , , 2000    'Too many nested routines error msg otherwise
CONST limit% = 3000 'APRS map size limit
CONST pi! = 3.14159
'Define radom access file records using field statements
'Copy to clipboard as required
'General text record types 1,2,3
'field 1,82 as banner
'Type 4 record
'field1,6 as dlg,6 as code,6 as gprs,6 as gprc,18 as res,6 as ntrfp,6 as nacr,
'6 as ncp,6 as ncat,6 as fill1
'Type 5-9 record
'field1, 24 as p1,24 as p2,24 as p3,8 as fill2
'Control point records - ncp
'field 1,6 as quad,12 as rflat,12 as rflong,18 as refx,12 as refy,20 as fill3
'Category id records- ncat
'field 1, 24 as cname,6 as rnodes,6 as nnodes,2 as linkf,2 as naf,6 as rarea,6 as narea,
'4 as mflg,6 as rlines,6 as nlines,12 as fill4
'Node and area id records
'field 1,1 as rtype,5 as idnum,12 as ptxc,12 as ptcy,t as nlist,, 6 as nlines,6 as npairs,
'6 as nattc,6 as ntxtc,6 as nisld,14 as fill5
'Line id records
'field 1,1 as ltype,5 as lnum,6 as stnode,6 as ednode,6 as larea,6 as rarea,
'18 as ncoor,6 as nlatt,26 as fill6
'Line data records- ncoor/3
'Field 1, 12 as u1,12 as v1,12 as u2,12 as v2,12 as u3,12 as v3
'Attribute code records nlatt/6
'field 1, 6 as cmj1,6 as cmn1,6 as cmj2,6 as cmn2,6 as cmj3, 6 as cmn3

CALL init(mapf, datf, path, nf%, UB%)
npts% = 8
finx% = 1
nseg% = 0
oldx! = 99999
oldy! = 99999
tstart = TIME$
DO WHILE finx% <= nf% 'loop1  over files
DO  'loop2
 F = LEFT$(dir(finx%), 12)
 OPEN path + "\" + F FOR RANDOM AS #1 LEN = UB%
 CALL fltest(good%)
 IF NOT good% THEN
   finx% = finx% + 1
   CLOSE 1
 END IF
LOOP UNTIL good% OR finx% > nf% 'loop2  over good files
IF NOT good% THEN EXIT DO
FIELD 1, 24 AS cname, 6 AS rnodes, 6 AS nnodes, 2 AS linkf, 2 AS naf, 6 AS rarea, 6 AS narea, 4 AS mflg, 6 AS rlines, 6 AS nlines, 12 AS fill4
FIELD 1, 6 AS cmj1, 6 AS cmn1, 6 AS cmj2, 6 AS cmn2, 6 AS cmj3, 6 AS cmn3
FIELD 1, 1 AS ltype, 5 AS lnum, 6 AS stnode, 6 AS ednode, 6 AS larea, 6 AS rarea, 18 AS ncoor, 6 AS nlatt, 26 AS fill6
labnr% = 0
rcno& = 15
' Read header lines of CD. Extract number of area and line records.
' Estimate number of physical records and skip ahead.  Someday I may
' make use of this skipped info. Search one physical record at a time
' until an "L" found in first byte. Then test to see if this line
'segment is in region of interest. If so then extract data pairs. If
'not then skip to next logical line record.
GET 1, rcno&
rcno& = rcno& + 2 * (VAL(nnodes) + VAL(narea)) 'Approx skip of node and area info
rmax& = LOF(1) / 82  'QB does not recognize CD eof!  82 bytes per record
maxl% = VAL(nlines)
DO WHILE NOT EOF(1) AND rcno& < rmax& 'loop3 over lines in file
DO 'loop4
LOCATE 1, 1
GET 1, rcno&
PRINT "Searching file "; F; ltype; lnum; maxl%; nseg%
rcno& = rcno& + 1
LOOP UNTIL ltype = "L" OR rcno& > rmax&  'loop4  finding start of line data
startflg% = -1
k% = 0
lnum% = VAL(lnum)
ncoor% = VAL(ncoor)
nlatt% = VAL(nlatt)
nphrec% = ncoor% \ 3
IF (ncoor% MOD 3) <> 0 THEN nphrec% = nphrec% + 1
rstop& = rcno& + nphrec%
IF nlatt% = 0 THEN rstop& = rstop& - 1
IF nlatt% > 6 THEN rstop& = rstop& + 1
ratt& = rstop&  'Normally
FIELD 1, 12 AS u1, 12 AS v1, 12 AS u2, 12 AS v2, 12 AS u3, 12 AS v3
IF nlatt% <> 0 THEN 'Line with no attribute it is neat line or of no interest
  CALL Test(rcno&, rstop&, ratt&, testflg%, icolor%, lab)
ELSE
   testflg% = 0
END IF
IF testflg% THEN          'nf1  while have a good line
 DO WHILE rcno& < rstop&   'loop5   over line data points
 GET 1, rcno&
 u#(1) = VAL(u1)
 v#(1) = VAL(v1)
 u#(2) = VAL(u2)
 v#(2) = VAL(v2)
 u#(3) = VAL(u3)
 v#(3) = VAL(v3)
 FOR I% = 1 TO 3
 IF u#(I%) = 0 THEN EXIT FOR
 xt! = u#(I%) - xx0# 'meters
 yt! = v#(I%) - yy0# 'meters
 REM Rotate to align with lat/long
 x! = xt! * cr! + yt! * sr!
 y! = yt! * cr! - xt! * sr!
 REM Test to see if this point is on map
 ok% = 0
 IF (y! <= ymax!) AND (y! >= ymin!) THEN
   IF (x! <= xmax!) AND (x! >= xmin!) THEN
      ok% = -1
   END IF
 END IF
 IF ok% THEN           'nf2  while we have good point
      dx! = (x! - xmin!) 'meters
      xlng! = dx! * scfx! 'deg long
      xp! = INT(xlng! * ppdy! + .5)
      dy! = (ymax! - y!)
      ylat! = dy! * scfy! 'deg lat
      yp! = INT(ylat! * ppdy! + .5)
     IF startflg% THEN   'Set up a new line segment in map nf3
       PSET (xp! * Hfac!, yp!), icolor%
       'PRINT #2, "   0,   0"
       labnr% = labnr% + 1
       labs = RIGHT$(STR$(labnr%), 3)
       ll = LEFT$(lab, 2)
       tag = lab
       IF ll = "st" THEN tag = ll + labs
       IF ll = "rd" THEN tag = ll + labs
       'PRINT #2, USING "##_,\    \"; icolor%; tag
       'PRINT #2, USING "####_,####"; xp!; yp!
       k% = 1
       xs(k%) = xp!
       IF xs(k%) = 0 THEN xs(k%) = 1
       ys(k%) = yp!
       startflg% = 0
     ELSE  'Just plot next point
      LINE -(xp! * Hfac!, yp!), icolor%
      'PRINT #2, USING "####_,####"; INT(xp! + .5); INT(yp! + .5)
      k% = k% + 1
      xs%(k%) = xp!
      IF xs(k%) = 0 THEN xs(k%) = 1
      ys%(k%) = yp!
    END IF 'plot point                                     nf3
  ELSE
    startflg% = -1
 END IF 'plot good point  on map                           nf2
 NEXT I%  'plot next point in record
 rcno& = rcno& + 1
 LOOP 'plot line loop5
  ' Now write to disk in ascending order by y-coordinate
  IF k% > 1 THEN  'Only lines with more than one point
  PRINT #2, "   0,   0"
  PRINT #2, USING "##_,\    \"; icolor%; tag
  npts% = npts% + 2
  nseg% = nseg% + 1
  lindx&(nseg%) = npts% - 1
  kstop% = k%
  IF ys%(1) <= ys%(kstop%) THEN
   k1% = 1
   k2% = kstop%
   kstep% = 1
  ELSE
   k1% = kstop%
   k2% = 1
   kstep% = -1
 END IF
 FOR k% = k1% TO k2% STEP kstep%
 PRINT #2, USING "####_,####"; xs(k%); ys(k%)
 npts% = npts% + 1
 NEXT k%
 END IF
 startflg% = -1
 ELSE
 rcno& = rstop& + 1
END IF 'plot good line                                   nf1
LOOP 'loop over all lines loop3
tstop = TIME$
PRINT
LOCATE 2, 1
PRINT tstart; " "; tstop
finx% = finx% + 1
cmaxrec& = LOF(2) \ 11
lindx&(nseg% + 1) = npts% + 1 'Dummy pointing to end of data file
CLOSE 1
LOOP ' loop1 over all files
CLOSE 1
CLOSE 2
'Did we get anything
IF npts% = 8 THEN
PRINT " Oops! None of the files in "; path
PRINT "contained any data points within "; mradm!; " nautical miles"
PRINT "of your map center of "; lat0!; " N and "; long0!; " W"
PRINT "Get the right files from CD or recenter the APRS map"
PRINT
PRINT "Hit any key to STOP"
DO UNTIL INKEY$ <> "": LOOP
STOP
END IF
mseg% = nseg%
mpts% = npts%
CALL achain(lindx&(), datf, mseg%, mpts%)
PRINT
PRINT "Reduction from "; npts%; " to "; mpts%; " points"
PRINT "Reduction from "; nseg%; " to "; mseg%; " line segments"
REM  Map extraction complete now thin map to fit APRS 3000 pt limit
thin% = INT(mpts% \ (limit% - 2 * mseg% - 8)) + 1
OPEN datf FOR APPEND AS #2
'Put end of map here
finish = "   0,  -1"
PRINT #2, finish
nrecm& = LOF(2) \ 11
CLOSE 2
IF thin% < 1 THEN
  PRINT "WE HAVE A PROBLEM!"
  PRINT "THERE ARE MORE LINE SEGEMENTS "; nseg%
  PRINT "THAN ALLOWABLE POINTS "; limit%; " (4 pts/segement)"
  PRINT "SUGGEST USING REMAP.BAS TO THIN OUT OR REDO WITH"
  PRINT "WITH A SMALLER MAP RADIUS ---  REGRETS"
  STOP
END IF

' re-open as a random file
OPEN datf FOR RANDOM AS #2 LEN = 11
OPEN mapf FOR RANDOM AS #1 LEN = 11
FIELD 1, 11 AS stuff
FIELD 2, 11 AS instuff
'copy first eight lines to output file
FOR I% = 1 TO 8
GET 2, I%
LSET stuff = instuff
PUT 1, I%
NEXT I%
xtest% = 0
rstart& = 8
DO WHILE rstart& < nrecm&
 WHILE NOT xtest%  'Move to start of next line
 GET 2, rstart&
 rstart& = rstart& + 1
 IF (LEFT$(instuff, 9) = "   0,   0") THEN xtest% = -1
   IF rstart& > nrecm& THEN
    xtest% = -1
    rstart& = nrecm&
   END IF
 WEND
 xtest% = 0
 rstop& = rstart&
 WHILE NOT xtest%  'Find end of next line
  rstop& = rstop& + 1
  GET 2, rstop& + 1
  IF (LEFT$(instuff, 9) = "   0,   0") THEN xtest% = -1
   IF rstop& > nrecm& THEN
     rstop& = nrecm&
     xtest% = -1
   END IF
 WEND
'Copy every thin(t)h record from input to output file
'If line segment has less than n points then skip,
' but make sure that first and last points the same
' for both the original and thinned  segment
 n% = (rstop& - rstart&) / thin% + 1
 rcno& = rstart&
 IF n% > 1 THEN
  LSET stuff = "   0,   0" + CHR$(&HD) + CHR$(&HA)
  PUT 1
  GET 2, rcno&
  LSET stuff = instuff 'Color and segment label
  PUT 1
  rcno& = rcno& + 1
  wflg% = -1
  DO WHILE wflg%
    IF rcno& < rstop& THEN
      GET 2, rcno&
      LSET stuff = instuff
      PUT 1
     ELSE
      GET 2, rstop&
      LSET stuff = instuff
      PUT 1
      wflg% = 0
    END IF
    x% = VAL(instuff)
    y% = VAL(MID$(instuff, 6, 4))
    PRESET (x% * Hfac!, y%), 4
    rcno& = rcno& + thin%
  LOOP
 END IF
  rcno& = rstop& + 1
  rstart& = rcno&
xtest% = 0
LOOP
newmax& = LOF(1) / 11  ' Last record in mapf
CLOSE
PRINT "Hit any key to see the thinned map as it will appear in APRS"
DO WHILE INKEY$ = "": LOOP
CALL redraw(newmax&, mapf)
DO WHILE INKEY$ = "": LOOP
'TOGGLE F4 TO VIEW MAP AGAIN
STOP
punt:
PRINT "Unrecoverable error "; ERR; " has occurred!"
PRINT "Input variables"
PRINT "Path- "; path
PRINT "lat0 -"; lat0!
PRINT "long0-"; long0!
PRINT "Radius-"; mradm!
PRINT "Status pointers"
PRINT "file- "; F
PRINT "Line segements extracted "; nseg%
PRINT "Points extracted "; npts%
PRINT "File record number "; rcno&
PRINT "Do a screen dump to printer so author can de-bug"
STOP
'Hit F4 to see error msg; print screen for help in de-bugging
END

REM $STATIC
SUB achain (lindx&(), datf, mseg%, mpts%)
REDIM hdtail(2048, 2) AS STRING * 11
OPEN datf FOR RANDOM AS #2 LEN = 11
OPEN "temp" FOR RANDOM AS #3 LEN = 11
FIELD 2, 11 AS outstuff
FIELD 3, 11 AS instuff
LOCATE 1, 1
PRINT SPACE$(40);
LOCATE 1, 1
PRINT "Chaining segments ";
nseg% = mseg%
npts% = mpts%
'build table of line start and end points
'lindx&() built in main routine with pointer to "0,0" line starts
FOR I% = 1 TO nseg%
 i1& = lindx&(I%) + 2 'start
 GET 3, i1&
 hdtail(I%, 1) = instuff
 i2& = lindx&(I% + 1) - 1'end
 GET 3, i2&
 hdtail(I%, 2) = instuff
NEXT I%
'copy first 8 header items from temp to data file
FOR I% = 1 TO 8
GET 3, I%
LSET outstuff = instuff
PUT 2, I%
NEXT I%
maxr& = LOF(3) / 11
bstr = "   0,   0" + CHR$(&HD) + CHR$(&HA)
done = "X       X" + CHR$(&HD) + CHR$(&HA)
'copy first segment to data file
mpts% = 8
mseg% = 1
kseg% = 1
jseg% = 1
j& = 9
i1& = 9
I& = 9
GET 3, 10
oclr% = VAL(instuff)
clr% = oclr%
i2& = lindx&(2) - 1
backflg% = 0
new% = -1
tst& = i1& + 2
DO   'The main loop over all segments l1
LOCATE 1, 19
PRINT kseg%; nseg%; mpts%; npts%;
DO    'loop over a line segment       l2
'LOCATE 1, 1
'PRINT i1&; i&; i2&; j&; iseg%; kseg'debug
GET 3, I&
LSET outstuff = instuff
PUT 2, j&
j& = j& + 1
mpts% = mpts% + 1
'debug  .................................
IF I& >= tst& THEN
 u% = VAL(instuff) * Hfac!
 v% = VAL(RIGHT$(instuff, 6))
 IF new% THEN
  PSET (u%, v%)
  new% = 0
 ELSE
  LINE -(u%, v%)
 END IF
END IF
'debug ..................................
IF backflg% THEN
  I& = I& - 1
ELSE
  I& = I& + 1
END IF
LOOP UNTIL I& > i2& OR I& < i1&  'l2
ends = outstuff    'save end point
'search for another segment with same start or end
iseg% = kseg% + 1
  DO  'Loop over lines not copied yet l3
  k& = lindx&(iseg%)
  GET 3, k& + 1
  clr% = VAL(instuff)
  GET 3, k&
  ok% = 0
  IF instuff = bstr THEN   'This line has not be used nf1
    i1& = k& + 2     'First point of line
    i2& = lindx&(iseg% + 1) - 1  'Last point of line
    b = hdtail(iseg%, 1)
    IF b = ends THEN   'check start of line
     IF oclr% = clr% THEN
       i1& = i1& + 1  'this point already plotted in last segment
       I& = i1&
       backflg% = 0
       ok% = -1
     END IF
    END IF
    IF NOT ok% THEN  'check end of line     nf2
    e = hdtail(iseg%, 2)
    IF e = ends AND oclr% = clr% THEN
       i2& = i2& - 1  'Don't want overlap point twice
       I& = i2&
       backflg% = -1
       ok% = -1
    END IF
   END IF  'nf2
  END IF   'nf1
   IF ok% THEN
     LSET instuff = done
     PUT 3, k&      'Mark line as done
     oclr% = clr%
     EXIT DO
   END IF
   iseg% = iseg% + 1
'      LOCATE 1, 1
'      PRINT kseg%, iseg%; mseg%
   LOOP UNTIL iseg% > nseg%  ' l3
'Did not find a continuation to current line go get next line
'not already plotted
    IF NOT ok% THEN     'nf4
     new% = -1
     DO                 'l4
      kseg% = kseg% + 1 'Points to next line not used as segement start
      I& = lindx&(kseg%)
      GET 3, I&
      IF instuff = bstr THEN 'found a new line nf5
        ok% = -1
        LSET instuff = done
        PUT 3, I&      'Mark line as done
        LSET outstuff = bstr  '0,0 start of new line
        PUT 2, j&
        j& = j& + 1
        mpts% = mpts% + 1
        backflg% = 0
        I& = I& + 1 'Points to color label line
        GET 3, I&
        clr% = VAL(instuff)
        oclr% = clr%
        i1& = I&
        i2& = lindx&(kseg% + 1) - 1
        jseg% = jseg% + 1
        tst& = i1& + 1
        iseg% = kseg%
      END IF                 'nf5
    LOOP UNTIL kseg% > nseg% OR ok%  'l4
  END IF   'nf4
LOOP UNTIL kseg% > nseg%       'l1
mseg% = jseg%
CLOSE 3
CLOSE 2
END SUB

SUB fltest (good%)
'This tests to see if whole file has good data points using corner references
good% = -1
FIELD 1, 6 AS quad, 12 AS rflat, 12 AS rflong, 18 AS refx, 12 AS refy, 20 AS fill3
rcno& = 13
GET 1, rcno& 'Get NE corner reference points
longz! = VAL(rflong) 'East meridian of section
newz! = 6 * FIX(longz! / 6) - 3 'Get utm zone center meridian
IF newz! <> utmz! THEN
   utmz! = newz!
   CALL utm(xx0#, yy0#, utmz!)
   lat0! = lat0! + .25'a short meridian line through origin of map
   CALL utm(x1#, y1#, utmz!)
   lat0! = lat0! - .25'restore
   dx! = x1# - xx0#
   dy! = y1# - yy0#
   phi! = -ATN(dx! / dy!)  'rotation angle between true north and grid north
   cr! = COS(phi!)
   sr! = SIN(phi!)
END IF
e! = VAL(refx) - xx0#
n! = VAL(refy) - yy0#
rcno& = rcno& - 2
GET 1, rcno&  'Get SW reference points
w! = VAL(refx) - xx0#
s! = VAL(refy) - yy0#
IF w! > xmax! THEN good% = 0
IF e! < xmin! THEN good% = 0
IF n! < ymin! THEN good% = 0
IF s! > ymax! THEN good% = 0
END SUB

SUB fsel (path, ND%)
 'DIRECTORY SELECT MENU
 DIM dir(100) AS STRING * 35
 DEF SEG = &HB800'THIS IS LOCATION OF VIDEO RAM SCREEN 0 TEXT MODE
 SCREEN 0, 0
 CLS
 FILES path + "\*.*"     'CHANGE TO SUIT APPLICATION
 KPT% = 1:
 IP% = 160
 Tflg% = 0
 DO
 FOR L% = 0 TO 3
 e$ = ""
 FOR j% = IP% + 36 * L% TO (IP% + 36 * L% + 34) STEP 2'CHAR. IN EVERY OTHER LOC.
 e$ = e$ + CHR$(PEEK(j%))
 NEXT j%
 IF INSTR(e$, "<DIR>") = 0 AND LEFT$(e$, 6) <> "      " THEN
   dir(KPT%) = e$
   KPT% = KPT% + 1
 END IF
 NEXT L%
 IF LEFT$(e$, 6) = "      " THEN Tflg% = -1
 IP% = IP% + 160
 LOOP UNTIL IP% > 23 * 160 OR Tflg%
 DEF SEG
 ND% = KPT% - 1

END SUB

SUB init (mapf, datf, path, nf%, UB%)
REM Initialization and user input routine
REM COMMON SHARED lat0!, long0!, ymax!, xmax!, scfy!, scfx!, rds%, mradm!
REM COMMON SHARED ymin!, xmin!, yy0#, xx0#, utmz!, sr!, cr!, dir() AS STRING * 35
CLS
PRINT "Making APRS maps from the 100000:1 CD DLG CD"
PRINT "is a two step process. If you got to this step,"
PRINT "you should have already unpacked and copied the"
PRINT "map files of interest from the CD to a working"
PRINT "directory on your hard disk following the "
PRINT "instructions found with the CD documentation. "
PRINT
PRINT "Alternatively, you may use map files from the INTERNET..."
PRINT
PRINT "Remember the path to this working directory to which"
PRINT "you copied the files. Only the files that will "
PRINT "be used to make APRS maps should be in the hard"
PRINT "drive working directory. Otherwise this program"
PRINT "will crash. "
PRINT
INPUT "Are your files UN-BLOCKED (from internet)[U] or BLOCKED from the CD [B]"; a$
IF UCASE$(LEFT$(a$, 1)) = "U" THEN UB% = 80 ELSE UB% = 82
INPUT "What is path to map files"; path
CLS
PRINT "File path  is "; path
INPUT "Enter a file name for results (.map) will be added ", mapf
INPUT "Enter latitude of map center in degrees & minutes (dd,mm.m) ", d!, m!'Manual for now
lat0! = d! + m! / 60!
INPUT "Enter longitude of map center in degrees & minutes (dd,mm.m) ", d!, m!
long0! = ABS(d!) + m! / 60!
long0! = -1! * ABS(long0!) 'Optional format requries negative west longitudes
PRINT
PRINT "You are about to enter the radius of your map"
PRINT "This radius determines the level of detail in the map"
PRINT "Prefix your value with a minus (-) sign for less detail than the default"
PRINT "Prefix your value with a plus (+) sign for more detail than the default"
INPUT "Enter map radius in nautical miles ", mradm$
utmz! = 99    'Dummy start value
mradm! = ABS(VAL(mradm$))
sg% = 0
IF LEFT$(mradm$, 1) = "+" THEN sg% = 1
IF LEFT$(mradm$, 1) = "-" THEN sg% = -1
SELECT CASE mradm!
CASE IS > 16!
 CLS
 PRINT
 PRINT "The 100K CD is not recommended for maps bigger that"
 PRINT "16 miles. Use the 2Meg CD instead.  The code will proceed"
 PRINT "but be warned that it may crash"
 PRINT
 PRINT "Hit any key to continue"
 DO WHILE INKEY$ = "": LOOP
 rds% = 209
CASE 8! TO 16!
 rds% = 209
CASE 4! TO 8!
  rds% = 210
CASE IS > 2!
 rds% = 210
CASE IS <= 2!
 IF NOT sg% THEN
  CLS
  PRINT
  PRINT "   You have chosen a map size that will result in an attempt"
  PRINT "to extract all possible road data.  Depending on the density"
  PRINT "of map data in the area of interest, this may result in a "
  PRINT "in a program crash or a map that is thinned down too much"
  PRINT "to be useful.  In this case your options are to increase the"
  PRINT "map radius to more than 2 miles and live with the lack of class"
  PRINT "4 streets or sub-divide the region of interest into four 1 mile"
  PRINT "radius maps. A third alternative is to use a negative map radius."
  PRINT " This will lower level of detail by one step."
  PRINT "If USGS had used the same attribute coding as with 2meg CD, "
  PRINT "we might have been able to be more selective in choosing"
  PRINT "features for the 100k CD based APRS maps"
  PRINT
  PRINT "hit any key to continue"
  rds% = 211
 END IF
END SELECT
rds% = rds% + sg%
IF rds% > 211 THEN rds% = 211
IF rds% < 209 THEN rds% = 209
datf = mapf + ".dat"  'Data extracted from CD goes to this file
mapf = mapf + ".map"  'This file has final APRS map
mpernm! = 1854  'Meters per nautical mile
CALL fsel(path, nf%)
CLOSE 1
lfac! = COS(pi! * lat0! / 180!)
'Scaling the map and screen
rady! = mradm!
radx! = 4 * mradm! / 3 'screen aspect ratio
ymax! = mpernm! * rady! 'meters from center to top edge
ymin! = -ymax!
xmax! = mpernm! * radx! 'meters from center to left edge
xmin! = -xmax!
scfy! = 1! / (mpernm! * 60)
scfx! = scfy! / lfac!
drady! = rady! / 60! 'map vertical half span in degrees lat.
dradx! = radx! / (60! * lfac!) 'map horz. half span in degress long.
latmax! = lat0! + drady!
longmax! = ABS(long0!) + dradx!
ppdy! = INT(175! / drady! + .5)   'Data file scaling both lat&long
ppdx! = INT(320! / dradx! + .5)
Hfac! = ppdx! / ppdy!   'Sreen horizontal scaling

OPEN "temp" FOR OUTPUT AS #2
PRINT #2, USING "###.####_,"; latmax!
PRINT #2, USING "###.####_,"; longmax!
PRINT #2, USING "#####.##_,"; ppdy!
PRINT #2, USING "###.####_,"; lat0!
PRINT #2, USING "###.####_,"; ABS(long0!)
PRINT #2, USING "###.####_,"; mradm!
PRINT #2, "0,Reservd"
PRINT #2, "* Comment"
CLS
SCREEN 9
WIDTH 80, 43
END SUB

SUB redraw (cmaxrec&, datf) STATIC
REM Redraws the map without the clutter of the labels
nrec& = 9
CLS
OPEN datf FOR RANDOM AS #2 LEN = 11
FIELD 2, 11 AS stuff
WHILE nrec& < cmaxrec&
GET 2, nrec&
  IF stuff = "   0,   0" + CHR$(&HD) + CHR$(&HA) THEN
     'Start of a line segment
     GET 2, nrec& + 1
     clr% = VAL(stuff)
     nrec& = nrec& + 2
     GET 2, nrec&
     x% = VAL(stuff)
     y% = VAL(RIGHT$(stuff, 5))
     PSET (x% * Hfac!, y%), clr%
     nrec& = nrec& + 1
  ELSE  'Continuation of a line segement
     x% = VAL(stuff)
     IF x% <> 0 THEN
      y% = VAL(RIGHT$(stuff, 5))
      LINE -(x% * Hfac!, y%), clr%
     END IF
     nrec& = nrec& + 1
  END IF
WEND
CLOSE 2
END SUB

SUB Test (rcno&, rstop&, ratt&, testflg%, icolor%, lab)
REM COMMON SHARED lat0!, long0!, ymax!, xmax!, scfy!, scfx!
REM COMMON SHARED ymin!, xmin!, yy0#, xx0#
REM First test attribute and set color and line label if good
testflg% = 0
FIELD 1, 6 AS cmj1, 6 AS cmn1, 6 AS cmj2, 6 AS cmn2, 6 AS cmj3, 6 AS cmn3
  GET 1, ratt&
  attrb% = VAL(cmj1)
SELECT CASE attrb%
  CASE 50 'Stream, river bank or shore line
    minor% = VAL(cmn1)
    IF minor% > 199 AND minor% < 207 AND minor% <> 202 THEN 'shore lines
      icolor% = 3
      lab = "st"
      testflg% = -1
    ELSEIF minor% = 605 OR minor% = 606 THEN 'River bank
      icolor% = 3
      lab = "st"
      testflg% = -1
    END IF
  CASE 170  'roads general
     minor% = VAL(cmn1)
     IF minor% > 200 AND minor% < rds% THEN 'Road category depends on map size
       icolor% = 7
       lab = "rd"
       testflg% = -1
     ELSEIF minor% = 615 THEN  'By-pass
       icolor% = 10
       lab = "bp"
       testflg% = -1
     END IF
     'Now test to see if second attribute applies
     at2% = VAL(cmj2)
     mn2% = VAL(cmn2)
     SELECT CASE at2%
     CASE 172  'Interstate
         icolor% = 10
         lab = "I-" + RIGHT$(cmn1, 3) 'route number
       testflg% = -1
     CASE 173  'US route
         icolor% = 12
         lab = "us" + RIGHT$(cmn1, 3)  'route number
       testflg% = -1
     CASE 174  'State route
         icolor% = 4
         lab = "sr" + RIGHT$(cmn1, 3)  'route number
       testflg% = -1
     CASE 176 'County route
        icolor% = 7
         lab = "cr" + RIGHT$(cmn1, 3)  'route number
    END SELECT
'continue with first attribute
  CASE 172  'Interstate
         icolor% = 10
         lab = "I" + RIGHT$(cmn1, 3)
       testflg% = -1
  CASE 173  'US route
         icolor% = 12
         lab = "us" + RIGHT$(cmn1, 3)
       testflg% = -1
  CASE 174  'State route
         icolor% = 4
         lab = "sr" + RIGHT$(cmn1, 3)
       testflg% = -1
 END SELECT
IF testflg% THEN
' Test last point to see if it is on map
FIELD 1, 12 AS u1, 12 AS v1, 12 AS u2, 12 AS v2, 12 AS u3, 12 AS v3
GET 1, rstop& - 1
 IF VAL(u3) <> 0 THEN  'get the very last point; could be anywhere in record
  x! = VAL(u3) - xx0#
  y! = VAL(v3) - yy0#
 ELSEIF VAL(u2) <> 0 THEN
  x! = VAL(u2) - xx0#
  y! = VAL(v2) - yy0#
 ELSE
  x! = VAL(u1) - xx0#
  y! = VAL(v1) - yy0#
 END IF
 IF (y! <= ymax!) AND (y! >= ymin!) THEN
   IF (x! <= xmax!) AND (x! >= xmin!) THEN
     testflg% = -1
   END IF
END IF
IF NOT testflg% THEN
 ' Test midpoint to see if it falls on the map
 recmid& = (rstop& - 1 + rcno&) \ 2
 GET 1, recmid&
  x! = VAL(u2) - xx0# 'This catches short 2pt lines
  y! = VAL(v2) - yy0#
  IF (y! <= ymax!) AND (y! >= ymin!) THEN
    IF (x! <= xmax!) AND (x! >= xmin!) THEN
     testflg% = -1
    END IF
  END IF
END IF
' Test first point to see if it is on map
IF NOT testflg% THEN
 GET 1, rcno&
  x! = VAL(u1) - xx0#
  y! = VAL(v1) - yy0#
 ' PRINT tab30; x!; y!  'debug line
  IF (y! <= ymax!) AND (y! >= ymin!) THEN
    IF (x! <= xmax!) AND (x! >= xmin!) THEN
     testflg% = -1
    END IF
  END IF
END IF
END IF
END SUB

SUB utm (x#, y#, utmz!)
CONST pi# = 3.14159265359#
'COMMON SHARED lat0!, long0!, ymax!, xmax!, scf!, ppdx!
'This performs the lat/long coordinate conversion of map center
' to 100K CD  UTM projection coordinates.
' Algorithm found in Pearson, 'Map Projections', CRC Press, 1990, p343
' Text on pp 210-213 has numerous typos
a0# = 6378206 'Clark 1866 reference spheroid
e# = .082269
e2# = e# * e#
e4# = e2# * e2#
lat0r! = lat0! * pi# / 180!
dl! = (long0! - utmz!) * pi# / 180!
fe# = 500000  'False easting of x-coordinate of zone center meridian
cphi! = COS(lat0r!)
sphi! = SIN(lat0r!)
tphi! = TAN(lat0r!)
tphi2! = tphi! * tphi!
rp# = a0# / SQR(1! - e2# * sphi! * sphi!)
f1# = (1! - .25 * e2# - .046875 * e4#) * lat0r!
f2# = (.375 * e2# + .093758 * e4#) * SIN(2! * lat0r!)
f3# = .058594 * e4# * SIN(4! * lat0r!)
dm# = a0# * (f1# - f2# + f3#)
n2# = e2# * cphi! ^ 2 / (1 - e2#)
fx# = (1# - tphi2! + n2#)
fy# = (5# - tphi2! + 9# * n2#)
xx# = rp# * (dl! * cphi! + (dl! * cphi!) ^ 3 * fx# / 6#)
yy# = dm# + rp# * (dl! ^ 2 * sphi! * cphi! / 2 + dl! ^ 4 * sphi! * cphi! ^ 3 * fy# / 24#)
x# = .9996 * xx# + fe#
y# = .9996 * yy#


END SUB

