{  $LIST+, $DEBUG+, $BRAVE+, $LINESIZE:132, $PAGESIZE:80, $OCODE+   }
{  $ERRORS:50, $MATHCK+, $RANGECK+, $INITCK+, $INDEXCK+, $ENTRY+    }
{  $LINE+, $RUNTIME+, $SYMTAB+, $WARN+, $GOTO-     }
{  $TITLE:'FILE DATA BASE  ---  AEM$SCRATCH'             }
{  $MESSAGE:'PASCAL - COMPILATION OPTIONS SET'     }
{  $MESSAGE:'SYSTEM - COMPILATION BEGINS'          }

{$LIST-}
{$INCLUDE:'A:FILKQQ.INC'}
{$INCLUDE:'A:FILUQQ.INC'}
{$LIST+}
program file_code (input,output);  uses filkqq,filuqq;

const
   maxname =   20;
   maxstrg =   30;
   blank   =   ' ';

type
   stindex     =   byte;
   idxrng      =   0..30;
   varstrng    =   lstring(maxname);
   fixstrng    =   string(maxname);
   maxstrng    =   string(maxstrg);
   maxlstrng   =   lstring(maxstrg);

   entrytype   =   record
       name    :   record
           lastname, firstname : fixstrng;
           midinit : char
       end;
       addr    :   record
           street  : maxstrng;
           city    : fixstrng;
           state   : string (2);
           zip     : string(5)
       end;
       phone   :   record
           number  : string(8);
           areacod : string(3)
       end;
       dob : string(8)
   end;

   nodeptr     =   ^node;
   node    = record
       entry :  entrytype;
       next : nodeptr
   end;

VAR [STATIC]
   hol : nodeptr;
   reccount : integer;
   recfil : file of entrytype;
   curtime, curdate : string(10);
   option : char;
   length : idxrng;
   saved : boolean;

procedure recdisp (const curdisp : nodeptr; const reccount : integer); extern;
procedure expand; extern;    {expand the cursor to a large block}
procedure contract; extern;  {contract the cursor to normal scan line}
procedure endxqq; extern;
procedure getdata (var newrecord : entrytype);  extern;
procedure view (const hol : nodeptr);  extern;
procedure beep;external;
procedure date (var s : string); extern;
procedure time (var s : string); extern;
procedure locate (row, column : integer); extern;
procedure cls; extern;
procedure keyboard (var temp : string; var length:idxrng; width:integer); extern;


procedure browse (const hol : nodeptr; const reccount : integer);

var
   option : char;
   length : idxrng;
   current : nodeptr;
   count : integer;

label exit;

begin
   count := 0;
   time (curtime);   date (curdate);
   current := hol;
   while current <> nil do
       begin
           count := count + 1;
           recdisp (current,reccount);
           current := current^.next;    {get next record}
           locate (20,1);  write (output, null : 60);
           locate (22,1);  write (output, null : 60);
           locate (23,1);   write (output, null : 60);
           if current = nil then goto exit;
           locate (23,1);   write (output, count : 1, ' of ', reccount : 1);
           locate (23,70);  write (output, 'More...');
           keyboard (option,length,1)
       end;
exit:
   locate (23,1); write (output, null:78);
   locate (23,1); write (output, 'End'); locate (23,70); write (output, 'EOF');
   locate (24,1); write (output, null:78);
   locate (24,1); write (output, 'Strike any key to return to primary options');
   keyboard (option,length,1);
 return
end;  {procedure}

procedure  menu_display;
   begin
     cls;
     locate (22, 1);
     time (curtime);
     write (output, 'Time: ', curtime, null:4, 'Date: ', curdate);
     locate (2,26);
     write (output, 'PRIMARY OPTIONS');
     locate (4,5);       write (output, '<I>nsert NEW record');
     locate (4,45);      write (output, '<D>elete OLD record');
     locate (5,5);       write (output, '<U>pdate OLD record');
     locate (5,45);      write (output, '<V>iew OLD record');
     locate (6,5);       write (output, '<B>rowse current file');
     locate (6,45);      write (output, '<F>ile with save');
     locate (7,05);      write (output, '<A>bort without save');
     locate (10,5);      write (output, 'OPTIONS (');
     write (output, 'I');
     if hol <> nil then write (output,'DUVBF') else write (output, blank,blank,blank,blank,blank);
     write (output, 'A)');
     write (output, '    --> ')
end;


procedure lookup (const key : entrytype;  var current,previous : nodeptr;
                  const hol : nodeptr; var found : boolean)   [public];

