Simtel MSDOS 1992 June/SIMTEL_0692.cdr/msdos/txtutl/spel204.arc/SPELWELL.PAS

Pascal/Delphi Source File | 1987-05-16 | 11.9 KB | 504 lines

program SPELWELL (input,output);

const

  version         ='2.04';
  dictionary_file ='DX.DAT';
  spellfile       ='MISSPELL.DAT';
  dxsize          = 3855; {max number words in dictionary}
  wordlen         = 16;
  listsize        = 1000; {max number misspelled words}

type

  dxtype   = array[1..dxsize] of string[wordlen];
  dxptr    = ^dxtype;
  line     = string[80];

var

  ch,
  choice      :char;
  dxfile,
  infile,
  mispfile    : text;
  entry       : dxptr; {dictionary entry}
  list        : array [0..listsize] of string[wordlen]; {misspelled list}
  num_entries,
  wordno      : integer;
  filename    : string[14];
  i,j,k,
  pos,
  size        : integer;
  word        : string[16];
  yes         : boolean;
  endoftext,
  found,
  goodfile    : boolean;
  suffix1     : char;
  suffix2     : string[2];

procedure alarm;
var
  num:integer;
begin
  num:=0;
  repeat
    write(#7);
    delay(100);
    write(#7);
    delay(300);
    num:=num+1;
  until (num=10) or keypressed;
end;

function allcaps(instring:line):line;
var
  temp:line;
begin
  temp:='';
  for j:=1 to length(instring) do temp:=temp+upcase(instring[j]);
  allcaps:=temp;
end;

procedure beep;begin write(chr(7));end;

procedure dashline;
  begin
   writeln('==============================================================================');
  end;

procedure query(bias:boolean);
var
  yesno       :char;
begin
  yes:=bias;
  readln(yesno);
  if yesno in ['Y','y'] then yes:=true;
  if yesno in ['N','n'] then yes:=false;
end;

procedure waitkey;begin
  writeln;
  write('* Press any key to continue ');
  repeat until keypressed;
end;

procedure read_file;
var
  i: integer;
begin
  assign(dxfile,dictionary_file);
  reset(dxfile);
  i:=0;
  while not eof(dxfile) do begin
      i:=i+1;
      readln(dxfile,entry^[i]);
    end;
  close(dxfile);
  num_entries:=i;
end;

procedure test_filename;begin
  goodfile:=false;
  assign(infile,filename);
  {$I-} reset(infile) {$I+};
  goodfile:=(ioresult=0);
end;

procedure show_directory;
type
  entrytype   = string[12];
  result_type = record
                 ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;
               end;
const
  maxfiles = 64;
  fcb1     = $5C;
  fcb      = $80;
var
  num_entries,
  num_rows,
  i,j,k:integer;
  dtabuf:array[1..130] of byte;
  drive:integer;
  dir_buf:array[1..maxfiles] of entrytype;
  result:result_type;
  x:integer;

    procedure shell_sort;
    var
      done  :boolean;
      jump,
      i,
      j,
      swno  :integer;

    function firstjump(length: integer): integer;
    var
      temp : integer;
    begin
      temp:=1;
      while temp<=length do
        temp:=temp*2;
      firstjump:=temp
    end;

    procedure swap (var p,q: entrytype);
    var
      hold :entrytype;
    begin
      hold:=p;
      p:=q;
      q:=hold
    end;

    begin
      swno:=0;
      jump:=firstjump(num_entries);
      while jump>1 do begin
        jump:=(jump-1) div 2;
          repeat
            done:=true;
            for j:=1 to num_entries-jump do begin
              i:=j+jump;
              if dir_buf[j]>dir_buf[i] then begin
                swno:=swno+1;
                swap(dir_buf[j],dir_buf[i]);
                done:=false;
              end;
            end;
          until done
      end;
    end;

begin {dir}
  drive:=0;
  writeln;write('* Enter drive (1="A", 2="B", 3="C") > ');
  readln(drive);writeln;
  mem[seg(dtabuf[1]):$5c]:=drive;   {default drive}
  for i:=1 to 11 do begin mem[seg(dtabuf[1]):$5c+i]:=ord('?');end;
  for i:=12 to 36 do begin mem[seg(dtabuf[1]):$5c+i]:=0;end;
  fillchar(dir_buf,sizeof(dir_buf),' ');
  i:=1;
  with result do begin
    dx:=ofs(dtabuf[1]);    {offset of DTA}
    ax:=$1a shl 8;        {set AH=26}
    ds:=seg(dtabuf[1]);
  end;
  msdos(result);
  with result do begin
    dx:=$5c;
    ax:=$11 shl 8;           {set AH=$11}
    ds:=seg(dtabuf[1]);
  end;
  msdos(result);
  with result do begin
    j:=ax and $00ff;      {result in AL}
  end;
  if j<255
  then begin
    dtabuf[j*32+1]:=11;
    move(dtabuf[j*32+1],dir_buf[i],12);
    with result do begin
      DX:=$005c;
      AX:=$12 shl 8;
      ds:=seg(dtabuf[1]);
    end;
    msdos(result);
    with result do begin
      j:=ax and $00ff;
    end;
    while j<255 do begin
      i:=i+1;
      dtabuf[j*32+1]:=11;
      move(dtabuf[j*32+1],dir_buf[i],12);
      with result do begin
        DX:=$005c;
        AX:=$12 shl 8;
        ds:=seg(dtabuf[1]);
      end;
      msdos(result);
      with result do begin j:=ax and $00ff;end;
    end;
    with result do begin
      DX:=fcb;
      AX:=$1a shl 8;
    end;
    msdos(result);
    for j:=1 to i do insert('.',dir_buf[j],9);
    num_entries:=i;
    shell_sort;
    num_rows:=(i div 5);
    if i mod 5>0 then num_rows:=num_rows+1;
    for i:=num_entries+1 to num_rows*5 do dir_buf[i]:='';
    j:=1;
    while j<=num_rows do begin
      for k:=0 to 4 do write(dir_buf[j+k*num_rows],'  ');
      writeln;
      j:=j+1
    end;
  end;
end; {dir}

procedure lowercase;begin
  if ord(ch)<91 then ch:=chr(ord(ch)+32);
end;

procedure getnextword;
type
  spaceset=set of char;
  wordset=set of char;
var
  spacechars:spaceset;
  wordchars:wordset;
begin
  word:='';
  wordchars:=['A'..'Z','a'..'z'];
  spacechars:=[chr(10),chr(13),chr(23),' '..'/',':'..'@','['..'`','{'..'~','0'..'9',chr(208)];
  if not eof(infile) then          {find beginning of word}
    repeat
      read(infile,ch);
    until (ch in wordchars) or eof(infile);
  if not eof(infile) then begin
      repeat
        lowercase;
        word:=word+ch;
        read(infile,ch);
      until (ch in spacechars) or eof(infile);
    end
  else endoftext:=true;
end;

procedure bsearch;

var
  lower,
  upper,
  center : integer;

begin
  lower:=1;
  upper:=num_entries;
  found:=false;
  while (upper>=lower) and (not found) do begin
    center:=(lower+upper) div 2;
    if word=entry^[center] then begin
        found:=true;
      end
    else
      if word>entry^[center] then
        lower:=center+1
      else
        upper:=center-1
  end;
  wordno:=center;
end;

procedure addtolist;
var
  word_found     : boolean;
  i,
  j              : 1..listsize;
  position       : integer;

  procedure find_position;

  var
    bottom_list,
    top_list            : integer;

  begin
    bottom_list:=1;
    top_list:=size;
    word_found:=false;
    while (top_list>=bottom_list) and (not word_found) do begin
      position:=(bottom_list+top_list) div 2;
      if word=list[position] then begin
          word_found:=true;
        end
      else
        if word>list[position] then
          bottom_list:=position+1
        else
          top_list:=position-1
    end;
  end;

begin
  find_position;
  if not word_found then begin
    size:=size+1;
    if word>list[position] then position:=position+1;
    for j:=size downto position do list[j]:=list[j-1];
    list[position]:=word;
  end;
end;

procedure screen;
var
  i : integer;
begin
  writeln;writeln;
  for i:=2 to size-1 do begin
    writeln(i-1,'  ',list[i]);
    if i mod 23=0 then repeat until keypressed;
  end;
end;

procedure single;
var
  i : integer;
begin
  writeln(lst,'          File = ',filename,'     No. Misspelled Words = ',size-2);writeln(lst);
  for i:=2 to size-1 do begin
    writeln(lst,'          ',list[i]);
    if i mod 53=0 then begin
        writeln;writeln('Change paper and press any key to continue');
        repeat until keypressed;
      end;
  end;
end;

procedure continuous;
var
  i : integer;

begin
  writeln(lst);writeln(lst);writeln(lst);writeln(lst);writeln(lst);
  writeln(lst,'          File = ',filename,'     No. Misspelled Words = ',size-2);writeln(lst);
  for i:=2 to size-1 do begin
    writeln(lst,'          ',list[i]);
    if i mod 53=0
    then begin
      writeln(lst);writeln(lst);writeln(lst);writeln(lst);writeln(lst);
      writeln(lst);writeln(lst);writeln(lst);writeln(lst);writeln(lst);
    end;
  end;
end;

procedure disk;
var
  i: integer;
begin
  assign(mispfile,spellfile);
  rewrite(mispfile);
  for i:=2 to size-1 do begin
    writeln(mispfile,list[i]);
  end;
  close(mispfile);
end;

procedure output_list;begin
  writeln('* A disk file of "misspelled" words will automatically be created.');
  writeln;write('  Printed List Also ? (Y/N) <Y> ');
  query(true);
  if yes then begin
    writeln;writeln('* Select Printed Output To:');writeln;
    writeln('  1 - Screen');
    writeln('  2 - Printer, Single Sheet');
    writeln('  3 - Printer, Continuous Form');
    writeln('  4 - Omit Printout');writeln;
    write('  Choice --> ');readln(choice);
    case choice of
    '1':screen;
    '2':single;
    '3':continuous;
    end;
  end;
end;

procedure initialize;
var
  i : integer;

begin
  for i:=1 to listsize do list[i]:='';
  list[1]:='!!!!!!!!!!!!!!!!';
  list[2]:='~~~~~~~~~~~~~~~~';
  size:=2;
  endoftext:=false;
end;

procedure title;begin
  clrscr;
  dashline;
  writeln('SPELWELL  Ver. ',version,'  Copr. 1985, 1987  M. Lee Murrah.  All Rights Reserved.');
  dashline;writeln;
  writeln('A simple spelling checker program.  Users are granted the right to');
  writeln('make and transfer copies so long as no consideration is charged.  Author');
  writeln('reserves exclusive right to prepare updates and derivative works for dist-');
  writeln('ribution.  Suggestions for changes and improvements, and information regarding');
  writeln('bugs should be directed to the author at 10 Cottage Grove Woods, SE, Cedar');
  writeln('Rapids, IA 52403, Tel: [phone].');
  writeln;writeln;write('* Loading Dictionary > ');
  read_file;
  writeln(num_entries,' entries');
  initialize;
  waitkey;
end;

begin
  new(entry);
  title;
  clrscr;
  dashline;
  writeln('SPELWELL  Ver. ',version,' Copr. 1985, 1987  M. Lee Murrah.  All Rights Reserved.');
  dashline;writeln;
  repeat
    writeln;write('* Enter name of file to be checked > ');readln(filename);
    filename:=allcaps(filename);writeln;
    if filename<>'QUIT' then begin
      test_filename;
      if not goodfile then begin
        writeln('  BAD FILE NAME');writeln;beep;
        write('* Do you want a directory listing (Y/N) <N> ? > ');query(false);
        if yes then show_directory;
      end
    end;
  until goodfile or (filename='QUIT');
  if filename<>'QUIT' then begin
    write('* Working...');
    assign(infile,filename);
    reset(infile);
    getnextword;
    while not endoftext do begin
        bsearch;
        if not found then begin
            suffix1:=copy(word,length(word),1);
            if suffix1 in ['d','s'] then begin
                word:=copy(word,1,length(word)-1);
                bsearch;
                if not found then word:=word+suffix1;
              end;
            if length(word)>2 then begin
              suffix2:=copy(word,length(word)-1,2);
              if (suffix2='ed') or (suffix2='es') then begin
                  word:=copy(word,1,length(word)-2);
                  bsearch;
                   if not found then word:=word+suffix2
                end;
            end;
          end;
        if not found and (length(word)>1) then
          addtolist;
        getnextword;
      end;
    close(infile);
    writeln;writeln;
    writeln('  Number misspelled or missing words > ',size-2);
    writeln;write('* Spelling check completed. Press any key to continue. ');
    alarm;writeln;writeln;
    if size>2 then begin
        output_list;
        waitkey;
        writeln;writeln;write('* Outputting misspelled words to disk file [MISSPELL.DAT]');
        disk;writeln;
      end
    else begin
        writeln('* No misspelled words in document');
      end;
  end;
  writeln;writeln('* Thanks for using SPELWELL');writeln;
end.