&routine drawgrid

&rem DRAWGRID.SML

&rem **** draw coordinate grid in ARCPLOTW ****************************

&rem Original version: 9/6/94  mtc
&rem Revised to handle negative coordinates:  2/1/98 mtc

&define int -1 &var
&define yshift -2 &var
&define tsize -3 &var
&define offset -4 &var
&define i -5 &var
&define n -6 &var
&define exp -7 &var
&define saxis -8 &var
&define xfirst -9 &var
&define yfirst -10 &var
&define xmin -11 &var
&define ymin -12 &var
&define xmax -13 &var
&define ymax -14 &var
&define axisx -15 &var
&define axisy -16 &var
&define gxmin -17 &var
&define gymin -18 &var
&define gxmax -19 &var
&define gymax -20 &var

&goto usage &if &eq "x[int]" "x/?"
&if &eq "x[int]" "x" &do
   &sv [int] #
&end
&if &eq "x[yshift]" "x" &or &eq "x[yshift]" "x#" &do
   &sv [yshift] 0
&end
&if &eq "x[tsize]" "x" &or &eq "x[tsize]" "x#" &do
   &sv [tsize] 0.08
&end
&if &eq "x[offset]" "x" &do
   &sv [offset] #
&end

SHOW MAPEXTENT [xmin] [ymin] [xmax] [ymax]
&cv [axisx] [xmax] - [xmin]
&cv [axisy] [ymax] - [ymin]

&rem **** if interval is not specified then calculate default *********

&if &eq "x[int]" "x#" &do

   &rem **** find shortest mapextent axis *****************************

   &if &eq %<[axisx] max [axisy]> [axisy] &do
      &sv [saxis] [axisx]
   &else
      &sv [saxis] [axisy]
   &end

   &rem **** find "scientific notation" *******************************

   &cv [exp] ( ( [saxis] ln ) / ( 10 ln ) ) int
   &cv [n] 10 ** ( ( ( [saxis] ln ) / ( 10 ln ) ) - [exp] )

   &rem **** set interval *********************************************

   &if &rn [n] 0 1.5 &do
      &cv [int] 0.25 * ( 10 ** [exp] )
   &elseif &rn [n] 1.5 3.0 &do
      &cv [int] 0.50 * ( 10 ** [exp] )
   &elseif &rn [n] 3.0 4.5 &do
      &cv [int] 0.75 * ( 10 ** [exp] )
   &elseif &rn [n] 4.5 6.0 &do
      &cv [int] 1.00 * ( 10 ** [exp] )
   &elseif &rn [n] 6.0 7.5 &do
      &cv [int] 1.25 * ( 10 ** [exp] )
   &else
      &cv [int] 1.50 * ( 10 ** [exp] )
   &end
   &type "Grid Interval = [int]"
&end

&rem **** set default text offset *************************************

&if &eq "x[offset]" "x#" &do
   &cv [offset] [int] / 50
&end

&rem **** find first gridline locations within mapextent **************

&cv [gxmin] [xmin] + ( [int] / 10 )
&cv [gymin] [ymin] + ( [int] / 10 )
&cv [gxmax] [xmax] - ( [int] / 10 )
&cv [gymax] [ymax] - ( [int] / 10 )
&if &eq %<[gxmin] min 0> 0 &do
   &cv [xfirst] [gxmin] - ( [gxmin] mod [int] ) + [int]
&else
   &cv [xfirst] [gxmin] + ( [gxmin] abs mod [int] )
&end
&if &eq %<[gymin] min 0> 0 &do
   &cv [yfirst] [gymin] - ( [gymin] mod [int] ) + [int]
&else
   &cv [yfirst] [gymin] + ( [gymin] abs mod [int] )
&end

&rem **** draw and annotate grid lines ********************************

LINESET COLOR255.LIN
LINESYMBOL 1
TEXTSET TRUETYPE.TXT
TEXTSYMBOL 31
TEXTSIZE [tsize]
UNITS MAP
&sv [i] [xfirst]
&while &rn [i] [gxmin] [gxmax] &do
   LINE [i] [ymin] [i] [ymax]
   TEXTANGLE 90
   MOVE %<[i] - [offset]> %<[ymin] + [offset]>
   TEXT [i]
   &inc [i] [int]
&end
&sv [i] [yfirst]
&while &rn [i] [gymin] [gymax] &do
   LINE [xmin] [i] [xmax] [i]
   TEXTANGLE 0
   MOVE %<[xmin] + [offset]> %<[i] + [offset]>
   TEXT %<[i] + [yshift]>
   &inc [i] [int]
&end

&return

&label usage

&type "Usage: &r DRAWGRID {interval} {yshift} {tsize} {offset}"
&type " "
&type "        interval = distance in map units between grid lines"
&type "                   (default is calculated)"
&type "          yshift = number to be added to printed y coordinates"
&type "                   (default = 0)"
&type "           tsize = text size"
&type "                   (default = 0.08)"
&type "          offset = text offset"
&type "                   (default = interval / 50)"

&return

&rem ******************************************************************

&routine keyskip

&rem KEYSKIP.SML

&rem **** skip to next row or column of legend in ARCPLOTW ************

&rem Original version: 9/8/94  mtc
&rem Revised for 3.5:  7/23/96 mtc

&rem **** establish variable set and arguments ************************

&define arg1 -1 &var
&define type -18 &var
&define temp -19 &var
&define wksp -20 &var
&define xmin 11 &var
&define ymin 12 &var
&define xmax 13 &var
&define ymax 14 &var
&define colw 15 &var
&define boxw 16 &var
&define boxh 17 &var
&define sept 18 &var
&define sepl 19 &var
&define tsize 20 &var
&define columns 21 &var
&define rows 22 &var
&define col 23 &var
&define row 24 &var

&goto usage &if &eq "x[arg1]" "x/?"
&value [wksp] WKSP
&if &nf [wksp]t$legp.sml &do
   &type "ERROR:  SETLEG must be executed first"
   &return