var
   notfound : boolean;   {true if next node must be examined}
begin
   previous := nil;    notfound := true;   current := hol;
   found := false;
   while notfound and (current <>  nil) do
       with current^  do
           if  key.name.lastname <= entry.name.lastname then
               notfound := false
           else  {move pointers to next node and look again}
               begin
                   previous := current;
                   current := next
               end;
   if current <> nil then   {see if the name was found}
   if key.name.lastname = current^.entry.name.lastname then
               found := true
       else found := false
end;   {procedure listsearch}

procedure initialize (var hol : nodeptr;
                      var reccount : integer);

var skipchar, fstat : char;
    i : idxrng;
    current, newnode, previous : nodeptr;
  found : boolean;

begin
   cls;
	 expand;
   reccount := 0;
   hol := nil;
   locate (1,1);
   time (curtime);
   date (curdate);
   write (output, 'Execution on:  ', curtime : 12, curdate);
   locate (3,1);
   write (output, 'Enter filename to update --> ');
   readfn (input, recfil);
   locate (5,1);
   readln (input);
   write ('Is this file new?  (Y/N) : ');
   readln (input, fstat);
   if (fstat = 'n') OR (fstat = 'N') THEN
       begin
				recfil.trap := true;
           reset (recfil);         {reset does performs an implied get operation}
				if recfil.errs <> 00 then    {file not found or disk error}
					begin
						writeln (output, 'File not on volume, or Disk error');
						contract;
						endxqq         {library terminate call}
					end;
           writeln (output);
           writeln (output, 'Existing file, opened');
           writeln (output);
           {$NILCK-}   {stop nil checking temporarily}
           while not eof (recfil) do   {load the list with existing file}
               begin
                   new(newnode);
                   newnode^.entry := recfil^;
                   current := hol;   previous := nil;
                   lookup (newnode^.entry,current,previous,hol,found);
                   reccount := reccount + 1;
                   get (recfil);
                   if previous <> nil then
                       begin
                           newnode^.next := previous^.next;
                           previous^.next := newnode
                       end
                   else
                       begin
                           newnode^.next := hol;
                           hol := newnode
                       end
               end
       end
   else
       begin
           writeln (output);
           writeln (output);
           writeln (output, 'New file');
           writeln (output, 'File will be created');
           rewrite (recfil);
           writeln (output, 'Created')
       end;
   locate (15,1);
   write (output, 'Hit <ENTER> to continue...');
   keyboard (skipchar, i, 1);
   cls;
   writeln (output)
   {$NILCK+}    {restart nil reference checking}
end;

procedure updrec (var hol : nodeptr; const reccount : integer);

var
   tmpstrng : maxstrng;
   temp : entrytype;
   current, previous : nodeptr;
   found : boolean;
   select : char;
   maxlen, length, i : idxrng;

   procedure chngstrng (var curstrng : string;  const newstrng : string; const length: idxrng; maxlen : idxrng);
   var
       j : idxrng;
   begin
       for j := 1 to length do
           curstrng [j] := newstrng [j];
       for j := length+1 to maxlen do
       curstrng [j] := blank
   end;  {procedure}
