program Labelmaker(Addresses);

type Addresses=record
                LName:string [18];
                FName :string [18];
                Apmt:string [30];
                Strt:string [30];
                Cty : string [15];
                State:string[10];
                Zp: string [10];
                end;
     Labfile = FILE OF integer;
     Addressfile = FILE OF Addresses;
     Entries = array[1..40] of Addresses;
     nametype = string[18];
     strtype = string [30];
     ctytype = string [15];
     ziptype = string [10];

var   lab :Labfile;
      entry:Entries;
      input:char;
      no1,no2,Addr:Addresses;
      second,temp,Address:Addressfile;
      beth,alph,which : char;
      updtno,z,q,r,c : integer;
      flname,ln,fn : nametype;
      apt,st : strtype;
      cy : ctytype;
      sta,code : ziptype;
      newfl,ok : boolean;
(*$R+*)

Procedure Switchfiles(var Addr:Addresses;var Address:Addressfile;var Alph,Beth:
                         char; var z:integer;var flname:nametype);
var ok,newfl: boolean;

Begin
        REPEAT
     writeln ('Enter name of file you wish to deal with. ');
     readln (flname);
     if length(flname) > 8 then writeln ('only 8 letters in a filename allowed.');
        UNTIL length (flname) <= 8;
     flname:= concat(flname,'.LBL');
     Assign(Address,flname);
     (*$I-*) reset (Address) (*$I+*);
     ok := (IOresult =0);
     if not ok then newfl:= true
     else newfl:= false;
     if newfl = true then begin
        rewrite (Address);
        writeln ('New file ',flname,' created.');
                REPEAT
        writeln ('Do you wish this file to be sorted by  0: last names; ');
        writeln ('1: Cities;  2: States;  3: zip codes ?');
        readln (Alph);
             UNTIL Alph in ['0','1','2','3'];
        Addr.LName := Alph;
             REPEAT
        writeln ('Do you wish to print 4 lines for each address rather than 3?');
        writeln('(Y/N or T for 3 lines and telephone #)');
        readln (Beth);
             UNTIL Beth in ['Y','y','N','n','t','T'];
        Addr.FName:= Beth;
        write (Address,Addr);
        end;
     z:= filesize(Address);
     z:= z-1;
     if newfl = false then begin
        read (Address,Addr);
        Alph:= Addr.LName;
        Beth:= Addr.FName;
     end;
     close (Address);
     writeln ('There are ',z,' names in this file');
end; (*switchfiles *)

Procedure Erase (var z:integer);
   Begin
      z:=0;
      Assign(Address,flname);
      rewrite (Address);
      close (Address);
   end;

Procedure Rewritefile (var Entry:Entries;var Addr:Addresses;var
              Address,temp:Addressfile; r:integer; fl:boolean);
var    b: integer;

Begin
   if fl = true then begin
     if r >= 40 then begin
        repeat
        for b:= 1 to 40 do read (Address,Entry[b]);
        for b:= 1 to 40 do write(temp,Entry[b]);
        r:= r-40;
        until r < 40;
     end;
     if r >= 20 then begin
        for b:= 1 to 20 do read (Address,Entry[b]);
        for b:= 1 to 20 do write(temp,Entry[b]);
        r:= r-20;
     end;
     if r >= 10 then begin
        for b:= 1 to 10 do read (Address,Entry[b]);
        for b:= 1 to 10 do write(temp,Entry[b]);
        r:= r-10;
     end;
     if r >= 5 then begin
        for b:= 1 to 5 do read (Address,Entry[b]);
        for b:= 1 to 5 do write(temp,Entry[b]);
        r:= r-5;
     end;
     if r > 0 then begin
        for b:= 1 to r do begin
           read (Address,Addr);
           write(temp,Addr);
        end;
     end;
  end; (* fl=true *)
  if fl= false then begin
     if r >= 40 then begin
           repeat
        for b:= 1 to 40 do read (temp,Entry[b]); write(b);
        for b:= 1 to 40 do write(Address,Entry[b]); write(b);
        r:= r-40;
        until r < 40; writeln;
     end;
     if r >= 20 then begin
        for b:= 1 to 20 do read (temp,Entry[b]); write(b);
        for b:= 1 to 20 do write(Address,Entry[b]); write(b);
        r:= r-20;
        writeln;
     end;
     if r >= 10 then begin
        for b:= 1 to 10 do read (temp,Entry[b]);
        for b:= 1 to 10 do write(Address,Entry[b]);
        r:= r-10;
     end;
     if r >= 5 then begin
        for b:= 1 to 5 do read (temp,Entry[b]);
        for b:= 1 to 5 do write(Address,Entry[b]);
        r:= r-5;
     end;
     if r > 0 then begin
        for b:= 1 to r do begin
           read (temp,Addr);
           write(Address,Addr);
        end;
     end;
  end; (* if fl=false *)
