Cod sursa(job #1013528)

Utilizator baolaptrinhbaolaptrinh baolaptrinh Data 21 octombrie 2013 07:34:08
Problema ADN Scor 80
Compilator fpc Status done
Runda Arhiva de probleme Marime 5.79 kb
{$h+}
Uses math;
Const
        oo=1000000007;
Type
        mat=array [0..1 shl 18,0..18] of longint;
Var     f,tr,tr1:mat;
        n,res:longint;
        a,b:array [1..20] of string;
        c:array [1..20,1..20] of longint;
        hash,g:array [1..20,0..30001] of int64;
        kt:array ['A'..'Z'] of longint;
        mu,dd:array [0..30001] of int64;
        kq:string;
        fi,fo:text;


Function Tinh(x,i,j:longint):int64;
        Begin
                Tinh:=(g[x,j]-(g[x,i-1]*mu[j-i+1] mod oo)+oo) mod oo;
        end;

Procedure Loaichung;
        Var i,j,k:longint;
        Begin
        mu[0]:=1;
                For i:=1 to 30001 do mu[i]:=(mu[i-1]*4) mod oo;
                For i:=1 to n do
                 Begin
                   For j:=1 to length(b[i]) do
                      g[i,j]:=(g[i,j-1]*4+kt[b[i][j]]) mod oo;
                 end;
                For i:=1 to n do
                 For j:=1 to n do
                 If i<>j then
                  If (dd[i]=0) and (dd[j]=0) then
                   If length(b[i])<=length(b[j]) then
                    Begin
                     For k:=length(b[i]) to length(b[j]) do
                       If Tinh(i,1,length(b[i]))=Tinh(j,k-length(b[i])+1,k) then
                        Begin
                                dd[i]:=1;
                                break;
                        end;
                    end;
                j:=0;
                For i:=1 to n do
                 If dd[i]=0 then
                  Begin
                        inc(j);
                        a[j]:=b[i];
                  end;
                n:=j;
        end;

Procedure Doc;
        Var i:longint;
        Begin
                kt['A']:=1;
                kt['G']:=2;
                kt['T']:=3;
                kt['C']:=4;
                Readln(fi,n);
                For i:=1 to n do Readln(fi,b[i]);
                Loaichung;
        end;

Function Get(x,i,j:longint):int64;
        Begin
                Get:=(hash[x,j]-(hash[x,i-1]*mu[j-i+1] mod oo)+oo) mod oo;
        end;


Function Count(x,y:longint):longint;
        Var i,k:longint;
        Begin
                For i:=1 to length(a[x]) do
                 Begin
                        k:=length(a[x])-i+1;
                        If k<=length(a[y]) then
                         Begin
                                If Get(x,i,length(a[x]))=Get(y,1,k) then exit(length(a[y])-k);
                         end
                        else
                         Begin
                                If Get(x,i,i+length(a[y])-1)=Get(y,1,length(a[y])) then exit(0);
                         end;
                 end;
                exit(length(a[y]));
        end;

Procedure Khoitao;
        Var i,j:longint;
        Begin
                mu[0]:=1;
                For i:=1 to 30001 do mu[i]:=(mu[i-1]*4) mod oo;
                For i:=1 to n do
                 Begin
                   For j:=1 to length(a[i]) do
                      hash[i,j]:=(hash[i,j-1]*4+kt[a[i][j]]) mod oo;
                 end;
                For i:=1 to n do
                  For j:=1 to n do c[i,j]:=Count(i,j);
        end;


Function Getbit(k,x:longint):longint;
        Begin
                getbit:=(x shr (k-1)) and 1;
        end;


Function Setbit(c,k,x:longint):longint;
        Begin
                If c=1 then Setbit:=x or (1 shl (k-1))
                else Setbit:=x and (not (1 shl (k-1)));
        end;

Procedure Trace;
        Var i,tt,tt1,i1,k,j:longint;
        Begin
                kq:='';
                For i:=1 to n do
                 If res=f[1 shl n-1,i] then break;
                tt:=1 shl n-1;
                Repeat
                        tt1:=tr[tt,i];
                        i1:=tr1[tt,i];
                        If f[tt1,i1]<f[tt,i] then
                         Begin
                                j:=f[tt,i]-f[tt1,i1];
                                For k:=length(a[i]) downto length(a[i])-j+1 do
                                  kq:=kq+a[i][k];
                         end;
                         tt:=tt1;
                         i:=i1;
                        If length(kq)=res then break;
                Until false;
        end;


Procedure Lam;
        Var i,j,tt,tt1:longint;
        Begin
                Khoitao;
                For tt:=0 to 1 shl n-1 do
                  For i:=1 to n do f[tt,i]:=oo;
                For i:=1 to n do
                 Begin
                        tt:=Setbit(1,i,0);
                        f[tt,i]:=length(a[i]);
                 end;
                For tt:=0 to 1 shl n-1 do
                 For i:=1 to n do
                   If f[tt,i]<>oo then
                     For j:=1 to n do
                       If Getbit(j,tt)=0 then
                        Begin
                                tt1:=Setbit(1,j,tt);
                                If f[tt1,j]>f[tt,i]+c[i,j] then
                                 Begin
                                        f[tt1,j]:=f[tt,i]+c[i,j];
                                        tr[tt1,j]:=tt;
                                        tr1[tt1,j]:=i;
                                 end;
                        end;
                res:=oo;
                For i:=1 to n do res:=Min(res,f[1 shl n-1,i]);
                Trace;
                //Writeln(fo,n);
                //For i:=1 to n do Writeln(fo,a[i]);
                For i:=res downto 1 do Write(fo,kq[i]);
        end;

Procedure Inkq;
        Begin
        end;

        Begin
                Assign(fi,'adn.in');Reset(fi);
                Assign(fo,'adn.out');Rewrite(fo);
                        Doc;
                        Lam;
                        Inkq;
                Close(fo);Close(fi);
        end.