usaco 3.1 contact 2008.7.18

usaco 3.1 contact 2008.7.18

{

ID:  

PROG: contact

LANG: PASCAL

}

program p_contact;
  const fin='contact.in';fout='contact.out';
var
   f1,f2:text;
   yy,i,a,j,b,n,lr,l,p,ls,lg,xp,min:longint;
   r,s:string;
   x:array[1..840]of string;
   z:array[1..840]of longint;
   g:array[1..50]of longint;
   v:array[1..840]of longint;
   h:array[1..840]of string[12];
procedure qsort(i1,j1:longint);
var
l1,r1,x1,y1:longint;
begin
l1:=i1;r1:=j1;
x1:=g[(l1+r1) div 2];
repeat
while g[l1]>x1 do inc(l1);
while g[r1]<x1 do dec(r1);
 if l1<=r1 then
   begin
   y1:=g[l1];
   g[l1]:=g[r1];
   g[r1]:=y1;
   inc(l1);
   dec(r1);
   end;
until l1>r1;
if r1>i1 then qsort(i1,r1);
if l1<j1 then qsort(l1,j1);
end;
procedure init;
  begin
     assign(f1,fin);reset(f1);
     assign(f2,fout);rewrite(f2);
     readln(f1,a,b,n);p:=1;l:=0;
     repeat
        readln(f1,r);lr:=length(r);
        if l<=160 then begin x[p]:=x[p]+r;inc(l,lr);end
                       else begin z[p]:=l;inc(p);x[p]:=r;l:=lr;end;
     until eof(f1);
end;
procedure deal(s:string);
var sum,m,lm,k,tt:longint;f:string;
    ff:boolean;
begin
   sum:=0;m:=1;f:=x[1];
   repeat
     k:=pos(s,f);
     if k=0 then
                   begin
                      f:=copy(f,length(f)-ls+1,ls)+copy(x[m],lm,z[m]-lm+1);
                      inc(m);lm:=1;
                   end
                else
                   begin
                     f:=copy(f,k+1,length(f)-k);inc(sum);
                   end;
    until m>p;
    if lg<n then begin ff:=true;for tt:=1 to lg do if sum=g[tt] then ff:=false;
                       if ff then begin if sum<min then min:=sum;inc(lg);g[lg]:=sum;end;
                 end
            else begin
                if sum>min then
                  begin
                      ff:=true;for tt:=1 to n do if sum=g[tt] then ff:=false;
                       if ff then begin
                                 g[n+1]:=sum;qsort(1,n+1);
                                 min:=g[n];end;
                                 end;
                      end;
   inc(xp);h[xp]:=s;v[xp]:=sum;

   end;
procedure find(sp:longint);
var u:char;ss:string;
begin
  if sp=ls+1 then deal(s)
 else
  for u:='0' to '1' do
     begin ss:=s;s:=s+u;find(sp+1);s:=ss;end;
end;
procedure doit;
begin
   for i:=a to b do
       begin s:='';ls:=i;find(1);end;
end;
procedure choose;
var pp,i:longint;
begin
 pp:=0;


  for i:=1 to xp do
    if v[i]>=min then begin inc(pp);h[pp]:=h[i];v[pp]:=v[i];end;
 xp:=pp;
end;
{----------------------------------------}
begin
  lg:=0;xp:=0;min:=maxlongint;
  init;
  if length(x[1])=1 then begin writeln(f2,1);writeln(f2,1)end
else
 begin
  doit;
  choose;


  for i:=1 to n do
   begin
    writeln(f2,g[i]);yy:=0;
    for j:=1 to xp do
      if v[j]=g[i] then begin
           inc(yy);
           if yy=1 then write(f2,h[j]) else
           if yy mod 6=0 then writeln(f2,' ',h[j]) else write(f2,' ',h[j]);end;
   if yy mod 6<>0 then writeln(f2);
   end;
    end;
  close(f1);close(f2);
end.