TRADER.RX

/* REXX */
ARG USROVERRIDE
/* Universe Structure */

OFFS=DCL('$DEFINE','SECTOR')
OFFS=DCL('SECKEY',1,20,'CHAR')
OFFS=DCL('SECTID',,8,'CHAR')
OFFS=DCL('ROW',,4,'CHAR')
OFFS=DCL('COL',,4,'CHAR')
OFFS=DCL('KPLANET',,20,'CHAR')
OFFS=DCL('SYSNAME',,30,'CHAR')
OFFS=DCL('KPORT',,20,'CHAR')
OFFS=DCL('OWNER',,6,'CHAR')
OFFS=DCL('BLACKHOLE',,1,'CHAR')
OFFS=DCL('LOTTERY',,1,'CHAR')

OFFS=DCL('$DEFINE','PORT')
OFFS=DCL('PORKEY',1,20,'CHAR')
OFFS=DCL('TPORT',,6,'CHAR')
OFFS=DCL('TNAME',,30,'CHAR')
OFFS=DCL('TROW',,4,'CHAR')
OFFS=DCL('TCOL',,4,'CHAR')
OFFS=DCL('TOWNER',,8,'CHAR')
OFFS=DCL('TFOOD',,18,'CHAR')
OFFS=DCL('TFPRICE',,18,'CHAR')
OFFS=DCL('TEQUIP',,18,'CHAR')
OFFS=DCL('TEPRICE',,18,'CHAR')
OFFS=DCL('TMATL',,18,'CHAR')
OFFS=DCL('TMPRICE',,18,'CHAR')
OFFS=DCL('TBANK',,18,'CHAR')

OFFS=DCL('$DEFINE','PLANET')
OFFS=DCL('PLAKEY',1,20,'CHAR')
OFFS=DCL('PLANET',,5,'CHAR')
OFFS=DCL('PNAME',,30,'CHAR')
OFFS=DCL('PSECT',,8,'CHAR')
OFFS=DCL('PROW',,4,'CHAR')
OFFS=DCL('PCOL',,4,'CHAR')
OFFS=DCL('POWNER',,8,'CHAR')
OFFS=DCL('PGENDEV',,3,'CHAR')
OFFS=DCL('PFIGHTERS',,18,'CHAR')
OFFS=DCL('PMINES',,18,'CHAR')
OFFS=DCL('PPOSTURE',,1,'CHAR')
OFFS=DCL('PFOOD',,18,'CHAR')
OFFS=DCL('PEQUIP',,18,'CHAR')
OFFS=DCL('PMATL',,18,'CHAR')
OFFS=DCL('PMONEY',,20,'CHAR')

OFFS=DCL('$DEFINE','DEFENSE')
OFFS=DCL('DEFKEY',1,20,'CHAR')
OFFS=DCL('ROW',,4,'CHAR')
OFFS=DCL('COL',,4,'CHAR')
OFFS=DCL('OWNER',,8,'CHAR')
OFFS=DCL('POSTURE',,1,'CHAR')
OFFS=DCL('FIGHTERS',,15,'CHAR')
OFFS=DCL('MINES',,15,'CHAR')
OFFS=DCL('NUKE',,1,'CHAR')
OFFS=DCL('NUKE_FOR',,6,'CHAR')
OFFS=DCL('BOOT',,1,'CHAR')

OFFS=DCL('$DEFINE','PLAYER')
OFFS=DCL('PLRKEY',1,20,'CHAR')
OFFS=DCL('USERID',,8,'CHAR')
OFFS=DCL('TEAM',,4,'CHAR')
OFFS=DCL('SCORE',,8,'CHAR')
OFFS=DCL('HANDLE',,30,'CHAR')
OFFS=DCL('SHIP',,3,'CHAR')
OFFS=DCL('SHIP_NAME',,30,'CHAR')
OFFS=DCL('HOLDS',,9,'CHAR')
OFFS=DCL('FOOD',,9,'CHAR')
OFFS=DCL('EQUIP',,9,'CHAR')
OFFS=DCL('MATL',,9,'CHAR')
OFFS=DCL('MONEY',,15,'CHAR')
OFFS=DCL('FIGHTERS',,10,'CHAR')
OFFS=DCL('MINES',,10,'CHAR')
OFFS=DCL('GENDEV',,3,'CHAR')
OFFS=DCL('NUKES',,3,'CHAR')
OFFS=DCL('BOOTS',,3,'CHAR')
OFFS=DCL('MODERATED',,1,'CHAR')
OFFS=DCL('SUSPEND',,1,'CHAR')
OFFS=DCL('CURSEC',,8,'CHAR')
OFFS=DCL('AUTOPAY',,1,'CHAR')
OFFS=DCL('WELC',,1,'CHAR')

/* DONT EVER EXPECT PLWORK TO BE WHAT YOU THINK */
/* IT IS.  ANY ROUTINE CAN UPDATE IT */
/* UNLESS YOU'RE DOING SOMETHING WITH IT IN */
/* A MAJOR FUNCTION THAT BEGINS AND ENDS IN ITSELF */
/* DONT DEPEND ON IT, IT'S FOR WORK ONLY */
/* IT'S HANDY WHEN YOU WANT TO LOAD ANOTHER PLAYER */
/* THAT ISN'T THE CURRENT PLAYER */

