! ***********************************************************************
! ************************  APM DATABASE PROGRAM  ***********************
! ************************      Gavin Shearer     ***********************
! ************************  Version 1.1 27/09/85  ***********************
! ***********************************************************************

%include "inc:util.imp"                    {extra functions, e.g. to upper}
%include "vtlib.imp"                       {screen splitting routines}
                                           {note it is a customised version}
%begin

! format of the record which holds information about an APM system
%record %format sysf(%string (8) sname     {short name} , 
                     %string (32) lname    {long name} , 
                     %byte pos             {in/on/at, room} ,
                     %string (8) owner     {short name of owner} ,
                     %string (8) location  {where it is} ,
                     %integer tar head     {head of target peripherals} ,
                     %integer act head     {head of actual peripherals} )

! format of the record which holds information on the peripherals of a system
%record %format perf(%integer type         {indexes array for type of} ,
                                           {peripheral and drawing no.}
                     %integer ser          {serial no.} ,
                     %string (2) rev       {revision code} ,
                     %integer target       {target system} ,
                     %integer actual       {actual system in} ,
                     %integer batch        {batch it belongs to} ,
                     %byte status          {status of the peripheral} ,
                     %integer history      {index to history array} ,
                     %integer next tar     {next target peripheral in system} ,
                     %integer next act     {next actual peripheral} ,
                     %integer dep          {dependent information} )

! format of record which contains the history of a peripheral
%record %format hisf(%string(255)text      {holds the text} ,
                     %integer next         {continuation no., if necc} )

%constant %integer extra sys = 20          {no. of extra system records in array},
                   extra per = 40          {no. of extra peripheral records} ,
                   extra his = 40          {no. of extra history records} ,
                   top rows  = 17          {no of rows in top screen} ,
                   batch max = top rows-4  {maximum no. of batch codes to show},
                   no types  = 26          {the number of peripheral types} ,
                   no stati  = 11          {the number of different stati}  ,
                   text max  = 255*4       {amount of history entered at on time} ,
                   case type = 11          {type number of the case},
                   esc       = 27          {the escape character}

%conststring (31) %array stat(1:no stati) = %c
"Working in own system",
"Working, but not in own system",
"Awaiting repair",
"Awaiting construction",
"Awaiting assembly",
"Awaiting board",
"Awaiting components",
"Awaiting socketing",
"Awaiting population",
"Awaiting testing",
"Awaiting installation"


%conststring (26) %array type(1:no types) = %c
{1} "0.5Mb memory board",
{2} "68010 processor board",
{3} "8MHz processor board",
{4} "10MHz processor board",
{5} "2MHz ethernet board",
{6} "10MHz ethernet board",
{7} "Level 1 graphics board",
{8} "Level 1.5 graphics board",
{9} "?MHz processor board",
{10} "Level 2 graphics board",
{11} "Case",
{12} "2.0Mb memory board",
{13} "Mouse controller",
{14} "N???",
{15} "O???",
{16} "Laser printer controller",
{17} "QSART board",
{18} "RTS interface board",
{19} "Special board",
{20} "T???",
{21} "U???",
{22} "V???",
{23} "W???",
{24} "MIT graphics monitor",
{25} "Unknown monitor",
{26} "Twin floppy-disk drive"

%constant %string(6) %array detname (1:3) = %c
"Brief","Normal","Full"

%constinteger %array draw (1:notypes) = %c
{1} 519,
{2} 273,
{3} 279,
{4} 899,
{5} 523,
{6} 290,
{7} 517,
{8} 816,
{9} 666,
{10} 667,
{11} 668,
{12} 579,
{13} 111,
{14} 121,
{15} 141,
{16} 131,
{17} 434,
{18} 520,
{19} 567,
{20} 900,
{21} 201,
{22} 222,
{23} 713,
{24} 537,
{25} 309,
{26} 707

%string(1) ff=tostring(12)

%string(100) dashes=tostring(nl)."---------------------------------". %c
                   "---------------------------------------------". %c
                   tostring(nl). tostring(nl),
                   equals=tostring(nl)."=================================". %c
                   "=============================================". %c
                   tostring(nl).tostring(nl)

%integer detail=2,                         {set to NORMAL detail initially}
         screen=1,                         {set to 1 if query results -> screen}
         file=0,                           {set to 1 if query results -> file}
         report on=1,                      {set to 1 if to report no. in a group}
         rec sep no=1,                     {initial option no. of rec sep}
         res sep no=2                      {initial option no. of res sep}

%string(30) outfile=""                     {file where output is to be sent}
%string(100) rec sep=dashes, res sep=equals{initial separator strings}

%on %event 14 %start                       {signalled to reload the data file}
%finish
%begin                                     {goes here if have to reload system}
%integer sys limit,                        {size to declare sys array to}
         per limit,                        {size to declare per array to}
         his limit,                        {size to declare his array to}
         sys len,                          {length of sys array used}
         per len,                          {length of per array used}
         his len,                          {length of his array used}
         free sys,                         {head of free system record list}
         free per,                         {head of free peripheral record list}
         free his,                         {head of free history record list}
         batch len,                        {no of batch codes to display}
         sys full=0,                       {set to 1 when system array is full}
         per full=0,                       {set to 1 when peripheral array full}
         his full=0,                       {set to 1 when history array full}
         updating,                         {set to 1 when updating}
         changed=0,                        {set to 1 when database data changed}
         sig again=0                       {1 when have to signal event again}

%integer %array batch list (1:batch max)   {holds the last lot of batch numbers}

%record(wininfo) top                       {holds info about top part of screen}
%record(wininfo) bottom                    {holds info about bottom part}


open input (1,"db.dat")                    {file where data is stored}
select input (1)

read (sys limit)
read (per limit)
read (his limit)

! array to hold system information
%record (sysf) %array sys (1:sys limit)
%integer %array sys sort (1:sys limit), sys comp(1:sys limit)

! array to hold peripheral information
%record (perf) %array per (1:per limit)
%integer %array per sort (1:per limit)

! array to hold history of peripherals
%record (hisf) %array his (1:his limit)


! returns %true if the type is an ethernet board
%predicate ethernet (%integer type)
   %true %if type=5 %or type=6
   %false
%end

! returns %true if the type is a processor
%predicate processor(%integer type)
   %true %if type=2 %or type=3 %or type=4 %or type=9
   %false
%end

! function to convert a hex string into an integer
%integerfn hex(%string (*) %name s)
   %integer i,no,a
   no=0
   %result=-1 %if s=""
   to upper (s)
   %for i=1,1,length(s) %cycle
      a=charno(s,i); a=a-'0'
      a=a-7 %if a>9
      %result=-1 %unless 0<=a<=15
      no=no<<4+a
   %repeat
   %result=no
%end

! function to convert an integer into a hex string
%string(8) %function itoh(%integer x)
%string(8) s=""
%integer y
   %cycle
      y=rem(x,16)
      %if y>9 %then y=y+7
      y=y+'0'
      s=tostring(y).s
      x=x//16
   %repeat %until x=0
   %if rem(length(s),2)=1 %then s="0".s       {make no. of digits even}
   %result=s
%end

%routine set top   {sets printing from now on to go to top part of screen}
  %if win_top#0 %then bottom=win %and win=top
%end

%routine set bot   {sets printing from now on to go to bottom half}
  %if win_top=0 %then top=win %and win=bottom
%end

%routine set screens {initialises the two screens and draws a line between them}
%integer i
  setvideomode(screenmode)
  set frame (0,top rows,0,vdu_cols)
  set mode(0)
  set shade(0)
  top=win
  set frame (top rows+1,vdu_rows-top rows-1,0,vdu_cols)
  vt at (0,0)
  bottom=win
  win=vdu
  clear frame
  vt at (top rows,0)
  printsymbol('-') %for i=1,1,vdu_cols
  win=top
%end

!routine to print a title in the centre of an 80 columns
%routine printcentre(%string(80) title)
%integer i
   printstring(" ") %for i=1,1,(80-length(title))//2
   printstring(title)
%end

!routine to send to the file the record separator
%routine write rec sep
  %if updating=1 %or file=0 %then %return
  select output(3)
  printstring(rec sep)
  select output(0)
%end

!routine to send to the file the result separator
%routine write res sep
  %if updating=1 %or file=0 %then %return
  select output(3)
  printstring(res sep)
  select output(0)
%end

!routine to write a heading to a file only
%routine write file(%string(80) heading)
   %if file=0 %or updating=1 %then %return
   select output(3)
   printcentre(heading);newline
   printstring(rec sep)
   select output(0)
%end

! sends writing to go to the screen, a file, or both
%routine writer(%integer x,p)
   %if updating=1 %then write(x,p) %and %return    {output only to screen}
   %if screen=1 %then write(x,p)
   %if file=1 %then %start
      select output(3)
      write(x,p)
      select output(0)
   %finish
%end

! sends strings to the screen, a file, or both
%routine printr(%string(255) s)
   %if updating=1 %then printstring(s) %and %return    {output only to screen)
   %if screen=1 %then printstring(s)
   %if file=1 %then %start
      select output(3)
      print string(s)
      select output(0)
   %finish
%end

!routine to handle escape key presses. Esc'A' is cursor up meaning that
!the program has to go back to the last menu. Esc'H' is home meaning
!that the program has to go to the main menu.
%routine escape(%byte line)
%byte ch
   readsymbol(ch)
   %if ch='O' %or ch='[' %then %start    {sequence used by WYSE}
      set video mode(screenmode+noecho+single)
      readsymbol(ch)
   %finish
   set video mode(screenmode)     {put back to normal}
   newline %if line=1
   %if ch='A' %then %signal %event 13
   %if ch='H' %then %signal %event 15
%end

%routine %spec output options

!sends a newline to the screen, and stops if the screen is full
!if a key other than 'o' is pressed the top screen is cleared and
!writing is continued. If 'o' is pressed then the program goes to
!the output option menu, so that the user can change the output.
%routine newlinev
%byte ch
%on %event 13 %start
   %if sig again=1 %then sig again=0 %and %signal %event 13
   set top; clear frame; %return
%finish
   newline
   %if win_row=top rows-1 %then %start
      set video mode(screenmode+single+noecho);set shade(1)
      printstring("More? (O for Output Options)")
      sig again=1
      ch=readsymbol
      set shade(0)
      %if ch=esc %then escape(0)
      set video mode(screenmode)
      sig again=0
      %if ch='o' %or ch='O' %then output options
      clear frame
   %finish
%end

! writes of newlines to the screen, a file, or both
%routine newliner
   %if updating=1 %then newline %and %return
   %if screen=1 %then newlinev
   %if file=1 %then %start
      select output(3)
      newline
      select output(0)
   %finish
%end

! clears the screen and writes a heading, if output is going to a file
! and not to the screen then the user is reminded of this
%routine write screen(%string(80)heading)
   set top;clear frame
   printcentre(heading);newline
   %if screen=1 %or file=0 %then newline %and %return
   printcentre("THE OUTPUT IS BEING SENT". %c
   " TO FILE '".outfile."'")
%end

!routine to write the screen record separator
%routine screen rec sep
   %if screen=0 %then %return
   newlinev
   printstring("--------------------------------------------")
   newlinev;newlinev
%end