&end
&if &eq "x[arg1]" "x" &or &eq "x[arg1]" "x#" &do
   &sv [type] COLUMN
&else
   &extract [type] [arg1] 1
&end
&save [wksp]t$temp 11 24
&r [wksp]t$legp.sml

&rem **** check pointers and update as appropriate ********************

&sv [temp] OK
&if &eq [type] COLUMN &do
   &if &rn [col] 0 [columns] &and &ne [col] [columns] &do
      &cv [col] [col] + 1
      &sv [row] 1
   &else
      &type "ERROR: legend region full"
      &sv [temp] ERROR
   &end
&else
   &if &rn [row] 0 [rows] &and &ne [row] [rows] &do
      &cv [row] [row] + 1
   &elseif &rn [col] 0 [columns] &and &ne [col] [columns] &do
      &cv [col] [col] + 1
      &sv [row] 1
   &else
      &type "ERROR: legend region full"
      &sv [temp] ERROR
   &end
&end

&if &eq [temp] OK &do
   &save [wksp]t$legp 11 24
&else
   & DEL [wksp]t$legp.sml
&end

&r [wksp]t$temp.sml
& DEL [wksp]t$temp.sml

&return

&label usage

&type "Usage: &r KEYSKIP {type}"
&type " "
&type "arguments:  type = (COLUMN/ROW)"
&type "                   (default = COLUMN)"

&rem ******************************************************************

&routine keyspot

&rem KEYSPOT.SML

&rem **** adds PSPOT entry to legend **********************************

&rem Original version: 9/13/96  mtc

&rem **** establish variable set and arguments ************************

&define type -1 &var
&define size -2 &var
&define text -3 &var
&define outline -4 &var
&define box -5 &var
&define curlin -6 &var
&define entryx -7 &var
&define entryy -8 &var
&define pointx -9 &var
&define pointy -10 &var
&define wksp -20 &var
&define xmin 11 &var
&define ymin 12 &var
&define xmax 13 &var
&define ymax 14 &var
&define colw 15 &var
&define boxw 16 &var
&define boxh 17 &var
&define sept 18 &var
&define sepl 19 &var
&define tsize 20 &var
&define columns 21 &var
&define rows 22 &var
&define col 23 &var
&define row 24 &var

&goto usage &if &eq "x[type]" "x"
&goto usage &if &eq "x[type]" "x/?"
&goto usage &if &eq "x[size]" "x"
&goto usage &if &eq "x[text]" "x"
&value [wksp] WKSP
&if &nf [wksp]t$legp.sml &do
   &type "ERROR:  SETLEG must be executed first"
   &return
&end
&save [wksp]t$temp 11 25
&extract [type] [type] 1
&goto ok &if &eq CIRCLE [type]
&goto ok &if &eq SQUARE [type]
&goto ok &if &eq TRIANGLE [type]
&goto ok &if &eq DIAMOND [type]
&goto ok &if &eq STAR [type]
&goto ok &if &eq CROSS [type]
&goto usage
&label ok
&goto usage &if &nn [size]
&if &eq "x[outline]" "x" &or &eq "x[outline]" "x#" &do
   &sv [outline] NO
&else
   &extract [outline] [outline] 1
&end
&if &eq "x[box]" "x" &or &eq "x[box]" "x#" &do
   &sv [box] NOBOX
&else
   &extract [box] [box] 1
&end
&if &eq "x[curlin]" "x" &or &eq "x[curlin]" "x#" &do
   &sv [curlin] PLOTTER.LIN
&else
   &extract [curlin] [curlin] 1
&end

&save [wksp]t$temp 11 24
&r [wksp]t$legp.sml

&rem **** check pointer values ****************************************

