Найти и сохранить в каждой строке только те слова, которые встречаются в ней по одному разу

program NinthLab;
 
Uses Crt;{Подключение стандартного модуля Crt}
 
procedure Exist(var fname: String);
{Проверка существования файла с указанным именем}
var
  ch: Char;
begin
  if FileExists(fname)
  Then begin
    WriteLn('Такой файл уже есть!');
    Write('Уничтожить его? Y/N -> ');
    ReadLn(ch);
    if ch In ['N', 'n', 'Т', 'т']
      Then repeat
        WriteLn('Введите новое имя файла:');
        ReadLn(fname);
        if FileExists(fname)
        Then begin
          WriteLn('Такой файл уже есть!');
          Write('Уничтожить его? Y/N -> ');
          ReadLn(ch);
        end;
      until(not FileExists(fname)) Or (ch In ['Y', 'y', 'Н', 'н']);
  end;
end;
 
procedure SozdFT(const fname: String);
{Создание исходного текстового файла}
var
  FT: Text;
  st: String;
begin
  Assign(FT, fname);
  ReWrite(FT);          {открытие файла для записи}
  Write(' Начинаем ввод. ');
  WriteLn(' Признак окончания ввода - пустая строка.');
  ReadLn(st);           {ввод строки с клавиатуры}
  while st <> ''          {пока строка не пустая}
  Do
  begin
    WriteLn(FT, st);  {запись строки в файл}
    ReadLn(st);
  end;
  Close(FT);            {закрытие файла}
end;
 
procedure ProsmFT(const fname: String);
{просмотр текстового файла}
var
  st: String;
  FT: Text;
begin
  Assign(FT, fname);
  Reset(FT);            {открытие файла для чтения}
  if Eof(FT)
  Then begin
    Writeln(' Файл пуст!');
    WriteLn(' Нажмите Enter ->');
    ReadLn;
    Halt;
  end;
  while not Eof(FT)     {пока не достигнут конец файла}
  Do
  begin
    Readln(FT, st);   {чтение строки из файла}
    Writeln(st);     {вывод строки на экран}
  end;
  Writeln;
  Close(FT);            {закрытие файла}
end;{ProsmFT}
 
function NovSt(st: String): string;
var
  L, i: Byte;
begin
  L := Length(st); 
  i := 1;              
  while i <= L      
     Do
  begin
    if st[i] = ' '
    Then begin
      if (i = 1) Or (i = L) 
        Then Delete(st, i, 1)
      Else if (i < L) And (st[i + 1] = ' ') 
        Then Delete(st, i + 1, 1)
      Else i := i + 1; 
      L := Length(st); 
    end
    Else i := i + 1;
  end;
  NovSt := st;
end;
 
function checkCountVowels(var slovo: String): Boolean;
var
  quantity, i: Integer;
  allVowels: String;
begin
  quantity := 0;
  allVowels := 'ауоыэяюёиеaeiouy';
  for i := 1 to length(slovo) do
    if (slovo[i].ToLower() in allVowels) then
      quantity := quantity + 1;
  
  checkCountVowels := quantity > length(slovo) div 2;
end;
 
function split(const str: String): String;
var
  resultSplit: String;
  i: Integer;
  currentSlovo: String;
begin
  currentSlovo := '';
  for i := 1 to Length(str) do
  begin
    if (str[i] <> char(32)) then
    begin
      currentSlovo := currentSlovo + str[i];
    end;
    
    if (((i = length(str)) or (str[i] = char(32))) and (Length(currentSlovo) > 0)) then
    begin
      if (checkCountVowels(currentSlovo)) then
        resultSplit := resultSplit + currentSlovo + ' '; 
      currentSlovo := '';
    end;
  end;
  split := resultSplit.TrimEnd();
end;
 
procedure RedaktFT(const nameF1, nameF2: String);
var
  F1, F2: Text;
  st: String;
begin
  Assign(F1, nameF1); Assign(F2, nameF2);
  Reset(F1); Rewrite(F2);  
  while not Eof(F1)        
  Do
  begin
    ReadLn(F1, st);  
    st := NovSt(st);   
    st := split(st);  
    WriteLn(F2, st);     
  end;
  Close(F1); Close(F2);   
end;
 
{Основная программа}
var
  nameF1, nameF2: String;{имена текстовых файлов}
 
begin
  ClrScr;      {очистка экрана} 
  Write(' Введите имя исходного файла: ');
  ReadLn(nameF1);
  Exist(nameF1);
  SozdFT(nameF1);              {создание исходного файла}
  WriteLn(' Вид исходного файла');
  ProsmFT(nameF1);
  Write(' Введите имя файла результата: ');
  ReadLn(nameF2);
  Exist(nameF1);
  RedaktFT(nameF1, nameF2);     {редактирование файла}
  WriteLn(' Файл после обработки:');
  ProsmFT(nameF2);
end. {FileText}