end; (* Rewritefile *)


Procedure Bubblesort (var Entry:Entries; r:integer;Alph:char);
var last: 2..10;
    curr,temp: 1..11;
    bubb: boolean;
Begin
     temp:= 11;
     for last:= r downto 2 do
         for curr:= 1 to last-1 do begin
     if alph = '0' then if Entry[curr].LName > Entry[curr+1].LName then bubb:=true
     else bubb := false;
     if alph='1' then if Entry[curr].Cty >Entry[curr+1].Cty then bubb := true
     else bubb := false;
     if alph='2' then if Entry[curr].State >Entry[curr+1].State then bubb :=true
     else bubb := false;
     if alph='3' then if Entry[curr].Zp >Entry[curr+1].Zp then bubb := true
     else bubb := false;
             if bubb = true then begin
                Entry[temp]:= Entry[curr];
                Entry[curr]:= Entry[curr+1];
                Entry[curr+1]:= Entry[temp];
             end; (* if *)
         end; (* current for *)
end; (* Bubblesort *)

Procedure Alphabetize (var Entry:Entries; var Addr:Addresses;var Address,
                          temp:Addressfile; r,z:integer; new:boolean;
                          Alph: char);
var l,t,c:integer;
    sort,fl: boolean;

Begin
     if r > 1 then Bubblesort(Entry,r,Alph);
     Assign (Address,flname);
     reset (Address);  read (Address,Addr);
   if new = false then begin
     Assign (temp,'TEMP.UPD');
     rewrite (temp); write (temp,Addr);
     while not eof(Address) do begin
           read (Address,Addr); t:= 0;
               if r > 0 then begin
                   repeat
               t:= t+ 1;
     if alph = '0' then if Entry[t].LName < Addr.LName then sort:=true
     else sort := false;
     if alph='1' then if Entry[t].Cty < Addr.Cty then sort := true
     else sort := false;
     if alph='2' then if Entry[t].State < Addr.State then sort:=true
     else sort := false;
     if alph='3' then if Entry[t].Zp < Addr.Zp then sort := true
     else sort := false;
               if sort = true then begin
                  write (temp,Entry[t]);
                  writeln(entry[t].LName,' written to temp');
                  r:= r-1;
                  if t < r+1 then begin
                     for c:= t to r do begin
                         Entry[c]:= Entry[c+1];
                     end;
                  t:= t- 1;
                  end;  (* if t *)
end; (* Entry if *)
             if r = 0 then t:= r;
             until t= r;
            end; (* r>0 *)
           write (temp,Addr);
    end; (* while *)
    if r > 0 then begin
       for t:= 1 to r do write (temp,Entry[t]);
    end;
    writeln (' Updating ',flname,' file. ');
    rewrite(Address);
    reset (temp);
    l:= filesize (temp);
    fl:= false;
    r:= l; writeln('size of ',flname,' is ',r-1);
    Rewritefile(Entry,Addr,Address,temp,r,fl);
    close (temp);
    close (Address);
end; (* if new *)
if new= true then begin
   for c:= 1 to r do write (Address,Entry[c]);
   close (Address);
end; (* if *)
end; (* Alphabetize *)
Procedure Secondfile (var Entry:Entries;var Addr:Addresses;var second,
                 Address:Addressfile; var Alph:char;var Beth:char; z:integer);
var tp,ans:string[15];
    new,ok,yes:boolean;
    c,y,n,r,x:integer;
    be,al,answ,repl: char;
Begin
     writeln(' Enter name of second file you wish to create or add to.');
          REPEAT
     readln (ans);
     if length(ans) > 8 then writeln ('only 8 letters in a filename allowed.');
        UNTIL length(ans)<= 8;
     ans:= concat (ans,'.LBL');
           repeat