&if &rn [row] 0 [rows] &and &rn [col] 0 [columns] &do
   UNITS PAGE

   &rem **** create spot coverage *************************************

   &if &fn [wksp]spot &do
      & DELETE [wksp]spot -NQ
   &end

   &cv [entryx] [xmin] + ( ( [col] - 1 ) * [colw] )
   &cv [entryy] [ymax] - ( [row] * ( [boxh] + [sepl] ) )
   &cv [pointx] [entryx] + ( [boxw] / 2 )
   &cv [pointy] [entryy] + ( [boxh] / 2 )

   &openw [wksp]p$spot1.sml
   &write "GENERATE [wksp]spot [wksp]p$spot2.sml"
   &write "CLEAN [wksp]spot"
   &write "QUIT"
   &closew

   &openw [wksp]p$spot2.sml
   &if &eq [type] CIRCLE &do
      &write "CIRCLES NOLABELS"
   &else
      &write "LINES"
   &end
   &cv [size] [size] / 2
   &if &eq [type] CIRCLE &do
      &write "101, [pointx], [pointy], [size]"
   &elseif &eq [type] SQUARE &do
      &write "101"
      &write "%<[pointx] - [size]> %<[pointy] - [size]>"
      &write "%<[pointx] - [size]> %<[pointy] + [size]>"
      &write "%<[pointx] + [size]> %<[pointy] + [size]>"
      &write "%<[pointx] + [size]> %<[pointy] - [size]>"
      &write "%<[pointx] - [size]> %<[pointy] - [size]>"
      &write "END"
   &elseif &eq [type] TRIANGLE &do
      &write "101"
      &write "[pointx] %<[pointy] + [size]>"
      &write "%<[pointx] + [size]> %<[pointy] - ( [size] * 0.625 )>"
      &write "%<[pointx] - [size]> %<[pointy] - ( [size] * 0.625 )>"
      &write "[pointx] %<[pointy] + [size]>"
      &write "END"
   &elseif &eq [type] DIAMOND &do
      &write "101"
      &write "[pointx] %<[pointy] + [size]>"
      &write "%<[pointx] + [size]> [pointy]"
      &write "[pointx] %<[pointy] - [size]>"
      &write "%<[pointx] - [size]> [pointy]"
      &write "[pointx] %<[pointy] + [size]>"
      &write "END"
   &elseif &eq [type] STAR &do
      &write "101"
      &write "[pointx] %<[pointy] + [size]>"
      &write "%<[pointx] + ( [size] * 0.625 )> %<[pointy] - ( [size] * 0.875 )>"
      &write "%<[pointx] - [size]> %<[pointy] + ( [size] * 0.25 )>"
      &write "%<[pointx] + [size]> %<[pointy] + ( [size] * 0.25 )>"
      &write "%<[pointx] - ( [size] * 0.625 )> %<[pointy] - ( [size] * 0.875 )>"
      &write "[pointx] %<[pointy] + [size]>"
      &write "END"
   &else
      &write "101"
      &write "%<[pointx] - ( [size] / 3 )> %<[pointy] + [size]>"
      &write "%<[pointx] + ( [size] / 3 )> %<[pointy] + [size]>"
      &write "%<[pointx] + ( [size] / 3 )> %<[pointy] + ( [size] / 3 )>"
      &write "%<[pointx] + [size]> %<[pointy] + ( [size] / 3 )>"
      &write "%<[pointx] + [size]> %<[pointy] - ( [size] / 3 )>"
      &write "%<[pointx] + ( [size] / 3 )> %<[pointy] - ( [size] / 3 )>"
      &write "%<[pointx] + ( [size] / 3 )> %<[pointy] - [size]>"
      &write "%<[pointx] - ( [size] / 3 )> %<[pointy] - [size]>"
      &write "%<[pointx] - ( [size] / 3 )> %<[pointy] - ( [size] / 3 )>"
      &write "%<[pointx] - [size]> %<[pointy] - ( [size] / 3 )>"
      &write "%<[pointx] - [size]> %<[pointy] + ( [size] / 3 )>"
      &write "%<[pointx] - ( [size] / 3 )> %<[pointy] + ( [size] / 3 )>"
      &write "%<[pointx] - ( [size] / 3 )> %<[pointy] + [size]>"
      &write "END"
   &end
   &write " "
   &write "QUIT"
   &write "&return"
   &closew

   WIN RUNW ARCX [wksp]p$spot1.sml

   &rem **** create graphic entry *************************************

   SHOW MAPEXTENT 1 2 3 4
   &sv -11 "%1 %2 %3 %4"
   SHOW MAPLIMITS 1 2 3 4
   &sv -12 "%1 %2 %3 %4"
   SHOW MAPPOSITION 1 2 3 4
   &sv -13 "%1 %2 %3 %4"
   SHOW MAPANGLE -14
   SHOW MAPSCALE -15

   &cv 1 [pointx] - [size]
   &cv 2 [pointy] - [size]
   &cv 3 [pointx] + [size]
   &cv 4 [pointy] + [size]

   MAPANGLE 0
   MAPSCALE AUTOMATIC
   MAPEXTENT %1 %2 %3 %4
   MAPLIMITS %1 %2 %3 %4
   MAPPOS CEN CEN

   SHOW SHADESYMBOL -1
   POLYGONSHADES [wksp]spot %-1
   &if &eq [outline] YES &do
      POLYS [wksp]spot
   &end

   MAPEXTENT %-11
   MAPLIMITS %-12
   MAPPOSITION %-13
   MAPANGLE %-14
   MAPSCALE %-15

   &if &eq [box] BOX &do
      LINESET PLOTTER.LIN
      LINESYMBOL 1
      BOX [entryx] [entryy] %<[entryx] + [boxw]> %<[entryy] + [boxh]>
      &if &ne "[curlin]" "PLOTTER.LIN" &do
         LINESET [curlin]
      &end
   &end

   &rem **** generate text entry **************************************

   MOVE %<[entryx] + [boxw] + [sept]> %[entryy]
   TEXTSET TRUETYPE.TXT
   TEXTSYMBOL 1
   TEXTSIZE [tsize]
   TEXT '[text]'

   &rem **** set and check pointers ***********************************

   &if &eq [row] [rows] &do
      &sv [row] 1
      &cv [col] [col] + 1
   &else
      &cv [row] [row] + 1
   &end
   &save [wksp]t$legp 11 24
&else
   &type "ERROR: legend region full"
   & DEL [wksp]t$legp.sml
&end

&r [wksp]t$temp.sml
& DEL [wksp]t$temp.sml

&return

&label usage

&delim < >
&type "Usage: &r KEYSPOT [type] [size] [text] {outline} {box} {curlin}"
&delim [ ]
&type " "
&type "    type = CIRCLE, SQUARE, TRIANGLE, DIAMOND, STAR, or CROSS"
&type "    size = size in page units"
&type "    text = legend text"
&type "           (must be in double quotes if contains spaces)"
&type " outline = NO/YES, draw outline using current line symbol"
&type "           (default = NO)"
&type "     box = (NOBOX/BOX) draw box around symbol"
&type "  curlin = lineset to resume after drawing box"
&type "           (default = plotter.lin)"

&return

&rem ******************************************************************

&routine keysym

&rem KEYSYM.SML

&rem **** add entry to legend in ARCPLOTW *****************************

&rem Original version: 9/8/94  mtc
&rem Revised for 3.5:  7/23/96 mtc

&rem **** establish variable set and arguments ************************

&define type -1 &var
&define symbol -2 &var
&define text -3 &var
&define box -4 &var
&define curlin -5 &var
&define msize -6 &var
&define entryx -7 &var
&define entryy -8 &var
&define boxx2 -9 &var
&define boxy2 -10 &var
&define linex1 -11 &var
&define linex2 -12 &var
&define pointx -13 &var
&define pointy -14 &var
&define tx -15 &var
&define wksp -20 &var
&define xmin 11 &var
&define ymin 12 &var
&define xmax 13 &var
&define ymax 14 &var
&define colw 15 &var
&define boxw 16 &var
&define boxh 17 &var
&define sept 18 &var
&define sepl 19 &var
&define tsize 20 &var
&define columns 21 &var
&define rows 22 &var
&define col 23 &var
&define row 24 &var

