home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / USCX / TPCOMPLT.ZIP / LISTMAN.PAS < prev    next >
Pascal/Delphi Source File  |  1986-05-05  |  10KB  |  326 lines
  1. {--------------------------------------------------------------}
  2. {                          ListMan                             }
  3. {                                                              }
  4. {    Mailing list manager demo using dynamic (heap) storage    }
  5. {                                                              }
  6. {                             by Jeff Duntemann                }
  7. {                             Turbo Pascal V3.0                }
  8. {                             Last update 2/1/86               }
  9. {                                                              }
  10. {    From the book, COMPLETE TURBO PASCAL, by Jeff Duntemann   }
  11. {    Scott, Foresman & Co. (c) 1986,1987  ISBN 0-673-18600-8   }
  12. {--------------------------------------------------------------}
  13.  
  14. PROGRAM ListMan;
  15.  
  16. TYPE
  17.   String30 = String[30];       { Using derived string types }
  18.   String6  = String[6];        { makes type NAPRec smaller }
  19.   String3  = String[3];
  20.  
  21.   NAPPtr = ^NAPRec;
  22.   NAPRec = RECORD
  23.              Name    : String30;
  24.              Address : String30;
  25.              City    : String30;
  26.              State   : String3;
  27.              Zip     : String6;
  28.              Next    : NAPPtr      { Points to next NAPRec }
  29.            END;                    { in a linked list }
  30.  
  31.   NAPFile = FILE OF NAPRec;
  32.  
  33.  
  34. VAR
  35.   Ch       : Char;
  36.   Root     : NAPPtr;
  37.   Quit     : Boolean;
  38.  
  39.  
  40.  
  41. {$I YES.SRC }      { Contains Yes }
  42.  
  43.  
  44. PROCEDURE ClearLines(First,Last : Integer);
  45.  
  46. VAR
  47.   I : Integer;
  48.  
  49. BEGIN
  50.   FOR I := First TO Last DO
  51.     BEGIN
  52.       GotoXY(1,I);
  53.       ClrEOL
  54.     END
  55. END;
  56.  
  57.  
  58.  
  59. PROCEDURE ShowRecord(WorkRec : NAPRec);
  60.  
  61. VAR
  62.   I : Integer;
  63.  
  64. BEGIN
  65.   ClearLines(17,22);  { Clear away anything in that spot before }
  66.   GotoXY(1,17);
  67.   WITH WorkRec DO
  68.     BEGIN
  69.       Writeln('>>Name:     ',Name);
  70.       Writeln('>>Address:  ',Address);
  71.       Writeln('>>City:     ',City);
  72.       Writeln('>>State:    ',State);
  73.       Writeln('>>Zip:      ',Zip)
  74.     END
  75. END;
  76.  
  77.  
  78. PROCEDURE CheckSpace;
  79.  
  80. VAR
  81.   Space      : Integer;
  82.   RealRoom   : Real;
  83.   RecordRoom : Real;
  84.  
  85. BEGIN
  86.   Space := MemAvail;    { MemAvail returns negative Integer for   }
  87.                         { space larger than 32,767.  Convert }
  88.                         { (to a real) by adding 65536 if negative }
  89.   IF Space < 0 THEN RealRoom := 65536.0 + Space ELSE RealRoom := Space;
  90.  
  91.   RealRoom := RealRoom * 16;   { Delete this line for Z80 versions! }
  92.                                { MemAvail for 8086 returns 16-byte  }
  93.                                { paragraphs, not bytes!! }
  94.  
  95.   RecordRoom := RealRoom / SizeOf(NAPRec);
  96.   ClearLines(2,3);
  97.   Writeln('>>There is now room for ',RecordRoom:6:0,' records in your list.');
  98. END;
  99.  
  100.  
  101. PROCEDURE ListDispose(VAR Root : NAPPtr);
  102.  
  103. VAR
  104.   Holder : NAPPtr;
  105.  
  106. BEGIN
  107.   GotoXY(27,10); Write('>>Are you SURE? (Y/N): ');
  108.   IF YES THEN
  109.     IF Root <> Nil THEN
  110.       REPEAT
  111.         Holder := Root^.Next;    { First grab the next record...       }
  112.         Dispose(Root);           { ...then dispose of the first one... }
  113.         Root := Holder           { ...then make the next one the first }
  114.       UNTIL Root = Nil;
  115.   ClearLines(10,10);
  116.   CheckSpace
  117. END;
  118.  
  119.  
  120. PROCEDURE AddRecords(VAR Root : NAPPtr);
  121.  
  122. VAR
  123.   I       : Integer;
  124.   Abandon : Boolean;
  125.   WorkRec : NAPRec;
  126.   Last    : NAPPtr;
  127.   Current : NAPPtr;
  128.  
  129. BEGIN
  130.   GotoXY(27,7); Write('<<Adding Records>>');
  131.   REPEAT               { Until user answers 'N' to "MORE?" question... }
  132.     ClearLines(24,24);
  133.     FillChar(WorkRec,SizeOf(WorkRec),CHR(0));  { Zero the record }
  134.     ClearLines(9,15);
  135.     GotoXY(1,9);
  136.     WITH WorkRec DO          { Fill the record with good data }
  137.       BEGIN
  138.         Write('>>Name:     '); Readln(Name);
  139.         Write('>>Address:  '); Readln(Address);
  140.         Write('>>City:     '); Readln(City);
  141.         Write('>>State:    '); Readln(State);
  142.         Write('>>Zip:      '); Readln(Zip)
  143.       END;
  144.     Abandon := False;
  145.                         { Here we traverse list to spot duplicates: }
  146.  
  147.     IF Root = Nil THEN      { If list is empty point Root to record }
  148.       BEGIN
  149.         New(Root);
  150.         WorkRec.Next := Nil;  { Make sure list is terminated by Nil }
  151.         Root^ := WorkRec;
  152.       END
  153.     ELSE                      { ...if there's something in list already   }
  154.       BEGIN
  155.         Current := Root;      { Start traverse at Root of list }
  156.         REPEAT
  157.           IF Current^.Name = WorkRec.Name THEN { If duplicate found }
  158.             BEGIN
  159.               ShowRecord(Current^);
  160.               GotoXY(1,15);
  161.               Write
  162. ('>>The record below duplicates the above entry''s Name.  Toss entry? (Y/N): ');
  163.               IF Yes THEN Abandon := True ELSE Abandon := False;
  164.               ClearLines(15,22)
  165.             END;
  166.           Last := Current;
  167.           Current := Current^.Next
  168.         UNTIL (Current = Nil) OR Abandon OR (Current^.Name > WorkRec.Name);
  169.  
  170.         IF NOT Abandon THEN            { Add WorkRec to the linked list  }
  171.           IF Root^.Name > WorkRec.Name THEN  { New Root item!     }
  172.             BEGIN
  173.               New(Root);               { Create a new dynamic NAPRec  }
  174.               WorkRec.Next := Last;    { Point new record at old Root }
  175.               Root^ := WorkRec         { Point new Root at WorkRec    }
  176.             END
  177.           ELSE
  178.             BEGIN
  179.               NEW(Last^.Next);         { Create a new dynamic NAPRec, }
  180.               WorkRec.Next := Current; { Points its Next to Current  }
  181.               Last^.Next^ := WorkRec;  { and assign WorkRec to it    }
  182.               CheckSpace               { Display remaining heapspace }
  183.             END;
  184.       END;
  185.     GotoXY(1,24); Write('>>Add another record to the list? (Y/N): ');
  186.   UNTIL NOT Yes;
  187. END;
  188.  
  189.  
  190. PROCEDURE LoadList(VAR Root : NAPPtr);
  191.  
  192. VAR
  193.   WorkName : String30;
  194.   WorkFile : NAPFile;
  195.   Current  : NAPPtr;
  196.   I        : Integer;
  197.   OK       : Boolean;
  198.  
  199. BEGIN
  200.   Quit := False;
  201.   REPEAT
  202.     ClearLines(10,10);
  203.     Write('>>Enter the Name of the file you wish to load: ');
  204.     Readln(WorkName);
  205.     IF Length(WorkName) = 0 THEN   { Hit (CR) only to abort LOAD }
  206.       BEGIN
  207.         ClearLines(10,12);
  208.         Quit := True
  209.       END
  210.     ELSE
  211.       BEGIN
  212.         Assign(WorkFile,WorkName);
  213.         {$I-} Reset(WorkFile); {$I+}
  214.         IF IOResult <> 0 THEN          { 0 = OK; 255 = File Not Found }
  215.           BEGIN
  216.             GotoXY(1,12);
  217.             Write('>>That file does not exist.  Please enter another.');
  218.             OK := False
  219.           END
  220.         ELSE OK := True                { OK means File Is open }
  221.       END
  222.     UNTIL OK OR Quit;
  223.   IF NOT Quit THEN
  224.     BEGIN
  225.       ClearLines(10,12);
  226.       Current := Root;
  227.       IF Root = Nil THEN               { If list is currently empty }
  228.         BEGIN
  229.           NEW(Root);                   { Load first record to Root^ }
  230.           Read(WorkFile,Root^);
  231.           Current := Root
  232.         END                            { If list is not empty, find the end: }
  233.       ELSE WHILE Current^.Next <> Nil DO Current := Current^.Next;
  234.       IF Root^.Next <> Nil THEN { If file contains more than 1 record }
  235.       REPEAT
  236.         NEW(Current^.Next);          { Read and add records to list }
  237.         Current := Current^.Next;    { until a record's Next field  }
  238.         Read(WorkFile,Current^)      { comes up Nil   }
  239.       UNTIL Current^.Next = Nil;
  240.       CheckSpace;
  241.       Close(WorkFile)
  242.     END
  243. END;
  244.  
  245.  
  246. PROCEDURE ViewList(Root : NAPPtr);
  247.  
  248. VAR
  249.   I        : Integer;
  250.   WorkFile : NAPFile;
  251.   Current  : NAPPtr;
  252.  
  253. BEGIN
  254.   IF Root = Nil THEN                 { Nothing is now in the list }
  255.     BEGIN
  256.       GotoXY(27,18);
  257.       Writeln('<<Your list is empty!>>');
  258.       GotoXY(26,20);
  259.       Write('>>Press (CR) to continue: ');
  260.       Readln
  261.     END
  262.   ELSE
  263.     BEGIN
  264.       GotoXY(31,7); Write('<<Viewing Records>>');
  265.       Current := Root;
  266.       WHILE Current <> Nil DO   { Traverse and display until Nil found }
  267.         BEGIN
  268.           ShowRecord(Current^);
  269.           GotoXY(1,23);
  270.           Write('>>Press (CR) to view Next record in the list: ');
  271.           Readln;
  272.           Current := Current^.Next
  273.         END;
  274.       ClearLines(19,22)
  275.     END
  276. END;
  277.  
  278.  
  279. PROCEDURE SaveList(Root : NAPPtr);
  280.  
  281. VAR
  282.   WorkName : String30;
  283.   WorkFile : NAPFile;
  284.   Current  : NAPPtr;
  285.   I        : Integer;
  286.  
  287. BEGIN
  288.   GotoXY(1,10);
  289.   Write('>>Enter the filename for saving out your list: ');
  290.   Readln(WorkName);
  291.   Assign(WorkFile,WorkName);   { Open the file for write access }
  292.   Rewrite(WorkFile);
  293.   Current := Root;
  294.   WHILE Current <> Nil DO      { Traverse and write }
  295.     BEGIN
  296.       Write(WorkFile,Current^);
  297.       Current := Current^.Next
  298.     END;
  299.   Close(WorkFile)
  300. END;
  301.  
  302.  
  303.  
  304. BEGIN       { MAIN }
  305.   ClrScr;
  306.   GotoXY(28,1); Write('<<Linked List Maker>>');
  307.   CheckSpace;
  308.   GotoXY(17,8);  Write('--------------------------------------------');
  309.   Root := Nil; Quit := False;
  310.   REPEAT
  311.     ClearLines(5,7);
  312.     ClearLines(9,24);
  313.     GotoXY(1,5);
  314.     Write
  315.     ('>>[L]oad, [A]dd record, [V]iew, [S]ave, [C]lear list, or [Q]uit: ');
  316.     Readln(Ch);                    { Get a command }
  317.     CASE Ch OF
  318.      'A','a' : AddRecords(Root);  { Parse the command & perform it }
  319.      'C','c' : ListDispose(Root);
  320.      'L','l' : LoadList(Root);
  321.      'S','s' : SaveList(Root);
  322.      'V','v' : ViewList(Root);
  323.      'Q','q' : Quit := True;
  324.     END; { CASE }
  325.   UNTIL Quit
  326. END.