if ans = flname then begin
        writeln ('you are already using that filename. Try again');
        readln (ans);
        end;
           until ans <> flname;
     Assign (second,ans);
     (*$I-*) reset (second) (*$I+*);
     ok:= (IOresult = 0);
     if not ok then new:= true
     else new:= false;
     if new = true then begin
        rewrite (second);
        writeln (' New file ',ans,' created.');
        new:= true;
        al:= Alph; be:= Beth;
              REPEAT
        writeln ('Do you wish it to be sorted by : 0:Last Name ');
        writeln ('1: City;  2: State;  3: Zip code? ');
        readln (Alph);
              UNTIL Alph in ['0','1','2','3'];
        Addr.LName:= Alph;
             REPEAT
        writeln ('Do you wish ',ans,' file to have 4 lines in the addresses ');
        writeln ('rather than 3? (Y/N or T for 3 lines and telephone #)');
        readln (Beth);
             UNTIL Beth in ['Y','y','N','n','T','t'];
        Addr.FName:= Beth;
        write (second,Addr);
        reset (second);
     end; (* if new=true *)
     y:= filesize (second); y:= y-1;
     read (second,Addr);
     if new = false then begin
        al:= Alph; be:= Beth;
        Alph:= Addr.LName; Beth:= Addr.FName;
     end;
     Assign (Address,flname);
     reset (Address);
     writeln (' Enter 0 to quit.');
     c:= 0; n:= 1; z:= z+1;
     read (address,addr);
         REPEAT
     read (Address,Addr);
     writeln (Addr.FName,' ',Addr.LName);
     if Beth in ['Y','y'] then writeln (Addr.Apmt);
     writeln (Addr.Strt);
     writeln (Addr.Cty,' ',Addr.State,' ',Addr.Zp);
     writeln (' Do you wish to select this to include in ',ans,' file? Y/N');
     readln (repl);
     if repl in ['y','Y'] then yes:= true
     else yes:= false;
     n:= n+1;
     if repl = '0' then n:= z;
     if yes = true then begin
        c:= c+1;
        Entry[c]:= Addr;
        if c = 10 then begin
           r:= c; y:= y+c;
           close (Address); close (second);
           tp:=flname;flname:= ans;
           writeln ('Writing to ',ans,' file. ');
           if new = false then Alphabetize(Entry,Addr,Address,temp,r,z,new,Alph);
           if new = true then begin
              assign (second,ans); reset (second);
              r:= 10; read (second,Addr);
              Bubblesort(Entry,r,Alph);
              for x:= 1 to 10 do write (second,Entry[x]);
           end;
           new:= false;
           flname:= tp;
           c:= 0; x:= n;
           assign (Address,flname);
           reset (Address);
           for x:= 1 to n do read (Address,Addr);
        end; (* if c=10 *)
     end; (* if yes=true *)
     until n = z;
     if c = 0 then close (second);
     if c > 0 then begin
        r:= c; y:= y+c;
        close (Address); close (second);
        tp:= flname; flname:=ans;
        if new= false then Alphabetize(Entry,Addr,Address,temp,r,z,new,Alph);
        if new= true then begin
           assign(second,ans); reset (second);
           read (second,Addr);
           Bubblesort(Entry,r,Alph);
           for x:= 1 to c do write (second,Entry[x]);
           close (second);
        end;
        new := false;
        flname:= tp;
        end; (* c>0 *)
Alph:= al;Beth:= be;
end; (* Secondfile *)

Procedure Enter(var Addr:Addresses;var Address:Addressfile;
                           var z:integer; Alph,Beth:char);
var
   r,n:integer;
   ans:char;
   new,yes:boolean;
Begin
     if z=0 then new:= true
     else new:= false;
     n:= 1;
        repeat
  with Entry[n] do begin
   writeln('Enter last name  ');
   readln(LName);
   writeln('Enter first name  ');
   readln(FName);
   if Beth in ['Y','y'] then writeln ('Enter company or apartment no.');
   if Beth in ['Y','y'] then readln (Apmt);

   writeln ('Enter street address  ');
   readln (Strt);
   writeln ('Enter city ');
   readln (Cty);
   writeln ('Enter State ');
   readln (State);
   writeln ('Enter zip code  ');
   readln (Zp);
   if Beth in ['T','t'] then begin
      writeln ('Enter telephone no.');
      readln (Apmt);
   end; (* if beth *)
    end;
   writeln ('Continue to enter addresses? Y/N ');
   readln (ans);
   if ans in ['Y','y'] then yes:= true
   else yes := false;
   n:= n + 1;
   if n = 11 then begin
      r:= n-1; z:= z+r;
      writeln ('Updating file ');
      Alphabetize(Entry,Addr,Address,temp,r,z,new,Alph);
      n:= 1; new:= false;
   end;
        until yes = false;
   if n <> 1 then begin
      r:= (n-1);  z:= z+r;
      writeln ('Updating file ');
      Alphabetize(Entry,Addr,Address,temp,r,z,new,Alph);
   end; (* if *)
end; (* Enter *)

Procedure Update (var Addr:Addresses;q,z:integer; var temp:Addressfile;
                         var Address:Addressfile; Alph,Beth:char);
