{
******************************************************************************
*                                                                            *
*                   VAX VMS Terminal reservation program                     *
*                   *** *** ******** *********** *******                     *
*                                                                            *
*  This program will allow users to reserve a fixed number of 1/2 hour       *
*  slots on any available terminal. The program uses two files to store      *
*  user and terminal data, and automatically maintains the database to       *
*  be current to the latest half-hour. Many of the operating parameters      *
*  may be varied by adjusting the commented constants at the head of the     *
*  program.                                                                  *
*                                                                            *
*  Version:                 1.1                                              *
*                                                                            *
*  Revision Date:           21-SEP-1983                                      *
*                                                                            *
*  Written by:              Mark Resmer - Academic Computer Center Manager   *
*                           Box 248                                          *
*                           Vassar College                                   *
*                           Poughkeepsie                                     *
*                           NY 12601                                         *
*                                                                            *
*  Language:		    PASCAL version 2.2                               *
*                                                                            *
*  Operating System:        VMS version 3.4                                  *
*                                                                            *
*  Copyright (C) 1983 Mark Resmer - permission is hereby  granted for the    *
*  reproduction of this software, on condition that this copyright notice    *
*  is included in the reproduction, and that such reproduction is not for    *
*  purposes of profit or material gain.                                      *
*                                                                            *
******************************************************************************
}

[inherit('sys$library:starlet')]
program reserv(input,output,cc,cn,ttyfile,userfile,whowhrfile);

label 1;			{apologies Edsger - it is the panic button!}

