Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PASDEMO2.ZIP/D_LINK1.PAS

Pascal/Delphi Source File | 1987-09-09 | 7.7 KB | 274 lines

(* A mailing list
   That uses a Double Linked List

   Here is a simple mailing list program that uses a double linked list. The
   entire list is kept in memory while in use; howvwe, the program can be
   modified to store the mailing list in a disk file. *)

program Mail_List;      { page 56 }

type Str80 = string[80];
     AddrPointer = ^address;
     address = record
             Name:   string[30];
             Street: string[40];
             City:   string[20];
             State:  string[2];
             Zip:    string[9];
             Next:   AddrPointer;   { pointer to next record }
             Prior:  AddrPointer;   { pointer to previous record }
          end;
     DataItem  = address;
     DataArray = array[ 1..100 ] of AddrPointer;
                                         { hold pointers to address records }
     filetype = file of address;
var Test: DataArray;
    T, T2:       integer;
    MList:       FileType;
    Start, Last: AddrPointer;
    Done:        boolean;

function MenuSelect: char;  { return the users selection }
   var ch: char;
   begin
      writeln( '1. Enter names' );
      writeln( '2. Delete a name' );
      writeln( '3. Display the list' );
      writeln( '4. Search the list' );
      writeln( '5. Save the list' );
      writeln( '6. Load the list' );
      writeln( '7. Quit' );
      repeat
         writeln;
         write( 'Enter your choice: ' );
         read( ch ); ch := upcase( ch ); writeln;
      until ( ch >= '1' ) and ( ch <= '7' );
      Menuselect := ch;
   end; { MenuSelect }

function DSL_Store( Info, Start: AddrPointer; var Last: AddrPointer ):
                    AddrPointer; { store entries in sorted order }
   var Old, Top: ^Address;
       Done: boolean;
   begin
      Top := Start;
      Old := nil;
      Done := false;

      if Start = nil then
      begin  { first element in list }
         Info^.Next := nil;
         Last := Info;
         Info^.Prior := nil;
         DSL_Store := Info;
      end else
      begin
         while ( start <> nil ) and ( not Done ) do
         begin
            if Start^. Name < Info^.Name then
            begin
               Old := Start;
               Start := Start^.Next;
            end else
            begin   { goes in middle }
               if Old <> nil then
               begin
                  Old^.Next := Info;
                  Info^.Next := Start;
                  Start^.Prior := Info;
                  Info^.Prior := Old;
                  DSL_Store := Top;  { keep same starting point }
                  Done := true;
               end else
               begin
                  Info^.Next := Start;  { new first element }
                  Info^.Prior := Info;
                  Done := true;
               end;
            end;
         end { while };
         if not Done then
         begin
            Last^.Next := Info;  { goes on end }
            Info^.Next := nil;
            Info^.Prior := Last;
            Last := Info;
            DSL_Store := Top;
         end;
      end;
   end; { DSL_Store }

function DL_Delete( Start: AddrPointer; key: str80 ): AddrPointer;
   var Temp, Temp2: AddrPointer;
       Done: boolean;
   begin
      if Start^.Name = key then
      begin
         DL_Delete := Start^.Next;
         if Temp^.Next <> nil then
         begin
            Temp := Start^.Next;
            Temp^.Prior := nil;
         end;
         dispose( Start );
      end else
      begin
         Done := false;
         Temp := Start^.Next;
         Temp2 := Start;
         while ( Temp <> nil ) and ( not Done ) do
         begin
            if Temp^.Name = key then
            begin
               Temp2^.Next := Temp^.Next;
               if Temp^.Next <> nil then
                  Temp^.Next^.Prior := Temp2;
               Done := True;
               dispose( Temp );
            end else
            begin
               Temp2 := Temp;
               Temp := Temp^.Next;
            end;
         end;
         DL_Delete := Start;   { still same starting point }
         if not Done then Writeln( 'not found' );
      end;
   end { DL_Delete };

procedure Remove;
   var Name: Str80;
   begin
      write( 'Enter name to delete: ' );
      read( Name ); writeln;
      Start := DL_Delete( Start, Name );
   end { Remove };

procedure Enter;
   var Info: AddrPointer;
       Done: boolean;
   begin
      Done := false;
      repeat
         new( Info );   { get a new record }
         write( 'Enter name: ' );
         read( Info^.Name );
         writeln;
         if length( Info^.Name ) = 0 then Done := true
         else begin
            write( 'Enter street: ' );
            readln( Info^.Street );
            write( 'Enter city: ' );
            readln( Info^.City );
            write( 'Enter state: ' );
            readln( Info^.State );
            write( 'Enter zip: ' );
            readln( Info^.Zip );
            Start := DSL_Store( Info, Start, Last );   { store it }
         end;
      until Done;
   end { Enter };

procedure Display( Start: AddrPointer );
   begin
      while Start <> nil do begin
         writeln( Start^.Name );
         writeln( Start^.Street );
         writeln( Start^.City );
         writeln( Start^.State );
         writeln( Start^.Zip );
         Start := Start^.Next;
      end { while };
   end { Display };

function Search( Start: AddrPointer; Name: Str80 ): AddrPointer;
   var Done: boolean;
   begin
      Done := false;
      while ( Start <> nil ) and ( not Done ) do begin
         if Name = Start^.Name then
            begin Search := Start;
                  Done := true;
            end
         else Start := Start^.Next;
      end { while };
      if Start = nil then Search := nil;   { not in list }
   end { Search };

procedure Find;
   var Loc: AddrPointer;
       Name: Str80;
   begin
      write( 'Enter name to find: ' );
      readln( Name );
      Loc := Search( Start, Name );
      if Loc <> nil then writeln( Loc^.Name )
      else writeln( 'not in list ' );
   end { Find };

procedure Save( var F: FileType; Start: AddrPointer );
   begin
      writeln( 'saving file' );
      rewrite( F );
      while STart <> nil do
      begin
         write( F, Start^ );
         Start := Start^.Next;
      end;
   end { Save };

function Load( var F: FileType; Start: AddrPointer ): AddrPointer;
{ return a pointer to the start of the list }
   var Temp, Temp2: AddrPointer;
       First: boolean;
   begin
      writeln( 'Load file' );
      reset( F );
      while Start <> nil do
      begin   { free memory, if any }
         Temp := Start^.Next;
         dispose( Start );
         Start := Temp;
      end;

      Start := nil; Last := nil;
      if not eof( F ) then
      begin
         new( Temp );
         read( F, Temp^ );
         Temp^.Next := nil;  Temp^.Prior := nil;
         Load := Temp;   { pointer to start of list }
      end;

      while not eof( F ) do
      begin
         New( Temp2 );
         read( F, Temp2^ );
         Temp^.Next := Temp2; { build list }
         Temp2^.Next := nil;
         Temp^.Prior := Temp2;
         Temp := Temp2;
      end;
      Last := Temp2;
   end; { Load }

begin
   Start := nil;   { initially empty list }
   Last := nil;
   Done := false;

   Assign( MList, 'a:\advanced\mlist.dat' );

   repeat
      case MenuSelect of
         '1': Enter;
         '2': Remove;
         '3': Display( Start );
         '4': Find;
         '5': Save( MList, Start );
         '6': Start := Load( MList, Start );
         '7': Done := true;
      end;
   until Done = true;

end. { MList }