Cod sursa(job #1013519)

Utilizator hungntnktpHungntnktp hungntnktp Data 21 octombrie 2013 05:00:10
Problema ADN Scor 20
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.83 kb
{$h+}
USES math;
CONST
        tfi     ='adn.in';
        tfo     ='adn.out';
        nmax    =18;
        smax    =30001;
        oo      =1000000007;
TYPE
        arr     =array [1..18] of string;
        arr1    =array [1..18,0..smax] of longint;
        arr2    =array [0..smax] of longint;
        arr3    =array [1..nmax] of boolean;
        arr4    =array [1..nmax,1..nmax] of longint;
        arr5    =array [1..nmax,0..(1 shl nmax)-1] of longint;
        arr6    =array [1..nmax,0..(1 shl nmax)-1,1..2] of longint;
VAR
        fi,fo   :text;
        a       :arr;
        n,res   :longint;
        s       :arr1;
        g       :arr2;
        free    :arr3;
        c       :arr4;
        f       :arr5;
        truoc   :arr6;
 (*********************************************************************)
Procedure nhap;
      Var
        i       :longint;
      Begin
        assign(fi,tfi);reset(fi);
          readln(fi,n);
          for i:=1 to n do readln(fi,a[i]);
        close(fi);
      End;
 (***********************************************************************)
Procedure init;
      Var
       i,j,u,v,t:longint;
       dd       :boolean;
      Begin
        for i:=1 to n do
          for j:=1 to length(a[i]) do
            begin
              if a[i,j]='A' then u:=1
              else if a[i,j]='G' then u:=2
              else u:=3;
              s[i,j]:=(int64(s[i,j-1])*26+u) mod oo;
            end;
        g[0]:=1;
        for i:=1 to smax do g[i]:=(int64(g[i-1])*26) mod oo;
        for i:=1 to n do
          for j:=1 to n do
            if (i<>j) and (length(a[i])<=length(a[j])) then
              begin
                u:=length(a[i]);v:=length(a[j]);
                dd:=false;
                for t:=u to v do
                  if (s[j,t]-(int64(s[j,t-u])*g[u]) mod oo+oo) mod oo=s[i,u]
                  then
                    begin
                      dd:=true;
                      break;
                    end;
                if dd then free[i]:=true;
              end;
        j:=0;
        for i:=1 to n do
          if free[i]=false then
            begin
              inc(j);
              a[j]:=a[i];
              s[j]:=s[i];
            end;
        n:=j;
      End;
 (************************************************************************)
Procedure init2;
      Var
        i,j,u,t,v:longint;
      Begin
        for i:=1 to n do
          for j:=1 to n do
            if i<>j then
              begin
                u:=min(length(a[i]),length(a[j]));
                v:=0;
                for t:=u downto 1 do
                if (s[i,length(a[i])]-(int64(s[i,length(a[i])-t])*g[t]) mod oo+oo) mod oo
                =s[j,t] then
                  begin
                    v:=t;
                    break;
                  end;
                c[i,j]:=v;
              end;
      End;
 (*************************************************************************)
Procedure lam;
      Var
        i,tt,j  :longint;
      Begin
        for i:=1 to n do
          for tt:=0 to (1 shl n)-1 do f[i,tt]:=maxlongint;
        for i:=1 to n do f[i,1 shl (i-1)]:=length(a[i]);
        for tt:=0 to (1 shl n)-1 do
          for i:=1 to n do
            if f[i,tt]<>maxlongint then
              begin
                for j:=1 to n do
                  if tt and (1 shl (j-1))=0 then
                    begin
                      f[j,tt or (1 shl (j-1))]:=min(f[j,tt or (1 shl (j-1))],length(a[j])-c[i,j]+f[i,tt]);
                      if f[j,tt or (1 shl (j-1))]=length(a[j])-c[i,j]+f[i,tt] then
                        begin
                          truoc[j,tt or (1 shl (j-1)),1]:=i;
                          truoc[j,tt or (1 shl (j-1)),2]:=tt;
                        end;
                    end;
              end;
      End;
 (*************************************************************************)
Procedure truyvet(u,v:longint);
      Var
        i       :longint;
      Begin
        if 1 shl (u-1)=v then
          begin
            write(fo,a[u]);
            exit;
          end;
        truyvet(truoc[u,v,1],truoc[u,v,2]);
        for i:=c[truoc[u,v,1],u]+1 to length(a[u]) do write(fo,a[u,i]);
      End;
 (*************************************************************************)
Procedure inkq;
      Var
        u,v,i   :longint;
      Begin
        assign(fo,tfo);rewrite(fo);
          res:=maxlongint;
          v:=(1 shl n)-1;
          for i:=1 to n do
             begin
               res:=min(res,f[i,(1 shl n)-1]);
               if res=f[i,(1 shl n)-1] then u:=i;
             end;
          truyvet(u,v);
        close(fo);
      End;
 (*************************************************************************)
BEGIN
        nhap;
        init;
        init2;
        lam;
        inkq;
END.