! reads a string, ignoring leading spaces
%string (255) %function readstring (%string (255) prompt,%byte size)
%string(255)answer
%byte ch
   set bot
   %cycle
      printstring(prompt)
      answer=""
      %cycle
         readsymbol(ch)
         %exit %if ch=nl %or ch=esc
         answer=answer.tostring(ch)
      %repeat
      %if ch=esc %then escape(1) %else newline
      %while length(answer)>0 %and charno(answer,1)=' ' %cycle
         answer=substring(answer,2,length(answer))
      %repeat
      %if length(answer)<=size %then %result=answer
      printstring("Please type in at most") ; write(size,1)
      printstring(" characters");newline
   %repeat
%end

! reads a string, ignoring leading spaces, and converts the letters into capitals
%string (255) %function readcapstr (%string (255) prompt,%byte size)
%string (255) answer
   answer=readstring(prompt,size)
   to upper(answer)
   %result=answer
%end

!reads in a string and checks that the first letters are among the
!characters in the second string, returning the first character of the first
%byte %function read letter(%string (255) prompt,letters)
%string (255) input
%byte ch,len,i
   len=length(letters)
   %cycle
      input=readcapstr(prompt,255)
      %if input="" %then %result=charno(letters,1)
      ch=charno(input,1)
      %for i=1,1,len %cycle
         %if charno(letters,i)=ch %then %result=ch
      %repeat
      %if len=1 %then printstring("Please type ".letters) %c
      %else %start
         printstring("Please type ")
         %for i=1,1,len-1 %cycle
           printsymbol(charno(letters,i))
           printstring(", ")
         %repeat
         printstring("or ");printsymbol(char no(letters,len))
      %finish
      new line
   %repeat
%end
        
! asks the users for (Y)es or (N)o and returns true if the reply was yes
! but returns false if the reply was no
%predicate yes(%string (255) prompt)
%byte ch
   ch=read letter (prompt." (Y/N) ","YN")
   %if ch='Y' %then %true %else %false
%end

! Reads in a number. If characters are input which are not digits
! it prompts for a number again
%integer %function get no(%string(255) prompt)
%string(255) answer
%integer no, i, digit, minus
  %on %event 1 %start   {signalled if too large a number is input}
      print string ("That number was too large");new Line
  %finish
  again:
  no=0 ; minus=0
  answer=readstring(prompt,255)
  %if charno(answer,1)='-' %then %start
     minus=1
     answer=substring(answer,2,length(answer))
  %else
     %if charno(answer,1)='+' %then answer=substring(answer,2,length(answer))
  %finish
  %if answer="" %then printstring("Type a number, please") %and %c
  newline %and -> again
  %for i=1,1,length(answer) %cycle
      digit=charno(answer,i)
      %exit %if digit=' '
      digit=digit-48
      %if %not 0<=digit<=9 %then printstring("Type a number, please") %c
      %and newline %and -> again
      no=no*10+digit
  %repeat
  %if minus=1 %then no=-no
  %result=no
%end

! asks the user for a number in the range 1 to high (ensuring it gets it)
! and returns the value. This function is used by menus.
%integerfunction get menu no(%integer high)
%integer answer
  %cycle
     answer=get no ("Selection ")
     %result = answer %if answer >= 0 %and answer <= high
     print string("Type a number in the range 1 to")
     write(high,1);print string(", please");newline
  %repeat
%end

%routine load data   {loads the data about the APMs from the file}
%integer i,j
  skipsymbol  {ignore the NL character left after read}
  ! read in the last lot of batch codes
  j=addr(batch list)
  readsymbol(byteinteger(i)) %for i=j,1,j+size of(batch list(1)) * batch len -1

  ! read in the system array
  j=addr(sys)
  readsymbol(byteinteger(i)) %for i=j,1,j+size of(sys(1)) * sys len -1

  ! read in the peripheral array
  j=addr(per)
  readsymbol(byteinteger(i)) %for i=j,1,j+size of(per(1)) * per len -1

  ! read in the history array
  j=addr(his)
  readsymbol(byteinteger(i)) %for i=j,1,j+size of(his(1)) * his len -1
  select input (0)
%end

%routine save data   {saves data about the APMs to the file}
%integer i,j
  copy("db.dat.old","db.dat.older")
  copy("db.dat","db.dat.old")
  open output (2,"db.dat")
  select output (2)
  ! write out important variables
  write (sys len+extra sys,1)
  write (per len+extra per,1)
  write (his len+extra his,1) ; New Line
  write (sys len,1)
  write (per len,1)
  write (his len,1) ; New Line
  write (free sys,1)
  write (free per,1)
  write (free his,1); New Line
  write (batch len,1); New Line

  ! write out the batch array
  j=addr (batch list)
  printsymbol(byteinteger(i)) %for i=j,1,j+size of(batch list(1)) * batch len -1

  ! write out the system array
  j=addr(sys)
  printsymbol(byteinteger(i)) %for i=j,1,j+size of(sys(1)) * sys len -1

  ! write out the peripheral array
  j=addr(per)
  printsymbol(byteinteger(i)) %for i=j,1,j+size of(per(1)) * per len -1

  ! write out the history array
  j=addr(his)
  printsymbol(byteinteger(i)) %for i=j,1,j+size of(his(1)) * his len -1

  close output
  select output (0)
%end

! this routine is called when the program has run out of space. It asks
! the user if he wants to reload the data or go to the main menu.
! Reloading data is done by writing out the file, redimensioning the 
! arrays, and then reading the file in again
%routine reload(%string(30) reason)
%integer no
   set top;clear frame
   printstring("I have run out of ".reason." space, so I can either :-"); newlines (2)
   printstring("1)  Get more space by updating the database file and". %c
   " reloading it");newlines (2)
   printstring("2)  Return to the main menu, with no more space");newline
   printstring("    (If you have changed your mind about making more ". %c
   reason." entries)");newline
   no=get menu no(2)
   %if no=2 %then %signal %event 15

   save data
   %signal %event 14
%end

! returns true if first short name is greater than the second,
! used by the sort routine
%predicate gtr sname(%integer j,k,%integer %array %name data)
   %true %if sys(data(j))_sname>sys(data(k))_sname
   %false
%end

! returns true if first location is greater than the second,
! used by the sort routine
%predicate gtr location(%integer j,k,%integer %array %name data)
   %true %if sys(data(j))_location>sys(data(k))_location
   %false
%end

! returns true if data at position j is greater than data at position k
%predicate gtr(%integer j,k,%integer %array %name data)
   %true %if data(j)>data(k)
   %false
%end

! returns true if type and serial number are greater
%predicate gtr type(%integer j,k,%integer %array %name data)
   %true %if per(data(j))_type>per(data(k))_type
   %false %if per(data(j))_type<per(data(k))_type
   %true %if per(data(j))_ser>per(data(k))_ser
   %false
%end

! returns true if status, then type and serial number are greater
%predicate gtr status(%integer j,k,%integer %array %name data)
   %true %if per(data(j))_status>per(data(k))_status
   %false %if per(data(j))_status<per(data(k))_status
   %if gtr type(j,k,data) %then %true
   %false
%end

! returns true if batch no, then type and serial number are greater
%predicate gtr batch(%integer j,k,%integer %array %name data)
   %true %if per(data(j))_batch>per(data(k))_batch
   %false %if per(data(j))_batch<per(data(k))_batch
   %if gtr type(j,k,data) %then %true
   %false
%end

! copies the serial number of the first peripheral of the required type
! that belongs to each system into the 'comp' array, which is used in sorting
%routine copy tar(%integer type no)
%integer i,pos
   %for i=1,1,sys len %cycle
      pos=sys(i)_tar head
      pos=per(pos)_next tar %while pos#0 %and per(pos)_type#type no
      %if pos=0 %then sys comp(i)=-1 %else sys comp(i)=per(pos)_ser
   %repeat
%end

! copies the serial number of the first peripheral of the required type
! that is in each system into the 'comp' array, which is used in sorting
%routine copy act(%integer type no)
%integer i,pos
   %for i=1,1,sys len %cycle
      pos=sys(i)_act head
      pos=per(pos)_next act %while pos#0 %and per(pos)_type#type no
      %if pos=0 %then sys comp(i)=-1 %else sys comp(i)=per(pos)_ser
   %repeat
%end

! copies the station number of the first ethernet device belonging to
! each system into the 'comp' array.
%routine copy tar station
%integer i,pos
   %for i=1,1,sys len %cycle
      pos=sys(i)_tar head
      pos=per(pos)_next tar %while pos#0 %and %not ethernet(per(pos)_type)
      %if pos=0 %then sys comp(i)=-1 %else sys comp(i)=per(pos)_dep
   %repeat
%end

! as above but for the system it is in.
%routine copy act station
%integer i,pos
   %for i=1,1,sys len %cycle
      pos=sys(i)_act head
      pos=per(pos)_next act %while pos#0 %and %not ethernet(per(pos)_type)
      %if pos=0 %then sys comp(i)=-1 %else sys comp(i)=per(pos)_dep
   %repeat
%end

! returns true if the first value in sys comp is greater than the second
! used by the sort routine
%predicate gtr sys comp(%integer j,k,%integer %array %name data)
   %true %if sys comp(data(j))>sys comp(data(k))
   %false
%end

! this is the sort routine of the program. It is called by all routines
! wanting something sorted. The predicate which determines if one
! item is bigger than another is passed as a parameter, making the
! routine very flexible as it can sort items of any type
%routine sort(%integerarrayname data, %integer entries, 
              %predicate greater(%integer j,k,%integer %array %name data))
   !Sort array data, throughout its length
    %integer i,j,k,l,n1, temp
      ! the main sort routine only works for 4 items or more, so need
      ! special cases for 1,2, and 3 items
      %if entries<=1 %then %return
      %if entries=2 %then %start
         %if greater(1,2,data) %then temp=data(1) %and data(1)=data(2) %and %c
         data(2)=temp
         %return
      %finish
      %if entries=3 %then %start
         %if greater(1,2,data) %then temp=data(1) %and data(1)=data(2) %and %c
         data(2)=temp
         %if greater(2,3,data) %then temp=data(2) %and data(2)=data(3) %and %c
         data(3)=temp
         %if greater(1,2,data) %then temp=data(1) %and data(1)=data(2) %and %c
         data(2)=temp
         %return
      %finish
      n1 = 1
      l = entries - 2
      n1 = 2*n1 %while n1<l
      l = 0
       %while n1 > 1 %cycle
         n1 = n1 // 2
         i = l
          %cycle
            i = i+1
            j = i+n1
             %exitif j > entries
            k = i
             %cycle
                %exit %if greater(j,k,data)
                temp = data(j); data(j) = data(k); data(k)= temp
               j = k
               k = k - n1
             %repeatuntil k < 1
          %repeat
       %repeat
    %end