&goto usage &if &eq "x[type]" "x"
&goto usage &if &eq "x[type]" "x/?"
&goto usage &if &eq "x[symbol]" "x"
&goto usage &if &eq "x[text]" "x"
&value [wksp] WKSP
&if &nf [wksp]t$legp.sml &do
   &type "ERROR:  SETLEG must be executed first"
   &return
&end
&save [wksp]t$temp 11 25
&extract [type] [type] 1
&if &eq "x[box]" "x" &or &eq "x[box]" "x#" &do
   &sv [box] NOBOX
&else
   &extract [box] [box] 1
&end
&if &eq "x[curlin]" "x" &or &eq "x[curlin]" "x#" &do
   &sv [curlin] PLOTTER.LIN
&else
   &extract [curlin] [curlin] 1
&end
&if &eq [type] MARKER &do
   &if &eq "x[msize]" "x" &or &eq "x[msize]" "x#" &do
      &sv [msize] #
   &end
&end

&save [wksp]t$temp 11 24
&r [wksp]t$legp.sml

&rem **** check pointer values ****************************************

&if &rn [row] 0 [rows] &and &rn [col] 0 [columns] &do
   UNITS PAGE

   &rem **** generate graphic entry ***********************************

   &cv [entryx] [xmin] + ( ( [col] - 1 ) * [colw] )
   &cv [entryy] [ymax] - ( [row] * ( [boxh] + [sepl] ) )
   &cv [boxx2] [entryx] + [boxw]
   &cv [boxy2] [entryy] + [boxh]
   &if &eq [type] LINE &do
      &cv [linex1] ( ( [boxx2] - [entryx] ) / 3 ) + [entryx]
      &cv [linex2] ( 2 * ( [boxx2] - [entryx] ) / 3 ) + [entryx]
      LINESYMBOL [symbol]
      LINE [entryx] [entryy] [linex1] [boxy2] [linex2] [entryy] [boxx2] [boxy2]
   &elseif &eq [type] MARKER &do
      &cv [pointx] ( ( [boxx2] - [entryx] ) / 2 ) + [entryx]
      &cv [pointy] ( ( [boxy2] - [entryy] ) / 2 ) + [entryy]
      MARKERSYMBOL [symbol]
      &if &ne "x[msize]" "x#" &do
         MARKERSIZE [msize]
      &end
      MARKER [pointx] [pointy]
   &else
      SHADESYMBOL [symbol]
      PATCH [entryx] [entryy] [boxx2] [boxy2]
   &end
   &if &eq [box] BOX &do
      LINESET PLOTTER.LIN
      LINESYMBOL 1
      BOX [entryx] [entryy] [boxx2] [boxy2]
      &if &ne "[curlin]" "PLOTTER.LIN" &do
         LINESET [curlin]
      &end
   &end

   &rem **** generate text entry **************************************

   &cv [tx] [boxx2] + [sept]
   MOVE %[tx] %[entryy]
   TEXTSET TRUETYPE.TXT
   TEXTSYMBOL 1
   TEXTSIZE [tsize]
   TEXT '[text]'

   &rem **** set and check pointers ***********************************

   &if &eq [row] [rows] &do
      &sv [row] 1
      &cv [col] [col] + 1
   &else
      &cv [row] [row] + 1
   &end
   &save [wksp]t$legp 11 24
&else
   &type "ERROR: legend region full"
   & DEL [wksp]t$legp.sml
&end

&r [wksp]t$temp.sml
& DEL [wksp]t$temp.sml

&return

&label usage

&delim < >
&type "Usage: &r KEYSYM [type] [symbol] [text] {box} {curlin} {msize}"
&delim [ ]
&type " "
&type "          type = (LINE/MARKER/SHADE)"
&type "        symbol = legend symbol"
&type "          text = legend text"
&type "                 (must be in double quotes if contains spaces)"
&type "           box = (NOBOX/BOX) draw box around symbol"
&type "        curlin = lineset to resume after drawing box"
&type "                 (default = plotter.lin)"
&type "         msize = marker size (type = MARKER only)"
&type "                   (default = unchanged)"

&return

&rem ******************************************************************

&routine narrow

&rem NARROW.SML

&rem **** draw north arrow in ARCPLOTW *********************************

&rem Original version: 6/18/95 mtc
&rem Revised for 3.5:  7/23/96 mtc

&define arg1 -1 &var
&define arg2 -2 &var
&define arg3 -3 &var
&define arg4 -4 &var
&define i -5 &var
&define j -6 &var
&define cx -7 &var
&define cy -8 &var
&define width -9 &var
&define angle -10 &var

&rem **** establish parameters ****************************************

&goto usage &if &eq "x[arg1]" "x"
&goto usage &if &eq "x[arg1]" "x/?"
&goto usage &if &eq "x[arg2]" "x"
&sv [cx] [arg1]
&sv [cy] [arg2]
&if &eq "x[arg3]" "x" &or &eq "x[arg3]" "x#" &do
   &sv [width] 1
&else
   &sv [width] [arg3]
&end
&if &eq "x[arg4]" "x" &or &eq "x[arg4]" "x#" &do
   &sv [angle] 0
&else
   &sv [angle] [arg4]
&end

UNITS PAGE

&rem **** draw north arrow polygons ***********************************