var
   updtno,n,num,r : integer;
   fn,ln : nametype;
   apt,st,tp : strtype;
   cy : ctytype;
   code,sta : ziptype;
   fl:boolean;
Begin
   writeln ('Enter 0 to leave a field unchanged.');
     updtno:=q;
   writeln ('Enter last name  ');
   readln (tp);if tp <> '0' then ln:= tp
   else ln:= Addr.LName;
   writeln('Enter first name  ');
   readln(tp);if tp <> '0' then fn:= tp
   else fn:= Addr.FName;
   if Beth in ['Y','y'] then begin
      writeln ('Enter company or apartment no.');
      readln(tp); if tp <> '0' then apt:= tp
      else apt:= Addr.Apmt;
   end;
   writeln ('Enter street address  ');
   readln (tp);if tp <> '0' then st:= tp
   else st:= Addr.Strt;
   writeln ('Enter city ');
   readln (tp);if tp <> '0' then cy:= tp
   else cy:= Addr.Cty;
   writeln ('Enter state ');
   readln (tp); if tp <> '0' then sta:= tp
   else sta:= Addr.State;
   writeln ('Enter zip code  ');
   readln (tp); if tp <> '0' then code := tp
   else code := Addr.Zp;
   if Beth in ['t','T'] then begin
      writeln ('Enter telephone no.');
      readln(tp); if tp <> '0' then apt:= tp
      else apt:= Addr.Apmt;
   end;
Assign (Address,flname);
reset (Address);
Assign (temp,'NAMES.UPD');
rewrite (temp);
        if updtno > 1 then begin
           r:= updtno-1;
           fl:= true;
           Rewritefile(Entry,Addr,Address,temp,r,fl);
        end;
   n:= updtno;
       Addr.LName:=ln; Addr.FName:=fn;
       if Beth in ['Y','y','T','t'] then Addr.Apmt:= apt;
       Addr.Strt := st;
       Addr.Cty := cy; Addr.State:= sta; Addr.Zp:= code;
       write (Temp,Addr);
       read (Address,Addr);
       if n < z then begin
           r:= z - (updtno);
           fl:= true;
           Rewritefile(Entry,Addr,Address,temp,r,fl);
       end;
       r:= z;
       fl:= false;
       rewrite (Address); reset (temp);
       Rewritefile(Entry,Addr,Address,temp,r,fl);
       close(Address);
       close(temp);
end; (* Update *)

Procedure PrintAllNames (var Entry:Entries; var Addr:Addresses; var
                              Address:Addressfile; z:integer; Beth:char);
var
   c,n,d,p,l,bl,b:integer;
   ch: char;
   even:boolean;
   tp1,tp2,tp3,line:strtype;
Begin
     writeln ('filesize = ',z,' filename = ',flname);
   assign (Address, flname);
   reset (Address);
   read (Address,Addr);
   if z mod 2 = 0 then even:= true
   else even:= false;
   n:= 0; p:= 0; c:= 1;ch:= '6';
   writeln ('Press  >return< to continue, 0 to quit. ');
   if z > 1 then begin
      if even = false then z:= z-1;
          repeat
      read (Address,Entry[c]);
      read (Address,Entry[c+1]);
      n:= n+2; p:= p+2;
     write (entry[c].FName,' ',entry[c].LName);
     tp1:= entry[c].FName; tp2:= entry[c].LName;
     line:= concat(tp1,' ',tp2);
     l:= length(line);
     bl:= (40- l);
     if bl > 0 then begin
        for b:= 1 to bl do write (' ');
     end;
     writeln (entry[c+1].FName,' ',entry[c+1].LName);
     if Beth in ['Y','y'] then begin
        write (entry[c].apmt);
        line:= entry[c].apmt;
        l:= length(line);
        bl:= (40 - l);
        if bl > 0 then begin
           for b:= 1 to bl do write (' ');
        end;
        writeln (entry[c+1].Apmt);
     end; (* if Beth *)
     write (entry[c].strt);
     line:= entry[c].strt;
     l:= length(line);
     bl:= (40 - l);
     if bl > 0 then begin
        for b:= 1 to bl do write (' ');
     end;
     writeln (entry[c+1].Strt);
     write (entry[c].Cty,' ',entry[c].State,' ',entry[c].Zp);
     tp1:= entry[c].Cty; tp2:= entry[c].Zp; tp3:= entry[c].State;
     line:= concat(tp1,' ',tp2,' ',tp3);
     l:= length(line);
     bl:= (40 - l);
     if bl > 0 then begin
        for b:= 1 to bl do write (' ');
     end;
     writeln (entry[c+1].Cty,' ',entry[c+1].State,' ',entry[c+1].Zp);
     if Beth in ['T','t'] then begin
        write (entry[c].apmt);
        line:= entry[c].apmt;
        l:= length(line);
        bl:= (40 - l);
        if bl > 0 then for b:= 1 to bl do write (' ');
        writeln (entry[c+1].Apmt);
     end; (* if Beth *)
     writeln;
     if Beth in ['Y','y','T','t'] then begin
        if n mod 8 = 0 then read (ch);
     end;
     if Beth in ['n','N'] then begin
        if n mod 10 = 0 then read (ch);
     end;
     if ch = '0' then n:= z;
     UNTIL n = z;
  end; (* if z>1 *)
 if ch <> '0' then begin
   while not eof(Address) do begin
       read (Address, Addr);
       writeln (Addr.FName,' ',Addr.LName);
       if beth in ['Y','y'] then writeln (Addr.Apmt);
       writeln (Addr.Strt);
       write (Addr.Cty,' ');write (Addr.State,' ');
       writeln (Addr.Zp);
       if beth in ['T','t'] then writeln (Addr.Apmt);
       writeln;
  end;  (* begin *)