! this function list all types with there drawing numbers and
! gets the user to choose one of them, returning the number
! of the one chosen. It is written so that it will still work
! if there are too many types for the screen by enabling the user
! to switch to the next lot of options.
%integer %function list types (%string (80) heading)
%integer i,j,k,h,l,no
%constant %integer no show=(top rows-4)*2
  %if per full=1 %then reload("peripheral")
  i=1
  j=no types
  %cycle
     %if j>no show %then k=no show %else k=j
     j=j-k
     h=k//2
     set top
     clear frame
     printcentre(heading);newline
     spaces(16) ; printstring ("Peripherals listed by ")
     set shade(1);printstring("drawing no.")
     set shade(0);printstring(" and type"); newline
     spaces(16) ; printstring ("------------------------------------------")
     newline
     %for l=i,1,h+i-1 %cycle
        write(l-i+1,2);  printstring(") ");set shade(1)
        write(draw(l),4);setshade(0)
        printstring(" ".type(l));newline
     %repeat
     %for l=h+i,1,k+i-1 %cycle
        vt at(3+l-i-h,40);write(l-i+1,2)
        printstring(") ");set shade(1)
        write(draw(l),4);setshade(0)
        printstring(" ".type(l));newline
     %repeat
     %if j#0 %then %start
        vt at(top rows-1,13);write(k+1,2)
        printstring(") For more peripherals and drawing numbers")     
        set bot
        no=get menu no(k+1)
        %result=no+i-1 %unless no=k+1
        i=i+k
     %else
        %if no types>no show %then %start
          vt at(top rows-1,10);write(k+1,2)
          printstring(") To go back to the first screen of peripherals")
          set bot
          no=get menu no(k+1)
          %if no=k+1 %then i=1 %and j=no types %else %result=no+i-1
        %else
          set bot
          no=get menu no(k)
          %result=no+i-1
        %finish
     %finish
  %repeat
%end

! writes out all the serial numbers of a certain type
%routine list ser(%integer type no,%string(255)heading)
%integer i,j
%string(255) s
   set top; clear frame; printcentre(heading);newline
   j=0
   %for i=1,1,per len %cycle
      %if per(i)_status#0 %and per(i)_type=type no %then %c
      j=j+1 %and per sort(j)=per(i)_ser
   %repeat
   sort(per sort,j,gtr)
   s=""
   %for i=1,1,j %cycle
      %if length (s)<75 %then s=s.itos(per sort(i),1) %else %c
      printstring(s) %and newline %and s=itos(per sort(i),1)
   %repeat
   printstring(s);newline
%end

! checks if a serial no. exists, returning the position in the array if
! it does,and 0 if it doesn't
%integer %function ser exists (%integer ser no,type no)
%integer i
   %for i=1,1,per len %cycle
      %if per(i)_status#0 %and per(i)_type=type no %c
      %and per(i)_ser=ser no %then %result=i
   %repeat
   %result=0
%end

! checks if a station number exists, returning the position in the array if
! it does, and 0 if it doesn't
%integer %function station exists (%integer stat)
%integer i
   %for i=1,1,per len %cycle
      %if per(i)_status#0 %and ethernet(per(i)_type) %c
      %and per(i)_dep=stat %then %result=i
   %repeat
   %result=0
%end

! checks if a short name exists, returning the position in the array if
! it does, and 0 if it doesn't
%integer %function sname exists (%string(8) sname)
%integer i
   %for i=1,1,sys len %cycle
      %if sys(i)_pos#255 %and sys(i)_sname=sname %then %result=i
   %repeat
   %result=0
%end

! checks if a location exists starting from pos to the end of the array,
! returning the position in the array if does, otherwise 0
%integer %function location exists(%string(8) location,%integer pos)
%integer i
   %for i=pos,1,sys len %cycle
      %if sys(i)_pos#255 %and sys(i)_location=location %then %result=i
   %repeat
   %result=0
%end

! function to get a new serial number for a peripheral of a certain type
%integer %function get ser(%integer type no)
%integer ser no
   in ser:
   ser no=get no("Serial number ")
   %if ser exists(ser no,type no)#0 %then %start
      print string("That serial number already exists. "); newline
      ->in ser
   %finish
   %result=ser no
%end

