Составить программу компрессии строк

uses crt;
var s:string;
    a:array[32..255] of byte;
    n,i,j:byte;
begin
writeln('Введите строку с одинаковыми символами рядом');
readln(s);
n:=length(s);
for i:=32 to 255 do
a[i]:=0;
for i:=1 to n do
inc(a[ord(s[i])]);
for i:=1 to n-1 do
for j:=n downto i+1 do
if s[j]=s[i] then delete(s,j,1);
writeln(s);
for i:=32 to 255 do
if a[i]<>0 then write(a[i],' ')
end.

uses crt;
var s:string;
    a:array[32..255] of byte;
    n,i,j:byte;
begin
writeln('Введите строку с одинаковыми символами рядом');
readln(s);
n:=length(s);
for i:=32 to 255 do
a[i]:=0;
for i:=1 to n do
inc(a[ord(s[i])]);
for i:=1 to length(s)-1 do//длина строки меняется, поэтому зря я присобачил n
for j:=length(s) downto i+1 do//хотя в простом АВС это не влияло и ошибки не было
if s[j]=s[i] then delete(s,j,1);
writeln(s);
for i:=32 to 255 do
if a[i]<>0 then write(a[i],' ')
end.

var s:string;
    a:array[byte] of byte;
    n,i,j:byte;
begin
writeln('Введите строку с одинаковыми символами рядом');
readln(s);
s:=s+' ';
i:=1;
n:=0;
while i<length(s) do
 begin
  inc(n);
  a[n]:=1;
  j:=i+1;
  while(j<=length(s))and(s[j]=s[i]) do
   begin
    inc(a[n]);
    delete(s,j,1);
   end;
  inc(i);
 end;  
writeln(s);
for i:=1 to n do
write(a[i],' ')
end.

delete(s,length(s),1) ;//удалим пробел который добавили в начале

var s:string;
    a:array[byte] of byte;
    n,i,j:byte;
begin
writeln('Введите строку с одинаковыми символами рядом');
readln(s);
i:=1;
n:=0;
while i<=length(s) do
 begin
  inc(n);
  a[n]:=1;
  if i<length(s) then
   begin
    j:=i+1;
    while(j<=length(s))and(s[j]=s[i]) do
     begin
      inc(a[n]);
      delete(s,j,1)
     end;
    inc(i)
   end
  else inc(i)
 end;  
writeln(s);
for i:=1 to n do
write(a[i],' ')
end.