OFFS=DCL('$DEFINE','PLWORK')
OFFS=DCL('WPLRKEY',1,20,'CHAR')
OFFS=DCL('WUSERID',,8,'CHAR')
OFFS=DCL('WTEAM',,4,'CHAR')
OFFS=DCL('WSCORE',,8,'CHAR')
OFFS=DCL('WHANDLE',,30,'CHAR')
OFFS=DCL('WSHIP',,3,'CHAR')
OFFS=DCL('WSHIP_NAME',,30,'CHAR')
OFFS=DCL('WHOLDS',,9,'CHAR')
OFFS=DCL('WFOOD',,9,'CHAR')
OFFS=DCL('WEQUIP',,9,'CHAR')
OFFS=DCL('WMATL',,9,'CHAR')
OFFS=DCL('WMONEY',,15,'CHAR')
OFFS=DCL('WFIGHTERS',,10,'CHAR')
OFFS=DCL('WMINES',,10,'CHAR')
OFFS=DCL('WGENDEV',,3,'CHAR')
OFFS=DCL('WNUKES',,3,'CHAR')
OFFS=DCL('WBOOTS',,3,'CHAR')
OFFS=DCL('WMODERATED',,1,'CHAR')
OFFS=DCL('WSUSPEND',,1,'CHAR')
OFFS=DCL('WCURSEC',,8,'CHAR')
OFFS=DCL('WAUTOPAY',,1,'CHAR')
OFFS=DCL('WWELC',,1,'CHAR')

MAXROWS=350
MAXCOLS=350
MAXSECTORS=MAXROWS*MAXCOLS
LEAVING=0
ERRMSG=COPIES(' ',79)
call import fssapi
ADDRESS TSO
"CLEARS"
IF STRIP(USROVERRIDE)='NULL' THEN
   UID=SYSVAR(SYSUID)
ELSE
   DO
      UID=USROVERRIDE
   END
CALL OPENDSN

LEAVING=0
/* CHECK TO SEE IF THE UID IS REGISTERED */
CALL READUSER
IF WELC<>'N' THEN
   CALL WELCOME
DO WHILE NEWUSER=1
   CALL NEWUSER
   CALL CONFIRMNEW
   CALL WRITEUSER
END

DO WHILE LEAVING=0
   /* CHECK THE SECTOR BEFORE DOING STATUS */
   MYSECTOR=STRIP(CURSEC)
   /* IS THERE A LOTTERY? */
   /* IS THERE A BLACKHOLE? */
   /* IS THERE ANOTHER PLAYER? */
   /* IS THERE A PORT */
   /* IS THERE A PLANET */
   /* WHAT ARE THE DEFENSES? */
   CALL READSECTOR(MYSECTOR)
   CALL CHKSECT
   CALL TRSECTOR
   /* IN CASE TRSECTOR CHANGED CURRENT SECTOR */
   MYSECTOR=STRIP(CURSEC)
   CALL READSECTOR(MYSECTOR)
   CALL STATUS
END
CALL ENDPROG
EXIT

WELCOME:
ADDRESS FSS
CALL FSSINIT
CALL FSSTITLE "MVS TRADER V1R0M0",#PROT+#WHITE+#REVERSE
CALL FSSTEXT "Written in BREXX/370 for MVS 3.8j",2,1,,#PROT+#TURQ
CALL FSSTEXT " This game is completely open source.  You may use, copy and distribute",4,1,,#PROT+#TURQ
CALL FSSTEXT " this code in whatever means you like provided your own modifications",5,1,,#PROT+#TURQ
CALL FSSTEXT " maintain these terms.",6,1,,#PROT+#TURQ
CALL FSSTEXT " A special thanks to all the great people in the",8,1,,#PROT+#TURQ
CALL FSSTEXT "Mainframe Enthusiasts",8,50,,#PROT+#YELLOW+#BLINK
CALL FSSTEXT " Discord Server.  If you get a chance, stop in and you'll find friendly",9,1,,#PROT+#TURQ
CALL FSSTEXT " and helpful individuals willing to get you started on your own",10,1,,#PROT+#TURQ
CALL FSSTEXT " mainframe adventure.",11,1,,#PROT+#TURQ
CALL FSSTEXT " While this game is based on old BBS door games, it DOES     in any way",13,1,,#PROT+#TURQ
CALL FSSTEXT "NOT",13,58,,#PROT+#WHITE+#USCORE
CALL FSSTEXT " share code, functionality or data structures.  This game is not",14,1,,#PROT+#TURQ
CALL FSSTEXT " affiliated with or associated with any of those products and their",15,1,,#PROT+#TURQ
CALL FSSTEXT " authors in any way.",16,1,,#PROT+#TURQ
CALL FSSTEXT " Have fun, and enjoy the game.",18,1,,#PROT+#TURQ
CALL FSSTEXT " --ScottJ (westdalefarmer@gmail.com)",19,1,,#PROT+#TURQ
CALL FSSTEXT "PRESS <ENTER> TO BEGIN",21,2,,#PROT+#RED+#USCORE+#REVERSE
DO FOREVER
   RKEY=FSSREFRESH()
   IF RKEY=#ENTER THEN LEAVE
END
WELC='N'
CALL UPDATEUSER
CALL FSSCLOSE
RETURN

NEWUSER:
   ADDRESS FSS
   CALL FSSINIT
   CALL FSSTITLE 'WELCOME TO TRADER(MVS)',#prot+#WHITE
   CALL FSSTEXT 'This is your first time running TRADER.',3,3,,#PROT
   CALL FSSTEXT 'Please choose the name you will be known by.
',6,3,,#prot+#yellow
   CALL FSSTEXT 'Player name:',8,3,,#PROT+#YELLOW
   call fsstext 'Ship name:',9,3,,#prot+#yellow
   CALL FSSTEXT 'Your new ship will have 100 holds, and an initial
defense force',11,3,,#prot+#GREEN
   call fsstext 'of 10,000 fighters.',12,3,,#prot+#green
   call fsstext 'You will also start with 50,000 credits in your
bank account.',13,3,,#prot+#GREEN
   call fsstext 'A special shout out to all the fantastic folks
on the Mainframe',15,3,,#prot+#WHITE
   call fsstext 'Enthusiasts server on discord.  Without their