! function to get the name of the target system of a peripheral
%integer %function  get target(%string(255) prompt)
%string (8) target
%integer target pos
   in target:
   target=readcapstr(prompt,8)
   target pos=sname exists(target)
   %if target pos=0 %then %start      {0 means the sname doesn't exist}
      print string("That system name does not exist");newline
      -> in target
   %finish
   %result=target pos
%end

! function to get the name of the actual system of a peripheral
%integer %function get actual(%integer target pos,%string(255) prompt)
%string(8) actual
%integer actual pos
   in actual:
   actual=readcapstr(prompt.tostring(nl). %c
   "(or press <RETURN> if same as belongs) ",8)
   %if actual="" %then actual pos=target pos %else %start
      actual pos=sname exists(actual)
      %if actual pos=0 %then %start
         printstring("That system name does not exist");newline
         -> in actual
      %finish
   %finish
   %result=actual pos
%end

! function to get the batch number a peripheral has. The last lot of
! batch numbers are printed on the screen and the user can either
! choose one of these or select the option to type in his own
%integer %function get batch (%string (80) heading)
%integer i,no
   %if batchlen=0 %then -> no batch
   set top
   clear frame
   print centre (heading);newline
   spaces (20); printstring("List of the last");write(batch len,1)
   printstring(" batch numbers") ; newline
   spaces (20); printstring("--------------------------------")
   %if batchlen>9 %then printstring("-")
   new line
   %for i=1,1,batch len %cycle
      write(i,2);printstring(") ");write(batch list(i),1);newline
   %repeat
   write(batch len+1,2);printstring(")  To type in a batch number")
   set bot
   no=get menu no(batch len+1)
   %result=batch list(no) %if no#batch len+1
   no batch:
   set top
   clear frame
   print centre (heading);newline
   set bot
   %result=get no("Batch number ")
%end

! routine to update the list of the last lot of batch numbers
%routine update batch list(%integer no)
%integer i
   %for i=1,1,batch len %cycle
      %if batch list(i)=no %then %return
   %repeat
   %if batch len#batch max %then %start
      batch len=batch len+1
      batch list(batch len)=no
   %else
      batch list(i-1)=batch list(i) %for i=2,1,batch max
      batch list(i)=no
   %finish
%end

! routine to get the status of a peripheral. All the possible states
! a peripheral can be in are written on the screen and the user
! chooses which one he wants
%integer %function get status (%string(80) heading)
%integer i
   set top
   clear frame
   print centre(heading);new line
   print centre("List of states a peripheral can be in"); newline
   print centre("-------------------------------------"); newline
   %for i=1,1,no stati %cycle
      write(i,2);printstring(")  ".stat(i)); newline
   %repeat
   set bot
   %result=get menu no(no stati)
%end

! function to get the station number of an ethernet, typed in in hex
%integer %function get station(%string(80) heading)
%string (7) hex no
%integer no,exists
   set top
   clear frame
   print centre(heading);new line
   set bot
   %cycle
      hex no=readstring("Station number (Hex) ",7)
      no=hex(hex no)
      exists= station exists(no)
      %result=no %if no#-1 %and exists=0
      %if no=-1 %then %c
      printstring("That was not hex, try again") %and new line %else %c
         printstring("That station number is already in use");newline
   %repeat
%end

! routine to write out the long name of a system using lname and pos,
! which contains condensed information on whether it is on, at, in, etc.
%routine write lname(%string(32) lname,%byte pos)
   %if pos&2 #0 %then printr ("On ")
   %if pos&4 #0 %then printr ("At ")
   %if pos&8 #0 %then printr ("In ")
   %if pos&16#0 %then %start
      %if pos&14#0 %then printr ("the ") %else printr("The ")
   %finish
   printr(lname)
   %if pos&1#0 %then printr ("'s room")
%end

! routine to write out peripheral information in NORMAL detail
%routine write per2(%record(perf) p)
   set top
   printr("                    Peripheral Record"); newliner
   printr("                    -----------------"); newliner
   newliner
   printr("Type of peripheral       : ");printr(type(p_type));newliner
   printr("Drawing number           :");writer(draw(p_type),1);newliner
   printr("Serial number            :");writer(p_ser,1);newliner
   printr("Revision code            : ");printr(p_rev);newliner
   printr("System it belongs to     : ");printr(sys(p_target)_sname);newliner
   printr("System it is in now      : ");printr(sys(p_actual)_sname);newliner
   printr("Batch it is in           :");writer(p_batch,1);newliner
   printr("Status of peripheral     : ");printr(stat(p_status));newliner
   %if ethernet(p_type) %then %start
   printr("Ethernet station no (hex): ".itoh(p_dep));newliner; %finish
   %if processor(p_type) %and p_dep#0 %then %start
   printr("Daughter board serial no.: ".itos(p_dep,0));newliner; %finish
   printr("Has it got any history ? : ")
   %if p_history=0 %then printr("No") %else printr("Yes");newliner
   write rec sep
%end

! routine to print the history of a peripheral
%routine print history (%integer i)
%string (255) s,t
   set top
   %while i#0 %cycle
     s=his(i)_text
     printr(" ".t) %and newliner %while s->t.(tostring(nl)).s
     i=his(i)_next
   %repeat
%end

%routine write sys of per(%record(sysf) s)
   printr("   Short name    - ");printr(s_sname);newliner
   printr("   Long name     - ");write lname(s_lname,s_pos);newliner
   printr("   Owner         - ");printr(s_owner);newliner
   printr("   Location      - ");printr(s_location);newliner
%end

! routine to write a peripheral record in FULL detail
%routine write per3(%record(perf) p)
   set top
   printr("                    Peripheral Record"); newliner
   printr("                    -----------------"); newliner
   newliner
   printr("Type of peripheral       : ");printr(type(p_type));newliner
   printr("Drawing number           : ");writer(draw(p_type),0);newliner
   printr("Serial number            : ");writer(p_ser,0);newliner
   printr("Revision code            : ");printr(p_rev);newliner
   printr("System it belongs to     :-");newliner
   write sys of per(sys(p_target))
   printr("System it is in          :-");newliner
   write sys of per(sys(p_actual))
   printr("Batch it is in           : ");writer(p_batch,0);newliner
   printr("Status of peripheral     : ");printr(stat(p_status));newliner
   %if ethernet(p_type) %then %start
   printr("Ethernet station no (hex): ".itoh(p_dep));newliner; %finish
   %if processor(p_type) %and p_dep#0 %then %start
   printr("Daughter board serial no.: ".itos(p_dep,0));newliner;%finish
   printr("History                  : ")
   %if p_history=0 %then printr("It has not got any") %and newliner %c
   %else newliner %and print history(p_history)
   write rec sep
%end

! routine to write a peripheral record in the current detail
%routine write per(%record (perf) p)
%integer i
   %if detail=1 %then %start                     {brief detail}
      set top
      printr(type(p_type))
      printr(" ") %for i=1,1,32-length(type(p_type))
      printr(itos(draw(p_type),0)."/".itos(p_ser,0)."/".p_rev)
      newliner
      %return
   %finish
   %if detail=2 %then write per2(p) %and %return  {normal detail}
   write per3(p)                                  {full detail}
%end

! routine to write a system record in BRIEF detail
%routine write sys1 (%record(sysf) s)
   set top
   printr("                    System Record");newliner
   printr("                    -------------");newliner
   newliner
   printr("Short name     : ");printr(s_sname);newliner
   printr("Long name      : ");write lname(s_lname,s_pos);newliner
   printr("Owner          : ");printr(s_owner);newliner
   printr("Location       : ");printr(s_location);newliner
%end

! routine to write a system record in NORMAL detail
%routine write sys2(%record(sysf) s)
%integer actual pos,target pos,i
%string(80) st
   write sys1(s)
   newliner
   printr("    Peripherals Belonging                  Peripherals In Now");newliner
   printr("    ~~~~~~~~~~~~~~~~~~~~~                  ~~~~~~~~~~~~~~~~~~");newliner
   target pos=s_tar head; actual pos=s_act head
   %while target pos#0 %or actual pos#0 %cycle
      %if target pos=0 %then printr("                                        ") %c
      %else %start              {print and fill with spaces to column 40}
         st=type(per(target pos)_type)." (#".itos(per(target pos)_ser,0).")"
         %if processor(per(target pos)_type) %and per(target pos)_dep#0 %c
         %then st=st." Dau=". itos(per(target pos)_dep,0)
         %if ethernet(per(target pos)_type) %then st=st." Stn=". %c
         itoh(per(target pos)_dep)
         printr(st);printr(" ") %for i=1,1,40-length(st)
         target pos=per(target pos)_next tar
      %finish
      %if actual pos#0 %then %start
         printr(type(per(actual pos)_type)." (#")
         writer(per(actual pos)_ser,0);printr(")")
         %if ethernet(per(actual pos)_type) %then %c
         printr(" Stn=".itoh(per(actual pos)_dep))
         %if processor(per(actual pos)_type) %and per(actual pos)_dep#0 %then %c
         printr(" Dau=") %and writer(per(actual pos)_dep,0)
         actual pos=per(actual pos)_next act
      %finish
      newliner
   %repeat
   write rec sep
%end

%routine write per of sys(%record(perf) p)
   printr("Type of peripheral       : ");printr(type(p_type));newliner
   printr("Drawing number           : ");writer(draw(p_type),0);newliner
   printr("Serial number            : ");writer(p_ser,0);newliner
   printr("Revision code            : ");printr(p_rev);newliner
   printr("Batch it is in           : ");writer(p_batch,0);newliner
   printr("Status of peripheral     : ");printr(stat(p_status));newliner
   %if ethernet(p_type) %then %start
   printr("Ethernet station no (hex): ".itoh(p_dep));newliner; %finish
   %if processor(p_type) %and p_dep#0 %then %start
   printr("Daughter board serial no.: ".itos(p_dep,0));newliner;%finish
   printr("Has it got any history ? : ")
   %if p_history=0 %then printr("No") %else printr("Yes");newliner
   printr("-------------------------------------------");newliner
%end

! routine to write a system record in FULL detail
%routine write sys3(%record (sysf) s)
%integer actual pos,target pos
   writesys1(s);newliner
   printr("                 Peripherals Belonging");newliner
   printr("                 ---------------------");newliner
   target pos=s_tar head
   %while target pos#0 %cycle
      write per of sys(per(target pos))
      target pos=per(target pos)_next tar
   %repeat
   newliner;newliner
   printr("                 Peripherals In Now");newliner
   printr("                 ------------------");newliner
   actual pos=s_act head
   %while actual pos#0 %cycle
      write per of sys(per(actual pos))
      actual pos=per(actual pos)_next act
   %repeat
   write rec sep
%end

! routine to write a system record in current detail
%routine write sys(%record (sysf) s)
  %if detail=1 %then %start
     write sys1(s)                               {brief detail (1)}
     write rec sep
     %return
  %finish
  %if detail=2 %then write sys2(s) %and %return  {normal detail (2)}
  write sys3(s)                                  {full detail (3)}
%end

! routine to get the history of a peripheral
%routine get history(%byte %array %name text,%integer %name pos,%string(80) heading)
%string (255) input
%byte ch,len,i
   %if his full=1 %then reload("history")
   pos=1
   set top
   clear frame
   printcentre(heading)
   vt at (top rows-2,5)
   printstring("Type it in a line at a time, type : at start of line to stop")
   set bot
   clear frame
   %cycle
      printsymbol(' ')
      input=""
      %cycle
         readsymbol(ch)
         input=input.tostring(ch)
      %repeat %until ch=nl
      new line
      %exit %if charno(input,1)=':'
      len=length(input)
      %if pos+len-1>text max %then %start
         new line
         print string("You have entered too much history at once, please enter")
         new line
         print string("the rest of it, starting with the last line entered, by")
         new line
         print string("selecting to append to a peripheral's history")
         new line
         %exit
      %finish
      text(i+pos-1)=charno(input,i) %for i=1,1,len
      pos=pos+len
   %repeat
   pos=pos-1                      {make it index the last character}
%end

! function which returns a position in the peripheral array which is free.
! it is taken of the free list if possible, otherwise the next in the array.
%integer %function get new per
%integer pos
   changed=1                      {set to 1 when database is altered}
                                  {used to indicate whether to write back or not}
   %if free per#0 %then %start    {the free list is not empty}
      pos=free per
      free per=per(free per)_next act
      %if free per=0 %and per len=per limit %then per full=1
      %result=pos
   %else
      per len=per len+1
      %if per len=per limit %then per full=1
      %result=per len
   %finish
%end

! as above, but for the system array
%integer %function get new sys
%integer pos
   changed=1                     {indicates the need to write out file on exit}
   %if free sys#0 %then %start   {the free list is not empty}
      pos=free sys
      free sys=sys(free sys)_act head
      %if free sys=0 %and sys len=sys limit %then sys full=1
      %result=pos
   %else
      sys len=sys len+1
      %if sys len=sys limit %then sys full=1
      %result=sys len
   %finish
%end

! as above, but for the history array
%integer %function get new his
%integer pos
   changed=1                    {need to write the file out when leaving program}
   %if free his#0 %then %start
      pos=free his
      free his=his(free his)_next
      %result=pos
   %else
      his len=his len+1
      %if his len=his limit-3 %then his full=1
      %result=his len
   %finish
%end

%routine delete per(%integer pos) {puts peripheral record on free list}
   changed=1                      {need to write file out when program finished}
   per full=0                     {if it was full, it is no longer}
   per(pos)_status=0              {indication that it is empty}
   per(pos)_next act=free per
   free per=pos
%end

%routine delete sys(%integer pos) {puts system record on free list}
   changed=1
   sys full=0                     {if it was full, it is not any more}
   sys(pos)_pos=255               {indication that it is empty}
   sys(pos)_act head=free sys
   free sys=pos
%end

%routine delete his(%integer pos) {puts the history of a peripheral on free list}
%integer next pos
   changed=1
   %while pos#0 %cycle
      next pos=his(pos)_next      {next part of peripherals history}
      his(pos)_next=free his      {put on free list, next points to next free one}
      free his=pos
      pos=next pos
   %repeat
%end

! routine to put history in the array text into its correct
! postion in the history array
%routine put history(%integer per pos,%byte %array %name text,%integer size)
%integer his pos, index=1 ,i,j,k,l
   changed=1
   his pos=per(per pos)_history
   %if his pos<=0 %then %start
      his pos=get new his 
      per(per pos)_history=his pos
      i=1
   %else
      his pos=his(his pos)_next %while his(his pos)_next#0
      i=length (his(his pos)_text)+1
   %finish
   j=i+size-1
   %cycle
      %if j<=255 %then k=j %else k=255
      j=j-k
      charno(his(his pos)_text,l)=text(index+l-i) %for l=i,1,k
      length(his(his pos)_text)=k
      %if j=0 %then his(his pos)_next=0 %and %return
      l=get new his
      his(his pos)_next=l
      his pos=l
      i=1
      index=index+k-i+1
   %repeat
%end

! adds the peripheral at per pos to the list of target peripherals
! of the system at sys pos
%routine add target(%integer sys pos,per pos)
%integer pos
   changed=1
   %if sys(sys pos)_tar head=0 %then sys(sys pos)_tar head=per pos %else %start
      pos=sys(sys pos)_tar head
      pos=per(pos)_next tar %while per(pos)_next tar#0
      per(pos)_next tar=per pos
   %finish
    per(per pos)_next tar=0
%end

! adds the peripheral at per pos to the list of actual peripherals
! of the system at sys pos
%routine add actual(%integer sys pos,per pos)
%integer pos
   changed=1
   %if sys(sys pos)_act head=0 %then sys(sys pos)_act head=per pos %else %start
      pos=sys(sys pos)_act head
      pos=per(pos)_next act %while per(pos)_next act#0
      per(pos)_next act=per pos
   %finish
   per(per pos)_next act=0
%end

! removes a target peripheral from a system, but doesn't delete it
%routine delete target(%integer sys pos,per pos)
%integer %name pos
   changed=1
   pos==sys(sys pos)_tar head
   pos==per(pos)_next tar %while pos#per pos
   pos=per(pos)_next tar
%end

! removes an actual peripheral from a system, but doesn't delete it
%routine delete actual(%integer sys pos,per pos)
%integer %name pos
   changed=1
   pos==sys(sys pos)_act head
   pos==per(pos)_next act %while pos#per pos
   pos=per(pos)_next act
%end

! gets a long name from the user, and parses it so it puts information
! such as in, at, on etc. into the byte pos
%string(32) %function get lname(%byte %name pos)
%string(255) input
%string(7) st
   %cycle
      input=readstring("Long name ",255)
      pos=0
      st=substring(input,length(input)-6,length(input))
      %if st="'s room" %or st="'s Room" %then %c
      pos=pos!1 %and input=substring(input,1,length(input)-7)
      st=substring(input,1,3)
      %if st="on " %or st="On " %then %c
      pos=pos!2 %and input =substring(input,4,length(input))
      %if st="at " %or st="At " %then %c
      pos=pos!4 %and input=substring(input,4,length(input))
      %if st="in " %or st="In" %then %c
      pos=pos!8 %and input=substring(input,4,length(input))
      st=substring(input,1,4)
      %if st="the " %or st="The " %then %c
      pos=pos!16 %and input=substring(input,5,length(input))
      %if length(input)<=32 %then %result=input
      printstring("The long name is too long, please type a shorter one")
      newline
   %repeat
%end

! returns the short name a user has entered, after ensuring that it is unique
%string (8) %function get sname(%string(255) prompt)
%string(8) sname
   in sname:
   sname=readcapstr(prompt,8)
   %if sname exists(sname)#0 %then %start
      printstring("That short name already exists"); newline
      -> in sname
   %finish
   %result=sname
%end

! routine used to enter the peripherals of a system. The peripherals
! can either be moved from another system, or input as new peripherals
%routine get peripherals(%integer sys pos,targ)
%constant %string(80) heading= %c
"ENTERING DATA FOR A PERIPHERAL OF A NEW SYSTEM"
%record(perf) p=0
%byte hwant=0
%integer size,pos,oldname,perpos
%byte %array text(1:text max)
   again:
   %if targ=1 %then p_target=sys pos %else p_actual=sys pos
   p_type=list types(heading)
   list ser(p_type,heading)
   in ser:
   p_ser=get no("Serial number ")
   per pos =ser exists(p_ser,p_type)
   %if per pos=0 %then %start
      %if %not yes("That is a new serial number, OK ?") %then ->in ser
      set top; clear frame; printcentre(heading) ;new line
      p_rev=readcapstr("Revision code ",2)
      %if targ=1 %then %c
      p_actual=get actual(p_target,"Short name in now ") %c
      %else p_target=get target("Short name it belongs to ")
      p_batch=get batch(heading)
      p_status=get status(heading)
      %if ethernet(p_type) %then p_dep=get station(heading)
      %if processor(p_type) %then %c
      p_dep=get no("Daughter serial number, (0 if it hasn't one) ")
      %if his full=1 %then printstring("YOU CAN'T ENTER ANY HISTORY JUST NOW". %c
      " AS THERE IS NO SPACE FOR IT".tostring(nl)) %and hwant=1 %else %start
         %if yes("Any history ?") %then %c
         get history(text,size,heading) %and p_history=-1
      %finish
      set top; clear frame; printcentre(heading);newline
      write per2(p)
      set bot
      check again:
      %if %not yes("Data entered OK ?") %then %start
         %if yes("Are you sure you want to forget the data ?") %then -> end
         -> check again
      %finish
      pos=get new per
      update batch list(p_batch)
      per(pos)=p
      %if p_history=-1 %then put history(pos,text,size)
      add target(p_target,pos)
      add actual(p_actual,pos)
      %if hwant=1 %then reload("history")
   %else                   {the peripheral already exists}
      %if targ=1 %then oldname=per(per pos)_target %else %c
      oldname=per(per pos)_actual
      newline
      printstring("It ")
      %if targ=1 %then printstring("belongs to") %else printstring("is in")
      printstring(" the system '".sys(oldname)_sname."'");newline
      %if %not yes("OK to move it ?") %then ->in ser
      %if targ=1 %then %start
         delete target(oldname,per pos)
         per(per pos)_target=sys pos
         add target(sys pos,per pos)
         %if yes("In that system as well ?") %then %start
            delete actual(per(per pos)_actual,per pos)
            per(per pos)_actual=sys pos
            add actual(sys pos,per pos)
         %finish
      %else
         delete actual(oldname,per pos)
         per(per pos)_actual=sys pos
         add actual(sys pos,per pos)
         %if yes("Belongs to that system as well ?") %then %start
            delete target(per(per pos)_target,per pos)
            per(per pos)_target=sys pos
            add target(sys pos,per pos)
         %finish
      %if yes("Change its status ?") %then per(per pos)_status=get status(heading)
      %finish
   %finish
   end:
   %if targ=1 %then %start
      %if yes("Any more to BELONG ?") %then p=0 %and ->again
   %else
      %if yes("Any more now IN ?") %then p=0 %and ->again
   %finish
%end

! routine to write the system that a peripheral is in and belongs to
%routine sys of per(%integer pos)
   %if per(pos)_actual=per(pos)_target %then %start
      printr(" BELONGS TO AND IS IN");newliner;newliner
      write sys(sys(per(pos)_actual))
   %else
      printr(" BELONGS TO");newliner;newliner
      write sys(sys(per(pos)_target))
      newline;newline
      printr("        THE SYSTEM IT IS IN");newliner;newliner
      write sys(sys(per(pos)_actual))
   %finish
%end

! routine used by output options to get the file name of the file
! to send output to
%routine new filename
%string(30)newfile
%on %event 3 %start
   printstring("That was an invalid file name, try another")
   newline
%finish
    newfile=readstring("File name ",30)
    %if newfile="" %then %signal %event 3
    %if exists(newfile) %and %not yes("It already exists, ". %c
    "Overwrite it ?") %then %return
    %if outfile#"" %then %start
       %if %not yes("Have to close '".outfile. %c
       "', OK ?") %then %return
       select output(3); close output;select output(0)
       outfile="";file=0
    %finish
    open output(3,newfile)
    outfile=newfile
    file=1
%end

! routine used to change the current detail options
%routine detail options
%integer no
  set top;clear frame
   print centre("Change Detail");newline
   print centre("-------------");newline
   printstring("  Current Detail: ".detname(detail));newline;newline
   printstring("  0)  NO CHANGE");newline
   printstring("  1)  BRIEF    Peripheral: Type, drawing/serial/revision");newline
   printstring("               System    : Short name, long name, owner, location")
   newline
   printstring("  2)  NORMAL   Peripheral: Type, drawing no, serial no, revision code, ")
   newline
   printstring("                           system belonging to, system in, status,")
   newline
   printstring("                           if any history, stn or dau no, if required")
   newline
   printstring("               System    : As Brief but with the type, serial number, and");
   newline
   printstring("                           stn or dau no. (if required) of all its peripherals");
   newline
   printstring("  3)  FULL     Peripheral: As Normal but with Brief info of system")
   newline
   printstring("                           belonging to and in, and the history")
   newline
   printstring("               System    : As Normal but with Normal info on all")
   newline
   printstring("                           peripherals of the system")
   no=get menu no(3)
   detail=no %if no#0
%end

! routine to set the separators between records and results.
! note that these only affect output sent to a file, not the screen
%routine sep options(%string(*) %name sep, %integer %name sep no,%string(6) title)
%switch menu(1:6)
%integer menu no,no,i
%string (1) ch
%on %event 13 %start
   %if sig again=1 %then sig again=0 %and %signal %event 13
%finish
   set top;clear frame
   print centre("Change ".title." Separator");newline
   print centre("-----------------------");newline
   printstring("  Current separator : Option");write(sep no,1);newlines(2)
   printstring("  0) Don't change the separator");newline
   printstring("  1) Row of dashes"); newline
   printstring("  2) Row of equal signs"); newline
   printstring("  3) Row of one inputted character"); newline
   printstring("  4) Blank lines (0-100)"); newline
   printstring("  5) One form feed"); newline
   printstring("  6) Two form feeds"); newline

   sig again=1
   menu no=get menu no(6)
   sig again=0
   %if menu no=0 %then %return
   -> menu(menu no)

   menu(1):sep=dashes;sep no=menu no;%return
   menu(2):sep=equals;sep no=menu no;%return
   menu(3):ch=readstring("Character ",1)
           %if ch="" %then printstring("For blank lines see 4 !") %c
           %and newline %and ->menu(3)
           sep=tostring(nl); sep=ch.sep %for i=1,1,78
           sep no=menu no
           %if yes("Blank line before it ?") %then sep=tostring(nl).sep
           %if yes("Blank line after it ?") %then sep=sep.tostring(nl)
           %return
   menu(4):no=get no("How many ? (0-100) ")
           %if %not 0<=no<=100 %then printstring("Between 0 and 100, please") %c
           %and newline %and ->menu(4)
           sep="";sep=sep.tostring(nl) %for i=1,1,no
           sep no=menu no
           %return
   menu(5):sep=ff;sep no=menu no;%return
   menu(6):sep=ff.ff;sep no=menu no
%end

! routine to change all the possible output options of the program
%routine output options
%switch menu(0:11)
%integer no
%on %event 13 %start
   %if sig again=1 %then sig again=0 %and %signal %event 13
%finish
   again:
   set top;clear frame
   spaces(18);printstring("Change Output Options");newline
   spaces(18);printstring("---------------------");newline
   printstring("  Current file: ".outfile.tostring(nl)) %if outfile#""
   printstring("  Current setting: ")
   %if screen=1 %then printstring("To Screen, ")
   %if file=1 %then printstring("To File, ")
   %if report on=1 %then printstring("Reporting counts, ")
   printstring("Detail - ".detname(detail));newline;newline
   printstring("  0)  Return");newline
   printstring("  1)  Pause screen");newline
   printstring("  2)  Continue screen");newline
   printstring("  3)  Pause file");newline
   printstring("  4)  Continue file");newline
   printstring("  5)  Close file");newline
   printstring("  6)  New file");newline
   printstring("  7)  Report count on/off");newline
   printstring("  8)  Change detail");newline
   printstring("  9)  Change record separator");newline
   printstring(" 10)  Change result separator");newline
   printstring(" 11)  Main menu")

   no again:
   sig again=1
   no=get menu no(11)
   sig again=0
   set bot
   ->menu(no)

   menu(0):%if file=0 %and screen=0 %then %start
              printstring("You have got to send output somewhere !")
              newline
              -> no again
           %finish
           set top;%return
   menu(1):%if screen=0 %then printstring("I was not sending output to the". %c
           " screen") %and newline %and ->no again
           screen=0; ->again
   menu(2):%if screen=1 %then printstring("I am already sending output". %c
           " to the screen") %and newline %and ->no again
           screen=1; ->again
   menu(3):%if outfile="" %then printstring("There is no current file !") %c
           %and newline %and ->no again
           %if file=0 %then printstring("I was not sending output to the". %c
           " current file") %and newline %and ->no again
           file=0; ->again
   menu(4):%if outfile="" %then printstring("There is no file open") %and %c
           newline %and -> no again
           %if file=1 %then printstring("I am already sending output". %c
           " to the current file") %and newline %and ->no again
           file=1; ->again
   menu(5):%if outfile="" %then printstring("There is no current file !") %c
           %and newline %and ->no again
           select output(3); close output; select output(0)
           outfile=""; file=0; ->again
   menu(6):new filename; ->again
   menu(7):report on=1-report on; ->again
   menu(8):detail options; ->again
   menu(9):sep options(rec sep,rec sep no,"Record"); ->again
   menu(10):sep options(res sep,res sep no,"Result"); ->again
   menu(11):%if file=0 %and screen=0 %then %start
               printstring("You have got to send output somewhere !")
               newline
               -> no again
            %finish
            %signal %event 15
%end

%routine fsys sname 
%constant %string(80)heading= %c
"FINDING A SYSTEM USING ITS SHORT NAME"
%integer pos
%string(8) sname
   write screen(heading)        {writes heading on the screen}
   %cycle 
      sname=readcapstr("Short name ",8)
      pos = sname exists(sname)
      %if pos=0 %then printstring("I can't find a system with that name") %c
      %and newline %else %start
         write file(heading) 
         write sys(sys(pos))
         write res sep
      %finish
   %repeat
%end
   
%routine fsys loc
%constant %string(80)heading= %c
"FINDING SYSTEM(S) AT A LOCATION"
%integer pos
%string(8) location
   write screen(heading)
   %cycle
      location=readcapstr("Location ",8)
      pos=location exists(location,1)
      %if pos=0 %then printstring("I can't find any system at that location") %c
      %and newline %else %start
         write file(heading)
         %cycle
            write sys(sys(pos))
            pos=location exists(location,pos+1)
            %exit %if pos=0
            screen rec sep
         %repeat
         write res sep
      %finish
   %repeat
%end

%routine fsys case
%constant %string(80)heading= %c
"FINDING A SYSTEM USING ITS CASE NUMBER"
%integer pos,case no
   write screen(heading)
   %cycle
      case no=get no("Case number ")
      pos= ser exists(case no,case type)
      %if pos=0 %then printstring("I can't find a case with that number") %c
      %and newline %else %start
         set top
         newline
         write file(heading)
         printr("       THE SYSTEM WHICH CASE NUMBER");writer(case no,1)
         sys of per(pos)
         write res sep
      %finish
   %repeat
%end

%routine fsys stat
%constant %string(80)heading= %c
"FINDING A SYSTEM USING ITS STATION NUMBER"
%integer pos,stat no
%string(7) hex no
   write screen(heading)
   %cycle
      %cycle
         hex no=readstring( %c
         "Station number (Hex) ",7)
         stat no=hex(hex no)
         %exit %if stat no#-1
         printstring("That was not hex, try again");newline
      %repeat
      pos= station exists(stat no)
      %if pos=0 %then %start
         printstring("I can't find an ethernet with that station number")
         newline
      %else
         set top;newline
         write file(heading)
         printr("      THE SYSTEM WHICH STATION NUMBER ");printr(hex no)
         sys of per(pos)
         write res sep
      %finish   
   %repeat
%end

! routine to list all systems in a certain order
%routine list systems(%string(80)heading,%predicate gtr(%integer j,k,
                     %integer %array %name data))
%integer i
   write screen("LIST OF ALL SYSTEMS, ".heading)
   write file  ("LIST OF ALL SYSTEMS, ".heading)
   sys sort(i)=i %for i=1,1,sys len {set the indices}
   sort(sys sort,sys len,gtr)
   %for i=1,1,sys len %cycle
      %if sys(sys sort(i))_pos#255 %then      {if it is not on free list} %c
      write sys(sys(sys sort(i))) %and screen rec sep
   %repeat
   write res sep
   %if %not yes("Another query ?") %then %signal %event 15
%end

%routine fsys per
%constant %string(80) heading= %c
"FINDING SYSTEMS WITH A CERTAIN PERIPHERAL"
%integer type no, ser, pos, i, j ,last
%string(29) type name
%byte ch
   again:
   type no=list types(heading)
   type name=type(type no)
   %if %not yes("All of them ?") %then %start
      list ser(type no,heading)
      ser=get no("Serial number ")
      pos=ser exists(ser,type no)
      %if pos=0 %then %start
         printstring("There isn't any ".type name." with that serial number")
         newline
         ->again
      %else
         to upper(type name)
         write screen(heading)
         write file(heading)
         printr("THE SYSTEM WHICH THE ".type name." (")
         writer(ser,0);printr(")")
         sys of per(pos)
         write res sep
      %finish
   %else
      to upper(type name)
      set top;clear frame
      printr("                 ALL SYSTEMS WHICH HAVE A ".type name)
      newline;newline
      write rec sep
      ch=readletter("Belonging to or In ? (B/I) ","BI")
      j=0
      %for i=1,1,per len %cycle
         %if per(i)_status#0 %and per(i)_type=type no %then %start
           j=j+1
           %if ch='B' %then per sort(j)=per(i)_target %else %c
           per sort(j)=per(i)_actual
         %finish
      %repeat
      sort(per sort,j,gtr sname)
      last=0
      %for i=1,1,j %cycle
         %if per sort(i)#last %start    {haven't written the system out already}
            write sys(sys(per sort(i)))
            last=per sort(i)
            screen rec sep
         %finish
      %repeat
      write res sep
   %finish
   %if yes("Find more ?") %then ->again
%end

%routine lsys case
%byte ch
   ch=readletter("Belonging to or In ? (B/I) ","BI")
   %if ch='B' %then %start
      copy tar(case type) 
      list systems("ORDERED BY THE CASE BELONGING TO A SYSTEM",gtr sys comp)
   %else
      copy act(case type)
      list systems("ORDERED BY THE CASE IT IS IN",gtr sys comp)
   %finish
%end

%routine lsys stat
%byte ch
   ch=readletter("Belonging to or In ? (B/I) ","BI")
   %if ch='B' %then %start
      copy tar station
      list systems("ORDERED BY THE STATION NUMBER BELONGING TO SYSTEM",
      gtr sys comp)
   %else
      copy act station
      list systems("ORDERED BY THE STATION NUMBER A SYSTEM CURRENTLY HAS",
      gtr sys comp)
   %finish
%end

%routine list stat
%constant %string (80) heading= %c
"LISTING ALL STATION NUMBER CURRENTLY IN USE"
%string(255) s=""
%integer i,j=0
   write screen(heading)
   write file(heading)
   %for i=1,1,per len %cycle
      %if per(i)_status#0 %and ethernet(per(i)_type) %then %c
      j=j+1 %and per sort(j)=per(i)_dep
   %repeat
   sort(per sort,j,gtr)
   %for i=1,1,j %cycle
      %if length (s)<=71 %then s=s." ".itoh(per sort(i)) %else %c
      printr(s) %and newliner %and s=itoh(per sort(i))
   %repeat
   printr(s);newliner
   write res sep
   %if %not yes("Another query ?")  %then %signal %event 15
%end

%routine lper type
%constant %string(80) heading="PERIPHERALS OF A CERTAIN TYPE"
%integer type no,i,j
%string(128) title
%string (29) type name
   again:
   type no=list types(heading)
   type name=type(type no)
   to upper(type name)
   j=0
   %for i=1,1,per len %cycle
      %if per(i)_status#0 %and per(i)_type=type no %then %c
      j=j+1 %and per sort(j)=i
   %repeat
   %if j=1 %then title="THERE IS 1 PERIPHERAL" %else %c
   title="THERE ARE ".itos(j,0)." PERIPHERALS"
   title=title." OF TYPE ".type name." (DRAWING NO.".itos(draw(type no),1).")"
   write screen(title) ;write file(title)
   sort(per sort,j,gtr type)
   write per(per(per sort(i))) %and screen rec sep %for i=1,1,j
   write res sep
   %if yes("Another type ?") %then ->again
%end
     
%routine lper status
%constant %string(80) heading="PERIPHERALS WITH A CERTAIN STATUS"
%integer status no,i,j
%string (128) title
%string (31) status name
   again:
   status no=get status(heading)
   status name=stat(status no)
   to upper(status name)
   j=0
   %for i=1,1,per len %cycle
      %if per(i)_status=status no %then j=j+1 %and per sort(j)=i
   %repeat
   %if j=1 %then title="THERE IS 1 PERIPHERAL" %else %c
   title="THERE ARE ".itos(j,0)." PERIPHERALS"
   title=title." WITH STATUS - ".status name
   write screen(title); write file(title)
   sort(per sort,j,gtr type)
   write per(per(per sort(i))) %and screen rec sep %for i=1,1,j
   write res sep
   %if yes("Another status ?") %then ->again
%end

%routine lper batch
%constant %string(80) heading="PERIPHERALS IN A CERTAIN BATCH"
%integer batch no,i,j
%string (128) title
   again:
   batch no=get batch(heading)
   j=0
   %for i=1,1,per len %cycle
      %if per(i)_status#0 %and per(i)_batch=batch no %then %c
      j=j+1 %and per sort(j)=i
   %repeat
   %if j=1 %then title="THERE IS 1 PERIPHERAL" %else %c
   title="THERE ARE ".itos(j,0)." PERIPHERALS"
   title=title." IN BATCH".itos(batch no,1)
   write screen(title);write file(title)
   sort(per sort,j,gtr type)
   write per(per(per sort(i))) %and screen rec sep %for i=1,1,j
   write res sep
   %if yes("Another batch ?") %then ->again
%end

!routine to write out how many there are of each type, used by list
!peripherals
%routine no in type(%integer %name k)
%integer j=0
   %cycle
      %if per(per sort(k))_status#0 %then j=j+1
      k=k+1
      %exit %if k>per len %or %c
      per(per sort(k-1))_type#per(per sort(k))_type
   %repeat
   %return %if j=0
   %if j=1 %then printr("There is only 1 ".type(per(per sort(k-1))_type)) %else %c
   printr("There are ".itos(j,0)." ".type(per(per sort(k-1))_type)."s")
   newliner;write rec sep
   screen rec sep
%end

!routine to write out how many peripherals there with each status, used
! by the routine list peripherals
%routine no in state(%integer %name k)
%integer j=0
   %cycle
      %if per(per sort(k))_status#0 %then j=j+1
      k=k+1
      %exit %if k>per len %or %c
      per(per sort(k-1))_status#per(per sort(k))_status
   %repeat
   %return %if j=0
   %if j=1 %then printr("There is only 1 peripheral ") %else %c
   printr("There are ".itos(j,0)." peripherals ")
   printr(stat(per(per sort(k-1))_status));newliner
   write rec sep
   screen rec sep
%end

!routine to write out how many peripherals there are in each batch,
! used by the routine list peripherals, below
%routine no in batch(%integer %name k)
%integer j=0
   %cycle
      %if per(per sort(k))_status#0 %then j=j+1
      k=k+1
      %exit %if k>per len %or %c
      per(per sort(k-1))_batch#per(per sort(k))_batch
   %repeat
   %return %if j=0
   %if j=1 %then printr("There is only 1 peripheral") %else %c
   printr("There are ".itos(j,0)." peripherals")
   printr(" in batch ".itos(per(per sort(k-1))_batch,0));newliner
   write rec sep
   screen rec sep
%end

! lists all peripherals in a certain order
%routine list peripherals(%string(80)heading,%predicate gtr(%integer j,k,
                          %integer %array %name data),
                          %routine no in(%integer %name k))
%integer i
%integer next title=1
   write screen("LIST OF ALL PERIPHERALS, GROUPED BY ".heading)
   write file  ("LIST OF ALL PERIPHERALS, GROUPED BY ".heading)
   per sort(i)=i %for i=1,1,per len {initial order of the array}
   sort(per sort,per len,gtr)
   %for i=1,1,per len %cycle
      %if per(per sort(i))_status#0 %then %start  {not on the free list}
         %if report on=1 %and i>=next title %then {should report count} %c
         next title=i %and no in(next title) {write title}
         write per(per(per sort(i)))
         screen rec sep
      %finish
   %repeat
   write res sep
   %if %not yes("Another query ?") %then %signal %event 15
%end

%routine fper ser
%constant %string(80) heading= %c
"FINDING A PERIPHERAL USING ITS TYPE AND SERIAL NUMBER"
%integer type no,ser,pos
   again:
   type no=list types(heading)
   list ser(type no,heading)
   ser=get no("Serial number ")
   pos=ser exists(ser,type no)
   %if pos=0 %then %start
      printstring("There isn't any ".type(type no)." with that serial number")
      newline
      -> again
   %else
      write screen(heading)
      write file(heading)
      write per(per(pos))
      write res sep
   %finish
   %if yes("Find another?") %then ->again
%end

%routine pri his
%constant %string(80) heading= %c
"PRINTING THE HISTORY OF A PERIPHERAL"
%integer type no,ser,pos,i
%string (29) type name
   again:
   type no=list types(heading)
   type name=type(type no)
   list ser(type no,heading)
   ser=get no("Serial number ")
   pos=ser exists(ser,type no)
   %if pos=0 %then %start
      printstring("There isn't any ".type name." with that serial number")
      newline
      -> again
   %else
      write screen(heading)
      to upper(type name)
      printr("THE HISTORY OF THE ".type name.", SERIAL NUMBER")
      writer(ser,1);newliner;newliner
      i=per(pos)_history
      %if i=0 %then %start
          printr("No history recorded for that peripheral")
          newliner
      %finish %else print history(i)
      write res sep
   %finish
   %if yes("Find another ?") %then ->again
%end

%routine fper sys
%constant %string(80)heading= %c
"FINDING THE PERIPHERALS OF A SYSTEM"
%integer pos
%string(8) sname
   write screen(heading)
   %cycle
      sname=readcapstr("Short name ",8)
      pos=sname exists(sname)
      %if pos=0 %then printstring("I can't find a system with that name") %c
      %and newline %else %start
         write file(heading)
         {the least detailed system writeout doesn't include peripherals}
         %if detail=1 %then write sys2(sys(pos)) %else write sys3(sys(pos))
         write res sep
      %finish
   %repeat
%end

%routine lper ser
%constant %string(80) heading= %c
"LISTING ALL SERIAL NUMBERS OF A TYPE OF PERIPHERAL"
%string(255) s
%integer type no,i,j
%string(29) type name
   again:
   type no=list types(heading)
   type name=type(type no)
   to upper(type name)
   write screen("ALL SERIAL NUMBERS OF PERIPHERALS OF TYPE ".type name)
   write file("ALL SERIAL NUMBERS OF PERIPHERALS OF TYPE ".type name)
   j=0
   %for i=1,1,per len %cycle
      %if per(i)_status#0 %and per(i)_type=type no %then %c
      j=j+1 %and per sort(j)=per(i)_ser
   %repeat
   sort(per sort,j,gtr)
   s=""
   %for i=1,1,j %cycle
      %if length (s)<71 %then s=s.itos(per sort(i),1) %else %c
      printr(s) %and newliner %and s=itos(per sort(i),1)
   %repeat
   printr(s);newliner
   write res sep
   %if yes("Another type ?") %then ->again
%end
   
! gets from the menu the system information the user wants to find
%routine ret sys
%switch menu(0:11)
%integer no
%on %event 13 %start
   %if sig again=1 %then sig again=0 %and %signal %event 13
%finish
   updating=0                   {used to indicate output may go to a file}
   again:
   set top;clear frame
   print centre("Query Systems");newline
   print centre("-------------");newlines(2)
   printstring("  0)  Main menu");newline
   printstring("  1)  With short name");newline
   printstring("  2)  At location");newline
   printstring("  3)  With case number");newline
   printstring("  4)  With station number");newline
   printstring("  5)  With peripheral");newline
   printstring("  6)  Order by short name");newline
   printstring("  7)  Order by location");newline
   printstring("  8)  Order by case number");newline
   printstring("  9)  Order by station number");newline
   printstring(" 10)  All station numbers");newline
   printstring(" 11)  Change output options");newline

   sig again=1
   no=get menu no(11)
   sig again=0
   ->menu(no)

   menu(0):%return
   menu(1):fsys sname
   menu(2):fsys loc
   menu(3):fsys case
   menu(4):fsys stat
   menu(5):fsys per;->again
   menu(6):list systems("ORDERED BY SHORT NAME",gtr sname);->again
   menu(7):list systems("ORDERED BY LOCATION",gtr location);->again
   menu(8):lsys case;->again
   menu(9):lsys stat;->again
   menu(10):list stat;->again
   menu(11):output options;->again
%end

! gets from the menu the peripheral information the user wants to find
%routine ret per
%switch menu(0:12)
%integer no
%on %event 13 %start
   %if sig again=1 %then sig again=0 %and %signal %event 13
%finish
   updating=0
   again:
   set top; clear frame
   printcentre("Query Peripherals");newline
   printcentre("-----------------");newline;newline
   printstring("  0)  Main menu");newline
   printstring("  1)  With type and serial number");newline
   printstring("  2)  Print history");newline
   printstring("  3)  Of a system");newline
   printstring("  4)  Of a certain type");newline
   printstring("  5)  With a certain status");newline
   printstring("  6)  In a certain batch");newline
   printstring("  7)  Group by type");newline
   printstring("  8)  Group by status");newline
   printstring("  9)  Group by batch");newline
   printstring(" 10)  All station numbers");newline
   printstring(" 11)  All serial numbers of a type");newline
   printstring(" 12)  Change output options");newline

   sig again=1
   no=get menu no(12)
   sig again=0
   ->menu(no)

   menu(0):%return
   menu(1):fper ser;->again
   menu(2):pri his;->again
   menu(3):fper sys
   menu(4):lper type;->again
   menu(5):lper status;->again
   menu(6):lper batch;->again
   menu(7):list peripherals("TYPE",gtr type,no in type);->again
   menu(8):list peripherals("STATUS",gtr status,no in state);->again
   menu(9):list peripherals("BATCH",gtr batch,no in batch);->again
   menu(10):list stat;->again
   menu(11):lper ser;->again
   menu(12):output options;->again
%end

%routine change sys
%const %string (80) heading = %c
"CHANGING INFORMATION ABOUT A SYSTEM"
%switch menu(0:5)
%string (8) sname
%integer pos,no
%on %event 13 %start
   %if sig again=1 %then sig again=0 %and %signal %event 13
   -> menu again
%finish
   again:
   set top;clear frame;printcentre(heading);newline
   sig again=1
   sname=readcapstr("Short name ",8)
   pos=sname exists(sname)
   %if pos=0 %then %start
      printstring("I can't find a system with that name"); newline 
      -> again
   %finish
   menu again:
   set top;clear frame
   printcentre("Change System");newline
   printcentre("-------------");newline
   printstring("  Choose which information you wish to change");newlines(2)
   printstring("                           Current Values");newline
   printstring("                           ~~~~~~~~~~~~~~");newline
   printstring("  0)  Main menu");newline
   printstring("  1)  Short name           ".sys(pos)_sname);newline
   printstring("  2)  Long name            ")
   write lname(sys(pos)_lname,sys(pos)_pos);newline
   printstring("  3)  Owner                ".sys(pos)_owner);newline
   printstring("  4)  Location             ".sys(pos)_location);newline
   printstring("  5)  Change another system");newline

   sig again=1
   no=get menu no(6)
   sig again=0
   -> menu(no)
   
   menu(0):%return
   menu(1):sname=readcapstr("New short name ",8)
           %if sname exists(sname)#0 %then %c
           printstring("That short name is already in use") %c
           %and newline %and ->menu again
           sys(pos)_sname=sname;-> menu again
   menu(2):sys(pos)_lname=get lname(sys(pos)_pos); ->menu again
   menu(3):sys(pos)_owner=readcapstr("New owner ",8)   
           ->menu again
   menu(4):sys(pos)_location=readcapstr("New location ",8)
           ->menu again
   menu(5):->again
%end

%routine change per
%const %string (80) heading = %c
"CHANGING INFORMATION ABOUT A PERIPHERAL"
%switch menu(0:12)
%string (8) sname
%string (7) hex no
%integer type no,ser no,pos,no,off,size,new pos,menu no
%byte %array text(1:text max)
%on %event 13 %start
   %if sig again=1 %then sig again=0 %and %signal %event 13
   -> menu again
%finish
   again:
   sig again=1
   type no=list types("CHOOSE TYPE OF PERIPHERAL YOU WISH TO CHANGE")
   ser again:
   list ser(type no,heading)
   ser no=get no("Serial number ")
   pos=ser exists(ser no,type no)
   %if pos=0 %then %start
      printstring("There isn't any ".type(type no)." with that serial number")
      newline;
      -> again
   %finish
   menu again:
   set top;clear frame
   printcentre("Change Peripheral");newline
   printcentre("-----------------");newline
   printstring("      Can Change                    Current Values");newline
   printstring("      ~~~~~~~~~~                    ~~~~~~~~~~~~~~");newline
   printstring("  0)  Main menu");newline
   printstring("  1)  Type (drawing no)             ".type(per(pos)_type). %c
   " (". itos(draw(per(pos)_type),0).")");newline
   printstring("  2)  Serial number                 ".itos(per(pos)_ser,0));newline
   printstring("  3)  Type and serial no.           As Above");newline
   printstring("  4)  Revision code                 ".per(pos)_rev);newline
   printstring("  5)  System it belongs to          ".sys(per(pos)_actual)_sname);newline
   printstring("  6)  System it is in               ".sys(per(pos)_target)_sname);newline
   printstring("  7)  Batch number                  ".itos(per(pos)_batch,0));newline
   printstring("  8)  Status of peripheral          ".stat(per(pos)_status));newline
   off=0
   %if ethernet(per(pos)_type) %then %start
      off=1
      printstring("  9)  Station number (hex)          ".itoh(per(pos)_dep));newline
   %finish
   %if processor(per(pos)_type) %then %start
      off=1
      printstring("  9)  Daughter serial no.           ".itos(per(pos)_dep,0));newline
   %finish
   printstring(itos(9+off,2).")  Add to the history            ")
   %if per(pos)_history=0 %then printstring("It has none") %else %c
   printstring("It has some");newline
   printstring(itos(10+off,2).")  Change peripheral of same type");newline
   printstring(itos(11+off,2).")  Change different peripheral")
   sig again=1
   menu no=get menu no(11+off)
   sig again=0
   %if menu no<=8 %then ->menu(menu no) %else ->menu(menu no+1-off)

   menu(0):%return
   menu(1):type no=list types("CHOOSE THE NEW TYPE OF THE PERIPHERAL")
           %if ser exists(per(pos)_ser,type no)#0 %start
              printstring("You can't change it to that, because there is");newline
              printstring("already a ".type(type no)." with the same serial number")
              newline
              ->menu again
           %finish
           %if ethernet(type no) %then ->get stat {has to get station number}
           per(pos)_type=type no                  {routine is in menu(3) below}
           -> menu again
   menu(2):list ser(per(pos)_type,"SERIAL NUMBERS ALREADY IN USE")
           ser no=get no("New serial number ")
           %if ser exists(ser no,per(pos)_type)#0 %start
              printstring("You can't change it to that, because there is");newline
              printstring("already a ".type(per(pos)_type)." with that". %c
              " serial number");newline
              -> menu again
           %finish
           per(pos)_ser=ser no
           -> menu again
   menu(3):type no=list types("CHOOSE THE NEW TYPE OF THE PERIPHERAL FIRST")
           list ser(per(pos)_type,"SERIAL NUMBERS ALREADY IN USE")
           ser no=get no("New serial number ")
           %if ser exists(ser no,type no)#0 %start
              printstring("You can't change them to those values, because");newline
              printstring("there is already a ".type(type no)." with ". %c
              "serial number ".itos(ser no,0));newline
              ->menu again
           %finish
           %if %not ethernet(type no) %then %start
              per(pos)_type=type no
              per(pos)_ser=ser no
              ->menu again
           %finish
           set top;clear frame;printcentre(heading); newline
           get stat:     {get the station no., as changed to an ethernet}
                         {this bit is also used by menu(1)}
             hex no=readstring("Station number as well (hex) ",7)
             no=hex(hex no)
             %if no=-1 %then printstring("That was not hex, try again please") %c
             %and newline %and -> get stat
             %if station exists(no)#0 %then printstring("That station number". %c
             " is already in use, try another") %and newline %and ->get stat
             per(pos)_dep=no
             per(pos)_type=type no
             per(pos)_ser=ser no %if menu no=3
           -> menu again
   menu(4):set top; clear frame; printcentre(heading); newline
           per(pos)_rev=readcapstr("New revision code ",2); -> menu again
   menu(5):set top;clear frame; printcentre(heading); newline
           sname=readcapstr("System it now BELONGS to ",8)
           new pos=sname exists(sname)
           %if new pos=0 %then printstring("I can't find that system") %and %c
           newline %and ->menu again
           delete target(per(pos)_target,pos)
           per(pos)_target=new pos
           add target(new pos,pos)
           -> menu again
   menu(6):set top; clear frame; printcentre(heading);newline
           sname=readcapstr("System it is now IN ",8)
           new pos=sname exists(sname)
           %if new pos=0 %then printstring("I can't find that system") %and %c
           newline %and ->menu again
           delete actual(per(pos)_actual,pos)
           per(pos)_actual=new pos
           add actual(new pos,pos)
           -> menu again
   menu(7):per(pos)_batch=get batch(heading)
           update batch list(per(pos)_batch); ->menu again
   menu(8):per(pos)_status=get status(heading); ->menu again
   menu(9):set top; clear frame;printcentre(heading); newline
           %if processor(per(pos)_type) %then %c
           per(pos)_dep=get no("New daughter serial number ") %and ->menu again
           hex again:       {Otherwise it is an ethernet board, so ...}
           hex no=readstring("New station number (hex) ",7)
           no=hex(hex no)
           %if no=-1 %then printstring("Now that wasn't hex, was it ?". %c
           " Try again") %and newline %and -> hex again
           %if station exists(no)#0 %then printstring("That station". %c
           " number is already in use, so I can't make a change") %and %c
           newline %and ->menu again
           per(pos)_dep=no; -> menu again
   menu(10):get history(text,size,"TYPE IN HISTORY TO APPEND TO CURRENT HISTORY")
            %if %not yes("Can I add it ?") %c
            %then printstring("Not added to the history") %and newline %and -> menu again
            put history(pos,text,size); ->menu again
   menu(11):type no=per(pos)_type;-> ser again
   menu(12):-> again