end; (* if ch<>0 *)
  close (Address);
 readln(ch);  writeln;
end;

Procedure Retrieve (var Addr: Addresses; var Address:Addressfile; z: integer;
                                       var q:integer; Beth:char);
 var
    ln,Last:nametype;
    yesno,print: boolean;
    ans : char;
    p:integer;
Begin
     z:= z+1;
     print:= false;
     assign (Address,flname);
     reset (Address);
     writeln ('Enter last name you wish to retrieve');
     readln (Last);
     clrscr;
     p:= 1;
     while p <= z do begin
       read (Address, Addr);
       ln:=Addr.LName;
       if Last = ln then begin
              writeln('p',p,'z',z);
              write (Addr.FName); write (' '); writeln (Addr.LName);
              if beth in ['Y','y'] then writeln (Addr.Apmt);
              writeln (Addr.Strt);
              writeln (Addr.Cty,' ',Addr.State,' ',Addr.Zp);
              if beth in ['T','t'] then writeln (Addr.Apmt);
              q:=p;
              print:= true;
              writeln ('Do you wish to update this name? (Y/N)');
              readln (ans);
              if ans in ['y','Y'] then yesno:= true
              else yesno:= false;
              if yesno = true then begin
                 close (Address);
                 Update (Addr,q,z,temp,Address,Alph,Beth);
                 p:= z+1;
              end;  (*begin *)
         end; (* if last=ln *)
      if p = z then  close (Address);
     p:= p+1;
     end; (* while *)
 if print = false then
   writeln(' There is no name like that in the file');
  end;

Procedure Delete(var Addr:addresses; var Address:Addressfile;
                          var temp:Addressfile; var z:integer);
var
   Last:nametype;
   p,n,tmp : integer;
   fl,yes : boolean;
   ans: char;
Begin
     z:= z+1;
     writeln ('Enter last name to delete ');
     readln (Last);
     Assign (Address, flname);
     reset (Address);
     Assign (temp, 'NAMES.UPD');
     rewrite (temp);
     yes:= false; n:= 1; tmp:= 1;
     if not eof(Address) then begin
        while n <= z do begin
            tmp:= n;
            read (Address, Addr);
            if Addr.LName = Last then begin
               writeln (Addr.FName,' ',Addr.LName);
               writeln ('Is this the name you wish to delete? ');
               readln (ans);
               if ans in ['Y','y'] then yes:= true
            end;(* if *)
            if yes = false then n:= n+1
            else n := z+1;
               end; (* while *)
         end; (* if *)
       reset (Address);
   if yes = true then begin
       n:= tmp;
     if n > 1 then begin
        fl:= true; r:= n-1;
        Rewritefile(Entry,Addr,Address,temp,r,fl);
     end;
     read (Address,Addr);
     if n < z then begin
        fl:= true; r:= z-n;
        Rewritefile(Entry,Addr,Address,temp,r,fl);
     end; (* if *)
     rewrite (Address); reset (temp);
     z:= z-1;
     fl:= false; r:= z;
         Rewritefile(Entry,Addr,Address,temp,r,fl);
   end; (* yes=true*)
         close (Address);
         rewrite (temp);
         close (temp);
         z:= z-1;
end; (* Delete *)Procedure DesignLabels (var lab:Labfile);
var
   tp,sp,adsp,across,col1,col2,col3,col4 : integer;
