Удвоить все буквы в чётных словах

program a;
uses crt;
type str=string;mass=array[1..20] of str;
var s,s1,s2,s3:str;i,j,k,l,n:integer;x,y:mass;
 
function quantity(s1,s2:str):integer;
var i,k:integer;
begin
k:=0;
for i:=1 to length(s2)-length(s1)+1 do 
if copy(s2,i,length(s1))=s1 then k:=k+1;
quantity:=k; end;
 
procedure inverse(var s1:str);
var i:integer;k:str;
begin
k:='';
for i:=1 to length(s1) do
k:=copy(s1,i,1)+k;
s1:=k; end;
 
procedure double(var s1:str);
var i:integer;k:str;
begin
k:='';
for i:=1 to length(s1) do
k:=k+copy(s1,i,1)+copy(s1,i,1);
s1:=k;
end;
 
procedure zamena(var s1:str;s2,s3:str);
var i:integer;k:str;
begin
k:='';
for i:=1 to length(s1) do 
if copy(s1,i,length(s2))=s2 then k:=k+s3 else k:=k+copy(s1,i,1);
s1:=k; end;
 
procedure del(var s1:str;s2:str);
begin
zamena(s1,s2,'');
end;
 
procedure  slova(s1:str;var k:integer;var x:mass);
var i,l:integer;
begin
l:=pos('  ',s1);
while l>0 do begin
zamena(s1,'  ',' ');
l:=pos('  ',s1);end;
k:=1;l:=pos(' ',s1);
while l>0 do begin
x[k]:=copy(s1,1,l-1);
k:=k+1;
delete(s1,1,l);
l:=pos(' ',s1);
end;
x[k]:=copy(s1,1,length(s1));
end;
 
procedure printmass(k:integer;x:mass);
var i:integer;
begin
for i:=1 to k do begin
writeln(x[i]);
end;
end;
 
var
m: integer;
begin
writeln('введите словo');
readln(s);
slova(s,n,x);
 
printmass(n,x);
 
for i:=0 to n do begin
if pos('a',s)>0 then
delete (s,i,1);
end;
write(s);
 
end.

const rz=[',',';',':','!','?','.',' '];//разделители можно добавить, зависит от текста
var  s,s1:string;
     i,j,k,p:integer;
begin
writeln('Введите текст');
readln(s);
i:=1;
k:=0;
while i<length(s) do//идем до конца
 begin
  if not(s[i] in rz)and((i=1)or (s[i-1] in rz))then//если не разделитель и он первый или перед ним раделитель
   begin
    inc(k);//новое слово
    if k mod 2=0 then //если оно четное
     begin
      j:=1;
      while (i+j<=length(s))and not(s[i+j-1] in rz) do inc(j); //найдем конец слова
      for p:=i+j-1 downto i do //с конца слова  до начала
      insert(s[p],s,p); //продублируем буквы
      i:=i+j; //перешагнем через это слово
     end
    else inc(i);//если нечетное слово, вперед
   end
  else inc(i);//если не начало слова, вперед
 end;
write(s);
end.

Var s:string;
i,k:integer;
w:array[1..100] of string;
Function Doub(a:string):string;
Var b:string; z:integer;
 begin
  b:='';
  for z:=1 to Length(a) do
   b:=b+a[z]+a[z];
  Result:=b;
 end;
begin
writeln('Введите слова через пробел:');
readln(s);
s:=s+' ';
k:=1;
w[k]:='';
for i:=1 to length(s) do
begin
  if pos(s[i],' ')=0 then w[k]:=w[k]+s[i]
   else
    begin
     if length(w[k])>0 then k:=k+1;
     w[k]:='';
    end;
 end;
writeln('Результат:');
for i:=1 to k-1 do
 if odd(i) then write(w[i],' ')
  else write(Doub(w[i]),' ');
End.