%end


! routine to let the user input a new system
%routine new sys
%constant %string(80) heading= %c
"ENTERING DATA FOR A NEW SYSTEM"
%record(sysf) s=0
%integer index
   %if sys full=1 %then reload("system")
   again:
   set top; clear frame; printcentre(heading); newline
   s_sname=get sname("Short name ")
   s_lname=get lname(s_pos)
   %if charno(s_sname,1)='@' %then %start
      s_owner=readcapstr("Owner, <RETURN> if short name with no '@' ",8)
      %if s_owner="" %then s_sname->("@").s_owner
   %else
      s_owner=readcapstr("Owner ",8)
   %finish
   s_location=readcapstr("Location ",8)
   set top; clear frame; printcentre(heading); newlines(2)
   write sys1(s)
   check again:
   %if %not yes("Data entered OK ?") %then %start
      %if yes("Are you certain you want to forget the data ?") %then -> another
      ->check again
   %finish
   index=get new sys
   sys(index)=s
   %if yes("Input peripherals which BELONG to the system ?") %c
   %then get peripherals (index,1)
   %if yes("Input peripherals which are IN the system now ?") %c
   %then get peripherals (index,0)
   another:
   %if yes("Another new system ?") %then s=0 %and ->again
%end

! routine to let the user input a new peripheral
%routine new per
%constant %string(80) heading= %c
"ENTERING DATA FOR A NEW PERIPHERAL"
%record(perf) p=0
%byte %array text (1:text max)
%integer size,pos
%byte hwant
   again:               {jumped to if another peripheral to be entered}
   p_type=list types(heading)
   again no type:       {jumped to if another item of same type to be entered}
   %if per full=1 %then reload("peripheral")
   list ser(p_type,heading)
   p_ser=get ser(p_type)
   set top; clear frame; print centre(heading);newline
   p_rev=readcapstr("Revision code ",2)
   p_target=get target("Short name it belongs to ")
   p_actual=get actual(p_target,"Short name it is in now ")
   p_batch=get batch(heading)
   p_status=get status(heading)
   %if ethernet(p_type) %then p_dep=get station(heading)
   %if processor(p_type) %then %c
   p_dep=get no("Daughter serial number, (0 if it hasn't one) ")
   %if his full=1 %then printstring("YOU CAN'T ENTER ANY HISTORY JUST NOW".%c
   " AS THERE IS NO SPACE FOR IT".tostring(nl)) %and hwant=1 %else %start
      %if yes("Enter history ?") %then %c
      get history(text,size,heading) %and p_history=-1
   %finish
   set top; clear frame; printcentre(heading);newline
   write per2(p)
   set bot
   check again:
   %if %not yes("Data entered OK ?") %then %start
      %if yes("Are you sure you want to forget the data ?") %then -> another
      -> check again
   %finish

   pos=get new per                     {get position of place for new record}
   update batch list(p_batch)          {add batch to the batch list}
   per(pos)=p
   %if p_history=-1 %then put history(pos,text,size)
   add target(p_target,pos)
   add actual(p_actual,pos)
   %if hwant=1 %then reload("history")
   another:
   %if yes("Another new peripheral ?") %then p=0 %and -> again
