ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/SLLIST.ZIP/SLLIST.PAS

Pascal/Delphi Source File | 1989-03-10 | 11.8 KB | 499 lines

{$A+,B+,D+,E+,F-,I+,L+,N-,O-,R+,S+,V-}
{$M 8192,0,655360}

program SinglyLinkedList;

uses crt,dos;
type
 _str80         = string[80];
 _str30         = string[30];
 _str20         = string[20];
 _wordP         = ^_wordrec;
 _wordrec       = record
                    index  : word;
                    aword  : _str20;
                    next   :_wordP;
                  end;

  _infiletype1  = text;
  _infiletype2  = file of _wordrec;
  _outfiletype1 = text;
  _outfiletype2 = file of _wordrec;

var
  start,last  : _wordP;
  t,t2        : integer;
  infile1     : _infiletype1;
  infile2     : _infiletype2;
  outfile1    : _outfiletype1;
  outfile2    : _outfiletype2;
  infilename,
  outfilename : _str30;
  done        : boolean;
  savindex    : word;
  savattr     : byte;

function MenuSelect:char;
var ch:char;
begin
  writeln;
  writeln('   1. Enter a new word.');
  writeln('   2. Delete a word.');
  writeln('   3. Display the list of words.');
  writeln('   4. Search for a word.');
  writeln('   5. Save the word list to disk.');
  writeln('   6. Load a word list from disk.');
  writeln('   7. Load words, then Select random words and save to disk.');
  writeln('   0. Quit.');
  repeat
    write(#13);
    write('                       Enter choice...');
    ch := upcase(readkey);
  until (ch in ['0'..'7']);
  MenuSelect := ch;
end; (* MenuSelect *)

function Mono : boolean;
var
  Regs : Registers;
begin
  intr(17,dos.Registers(Regs));
  if (Regs.AX and $0030) = $30 then Mono := true
  else Mono := false
end;(* Mono *)

procedure CursorOn;
var    Regs : Registers;
begin
  with Regs do begin
      AX := $0100;
      if Mono then CX := $0B0C else CX := $0607;
    end;
  intr(16,Regs);
end; (* CursorOn *)

function Store(info,start : _wordP;
                 var last : _wordP):_wordP;
(*** stores entries in sorted order ***)
var
  old,top  : _wordP;
  done     : boolean;
begin
  top  := start;
  old  := NIL;
  done := false;

  if start = NIL then
  begin                       (* first element in the list *)
    info^.next  := NIL;
    last  := info;
    Store := info;
  end else
  begin
    while (start <> NIL) and (not done) do
    begin
      if (start^.aword < info^.aword) then
      begin
        old := start;
        start := start^.next
      end else
      begin                (* goes in the middle *)
        if old <> NIL then
        begin
          old^.next  := info;
          info^.next := start;
          Store := top;    (* keep same starting point *)
          done := true
        end else
        begin
          info^.next := start; (* new first element *)
          Store := info;
          done := true
        end;
      end;
    end; (*while *)
    if (not done) then
      begin
        last^.next := info;    (* goes on end *)
        info^.next := NIL;
        last := info;
        Store := top
      end;
  end;
end;(* Store *)

function Delete(VAR start : _wordP;
           item,prioritem : _wordP) : _wordP;
begin
  clrscr;
  writeln('The word #',item^.index,' "',item^.aword,'" will be deleted.');
  repeat until keypressed;
  if (prioritem <> NIL) then
    prioritem^.next := item^.next
  else start := item^.next;
  Delete := start
end; (* Delete *)

function GetPrior(start_ : _wordP;
       VAR item_, prior_ : _wordP;
                       x : word) : _wordP;

begin

  if (x = 1) then          (* Then "x" is the first in the list or index #1 *)
    begin
      prior_  := NIL;
      item_   := start
    end else
    begin
      prior_ := start;
      item_  := start^.next;
      while (item_^.index) < x  do
      begin
        prior_  := item_;                   (* *)
        item_   := item_^.next;
        write(prior_^.aword);
        write(item_^.aword)
      end;
    end;

  GetPrior := prior_
end; (* GetPrior *)

procedure Remove{(start : _wordP)};
var
  ix : word;
  item,prior : _wordP;
begin
  writeln;
  writeln('   Enter the index # of the word to delete from list OR');
  write  ('                                      Enter a 0 to quit: ');
  read(ix);
  if (ix = 0) then exit;
  writeln;
  prior := GetPrior(start,item,prior,ix);
  start := Delete(start,item,prior)
end; (* Remove *)

procedure Enter;
var
  info : _wordP;
  done : boolean;
begin
  done := false;
  repeat
    New(info);               (** get a new record **)
    writeln;
    write('   Enter a word to enter into the list: ');
    readln(info^.aword); writeln;
    if (length(info^.aword)) = 0 then done := true
    else
    begin
      start := Store(info,start,last);         (** Store it **)
    end;
  until (done)
end; (* Enter *)

procedure Display(start : _wordP);
begin
  window(1,1,80,25); clrscr;
  writeln;writeln;
  if (start = NIL) then
    writeln('The list is empty!!!')
    else while (start <> NIL) do
    begin
      with start^ do
        begin
          write(index:5,' ',aword,' ');
        end;
      start := start^.next;
    end;
  writeln; writeln('Press [Enter] to continue...');readln; writeln;
  textattr := savattr;
  clrscr;
end; (* Display *)

function Search( start : _wordP;
                ix     : word         ):_wordP;
var
  done : boolean;
begin
  done := false;
  while (start <> NIL) and (not done) do
    begin
      if (ix = start^.index) then
        begin
          Search := start;
          done := true
        end else
          start := start^.next
    end;
  if (start = NIL) then
    search := NIL;  (* not in list *)
end; (* Search *)

procedure Find1;
var
  loc   : _wordP;
  inx : word;
begin
  clrscr;
  writeln;
  writeln('   Enter the index # of the word to find OR');
  write  ('                            enter 0 to quit: ');
  read(inx);
  if inx = 0 then exit;
  writeln;
  loc := Search(start,inx);
  if (loc <> NIL) then
    begin
      writeln('   Word # ',inx,' is ',loc^.aword);
      writeln;
      writeln('   Press any key to continue...');repeat until keypressed;
    end
  else
  begin
    writeln('   Word # ',inx,' is not in the list!');
    writeln;
    writeln('   Press any key to continue...');repeat until keypressed;
  end;
end; (* Find1 *)

{
procedure Find2;
var
  loc  :_addrPointer;
  name :_str80;
begin
  writeln;
  write('Enter Name to find: ');
  readln(name); writeln;
  loc := Search(start,name);
  if (loc <> NIL) then
    begin
      writeln('■',loc^.name,'■');
      writeln('■',loc^.street,'■');
      writeln('■',loc^.city,'■');
      writeln('■',loc^.state,'■');
      writeln('■',loc^.zip,'■'); (* writeln; *)
    end
  else
    writeln('Name not in list!'); writeln;
  writeln('Press [Enter] to continue...');readln;
end; (* Find2 *)
}

procedure Save1(var fil   : _outfiletype1;
                    start : _wordP);
begin
  window(1,1,80,25);
  rewrite(fil);
  while(start <> NIL) do
    begin
      writeln(fil,start^.aword);
      with start^ do
        begin
          write(index:5,' ',aword,' ');
        end;
      start := start^.next
    end;
  close(fil);
  writeln('   Press any key to continue...');repeat until keypressed;
  textattr := savattr; clrscr;
end; (* Save *)

procedure Save2(var fil   : _outfiletype2;
                    start :_wordP);
begin
  writeln;
  writeln('Saving file...');
  rewrite(fil);
  while(start <> NIL) do
    begin
      write(fil,start^);
      { with start^ do }
        { begin }
        { end; }
      start := start^.next
    end;
  close(fil);
  writeln;writeln('Press [Enter] to continue...');readln;
end; (* Save2 *)

function Load1(var fil   : _infiletype1;         (*** text file ***)
                   start : _wordP):_wordP;
(***** returns a pointer to start of the list *****)
var
  temp,temp2 :_wordP;
  first      : boolean;
  line       : _str20;
  indx       : word;
begin
  writeln;
  writeln('                       Loading file...');
  reset(fil);
  while (start <> NIL) do    (* free memory, if any reserved *)
    begin
      temp := start^.next;
      Dispose(start);
      start := temp
    end;

  start := NIL; last := NIL; indx := 1;
  if (not eof(fil)) then
    begin
      New(temp);
      readln(fil,line);
      temp^.aword := line;
      temp^.index := indx;
      temp^.next := NIL;
      load1 := temp;          (* pointer to start of list *)
    end;

  while (not eof(fil)) do
    begin
      New(temp2);
      readln(fil,line);
      inc(indx);
      temp2^.aword := line;
      temp2^.index := indx;
      temp^.next := temp2;   (* now build list *)
      temp2^.next := NIL;
      temp := temp2;
    end;
  last := temp2;
  savindex := indx;
  close(fil);
  Delay(500);
end; (* Load1 *)

function Load2(var fil   : _infiletype2;  (*** file of records ***)
                   start : _wordP):_wordP;
(***** returns a pointer to start of the list *****)
var
  temp,temp2 :_wordP;
  first      : boolean;
  line       : _str20;
  indx       : word;
begin
  writeln;
  writeln('                        Loading file...');
  reset(fil);
  while (start <> NIL) do    (* free memory, if any reserved *)
    begin
      temp := start^.next;
      Dispose(start);
      start := temp
    end;

  start := NIL; last := NIL; indx := 1;
  if (not eof(fil)) then
    begin
      New(temp);
      read(fil,temp^);
      temp^.aword := line;
      temp^.index := indx;
      temp^.next := NIL;
      load2 := temp;          (* pointer to start of list *)
    end;

  while (not eof(fil)) do
    begin
      New(temp2);
      read(fil,temp2^);
      inc(indx);
      temp2^.aword := line;
      temp2^.index := indx;
      temp^.next := temp2;   (* now build list *)
      temp2^.next := NIL;
      temp := temp2;
    end;
  last := temp2;
  close(fil);
  Delay(500);
end; (* Load2 *)

procedure Select;
var
  i,
  rnd, numwords : word;
  getword       : _wordP;
begin
  clrscr;
  writeln;
  write('   Enter name of source file: ');
  readln(infilename);if (infilename = '') then exit;

  writeln;
  write('   Enter name of destination file: ');
  readln(outfilename);if (outfilename = '') then exit;
  writeln;

  assign(infile1,infilename);
  reset(infile1);
  assign(outfile1,outfilename);
  rewrite(outfile1);
  start := Load1(infile1,start);

  writeln; write('   Enter the number of random words desired: ');
  readln(numwords);
  if (numwords <= savindex) and (numwords >0 ) then
    begin
      Randomize;
      for i := 1 to numwords do
        begin
          rnd := Random(savindex)+1;
          getword := Search(start,rnd);
          writeln(outfile1,getword^.aword);
          write(getword^.aword,' ');
        end;
      writeln;writeln(numwords,' random words saved to >> ',outfilename,' <<');
      writeln('     Press any key to continue...');repeat until keypressed;
    end else
    begin
      exit;
    end;
  close(outfile1);
end; (* Select *)

begin (* Main *)
  start := NIL;              (* initially empty list *)
  last := NIL;
  done := false;

  savattr := textattr;

  infilename :=  '9.dat';
  assign(infile1,infilename);

  outfilename := 'sample.$$$';
  assign(outfile1,outfilename);

  repeat
    window(5,7,75,19);
    textattr := white + cyan*16; CursorOn;
    clrscr;
    case MenuSelect of
      '1': Enter;
      '2': Remove{(start)};
      '3': Display(start);
      '4': Find1;
      '5': Save1(outfile1,start);     (*save as text file *)
     {'5': Save2(outfile2,start);     (*save with index as file of _wordrec*) }
      '6': start := Load1(infile1,start);
     {'6': start := Load2(infile1,start); }
      '7': Select;                    (*get random words and save to disk *)
      '0': done := true
    end;
  until (done);
  window(1,1,80,25);
end. (* SLL1*)