Begin
     Assign (lab,'LABEL.DES');
     (*$I-*) reset (lab) (*$I+*);
     ok := (IOresult = 0);
     if ok = false then begin
        rewrite (lab);
        sp:=100;adsp:= 100; across:= 20;
        col1:= 100; col2:= 200; col3:= 300;
     end
     else if not eof(lab) then
          read (lab,sp,adsp,across,col1,col2,col3);
     close (lab);
     writeln ('Press >0< to keep value unchanged.');
     writeln ('Enter # for linespacing within an address. For instance,');
     writeln ('1 for singlespacing, 2 for doublespacing, etc.');
     writeln ('Current value is ',sp);
     readln (tp); if tp in [1..1000] then sp:= tp;
     writeln ('How many blank lines up and down between addresses?');
     writeln ('Current value is ',adsp);
     readln (tp); if tp in [1..1000]then adsp:= tp;
     writeln ('First address to start at column # ?');
     writeln ('Current column is ',col1);
     readln (tp); if tp in [1..1000] then col1:= tp;
     writeln ('How many addresses across on the page? (1-3)');
     writeln ('Current number is ',across);
     readln (tp); if tp in [1..3] then across:= tp;
     if across = 1 then begin
        col2:= 100; col3 := 200; col4:= 400;
     end;
     if across >= 2 then begin
        writeln ('At what column do you wish to start the second address?');
        writeln ('Current column is ',col2);
        readln (tp); if tp in [1..1000] then col2:= tp;
        if across = 2 then begin
           col3:= 200; col4:= 400;
        end;
    end;
    if across >= 3 then begin
       writeln ('At what column do you wish to start the 3rd address?');
       writeln ('Current column is ',col3);
       readln (tp); if tp in [1..1000] then col3:= tp;
       if across = 3 then col4:= 400;
    end;
    writeln ('Well, it''s your design...');
    Assign (lab,'LABEL.DES');
    rewrite (lab);
    write (lab, sp,adsp,across,col1,col2,col3,col4);
    close (lab);
end;

Procedure Singlelist (var Addr:Addresses;n,sp,adsp,col1:integer; Beth:char);
var b:integer;
Begin
     if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
     writeln(lst,Addr.FName,' ',Addr.LName);
     if sp > 1 then for b:= 2 to sp do writeln(lst);
     if Beth in ['Y','y'] then begin
        if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
        Writeln (lst,Addr.Apmt);
        if sp > 1 then for b:= 2 to sp do writeln (lst);
     end; (* if Beth *)
      if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
     Writeln (lst,Addr.Strt);
     if sp > 1 then for b:= 2 to sp do writeln (lst);
     if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
     writeln (lst,Addr.Cty,' ',Addr.State,' ',Addr.Zp);
     if Beth in ['T','t'] then begin
        if sp > 1 then for b:= 2 to sp do writeln (lst);
        if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
        Writeln (lst,Addr.Apmt);
     end; (* if Beth *)
     if adsp > 0 then for b:= 1 to adsp do writeln (lst);
end; (*Singlelist *)

Procedure zpr (var Entry:Entries; col1,col2,colm,col,d,n,c:integer);
var tp1,tp2,tp3,line:strtype;
    b,bl,l: integer;
Begin
   if colm = col1 then begin
     if colm > 1 then begin
        for b:= 2 to colm do write (lst,' ');
     end;
     write (lst,entry[c].Cty,' ',entry[c].State,' ',entry[c].Zp);
   end;
     tp1:= Entry[c].Cty; tp2:= Entry[c].Zp; tp3:= Entry[c].State;
     line:= concat(tp1,' ',tp2,' ',tp3);
     l:= length(line);
     if colm=col1 then bl:= (col-(l+col1))
     else bl:= (col-(l+col2));
     if bl > 0 then begin
        for b:= 1 to bl do write (lst,' ');
     end;
     write(lst,Entry[c+1].Cty,' ',Entry[c+1].State,' ',Entry[c+1].Zp);
end;

Procedure stpr (var Entry:Entries; col1,col2,colm,col,d,n,c: integer);
var tp1:strtype;
    b,bl,l: integer;
Begin
   if colm = col1 then begin
     if colm > 1 then begin
        for b:= 2 to colm do write (lst,' ');
     end;
     write (lst,entry[c].Strt);
   end;
     tp1:= entry[c].Strt;
     l:= length(tp1);
     if colm=col1 then bl:= (col-(l+col1))
     else bl:= (col-(l+col2));
     if bl > 0 then begin
        for b:= 1 to bl do write (lst,' ');
     end;
     write (lst,entry[c+1].Strt);
end;

Procedure apmtpr (var Entry:Entries; col1,col2,colm,col,d,n,c: integer);
var tp1:strtype;
    b,bl,l: integer;
