Подсчитать число вхождений каждого слова в текст

uses crt;
var path, elem:string;
    f: text;
    n,k,n1,n2,i,j,count:integer;
    check: boolean;
    slova_vse,slova_unic:array[1..1000] of string;
procedure PrintFile(f:text);
begin
     while not eof(f) do
     begin
          readln(f,elem);
          writeln(elem);
     end;
end;
begin
     write('Введите имя входного файла:');
     readln(path);
     assign(f,path);
     reset(f);
     n:=1;
     writeln('Содержимое входного файла:');
     while not eof(f) do
     begin
           readln(f,elem);
           writeln(elem);
           n1:=1;
           for i:=1 to length(elem) do
               if (elem[i]=' ') then
               begin
                    n2:=i;
                    slova_vse[n]:=copy(elem,n1,n2-n1);
                    inc(n);
                    n1:=n2+1;
               end;
               n2:=length(elem);
               slova_vse[n]:=copy(elem,n1,n2-n1+1);
     end;
     close(f);
     k:=1;
     for i:=1 to n do
     begin
         check:=false;
         for j:=1 to k do
         if slova_vse[i] = slova_unic[j] then
         begin
              check:=true;
              break;
         end;
         if check = false then
         begin
              slova_unic[k]:=slova_vse[i];
              inc(k);
         end;
     end;
     writeln();
     write('Введите имя выходного файла:');
     readln(path);
     assign(f,path);
     rewrite(f);
     for i:=1 to k-1 do
     begin
     count:=0;
              for j:=1 to n do
              if slova_unic[i] = slova_vse[j] then
                 inc (count);
     writeln(f,slova_unic[i],' - ',count);
     end;
     close(f);
     writeln('Содержимое выходного файла:');
     assign(f,path);
     reset(f);
     while not eof(f) do
     begin
           readln(f,elem);
           writeln(elem);
     end;
     close(f);
end.

const
    seps: Set Of Char = [' ', '.', ',', '!', ':', '?'];
type
    TMyWord = record
        s: String;
        count: LongWord;
    end;
    TMyWordArray = Array[Byte] Of TMyWord;
 
procedure FindRep(var arr: TMyWordArray; var n: Byte; const wrd: String);
var
    i: Byte;
    isFound: Boolean;
begin
    i := 0; isFound := False;
    while ((i < n) And (Not isFound)) do
    begin
        isFound := arr[i].s = wrd;
        if (isFound)
        then
            Inc(arr[i].count);
        Inc(i);
    end;
    if (Not isFound)
    then
    begin
        Inc(n);
        with arr[n - 1] do
        begin
            s := wrd;
            count := 1;
        end;
    end;
end;
 
var
    f, g: Text;
    fi, wrd, path: String;
    unic: TMyWordArray;
    i, unicCount: Byte;
begin
    Write('Name of input file: '); ReadLn(path);
    Assign(f, path); {$I-} Reset(f); {$I+}
    if (IOResult <> 0)
    then
        WriteLn('File not found!')
    else
    begin
        unicCount := 0;
        while (Not EoF(f)) do
        begin
            ReadLn(f, fi);
            WriteLn(fi);
            fi := fi + ' ';
            while (fi[1] in seps) do
                Delete(fi, 1, 1);
            while (Length(fi) > 0) do
            begin
                wrd := '';
                while Not (fi[1] in seps) do
                begin
                    wrd := wrd + fi[1];
                    Delete(fi, 1, 1);
                end;
                while ((Length(fi) > 0) And (fi[1] in seps)) do
                    Delete(fi, 1, 1);
                if (Length(wrd) > 0)
                then
                    FindRep(unic, unicCount, wrd);
            end;
        end;
        Close(f);
        Write('Output name of file: '); ReadLn(path);
        Assign(g, path); ReWrite(g);
        if (unicCount > 0)
        then
            for i := 0 to unicCount - 1 do
                with unic[i] do
                    WriteLn(g, s, ' ', count);
        Close(g);
    end;
end.