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);varl1,r1,x1,y1:longint;beginl1:=i1;r1:=j1;x1:=g[(l1+r1) div 2];repeatwhile 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)endelse 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.