В тексте найти все слова, у которых буква встречается более одного раза - Turbo Pascal - Ответ 3913838

program Project1;
 
const
  //Разделители слов.
  D = ['.', ',', ':', ';', '!', '?', '-', ' ', #9, #10, #13];
  //Наибольшее количество слов.
  M = 100;
type
  //Запись для хранения сведений о слове.
  TInfo = record
    SWord : String; //Слово.
    Len : Integer; //Длина слова.
  end;
var
  S : String;
  Arr : array[1..M] of TInfo; //Массив слов.
  Info : TInfo;
  Da : set of Char;
  i, j, k, Len, LenW : Integer;
  F : Boolean;
begin
  repeat
    Writeln('Задайте строку:');
    Readln(S);
    S := UpperCase(S); //Приводим буквы к верхнему регистру. Работает только для латиницы.
    
    //Находим слова, в которых есть повторы букв.
    Len := Length(S);
    LenW := 0; //Длина очередного слова.
    Da := []; //Множество букв в очередном слове.
    F := False; //Есть ли в текущем слове повторяющиеся буквы.
    j := 0; //Индекс для массива слов.
    for i := 1 to Len do begin //Перебор символов строки.
      if not (S[i] in D) then begin //Если символ не является разделителем.
        Inc(LenW); //Учитываем очередную букву в длине слова.
        if S[i] in Da then F := True; //Проверяем, есть ли в слове такая же буква.
        Da := Da + [S[i]]; //Добавляем букву во множество.
        if (i = Len) or (S[i + 1] in D) then begin //Отслеживаем конец слова.
          //Если в слове есть повторы букв, то добавляем его в массив.
          if F then begin
            Inc(j);
            Arr[j].SWord := Copy(S, i - LenW + 1, LenW);
            Arr[j].Len := LenW;
          end;
          LenW := 0; //Сброс длины слова.
          Da := []; //Обнуление множества букв.
          F := False; //Сброс флага.
        end;
      end;
    end;
 
    //Теперь сортируем массив по неубыванию (нестрогому возрастанию) длин слов.
    //Сортировка методом вставок.
    for i := 1 to j do begin
      k := i;
      Info := Arr[k];
      while (k > 1) and (Arr[k - 1].Len > Info.Len) do begin
        Arr[k] := Arr[k - 1];
        Dec(k);
      end;
      Arr[k] := Info;
    end;
 
    //Распечатка результата.
    if j > 0 then begin
      Writeln('Перечень слов, в которых есть повторы букв, в порядке возрастания длин:');
      for i := 1 to j do begin
        if i > 1 then Write(', ');
        Write(Arr[i].SWord);
      end;
      Writeln;
    end else
      Writeln('В тексте нет ни одного слова с повторящимися буквами.');
 
    Writeln('Повторить - Enter. Выход - любой символ + Enter.');
    Readln(S);
  until S <> '';
end.