support and',16,3,,#prot+#white
   call fsstext 'encouragement this game would not be possible.
',17,3,,#prot+#white
   call fssfield 'Z_PLNAME',8,15,30,#PINK,UID
   call fssfield 'Z_SHNAME',9,15,30,#PINK,'Starship MVS Blue'
   call fsscursor 'Z_PLNAME'
   do forever
      ret=fssDisplay()
      if ret=#PFK03 then call endprog
      if ret=#ENTER then leave
   end
   call fssfgetall
   call fssclose
   address tso
   "CLEARS"
   PlayerName=Strip(Z_PLNAME)
   ShipName=Strip(Z_SHNAME)
return

CONFIRMNEW:
ADDRESS FSS
CALL FSSINIT
CALL FSSTITLE "CONFIRM YOUR PLAYER DETAILS",#PROT
CALL FSSTEXT "Username:",4,3,,#PROT+#GREEN
CALL FSSTEXT "  Player:",5,3,,#PROT+#GREEN
CALL FSSTEXT "    Ship:",6,3,,#PROT+#GREEN
CALL FSSFIELD 'Z_PLNAME',5,13,30,#WHITE,PlayerName
CALL FSSFIELD 'Z_SHNAME',6,13,30,#WHITE,ShipName
CALL FSSTEXT UID,4,13,,#PROT+#WHITE
CALL FSSCURSOR 'Z_PLNAME'
msg1='Make any changes to this information and press ENTER'
msg2='Press PFK03 to cancel.  This will not register you, and'
msg3='exit this game.'
CALL FSSTEXT MSG1,14,3,,#PROT+#RED
CALL FSSTEXT MSG2,15,3,,#PROT+#RED
CALL FSSTEXT MSG3,16,3,,#PROT+#RED

DO FOREVER
   RET=FSSDISPLAY()
   IF RET=#PFK03 THEN CALL ENDPROG
   IF RET=#ENTER THEN LEAVE
END
NEWUSER=0
CALL FSSCLOSE
RETURN

CHANGESHIPNAME:
ADDRESS FSS
CALL FSSCLOSE
CALL FSSINIT
CALL FSSTITLE 'GALACTIC SHIP REGISTRY',#PROT
CALL FSSTEXT 'Ship name:',5,5,,#PROT+#GREEN
CALL FSSTEXT ' NEW name:',7,5,,#PROT+#GREEN
call fsstext ShipName,5,20,,#PROT+#TURQ
CALL FSSFIELD 'ZNEWNAME',7,20,30,#YELLOW,ShipName
CALL FSSCURSOR 'ZNEWNAME'
CALL FSSTEXT '<ENTER> SET NEW NAME, <PFK03> CANCEL',23,1,,#PROT+#WHITE
DO FOREVER
  RKEY=FSSREFRESH()
  IF RKEY=#PFK03 THEN LEAVE
  IF RKEY=#ENTER THEN
     DO
       ShipName=FSSFGET('ZNEWNAME')
       SHIP_NAME=ShipName
       CALL UPDATEUSER
       LEAVE
     END
END
CALL FSSCLOSE
RETURN

STATUS:
ADDRESS FSS
CALL FSSCLOSE
CALL FSSINIT
CALL FSSTITLE 'SHIP STATUS '||'('||ShipName||')',#PROT
CALL FSSCOMMAND 2
CALL FSSTEXT 'Player:',3,1,,#PROT+#GREEN
CALL FSSTEXT PlayerName,3,9,,#PROT+#YELLOW
CALL FSSTEXT '  Ship:',3,40,,#PROT+#GREEN
CALL FSSTEXT ShipName,3,49,,#PROT+#YELLOW
CALL FSSTEXT 'Sector:',4,40,,#PROT+#GREEN
rowcol='('||strip(row)||','||strip(col)||')'
CALL FSSTEXT MYSECTOR||' '||rowcol,4,49,,#PROT+#YELLOW
CALL FSSTEXT 'System:',5,40,,#PROT+#GREEN
CALL FSSTEXT SYSNAME,5,49,,#PROT+#PINK
CALL FSSTEXT ' Money:',4,1,,#PROT+#GREEN
CALL FSSTEXT MONEY,4,9,,#PROT+#YELLOW
CALL FSSTEXT ' Holds:',5,1,,#PROT+#GREEN
CALL FSSTEXT HOLDS,5,9,,#PROT+#YELLOW
CALL FSSTEXT '   Food:',6,9,,#PROT+#GREEN
CALL FSSTEXT FOOD,6,20,,#PROT+#YELLOW
CALL FSSTEXT 'Equipment:',7,7,,#PROT+#GREEN
CALL FSSTEXT EQUIP,7,20,,#PROT+#YELLOW
CALL FSSTEXT 'Material:',8,8,,#PROT+#GREEN
CALL FSSTEXT MATL,8,20,,#PROT+#YELLOW
CALL FSSTEXT '       Fighters:',10,1,,#PROT+#GREEN
CALL FSSTEXT FIGHTERS,10,20,,#PROT+#YELLOW
CALL FSSTEXT '          Mines:',11,1,,#prot+#green
CALL FSSTEXT MINES,11,20,,#PROT+#YELLOW
CALL FSSTEXT 'Genesis Devices:',12,1,,#prot+#green
CALL FSSTEXT GENDEV,12,20,,#PROT+#YELLOW
CALL FSSTEXT '          Nukes:',13,1,,#prot+#green
CALL FSSTEXT NUKES,13,20,,#PROT+#YELLOW
CALL FSSTEXT '          Boots:',14,1,,#prot+#green
CALL FSSTEXT BOOTS,14,20,,#PROT+#YELLOW
TLANES='Trading lanes lead to the following sectors'
CALL FSSTEXT TLANES,21,1,,#PROT+#GREEN
CALL FSSTEXT GETEXITS(),22,1,,#PROT+#YELLOW
CALL FSSTEXT "<PFK03>-QUIT, <PFK01>-COMMAND HELP",23,1,,#PROT+#PINK
CALL FSSTEXT 'PORT:',17,40,,#PROT+#GREEN
CALL FSSTEXT 'PLANET:',18,40,,#PROT+#GREEN
IF STRIP(TNAME)='NO PORT' THEN DO
   CALL FSSTEXT TNAME,17,48,,#PROT+#BLUE
   CALL FSSTEXT '           ',16,5,,#PROT
   CALL FSSTEXT COPIES(' ',30),17,5,,#PROT
   CALL FSSTEXT COPIES(' ',30),18,5,,#PROT
   CALL FSSTEXT COPIES(' ',30),19,5,,#PROT
   END