const
          			{parameters indicated by "D" are dynamic}
				{i.e. may be changed without rebuilding the}
				{database}

				{paramenters indicated by "S" are static}
				{if changed, data files must be deleted and}
				{the whole database re-initialized}

				{parameters indicated by "X" should not be}
				{changed at all}

   class1   = 'Faculty';        {D UICs - lower and upper bounds}
   class1l  = %O'1';		{D        more classes could be added quite}
   class1u  = %O'77';		{D        simply - see procedure setlimits}
   class2   = 'Student';	{D}
   class2l  = %O'100';		{D}
   class2u  = %O'177';		{D}
   class3   = 'Courses';	{D}
   class3l  = %O'200';		{D}
   class3u  = %O'377';		{D}

   max1     = 20;		{D maximum # of 1/2 hour slots for faculty}
   max2     = 4;		{D for students}
   max3     = 10;		{D for courses}
				{  no real limits, but see maxslots}

   leadtime1= 21;		{D class1 advance booking in days}
   leadtime2= 7;		{D class2 advance booking in days}
   leadtime3= 14;		{D class3 advance booking in days}
				{  no real limits, but see maxdays}

   last1    = 1;                {D last chance to change reservation in hours}
   last2    = 2;		{D no real limits - may be zero if desired}
   last3    = 2;		{D}

   console  = 96;		{D VMS device number for a VT100}
   asterisk = 26;		{D location of NORESERVE asterisk in WHO.WHR}
   timoutmax= 30;               {D seconds to wait on a deadlock timeout}

   ttnamlen = 5;		{S maximum length of a TTY name - might need}
				{  fixing for VMS 4.0?}

   usernamlen=9;                {S maximum length of a username - might need}
				{  fixing if you use maximum 12 chars allowed}
				{  N.B. PAST, SYSRES and BLANKS9 need to be}
				{  altered if you change this}

   maxslots = 21;		{S maximum reservation time - in 1/2 hours - }
				{  must be at least 1 more than biggest max}

   maxdays  = 22;		{S period of days covered by system - must be}
				{  at least 1 more than biggest leadtime}

   past     = '*EXPIRED*';      {S expired username field - length USERNAMLEN}
   sysres   = '*SYSTEM* ';      {S system username field - length USERNAMLEN}

   blanks9  = '         ';	{S blank username - length USERNAMLEN}

   blanks5  = '     ';          {X blank time field}
   blanks11 = '           ';	{X blank date field}

   maxterms = 60;               {X maximum # of terminals covered by system}

   esc      = 27;               {X ASCII escape}
   bell     = 7;      		{X ASCII bell}
   cr       = 13; 		{X ASCII return}
   bs       = 8;		{X ASCII backspace}
   del      = 127;              {X ASCII delete}

type
   linetype = varying [80] of char;		{dynamic and...}

   linefix = packed array [1..80] of char;	{...fixed length strings}

   systimtype = record				{system time}
                  i,j:unsigned;
                end;

   nametype = packed array [1..usernamlen] of char;	{usernames}

   datetype = packed array [1..11] of char; 	{ascii date}

   timetype = packed array [1..5] of char;      {ascii hours and minutes}

   uictype  = record				{uic number}
               group : 0..%O'377';
               member: 0..%O'377';
              end; 

   ttytype = packed array [1..ttnamlen] of char;{terminal physical name}

   loctype = varying [20] of char;		{terminal location}

   termptr = ^termtype;				{pointer to terminal record}

   termtype= record				{for single linked list}
                ptr:termptr;
                data:linetype;
             end;

   cursortype= (left,right,up,down);		{directions}

   slottype = array [1..maxslots] of integer;	{translation arrays}

   timartype= array [1..maxterms] of ttytype;
                   
   datarrtype=array [1..maxdays] of datetype;

   ttyrec =  record				{terminal file record}
              keysym: [key(0)] ttytype;
              date  : [key(1)] datetype;           
              tty   : [key(2)] ttytype;
              slot  : packed array [0..47] of nametype
             end;

   userrec = record				{user file record}
              username: [key(0)] nametype;
              slot    : packed array [1..maxslots] of
                           record
                              date: datetype;
                              time: timetype;
                              tty : ttytype
                           end
             end;

var
   ttyfile:    file of ttyrec;			{indexed file of terminals}
   userfile:   file of userrec;			{indexed file of users}
   whowhrfile: text;				{sequential file of locations}
   cc:         text;				{FORTRAN format SYS$OUTPUT}
   cn:         file of char;			{no format SYS$OUTPUT}
   tty:        ttyrec;				{current terminal record}
   user:       userrec;				{current user record}
   selection:  char;				{main menu selection}
   uic:        uictype;				{current UIC code}
   username:   nametype;			{current username}
   today:      datetype;			{current date}
   now:        timetype;			{current time}
   legalslots: integer;				{max number of reservations}
   leadtime:   timetype;			{max leadtime for reservations}
   lastchance: integer;				{min hours to allow changes}
   first:      boolean;				{flag for main menu}
   expert:     boolean;				{novice/expert flag}
   dupflag:    boolean;				{duplicate reservation flag}
   termroot:   termptr;				{root of terminal list}
   timoutcnt:  integer;				{count of seconds for timeout}
   thedate:    datetype;			{default date}
   thetime:    timetype;			{default time}
   ttykind:    ttytype;				{current tty id}
   slotarray:  slottype;			{translation arrays}
   timearray:  timartype;
   datearray:  datarrtype;
   mask:       integer;				{mask for control-y trap}
   thistty:    ttytype;				{user's terminal}
   
function getchar : char; extern;	{return a character noecho}

[asynchronous,external(lib$disable_ctrl)] 
   function nocontroly(VAR mask:integer):integer;external;
					{disable control Y}

[asynchronous,external(lib$enable_ctrl)] 
   function controly(VAR mask:integer):integer;external;
					{enable control Y}

[asynchronous,external(lib$get_foreign)] 
   function getforeign(%stdescr line:linefix):integer;external;
					{obtain VMS command line}

procedure syserror(i:integer);forward;  {display errors}

procedure putchar(ch:char);		{write single character to SYS$OUTPUT}
begin
   write(cn,ch,error:=continue);
end;

procedure movecursor(direction:cursortype;distance:integer);
						{move active cursor position}
                                         	{edit for appropriate terminal}
var dummy: varying [80] of char;        	{currently set for VT100}
    i    : integer;
    ch   : char;
begin
   case direction of
      left:  writev(dummy,chr(esc),'[',distance:1,'D');
      right: writev(dummy,chr(esc),'[',distance:1,'C'); 
      up:    writev(dummy,chr(esc),'[',distance:1,'A');
      down:  writev(dummy,chr(esc),'[',distance:1,'B'); 
   end;

   for i := 1 to length(dummy) do
     begin
        ch:=dummy.body[i];
        putchar(ch)
     end
end;

procedure clearscreen;			{blank the whole screen}
					{edit for appropriate terminal}
var dummy: varying [80] of char;        {currently set for VT100}
    i    : integer;
    ch   : char;
begin
   writev(dummy,chr(esc),'[1;1H',chr(esc),'[0J');
   for i := 1 to length(dummy) do
     begin
        ch:=dummy.body[i];
        putchar(ch)
     end
end;

procedure syserror;			{report internal errors}
					{error #s are tagged in code}
var ch:char;
begin
  clearscreen;
  writeln(' System error:#',i:1,' please report to system manager');
  writeln(' Press any character to continue...');
  ch:=getchar;
  goto 1
end;

procedure gotoxy(x,y:integer);		{set active cursor to X,Y position}
				        {edit for appropriate terminal}
var dummy: varying [80] of char;        {currently set for VT100}
    i    : integer;
    ch   : char;

begin
   writev(dummy,chr(esc),'[',y+1:1,';',x+1:1,'H');	{assemble string}
   for i := 1 to length(dummy) do			{...and print it}
     begin
        ch:=dummy.body[i];
        putchar(ch)
     end
end;

procedure wait;				{wait one second}
var
  tim:     timetype;
  bintim:  systimtype;  
begin
  timoutcnt:=timoutcnt+1;		{side effect - increment timout count}
  tim:='0 ::1';				{VAX delta time - 1 second}
  if not odd($bintim(timadr:=bintim,timbuf:=tim)) {make binary time}
    then syserror(2);
  if odd($schdwk(daytim:=bintim))	{schedule a wakeup}
     then
       $hiber				{hibernate a while}
     else
       syserror(3);
  gotoxy(33,23);
  writeln(cc,'+Please wait...')		{tell them you're asleep}
end;

function cursorcontrol(first:char):char;{get cursor key pressed}
					{return original character if}
					{not a cursor key}
					{edit for appropriate terminal}
var ch:char;				{currently set for VT100}
begin
   if first=chr(esc)
    then
     begin
      ch:=getchar;
      if ch='[' 
        then
         begin
          ch:=getchar;
          case ch of
           'A': cursorcontrol:='u';
           'B': cursorcontrol:='d';
           'C': cursorcontrol:='r';
           'D': cursorcontrol:='l';
          end
         end
        else
         cursorcontrol:=first
     end
    else
     cursorcontrol:=first
end;

procedure setexpert;			{set novice/expert flag}
var
  i:integer;
  line:linefix;
begin
  for i:=1 to 80 do line[i]:=' ';	{clear the line}
  expert:=false;			{clear the flag}
  getforeign(line);			{get VMS command line}
  if (line[1]='/') and (line[2]='E')	{look for /E(xpert)}
    then expert:=true
end;

procedure openfiles;			{open all files}
begin
   open(ttyfile,'sys$manager:ttys.dat',history:=unknown,access_method:=keyed,
        organization:=indexed,sharing:=readwrite,error:=continue);
   if status(ttyfile)<>0 then syserror(4);
   open(userfile,'sys$manager:users.dat',history:=unknown,access_method:=keyed,
        organization:=indexed,sharing:=readwrite,error:=continue);
   if status(userfile)<>0 then syserror(5);
   open(whowhrfile,'sys$manager:who.whr',history:=readonly,error:=continue);
   if status(whowhrfile)<>0 then syserror(6);
   reset(whowhrfile);
   open(cc,'sys$output:',carriage_control:=fortran,error:=continue);
   if status(cc)<>0 then syserror(7);
   rewrite(cc);
   open(cn,'sys$output:',carriage_control:=none,error:=continue);
   if status(cn)<>0 then syserror(8);
   rewrite(cn);
end;

procedure getname;			{obtain and set username}

var
  items: [volatile] record		{getjpi descriptor}
                     length: [word] 0..65535;
                     code  : [word] 0..65535;
                     adr   : ^nametype;
                     junk  : integer;
                    end;
  fullnam: [volatile] nametype;
begin
  items.length:=usernamlen;		{set JPI descriptors}
  items.code:=jpi$_username;
  items.adr:=address(fullnam);
  $getjpi(itmlst:=items);		{get the username}
  username:=fullnam;			{assign to non-volatile global}
end;

procedure getuic;			{obtain and set UIC}
var
  items: [volatile] record		{getjpi descriptor}
                     length: [word] 0..65535;
                     code  : [word] 0..65535;
                     adr   : ^integer;
                     junk  : integer;
                    end;
  grp,mem: [volatile] integer;
begin
  items.length:=4;			{set JPI descriptors}
  items.code:=jpi$_grp;
  items.adr:=address(grp);
  $getjpi(itmlst:=items);		{get the group number}
  items.length:=4;			{set JPI descriptors}
  items.code:=jpi$_mem;
  items.adr:=address(mem);
  $getjpi(itmlst:=items);		{get the member number}
  uic.group:=grp;			{assign to non-volatile global}
  uic.member:=mem;
end;

procedure gettty;
type
   termtype= packed array [1..7] of char;	{VMS physical device spec}
var
  items: [volatile] record		{getjpi descriptor}
                     length: [word] 0..65535;
                     code  : [word] 0..65535;
                     adr   : ^termtype;
                     junk  : integer;
                    end;
  ttyname: [volatile] termtype;
begin
  items.length:=7;			{set JPI descriptors}
  items.code:=jpi$_terminal;
  items.adr:=address(ttyname);
  $getjpi(itmlst:=items);		{get the device id}
  if ttyname[ttnamlen]=':' then ttyname[ttnamlen]:=' '; {cut colon}
  thistty:=substr(ttyname,1,ttnamlen)	{normalize name}
end;

procedure settime;			{set current hours and minutes}
					{into global NOW}
var fulltime:datetype;
begin
   time(fulltime);
   now:=substr(fulltime,1,5);           
end;

function convertdate(thisdate:datetype;logtophys:boolean):datetype;

					{convert VMS date format to one which}
					{can be sorted alphabetically or vice}
					{versa (VMS=physical}
					{logical format = yyyy-mcode-dd)}
const
   months='JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';

var
   logdate,physdate:datetype;
   dummy           :linetype;
   whichone        :integer;
   i               :integer;
begin
  if logtophys				{logical to VMS}
     then
      begin
       logdate:=thisdate;		{set logical date}
       for i:=1 to 4 do
        physdate[i+7]:=logdate[i];	{set VMS year} 
       physdate[7]:='-';		{set VMS punctuation}
       physdate[3]:='-';
       for i:=1 to 2 do
        physdate[i]:=logdate[i+9];	{set VMS day}
       whichone:=((ord(logdate[7])-48)*10)+(ord(logdate[8])-48); {index month}
       dummy:=substr(months,whichone,3);{get month from master string}
       for i:=1 to 3 do
        physdate[i+3]:=dummy.body[i];	{set VMS month}
       convertdate:=physdate		{return value}
      end
     else				{VMS to logical}
      begin
       physdate:=thisdate;		{set VMS date}
       for i:=1 to 4 do
        logdate[i]:=physdate[i+7];	{set logical year}
       logdate[5]:='-';			{set logical punctuation}
       logdate[9]:='-';
       for i:=1 to 2 do
        logdate[i+9]:=physdate[i];	{set logical day}
       writev(dummy,index(months,substr(physdate,4,3)):3); {set month index}
       for i:=1 to 3 do
        logdate[i+5]:=dummy.body[i];	{set logical month code}
       convertdate:=logdate		{return value}
      end;
end;

procedure typeanything;			{prompt and wait for any keystroke}
var ch:char;
begin
   gotoxy(23,23);   
   writeln(cc,'+',chr(bell),'Press any key to continue...');
   ch:=getchar
end;

function timeout:boolean;		{display timeout message if needed}
					{return true if timout has occured}
var ch:char;
begin
  if timoutcnt>=timoutmax
    then
     begin
      clearscreen;
      gotoxy(0,5);
writeln(cc,
'+*****************************************************************************'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   This action cannot be completed at this time. Please try again in a     *'
);
writeln(cc,
' *   few minutes...                                                          *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *****************************************************************************'
);
    typeanything;
    timeout:=true
   end
  else
    timeout:=false
end;

function checkconsole:boolean;		{check if terminal can be used}
var
  device: packed array [1..11] of char;	{device name for GETDVI}
  items: [volatile] record		{GETDVI descriptor list}
                     length: [word] 0..65535;
                     code  : [word] 0..65535;
                     adr   : ^integer;
                     junk  : integer;
                    end;
  devtype: [volatile] integer;
begin
  items.length:=4;			{set GETDVI descriptors}
  items.code:=dvi$_devtype;
  items.adr:=address(devtype);
  device:='SYS$OUTPUT:';
  $getdvi(devnam:=device,itmlst:=items);{get terminal code}
  $waitfr(0);				{wait for service completion}
  checkconsole:= (devtype=console);	{check if terminal acceptable}
end;


procedure addtimes(abstime,deltatime:systimtype;VAR newtime:systimtype);
					{add binary delta time to a binary 
					 absolute system time - NB delta times
					 are NEGATIVE!}
begin
  newtime.j:=abstime.j-deltatime.j;	{add high order longwords}
  newtime.i:=abstime.i-deltatime.i;	{add low order longwords}
  if newtime.i>abstime.i		{check for overflow of low longword}
   then
    newtime.j:=newtime.j-1;		{modify high longword if overflowed}
end;

procedure makedateslots(firstslot:char;firstdate:datetype);
					{update dates in date index array-}
					{firstdate is to be in firstslot}
var 
   adddate,fdate,newdate:datetype;
   addtime,systime,newtime:systimtype;
   slot:integer;
begin
   slot:=ord(firstslot)-65;		{slot coding starts at "A"}
   adddate:='1 00:00:00.';  		{VMS delta time for 1 day}
   fdate:=firstdate;			{prepare call for BINTIM}
   $bintim(timbuf:=adddate,timadr:=addtime);	{binary for 1 day}
   $bintim(timbuf:=fdate,timadr:=systime);	{binary for first day}
   while slot <=maxdays do			{do slots: slot..maxdays}
   begin
      $asctim(timbuf:=newdate,timadr:=systime);	{get VMS ASCII date}
      datearray[slot]:=newdate;			{update date index array}
      addtimes(systime,addtime,newtime);	{add a day}
      systime:=newtime;				{reset current date}
      slot:=slot+1;				{do next slot}
   end;
   slot:=1;
   while slot < (ord(firstslot)-65) do		{do slots: 1..original slot}
   begin
      $asctim(timbuf:=newdate,timadr:=systime);	{get VMS ASCII date}
      datearray[slot]:=newdate;			{update date index array}
      addtimes(systime,addtime,newtime);	{add a day}
      systime:=newtime;				{reset current date}
      slot:=slot+1;				{do next slot}
   end;
end;

procedure checkifcurrent;		{check if database is current - if not}
					{then update it - horrible procedure -}
					{don't tinker unless you have to!}
label 5;				{just to make it a little worse...}

var ok:integer;				{file status indicator}
    filtime,				{binary dates}
    systime,
    addtime,
    newtime :systimtype;
    fildate,
    sysdate : packed array [1..22] of char;	{VMS absolute format date/time}
    adddate : varying [11] of char;
    newdate : datetype;
    i:        integer;			{general integer}
    firstsym: char;			{alpha code of first date slot}
    firstdate:datetype;			{date in first date slot}
begin
  repeat
   timoutcnt:=0;			{zero timeout counter}
   repeat				{get reserved $LOCK record from file}
     findk(ttyfile,0,'$LOCK',eql,error:=continue);
     ok := status(ttyfile);
     if ok <> 0 then
          wait;
   until (ok = 0) or (timoutcnt>=timoutmax);	{try until timout or success}
   if timeout then goto 1;			{die gracefully on a timeout}
   if ufb(ttyfile)				{first time ever?}
        then 
          begin					{then initialize $LOCK record}
            ttyfile^.keysym:='$LOCK';		{reserved name}
            ttyfile^.date:=convertdate(today,false);	{todays date}
            ttyfile^.tty:='$OPEN';		{database available}
            ttyfile^.slot[1]:='B        ';	{start with slot "B"}
            put(ttyfile);			{put the record...}
            findk(ttyfile,0,'$LOCK',eql,error:=continue);	{..and lock it}
         end;
   tty:=ttyfile^;				{set current TTY}
   if tty.tty<>'$OPEN'				{database is already being..}
     then					{..updated right now}
       begin
        unlock(ttyfile);			{give up your claim to $LOCK}
        wait;					{hang around a bit}
       end;
   until tty.tty='$OPEN';			{database is available}
   firstdate:=convertdate(tty.date,true);	{set current first date}
   firstsym:=tty.slot[1,1];			{set current first slot}
   if (convertdate(tty.date,true)<>today)	{database is not current}
     then
      begin					{the horrible part...}
        clearscreen;
        writeln(cc,' The database is being updated - please wait!');
        writev(adddate,maxdays);		{BINTIM not like constants!}
        $bintim(timbuf:=adddate,timadr:=addtime);
        ttyfile^.tty:='$LOCK';			{lock the database}
        update(ttyfile);			{tell the other users}
        timoutcnt:=0;
        repeat
          resetk(ttyfile,1,error:=continue);	{reset TTY file}
          ok := status(ttyfile);		{usual lock check garbage}
          if ok <> 0 then
               wait;
        until (ok = 0) or (timoutcnt>=timoutmax);
        if timoutcnt>=timoutmax then goto 5;	{give up if it's locked}
        repeat
          tty:=ttyfile^;			{set current TTY}
          sysdate:=today+' 0:00:00.00';		{set time to midnite}
          fildate:=convertdate(tty.date,true)+' 0:00:00.00';
          $bintim(timbuf:=sysdate,timadr:=systime);
          $bintim(timbuf:=fildate,timadr:=filtime);
          if ((filtime.j<systime.j) or ((filtime.j=systime.j) and
              (filtime.i<systime.i))) and (tty.keysym<>'$LOCK')
		{i.e. this slot is in the past and it is not the reserved...}
		{...$LOCK slot}
           then
            begin
               addtimes(filtime,addtime,newtime);	{compute new time...}
               $asctim(timadr:=newtime,timbuf:=newdate);{...for the slot}
               tty.date:=convertdate(newdate,false);	{code the date}
               for i:=0 to 47 do
                 tty.slot[i]:=blanks9;			{blank all the slots}
               ttyfile^:=tty;				{and update the file}
               update(ttyfile)
            end;
           timoutcnt:=0;
           repeat
             get(ttyfile,error:=continue);		{do sequential reads..}
             ok := status(ttyfile);			{..on all the TTYs}
             if ok <> 0 then
                  wait;
           until (ok = 0) or (timoutcnt>=timoutmax);
           if timoutcnt>=timoutmax then goto 5;		{give up if its locked}
           if ufb(ttyfile)		{loopback in case more days to do...}
            then			{..only happens if not used for a...}
             repeat			{..very long time!}
               resetk(ttyfile,1,error:=continue);	{do another pass}
               ok := status(ttyfile);
               if ok <> 0 then
                    wait;
             until (ok = 0);		{keep trying - why are two people...}
					{..on at once after a month's disuse?}

        until (filtime.j>systime.j) or ((filtime.j=systime.j) and
              (filtime.i>=systime.i));	{until you get a current slot}

        if ttyfile^.keysym='$LOCK'	{reserved record - leave alone}
            then
             begin
               timoutcnt:=0;
               repeat
                 get(ttyfile,error:=continue);
                 ok := status(ttyfile);
                 if ok <> 0 then
                      wait;
               until (ok = 0) or (timoutcnt>=timoutmax);
               if timoutcnt>=timoutmax then goto 5;
             end;

        firstdate:=convertdate(ttyfile^.date,true);	{get first date}
        firstsym:=ttyfile^.keysym[1];			{get first slot code}
        timoutcnt:=0;
        repeat					{get reserved $LOCK record}
          findk(ttyfile,0,'$LOCK',eql,error:=continue);
          ok := status(ttyfile);
          if ok <> 0 then
               wait;
        until (ok = 0) or (timoutcnt>=timoutmax);
        if timoutcnt>=timoutmax then goto 5;	{still OK to give up}
        ttyfile^.date:=convertdate(today,false);{update the $LOCK data}
        ttyfile^.slot[1]:=firstsym+'        ';
        update(ttyfile);			{and the file}
        unlock(ttyfile,error:=continue);   	{give up the record}

5:      repeat					{jump here for aborted update}
          findk(ttyfile,0,'$LOCK',eql,error:=continue);
          ok := status(ttyfile);
          if ok <> 0 then
               wait;
        until (ok = 0);				{no timeout here!!!}
        ttyfile^.tty:='$OPEN';			{open the database}
        update(ttyfile);			{tell the world about it}
   end;
   unlock(ttyfile,error:=continue);		{give up the record}
   makedateslots(firstsym,firstdate);		{set up date index array}
end;

procedure setlimits;			{set limits for different classes}
					{limits set are:}
					{legalslots, lastchance, and leadtime}
var dummytime:linetype;
begin
      if (uic.group <= class1u) and (uic.group >= class1l)
         then
           begin
            legalslots:=max1;
            writev(dummytime,leadtime1:1);
            lastchance:=last1;
           end;
      if (uic.group <= class2u) and (uic.group >= class2l)
         then 
           begin
            legalslots:=max2;
            writev(dummytime,leadtime2:1);
            lastchance:=last2;
           end;
      if (uic.group <= class3u) and (uic.group >= class3l)
         then 
           begin
            legalslots:=max3;
            writev(dummytime,leadtime3:1);
            lastchance:=last3;
           end;
      dummytime:=pad(dummytime,' ',5);
      leadtime:=dummytime
end;

procedure maketermlist;			{build a linked list of terminals}
var term:linetype;
    termold,termlist: termptr;
begin
    new(termroot);			{make a root}
    termroot^.ptr:=NIL;			{define the end of the list}
    termold:=termroot;			{set pointer}
    reset(whowhrfile);			{read WHO.WHR}
    while not eof(whowhrfile) do
     begin
       readln(whowhrfile,term);		{read a terminal description}
       if index(term,'*')<>asterisk	{is it reservable?}
        then				{yes}
         begin
          term:=pad(term,' ',80);	{get a full line}
          new(termlist);		{get a new terminal list entry}
          termold^.ptr:=termlist;	{link it in}
          termold^.data:=term;		{put in the data}
          termlist^.ptr:=NIL;		{terminate the list}
          termlist^.data:=		{dummy data for last item}
'                                                                            ';
          termold:=termlist		{advance pointer}
         end
     end;
end;

function translate(ttycod:ttytype; VAR whereitis:loctype):boolean;
					{provide a location given a code}
					{function returns TRUE if TTY exists}
var term:termptr;
begin
   term:=termroot;			{start at the root}
   while (term^.ptr<>NIL) and (index(term^.data,ttycod)=0) do
      term:=term^.ptr;			{scan list}
   translate:=(term^.ptr<>NIL);		{did we find anything?}
   if term^.ptr=NIL
    then						{no}
       whereitis:='No such terminal!   '		{dummy location}
    else						{yes}
     whereitis:=substr(term^.data,ttnamlen+1,20);	{return the location}
end;

procedure makesymbol(term:linetype; slotnumber:integer; VAR symbol:ttytype);
					{given an integer and a TTY code,}
					{generate a unique symbol}
var ch:char;
begin
   ch:=chr(ord(slotnumber+65));		{convert integer to char}
   term.body[1]:=ch;			{substitute for first char of TTY code}
   symbol:=substr(term,1,ttnamlen)	{make a suitable length code}
end;

procedure myreadln(VAR line:linetype;numbers:boolean:=false);
					{intelligent readln routine - NUMBERS}
					{parameter accepts either alphanumeric}
					{or numeric only - beeps for garbage}
var ch: char;
    count:integer;
    okset: set of char;
begin
  if numbers
    then
      okset:=['0'..'9']			{only accept numbers}
    else
      okset:=['0'..'9','A'..'Z'];	{dont worry about LC - getchar is UC}
  line:='';				{initialize things}
  count:=0;
  repeat
   ch:=getchar;				{get a character}
     if ch in okset			{check it}
      then				{ok?}
        begin				{yes}
          putchar(ch);			{echo it}
          line:=line+ch;		{append it to the line}
          count:=count+1		{update character count}
        end
      else				{no}
        if (ch=chr(del)) or (ch=chr(bs)){allow erasure with either Del or Bs}
         then
           begin       
             if count>0 then		{but not past the left margin!}
               begin
                movecursor(left,1);	{go back}
                putchar(' ');		{delete the character}
                movecursor(left,1);	{back again}
                count:=count-1;		{decrement character count}
                line:=substr(line,1,count);	{remove it from the line}
               end
           end
         else				{try again}
           if ch=chr(esc) 		{esc escapes}
             then
               line:=''			{zap the line}
             else
                begin
                   if ch<>chr(cr)	{return at last?}
                     then
                       begin
                          ch:=chr(bell);{garbage = beep}
                          putchar(ch)
                       end
                end;
   until (ch=chr(cr)) or (ch=chr(esc))	{legal terminators}
end;

procedure getuser;			{update current user}
var i:integer;
begin
  if ufb(userfile) 			{no record for this user}
   then
     begin				{let's make one}
       user.username:=username;		{set up username}
       for i := 1 to maxslots do
        begin
         user.slot[i].date:=blanks11;	{blank the slots}
         user.slot[i].time:=blanks5;
         user.slot[i].tty :=blanks5;
        end;
       write(userfile,user);		{write new user record}
     end
   else
     user:=userfile^;			{update current user from file}
end;

function duplicates: boolean;		{check for duplicate reservations}
var i,j:integer;			{at the same time}
begin
  dupflag:=false;			{assume there are none}
  duplicates:=false;
  for i := 1 to maxslots do		{check all slots against each other}
    for j:= i to maxslots do
     if user.slot[i].date<>blanks11 then
       if  (user.slot[i].date=user.slot[j].date)
       and (user.slot[i].time=user.slot[j].time)
       and (i<>j)
        then dupflag:=true;		{set flag if duplicate found}
  if dupflag then
    begin
     duplicates:=true;			{return function value}
     clearscreen;			{holler at user}
     gotoxy(14,20);
     writeln(cc,'+You have attempted to reserve more than one terminal');
     gotoxy(12,21);
     writeln(cc,'+at the same time. The latest reservation will not be made');
     typeanything;
    end;
end;

procedure mainmenu(VAR Choice:Char);	{menus from here for a bit - no}
					{comments needed - save this one}
					{which looks different the first}
					{time and subsequent times}
var temp:packed array [1..5] of char;
begin
   clearscreen;
   gotoxy(0,0);
if expert
  then
    writeln(cc,'$<MAIN> A)dd, H)elp, R)emove, S)how, Q)uit:')
  else
   begin
writeln(cc,
'+*****************************************************************************'
);
   if first then begin
writeln(cc,
' *                  Vassar College Terminal Reservation System               *'
);
writeln(cc,
' *                  ****** ******* ******** *********** ******               *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *  This program will allow you to reserve one or more half-hour time slots  *'
);
writeln(cc,
' *  on any of the available VAX terminals. You may inspect reservations at   *'
);
   if lastchance=1 
   then
     temp:='hour '
   else
     temp:='hours';
writeln(cc,
' *  any time, and add or remove your reservations up to ',lastchance:1,' ',
                                                          temp,' before the   *'
);
writeln(cc,
' *  time to which they apply.                                                *'
);
   end
     else
   begin
writeln(cc,
' *                                 MAIN Menu                                 *'
);
writeln(cc,
' *                                 **** ****                                 *'
);
   end;
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *  You have the following options:                                          *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *  A)dd     a reservation. You can request a specific time or terminal when *'
);
writeln(cc,
' *           you make the reservation.                                       *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *  R)emove  a reservation.                                                  *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *  S)how    current reservations, either for yourself, or for all users on  *'
);
writeln(cc,
' *           the system - by terminal or date.                               *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *  Q)uit    the terminal reservation program.                               *'
);
writeln(cc,
' *                                                                           *'
);
if not first
   then
     begin
writeln(cc,
' *  X)pert   sets expert mode - switches off help menus like this one.       *'
);
writeln(cc,
' *                                                                           *'
);
     end;
writeln(cc,
' *      Please press the first letter of the option you wish to use...       *'
);
writeln(cc,
' *****************************************************************************'
);
   end;
   repeat
     choice:=getchar;
     if not (choice in ['A','H','R','S','Q','X','@']) then
          putchar(chr(bell));
   until choice in ['A','H','R','S','Q','X','@']
end;

procedure addmenu(VAR choice:char);
begin
   clearscreen;
   gotoxy(0,0);
   if expert
    then
     writeln(cc,'$<ADD> C)ode, D)ate, M)enu, Q)uit, T)ype:')
    else
     begin
   writeln(cc,
' *****************************************************************************'
);
   writeln(cc,
' *                               ADD Menu                                    *'
);
   writeln(cc,
' *                               *** ****                                    *'
);
   writeln(cc,
' *                                                                           *'
);
   writeln(cc,
' *   You have the following options:                                         *'
);
   writeln(cc,
' *                                                                           *'
);
   writeln(cc,
' *   C)ode - reserves a specific terminal at a specific date and time.       *' 
);
   writeln(cc,
' *                                                                           *'
);
   writeln(cc,
' *   D)ate - reserves your choice of terminal at a specific date and time.   *'
);
   writeln(cc,
' *                                                                           *'
);
   writeln(cc,
' *   M)enu - returns you to the Main menu.                                   *'
);
   writeln(cc,
' *                                                                           *'
);
   writeln(cc,
' *   Q)uit - quit the terminal reservation system. Return to VMS.            *'
);
   writeln(cc,
' *                                                                           *'
);
   writeln(cc,
' *   T)ype - reserves a generic terminal type or general location, at your   *'
);
   writeln(cc,
' *           choice of date and time.                                        *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *      Please press the first letter of the option you wish to use...       *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *****************************************************************************'
);
   end;
   repeat
     choice:=getchar;
     if not (choice in ['C','D','M','Q','T']) then
          putchar(chr(bell));
   until choice in ['C','D','M','Q','T'];
end;

procedure showmenu(VAR choice:char);
begin
clearscreen;
   if expert
    then
     writeln(cc,'$<SHOW> D)ate, H)ere, L)ocation, M)enu, N)ames, O)wn, Q)uit:')
    else
     begin
writeln(cc,
'+*****************************************************************************'
);
writeln(cc,
' *                                 SHOW Menu                                 *'
);
writeln(cc,
' *                                 **** ****                                 *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   You have the following options:                                         *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   H)ere        - shows today''s reservations for this terminal.            *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   L)ocation    - shows the reservations for a particular terminal.        *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   M)enu        - return to the main menu.                                 *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   N)ames       - the locations and codes of all reservable terminals .    *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   O)wn entries - shows all current reservations for your username.        *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   Q)uit        - quit the terminal reservation system. Returns to VMS.    *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   D)ate        - shows all reservations for a particular time slot.       *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *      Please press the first letter of the option you wish to use...       *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *****************************************************************************'
);
   end;
   repeat
     choice:=getchar;
     if not (choice in ['H','L','M','N','O','Q','D']) then
          putchar(chr(bell));
   until choice in ['H','L','M','N','O','Q','D'];
end;

procedure secretmenu(VAR choice:char);
begin
  if expert then
writeln(cc,
'$<MAINTAINANCE> B)lock, C)leanup, M)enu, R)emove, S)ystem, T)erm, U)pdate: ')
   else
     begin
writeln(cc,
' *****************************************************************************'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *                            MAINTAINANCE Menu                              *'
);
writeln(cc,
' *                            ************ ****                              *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   The following options are available:                                    *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   B)lock out a systemwide slot (e.g. backups etc...)                      *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   C)leanup user file - delete any users with no reservations              *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   M)enu menu                                                              *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   R)emove a terminal from the system                                      *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   S)ystem reservation - change any user''s reservation.                    *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   T)erminal reservation - block out any terminal for a particular slot.   *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   U)pdate the terminal file to account for new terminals in WHO.WHR       *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *****************************************************************************'
);
end;
         repeat
            choice:=getchar;
            if not (choice in ['B','C','M','R','S','T','U']) then
                 putchar(chr(bell));
         until choice in ['B','C','M','R','S','T','U'];
end;

procedure reservmenu;
begin
  gotoxy(0,17);
writeln(cc,
'+ ******************************************************************************'
);
writeln(cc,
'  *   Use the cursor arrow keys to move to the slot you wish to reserve. Then  *'
);
writeln(cc,
'  *   use one of the following commands:                                       *'
);
writeln(cc,
'  *                                                                            *'
);
writeln(cc,
'  *   R)eserve makes a reservation      U)nreserve cancels a new reservation   *'
);
writeln(cc,
'  *   K)eep    keeps new reservations   A)bandon   abandons new reservations   *'
);
writeln(cc,
'  ******************************************************************************'
);
end;

procedure locmenu(VAR choice:char);
begin
  gotoxy(0,18);
   if expert
    then
     writeln(cc,'$<LOCATION> P)revious day, N)ext day, M)enu:')
    else
     begin
writeln(cc,
'+ ******************************************************************************'
);
writeln(cc,
'  *                    You may use the following commands:                     *'
);
writeln(cc,
'  *                                                                            *'
);
writeln(cc,
'  *        P)revious - shows previous day     N)ext - shows next day           *'
);
writeln(cc,
'  *                      M)enu - returns to the SHOW menu                      *'
);
writeln(cc,
'  ******************************************************************************'
);
   end;
         repeat
            choice:=getchar;
            if not (choice in ['N','P','M']) then
                 putchar(chr(bell));
         until choice in ['N','P','M'];
end;

procedure datemenu(VAR choice:char);
begin
  if expert
    then
     begin
      gotoxy(0,23);
      writeln(cc,'+',' ':75);
      gotoxy(0,22);
      writeln(cc,'$<TIME> P)revious slot, N)ext slot, M)enu:')
     end
    else
     begin
  clearscreen;
  gotoxy(0,2);
writeln(cc,
'+ ******************************************************************************'
);
writeln(cc,
'  *                                                                            *'
);
writeln(cc,
'  *                    You may use the following commands:                     *'
);
writeln(cc,
'  *                                                                            *'
);
writeln(cc,
'  *        P)revious - show previous slot     N)ext - show next slot           *'
);
writeln(cc,
'  *                    M)enu - returns to the previous menu                    *'
);
writeln(cc,
'  *                                                                            *'
);
writeln(cc,
'  ******************************************************************************'
);
     end;
         repeat
            choice:=getchar;
            if not (choice in ['N','P','M']) then
                 putchar(chr(bell));
         until choice in ['N','P','M'];
end;

procedure typemenu(VAR choice:char);
begin
  clearscreen;
   if expert
    then
     writeln(cc,'$<TYPE> N)ext terminal, M)enu:')
    else
     begin
  gotoxy(0,2);
writeln(cc,
'+ ******************************************************************************'
);
writeln(cc,
'  *                                                                            *'
);
writeln(cc,
'  *                    You may use the following commands:                     *'
);
writeln(cc,
'  *                                                                            *'
);
writeln(cc,
'  *            N)ext - show the next terminal with these specifications        *'
);
writeln(cc,
'  *                    M)enu - returns to the previous menu                    *'
);
writeln(cc,
'  *                                                                            *'
);
writeln(cc,
'  ******************************************************************************'
);
   end;
         repeat
            choice:=getchar;
            if not (choice in ['N','M']) then
                 putchar(chr(bell));
         until choice in ['N','M'];
end;

procedure noentries;
var ch:char;
begin
   gotoxy(0,5);
writeln(cc,
'+*****************************************************************************'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *                 You have no reservations made at this time!               *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *****************************************************************************'
);
   typeanything;
end;

procedure noleadtime;
var ch:char;
begin
   clearscreen;
   gotoxy(0,2);
writeln(cc,
'+*****************************************************************************'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *            You may not reserve slots more than ',
               substr(leadtime,1,index(leadtime,' ')-1):2,
               ' days in advance!        *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *****************************************************************************'
);
   typeanything;
end;

procedure nolastchance;
var ch:char;
begin
   clearscreen;
   gotoxy(0,2);
writeln(cc,
'+*****************************************************************************'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *   You may not change reservations within ',
               lastchance:1,
                                             ' hours of the reservation time! *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *****************************************************************************'
);
   typeanything;
end;

procedure entriesfull;
var ch:char;
begin
   clearscreen;
   gotoxy(0,5);
writeln(cc,
'+*****************************************************************************'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *  You have reached your reservation limit - the new reservations on the    *'
);
writeln(cc,
' *  most recent screen have been ignored. You should wait until you have     *'
);
writeln(cc,
' *  used up some reservations, or remove some existing ones before trying    *'
);
writeln(cc,
' *  to reserve further time on the system.                                   *'
);
writeln(cc,
' *                                                                           *'
);
writeln(cc,
' *****************************************************************************'
);
   typeanything;
end;

procedure fixslots;			{back to real code at last! - this one}
					{updates any expired user slots}
var
   slottime,
   abstime:    packed array [1..17] of char;
   filtim,
   systim:     systimtype;
   i:          integer;

begin
   abstime:=today+' '+now;		{set current date/time}
   if not odd($bintim((abstime),systim)) then syserror(12);	{convert it}
   for i:=1 to maxslots do		{check all the user slots}
      begin
        if user.slot[i].date<>blanks11	{only check non-blank slots}
          then
            begin
             slottime:=user.slot[i].date+' '+user.slot[i].time;	{set date/time}
             $bintim((slottime),filtim);			{convert it}
             if (systim.j>filtim.j) 
             or ((systim.j=filtim.j) 
             and (systim.i>filtim.i))	{i.e. slot time is in the past}
               then 
                  begin
                    user.slot[i].date:=blanks11;	{blank the slots}
                    user.slot[i].time:=blanks5;
                    user.slot[i].tty:=blanks5
                  end
            end
      end
end;

function displayslots:integer;	{shows a user's reservations - returns number}
				{of reservations currently held}
var
   ok:integer;
   count:integer;
   location:loctype;
   found:integer;

begin
   timoutcnt:=0;
   repeat
     findk(userfile,0,username,eql,error:=continue);	{get user record}
     ok := status(userfile);
     if ok <> 0 then
          wait;
   until (ok = 0) or (timoutcnt>=timoutmax);
   if timeout then goto 1;				{die gracefully}
   if ufb(userfile) 					{no reservations ever}
      then
        begin
         clearscreen;
         displayslots:=0
        end
      else
         begin
           user:=userfile^;		{get user record}
           settime;			{update current time}
           fixslots;			{update user slots}
           clearscreen;			{and display them}
           gotoxy(0,0);
           writeln(cc,
            '    Reservations held by ',substr(username,1,index(username,' ')),
            'on ',today,' at ',now,':');
           writeln(cc,' ');
           found:=0;			{reservation count}
           for count := 1 to legalslots do	{only check legal slots}
              begin
                 if (user.slot[count].date <> blanks11)
                   then			{we found one!}
                     begin
                       found:=found+1;
                       slotarray[found]:=count;	{update slot index array}
                       translate(user.slot[count].tty,location);
                       writeln(cc,' ',found:2,'. ',
                               user.slot[count].date,'  ',
                               user.slot[count].time,'  ',
                               user.slot[count].tty, '  ',
                               location)
                     end
              end;
            for count:=found+1 to maxslots do	{zero out remaining elements}
               slotarray[count]:=0;
           displayslots:=found
         end
end;

procedure showterms;		{display list of reservable terminals}
				{dumb routine needs no comments}
 var ans:char;
     term:termptr;
     count:integer;
     i:integer;
begin
   clearscreen;
   gotoxy(30,0);
   writeln(cc,'+Reservable terminals:');
   term:=termroot;
   count:=0;
   gotoxy(0,1);
   writeln(cc,
'++-----------------------------------------------------------------------------+'
);
   for i:=2 to 22 do
    begin
      gotoxy(0,i);
      writeln(cc,
'+|                         |                         |                         |'
)
    end;
   gotoxy(0,22);
   writeln(cc,
'++-----------------------------------------------------------------------------+'
);
   while (term^.ptr<>NIL) do
     begin
      gotoxy((count DIV 20)*26,(count mod 20)+2);
      writeln(cc,'+| ',substr(term^.data,1,22):22);
      term:=term^.ptr;
      count:=count+1;
     end;
   typeanything;
end;

procedure gettime(VAR tim:timetype);	{intelligent time entry routine}
					{does not allow illegal times!}
var ch:char;
    count:integer;
    dummy:systimtype;
    oktim:boolean;
    okchars: set of char;
begin
  clearscreen;
  gotoxy(0,0);
  tim:=thetime;				{set default time}
  writeln(cc,'$Enter time in 24-hour format (HH:MM), default is ',tim,' : ');
  count:=0;				{zero character count}
  repeat
    case count of
     0: okchars := ['0','1','2'];	{select legal characters based on}
     1: if tim[1]='2'			{current character count}
         then
           okchars:= ['0'..'3']
         else
           okchars:= ['0'..'9'];
     3: okchars := ['0'..'5'];
     4: okchars := ['0'..'9']
    end;
    ch:=getchar;			{get a character}
    if ch<>chr(cr)			{all done?}
     then
     begin  
       if ch in okchars 		{no - check if legal}
         then
          begin
           count:=count+1;		{legal - increment character count}
           tim[count]:=ch;		{put char in string}
           putchar(ch)			{echo character}
          end
         else
          if (ch<>chr(bs)) and (ch<>chr(del)) then
           putchar(chr(bell));		{garbage - beep}
         if count=2			{add punctuation - magic!}
           then 
             begin
               count:=3;		{increment counter}
               tim[3]:=':';		{put punctuation in string}
               putchar(':');		{and on the screen}
             end;
        if (ch=chr(bs)) or (ch=chr(del)){BS or DEL corrects errors}
        then
         case count of
          1,4: begin			{easy - same trick as mywriteln}
                 putchar(chr(bs));
                 putchar(' ');
                 putchar(chr(bs));
                 count:=count-1
               end;
          0:   putchar(chr(bell));	{past left margin - beep - ignore}
          3:   begin
                 putchar(chr(bs));	{past the colon - double everything}
                 putchar(chr(bs));
                 putchar(' ');
                 putchar(' ');
                 putchar(chr(bs));
                 putchar(chr(bs));
                 count:=count-2
               end;
         end;
     end
  until (count=5) or (ch=chr(cr));	{terminate on CR or adequate count}
					{no problem because last digit not}
					{significant anyway}

  if (tim[1]='2') and (tim[2] in ['4'..'9']) then tim[2]:='3';
					{catch those odd hours between 24 & 29}
  if (tim[4] in ['0'..'2'])		{truncate to nearest half hour}
    then
      begin
        tim[4]:='0';
        tim[5]:='0'
      end;
  if (tim[4] in ['3'..'5'])
    then
      begin
        tim[4]:='3';
        tim[5]:='0'
      end;
end;

procedure getdate(VAR day:datetype);	{intelligent date reader - as gettime}
var ch:char;
    count:integer;
    dummy:systimtype;
begin
 repeat
  clearscreen;
  gotoxy(0,0);
  writeln(cc,'$Enter date (DD-MMM-YYYY), default is ',day,' : ');
  count:=0;
  repeat
    ch:=getchar;			{get a character}
    if ch<>chr(cr)			{not a CR?}
     then
     begin  
      case count of			{process depending on position}
      0,1,7,
      8,9,10:begin			{numeric fields}
              if (count=1) and (ch='-')	{code to make leading 0 optional}
               then			{as long as a "-" is typed}
                begin
                 count:=3;		{simulate a two digit date}
                 putchar(chr(bs));	{erase single digit}
                 putchar(' ');
                 putchar(day[1]);	{move it over one space}
                 putchar('-');		{write the hyphen}
                 day[2]:=day[1];	{update the string}
                 day[1]:='0';		{add simulated 0}
                 day[3]:='-'
                end
               else
              if ch in ['0'..'9'] 	{regular numeric entry}
               then
                begin
                 count:=count+1;	{increment character counter}
                 day[count]:=ch;	{update string}
                 putchar(ch)		{echo the character}
                end
               else
                if (ch<>chr(bs)) and (ch<>chr(del)) then
                 putchar(chr(bell));	{beep for garbage}
               if count=2		{magic auto punctuation}
                 then 
                   begin
                     count:=3;		{update counter}
                     day[3]:='-';	{update string}
                     putchar('-');	{display punctuation}
                   end
             end;
      3,4,5: begin			{ALPHA field (month)}
              if ch in ['A'..'Z'] 
               then
                begin			{ok character}
                 count:=count+1;	{increment counter}
                 day[count]:=ch;	{update string}
                 putchar(ch)		{echo character}
                end
               else
                if (ch<>chr(bs)) and (ch<>chr(del)) then
                 putchar(chr(bell));	{garbage - beep}
               if count=6		{another lot of magic - see above}
                 then 
                   begin
                     count:=7;
                     day[7]:='-';
                     putchar('-');
                   end
             end;
      end;
      if (ch=chr(bs)) or (ch=chr(del))	{deletions}
        then
         case count of
          1,4,5,8,9,10: begin			{single character}
                          putchar(chr(bs));
                          putchar(' ');
                          putchar(chr(bs));
                          count:=count-1
                        end;
          0:            putchar(chr(bell));	{past left margin - beep}
          3,7:          begin			{over a hyphen}
                          putchar(chr(bs));
                          putchar(chr(bs));
                          putchar(' ');
                          putchar(' ');
                          putchar(chr(bs));
                          putchar(chr(bs));
                          count:=count-2
                        end;
         end;
   end
  until (count=11) or (ch=chr(cr));		{terminate on full count}
  if day[1]='0' then day[1]:=' ';		{convert date to standard VMS}
  if not odd($bintim(day,dummy))		{check if date is legal}
        then 
          begin
            gotoxy(23,21);
            writeln(cc,'+',chr(bell),'Illegal date specification!');
            typeanything
          end
 until odd($bintim(day,dummy))			{keep trying until it is}
end;

function checkleadtime:boolean;		{check if reservation is within an}
					{illegal time slot - too far ahead}
var
  testtime,systime,addtime,newtime:systimtype;
  adddate:timetype;
begin
  $bintim(timbuf:=today,timadr:=systime);	{convert times to binary}
  $bintim(timbuf:=leadtime,timadr:=addtime);
  addtimes(systime,addtime,newtime);		{make lastest legal time}
  $bintim(timbuf:=thedate,timadr:=testtime);	{convert time to be checked}
  if ((newtime.j>testtime.j) or ((newtime.j=testtime.j) and
              (newtime.i>=testtime.i)))
    then
     checkleadtime:=true		{time is before latest legal time}
    else
     begin
      noleadtime;			{no such luck}
      checkleadtime:=false
     end
end;

function checklastchance(day:datetype;tim:timetype):boolean;
					{check if reservation is within an}
					{illegal time slot - too soon}
var sysdate,testdate:packed array[1..17] of char;
    adddate:packed array [1..7] of char;
    systime,addtime,newtime,testtime:systimtype;
    line:linetype;
begin
   settime;				{update current time}
   date(today);				{and date}
   sysdate:=today+' '+now;		{make a VMS absolute time}
   testdate:=day+' '+tim;		{and one to be tested}
   writev(line,'0 ',lastchance:1,':00 ');	{make VMS delta time}
   adddate:=substr(line,1,7);		{for LASTCHANCE hours}
   $bintim(timbuf:=sysdate,timadr:=systime);	{convert everything to binary}
   $bintim(timbuf:=adddate,timadr:=addtime);
   $bintim(timbuf:=testdate,timadr:=testtime);	
   addtimes(systime,addtime,newtime);	{set earliest legal time}
   if (newtime.j<testtime.j) or ((newtime.j=testtime.j) and
      (newtime.i<=testtime.i))
       then
        checklastchance:=true		{time is legal}
       else
        begin
         nolastchance;			{no such luck}
         checklastchance:=false
        end
end;

procedure unlockfiles;			{unlock any locked records}
begin
   unlock(ttyfile,error:=continue);
   unlock(userfile,error:=continue);
end;

procedure updatefiles;			{Update TTYFILE from TTY and}
					{       USERFILE from USER}
					{all normal updates to files made here}
label 2;
var ok:integer;				{file status indicator}

begin
  if not duplicates			{don't register duplicate bookings}
    then
     begin
       timoutcnt:=0;
       resetk(userfile,0,error:=continue);	{don't know why, but things}
					{crash without this statement, even}
					{though it does absolutely nothing!}
       repeat				{find the record}
         findk(userfile,0,user.username,eql,error:=continue);
         ok:=status(userfile);
         if ok<>0 then wait
       until (ok=0) or (timoutcnt>=timoutmax);
       if timeout then goto 2;		{give up on a timeout}
       if ufb(userfile) then syserror(14);	{must be there at this point}
       timoutcnt:=0;
       resetk(ttyfile,0,error:=continue);	{same thing for TTYfile}
       repeat
         findk(ttyfile,0,tty.keysym,eql,error:=continue);
         ok:=status(ttyfile);
         if ok<>0 then wait
       until (ok=0) or (timoutcnt>=timoutmax);
       if timeout then goto 2;
       if ufb(ttyfile) then syserror(15);
       if ttyfile^.date=tty.date		{hope midnite didn't intervene}
        then
         begin
           userfile^:=user;			{update file pointers}
           ttyfile^:=tty;
           update(ttyfile,error:=continue);	{update the files}
           if status(ttyfile)<>0 then syserror(16);
           update(userfile,error:=continue);
           if status(userfile)<>0 then syserror(17);
         end
        else
          begin					{midnite got in the way!}
           timoutcnt:=timoutmax;		{simulate a timeout}
           timeout;				{and holler}
          end;
      end;
2: unlockfiles;				{whatever happens don't hold onto the}
					{locked records!}
end;

function readtty(ttycode:ttytype;day:datetype;retry:boolean:=false): integer;
					{nasty routine to get a particular}
					{TTY record from the file. Would be}
					{nicer to do sequential gets if}
					{PASCAL didn't get stuck on locked}
					{records!}
					{RETRY parameter determines if locked}
					{records will be retried}
					{function returns status codes - see}
					{below}

var prefixnumber:integer;
    i:integer;
    ttysym:ttytype;
    ok:integer;
begin
   prefixnumber:=-1;			{impossible ASCII character}
   for i:=1 to maxdays do		{find the current slot code prefix}
    if datearray[i]=day			{inefficient, but runs faster than}
      then prefixnumber:=i;		{a while loop!}
   if prefixnumber>0 then		{is this a real date?}
    begin				{yes}
     ttysym:=ttycode;			{make up the slot code}
     ttysym[1]:=chr(prefixnumber+65);
     if retry				{regular technique to find a record}
       then				{and wait in case of a lock}
         begin
           timoutcnt:=0;
           repeat
            findk(ttyfile,0,ttysym,eql,error:=continue);
            ok := status(ttyfile);
            if ok <> 0 then
                 wait;
           until (ok = 0) or (timoutcnt>=timoutmax);
          if timeout then goto 1;
         end
       else				{no retries...}
         begin				{bit of a cheat - 10 retries are still}
          i:=0;				{done in case of simultaneous scans}
          repeat			{delay is minimal}
            findk(ttyfile,0,ttysym,eql,error:=continue);
            ok := status(ttyfile);
            i:=i+1;
          until (ok = 0) or (i>=10);
         end;
     readtty:=0;			{return code - 0 = successful return}
     if ufb(ttyfile) then readtty:=1;	{return code - 1 = no such record}
     if ok<>0 then readtty:=2;		{return code - 2 = record locked}
     tty:=ttyfile^			{set TTY to new value}
    end
   else
    readtty:=1				{no such record}
end;

function showtty(ttycode:ttytype;day:datetype;retry:boolean:=true):boolean;
					{shows reservations for a given TTY}
					{retry parameter is passed to GETTTY}
					{function returns TRUE if successful}
var found:boolean;
    i:    integer;
    slot: integer;
    minutes: packed array [1..2] of char;
    location:loctype;
    ok: integer;
    readstatus:integer;
begin
   clearscreen;
   translate(ttycode,location);		{get the location}
   gotoxy(0,0);
   writeln(cc,
           '+Terminal reservations for ',ttycode,'- ',location,day,':');
   timoutcnt:=0;
   readstatus:=readtty(ttycode,day,retry:=retry);	{try read the file}
   if readstatus=0
    then
      begin				{successful read}
       showtty:=true;			{set return value}
       if day=today			{show expired slots for today}
        then
          begin
           settime;			{update current time}
           slot:=(((ord(now[1])-48)*10)+(ord(now[2])-48))*2;{set current slot}
           if ord(now[4])>50 then slot:=slot+1;	{remember the 1/2 hours!}
           for i:=0 to slot-1 do
              tty.slot[i]:=past;	{print "expired" if time is past}
          end;
       gotoxy(0,2);			{draw top of box}
       writeln(cc,'+',
'+------------------------------------------------------------------------------+');
       for i:=0 to 47 do		{convert slots to times}
        begin
         if odd(i) 
          then
           minutes:='30'		{odd slots are half hours}
          else
           minutes:='00';		{even slots are hours}
         gotoxy(((i DIV 12)*20),(i mod 12)+3);
         writeln(cc,'+| ',(i div 2):2,':',minutes,' ',tty.slot[i]);
        end;
        for i:=3 to 14 do		{draw right side of box}
          begin
            gotoxy(79,i);
            writeln(cc,'+|');
          end;				{draw bottom of box}
       writeln(cc,' ',
'+------------------------------------------------------------------------------+');
      end
    else
     begin
      showtty:=false;			{couldn't do it!}
      clearscreen;
      case readstatus of
      1: begin
          gotoxy(14,21);
          writeln(cc,'+',chr(bell),
              'This date is not in the current reservation period!')
         end;
      2: begin
          gotoxy(14,21);
          writeln(cc,'+',chr(bell),
              'Please wait a few minutes and retry this operation!')
         end;
      end;
      typeanything;
      clearscreen
     end
end;

procedure reservit(ttycode:ttytype;day:datetype);
					{makes a terminal-specific reservation}
					{by moving cursor over screen painted }
					{by SHOWTTY}
var
  x,y,slot,ok:integer;
  choice:char;
  dummy:linetype;
begin
  x:=0; y:=0;				{top left corner}
  reservmenu;				{tell us what to do at bottom}
  gotoxy(8,3);
  timoutcnt:=0;
  repeat  				{get our user record}
    findk(userfile,0,username,eql,error:=continue);
    ok:=status(userfile);
     if ok<>0 then wait;
  until (ok=0) or (timoutcnt>=timoutmax);
  if timeout then goto 1;		{die gracefully if it's locked}
  getuser;				{set TTY to current user}
  repeat
    repeat
       choice:=getchar;			{get a keypress}
       choice:=cursorcontrol(choice);	{check if it's a cursor arrow}
       if not (choice in ['K','A','R','U','u','d','l','r']) then
            putchar(chr(bell));		{beep if illegal}
    until choice in ['K','A','R','U','u','d','l','r'];
    case choice of
     'u': if y>0 			{up - if not already at top}
           then
            begin
             movecursor(up,1);
             y:=y-1;
            end
           else
            putchar(chr(bell));
     'd': if y<11 			{down - if not already at bottom}
           then
             begin
              movecursor(down,1);
              y:=y+1;
             end
           else
            putchar(chr(bell));
     'r': if x<3			{right - etc.}
           then
            begin
             movecursor(right,20);
             x:=x+1;
            end
           else
            putchar(chr(bell));
     'l': if x>0 			{left - etc.}
          then
           begin
            movecursor(left,20);
            x:=x-1;
           end
          else
           putchar(chr(bell));
     'K': updatefiles;			{exit and save}
     'A': {abandon};			{exit and don't save}
     'R': begin				{reserve a slot}
           if tty.slot[(x*12)+y]=blanks9	{check if it's not reserved}
            then
             begin
              settime;			{update current time}
              fixslots;       		{update user's slots}
              slot:=1;
              while (slot<=legalslots) and (user.slot[slot].date<>blanks11) do
                slot:=slot+1;		{try find an empty slot}
              if slot<=legalslots	{empty slot available}
                 then
                   begin
                     if odd(y)		{convert slot # to minutes}
                         then
                            writev(dummy,(y div 2)+(x*6):2,':30')
                         else
                            writev(dummy,(y div 2)+(x*6):2,':00');
                     if checklastchance(thedate,substr(dummy,1,5))
                      then
                       begin		{not too close}
                        gotoxy((x*20)+8,y+3);
                        writeln(cc,'+',username);	{display reservation}
                        gotoxy((x*20)+8,y+3);		{go back!}
                        tty.slot[(x*12)+y]:=username;	{update tty slot}
                        user.slot[slot].date:=day;	{update user slots}
                        user.slot[slot].time:=substr(dummy,1,5);
                        user.slot[slot].tty:=ttycode;
                      end
                     else
                      choice:='A'	{abort on an illegal reservation}
                   end
                 else
                   begin     
                     entriesfull;	{maximum reservations for user}
                     choice:='A'
                   end
             end
            else
             putchar(chr(bell));	{illegal reservation}
          end;
     'U': begin				{unreserve - delete}
           if tty.slot[(x*12)+y]=username	{only delete your own!}
            then
             begin
              if odd(y)			{usual odd-even trick}
               then
                  writev(dummy,(y div 2)+(x*6):2,':30')
               else
                  writev(dummy,(y div 2)+(x*6):2,':00');
              if checklastchance(thedate,substr(dummy,1,5))	{not too close}
               then
                begin
                 gotoxy((x*20)+8,y+3);	{position to erase reservation}
                 writeln(cc,'+',blanks9);	{erase it}
                 gotoxy((x*20)+8,y+3);	{go back again}
                 tty.slot[(x*12)+y]:=blanks9;	{erase tty slot}
                 slot:=1;
                 while (slot<=legalslots) 	{look for same user slot}
                    and ((user.slot[slot].date<>day)
                    or (user.slot[slot].tty<>ttycode)
                    or (user.slot[slot].time<>substr(dummy,1,5))) do
                      slot:=slot+1;
                    user.slot[slot].date:=blanks11;	{and blank it}
                    user.slot[slot].time:=blanks5;	
                    user.slot[slot].tty:=blanks5;
               end
              else
               choice:='A'			{quit on illegal deletion}
             end
            else
             putchar(chr(bell));		{can't delete if not yours!}
          end
    end;
 until choice in ['K','A'];
 unlockfiles;					{don't hog any records!}
end;

function addbycode(showonly:boolean):boolean;
					{reserves or displays a particular}
					{terminal. SHOWONLY parameter}
					{determines which} 
var choice,ans:char;
    dummy:loctype;
    line: linetype;
    oktoreserve:boolean;
begin
   repeat
    clearscreen;
    writeln(cc,'$Do you want to see a list of available terminals?');
    ans:=getchar;
    if ans='Y'				{default to NO}
        then
          showterms;			{display a listing}
    clearscreen;
    writeln(cc,'$Please enter the terminal code (e.g. ',thistty,') ');
    myreadln(line);			{get a tty code}
    if((length(line)<4) or (length(line)>ttnamlen)) and 
      (length(line)<>0)
       then
         begin				{illegal terminal code}
           gotoxy(20,21);
           writeln(cc,'+Illegal format for terminal code!',chr(bell));
           typeanything;
         end
   until ((length(line)>3) and (length(line)<=ttnamlen)) or
         (length(line)=0);		{acceptable or null}
   if length(line)>0 then		{quit if null}
    begin
     line:=pad(line,' ',ttnamlen);	{make sure it's long enough}
     ttykind:=substr(line,1,ttnamlen);	{but not too long!}
     if translate(ttykind,dummy)	{check if it exists}
      then
        begin
         addbycode:=true;		{return success}
         getdate(thedate);		{read a date}
         if not showonly		{if a reservation, check leadtime}
          then oktoreserve:=checkleadtime
          else oktoreserve:=true;	{otherwise go ahead}
         if oktoreserve
          then				{show terminal}
           if (showtty(ttykind,thedate)) and (not showonly)
             then
               reservit(ttykind,thedate){and reserve it}
             else 
               unlockfiles		{make sure you dont hog the records}
        end               
      else				{no such terminal}
       begin
        clearscreen;
        addbycode:=false;		{return failure}
        gotoxy(14,21);
        writeln(cc,'+This terminal is not part of the reservation system!');
        typeanything
       end
    end
   else
    addbycode:=false;			{no terminal requested}
end;

procedure addbydate(showonly:boolean);
					{reserve or display at a given}
					{time/date. Parameter SHOWONLY}
					{determines which}
label 3;
var
   day: datetype;
   tim: timetype;
   slot:integer;
   count:integer;
   location:loctype;
   line:linetype;
   number:integer;
   ttycode:ttytype;
   i:integer;
   ok:integer;
   okday,oktoreserve,reserved:boolean;
   choice:char;
   nowslot,tmpslot:integer;

procedure confirm;			{confirms a reservation - trivial}
begin
   clearscreen;
   gotoxy(5,3);
   writeln(cc,'+Reservation made for ',substr(username,1,index(username,' ')),
           'to use ',tty.tty,'on ',day,
           ' at ',tim);
   typeanything
end;

procedure reservbydate;			{makes a reservation - non-trivial!}
begin
  reserved:=false;			{no reservation yet}
  repeat 
    gotoxy(0,23);			{clean up the input line}
    writeln(cc,'+',' ':75);
    gotoxy(0,22);
    writeln(cc,'$Reserve which number? (press <esc> key to quit): ');
    myreadln(line,numbers:=true);	{read a numeric string}
    if length(line)=1			{single digit?}
     then
       number:=ord(line.body[1])-48	{convert it}
     else
      if length(line)>1			{2 digits}
       then				{convert them - ignore anything else}
         number:=((ord(line.body[1])-48)*10)+(ord(line.body[2])-48);
    if (length(line)>0) and (number>0) and (number<=maxterms)
     then				{we have a legal reservation}
      if timearray[number]<>blanks5	{and it's not reserved already}
       then
         begin 
          timoutcnt:=0;			{find TTYfile record}
          repeat
            findk(ttyfile,0,timearray[number],eql,error:=continue);
            ok := status(ttyfile);
            if ok <> 0 then
                 wait;
          until (ok = 0) or (timoutcnt>=timoutmax);
          if timeout then goto 1;
          tty:=ttyfile^;		{set TTY to current record}
          if tty.slot[slot]=blanks9	{is it not reserved}
            then			{...in case someone slunk in the gap!}
             begin 
              settime;			{update current time}
              fixslots; 		{update user slots}
              i:=1;
              while (i<=legalslots) and (user.slot[i].date<>blanks11) do
                 i:=i+1;			{look for a free slot}
              if i<=legalslots		{did we find one?}
               then
                begin 
                  tty.slot[slot]:=username;	{fill TTY slot}
                  user.slot[i].date:=day;	{fill USER slots}
                  user.slot[i].time:=tim;
                  user.slot[i].tty:=tty.tty;
                  updatefiles;			{tell the world}
                  reserved:=true;		{and set the flag}
                end 
              else
                 begin 				{user full up}
                  unlockfiles;			{let go your records}
                  entriesfull;			{and holler}
                  goto 3;			{get out}
                 end; 
           end 
       end 
  until (length(line)=0) or (reserved);		{wait for a legal entry}
  if reserved and (not dupflag) then confirm;	{confirm if needed}
end;

procedure displaybydate;
					{routine shows free terminals for}
					{a given time slot}
var term:termptr;
    number:integer;
    i:integer;
begin
  clearscreen;
  gotoxy(16,0);
  writeln(cc,'+Free terminals for the ',tim,' slot on ',day,':');
  gotoxy(0,1);				{draw the top}
  writeln(cc,
'++-----------------------------------------------------------------------------+'
);
  for i:=2 to 22 do			{draw the bars}
   begin
     gotoxy(0,i);
     writeln(cc,
'+|                         |                         |                         |')
   end;
  gotoxy(0,22);				{draw the bottom}
  writeln(cc,
'++-----------------------------------------------------------------------------+'
);
  slot:=(((ord(tim[1])-48)*10)+(ord(tim[2])-48))*2;	{compute slot #}
  if ord(tim[4])>50 then slot:=slot+1;			{remember 1/2 hours}
  for number:=1 to maxterms do
    timearray[number]:=blanks5;		{init the time array}
  count:=0;				{number of free terminals found}
  number:=0;				{unique terminal number}
  term:=termroot;			{set pointer to root of list}
  while (term^.ptr<>nil) do		{scan list}
   begin
      number:=number+1;
      if readtty(substr(term^.data,1,ttnamlen),day,retry:=false)=0 then
        begin 				{successful read (no retries)}
         if day=today			{check for past slots}
           then
            begin
             nowslot:=(((ord(now[1])-48)*10)+(ord(now[2])-48))*2;
             if ord(now[4])>50 then nowslot:=nowslot+1;
             if slot<nowslot		{is the slot in the past}
              then
                tty.slot[slot]:=past	{mark it "expired"}
            end;
         if (tty.slot[slot]=blanks9)	{slot available}
           then
            begin 
             translate(tty.tty,location);	{get location}
             gotoxy((count DIV 20)*26,(count mod 20)+2);	{write it}
             writeln(cc,'+| ',number:2,'. ',location);
             timearray[number]:=tty.keysym;	{put symbol in index array}
             count:=count+1			{increment free count}
            end; 
        end; 
      term:=term^.ptr;				{advance pointer}
   end;
   if count=0 				{no free terminals}
     then
       begin 
        gotoxy(17,21);
        writeln(cc,'+There are no free terminals in this time slot!');
        typeanything
       end 
end;

begin {addbydate}
  timoutcnt:=0;
  repeat  
    findk(userfile,0,username,eql,error:=continue);	{get user record}
    ok:=status(userfile);
     if ok<>0 then wait;
  until (ok=0) or (timoutcnt>=timoutmax);
  if timeout then goto 1;
  getuser;					{update USER from file}
  getdate(thedate);				{get the required date}
  day:=thedate;  				{avoid changing global default}
  if not showonly
   then
    oktoreserve:=checkleadtime			{check leadtime if reserving}
   else
    oktoreserve:=true;				{else go ahead anyway}
  if oktoreserve
     then
      begin
       okday:=false;				{assume date is illegal}
       for i:=1 to maxdays do			{check them all}
         if datearray[i]=day
           then okday:=true;			{pleasant surprise if it's ok}
       if okday
         then
          begin
           gettime(tim);			{ask for a time}
           if not showonly
            then
             oktoreserve:=checklastchance(day,tim)	{see if not too late}
            else
             oktoreserve:=true;			{don't bother if just display}
           if oktoreserve then
           repeat
             displaybydate;			{show the slot}
             unlockfiles;			{and give up the records}
             if (not showonly) and (count>0)	{reserve if anything there}
               then
                 reservbydate
               else
                 if showonly and (not expert)	{experts get a different menu}
                   then
                      typeanything;
             tmpslot:=(((ord(tim[1])-48)*10)+(ord(tim[2])-48))*2;
					{convert time to slot #}
             if ord(tim[4])>50 then tmpslot:=tmpslot+1;	{remember 1/2 hours}
             datemenu(choice);		{show menu}
             case(choice) of
               'N': if tmpslot<47	{next slot - if still the same day}
                     then
                       tmpslot:=tmpslot+1	{increment slot number}
                     else
                       begin
                         clearscreen;
                         gotoxy(20,21);
                         writeln(cc,'+You cannot move to a new day in this mode!');
                         typeanything;
                         choice:='M'	{force exit to menu}
                       end;
               'P': if tmpslot>0	{previous slot - if still same day}
                     then
                       tmpslot:=tmpslot-1	{decrement slot number}
                     else
                       begin
                         clearscreen;
                         gotoxy(20,21);
                         writeln(cc,'+You cannot move to a new day in this mode!');
                         typeanything;
                         choice:='M'	{force exit to menu}
                       end;
               'M': {menu};		{dummy for exit purposes}
             end;
             tim[1]:=chr((tmpslot div 20)+48);	{convert slot to time}
             tim[2]:=chr(((tmpslot div 2) mod 10)+48);
             if odd(tmpslot)
               then
                 tim[4]:='3'
               else
                 tim[4]:='0';
             thetime:=tim;		{update default time}
           until choice='M'
         end
        else
         begin 
          gotoxy(14,21);
          writeln(cc,'+',chr(bell),
                  'This date is not in the current reservation period!');
          typeanything;
         end;
   end;
3:;					{exit from whole business}
end; 

procedure addbytype;
					{reserve terminal by generic type}
var choice,ans:char;
    dummy:loctype;
    line,test: linetype;
    term:termptr;
    i:integer;
    matches:boolean;
    firstflag:boolean;
begin
   matches:=false;			{no terminals matched yet}
   firstflag:=true;
   clearscreen;
   writeln(cc,'$Enter a terminal type or general location:');
   myreadln(line);
   if length(line)>0 then		{quit on null string}
    begin
      term:=termroot;			{start at root of terminal list}
      test:=term^.data;			{get first data - don't modify list!}
      for i:=1 to length(test) do
         if test.body[i] in ['a'..'z']
           then test.body[i]:=chr(ord(test.body[i])-32); {convert to U.C}
      repeat
         while (term^.ptr<>NIL) and (index(test,line)=0) do
            begin			{search for matching terminal}
             term:=term^.ptr;		{advance pointer}
             if term^.ptr<>NIL		{still more?}
               then
                begin
                  test:=term^.data;	{as before}
                  for i:=1 to length(test) do
                     if test.body[i] in ['a'..'z']
                       then test.body[i]:=chr(ord(test.body[i])-32)
                end;
            end;
         if term^.ptr<>NIL		{found a match}
          then
            begin
             matches:=true;		{set the flag}
             ttykind:=substr(term^.data,1,ttnamlen);	{get tty code}
             if firstflag then getdate(thedate);	{ask for date once}
             if checkleadtime			{check if legal date}
               then
                 begin
                   firstflag:=false;		{don't ask for date again}
                   IF (showtty(ttykind,thedate,retry:=false)) {show terminal}
                     then
                       reservit(ttykind,thedate);	{and reserve it}
                   typemenu(choice);
                 end
            end               
          else
           begin			{no matches [any more]}
            gotoxy(17,21);
            if matches
             then
              writeln(cc,'+No more terminals match specifications!')
             else
              writeln(cc,'+No terminal matches this specification!');
            typeanything
           end;
        test:='XYZZY';				{to phase the tester!}
      until (term^.ptr=NIL) or (choice='M')
    end
end;

procedure add;
					{master ADD routine - called from}
					{ main menu}
var choice:char;
begin
  repeat
   addmenu(choice);
   clearscreen;
   case choice of
   'C' : addbycode(showonly:=false);
   'D' : addbydate(showonly:=false);
   'M' : {main menu};
   'Q' : selection:='Q';
   'T' : addbytype;
   end
 until choice in ['M','Q']
end;

procedure remove;
					{REMOVE routine - called from}
					{ main menu}
var
  line:linetype;
  number:integer;
  displayed:integer;
  slot:integer;
  timeslot:integer;
  count:integer;
  found:boolean;
  ok:integer;
begin
 repeat
  displayed:=displayslots;		{show current reservations}
  if displayed>0 then			{are there any?}
   begin				{yes}
     gotoxy(0,22);
     writeln(cc,'$Remove which number? (press <esc> key to quit): ');
     myreadln(line,numbers:=true);	{get numeric string}
     if length(line)=1			{convert to an integer}
      then
        number:=ord(line.body[1])-48
      else
       if length(line)>1
        then
          number:=((ord(line.body[1])-48)*10)+(ord(line.body[2])-48);
					{ignore characters after the 2nd}
     if (length(line)>0) and (number>0) and (number<=displayed)
      then
       begin				{remove a reservation}
        slot:=slotarray[number];	{get index from index array}
        readtty(user.slot[slot].tty,user.slot[slot].date,retry:=true);
					{get the appropriate TTY record}
        if user.slot[slot].time[1]=' ' then user.slot[slot].time[1]:='0';
					{normalize the time field}
        timeslot:=(((ord(user.slot[slot].time[1])-48)*10)+
                  (ord(user.slot[slot].time[2])-48))*2;	{compute TTY slot}
        if ord(user.slot[slot].time[4])>50 then timeslot:=timeslot+1;
        user.slot[slot].date:=blanks11;	{blank everything}
        user.slot[slot].time:=blanks5;
        user.slot[slot].tty:=blanks5;
        tty.slot[timeslot]:=blanks9;
        updatefiles;			{and update it}
       end
   end
  else
   begin				{no reservations to delete}
     noentries;
     unlockfiles
   end
 until (length(line)=0) or (displayed=0)
end;

procedure show;
					{main routine to show reservations}
var
   choice:char;
   dummy:loctype;

procedure showbyloc;
					{show reservations for specific TTY}
var which:char;
    whichdate,addday:datetype;
    bindate,adddate,newdate:systimtype;
begin
  if addbycode(showonly:=true)		{show particular tty}
    then
  repeat
     locmenu(which);
     addday:='1          ';		{VMS delta time for 1 day}
     $bintim(timadr:=adddate,timbuf:=addday);	{get binary times}
     $bintim(timadr:=bindate,timbuf:=thedate);
     case which of
      'N':begin				{next day}
             addtimes(bindate,adddate,newdate);	{add a day}
             $asctim(timbuf:=whichdate,timadr:=newdate);	{VMS abs time}
             showtty(ttykind,whichdate);	{show next TTY}
             unlockfiles;			{and give up records}
             thedate:=whichdate;		{update default date}
          end;
      'P':begin				{previous day}
             newdate.j:=bindate.j+adddate.j;	{inline code of "subtimes"}
             newdate.i:=bindate.i+adddate.i;	{since this only happens once}
             if newdate.i<bindate.i		{compare with "addtimes" above}
                then newdate.j:=newdate.j+1;
             $asctim(timbuf:=whichdate,timadr:=newdate);	{VMS abs time}
             showtty(ttykind,whichdate);	{show next TTY}
             unlockfiles;			{give up records}
             thedate:=whichdate;		{update default date}
          end;
      'M': {menu}				{fake value to get out}
     end;
  until which = 'M'
end;

procedure showhere;
				{show this terminal today}
begin
  if translate(thistty,dummy)	{check if this terminal is reservable}
   then
    begin
     showtty(thistty,today);	{yes - show it}
     unlockfiles;		{give up the records}
     typeanything
    end
   else
    begin
     clearscreen;
     gotoxy(16,21);
     writeln(cc,
             '+This terminal is not in the reservation system!');
     typeanything
    end
end;

begin
   repeat
     showmenu(choice);
     case choice of
       'H' : showhere;
       'L' : showbyloc;
       'M' : {main menu};		{drop out to main menu}
       'N' : showterms;
       'O' :  if displayslots=0 
                 then 
                   noentries
                 else
                   typeanything;
       'Q' : selection:='Q';		{alter global and ascend to Nirvana}
       'D' : addbydate(showonly:=true);
     end
   until choice in ['M','Q']
end;

procedure secret;
					{maintainance routines - you don't}
					{expect these to be pretty - they}
					{are worse than that!}
					{access to these is via the magic}
					{"@" key in the main menu - coupled}
					{with the magic UIC [1,4]}
					{both use and perusal by the faint-}
					{hearted not recommended!}

var ch,choice :char;			{semi-globals!}
    line,term: linetype;
    ttykind,symbol:ttytype;
    slot,ok,i,j: integer;
    sysdate,fildate,plusdate: systimtype;
    adddate: varying [2] of char;
    addday: packed array [1..2] of char;
    day,newdate : datetype;
    dummy:loctype;
    found:boolean;
    tim:timetype;

procedure blockbook;
					{reserves a block for the system}
label 4;
var erase:boolean;
    testtim:timetype;
begin
 repeat
  clearscreen;				{all systems people are experts!}
  writeln(cc,'$<BLOCK> R)eserve a block, E)rase a block reservation, M)enu');
     repeat
      ch:=getchar;
     until ch in ['E','R','M'];
  if ch='M' then goto 4;		{avoid a long nasty IF statement}
  erase:=(ch='E');			{set erase flag}
  getdate(thedate);			{get a date}
  day:=thedate;  			{take a local copy}
  timoutcnt:=0;
  repeat				{get first TTY record for this day}
    findk(ttyfile,1,convertdate(day,false),eql,error:=continue);
    ok := status(ttyfile);
    if ok <> 0 then
         wait;
  until (ok = 0) or (timoutcnt>=timoutmax);	{still OK to timeout here}
  if timeout then goto 1;
  if not (ufb(ttyfile))			{is there such a day?}
    then
     begin
      gettime(tim);			{get time for booking}
      thetime:=tim;			{set default time}
      writeln(cc,' ');
      writeln(cc,'$Updating - please wait...');
      slot:=(((ord(tim[1])-48)*10)+(ord(tim[2])-48))*2;	{convert time to slot#}
      if ord(tim[4])>50 then slot:=slot+1;		{remember 1/2 hours}
      while (ttyfile^.date=convertdate(day,false)) and (not ufb(ttyfile)) do
       begin 				{get all TTYS for this date}
        if (ttyfile^.keysym<>'$LOCK')	{avoid changing reserved record}
          then
           begin 
            if erase 			{set values accordingly}
             then
              ttyfile^.slot[slot]:=blanks9	{delete}
             else
              ttyfile^.slot[slot]:=sysres;	{reserve}
            repeat
              resetk(userfile,0,error:=continue);	{check userfile}
              ok := status(userfile);
              if ok <> 0 then
                wait;
            until (ok = 0);			{no timeouts from here on!}
            while not ufb(userfile) do		{check all users on the system}
             begin				{and alter records if need be}
              found:=false;
              for i:= 1 to maxslots do		{check each user slot}
              begin
               testtim:=userfile^.slot[i].time;	{user time to check}
               if (testtim[1]=' ') then
                     testtim[1]:='0';		{normalize time}
               if (userfile^.slot[i].tty=ttyfile^.tty) and
                   (userfile^.slot[i].date=day) and
                   (testtim=tim)		{if this one is booked}
                then
                  begin
                    found:=true;		{set found flag}
                    userfile^.slot[i].date:=blanks11;	{blank all user slots}
                    userfile^.slot[i].time:=blanks5;
                    userfile^.slot[i].tty:=blanks5;
                  end;
               end;
               if found 			{only bother updating if found}
                   then
                     update(userfile,error:=continue);
               repeat
                get(userfile,error:=continue);	{sequential reads - may cause}
                ok := status(userfile);		{MAJOR hangup if other users}
                if ufb(userfile) then ok:=0;	{on concurrently!}
                if ok <> 0 then			{no timeouts allowed here!}
                  wait;
               until (ok = 0);
             end;
            update(ttyfile,error:=continue);	{one TTY updated!}
           end; 
        repeat
         get(ttyfile,error:=continue);		{same problem as above}
         ok := status(ttyfile);			{moral - do this when your}
         if ufb(ttyfile) then ok:=0;		{users are in bed!}
         if ok <> 0 then
           wait;
        until (ok = 0);				{still no timeouts allowed}
       end; 
     end
    else
      begin 
       gotoxy(14,21);
       writeln(cc,'+',chr(bell),
               'This date is not in the current reservation period!');
       typeanything;
     end; 
4: until ch='M';			{easy exit point!}
end;

procedure termbook;
					{make a system booking for a terminal}
label 6;
var erase:boolean;
    ttykind:ttytype;
    lowchoice:char;
    line:linetype;
    day:datetype;
    tim:timetype;
    dummy:loctype;
    testtim:timetype;
begin
 repeat
  clearscreen;			{beginning looks familiar - see above}
  writeln(cc,'$<TERM> R)eserve a terminal, E)rase a reservation, M)enu');
     repeat
      lowchoice:=getchar;
     until lowchoice in ['E','R','M'];
  if lowchoice='M' then goto 6;
  erase:=(lowchoice='E');
  getdate(thedate);
  day:=thedate;  
  repeat
    clearscreen;
    writeln(cc,'$Please enter the terminal code (e.g. ',thistty,') ');
    myreadln(line);		{need a terminal code this time}
    if((length(line)<4) or (length(line)>ttnamlen)) and 
      (length(line)<>0)		{even experts make typos - so lets check}
       then
         begin
           gotoxy(20,21);
           writeln(cc,'+Illegal format for terminal code!',chr(bell));
           typeanything;
         end
  until ((length(line)>3) and (length(line)<=ttnamlen)) or
         (length(line)=0);
   if length(line)>0 then	{quit on null string}
    begin
     line:=pad(line,' ',ttnamlen);	{pad and truncate string}
     ttykind:=substr(line,1,ttnamlen);
     if translate(ttykind,dummy)	{check if it exists}
      then
        begin
         if readtty(ttykind,day,retry:=true)=0	{get the record}
           then
            repeat
             gettime(tim);		{get time for booking}
             thetime:=tim;		{reset default time}
             slot:=(((ord(tim[1])-48)*10)+(ord(tim[2])-48))*2;	{compute slot}
             if ord(tim[4])>50 then slot:=slot+1;	{remember 1/2 hours}
             if erase 
              then
               tty.slot[slot]:=blanks9	{delete}
              else
               tty.slot[slot]:=sysres;	{reserve}
             repeat
               resetk(userfile,0,error:=continue);	{fixup user file}
               ok := status(userfile);
               if ok <> 0 then
                 wait;
             until (ok = 0);		{no timeouts!}
             while not ufb(userfile) do	{check all user records}
              begin
               found:=false;
               for i:= 1 to maxslots do	{check each slot}
                 begin
                   testtim:=userfile^.slot[i].time;	{copy time}
                   if (testtim[1]=' ') then		{normalize time}
                      testtim[1]:='0';
                   if (userfile^.slot[i].tty=ttykind) and
                      (userfile^.slot[i].date=day) and
                      (testtim=tim)			{if a full match}
                    then
                      begin
                        found:=true;			{set found flag}
                        userfile^.slot[i].date:=blanks11;	{blank slots}
                        userfile^.slot[i].time:=blanks5;
                        userfile^.slot[i].tty:=blanks5;
                      end;
                 end;   
                 if found 			{only update if altered}
                    then
                      update(userfile,error:=continue);
                repeat
                 get(userfile,error:=continue);	{sequential reads - no timeout}
                 ok := status(userfile);	{= possible long wait!}
                 if ufb(userfile) then ok:=0;
                 if ok <> 0 then
                   wait;
                until (ok = 0);
             end;
             clearscreen;
             writeln(cc,'$<TERM> A)nother slot, M)enu');
             repeat
               lowchoice:=getchar;
             until lowchoice in ['A','M'];	{inner loop till "M" selected"}
            until lowchoice='M';
        ttyfile^:=tty;			{update the TTY file}
        update(ttyfile,error:=continue);
       end
      else
       begin 
         gotoxy(14,21);
         writeln(cc,'+',chr(bell),
                 'This date is not in the current reservation period!');
         typeanything;
       end; 
    end;
6: until lowchoice='M';
end;

procedure cleanuserfile;
					{deletes empty records from user file}
					{use to remove defunct usernames from}
					{system - a [relatively] simple maint}
					{routine!}
begin
  repeat
    resetk(userfile,0,error:=continue);	{reset user file}
    ok := status(userfile);
    if ok <> 0 then
      wait;
  until (ok = 0);			{no timeouts}
  while not ufb(userfile) do		{check all records}
   begin
    found:=false;
    user:=userfile^;			{set current USER}
    settime;    			{set curent time}
    fixslots;				{update user slots}
    for i:= 1 to maxslots do		{check each slot in turn}
     if user.slot[i].date<>blanks11
      then
        found:=true;
    if not found 			{no valid slots}
         then
           delete(userfile,error:=continue);	{zap the guy}
    repeat
      get(userfile,error:=continue);	{usual story - sequential reads}
      ok := status(userfile);		{no timeout}
      if ufb(userfile) then ok:=0;
      if ok <> 0 then
        wait;
    until (ok = 0);
   end;
end;

procedure ttyupdate;
					{important procedure - gets the TTYS}
					{into the system in the first place}
begin
  reset(whowhrfile);			{reset WHO.WHR}
  while not eof(whowhrfile) do		{read from WHO.WHR}
     begin
       readln(whowhrfile,term);
       if index(term,'*')<>asterisk then	{ignore unreservable terms}
         begin
          term:=substr(term,1,ttnamlen);	{get TTY code}
          makesymbol(term,1,symbol);		{make a TTY file code symbol}
          findk(ttyfile,0,symbol,eql,error:=continue);	{check if old or new}
          if ufb(ttyfile)			{it's a new one}
           then 
            begin
              writeln(cc,' Adding: ',term);	{takes a while so tell them}
              for i:= 1 to maxdays do		{make record for each day}
                begin
                  ttyfile^.date:=convertdate(datearray[i],false); {get date}
                  makesymbol(term,i,symbol);	{make another code symbol}
                  ttyfile^.keysym:=symbol;	{put it in the record}
                  ttyfile^.tty:=term;		{make up rest of record}
                  for j := 0 to 47 do
                   ttyfile^.slot[j]:=blanks9;
                  put(ttyfile)			{write it to the file}
                end
            end
        end
   end
end;

procedure removetty;
					{removes a TTY and all its bookings}
					{NB Remove TTY from system first, then}
					{from WHO.WHR - other order don't work}
begin
  repeat
   clearscreen;
   writeln(cc,
           '$Please enter the terminal code (e.g. ',
           thistty,') ');
   myreadln(term);			{get the TTY code}
   if((length(term)<4) or (length(term)>ttnamlen)) and 
   (length(term)<>0)			{check it}
    then
     begin
       gotoxy(20,21);
       writeln(cc,'+Illegal format for terminal code!',
               chr(bell));
       typeanything;
     end
  until ((length(term)>3) and (length(term)<=ttnamlen)) or
   (length(term)=0);
   if length(term)>0 then		{quit on a null string}
     begin
       term:=pad(term,' ',ttnamlen);	{normalize terminal code}
       ttykind:=substr(term,1,ttnamlen);
       writeln(cc,
    ' All reservations for this terminal will be deleted!');
       writeln(cc,'$Delete ',ttykind,' Are you sure?');
       if getchar='Y'			{default to N - failsafe}
          then
           if translate(ttykind,dummy)	{is it there - see why we need WHO.WHR}
            then
             begin
              writeln(cc,' Please wait...');
              for i:= 1 to maxdays do
                begin
                 makesymbol(term,i,symbol);	{find each entry in TTY file}
                 repeat
                  findk(ttyfile,0,symbol,eql,
                        error:=continue);
                  ok := status(ttyfile);
                  if ok <> 0 then
                    wait;
                 until (ok = 0);		{no timeouts}
                 delete(ttyfile,error:=continue){and delete it}
                end;
                repeat
                  resetk(userfile,0,error:=continue);	{same for the userfile}
                  ok := status(userfile);
                  if ok <> 0 then
                    wait;
                until (ok = 0);
                while not ufb(userfile) do
                 begin
                  found:=false;
                  for i:= 1 to maxslots do
                   if userfile^.slot[i].tty=ttykind	{this TTY}
                    then
                      begin
                        found:=true;			{zap the bookings}
                        userfile^.slot[i].date:=blanks11;
                        userfile^.slot[i].time:=blanks5;
                        userfile^.slot[i].tty:=blanks5;
                      end;
                   if found 			{update if modified}
                       then
                         update(userfile,error:=continue);
                   repeat
                    get(userfile,error:=continue);	{sequential reads}
                    ok := status(userfile);
                    if ufb(userfile) then ok:=0;
                    if ok <> 0 then
                      wait;
                   until (ok = 0);
                 end;
                 writeln(cc,'0Terminal removed!');	{bingo!}
                 typeanything;
              end
          else
              begin			{can't remove what ain't there!}
               gotoxy(31,21);
               writeln(cc,'+No such terminal!');
               typeanything
              end
     end
end;

procedure sysreserve;
					{reserve for anybody - ADD only}
					{hint - can use ADD by CODE to remove!}
begin
  writeln(cc,'$Enter username:');
  myreadln(line);
  if length(line) < usernamlen then
     line:=pad(line,' ',usernamlen);
  username:=substr(line,1,usernamlen);
  writeln(cc,' ');
  writeln(cc,'$Select class number: (1.',class1,
          ', 2.',class2,', or 3.',class3,'): ');
  repeat
    ch:=getchar
  until ch in ['1'..'3'];
  case ch of
   '1': uic.group:=class1l;
   '2': uic.group:=class2l;
   '3': uic.group:=class3l;
  end;
  setlimits;	{recreate program startup}
  add;		{add only}
  goto 1;	{get out to prevent accidental use with a different username}
		{delete this line if you are brave (or over confident!)}
end;

begin
    getuic;	{check uic}
    if (uic.group=1) and (uic.member=4)		{[1,4] only - modify to suit}
     then
       begin
          repeat
           clearscreen;           
           secretmenu(choice);
           clearscreen;
           case choice of
              'B' : blockbook;
              'C' : cleanuserfile;
              'M' : {main menu};
              'R' : removetty;
              'S' : sysreserve;
              'T' : termbook;
              'U' : ttyupdate;
          end
         until choice='M'
       end
     else
       begin
        clearscreen;
        writeln(cc,' ',chr(bell),
             'The maintainance routines can only be used from account [1,4]!');
        typeanything;
       end
end;

procedure initialize;
					{onetime initializations}
begin
  if checkconsole			{check if this will run at all}
    then
     begin
       mask:=%x'02000000';		{mask for control-y trap routine}
       first:=true;			{first time through flag for main menu}
       nocontroly(mask);		{disable control y - dangerous not to!}
       setexpert;			{select initial display mode}
       openfiles;			{open all files}
       getname;				{get username}
       getuic;				{get uic}
       gettty;				{get tty code}
       date(today);			{get date}
       settime;				{get time}
       thetime:=now;			{set default time}
       thedate:=today;			{set default date}
       checkifcurrent;			{update database if necessary}
       setlimits;			{set limits for this user}
       maketermlist			{make terminal list}
     end
    else
     begin
       writeln('This program can only be used on a VT100 terminal!');
       goto 1;
     end
end;

begin					{main program}
    initialize;
    repeat
      mainmenu(selection);
      first:=false;
      case selection of
        'A': Add;        
        'H': if expert then expert:=false;
        'R': Remove;
        'S': Show;
        'Q': {quit};
        'X': if not expert then expert:=true;
        '@': Secret;
      end
    until selection = 'Q';
1:  clearscreen;		{ultimate exit point from all errors}
    controly(mask);		{re-enable control Y}
end.