home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / turbopas / sllist.arc / SLLIST.PAS < prev   
Pascal/Delphi Source File  |  1989-03-10  |  12KB  |  499 lines
  1. {$A+,B+,D+,E+,F-,I+,L+,N-,O-,R+,S+,V-}
  2. {$M 8192,0,655360}
  3.  
  4. program SinglyLinkedList;
  5.  
  6. uses crt,dos;
  7. type
  8.  _str80         = string[80];
  9.  _str30         = string[30];
  10.  _str20         = string[20];
  11.  _wordP         = ^_wordrec;
  12.  _wordrec       = record
  13.                     index  : word;
  14.                     aword  : _str20;
  15.                     next   :_wordP;
  16.                   end;
  17.  
  18.   _infiletype1  = text;
  19.   _infiletype2  = file of _wordrec;
  20.   _outfiletype1 = text;
  21.   _outfiletype2 = file of _wordrec;
  22.  
  23. var
  24.   start,last  : _wordP;
  25.   t,t2        : integer;
  26.   infile1     : _infiletype1;
  27.   infile2     : _infiletype2;
  28.   outfile1    : _outfiletype1;
  29.   outfile2    : _outfiletype2;
  30.   infilename,
  31.   outfilename : _str30;
  32.   done        : boolean;
  33.   savindex    : word;
  34.   savattr     : byte;
  35.  
  36. function MenuSelect:char;
  37. var ch:char;
  38. begin
  39.   writeln;
  40.   writeln('   1. Enter a new word.');
  41.   writeln('   2. Delete a word.');
  42.   writeln('   3. Display the list of words.');
  43.   writeln('   4. Search for a word.');
  44.   writeln('   5. Save the word list to disk.');
  45.   writeln('   6. Load a word list from disk.');
  46.   writeln('   7. Load words, then Select random words and save to disk.');
  47.   writeln('   0. Quit.');
  48.   repeat
  49.     write(#13);
  50.     write('                       Enter choice...');
  51.     ch := upcase(readkey);
  52.   until (ch in ['0'..'7']);
  53.   MenuSelect := ch;
  54. end; (* MenuSelect *)
  55.  
  56. function Mono : boolean;
  57. var
  58.   Regs : Registers;
  59. begin
  60.   intr(17,dos.Registers(Regs));
  61.   if (Regs.AX and $0030) = $30 then Mono := true
  62.   else Mono := false
  63. end;(* Mono *)
  64.  
  65. procedure CursorOn;
  66. var    Regs : Registers;
  67. begin
  68.   with Regs do begin
  69.       AX := $0100;
  70.       if Mono then CX := $0B0C else CX := $0607;
  71.     end;
  72.   intr(16,Regs);
  73. end; (* CursorOn *)
  74.  
  75. function Store(info,start : _wordP;
  76.                  var last : _wordP):_wordP;
  77. (*** stores entries in sorted order ***)
  78. var
  79.   old,top  : _wordP;
  80.   done     : boolean;
  81. begin
  82.   top  := start;
  83.   old  := NIL;
  84.   done := false;
  85.  
  86.   if start = NIL then
  87.   begin                       (* first element in the list *)
  88.     info^.next  := NIL;
  89.     last  := info;
  90.     Store := info;
  91.   end else
  92.   begin
  93.     while (start <> NIL) and (not done) do
  94.     begin
  95.       if (start^.aword < info^.aword) then
  96.       begin
  97.         old := start;
  98.         start := start^.next
  99.       end else
  100.       begin                (* goes in the middle *)
  101.         if old <> NIL then
  102.         begin
  103.           old^.next  := info;
  104.           info^.next := start;
  105.           Store := top;    (* keep same starting point *)
  106.           done := true
  107.         end else
  108.         begin
  109.           info^.next := start; (* new first element *)
  110.           Store := info;
  111.           done := true
  112.         end;
  113.       end;
  114.     end; (*while *)
  115.     if (not done) then
  116.       begin
  117.         last^.next := info;    (* goes on end *)
  118.         info^.next := NIL;
  119.         last := info;
  120.         Store := top
  121.       end;
  122.   end;
  123. end;(* Store *)
  124.  
  125. function Delete(VAR start : _wordP;
  126.            item,prioritem : _wordP) : _wordP;
  127. begin
  128.   clrscr;
  129.   writeln('The word #',item^.index,' "',item^.aword,'" will be deleted.');
  130.   repeat until keypressed;
  131.   if (prioritem <> NIL) then
  132.     prioritem^.next := item^.next
  133.   else start := item^.next;
  134.   Delete := start
  135. end; (* Delete *)
  136.  
  137. function GetPrior(start_ : _wordP;
  138.        VAR item_, prior_ : _wordP;
  139.                        x : word) : _wordP;
  140.  
  141. begin
  142.                                  
  143.   if (x = 1) then          (* Then "x" is the first in the list or index #1 *)
  144.     begin
  145.       prior_  := NIL;
  146.       item_   := start
  147.     end else
  148.     begin
  149.       prior_ := start;
  150.       item_  := start^.next;
  151.       while (item_^.index) < x  do
  152.       begin
  153.         prior_  := item_;                   (* *)
  154.         item_   := item_^.next;
  155.         write(prior_^.aword);
  156.         write(item_^.aword)
  157.       end;
  158.     end;
  159.  
  160.   GetPrior := prior_
  161. end; (* GetPrior *)
  162.  
  163. procedure Remove{(start : _wordP)};
  164. var
  165.   ix : word;
  166.   item,prior : _wordP;
  167. begin
  168.   writeln;
  169.   writeln('   Enter the index # of the word to delete from list OR');
  170.   write  ('                                      Enter a 0 to quit: ');
  171.   read(ix);
  172.   if (ix = 0) then exit;
  173.   writeln;
  174.   prior := GetPrior(start,item,prior,ix);
  175.   start := Delete(start,item,prior)
  176. end; (* Remove *)
  177.  
  178. procedure Enter;
  179. var
  180.   info : _wordP;
  181.   done : boolean;
  182. begin
  183.   done := false;
  184.   repeat
  185.     New(info);               (** get a new record **)
  186.     writeln;
  187.     write('   Enter a word to enter into the list: ');
  188.     readln(info^.aword); writeln;
  189.     if (length(info^.aword)) = 0 then done := true
  190.     else
  191.     begin
  192.       start := Store(info,start,last);         (** Store it **)
  193.     end;
  194.   until (done)
  195. end; (* Enter *)
  196.  
  197. procedure Display(start : _wordP);
  198. begin
  199.   window(1,1,80,25); clrscr;
  200.   writeln;writeln;
  201.   if (start = NIL) then
  202.     writeln('The list is empty!!!')
  203.     else while (start <> NIL) do
  204.     begin
  205.       with start^ do
  206.         begin
  207.           write(index:5,' ',aword,' ');
  208.         end;
  209.       start := start^.next;
  210.     end;
  211.   writeln; writeln('Press [Enter] to continue...');readln; writeln;
  212.   textattr := savattr;
  213.   clrscr;
  214. end; (* Display *)
  215.  
  216. function Search( start : _wordP;
  217.                 ix     : word         ):_wordP;
  218. var
  219.   done : boolean;
  220. begin
  221.   done := false;
  222.   while (start <> NIL) and (not done) do
  223.     begin
  224.       if (ix = start^.index) then
  225.         begin
  226.           Search := start;
  227.           done := true
  228.         end else
  229.           start := start^.next
  230.     end;
  231.   if (start = NIL) then
  232.     search := NIL;  (* not in list *)
  233. end; (* Search *)
  234.  
  235. procedure Find1;
  236. var
  237.   loc   : _wordP;
  238.   inx : word;
  239. begin
  240.   clrscr;
  241.   writeln;
  242.   writeln('   Enter the index # of the word to find OR');
  243.   write  ('                            enter 0 to quit: ');
  244.   read(inx);
  245.   if inx = 0 then exit;
  246.   writeln;
  247.   loc := Search(start,inx);
  248.   if (loc <> NIL) then
  249.     begin
  250.       writeln('   Word # ',inx,' is ',loc^.aword);
  251.       writeln;
  252.       writeln('   Press any key to continue...');repeat until keypressed;
  253.     end
  254.   else
  255.   begin
  256.     writeln('   Word # ',inx,' is not in the list!');
  257.     writeln;
  258.     writeln('   Press any key to continue...');repeat until keypressed;
  259.   end;
  260. end; (* Find1 *)
  261.  
  262. {
  263. procedure Find2;
  264. var
  265.   loc  :_addrPointer;
  266.   name :_str80;
  267. begin
  268.   writeln;
  269.   write('Enter Name to find: ');
  270.   readln(name); writeln;
  271.   loc := Search(start,name);
  272.   if (loc <> NIL) then
  273.     begin
  274.       writeln('■',loc^.name,'■');
  275.       writeln('■',loc^.street,'■');
  276.       writeln('■',loc^.city,'■');
  277.       writeln('■',loc^.state,'■');
  278.       writeln('■',loc^.zip,'■'); (* writeln; *)
  279.     end
  280.   else
  281.     writeln('Name not in list!'); writeln;
  282.   writeln('Press [Enter] to continue...');readln;
  283. end; (* Find2 *)
  284. }
  285.  
  286. procedure Save1(var fil   : _outfiletype1;
  287.                     start : _wordP);
  288. begin
  289.   window(1,1,80,25);
  290.   rewrite(fil);
  291.   while(start <> NIL) do
  292.     begin
  293.       writeln(fil,start^.aword);
  294.       with start^ do
  295.         begin
  296.           write(index:5,' ',aword,' ');
  297.         end;
  298.       start := start^.next
  299.     end;
  300.   close(fil);
  301.   writeln('   Press any key to continue...');repeat until keypressed;
  302.   textattr := savattr; clrscr;
  303. end; (* Save *)
  304.  
  305. procedure Save2(var fil   : _outfiletype2;
  306.                     start :_wordP);
  307. begin
  308.   writeln;
  309.   writeln('Saving file...');
  310.   rewrite(fil);
  311.   while(start <> NIL) do
  312.     begin
  313.       write(fil,start^);
  314.       { with start^ do }
  315.         { begin }
  316.         { end; }
  317.       start := start^.next
  318.     end;
  319.   close(fil);
  320.   writeln;writeln('Press [Enter] to continue...');readln;
  321. end; (* Save2 *)
  322.  
  323. function Load1(var fil   : _infiletype1;         (*** text file ***)
  324.                    start : _wordP):_wordP;
  325. (***** returns a pointer to start of the list *****)
  326. var
  327.   temp,temp2 :_wordP;
  328.   first      : boolean;
  329.   line       : _str20;
  330.   indx       : word;
  331. begin
  332.   writeln;
  333.   writeln('                       Loading file...');
  334.   reset(fil);
  335.   while (start <> NIL) do    (* free memory, if any reserved *)
  336.     begin
  337.       temp := start^.next;
  338.       Dispose(start);
  339.       start := temp
  340.     end;
  341.  
  342.   start := NIL; last := NIL; indx := 1;
  343.   if (not eof(fil)) then
  344.     begin
  345.       New(temp);
  346.       readln(fil,line);
  347.       temp^.aword := line;
  348.       temp^.index := indx;
  349.       temp^.next := NIL;
  350.       load1 := temp;          (* pointer to start of list *)
  351.     end;
  352.  
  353.   while (not eof(fil)) do
  354.     begin
  355.       New(temp2);
  356.       readln(fil,line);
  357.       inc(indx);
  358.       temp2^.aword := line;
  359.       temp2^.index := indx;
  360.       temp^.next := temp2;   (* now build list *)
  361.       temp2^.next := NIL;
  362.       temp := temp2;
  363.     end;
  364.   last := temp2;
  365.   savindex := indx;
  366.   close(fil);
  367.   Delay(500);
  368. end; (* Load1 *)
  369.  
  370. function Load2(var fil   : _infiletype2;  (*** file of records ***)
  371.                    start : _wordP):_wordP;
  372. (***** returns a pointer to start of the list *****)
  373. var
  374.   temp,temp2 :_wordP;
  375.   first      : boolean;
  376.   line       : _str20;
  377.   indx       : word;
  378. begin
  379.   writeln;
  380.   writeln('                        Loading file...');
  381.   reset(fil);
  382.   while (start <> NIL) do    (* free memory, if any reserved *)
  383.     begin
  384.       temp := start^.next;
  385.       Dispose(start);
  386.       start := temp
  387.     end;
  388.  
  389.   start := NIL; last := NIL; indx := 1;
  390.   if (not eof(fil)) then
  391.     begin
  392.       New(temp);
  393.       read(fil,temp^);
  394.       temp^.aword := line;
  395.       temp^.index := indx;
  396.       temp^.next := NIL;
  397.       load2 := temp;          (* pointer to start of list *)
  398.     end;
  399.  
  400.   while (not eof(fil)) do
  401.     begin
  402.       New(temp2);
  403.       read(fil,temp2^);
  404.       inc(indx);
  405.       temp2^.aword := line;
  406.       temp2^.index := indx;
  407.       temp^.next := temp2;   (* now build list *)
  408.       temp2^.next := NIL;
  409.       temp := temp2;
  410.     end;
  411.   last := temp2;
  412.   close(fil);
  413.   Delay(500);
  414. end; (* Load2 *)
  415.  
  416. procedure Select;
  417. var
  418.   i,
  419.   rnd, numwords : word;
  420.   getword       : _wordP;
  421. begin
  422.   clrscr;
  423.   writeln;
  424.   write('   Enter name of source file: ');
  425.   readln(infilename);if (infilename = '') then exit;
  426.  
  427.   writeln;
  428.   write('   Enter name of destination file: ');
  429.   readln(outfilename);if (outfilename = '') then exit;
  430.   writeln;
  431.  
  432.   assign(infile1,infilename);
  433.   reset(infile1);
  434.   assign(outfile1,outfilename);
  435.   rewrite(outfile1);
  436.   start := Load1(infile1,start);
  437.  
  438.   writeln; write('   Enter the number of random words desired: ');
  439.   readln(numwords);
  440.   if (numwords <= savindex) and (numwords >0 ) then
  441.     begin
  442.       Randomize;
  443.       for i := 1 to numwords do
  444.         begin
  445.           rnd := Random(savindex)+1;
  446.           getword := Search(start,rnd);
  447.           writeln(outfile1,getword^.aword);
  448.           write(getword^.aword,' ');
  449.         end;
  450.       writeln;writeln(numwords,' random words saved to >> ',outfilename,' <<');
  451.       writeln('     Press any key to continue...');repeat until keypressed;
  452.     end else
  453.     begin
  454.       exit;
  455.     end;
  456.   close(outfile1);
  457. end; (* Select *)
  458.  
  459. begin (* Main *)
  460.   start := NIL;              (* initially empty list *)
  461.   last := NIL;
  462.   done := false;
  463.  
  464.   savattr := textattr;
  465.  
  466.   infilename :=  '9.dat';
  467.   assign(infile1,infilename);
  468.  
  469.   outfilename := 'sample.$$$';
  470.   assign(outfile1,outfilename);
  471.  
  472.   repeat
  473.     window(5,7,75,19);
  474.     textattr := white + cyan*16; CursorOn;
  475.     clrscr;
  476.     case MenuSelect of
  477.       '1': Enter;
  478.       '2': Remove{(start)};
  479.       '3': Display(start);
  480.       '4': Find1;
  481.       '5': Save1(outfile1,start);     (*save as text file *)
  482.      {'5': Save2(outfile2,start);     (*save with index as file of _wordrec*) }
  483.       '6': start := Load1(infile1,start);
  484.      {'6': start := Load2(infile1,start); }
  485.       '7': Select;                    (*get random words and save to disk *)
  486.       '0': done := true
  487.     end;
  488.   until (done);
  489.   window(1,1,80,25);
  490. end. (* SLL1*)
  491.  
  492.  
  493.  
  494.  
  495.  
  496.  
  497.  
  498.  
  499.