else DO
   CALL PORTMARKET
   CALL FSSTEXT 'PORT REPORT',16,5,,#PROT+#RED
   CALL FSSTEXT TNAME,17,48,,#PROT+#YELLOW+#BLINK
   CALL FSSTEXT PORTLINE1,17,5,,#PROT+#WHITE
   CALL FSSTEXT PORTLINE2,18,5,,#PROT+#WHITE
   CALL FSSTEXT PORTLINE3,19,5,,#PROT+#WHITE
   END
IF STRIP(PNAME)='No planet' THEN
   CALL FSSTEXT PNAME,18,48,,#PROT+#BLUE
ELSE
   CALL FSSTEXT PNAME,18,48,,#PROT+#RED+#BLINK
CALL FSSTEXT ERRMSG,24,1,,#PROT+#WHITE+#BLINK
errmsg=copies(' ',79)
CALL SMSCAN
CALL FSSTEXT '   7     8     9',7,40,,#PROT+#WHITE
CALL FSSTEXT '4',11,38,,#WHITE
CALL FSSTEXT '6',11,60,,#WHITE
CALL FSSTEXT '   1     2     3',15,40,,#WHITE
CALL FSSTEXT SSCAN.1,8,40,,#PROT+#TURQ
CALL FSSTEXT SSCAN.2,9,40,,#PROT+#TURQ
CALL FSSTEXT SSCAN.3,10,40,,#PROT+#TURQ
CALL FSSTEXT SSCAN.4,11,40,,#TURQ
CALL FSSTEXT SSCAN.5,12,40,,#PROT+#TURQ
CALL FSSTEXT SSCAN.6,13,40,,#PROT+#TURQ
CALL FSSTEXT SSCAN.7,14,40,,#PROT+#TURQ
CALL FSSCURSOR 'ZCMD'
RKEY=FSSREFRESH()
MYCMD=FSSFGET('ZCMD')
IF RKEY=#PFK03 THEN LEAVING=1
IF RKEY=#PFK01 THEN CALL SHOWHELP
IF RKEY=#ENTER THEN CALL CMD
CALL FSSCLOSE
RETURN

SHOWHELP:
ADDRESS FSS
CALL FSSCLOSE
CALL FSSINIT
CALL FSSTITLE 'GAME COMMANDS',#PROT
CALL FSSTEXT 'This screen will develop as more commands are implemented.',2,1,,#prot+#turq
CALL FSSTEXT "M, or MOVE:  Moves your ship from it's current position to a nearby sector.",4,1,,#prot+#turq
CALL FSSTEXT "A, or AUTOPILOT: Engages autopilot to a sector, Cost is 50 credits",5,1,,#prot+#turq
CALL FSSTEXT "L, or LAND:  Land on the planet (Not implemented yet)",6,1,,#prot+#turq
CALL FSSTEXT 'CLAIM:  Claims ownership of unowned Systems',7,1,,#prot+#turq
CALL FSSTEXT 'SCAN:   Long range scanner',8,1,,#prot+#turq
call fsstext 'SHIPNAME: Allows you to change your ships name.',21,1,,#prot+#turq
call fsstext 'Movement commands are followed by a sector (M 1000)',23,1,,#prot+#white
call fsstext 'Any AID key returns',24,1,,#prot+#white
rkey=fssrefresh()
leaving=0
call fssclose
RETURN

AUTOPILOT:
   ARG TOSECTOR
   IF STRIP(TOSECTOR)='' THEN
      DO
         ERRMSG='You want to autopilot to nowhere?  Why?'
         RETURN
      END
ADDRESS FSS
CALL FSSCLOSE
CALL FSSINIT
CALL FSSTITLE 'INCOMING MESSAGE AUTOPILOT TO '||STRIP(TOSECTOR),#PROT
CALL FSSTEXT 'FROM: Universal Guidance',3,1,,#prot+#turq
CALL FSSTEXT 'MESSAGE:  Your autopilot request has been received.  Upon your confirmation',5,1,,#prot+#turq
CALL FSSTEXT '          a fee of 50 credits will be deducted from you account.',6,1,,#prot+#turq
CALL FSSTEXT '          To set up autopay, and avoid these messages for the rest of this',8,1,,#prot+#turq
CALL FSSTEXT '          session, respond with <A>.',9,1,,#prot+#turq
CALL FSSTEXT 'CONFIRM:           (Y/n/a)',11,1,,#prot+#green
CALL FSSFIELD 'ZCONFIRM',11,10,1,#YELLOW+#USCORE,'Y'
CALL FSSCURSOR 'ZCONFIRM'
CALL FSSTEXT '<PFK03> CANCEL, DO NOT ACCEPT, <ENTER> CONFIRM OR DENY',24,1,,#PROT+#WHITE
DO FOREVER
   RKEY=FSSREFRESH()
   IF RKEY=#PFK03 THEN
      DO
        ACCEPT='N'
        LEAVE
      END
   ANSWER=FSSFGET('ZCONFIRM')
   ACCEPT=TRANSLATE(ANSWER)
   IF RKEY=#ENTER THEN
      DO
      IF ACCEPT<>'N' THEN
         DO
            MONEY=MONEY-50
            CURSEC=STRIP(TOSECTOR)
            CALL UPDATEUSER
            RETURN
         END
      ELSE
         DO
            /* CANCEL AUTOPILOT */
            RETURN
         END
      END
