function pack(s:string):string;
var
i,k,l:integer;
mask,min,j:byte;
t:string;
begin
mask:=0;
min:=255;
j:=0;
l:=length(s);
for i:=1 to l do if min>byte(s[i])then min:=byte(s[i]);
t:=char(min);
for i:=1 to l do dec(byte(s[i]),min);
for i:=1 to l do mask:=mask or byte(s[i]);
t:=t+char(mask)+char(l);
min:=0;
for i:=1 to l do
begin
k:=1;
repeat
if boolean(mask and k)then
begin
min:=min or(byte((byte(s[i])and k)>0)shl j);
inc(j);
if j=8 then
begin
t:=t+char(min);
min:=0;
j:=0
end
end;
k:=k shl 1
until k=$100;
end;
if j>0 then t:=t+char(min);
pack:=t
end;
function unpack(s:string):string;
var
t:string;
mask,b,c,d,j,k,l:byte;
i:integer;
begin
j:=4;
b:=byte(s[4]);
mask:=byte(s[2]);
i:=1;
l:=0;
repeat
l:=l+byte((mask and i)>0);
i:=i shl 1;
until i=$100;
d:=0;
t:='';
while length(t)<byte(s[3])do
begin
k:=1;
c:=0;
for i:=1 to l do
begin
while k and mask=0 do k:=k shl 1;
if boolean(b and 1)then c:=c or k;
k:=k shl 1;
b:=b shr 1;
inc(d);
if d=8 then
begin
inc(j);
b:=byte(s[j]);
d:=0;
end;
end;
t:=t+char(c);
end;
b:=byte(s[1]);
for i:=1 to length(t)do inc(t[i],b);
unpack:=t
end;
var s:string;
begin
write('podaj ciag : ');
readln(s);
writeln(unpack(pack(s)));
writeln('dlugosc niespakowanego:',length(s));
writeln('dlugosc spakowanego:',length(pack(s)));
writeln('dlugosc rozpakowanego:',length(unpack(pack(s))));
end.
W miedzyczasie stworzyłem coś takiego :) Ciekawe, ze przy ciągu złożonym z jednakowych znaków niezmiennie po spakowaniu ciag ma tylko 3 znaki, niezależnie od długości oryginału ;] Oczywiście im ciąg bardziej rożnorodny tym gorsza kompresja. Ograniczenie do 255 znaków.
// algorytm wykorzystuje to, że znaki są kodowane w jakims przedziale, wiec nie nadaje sie do kompresii obrazow, bądź innych danych, ktore maja spory rozrzut mozliwych wartosci