SHADESET COLOR255.SHD
SHADESYMBOL 1
LINESET COLOR255.LIN
LINESYMBOL 1
&sv [i] 1
&while &rn [i] -1 1 &do
   &sv [j] 1
   &while &rn [j] -1 1 &do

      &rem **** find sin and cos of beta (alpha + xã/4) ***************

      &cv -1 ( ( [angle] sin ) * [j] ) + ( ( [angle] cos ) * [i] )
      &cv -2 ( ( [angle] cos ) * [j] ) - ( ( [angle] sin ) * [i] )
      &cv -11 [cx] + ( [width] * 0.07 * %-2 )
      &cv -12 [cy] + ( [width] * 0.07 * %-1 )


      &rem **** next angle is beta + ã/4 ******************************

      &cv -13 [cx] + ( [width] * 0.25 * ( %-2 - %-1 ) )
      &cv -14 [cy] + ( [width] * 0.25 * ( %-1 + %-2 ) )


      SHADE [cx] [cy] %-11 %-12 %-13 %-14
      LINE [cx] [cy] %-11 %-12 %-13 %-14 [cx] [cy]

      &rem **** next angle is beta + ã/2 ******************************

      &cv -11 [cx] - ( [width] * 0.07 * %-1 )
      &cv -12 [cy] + ( [width] * 0.07 * %-2 )

      LINE [cx] [cy] %-11 %-12 %-13 %-14 [cx] [cy]

      &cv [j] [j] - 2
   &end
   &cv [i] [i] - 2
&end

&rem **** draw "N" ****************************************************

TEXTSET PLOTTER.TXT
TEXTSYMBOL 41
SHOW TEXTANGLE -3
TEXTANGLE [angle]
TEXTSIZE %<[width] * 0.1> %<[width] * 0.125>

&rem **** find beta = alpha + angle corresponding to 0.05 shift *******

&cv -1 ( ( [angle] sin ) * 0.99655 ) + ( ( [angle] cos ) * 0.08305 )
&cv -2 ( ( [angle] cos ) * 0.99655 ) - ( ( [angle] sin ) * 0.08305 )

&rem **** find beta + ã/2 *********************************************

&cv -11 [cx] - ( [width] * 0.6 * %-1 )
&cv -12 [cy] + ( [width] * 0.6 * %-2 )
MOVE %-11 %-12
TEXT 'N'
TEXTANGLE %-3

&return

&label usage

&delim < >
&type "Usage: &r NARROW [x] [y] {width} {angle}"
&delim [ ]
&type " "
&type "            x = midpoint x coordinate in page units"
&type "            y = midpoint y coordinate in page units"
&type "        width = width of north arrow in page units"
&type "                (default = 1)"
&type "        angle = angle of north arrow in decimal degrees"
&type "                (default = 0)"

&return

&rem ******************************************************************

&routine neat

&rem NEAT.SML

&rem **** use single poly coverage or reselected poly *****************
&rem **** as mask/neatline in ARCPLOTW ********************************

&rem Original version: 10/9/95 mtc
&rem Revised for 3.5.2:  1/27/99

&define arg1 -1 &var
&define temp -10 &var
&define cover -11 &var
&define wksp -12 &var
&define curdir -13 &var

&goto usage &if &eq "x[arg1]" "x"
&goto usage &if &eq "x[arg1]" "x/?"
&sv [cover] [arg1]
&value [wksp] WKSP

&rem **** check validity of argument **********************************

&if &fn [wksp]neat &do
   & DELETE [wksp]neat -NQ
&end
&if &nf [cover] &do
   &type "ERROR: Coverage not found."
   &return
&end
&if &nf [cover]\pal &do
   &type "ERROR: Coverage is not polygon coverage."
   &return
&end
STATISTICS %[cover] POLY AREA
SHOW STATISTICS -1 -2 -3 -4 -5
&if &ne %-1 1 &do
   &if &ne %-1 2 &or &ne %-4 0 &do
      &type "ERROR:  Only one polygon may be used as neatline"
      &return
   &end
&end

&rem **** generate selection file *************************************

WIN SEL W [cover] POLY [wksp]t$neat.sel

&rem **** get current directory ***************************************

& CD >[wksp]t$curdir
&open [wksp]t$curdir error
&read -1 done
&label done
&close
& DEL [wksp]t$curdir
&value [curdir] -1

&rem **** generate SMLs to create mask coverage ***********************

&openw [wksp]t$neat1.sml
&write "A [curdir]"
&write "GENERATE [wksp]temp1 [wksp]t$neat2.sml"
&write "EXTRACT [cover] [wksp]t$neat.sel [wksp]temp2 POLY"
&write "APPEND [wksp]neat NOTEST NONE [wksp]t$neat3.sml"
&write "BUILD [wksp]neat POLY"
&write "&goto error &if &nf [wksp]neat\pal"
&write "CREATELA [wksp]neat"
&write "BUILD [wksp]neat POLY"
&write "&goto end"
&write "&label error"
&write "&openw [wksp]t$neat.err"
&write "&write ""Neatline polygon cannot intersect mapextent"" "
&write "& DELETE [wksp]neat -NQ"
&write "&closew"
&write "&label end"
&write "QUIT"
&closew

&openw [wksp]t$neat2.sml
SHOW MAPEXTENT -1 -2 -3 -4
&write "LINES"
&write "101"
&write "%-1, %-2"
&write "%-1, %-4"
&write "%-3, %-4"
&write "%-3, %-2"
&write "%-1, %-2"
&write "END"
&write "END"
&write "QUIT"
&closew

&openw [wksp]t$neat3.sml
&write "[wksp]temp1"
&write "[wksp]temp2"
&write "END"
&write "Y"
&closew

WIN RUNW arcx [wksp]t$neat1.sml

&rem **** shade neatline coverage *************************************

&if &fn [wksp]t$neat.err &do
   & type [wksp]t$neat.err
&else
   SHADESET hardware.shd
   RES [wksp]neat POLY NEAT_ = 2
   POLYGONSHADES [wksp]neat 0

   &rem **** get rid of edge speckles *********************************

   LINESET HARDWARE.LIN
   LINESYMBOL 1
   LINECOLOR 0
   SHOW MAPEXTENT -1 -2 -3 -4
   SHOW UNITS [temp]
   UNITS MAP
   BOX %-1 %-2 %-3 %-4
   SHOW MAPLIMITS -1 -2 -3 -4
   UNITS PAGE
   BOX %-1 %-2 %-3 %-4
   UNITS [temp]