END
RETURN

CMD:
/* PROCESSES COMMANDS */
/* NOTE THE FSS SCREEN IS STILL ACTIVE HERE */
MYCMD=STRIP(TRANSLATE(MYCMD))
IF MYCMD='1' THEN MYCMD='M '||GETROWCOL(ROW+1,COL-1)
IF MYCMD='2' THEN MYCMD='M '||GETROWCOL(ROW+1,COL)
IF MYCMD='3' THEN MYCMD='M '||GETROWCOL(ROW+1,COL+1)
IF MYCMD='4' THEN MYCMD='M '||GETROWCOL(ROW,COL-1)
IF MYCMD='6' THEN MYCMD='M '||GETROWCOL(ROW,COL+1)
IF MYCMD='7' THEN MYCMD='M '||GETROWCOL(ROW-1,COL-1)
IF MYCMD='8' THEN MYCMD='M '||GETROWCOL(ROW-1,COL)
IF MYCMD='9' THEN MYCMD='M '||GETROWCOL(ROW-1,COL+1)
PARSE VALUE MYCMD WITH COMM OPT
IF TRANSLATE(LEFT(COMM,1))='M' THEN
   DO
      CALL MOVEMENT(OPT)
   END
IF TRANSLATE(LEFT(COMM,8))='SHIPNAME' THEN
   DO
      CALL CHANGESHIPNAME
   END
IF TRANSLATE(LEFT(COMM,5))='CLAIM' THEN
   DO
      CALL MAKECLAIM
   END
IF TRANSLATE(LEFT(COMM,1))='A' THEN
   DO
      IF OPT>(MAXROWS*MAXCOLS) THEN
         DO
           ERRMSG='That is uncharted territory.  Autopilot unavailable.'
           RETURN
         end
      CALL AUTOPILOT(OPT)
   END
IF TRANSLATE(LEFT(COMM,1))='L' THEN
   DO
      CALL TRPLANET
      RETURN
   END
IF TRANSLATE(LEFT(COMM,1))='S' THEN
  DO
    CALL SCANNER
  END
RETURN

MOVEMENT:
   ARG TOSECT
   IF TOSECT<1 THEN
      DO
        ERRMSG="That would move you into uncharted space."
        Return
      end
   IF TOSECT>MAXSECTORS THEN
      DO
        ERRMSG="That would move you into uncharted space."
        return
      end
   IF FIND(GETEXITS(),TOSECT)=0 THEN DO
      ERRMSG="You can't get there from here.  Try again."
      return
      end
   CURSEC=TOSECT
   CALL UPDATEUSER
   call readsector(cursec)
RETURN

SMSCAN:
  /* RETURNS STEM WITH SMALL SCAN IMAGE */
  /* FOR THE STATUS DISPLAY             */
  DROP SSCAN.
  DROP SSEC.
  THISROW=ROW
  THISCOL=COL
  SSCAN.1=':-----:-----:-----.'
  SSCAN.2=':     :     :     :'
  SSCAN.3=SSCAN.1
  SSCAN.4=SSCAN.2
  SSCAN.5=SSCAN.1
  SSCAN.6=SSCAN.2
  SSCAN.7=SSCAN.1
  SSCAN.0=7
  SSEC.1=GETROWCOL(THISROW-1,THISCOL-1)
  SSEC.2=GETROWCOL(THISROW-1,THISCOL)
  SSEC.3=GETROWCOL(THISROW-1,THISCOL+1)
  SSEC.4=GETROWCOL(THISROW,THISCOL-1)
  SSEC.5=GETROWCOL(THISROW,THISCOL)
  SSEC.6=GETROWCOL(THISROW,THISCOL+1)
  SSEC.7=GETROWCOL(THISROW+1,THISCOL-1)
  SSEC.8=GETROWCOL(THISROW+1,THISCOL)
  SSEC.9=GETROWCOL(THISROW+1,THISCOL+1)
  SSEC.0=9
  SECTORHOLD=SETRECORD('SECTOR')
  DO I=1 TO 9
     SRPT.I=0
     MAXSECTORS=MAXROWS*MAXCOLS
     IF SSEC.I=0 THEN
        DO
           SRPT.I='XXX'
           ITERATE
        END
     CALL READSECTOR(SSEC.I)
     IF STRIP(KPLANET)<>'' THEN SRPT.I=100
     IF STRIP(KPORT)<>'' THEN SRPT.I=SRPT.I+50
     IF STRIP(OWNER)<>'' THEN SRPT.I=SRPT.I+1
     IF STRIP(BLACKHOLE)<>'' THEN SRPT.I=SRPT.I+10
     IF STRIP(LOTTERY)<>'' THEN SRPT.I=SRPT.I+12
     TEMP='000'
     L=LENGTH(SRPT.I)
     OVP=4-L
     TEMP=OVERLAY(SRPT.I,TEMP,OVP)
     SRPT.I=TEMP
  END
  SRPT.0=9
  /* PROCESS SSEC */
  SSCAN.2=OVERLAY(SRPT.1,SSCAN.2,3)
  SSCAN.2=OVERLAY(SRPT.2,SSCAN.2,9)
  SSCAN.2=OVERLAY(SRPT.3,SSCAN.2,15)
  SSCAN.4=OVERLAY(SRPT.4,SSCAN.4,3)
  SSCAN.4=OVERLAY('***',SSCAN.4,9)
  SSCAN.4=OVERLAY(SRPT.6,SSCAN.4,15)
  SSCAN.6=OVERLAY(SRPT.7,SSCAN.6,3)
  SSCAN.6=OVERLAY(SRPT.8,SSCAN.6,9)
  SSCAN.6=OVERLAY(SRPT.9,SSCAN.6,15)
  /* PUT THINGS BACK */
  CALL SPLITRECORD 'SECTOR',SECTORHOLD
  RETURN SSCAN.
