Задача на строки.

[Prin53]

Если в строке имеются последовательности, состоящие из более чем трех одинаковых символов, то заменить каждую такую последовательность подстрокой , где - признак повторения, - двухзначное число, определяющее количество повторений, - по-вторяющийся символ. В качестве признака повторений взять неиспользуемый в тексте сим-вол #14. Составить две процедуры, выполняющие соответственно сжатие и восстановление текста.

Спасибо.

Мне только процедуры нужны.

[denisbrain]

Сообщение от Prin53

Мне только процедуры нужны.

примерно так

var
    s:string;
    TextValue:array [1..100] of string[3];
    TextCount:integer=1;
    vs:char;

Function GetSimbel(Vstart:integer=64):integer;
var sv,x,l:integer;
begin
   l:=length(s);
   for sv:=Vstart to 255 do begin
     if ord(s[x])=sv then
     else begin result:=sv; exit; end;
   end;
end;
function CreateText(Text:string):integer;
var x:integer;
begin
result:=-1;
   for X:=1 to TextCount do if TextValue[x]=text then result:=x;

   if result=-1 then begin
      TextCount:=TextCount+1;
      TextValue[TextCount-1]:=text;
      result:=TextCount-1;
   end;

end;
Function Zip:integer;
var l,x,i:integer;

begin
  vs:=char(GetSimbel);
  l:=length(s);
  x:=3;
  while x<l do begin
    if (s[x-2]=s[x-1]) and (s[x-1]=s[x]) then begin
      i:=CreateText(s[x-2]+s[x-1]+s[x]);
      delete(s,x-2,3);
      insert(vs+inttohex(i,2),s,x-2);
    end;
    x:=x+1;
  end;end;


Function unZip(c:char):integer;
var l,x,i:integer;
    s1,s2:string;
begin
  l:=length(s);
  x:=1;s2:='';
  while x<l do begin
    if s[x]=c then begin
      s1:='$'+copy(s,x+1,2);
      s2:=TextValue[strtoint(s1)];
      delete(s,x,3);
      insert(s2,s,x);
    end;
    x:=x+1;
  end;

end;
procedure TForm1.Button1Click(Sender: TObject);
begin
s:=form1.Memo1.Lines.Text;
Zip;
form1.Memo2.Lines.Text:=s;
unZip(vs);
form1.Memo3.Lines.Text:=s;

end;

[Prin53]

Сообщение от denisbrain

примерно так

var
    s:string;
    TextValue:array [1..100] of string[3];
    TextCount:integer=1;
    vs:char;

Function GetSimbel(Vstart:integer=64):integer;
var sv,x,l:integer;
begin
   l:=length(s);
   for sv:=Vstart to 255 do begin
     if ord(s[x])=sv then
     else begin result:=sv; exit; end;
   end;
end;
function CreateText(Text:string):integer;
var x:integer;
begin
result:=-1;
   for X:=1 to TextCount do if TextValue[x]=text then result:=x;

   if result=-1 then begin
      TextCount:=TextCount+1;
      TextValue[TextCount-1]:=text;
      result:=TextCount-1;
   end;

end;
Function Zip:integer;
var l,x,i:integer;

begin
  vs:=char(GetSimbel);
  l:=length(s);
  x:=3;
  while x<l do begin
    if (s[x-2]=s[x-1]) and (s[x-1]=s[x]) then begin
      i:=CreateText(s[x-2]+s[x-1]+s[x]);
      delete(s,x-2,3);
      insert(vs+inttohex(i,2),s,x-2);
    end;
    x:=x+1;
  end;end;


Function unZip(c:char):integer;
var l,x,i:integer;
    s1,s2:string;
begin
  l:=length(s);
  x:=1;s2:='';
  while x<l do begin
    if s[x]=c then begin
      s1:='$'+copy(s,x+1,2);
      s2:=TextValue[strtoint(s1)];
      delete(s,x,3);
      insert(s2,s,x);
    end;
    x:=x+1;
  end;

end;
procedure TForm1.Button1Click(Sender: TObject);
begin
s:=form1.Memo1.Lines.Text;
Zip;
form1.Memo2.Lines.Text:=s;
unZip(vs);
form1.Memo3.Lines.Text:=s;

end;

Не понятно, особенно последняя процедура.

[Prin53]

Вот сделал:

var s,buf,sym,ost:string;
	i,schet:integer;
begin
	writeln('enter string');
	readln(s);
	i:=1;
	schet:=1;
	while i <= length(s)-1 do
		begin
			if s[i]=s[i+1] then
			    begin
			        inc(schet);
			        inc(i);
			    end
			else 
			    begin
			          if (schet >= 3) then 
			                  begin
			                      ost:=copy(s,length(s)-i,i+1);
			                      sym:=copy(s,i,1);
			                      Str(schet, buf);
			                      sym:='#'+buf+sym+'#';
			                      insert(sym,s,i-2);
			                      i:=i+4;
			                      schet:=1;
			                  end
			          else
			              begin
			                  schet:=1;
			                  inc(i);
			              end;
			    end;
		end;
	writeln(s);
	readln;
end.

Только нужно вставить удаление повторяющихся символов.
Результат

Исходная строка
ettty

Результат
e#3t#ttty

ttt нужно удалить. Помогите, срочно.

[Prin53]

Спасибо большое.