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

var s,s1:string;
    i,j,k:byte;
begin
writeln('Введите строку из слов, разделенных пробелами, в конце точка');
readln(s);
s:=' '+s;//добавим пробел в начало для удобства
writeln('Слова, первая буквы которых входит в них еще раз');
k:=0;
i:=2;
while i<length(s) do
if(s[i]<>' ')and(s[i-1]=' ') then//если не пробел, а перед ним пробел, новое слово
 begin
  s1:='';
  j:=i;
  while(j<=length(s))and not(s[j]in [' ','.'])do//
   begin
    s1:=s1+s[j];
    j:=j+1;
   end;
  if length(s1)>1 then//если слово больше 1 буквы
   begin
    j:=2;//проверим есть в нем первая буква еще
    while (j<=length(s1))and(s1[j]<>s1[1]) do j:=j+1;
    if j<=length(s1) then//если есть
     begin
      writeln(s1);//выводим слово
      k:=1;//фиксируем наличие
     end;
   end;
  i:=i+length(s1);//перешагиваем через него
 end
else i:=i+1;//пропускаем пробелы
if k=0 then write('Таких слов нет');
end.

type StringMas = array [1..200] of string;
 
function Count(s: string): integer;
var c, i: integer;
begin
  c := 1;
  for i := 2 to length(s) do
    if (s[i] = ' ') and (s[i - 1] <> ' ') then
      inc(c);
  if s[length(s)] = ' ' then dec(c);
  Count := c;
end;
 
procedure ToWords(var s: StringMas; str: string);
var i, n, c, start: integer;
begin
  i := 1;
  while (str[i] = ' ') do inc(i);
  start := i;
  n := Count(str);
  c := start;
  for i := 1 to n do begin
    s[i] := '';
    while (c <= length(str)) and (str[c] <> ' ') do begin
      s[i] := s[i] + str[c];
      inc(c);
    end;
    while (c < length(str)) and (str[c]=' ') do inc(c);
  end;
end;
 
var str: string;
    s: StringMas;
    i,j: integer;
begin
  readln(str);
  ToWords(s, str);
  for i := 1 to Count(str) do
    for j:=2 to length(s[i]) do
      if s[i][j] = s[i][1] then begin
        write(s[i],' ');
        break;
      end;
end.