SCANNER:
OFFS=DCL('$DEFINE','LRSCAN')
OFFS=DCL('LSECTOR',1,9,'CHAR')
OFFS=DCL('LPORT',,20,'CHAR')
OFFS=DCL('LPLAN',,20,'CHAR')
OFFS=DCL('LDEF',,15,'CHAR')
OFFS=DCL('LANOM',,15,'CHAR')
LSECTOR='SECTOR'
LPORT='PORT'
LPLAN='PLANET'
LDEF='DEFENSE'
LANOM='ANOMOLIES'
HEADER=SETRECORD('LRSCAN')
DROP EXITS.
DROP BUFFER.
BUFFER.0=0
CALL SPLIT(GETEXITS(),'EXITS.')
IF EXITS.0=0 THEN
    DO
      ERRMSG='Interference has rendered sensors inoperable.'
      return
    END
ELSE
    DO I=1 TO EXITS.0
    /* MOVE CURRENT RECORDS OUT OF THE WAY */
    SECTORHOLD=SETRECORD('SECTOR')
    PLANETHOLD=SETRECORD('PLANET')
    PORTHOLD=SETRECORD('PORT')
    THISID=EXITS.I
    CALL READSECTOR(THISID)
    LSECTOR=STRIP(SECTID)
    IF STRIP(KPORT)<>'' THEN CALL READPORT(KPORT)
    IF STRIP(KPLANET)<>'' THEN CALL READPLANET(KPLANET)
    LPORT=TNAME
    LPLAN=PNAME
    LDEF="Unknown"
    LANOM=''
    IF STRIP(OWNER)='0' THEN OWNER=''
    IF BLACKHOLE='Y' THEN LANOM="DANGER "
    IF STRIP(OWNER)<>'' THEN LANOM=LANOM||'OWNED('STRIP(OWNER)')'
    OUTREC=SETRECORD('LRSCAN')
    BUFCOUNT=BUFFER.0+1
    BUFFER.BUFCOUNT=OUTREC
    BUFFER.0=BUFCOUNT
    END
/* PUT THINGS BACK! */
CALL SPLITRECORD 'SECTOR',SECTORHOLD
CALL SPLITRECORD 'PLANET',PLANETHOLD
CALL SPLITRECORD 'PORT',PORTHOLD
ADDRESS FSS
CALL FSSCLOSE
CALL FSSINIT
_screen.footer='PFK03 EXIT'
_screen.color.List2=#YELLOW
_screen.color.Top2=#White
CALL FMTLIST(1,'_',HEADER,,'Scanner')
RETURN

WRITEUSER:

/* WRITE THE USER TO THE DATASET */
/* THIS PROC IS FOR NEW USERS ONLY */
/* USE UPDATEUSER AFTER INITIAL PLACEMENT */

PLKEY=FIXKEY('PLY'||UID)
PLRKEY=PLKEY
USERID=UID
TEAM=0
SCORE=0
HANDLE=PlayerName
SHIP=0 /* not implemented yet */
SHIP_NAME=ShipName
HOLDS=100
FOOD=0
EQUIP=0
MATL=0
MONEY=50000
FIGHTERS=10000
MINES=0
GENDEV=0
NUKES=0
BOOTS=0
MODERATED='N'
SUSPEND='N'
CURRENT=SETRECORD('PLAYER')
ADDRESS TSO
"VSAMIO OPEN UNISET (UPDATE"
"VSAMIO READ UNISET (KEY "PLKEY" UPDATE VAR OLDREC"
"VSAMIO WRITE UNISET (KEY "PLKEY" VAR CURRENT"
IF RC<>0 THEN DO
   SAY 'UNABLE TO WRITE RECORD RC='RC', RCX='RCX
   CALL ENDPROG
   END
"VSAMIO CLOSE UNISET"
NEWUSER=0
/* SANITY CHECK, READ THE PLAYER RECORD */
CURRENT=''
CALL READUSER
RETURN

UPDATEUSER:
ADDRESS TSO
PLKEY=FIXKEY('PLY'||UID)
CURRENT=SETRECORD('PLAYER')
"VSAMIO OPEN UNISET (UPDATE"
"VSAMIO READ UNISET (KEY "PLKEY" UPDATE VAR OLDREC"
"VSAMIO WRITE UNISET (KEY "PLKEY" VAR CURRENT"
IF RC<>0 THEN DO
   SAY 'UNABLE TO UPDATE RECORD RC='RC', RCX='RCX
   END
"VSAMIO CLOSE UNISET"
RETURN

READUSER:
  PLKEY=FIXKEY('PLY'||UID)
  NEWUSER=1
  ADDRESS TSO
  "VSAMIO OPEN UNISET (READ"
  "VSAMIO READ UNISET (KEY "PLKEY" UPDATE VAR CURRENT"
  "VSAMIO CLOSE UNISET"
  CALL SPLITRECORD 'PLAYER',CURRENT
  IF STRIP(USERID)=STRIP(UID) THEN DO
     PlayerName=Strip(Handle)
     ShipName=Strip(SHIP_NAME)
     IF STRIP(CURSEC)='' THEN DO
        CURSEC=PICKSECTOR()
        CALL WRITEUSER
        END
     NEWUSER=0
     END
  RETURN

