Xref: utzoo comp.lang.pascal:1370 comp.sys.mac.programmer:3644
Path: utzoo!attcan!uunet!husc6!mailrus!csd4.milw.wisc.edu!markh
From: markh@csd4.milw.wisc.edu (Mark William Hopkins)
Newsgroups: comp.lang.pascal,comp.sys.mac.programmer
Subject: Re: help with a pascal program plz
Message-ID: <138@csd4.milw.wisc.edu>
Date: 28 Dec 88 23:20:05 GMT
References: <66066AXS101@PSUVM>
Sender: news@csd4.milw.wisc.edu
Reply-To: markh@csd4.milw.wisc.edu (Mark William Hopkins)
Organization: University of Wisconsin-Milwaukee
Lines: 216


     The changes made to the program preserve the program's input/output 
behavior except in the addition of a sort routine.

     My Turbo Pascal knowledge is nil, but I assume that you can have file
parameters for procedures and multiple parameters in write/writeln Statements.
Also, if character sets are not allowed in Turbo Pascal then change the 13th
line of duplicatedF and the 17th line of menuK.

   You will need to verify it, but with the way the modified program has been
organized, this should not be any problem.  Let me know of the results.

program testing;
const MAX = 100;  (* Up to 100 table entries can be handled. *)
type string = string[64];
     Table = record
		Top: Card;
		List: array[1..MAX] of Card
             end;
     Card = record
               FirstName, LastName, StreetAddr, City, State: string[60];
	       Zip, FirstThree, LastFour, AreaCode: integer;
	       UserID, Blank: string[80]
	    end;
     Key = (FirstK, LastK, CityK, StateK, ZipK, AreaK, PhoneK);

var inF, outF: TEXT; Buffer: Table;
    Option: Key; ok, done: boolean;

(* TEXT FILE ROUTINES: duplicatedF, openF, testF *)

function duplicatedF(name: string): boolean;
(* To determine if the disk file is new or writeable. *)
var tempfile: text;
begin
   (* Disk files end in a ':'. *)
   if pos(':', name) = length(name) then duplicatedF := false
   else begin
      reset(tempfile, name);
      if ioresult <> 0 then duplicatedF := false
      else begin
         write('remove old ', name, '? (y/n) ');
	 readln(ch);
	 duplicatedF := not (ch in ['Y'..'y'])
         close(tempfile)
      end
   end
end;

procedure testF(var inF, outF: TEXT; var ok, done: boolean);
(*
   ok := (The inF and outF files are opened)
   done := (no inF file name was entered)
*)
type access = (R, W);
var named: boolean;

   procedure openF(var F: TEXT; var named, ok: boolean; io: access);
   var Name: string;
   begin
      readln(Name);
      named := (length(Name) > 0);
      if named then case io of 
          R: begin
                reset(F, Name); 
                ok := (ioresult = 0)
             end;
          W: if not duplicatedF(Name) then begin
                rewrite(F, Name);
                ok := (ioresult = 0)
             end
             else ok := false
      end
      else corrupt := false
   end;

begin
   write('input file? ');
   openF(inF, done, ok, R);
   if not done and ok then begin
      write('output file? ');
      openF(outF, named, ok, W);
      if not ok then close(inF)
   end
end;

(* STANDARD I/O ROUTINE: prompt. *)
procedure prompt;
var I: integer;
begin
   for I := 1 to 7 do writeln;
   writeln(' enter the input file volume:name,');
   writeln(' then the output file volume:name,');
   writeln(' or press return to quit.')
end;

(* OPTION KEY ROUTINES: menuK, convertK. *)

function convertK(Ch: char): Key;
begin
   if Ch = 1 then convertK := FirstK
   else if Ch = 2 then convertK := LastK
   else if Ch = 3 then convertK := CityK
   else if Ch = 4 then convertK := StateK
   else if Ch = 5 then convertK := ZipK
   else if Ch = 6 then convertK := AreaK
   else if Ch = 7 then convertK := PhoneK
end;

procedure menuK(var Option: Key);
var Ch: char;
begin
   repeat
      writeln;
      writeln;
      writeln( ' please pick a sort type: ');
      writeln( '            1: FirstName');
      writeln( '            2: LastName');
      writeln( '            3: City');
      writeln( '            4: State');
      writeln( '            5: Zipcode');
      writeln( '            6: area code of phone number');
      writeln( '            7: first three digits of phone');
      write  ( ' your choice: ');
      readln(Ch)
   until Ch in ['1'..'7'];
   Option := convertK(Ch)
end;

(* CARD ROUTINES: readC, writeC, moreC, swapC *)

procedure readC(var inF: TEXT; var C: Card);
begin
   with C do begin
      readln(inF, FirstName); readln(inF, LastName);
      readln(inF, StreetAddr);
      readln(inF, City); readln(inF, State); readln(inF, Zip);
      readln(inF, AreaCode); 
      readln(inF, FirstThree); readln(inF, LastFour);
      readln(inF, UserID);
      readln(inF, Blank);
   end
end;

procedure writeC(var outF: TEXT; C: Card);
begin
   writeln(outF, FirstName, ' ', LastName);
   writeln(outF, StreetAddr);
   writeln(outF, City, ', ', State, ' ', Zip);
   writeln(outF, '(', AreaCode, ') ', FirstThree, '-', LastFour)
end;

function moreC(Option: Key; A, B: Card): boolean;
begin
   case Option of
      FirstK: moreC := (A.FirstName > B.FirstName);
      LastK:  moreC := (A.LastName > B.LastName);
      CityK:  moreC := (A.City > B.City);
      StateK: moreC := (A.State > B.State);
      ZipK:   moreC := (A.Zip > B.Zip);
      AreaK:  moreC := (A.AreaCode > B.AreaCode);
      PhoneK: moreC := (A.FirstThree > B.FirstThree) or
                          (A.FirstThree = B.FirstThree) and
			  (A.LastFour > B.LastFour)
   end
end;

procedure swapC(var A, B: Card);
var C: Card;
begin
   C := A; A := B; B := C
end;

(* TABLE ROUTINES: readT, writeT, sortT *)
procedure readT(var inF: TEXT; var T: Table);
const bs = #8;
begin
   with T do begin
      Top := 0;
      while not eof(inF) and (Top < MAX) do begin
         Top := Top + 1; readC(inF, List[Top])
      end
   end
end;

procedure writeT(var outF: TEXT; T: integer);
const bs = #8;
var I: integer;
begin
   with T do for I := 1 to Top do writeC(outF, List[I])
end;

procedure sortT(Option: Key; var T: Table);
(* Bubble sort or something like that.  I could do a merge sort for you, 
   but it's getting late in the afternoon ... *)
begin
   with T do begin
      for I := 1 to Top - 1 do for J := I + 1 to Top do
	 if moreC(Option, List[I], List[J]) then swapC(List[I], List[J])
   end
end;

begin
   prompt;
   repeat
      writeln;
      testF(inF, outF, ok, done);
      if ok then begin
         readT(inF, Buffer);
         menuK(Option); sortT(Option, Buffer);
         writeT(outF, Buffer);
         close(inF); close(outF);
      end
      else if not done then writeln('ERROR : bad or duplicate file name.');
   until done
end.