%end

! routine to delete a system form the database, and adjust all
! peripherals which the system used to have
%routine del sys
%constant %string(80) heading= %c
"DELETING A SYSTEM ENTRY"
%integer old pos,new pos,per pos,next pos
%string (8) sname,sname1
   again:
   set top;clear frame;print centre(heading);newline
   sname=readcapstr("Short name ",8)
   old pos=sname exists(sname)
   %if old pos=0 %then print string("I can't find that system") %and %c
   newline %and ->again
   write sys1(sys(old pos))
   newline;printstring("It has ")
   %if sys(old pos)_tar head=0 %then printstring("no ")
   printstring("peripherals belonging to it");newline
   printstring("It has ")
   %if sys(old pos)_act head=0 %then printstring("no ")
   printstring("peripherals in it now");newline
   %if %not yes("Do you really want to delete it ?") %then -> another
   per pos=sys(old pos)_tar head
   %while per pos#0 %cycle
      next pos=per(per pos)_next tar
      set top;clear frame
      print centre("ADJUSTING PERIPHERALS BELONGING TO A DELETED SYSTEM")
      newline
      write per2(per(per pos))
      %if yes("Delete this peripheral completely ?") %then %start
         delete target(per(per pos)_target,per pos)
         delete actual(per(per pos)_actual,per pos)
         delete his(per(per pos)_history)
         delete per(per pos)
      %else
         sname again:
         sname1=readcapstr("Short name it belongs to now ",8)
         new pos=sname exists(sname1)
         %if new pos=0 %or new pos=old pos %then %c
         printstring("I can't find that system, try another") %and newline %c
         %and -> sname again
         delete target(old pos,per pos)
         per(per pos)_target=new pos
         add target(new pos,per pos)
         %if yes("IN that system as well ?") %c
         %then %start
             delete actual(per(per pos)_actual,per pos)
             per(per pos)_actual=new pos
             add actual(new pos,per pos)
         %finish
      %finish
      per pos=next pos
   %repeat
   per pos=sys(old pos)_act head
   %while per pos#0 %cycle
      next pos=per(per pos)_next act
      set top;clear frame
      print centre("ADJUSTING PERIPHERALS WHICH WERE IN A DELETED SYSTEM");newline
      write per(per(per pos))
      %if yes("Delete this peripheral completely ?") %then %start
         delete actual(per(per pos)_actual,per pos)
         delete target(per(per pos)_target,per pos)
         delete his(per(per pos)_history)
         delete per(per pos)
      %else
         sname2 again:
         sname1=readcapstr("Short name it is now in ",8)
         new pos=sname exists(sname1)
         %if new pos=0 %or new pos=old pos %then %c
         printstring("I can't find that system, try another") %c
         %and newline %and ->sname2 again
         delete actual(old pos,per pos)
         per(per pos)_actual=new pos
         add actual(new pos,per pos)
         %if yes("BELONGS to that system as well ?") %c
         %then %start
            delete target(per(per pos)_target,per pos)
            per(new pos)_target=new pos
            add target(new pos,per pos)
         %finish
      %finish
      per pos=next pos
   %repeat
   delete sys(old pos)
   another:
   %if yes("Delete another system ?") %then -> again