ENDPROG:
   CALL CLOSEDSN
   EXIT

OPENDSN:
   ADDRESS TSO
   "ALLOCATE FILE(UNISET) DSN('TRADER.UNIVERSE') SHR"
   IF RC<>0 THEN
      DO
         SAY "UNABLE TO ACCESS THE UNIVERSE DATASET."
         EXIT
      END
   RETURN

CLOSEDSN:
   ADDRESS TSO
   "FREE FILE(UNISET)"
   IF RC<>0 THEN
      DO
         SAY "UNABLE TO FREE THE UNIVERSE DSET ALLOCATION."
         EXIT
      END
   RETURN

FIXKEY:
   ARG INKEY
   INKEY=SUBSTR(INKEY,1,20,'_')
   OUTKEY=TRANSLATE(INKEY,'_',' ')
   RETURN OUTKEY

PICKSECTOR:
   SEED=RIGHT(TIME('LONG'),6)
   RNDROW=RANDOM(0,MAXROWS,SEED)
   RNDCOL=RANDOM(0,MAXCOLS,SEED)
   NEWSECTOR=((RNDROW-1)*350)+RNDCOL
   RETURN NEWSECTOR

GETROWCOL:
   ARG R,C
   /* SECTORS ARE NUMBERED ((R-1)*350)+C */
   IF R<1 THEN RETURN '0 '
   IF R>MAXROWS THEN RETURN '0 '
   IF C<1 THEN RETURN '0 '
   IF C>MAXCOLS THEN RETURN '0 '
   OSECT=((R-1)*350)+C
RETURN OSECT||' '

GETEXITS:
   MYROW=ROW
   MYCOL=COL
   TOSECTS=''
   TOSECTS=TOSECTS||FORMAT(GETROWCOL(MYROW-1,MYCOL-1))||' '
   TOSECTS=TOSECTS||FORMAT(GETROWCOL(MYROW-1,MYCOL))||' '
   TOSECTS=TOSECTS||FORMAT(GETROWCOL(MYROW-1,MYCOL+1))||' '
   TOSECTS=TOSECTS||FORMAT(GETROWCOL(MYROW,MYCOL-1))||' '
   TOSECTS=TOSECTS||FORMAT(GETROWCOL(MYROW,MYCOL+1))||' '
   TOSECTS=TOSECTS||FORMAT(GETROWCOL(MYROW+1,MYCOL-1))||' '
   TOSECTS=TOSECTS||FORMAT(GETROWCOL(MYROW+1,MYCOL))||' '
   TOSECTS=TOSECTS||FORMAT(GETROWCOL(MYROW+1,MYCOL+1))||' '
   DO FOREVER
      THISWORD=FIND(TOSECTS,'0')
      IF THISWORD=0 THEN LEAVE
      TOSECTS=DELWORD(TOSECTS,THISWORD,1)
   END
   RETURN TOSECTS

READSECTOR:
   ARG SECT
   IF SECT=0 THEN RETURN
   SEKEY=FIXKEY('SEC'||SECT)
   SECREC=''
   call splitrecord 'PORT',secrec /* empty port dcl */
   call splitrecord 'PLANET',secrec /* empty planet dcl */
   ADDRESS TSO
   "VSAMIO OPEN UNISET (READ"
   "VSAMIO READ UNISET (KEY "SEKEY" VAR SECREC"
   "VSAMIO CLOSE UNISET"
   CALL SPLITRECORD "SECTOR",SECREC
   IF STRIP(SECTID)='' THEN SAY 'WHAT?  NO SECTOR 'SEKEY'?'
   IF STRIP(KPORT)<>'' THEN CALL READPORT(KPORT)
   IF STRIP(KPLANET)<>'' THEN CALL READPLANET(KPLANET)
   IF STRIP(TNAME)='' THEN TNAME='NO PORT'
   IF STRIP(PNAME)='' THEN PNAME='No planet'
   ADDRESS FSS
RETURN

WRITESECTOR:
/* NO NEED TO PASS THE SECTOR IN, IT SHOULD BE LOADED ALREADY */
SEKEY=FIXKEY('SEC'||SECID)
ADDRESS TSO
SECREC=SETRECORD('SECTOR')
"VSAMIO OPEN UNISET (UPDATE"
"VSAMIO READ UNISET (KEY "SEKEY" UPDATE VAR DUMMYREC"
"VSAMIO WRITE UNISET (KEY "SEKEY" VAR SECREC"
WRC=RC; WRCX=RCX
"VSAMIO CLOSE UNISET"
IF WRC<>0 THEN DO
   SAY 'UNABLE TO UPDATE SECTOR ('SEKEY') RC='WRC' RCX='WRCX
   CALL ENDPROG
   END
ADDRESS FSS
RETURN

READPLANET:
   ARG PLANETKEY
   /* LOADS A PLANET INTO THE DCL 'PLANET' */
   READREC=''
   ADDRESS TSO
   "VSAMIO OPEN UNISET (READ"
   "VSAMIO READ UNISET (KEY "PLANETKEY" UPDATE VAR READREC"
   IF RC<>0 THEN
      DO
         SAY "UNABLE TO READ PLANET "PLANETKEY
         CALL ENDPROG
      END
   /* CHECK TO MAKE SURE IT'S REAL */
   IF LEFT(READREC,20)<>PLANETKEY THEN
      DO
         /* THIS ISN'T IT. PUT A NUL REC INTO PLANET */
         READREC=''
         call splitrecord 'PLANET',READREC
      END
   ELSE
      DO
         /* THIS IS THE RIGHT PLANET */
         /* PUT IT IN THE PLANET DCL */
         call splitrecord 'PLANET',READREC
      END
   "VSAMIO CLOSE UNISET"
   ADDRESS FSS /* PUT IT BACK TO FSS SO THE WORLD DOESN'T END */
