delphi сведение одинаковых символов в строке

[tema2434]

Нужно свести подобные символы в строке, если какой-то символа встречается 3 раза, удалить все его вхождения, строк состоит из подстрок которые разделяются '_' таким символом, моя наработка

var
    s1,s2,s3: string;
    i: byte;
    n,k:integer;
begin
    read(s1);
    for i:=1 to length(s1) do begin
      if s1[i]=s1[i+1] then
        n:=n+1;
      if n=3 then
        delete(s1,i,i);
    end;
    s2 := '';
    for i:=1 to length(s1) do begin
        s3 := copy(s1,i,1);
        if pos(s3,s2) = 0 then
            s2 := s2 + s3
    end;
    writeln(s2);
readln;
readln

Но выдает не совсем то, вот пример входная строка I_LOVVVVWWXXXWE_YOU вывод I_LOVE_YOU что мне в своем коде исправить, чтобы работало верно?

[Aleksandr H.]

Ересь получилась, но... разбирайся, может на какую-то идею натолкнет

Program HelloWorld(output);
var s:string; 
    a:array[1..100] of string;
    i,j,k,m,count:integer;
begin
  s := 'I_LOVVVVWWXXXWE_YOU';
  count:=1;
 i:=1; while (i<=length(s)) do begin
   if s[i]='_' then begin inc(count);inc(i);end;
   a[count]:=a[count]+s[i];
   inc(i);
end;
for i:=1 to count do write(a[i],' ');
writeln;

for i:=1 to count do
begin
  j:=1;
  while j<=length(a[i]) do
   begin
     m:=0;
     s:=a[i][j];m:=0;
     for k:=j to length(a[i]) do if s=a[i][k] then inc(m);
     if m>=3 then 
      begin
       m:=m div 3 * 3;writeln('m ',m);
       k:=1;
       while k<=length(a[i]) do
        if (a[i][k]=s) and (m>0)  then 
         begin 
          dec(m);
          delete(a[i],k,1);
         end
        else inc(k);
      end
    else 
    inc(j);
   end;
end;

for i:=1 to count-1 do
write(a[i],'_');writeln(a[count]);
end.