Help!
Here's my programm:
var s:array [1..100] of char;
r:array [1..100,1..100,1..100] of char;
l:array [1..100,1..100] of byte;
n,i,j,z,k,a,b:integer;
bool:boolean;
function f (i:byte):byte;
begin
 if (i>=10) and (i<100) then f:=4 else if i=100 then f:=5 else f:=3;
end;
begin
 i:=1; fillchar (l,sizeof (l),0);
 while not eoln do begin Read (s[i]); inc (i); end;
 n:=i-1;
 for j:=1 to 4 do
  for i:=1 to n-j+1 do begin
   for z:=i to i+j-1 do r[i,j,z-i+1]:=s[z];
   l[i,j]:=j;
  end;
 for j:=5 to n do
  for i:=1 to n-j+1 do begin
   a:=0;
   for z:=1 to j-1 do
    if (l[i,j]>l[i,z]+l[i+z,j-z]) or (l[i,j]=0) then
     begin
      l[i,j]:=l[i,z]+l[i+z,j-z];
      a:=z;
     end;
   b:=0;
   for z:=2 to j do
    if j mod z=0 then
     begin
      bool:=true;
      for k:=i to i-1+j-j div z do if s[k]<>s[k+j div z] then begin bool:=false; break; end;
      if bool then if l[i,j]>=f(z)+l[i,j div z] then
       begin
        l[i,j]:=f(z)+l[i,j div z];
        b:=z;
       end;
     end;
   if b=0 then
    begin
     for z:=1 to l[i,a] do
     r[i,j,z]:=r[i,a,z];
     for z:=1 to l[i+a,j-a]
     do r[i,j,z+l[i,a]]:=r[i+a,j-a,z];
    end else
    begin
     if b<10 then begin
      r[i,j,1]:=chr (b+ord ('0'));
      r[i,j,2]:='(';
      for z:=1 to l[i,j div b] do r[i,j,z+2]:=r[i,j div b,z];
      r[i,j,l[i,j div b]+3]:=')';
     end else if b<100 then begin
      r[i,j,1]:=chr (b div 10+ord ('0'));
      r[i,j,2]:=chr (b mod 10+ord ('0'));
      r[i,j,3]:='(';
      for z:=1 to l[i,j div b] do r[i,j,z+3]:=r[i,j div b,z];
      r[i,j,l[i,j div b]+4]:=')';
     end else begin
      r[i,j,1]:='1';
      r[i,j,2]:='0';
      r[i,j,3]:='0';
      r[i,j,4]:='(';
      for z:=1 to l[i,j div b] do r[i,j,z+4]:=r[i,j div b,z];
      r[i,j,l[i,j div b]+5]:=')';
     end;
    end;
  end;
  for i:=1 to l[1,n] do write (r[1,n,i]);
end.
It gets ML on test 20.

Don't keep best strings in memory. You can use O(N^2) memory (N - length of the string) to find the minimal length of folding and then build resulting string recursively.