из данного предложения вычеркнуть слова,встречающиеся больше одного раза

program Project1;
 
const
  (*Разделители слов.*)
  D = [' ', '.', ',', ':', ';', '!', '?', #9, #10, #13];
  N = 100;
 
type
  (*Тип, задающий массив слов.*)
  TArrWords = array[1..N] of String;
 
(*Формирует массив слов, которые надо удалить из строки.*)
procedure FillArrD(const aStr : String; var aArrD : TArrWords; var aCntD : Integer);
var
  (*Массив уже найденных слов.
  При этом каждое слово - в единственном экземпляре.*)
  ArrU : TArrWords;
  CntU, i, j, k, Pos1, Pos2 : Integer;
  StrWord : String;
  InU, InD : Boolean;
begin
  CntU := 0;
  aCntD := 0;
  Pos1 := 0;
  Pos2 := 0;
  for i := 1 to Length(aStr) do begin
    (*Если очередной символ является разделителем - пропускаем итерацию.*)
    if aStr[i] in D then Continue;
    (*Отслеживаем начало слова.*)
    if i = 1 then
      Pos1 := i
    else if aStr[i - 1] in D then
      Pos1 := i
    ;
    (*Отслеживаем конец слова.*)
    if i = Length(aStr) then
      Pos2 := i
    else if aStr[i + 1] in D then
      Pos2 := i
    ;
    (*Если конец слова найден - обрабатываем его.*)
    if Pos2 > 0 then begin
      (*Выделяем слово и преобразуем его буквы к верхнему регистру.*)
      StrWord := UpperCase( Copy(aStr, Pos1, Pos2 - Pos1 + 1) );
 
      (*Проверяем есть ли такое же слово в ArrU.*)
      InU := False;
      for j := 1 to CntU do begin
        (*Если слово обнаружено в ArrU, добавляем его в aArrD*)
        if ArrU[j] = StrWord then begin
          InD := False;
          for k := 1 to aCntD do begin
            if aArrD[k] = StrWord then begin
              InD := True;
              Break;
            end;
          end;
          if not InD then begin
            Inc(aCntD);
            aArrD[aCntD] := StrWord;
          end;
          InU := True;
          Break;
        end;
      end;
      (*Если слова в ArrU не оказалось - добавляем это слово в ArrU.*)
      if not InU then begin
        Inc(CntU);
        ArrU[CntU] := StrWord;
      end;
      (*Сбрасываем флаг-координату конца слова.*)
      Pos2 := 0;
    end;
  end;
end;
 
var
  ArrD : TArrWords;
  CntD, i, j, Pos1, Pos2 : Integer;
  StrRes, StrSrc, StrWord : String;
  InD : Boolean;
begin
  Writeln('Vvedite stroku:');
  Readln(StrSrc);
 
  CntD := 0;
  FillArrD(StrSrc, ArrD, CntD);
 
  Pos1 := 0;
  Pos2 := 0;
  for i := 1 to Length(StrSrc) do begin
    //Если очередной символ является разделителем - добавляем его к результирующей строке.
    if StrSrc[i] in D then begin
      StrRes := StrRes + StrSrc[i];
      Continue;
    end;
    //Отслеживаем начало слова.
    if i = 1 then
      Pos1 := i
    else if StrSrc[i - 1] in D then
      Pos1 := i
    ;
    //Отслеживаем конец слова.
    if i = Length(StrSrc) then
      Pos2 := i
    else if StrSrc[i + 1] in D then
      Pos2 := i
    ;
    //Если конец слова найден - обрабатываем его.
    if Pos2 > 0 then begin
      //Выделяем слово и преобразуем его буквы к верхнему регистру.
      StrWord := UpperCase( Copy(StrSrc, Pos1, Pos2 - Pos1 + 1) );
      //Переписываем это слово в результирующую строку, только если
      //оно не присутствует в ArrD.
      InD := False;
      for j := 1 to CntD do begin
        if ArrD[j] = StrWord then begin
          InD := True;
          Break;
        end;
      end;
      (*Если слово отсутсвует в ArrD, то переписываем это слово в результирующую строку.*)
      if not InD then begin
        StrRes := StrRes + Copy(StrSrc, Pos1, Pos2 - Pos1 + 1);
      end;
      //Сбрасываем флаг-координату конца слова.
      Pos2 := 0;
    end;
  end;
 
  Writeln('Poluchennaya stroka:');
  Writeln(StrRes);
  Readln;
 
end.