В произвольном тексте найти повторяющиеся слова,определить количество повторений каждого из них

program Project1;
 
const
  {Размер массива, который содержит сведения о различающихся словах.}
  M = 200;
  {Разделители слов.}
  D = ['.', ',', ':', ';', '!', '?', '-', ' ', #9, #10, #13];
type
  {Сведения о слове.}
  TInfo = record
    S : String[20]; {Слово.}
    Cnt : Integer;  {Количество присутствий слова в тексте.}
  end;
  {Массив сведений о различающихся словах.}
  TArr = array[1..M] of TInfo;
 
{Для кодовой страницы CP866 (DOS) переводит символы строки в верхний регистр.
Правильно обрабатывает русские и английские буквы.}
function UpCaseStr866(const aStr : String) : String;
var
  S : String;
  i : Integer;
begin
  S := aStr;
  for i := 1 to Length(S) do
    case S[i] of
      #$A0..#$AF: S[i] := Char(Ord(S[i]) - $20);
      #$E0..#$EF: S[i] := Char(Ord(S[i]) - $50);
      #$F1: S[i] := #$F0;
      else S[i] := UpCase(S[i]);
    end;
  UpCaseStr866 := S;
end;
 
{Функция извлекает из текста слова и добавляет эти слова и количество их
присутствий в массив aArr.
Предположим, из строки извлечено очередное слово. Если это слово уже есть
в массиве aArr, то счётчик этого слова увеличивается на 1. Если такого
слова в массиве нет, то слово добавляется в массив и его счётчик устанавливается
равным 1.
aArrLen - Количество значимых элементов в массиве.
Если все найденные слова записаны в массив, то функция возвращает значение True.
Если в массиве не хватило места для добавления слов, то функция возвращает
значение False.}
function ProcStr(const aStr : String; var aArr : TArr; var aArrLen : Integer) : Boolean;
var
  Sw : String;
  i, j, Len, LenW : Integer;
  Res : Boolean;
begin
  Res := True;
  Len := Length(aStr);
  LenW := 0; {Длина слова.}
  for i := 1 to Len do
    {Если символ не является разделителем, значит он принадлежит слову.}
    if not (aStr[i] in D) then begin
      Inc(LenW); {Учитываем очередной символ в длине слова.}
      {Отслеживаем конец слова.}
      if (i = Len) or (aStr[i + 1] in D) then begin
        {Выделяем слово и переводим его символы в верхний регистр.}
        Sw := UpCaseStr866( Copy(aStr, i - LenW + 1, LenW) );
        {Ищем индекс этого слова в массиве aArr.}
        j := 1;
        while (j <= aArrLen) and (aArr[j].S <> Sw) do Inc(j);
        {Если индекс оказался в пределах значимой части массива, значит
        слово найдено. В этом случае увеличиваем счётчик слова на 1.}
        if j <= aArrLen then Inc(aArr[j].Cnt)
        {Если индекс вышел за пределы значимой части массива, значит слово
        не найдено. В этом случае, если в массиве есть свободное место
        (j <= High(aArr)), то добавляем слово в массив и устанавливаем его
        счётчик, равным 1.}
        else if j <= High(aArr) then begin
          Inc(aArrLen);
          aArr[j].S := Sw;
          aArr[j].Cnt := 1;
        {Если индекс вышел за пределы массива (j > High(aArr)), значит,
        произошло переполнение. Т. е., в массиве нет свободного места для
        добавления нового слова.}
        end else begin
          Res := False; {Произошло переполнение.}
          Break;        {Прерываем цикл.}
        end;
        LenW := 0;
      end;
    end;
  ProcStr := Res;
end;
 
var
  F : Text;
  Arr : TArr; {Массив различающихся слов.}
  S, Fn : String;
  i, Cnt, ArrLen : Integer;
  Res : Boolean;
begin
  repeat
    {Открываем файл с исходным текстом.}
    Writeln('Задайте имя файла:');
    Readln(Fn);
    Assign(F, Fn);
    {$I-}
    Reset(F);
    {$I+}
    if IOResult <> 0 then begin
      Writeln('Не удалось открыть заданный файл. Действие отменено.');
      Writeln('Перейти к началу программы - Enter, выход - любой символ + Enter.');
      Readln(S);
      Continue;
    end;
    {Обработка файла. Последовательно читаем строки из файла и обрабатываем
    их с помощью функции ProcStr(). ProcStr() выделяет слова из строки и
    записывает сведения о них в массив Arr.}
    Res := True;
    ArrLen := 0; {Количество элементов, добавленных в массив Arr.}
    while not Eof(F) do begin
      Readln(F, S);
      Res := ProcStr(S, Arr, ArrLen);
      if not Res then Break;
    end;
    Close(F);
    {Проверяем - не было ли переполнения.}
    if not Res then begin
      Writeln('Обработка текста прервана. Произошло переполнение.');
      Writeln('Будут учтены не все слова.');
    end;
 
    {Распечатка сведений о повторяющихся словах.
    Повторяющиеся слова - это те слова из массива Arr, для которых показание
    счётчика больше, чем 1.}
    Writeln('Перечень повторяющися слов.');
    Writeln('В скобках указано количество присутствий слова:');
    Cnt := 0; {Количество повторяющихся слов.}
    for i := 1 to ArrLen do
      if Arr[i].Cnt > 1 then begin
        Inc(Cnt);
        if Cnt > 1 then Write(', ');
        Write(Arr[i].S, '(', Arr[i].Cnt, ')');
      end;
    if Cnt > 0 then Writeln;
    Writeln('Всего повторяющихся слов: ', Cnt);
    
    Writeln('Перейти к началу программы - Enter, выход - любой символ + Enter.');
    Readln(S);
  until S <> '';
end.