Begin
   if colm = col1 then begin
     if colm > 1 then begin
        for b:= 2 to colm do write (lst,' ');
     end;
     write (lst,entry[c].Apmt);
   end;
     tp1:= entry[c].Apmt;
     l:= length(tp1);
     if colm=col1 then bl:= (col-(l+col1))
     else bl:= (col-(l+col2));
     if bl > 0 then begin
        for b:= 1 to bl do write (lst,' ');
     end;
     write (lst,entry[c+1].Apmt);
end;

Procedure namepr(var Entry:Entries; col1,col2,colm,col,d,n,c:integer);
var tp1,tp2,line:strtype;
    b,bl,l : integer;
Begin
if colm = col1 then begin
 if colm > 1 then begin
        for b:= 2 to colm do write (lst,' ');
     end;
     write (lst,entry[c].FName,' ',entry[c].LName);
end;
     tp1:= entry[c].FName; tp2:= entry[c].LName;
     line:= concat(tp1,' ',tp2);
     l:= length(line);
     if colm=col1 then bl:= (col-(l+col1))
     else bl:= (col-(l+col2));
     if bl > 0 then begin
        for b:= 1 to bl do write (lst,' ');
     end;
     write (lst,entry[c+1].FName,' ',entry[c+1].LName);
end;

Procedure List2 (var Entry:Entries; var Address:Addressfile;sp,adsp,across,
         col1,col2,z,c:integer; fl:boolean; var Addr:Addresses; Beth:char);
var even : boolean;
    b,n,d,colm,col: integer;
Begin
   if fl = false then begin
     Assign(Address,flname);
     reset (Address);
     read (Address,Addr);
     end;
     if (z mod 2) = 1 then even:= false
     else even:= true;
     d:= 1;
     if fl = false then n:= 0
     else n:= z-2;
   if z > 1 then begin
    if fl = false then begin
     if even = false then z:= z-1;
    end;
     colm:= col1; col:= col2; c:= 1;
     repeat
     n:= n+2;
     read (Address,entry[c]);
     read (Address, entry[c+1]);
     namepr(Entry,col1,col2,colm,col,d,n,c);
        for b:= 1 to sp do writeln(lst);
     if Beth in ['Y','y'] then begin
        apmtpr(Entry,col1,col2,colm,col,d,n,c);
        for b:= 1 to sp do writeln(lst);
     end;
     stpr(Entry,col1,col2,colm,col,d,n,c);
        for b:= 1 to sp do writeln(lst);
     zpr (Entry,col1,col2,colm,col,d,n,c);
     if Beth in ['T','t'] then begin
        for b:= 1 to sp do writeln(lst);
        apmtpr(Entry,col1,col2,colm,col,d,n,c);
     end;
        for b:= 0 to adsp do writeln (lst);
     until n = z;
  end;
     if fl=true then even:= true;
     if even = false then begin
        n:= n+1;
        read (Address,Addr);
        Singlelist(Addr,n,sp,adsp,col1,Beth);
     end;
    close (Address);
end; (* list2 *)

Procedure List3 (var Entry:Entries; var Address:Addressfile;sp,adsp,across,
  col1,col2,col3,z,c: integer; var fl: boolean; var Addr:Addresses; Beth:char);
var l,b,n,d,colm,col,extra: integer;
    tp1,tp2,line: strtype;