&end

&rem **** keep the neatline coverage in case it's wanted **************

& DELETE [wksp]temp* -NQ
& DEL [wksp]t$neat*.*

&return

&label usage

&delim < >
&type "Usage: &r NEAT [cover]"
&type " "
&type "        cover = polygon coverage to use as mask"
&delim [ ]

&return

&label error

&type "I/O Error"
&return

&rem ******************************************************************

&routine pspot

&rem PSPOT.SML

&rem **** Plots point coverage in ARCPLOTW as shaded symbols **********

&rem Version 2.0: 9/13/96  mtc

&rem **** error checking **********************************************

&define arg1 -1 &var
&define arg2 -2 &var
&define arg3 -3 &var
&define arg4 -4 &var
&define cover -11 &var
&define size -12 &var
&define symbol -13 &var
&define outline -14 &var
&define wksp -15 &var
&define curdir -16 &var
&define temp -20 &var

&goto usage &if &eq "x[arg1]" "x"
&goto usage &if &eq "x[arg1]" "x/?"
&goto usage &if &eq "x[arg2]" "x"
&value [cover] [arg1]
&value [size] [arg2]
&if &eq "x[arg3]" "x" &or &eq "x[arg3]" "x#" &do
   &sv [symbol] CIRCLE
&else
   &extract [symbol] [arg3] 1
   &goto ok &if &eq CIRCLE [symbol]
   &goto ok &if &eq SQUARE [symbol]
   &goto ok &if &eq TRIANGLE [symbol]
   &goto ok &if &eq DIAMOND [symbol]
   &goto ok &if &eq STAR [symbol]
   &goto ok &if &eq CROSS [symbol]
   &goto usage
   &label ok
&end
&if &eq "x[arg4]" "x" &or &eq "x[arg4]" "x#" &do
   &sv [outline] NO
&else
   &extract [outline] [arg4] 1
&end
&value [wksp] WKSP
&if &nf [cover] &do
   &type "ERROR: Coverage not found."
   &return
&end
&if &nf [cover]\lab &or &fn [cover]\pal &do
   &type "ERROR: Coverage is not point coverage."
   &return
&end
&if &nn [size] &do
   &if &nf [cover]\pat.dbf &do
      &type "ERROR: Coverage has no point attributes."
      &return
   &end

   &rem **** see if size item exists **********************************

   &extract [size] [size] 1
   &openw [wksp]t$items.lis
   ITEMS [cover].PAT
   &closew
   &open [wksp]t$items.lis error
   &sv [temp] NO
   &while &do
      &read -1 [break]
      &extract -1 -1 2
      &if &eq %-1 [size] &do
         &sv [temp] YES
      &end
   &end
   &close
   & DEL [wksp]t$items.lis
   &if &eq [temp] NO &do
      &type "ERROR: Radius item does not exist in PAT."
      &return
   &end
&end
&if &fn [wksp]spot &do
   & DELETE [wksp]spot -NQ
&end

&rem **** generate selection file *************************************

WIN SEL w [cover] point [wksp]p$feat.sel

&rem **** get current directory ***************************************

& CD >[wksp]t$curdir
&open [wksp]t$curdir error
&read -1 done
&label done
&close
& DEL [wksp]t$curdir
&value [curdir] -1

&rem **** generate SMLs to create spot coverage ***********************

&openw [wksp]p$spot1.sml
&write "A [curdir]"
&write "EXTRACT [cover] [wksp]p$feat.sel [wksp]point POINT"
&write "UNGEN POINT [wksp]point [wksp]p$cov.gen"
&write "&goto FALSE001 &if &nm [size]"
&write "   TABLES [wksp]p$spot2.sml"
&write "&label FALSE001"
&write "GENERATE [wksp]spot [wksp]p$spot3.sml"
&write "&goto FALSE002 &if &fn [wksp]p$error.txt"
&write "   CLEAN [wksp]spot"
&write "&label FALSE002"
&write "& DELETE [wksp]point -NQ"
&write "QUIT"
&closew

&if &nn [size] &do
   &openw [wksp]p$spot2.sml
   &write "SEL [wksp]point.PAT"
   &write "&openw [wksp]p$size.lis"
   &write "LI [size]"
   &write "&closew"
   &write "QUIT"
   &closew
&end

&openw [wksp]p$spot3.sml
&write "&open [wksp]p$cov.gen error 1"
&write "&goto FALSE001 &if &nm [size]"
&write "   &open [wksp]p$size.lis error 2"
&write "   &read -1 error 2"
&write "&label FALSE001"

&if &eq [symbol] CIRCLE &do
   &write "CIRCLES NOLABELS"
&else
   &write "LINES"
&end

&rem **** get id, coordinate, and size ********************************

&write "&label WHILE001"
&write "   &read -1 END001 1"
&write "   &extract -2 -1 1"
&write "   &goto FALSE002 &if &eq %%-2 END"
&write "      &extract -11 -1 1"
&write "      &extract -12 -1 2"
&write "      &extract -13 -1 3"
&write "      &goto FALSE003 &if &NM [size]"
&write "         &read -14 END001 2"
&write "      &goto END003"
&write "      &label FALSE003"
&write "         &cv -14 [size]"
&write "      &label END003"

&write "&cv -14 %%-14 / 2"
&if &eq [symbol] CIRCLE &do
   &write "%%-11, %%-12, %%-13, %%-14"
&elseif &eq [symbol] SQUARE &do
   &write "%%-11"
   &write "%%<%%-12 - %%-14> %%<%%-13 - %%-14>"
   &write "%%<%%-12 - %%-14> %%<%%-13 + %%-14>"
   &write "%%<%%-12 + %%-14> %%<%%-13 + %%-14>"
   &write "%%<%%-12 + %%-14> %%<%%-13 - %%-14>"
   &write "%%<%%-12 - %%-14> %%<%%-13 - %%-14>"
   &write "END"