%end

! routine to delete a peripheral from the database
%routine del per
%constant %string(80) heading= %c
"DELETING A PERIPHERAL ENTRY"
%integer pos,type no,ser no
   again:
   type no=list types(heading)
   list ser(type no,heading)
   ser no=get no("Serial number ")
   pos=ser exists(ser no,type no)
   %if pos=0 %then %start
      printstring("There isn't any ".type(type no)." with that serial number")
      newline;-> again
   %finish
   set top; clear frame; printcentre(heading);newline
   write per2(per(pos))
   %if yes("Do you really want to delete it ?") %then %start
      delete target(per(pos)_target,pos)
      delete actual(per(pos)_actual,pos)
      delete his(per(pos)_history)
      delete per(pos)
   %finish
   %if yes("Delete another peripheral ?") %then -> again
%end
      
! routine to exit the database, without sending any updates made to
! the database file
%routine abort
   %if changed=1 %and %not %c
   yes("Are you sure you want to loose all the data you have entered ?") %c
   %then %signal %event 15
   win=vdu; clear frame
   %stop
%end

! routine to exit the program and send the altered database to the
! database file, (if it was altered)
%routine upd exit
   %if changed=1 %then save data
   win=vdu;clear frame
%end

! routine to update the database file, but without exiting the program
%routine update
   %if changed=0 %and %not yes("But you haven't altered anything in". %c
   " the database".tostring(nl)."So are you sure you want to update". %c
   " the database file ?") %then %return
   changed=1
   upd exit
   %signal %event 14