Begin
   if fl = false then begin
     Assign(Address,flname);
     reset (Address);
     read (Address,Addr);
     end;
     extra := z mod 3;
     n:= 0;
  if z > 2 then begin
     z:= z - extra;
       repeat
     colm:= col1; col:= col2;
     n:= n+3; d:= 2; c:= 1;
     read (Address,Entry[c]);
     read (Address,Entry[c+1]);
     read (Address, Entry[c+2]);
     namepr(Entry,col1,col2,colm,col,d,n,c);
     col:= col3;colm:= col2; d:= 1; c:=2;
     namepr (Entry,col1,col2,colm,col,d,n,c);
        for b:= 1 to sp do writeln(lst);
     if Beth in ['Y','y'] then begin
        col:= col2; colm:= col1; d:= 2; c:= 1;
        apmtpr(Entry,col1,col2,colm,col,d,n,c);
        col:= col3; colm:= col2; d:= 1; c:= 2;
        apmtpr(Entry,col1,col2,colm,col,d,n,c);
         for b:= 1 to sp do writeln(lst);
     end; (* if Beth *)
     col:= col2; colm:= col1; d:= 2; c:= 1;
     stpr(Entry,col1,col2,colm,col,d,n,c);
     col:= col3; colm:= col2; d:= 1; c:= 2;
     stpr (Entry,col1,col2,colm,col,d,n,c);
         for b:= 1 to sp do writeln(lst);
     col:= col2; colm:= col1; d:= 2; c:= 1;
     zpr (Entry,col1,col2,colm,col,d,n,c);
     col:= col3; colm:= col2; d:= 1; c:= 2;
     zpr (Entry,col1,col2,colm,col,d,n,c);
     if Beth in ['T','t'] then begin
        for b:= 1 to sp do writeln(lst);
        col:= col2; colm:= col1; d:= 2; c:= 1;
        apmtpr(Entry,col1,col2,colm,col,d,n,c);
        col:= col3; colm:= col2; d:= 1; c:= 2;
        apmtpr(Entry,col1,col2,colm,col,d,n,c);
     end; (* if Beth *)
        for b:= 0 to adsp do writeln(lst);
     until n = z;
     z:= z + extra;
  end; (* if z>2 *)
     if extra = 1 then begin
        read (Address,Addr);
        Singlelist (Addr,n,sp,adsp,col1,Beth);
     end;
     if extra = 2 then begin
        fl:= true; (* open *)
        c:= 1;
        List2 (Entry,Address,sp,adsp,across,col1,col2,z,c,fl,Addr,Beth);
     end;
  if fl = false then close (Address);
end;  (* List3 *)

Procedure List1 (var Addr:Addresses; var Address:Addressfile;sp,adsp,across,
                           col1,col2,col3,z:integer; fl:boolean; Beth:char);
var n:integer;

Begin
   if fl = false then begin
     Assign (Address,flname);
     reset (Address);
     read (Address,Addr);
     end;
     for n:= 1 to z  do begin
         read (Address, Addr);
         Singlelist (Addr,n,sp,adsp,col1,Beth);
     end;
     if fl = false then close (Address);
end;

Procedure List (var Addr:Addresses; var lab:labfile; z:integer; Beth:char);
var
   b,n,sp,adsp,across,col1,col2,col3,col4 : integer;
   fl,ok,design : boolean;
Begin
     Assign (lab,'LABEL.DES');
     (*$I-*) reset (lab) (*$I+*);
     ok:= (IOresult = 0);
     if not ok then design:= false
     else design:= true;
if design = false then begin
    writeln ('You must design label format (#6) before labels can be printed');
end;
if design = true then begin
     read (lab,sp,adsp,across,col1,col2,col3,col4);
     close (lab);
     fl:= false;

 if across = 1 then List1(Addr,Address,sp,adsp,across,col1,col2,col3,z,fl,Beth);
 if across = 2 then List2 (Entry,Address,sp,adsp,across,col1,col2,z,c,fl,Addr,Beth);
 if across = 3 then List3(Entry,Address,sp,adsp,across,col1,col2,col3,z,c,fl,
                                 Addr,Beth);
end; (* if design=true *)
end;
Procedure MainMenu;

Begin
   writeln ('0: Quit');
   writeln ('1: Enter new name & address');
   writeln ('2: Retrieve/Update');
   writeln ('3: Erase or start ERASES WHOLE FILE OF ADDRESSES');
   writeln ('4: View whole file');
   writeln ('5: Delete');
   writeln ('6: Design Labels');
   writeln ('7: Output to printer');
   writeln ('8: Create or add to another file');
   writeln ('9: Switch to another file');
   writeln ('Which? ');
   readln (which);
      case which of
      '0':  ;
      '1': Enter(Addr,Address,z,Alph,Beth);
      '2': Retrieve(Addr,Address,z,q,Beth);
      '3': Erase (z);
      '4': PrintAllNames (Entry,Addr,Address,z,Beth);
      '5': Delete(Addr,Address,temp,z);
      '6': DesignLabels(lab);
      '7': List (Addr,lab,z,Beth);
      '8': Secondfile (Entry,Addr,Address,second,Alph,Beth,z);
      '9': Switchfiles(Addr,Address,Alph,Beth,z,flname);
      end;
end;

Begin
  Switchfiles(Addr,Address,Alph,Beth,z,flname);
  MainMenu;
  while which <> '0' do
        repeat
  MainMenu;
    until which= '0';
  writeln ('Labelmaker was written by Ian Richmond.  I have put it in the public');
  writeln ('domain with only one stipulation: that it not be sold by anyone but');
  writeln ('distributed freely.  I cannot be responsible for any damages caused');
  writeln ('by it operating improperly.  But I will try to back it up.  If you ');
  writeln (' have any problems with it or want help changing it to fit your ');
  writeln ('purposes better, call me at: (215) 649-1198 eves. 6-12.');
end.