&elseif &eq [symbol] TRIANGLE &do
   &write "%%-11"
   &write "%%-12 %%<%%-13 + %%-14>"
   &write "%%<%%-12 + %%-14> %%<%%-13 - ( %%-14 * 0.625 )>"
   &write "%%<%%-12 - %%-14> %%<%%-13 - ( %%-14 * 0.625 )>"
   &write "%%-12 %%<%%-13 + %%-14>"
   &write "END"
&elseif &eq [symbol] DIAMOND &do
   &write "%%-11"
   &write "%%-12 %%<%%-13 + %%-14>"
   &write "%%<%%-12 + %%-14> %%-13"
   &write "%%-12 %%<%%-13 - %%-14>"
   &write "%%<%%-12 - %%-14> %%-13"
   &write "%%-12 %%<%%-13 + %%-14>"
   &write "END"
&elseif &eq [symbol] STAR &do
   &write "%%-11"
   &write "%%-12 %%<%%-13 + %%-14>"
   &write "%%<%%-12 + ( %%-14 * 0.625 )> %%<%%-13 - ( %%-14 * 0.875 )>"
   &write "%%<%%-12 - %%-14> %%<%%-13 + ( %%-14 * 0.25 )>"
   &write "%%<%%-12 + %%-14> %%<%%-13 + ( %%-14 * 0.25 )>"
   &write "%%<%%-12 - ( %%-14 * 0.625 )> %%<%%-13 - ( %%-14 * 0.875 )>"
   &write "%%-12 %%<%%-13 + %%-14>"
   &write "END"
&else
   &write "%%-11"
   &write "%%<%%-12 - ( %%-14 / 3 )> %%<%%-13 + %%-14>"
   &write "%%<%%-12 + ( %%-14 / 3 )> %%<%%-13 + %%-14>"
   &write "%%<%%-12 + ( %%-14 / 3 )> %%<%%-13 + ( %%-14 / 3 )>"
   &write "%%<%%-12 + %%-14> %%<%%-13 + ( %%-14 / 3 )>"
   &write "%%<%%-12 + %%-14> %%<%%-13 - ( %%-14 / 3 )>"
   &write "%%<%%-12 + ( %%-14 / 3 )> %%<%%-13 - ( %%-14 / 3 )>"
   &write "%%<%%-12 + ( %%-14 / 3 )> %%<%%-13 - %%-14>"
   &write "%%<%%-12 - ( %%-14 / 3 )> %%<%%-13 - %%-14>"
   &write "%%<%%-12 - ( %%-14 / 3 )> %%<%%-13 - ( %%-14 / 3 )>"
   &write "%%<%%-12 - %%-14> %%<%%-13 - ( %%-14 / 3 )>"
   &write "%%<%%-12 - %%-14> %%<%%-13 + ( %%-14 / 3 )>"
   &write "%%<%%-12 - ( %%-14 / 3 )> %%<%%-13 + ( %%-14 / 3 )>"
   &write "%%<%%-12 - ( %%-14 / 3 )> %%<%%-13 + %%-14>"
   &write "END"
&end

&write "   &label FALSE002"
&write "   &goback WHILE001"
&write "&label END001"
&write "&close &all"
&write " "
&write "QUIT"
&write "&return"
&write "&label error"
&write "&openw [wksp]p$error.txt"
&write "&write ""I/O Error"" "
&write "&closew"
&write "QUIT"
&write "&return"
&closew

WIN RUNW ARCX [wksp]p$spot1.sml

&rem **** shade and outline spot coverage *****************************

&if &fn [wksp]p$error.txt &do
   & TYPE [wksp]p$error.txt
&else
   SHOW SHADESYMBOL -1
   POLYGONSHADES [wksp]spot %-1
   &if &eq [outline] YES &do
      POLYS [wksp]spot
   &end
&end

&rem **** keep the spot coverage in case it's wanted ******************

& DEL [wksp]p$*.*
&return

&label usage

&delim < >
&type "Usage: &r PSPOT [cover] [size] {symbol} {outline}"
&delim [ ]
&type " "
&type "   cover = coverage"
&type "    size = size in map units or PAT item to use for size"
&type "  symbol = CIRCLE, SQUARE, TRIANGLE, DIAMOND, STAR, or CROSS"
&type "           (default = CIRCLE)"
&type " outline = NO/YES, draw outline using current line symbol"
&type "           (default = NO)"

&return

&label error

&type "I/O Error"
&return

&rem ******************************************************************

&routine sb

&rem SB.SML

&rem **** draw scalebar in ARCPLOTW ***********************************

&rem Original version: 4/27/95 mtc
&rem Revised for 3.5:  7/23/96 mtc

&rem **** establish variable set and arguments ************************

&define xbegin -1 &var
&define ybegin -2 &var
&define map -3 &var
&define units -4 &var
&define page -5 &var
&define tsize -6 &var
&define n -7 &var
&define x1 -11 &var
&define x2 -12 &var
&define x3 -13 &var
&define x4 -14 &var
&define x5 -15 &var
&define y1 -16 &var
&define y2 -17 &var
&define y3 -18 &var
&define y4 -19 &var

&goto usage &if &eq "x[xbegin]" "x"
&goto usage &if &eq "x[xbegin]" "x/?"
&goto usage &if &eq "x[ybegin]" "x"
&goto usage &if &eq "x[map]" "x"
&if &eq "x[units]" "x" &or &eq "x[units]" "x#" &do
   &sv [units] meters
&end
&if &eq "x[page]" "x" &or &eq "x[page]" "x#" &do
   &sv [page] 1
&end
&if &eq "x[tsize]" "x" &or &eq "x[tsize]" "x#" &do
   &sv [tsize] 0.1
&end

&rem **** draw scalebar ***********************************************