RETURN

UPDATEPLANET:
   THISKEY=PLAKEY
   ADDRESS TSO
   "VSAMIO OPEN UNISET (UPDATE"
   "VSAMIO READ UNISET (KEY "PLAKEY" UPDATE VAR DUMMYREC"
   PLRECORD=SETRECORD('PLANET')
   "VSAMIO WRITE UNISET (KEY "PLAKEY" VAR PLRECORD"
   "VSAMIO CLOSE UNISET"
   ADDRESS FSS
   RETURN

READPORT:
   ARG PORTKEY
   /* LOADS A PORT INTO THE PORT DCL */
   READREC=''
   ADDRESS TSO
   "VSAMIO OPEN UNISET (READ"
   "VSAMIO READ UNISET (KEY "PORTKEY" UPDATE VAR READREC"
   /* SANITY CHECK */
   IF LEFT(READREC,20)<>PORTKEY THEN
      DO
        /* IT'S NOT MY PORT */
        READREC=''
        /* DUMP A NULL RECORD INTO PORT */
        call splitrecord 'PORT',READREC
      END
   ELSE
      DO
         /* THIS IS THE RIGHT PORT */
         call splitrecord 'PORT',READREC
      END
   "VSAMIO CLOSE UNISET"
   ADDRESS FSS
RETURN

PORTMARKET:
   PORTLINE1=''
   PORTLINE2=''
   PORTLINE3=''
   SELLING_FOOD=1
   SELLING_EQUIP=0
   SELLING_MATL=0
   IF TEQUIP>TFOOD THEN
      DO
         SELLING_FOOD=0
         SELLING_EQUIP=1
      END
   IF (TMATL>TFOOD) & (TMATL>TEQUIP) THEN
      DO
         SELLING_MATL=1
         SELLING_FOOD=0
         SELLING_EQUIP=0
      END
   IF SELLING_FOOD=1 THEN
      PORTLINE1='     Food:  '||STRIP(TFOOD)||' (Selling)'
   ELSE
      PORTLINE1='     Food:  '||TFOOD

   IF SELLING_EQUIP=1 THEN
      PORTLINE2='Equipment:  '||STRIP(TEQUIP)||' (Selling)'
   ELSE
      PORTLINE2='Equipment:  '||TEQUIP

   IF SELLING_MATL=1 THEN
      PORTLINE3=' Material:  '||STRIP(TMATL)||' (Selling)'
   ELSE
      PORTLINE3=' Material:  '||TMATL

return

MAKECLAIM:
ADDRESS FSS
CALL FSSCLOSE
CALL FSSINIT
CALL FSSTITLE 'CLAIM THIS SYSTEM',#PROT
CALL FSSTEXT 'You are about to claim this system as your own.',4,1,,#prot+#green
CALL FSSTEXT 'If a sector is already claimed by somebody else, you cannot',6,1,,#prot+#green
CALL FSSTEXT 'claim it yourself.  Unclaimed sectors in this system will',7,1,,#prot+#green
CALL FSSTEXT 'be registerd to you.',8,1,,#prot+#green
CALL FSSTEXT 'What are you going to name this system?',10,1,,#prot+#green
CALL FSSFIELD 'ZSYSNAME',10,41,30,#YELLOW+#USCORE,''
CALL FSSCURSOR 'ZSYSNAME'
CALL FSSTEXT '<PFK03> CANCEL  <ENTER> Register claim',24,1,,#prot+#white
DO FOREVER
   RKEY=FSSREFRESH()
   IF RKEY=#PFK03 THEN LEAVE
   NEWSYSNAME=FSSFGET('ZSYSNAME')
   IF STRIP(ZSYSNAME)='' THEN
      DO
         CALL FSSZERRSM 'PROVIDE A NAME'
         ITERATE
      END

   IF RKEY=#ENTER THEN
      DO
        CALL CLAIMSYSTEM
        LEAVE
      END
END
CALL FSSCLOSE
RETURN

CLAIMSYSTEM:
/* CLAIMS ALL SECTORS IN TRADING LANES */
/* IF A SECTOR IS ALREADY CLAIMED, THE */
/* CLAIM FOR _THAT_ SECTOR WILL BE DENIED */
DROP EXITS.
CALL SPLIT(GETEXITS(),'EXITS.')
/* ADD THE CURRENT SECTOR TO THE LIST */
EXCOUNT=EXITS.0+1
EXITS.EXCOUNT=SECTID
EXITS.0=EXCOUNT
NUMBEXITS=EXITS.0
/* MOVE THE CURRENT SECTOR INTO STORAGE */
SECTORHOLD=SETRECORD('SECTOR')
DO I=1 TO EXITS.0
   CALL READSECTOR(EXITS.I)
   SECID=SECTID
   /* FIX A PREVIOUS ISSUE */
   IF SUBSTR(OWNER,1,3)='PLY' THEN OWNER=''
   IF STRIP(OWNER)='0' THEN OWNER=''
   if STRIP(OWNER)<>UID THEN
      DO
         IF STRIP(OWNER)<>'' THEN
            DO
              ERRMSG='Unable to register some or all of your claims.'
              ITERATE
            END
      END
   OWNER=UID
   SYSNAME=NEWSYSNAME
   CALL WRITESECTOR
END
/* PUT THE CURRENT SECTOR BACK */
CALL SPLITRECORD 'SECTOR',SECTORHOLD
CURSEC=SECTID
RETURN

RIGHTADJ:
   arg val,len
   val=strip(val)
   if length(val)>=len then return val
   temp=copies(' ',len)
   pad=(len-length(val))
   temp=overlay(val,temp,pad)
   return temp

MILLIS:
 RETURN RIGHT(TIME('LONG'),6)