Please help me !
I use DP, but WA at test #5
Can you tell me the bug(s) or show me the test(s) that my program  wrong ?
Thanks
[Code]
Const    fi        =    'input.sss';
    fo        =    'output.nnn';
        h        :    array['a'..'z']of char=('2','2','2','3','3','3','4','4','1',
'1','5','5','6','6','0','7','0','7','7','8','8','8',
                    '9','9','9','0');
        maxn    =    50001;
        maxm    =    101;
Var        f,f2    :    text;
        c        :    array[1..maxm,1..maxn]of boolean;
        d        :    array[0..maxm]of longint;
        a        :    array[1..maxn]of string[51];
        l,b     :   array[1..maxn]of longint;
        free    :    array[1..maxn]of boolean;
        trace   :   array[1..maxm]of longint;
        s        :    string;
        n,m        :    longint;
Procedure openf;
   begin
     assign(f,fi); reset(f);
     assign(f2,fo); rewrite(f2);
   end;
Procedure closef;
   begin
     close(f); close(f2);
   end;
Procedure init;
{   var}
   begin
     fillchar(d,sizeof(d),0);
     fillchar(trace,sizeof(trace),0);
   end;
Procedure inp;
   var i:longint;
   begin
     readln(f,s);
     if s='-1' then begin closef; halt; end;
     readln(f,n);
     for i:=1 to n do readln(f,a[i]);
   end;
Procedure predone;
   var i,j,k:longint; ok:boolean;
   begin
     m:=length(s);
     fillchar(c,sizeof(c),false);
     for i:=1 to n do l[i]:=length(a[i]);
     for i:=1 to m do
       for j:=1 to n do
         if l[j]<=i then
         begin
           ok:=true;
           for k:=l[j] downto 1 do
             if h[a[j,k]]<>s[i+k-l[j]] then begin ok:=false; break; end;
           c[i,j]:=ok;
         end;
   end;
Procedure solve;
   var i,j:longint;
   begin
     for i:=1 to m do
       begin
         d[i]:=maxint;
         for j:=1 to n do
           if c[i,j] then
              if d[i-l[j]]+1<d[i] then
             begin
               d[i]:=d[i-l[j]]+1;
               trace[i]:=j;
             end;
       end;
   end;
Procedure Out;
   var i,k:longint;
   begin
     if d[m]=maxint then begin writeln(f2,'No solution.'); exit; end;
     fillchar(free,sizeof(free),false);
     k:=0;
     while m>0 do
       begin
         inc(k);
         b[k]:=trace[m];
         dec(m,l[trace[m]]);
       end;
     for i:=k downto 1 do
       begin
         write(f2,a[b[i]],' ');
       end;
     writeln(f2);
   end;
Procedure process;
   var i,t:longint;
   begin
     repeat
       init;
       inp;
       predone;
       solve;
       Out;
     until false;
   end;
Begin
  openf;
  process;
End.
[/Code]