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

program Project1;
 
(*Подсчитывает количество слов в строке aStr, которые начинаются и заканчиваются
на одну и ту же букву, независимо от регистра.*)
function CountWord(const aStr : String) : Word;
const
  (*Множество разделителей.*)
  Delims = [' ', '.', ',', ':', ';', '!', '?', '-'];
var
  (*Индексы символов строки.*)
  i : Integer;
  (*Очередное слово, выделенное из строки.*)
  StrWord : String;
  (*Количество заданных слов в строке.*)
  Res : Word;
begin
  Res := 0;
  StrWord := '';
  (*Перебор всех символов строки.*)
  for i := 1 to Length(aStr) do begin
    (*Если символ не является разделителем - добавляем его к слову.*)
    if not (aStr[i] in Delims) then StrWord := StrWord + aStr[i];
    (*Отслеживаем конец слова.*)
    if ( (aStr[i] in Delims) or (i = Length(aStr)) ) and (StrWord <> '') then begin
      (*Если первая и последняя буквы слова совпадают (независимо от регистра),
      то подсчитываем это слово.*)
      if UpCase(StrWord[1]) = UpCase( StrWord[ Length(StrWord) ] ) then Inc(Res);
      StrWord := '';
    end;
  end;
 
  CountWord := Res;
end;
var
  StrTmp : String;
  CntWord : Word;
begin
  (*Производим подсчёт.*)
  write('Введите строку:'); Readln(StrTmp);
  CntWord := CountWord(StrTmp);
  (*Показываем результат подсчёта.*)
  Writeln('Количество слов с одинаковой буквой (независимо от регистра) в начале и в конце = ', CntWord);
 
  Readln;
end.

const 
   D = [' ', '.', ',', ':', ';', '!', '?', '-'];
var
  s:string;
  i,j,k:integer;
begin
  repeat
    write('Строка:');
    readln(s);s:=s+' ';
  until (length(s)>1);
  j:=1;k:=0;
  for i:=2 to length(s) do 
    if (s[i] in D) then if s[j]=s[i-1] then begin inc(k);j:=i+1;end else j:=i+1;
  writeln(k);  
end.

const 
   D = [' ', '.', ',', ':', ';', '!', '?', '-'];
var
  s:string;
  i,j,k:integer;
begin
  repeat
    write('Строка:');
    readln(s);s:=s+' ';
  until (length(s)>1);
  j:=1;k:=0;
  if s[1] in D then  while s[1] in D do delete(s,1,1);
  for i:=2 to length(s) do 
    if (s[i] in D) then if (s[j]=s[i-1]) and not (s[j] in D) then begin inc(k);j:=i+1;end else j:=i+1;
  writeln(k);  
end.