begin {updrec}
   current := hol;
   cls;  time (curtime);
   locate (1,1);
   write (output, 'Page:  UPDATE', null : 4, 'Primary key cannot be modified');
   locate (2,1); write (output, 'Time: ', curtime, null:3, 'Date: ', curdate);
   locate (5,1); write (output, 'Enter LAST name to modify --> ');
   locate (5,32); for i := 1 to 20 do write (output, '.');
   locate (5,32); keyboard (temp.name.lastname, length, 20);
   for i := length + 1 to 20 do
       [   write (output, blank);
           temp.name.lastname [i] := blank ];
   locate (4,1);    write (output, '*Update Record: ', temp.name.lastname);
   lookup (temp,current,previous,hol,found);
   if found then
       begin
           recdisp (current, reccount);
           with current^.entry do
               begin
                   locate (6,13);  keyboard (tmpstrng, length, 20);
                   if length > 0 then   {change string}
                       chngstrng (name.firstname, tmpstrng, length, 20);
                   locate (6,56); keyboard (tmpstrng, length, 1);
                   if length > 0 then
                       chngstrng (name.midinit, tmpstrng, length, 1);
                   locate (11,9); keyboard (tmpstrng, length, 30);
                   if length > 0 then
                       chngstrng (addr.street, tmpstrng, length, 30);
                   locate (12, 7); keyboard (tmpstrng, length, 20);
                   if length > 0 then
                       chngstrng (addr.city, tmpstrng, length, 20);
                   locate (12,48); keyboard (tmpstrng, length, 2);
                   if length > 0 then
                       chngstrng (addr.state, tmpstrng, length,2 );
                   locate (12,66); keyboard (tmpstrng, length, 5);
                   if length > 0 then
                       chngstrng (addr.zip, tmpstrng, length, 5);
                   locate (14,12); keyboard (tmpstrng, length, 3);
                   if length > 0 then
                       chngstrng (phone.areacod, tmpstrng, length, 3);
                   locate (14,24); keyboard (tmpstrng, length, 8);
                   if length > 0 then
                       chngstrng (phone.number, tmpstrng, length, 8);
               end;
           locate (20,1 ); write (output, null : 60);
           locate (22,1 ); write (output, null : 60);
           locate (20,1 ); write (output, '*Modified.');
           locate (22,1 ); write (output, 'Strike any key to return to primary options...');
           keyboard (select, i, 1);
           return      {to caller -- primary options}
       end
   else  {record requested is not found}
       begin
           cls;
           locate (1,1); write (output, '*UPDATE');
           locate (4,1); write (output, 'Search failure:');
           locate (6,1); write (output, 'Record: ', temp.name.lastname, ' Not found -- Update not done');
           locate (8,1); write (output, 'Strike any key to return to primary options...');
           keyboard (select, i, 1);
           return
       end
end;   {procedure}


procedure insrec (var hol : nodeptr; var reccount : integer);

var
   temp : entrytype;
   newnode, current, previous : nodeptr;
   found : boolean;
   select : char;
   i : idxrng;

begin
   getdata (temp);
   lookup (temp, current, previous, hol, found);
   if not found then    {insert the record}
       begin
           reccount := reccount + 1;
           new (newnode);
           newnode^.entry := temp;
           if previous <> nil then
               begin
                   newnode^.next := previous^.next;
                   previous^.next := newnode
               end
           else    {node goes at the head of the list (hol)}
               begin
                   newnode^.next := hol;
                   hol := newnode
               end;
           locate (23,1);
           write ('*** NEW record, Saved: (# ',reccount:1,')  ', temp.name.lastname);
           locate (24,1); write ('Strike any key to continue...');
           keyboard (select, i, 1)
       end
   else   {this record already exists}
       begin
           cls;
           locate (2,1);
           write (output, '*** Unable to insert record:');
           locate (4,1);
           write (output, '*** ', temp.name.lastname, ' Already exists');
           locate (5,1);
           write (output, '*** DUPLICATE primary keys are not allowed');
           locate (20,1);
           write ('[U]pdate, or [R]eturn  --> ');
           keyboard (select, i, 1);
           if (select = 'U') or (select = 'u') then
               updrec (hol,reccount)
           else
               return
       end
end;

procedure delrec (var hol : nodeptr;  var reccount : integer);

var
   newnode, current, previous : nodeptr;
   found : boolean;
   select : char;
   i, length : idxrng;
   lnam : fixstrng;
   temp : entrytype;

   procedure delrcrd (var hol : nodeptr);

   begin   {all the search variables are in a level above this, and visible}
       if previous <> nil then
           previous^.next := current^.next
       else
           hol := current^.next;
       dispose (current);
       reccount := reccount - 1
   end;   {delrcrd}
begin   {delrec}
   cls;
   if hol = nil then    {no records to save}
       begin
           locate (1,1);
           write (output, 'Internal file contains NO records.');
           locate (3,1);
           write (output, 'No records to delete now.');
           locate (7,1);
           write (output, 'Strike any key to return to primary options');
           keyboard (select,i,1);
           return
       end;
   locate (1,1);
   time (curtime);
   write (output, 'Delete record:  ', curtime, null : 3, curdate);
   locate (1,70);   write (output, 'DEL');
   locate (2,1);
   write (output, 'Page:  DEL:    <File unchanged>');
   locate (5,1);
   write (output, 'Enter LAST name of record to delete  --> ');
   locate (5,42); for i := 1 to 20 do write (output, '.');
   locate (5,42); keyboard (lnam, length, 20);
   beep;  for i := length+1 to 20 do write (output, blank);
   temp.name.lastname := lnam;
   for i := length + 1 to 20 do   {pad out garbage from asm routine}
       temp.name.lastname [i] := blank;
   lookup (temp, current, previous, hol, found);
   if not found then
       begin
           locate (8,1);
           write (output, '*** Requested record not found  (');
           for i := 1 to length do
               write (output, lnam[i]);
           write (output, ')');
           locate (9,1);
           write (output, '*** File unable to be modified');
           locate (15,1);
           write (output, 'Strike any key to return to primary options');
           keyboard (select,i,1)
       end
   else   {record will be deleted}
       begin
           locate (8,1);
           write (output, '*** Requested record located:');
           locate (9,1);
           write (output, '*** Delete?  --> ');
           keyboard (select,length,1);
           if (select = 'Y') or (select = 'y') then
               delrcrd (hol)
           else
               begin
                   locate (15,1);
                   write (output, 'Record delete NOT confirmed');
                   locate (17,1);
                   write (output, 'Strike any key to return to primary options');
                   keyboard (select,i,1);
                   return
               end
       end