LINESET PLOTTER.LIN
SHADESET COLOR100.SHD
TEXTSET TRUETYPE.TXT
LINESYMBOL 1
SHADESYMBOL 100
TEXTSYMBOL 31
TEXTSIZE [tsize]
UNITS PAGE
&cv [x1] [xbegin]
&cv [x2] [xbegin] + ( [page] / 2 )
&cv [x3] [xbegin] + [page]
&cv [x4] [xbegin] + ( [page] * 2 )
&cv [x5] [xbegin] + ( [page] * 3 )
&cv [y1] [ybegin]
&rem &cv [y2] [ybegin] + 0.1
&rem &cv [y3] [ybegin] + 0.2
&rem &cv [y4] [ybegin] + 0.3
&cv [y2] [ybegin] + ( [page] * 0.1 )
&cv [y3] [ybegin] + ( [page] * 0.2 )
&cv [y4] [ybegin] + ( [page] * 0.3 )

BOX [x1] [y1] [x5] [y3]
PATCH [x1] [y2] [x2] [y3]
PATCH [x2] [y1] [x3] [y2]
PATCH [x3] [y2] [x4] [y3]
PATCH [x4] [y1] [x5] [y2]

&rem **** draw text ***************************************************

MOVE %[x3] %[y4]
TEXT '0' LC
&cv [n] [map] * 2
MOVE %[x5] %[y4]
TEXT '[n]' LC
TEXT '  [units]'
MOVE %[xbegin] %[y4]
TEXT '[map]' LC
MOVE %[x4] %[y4]
TEXT '[map]' LC

&return

&label usage

&delim < >
&type "Usage: &r SB [xbegin] [ybegin] [map] {units} {page} {tsize}"
&delim [ ]
&type " "
&type "        xbegin = starting x coordinates (page units)"
&type "        ybegin = starting y coordinates (page units)"
&type "           map = length of interval in map units"
&type "         units = map units"
&type "                 (default = meters)"
&type "          page = length of interval in page units"
&type "                 (default = 1)"
&type "         tsize = text size"
&type "                 (default = 0.1)"

&return

&rem ******************************************************************

&routine setleg

&rem SETLEG.SML

&rem **** set up legend area in ARCPLOTW ******************************

&rem Original version: 9/8/94  mtc
&rem Revised for 3.5:  7/23/96 mtc

&define arg1 -1 &var
&define arg2 -2 &var
&define arg3 -3 &var
&define arg4 -4 &var
&define arg5 -5 &var
&define arg6 -6 &var
&define arg7 -7 &var
&define arg8 -8 &var
&define arg9 -9 &var
&define arg10 -10 &var
&define wksp -20 &var
&define xmin 11 &var
&define ymin 12 &var
&define xmax 13 &var
&define ymax 14 &var
&define colw 15 &var
&define boxw 16 &var
&define boxh 17 &var
&define sept 18 &var
&define sepl 19 &var
&define tsize 20 &var
&define columns 21 &var
&define rows 22 &var
&define col 23 &var
&define row 24 &var

&goto usage &if &eq "x[arg1]" "x"
&goto usage &if &eq "x[arg1]" "x/?"
&goto usage &if &eq "x[arg2]" "x"
&goto usage &if &eq "x[arg3]" "x"
&goto usage &if &eq "x[arg4]" "x"
&value [wksp] WKSP
&save [wksp]t$temp 11 24
&if &fn [wksp]t$legp.sml &do
   & DEL [wksp]t$legp.sml
&end
&value [xmin] [arg1]
&value [ymin] [arg2]
&value [xmax] [arg3]
&value [ymax] [arg4]
&if &eq "x[arg5]" "x" &or &eq "x[arg5]" "x#" &do
   &sv [colw] 4.0
&else
   &value [colw] [arg5]
&end
&if &eq "x[arg6]" "x" &or &eq "x[arg6]" "x#" &do
   &sv [boxw] 0.5
&else
   &value [boxw] [arg6]
&end
&if &eq "x[arg7]" "x" &or &eq "x[arg7]" "x#" &do
   &sv [boxh] 0.167
&else
   &value [boxh] [arg7]
&end
&if &eq "x[arg8]" "x" &or &eq "x[arg8]" "x#" &do
   &sv [sept] 0.1
&else
   &value [sept] [arg8]
&end
&if &eq "x[arg9]" "x" &or &eq "x[arg9]" "x#" &do
   &sv [sepl] 0.167
&else
   &value [sepl] [arg9]
&end
&if &eq "x[arg10]" "x" &or &eq "x[arg10]" "x#" &do
   &sv [tsize] 0.15
&else
   &value [tsize] [arg10]
&end
&cv [columns] ( ( [xmax] - [xmin] ) / [colw] ) int
&cv [rows]  ( ( [ymax] - [ymin] ) / ( [boxh] + [sepl] ) ) int
&sv [col] 1
&sv [row] 1

&rem **** save legend parameters **************************************

&if &eq [columns] 0 &or &eq [rows] 0 &do
   &type "WARNING:  legend region insufficient for entries"
&else
   &save [wksp]t$legp 11 24
&end
&r [wksp]t$temp
& DEL [wksp]t$temp.sml

&return

&label usage

&delim < >
&type "Usage: &r SETLEG [xmin] [ymin] [xmax] [ymax] {colw} {boxw} {boxh}"
&type "                  {sept} {sepl} {tsize}"
&delim [ ]
&type " "
&type "         xmin = starting x coordinates (page units)"
&type "         ymin = starting y coordinates"
&type "         xmax = ending x coordinates"
&type "         ymax = ending y coordinates"
&type "         colw = column width"
&type "                (default = 4.0)"
&type "         boxw = keybox width"
&type "                (default = 0.5)"
&type "         boxh = keybox height"
&type "                (default = 0.167)"
&type "         sept = text separation"
&type "                (default = 0.1)"
&type "         sepl = line separation"
&type "                (default = 0.167)"
&type "        tsize = textsize"
&type "                (default = 0.15)"

&return