%end

  
set screens

! read important information from the data file
read (sys len)
read (per len)
read (his len)

read (free sys)
read (free per)
read (free his)

read (batch len)

load data

! the main menu, which can be got to by signalling event 15 if necessary
%begin
%switch main (0:12)                 {where to jump to in main menu}

   ! trap an event to get a user back to the main menu
   %on %event 13,15 %start 
      sig again=0
   %finish

   main menu:
   updating=1
   set top
   clear frame
   spaces(18); printstring("Main Menu"); newline
   spaces(18); printstring("========="); newline
   newline
   printstring("  1)  Query systems");newline
   printstring("  2)  Change systems");newline
   printstring("  3)  New systems");newline
   printstring("  4)  Delete systems");newline
   printstring("  5)  Query peripherals");newline
   printstring("  6)  Change peripherals");newline
   printstring("  7)  New peripherals");newline
   printstring("  8)  Delete peripherals");newline
   printstring("  9)  Change output options");newline
   printstring(" 10)  Abort updates and stop");newline
   printstring(" 11)  Update database file");newline
   printstring(" 12)  Exit program (file updated if necessary)");newline
   
   ->main(get menu no(12))        {get reply to menu and jump to appropriate place}
   
   main(0): ->main menu
   main(1): ret sys ; ->main menu
   main(2): change sys ; ->main menu
   main(3): new sys ; ->main menu
   main(4): del sys ; ->main menu
   main(5): ret per ; ->main menu
   main(6): change per ; ->main menu
   main(7): new per ; ->main menu
   main(8): del per ; ->main menu
   main(9): output options; ->main menu
   main(10): abort
   main(11): update ; ->main menu
   main(12): upd exit
   
%end

%end
%end %of %program