【POJ3294】 Life Forms(SA)

const maxn=100419;
var
 x,y,rank,sa,c,col,h,rec:array[0..maxn] of longint;
 pd:array[0..maxn] of boolean;
 s:ansistring;
 n,k,maxlen,cnta:longint;

function max(x,y:longint):longint; begin if x>y then exit(x) else exit(y); end;
function min(x,y:longint):longint; begin if x<y then exit(x) else exit(y); end;
procedure swap(var x,y:longint);var tmp:longint; begin tmp:=x;x:=y;y:=tmp; end;

procedure make;
var i,p,tot:longint;
begin
 p:=1;
 while p<n do
  begin
   fillchar(c,sizeof(c),0);
   for i:= 1 to n-p do y[i]:=rank[i+p];
   for i:= n-p+1 to n do y[i]:=0;
   for i:= 1 to n do inc(c[y[i]]);
   for i:= 1 to n do inc(c[i],c[i-1]);
   for i:= 1 to n do
    begin
     sa[c[y[i]]]:=i;
     dec(c[y[i]]);
    end;
   fillchar(c,sizeof(c),0);
   for i:= 1 to n do x[i]:=rank[i];
   for i:= 1 to n do inc(c[x[i]]);
   for i:= 1 to n do inc(c[i],c[i-1]);
   for i:= n downto 1 do
    begin
     y[sa[i]]:=c[x[sa[i]]];
     dec(c[x[sa[i]]]);
    end;
   for i:= 1 to n do sa[y[i]]:=i;
   tot:=1;
   rank[sa[1]]:=1;
   for i:= 2 to n do
    begin
     if (x[sa[i]]<>x[sa[i-1]]) or (x[sa[i]+p]<>x[sa[i-1]+p]) then inc(tot);
     rank[sa[i]]:=tot;
    end;
   p:=p<<1;
  end;
 for i:= 1 to n do sa[rank[i]]:=i;
end;

procedure makeh;
var i,p,j:longint;
begin
 p:=0; h[1]:=0;
 for i:= 1 to n do
  begin
   p:=max(p-1,0);
   if rank[i]=1 then continue;
   j:=sa[rank[i]-1];
   while (j+p<=n) and (i+p<=n) and (s[i+p]=s[j+p]) do inc(p);
   h[rank[i]]:=p;
  end;
end;

procedure init;
var i,j,tot:longint;
 s1:ansistring;
begin
 k:=n>>1;
 readln(s);
 tot:=1;
 maxlen:=length(s);
 for i:= 1 to maxlen do col[i]:=1;
 for i:= 2 to n do
  begin
   readln(s1);
   s:=s+‘#‘;
   maxlen:=max(length(s1),maxlen);
   inc(tot);
   for j:= length(s)+1 to length(s)+length(s1) do col[j]:=tot;
   s:=s+s1;
  end;
 n:=length(s);
 fillchar(c,sizeof(c),0);
 for i:= 1 to n do x[i]:=ord(s[i]);
 for i:= 1 to n do inc(c[x[i]]);
 for i:= 1 to 128 do inc(c[i],c[i-1]);
 for i:= 1 to n do
  begin
   sa[c[x[i]]]:=i;
   dec(c[x[i]]);
  end;
 tot:=1;
 rank[sa[1]]:=1;
 for i:= 2 to n do
  begin
   if x[sa[i]]<>x[sa[i-1]] then inc(tot);
   rank[sa[i]]:=tot;
  end;
 make; makeh;
end;

function check(x:longint):boolean;
var i,j,tot,cnt:longint;
begin
 fillchar(pd,sizeof(pd),false);
 pd[0]:=true; tot:=0; cnt:=0;
 if not pd[sa[1]] then inc(tot);
 pd[sa[1]]:=true;
 for i:= 2 to n do
  begin
   if h[i]<x then
    begin
     if tot>k then
      begin
       inc(cnt);
       rec[cnt]:=i-1;
      end;
     tot:=0;
     fillchar(pd,sizeof(pd),false);
     pd[0]:=true;
    end;
   if not pd[col[sa[i]]] then inc(tot);
   pd[col[sa[i]]]:=true;
  end;
 if tot>k then
  begin
   inc(cnt);
   rec[cnt]:=i-1;
  end;
 if cnt>0 then
  begin
   cnta:=cnt;
   exit(true);
  end;
 exit(false);
end;

procedure qsort(l,r:longint);
var i,j,mid,tmp:longint;
begin
 if l>r then exit;
 i:=l; j:=r;
 mid:=rec[l+random(r-l+1)];
 repeat
  while rec[i]<mid do inc(i);
  while rec[j]>mid do dec(j);
  if i<=j then
   begin
    swap(i,j);
    inc(i); dec(j);
   end;
 until i>j;
 qsort(i,r); qsort(l,j);
end;

procedure solve;
var l,r,mid,tot,ans,i,j:longint;
begin
 l:=1; r:=maxlen;  ans:=0;
 while l<=r do
  begin
   mid:=(l+r)>>1;
   if check(mid) then
    begin
     ans:=mid;
     l:=mid+1;
    end
   else r:=mid-1;
  end;
 fillchar(pd,sizeof(pd),false);
 if ans=0 then
  begin
   writeln(‘?‘);
   exit;
  end;
 qsort(1,cnta);
 for i:= 1 to cnta do writeln(copy(s,sa[rec[i]],ans));
end;

Begin
 readln(n);
 while n<>0 do
  begin
   init;
   solve;
   writeln;
   readln(n);
  end;
End.