Замена одинаковых символов на n*2 штук

i:= 1; 
    while i<=length(s)-1 do begin     {пока не конец строки}
      For j := i+1 to length(s) do 
          if s[j]<>s[i] then i:= i + 1     {переходим к следующей букве}
                          else  inc(i);           {если символы равны}

var s, r, w: string;
    i: integer;
begin
  writeln('Введите строку:');
  readln(s);
  if s[length(s)] = ' ' then s := s + '.' else s := s + ' ';
  r := s[1];
  w := '';
  for i := 2 to length(s) do
    begin
      if s[i] = r[1]
        then r := r + s[i]
        else begin
          w := w + r;
          if length(r) > 1 then w := w + r;
          r := s[i]
        end;
    end;
  writeln('Результат:');
  writeln(w);
  readln
end.

var s:string;
    i:byte;
begin
writeln('Введите строку с одинаковыми символами подряд');
read(s);
for i:=length(s) downto 1 do
if (s[i]=s[i-1])or((s[i]=s[i+1])and(s[i]<>s[i-1]))
then insert(s[i],s,i+1);
write(s)
end.

Uses crt;
Var
   k : array [1..100] of string;
   s : string;
   i,c : integer;
begin
ReadLn(s);
s:=s+' ';
c:=1;
for i:=1 to length(s) do
                        begin
                        if s[i]=s[i+1] then begin k[c]:=k[c]+s[i]; end else
 begin k[c]:=k[c]+s[i]; inc(c); end;
                        end;
for i:=1 to c do
    if length(k[i])>1 then Write(k[i],k[i]) else write(k[i]);
end.

for i := length(s) downto 2 do

var s:string;
    i:byte;
begin
writeln('Введите строку с одинаковыми символами подряд');
read(s);
for i:=length(s) downto 1 do
if ((i>1)and(s[i]=s[i-1]))or((i<length(s))and(s[i]=s[i+1]))
then insert(s[i],s,i+1);
write(s)
end.

for i := length(s) downto 2 do

(s[i]=s[i-1])or((s[i]=s[i+1])

program Project2;
 
{$APPTYPE CONSOLE}
 
uses
  SysUtils;
 
var s:string;//shortstring
    i:byte;
begin
writeln('Введите строку с одинаковыми символами подряд');
readln(s);
for i:=length(s) downto 1 do
if (s[i]=s[i-1])or((s[i]=s[i+1])and(s[i]<>s[i-1]))
then insert(s[i],s,i+1);
write(s);
readln
end.