end;   {procedure}

procedure filrec (const hol : nodeptr; const reccount : integer;
                   var saved : boolean);

var
   i : idxrng;
   select : char;
   current : nodeptr;
begin
   cls;
   if hol = nil then    {no records to save}
       begin
           locate (1,1);
           write (output, 'Internal file contains NO records.');
           locate (3,1);
           write (output, 'File remains unchanged.');
           locate (7,1);
           write (output, 'Strike any key to return to primary options');
           keyboard (select,i,1);
           return
       end;
   locate (1,1);
   write (output, 'File records:',null:10, reccount : 1, ' Records to be saved');
   locate (1,70);
   write (output, 'FILE');
   locate (2,1);
   write (output, 'PAGE: SAVE', null : 10, 'Permanent File Modification');
   locate (3,1);
   time (curtime);
   write (output, 'File will be rewritten', '   Time: ', curtime, null : 4, 'Date: ', curdate);
   locate (10,1);
   write (output, 'Writing ', reccount : 1, ' record(s) on file');
   locate (12,1);
   write (output, 'Writing ', sizeof(hol^.entry) * wrd(reccount) : 1 : 16,
          'H bytes ', '(',sizeof(hol^.entry) * wrd(reccount): 1, ')');
   rewrite (recfil);
   current := hol;
   while current <> nil do
       begin
           recfil^ := current^.entry;
           put (recfil);
           current := current^.next
       end;
   locate (15,1);
   close (recfil);
   reset (recfil);
   write (output, 'Completed');
   locate (20,1); write (output, 'Strike any key to return to primary options');
   keyboard (select,i,1);
   saved := true
end;  {procedure}


begin   {main}
   date (curdate);
   time (curtime);
   cls;
   saved := false;
   initialize (hol, reccount);
   menu_display;
   keyboard (option,length,1);
   while not (option in ['A','a']) do
       begin
           case option of
           'I','i' :   insrec (hol, reccount);
           'D','d' :   delrec (hol, reccount);
           'F','f' :   filrec (hol, reccount,saved);
           'U','u' :   updrec (hol, reccount);
           'V','v' :   view (hol);
           'B','b' :   browse (hol,reccount);
           otherwise beep
           end;   {case}
           menu_display;
           keyboard (option,length,1)
       end;
   cls;
   if not saved and (hol <> nil) then   {file modified, not saved}
       begin
           locate (1,1);
           write (output, 'Record file has not been saved.');
           locate (3,1);
           write (output, 'Internal file contains: ', sizeof(hol^.entry) * wrd(reccount) : 1, null:3,
                  '(',sizeof(hol^.entry) * wrd(reccount):1:16,'H) bytes');
           locate (5,1);  write (output, 'Continue ABORT sequence, with no save?  ');
           keyboard (option,length,1);
           if not (option in ['Y','y']) then
                   begin
                       locate (7,1); write (output, 'File will be saved');
                       filrec (hol, reccount, saved)
                   end
           else
               begin
                   locate (7,1); write (output, 'Abort confirmed.');
                   locate (8,1); write (output, 'Input file unchanged.')
               end
       end;   {if not saved}
   writeln (output);
   writeln (output);
   locate (20,1); write (output, null : 60);
   locate (20,1); write (output, 'Returning to DOS');
   writeln (output);
   writeln (output,' EOJ :');
   time (curtime);
	 contract;
   locate (23,1);  write (output, 'Execution terminated normally on ', curdate, null:2, curtime)
end.
�V��v��+	"�f�]�U������F��~�}�
u�6V���~�}�	���F�
�V�v�R���~�}�.u