Cod sursa(job #1013524)

Utilizator hungntnktpHungntnktp hungntnktp Data 21 octombrie 2013 06:42:45
Problema ADN Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.9 kb
Program adn;
Const   finp='adn.in';
        fout='adn.out';
        oo=1000000;
Var     fi,fo:text;
        n,res  :longint;
        kq,x:ansistring;
        s  :array[1..18] of ansistring;
        free:array[1..18] of boolean;
        t:array[1..18] of longint;

Procedure enter;
    var i:longint;
    begin
        assign(fi,finp);reset(fi);
        readln(fi,n);
        for i:=1 to n do readln(fi,s[i]);
        close(fi);
    end;

Function find(s1,s2:ansistring):longint;
    var i,vt :longint;
        c :char;
        tg:ansistring;
    begin
        if pos(s1,s2)<>0 then exit(oo);
        c:=s2[length(s2)];
        for i:=length(s1) downto 1 do
            if s1[i]=c then
               begin tg:=copy(s1,1,i);
                     if pos(tg,s2)<>0 then exit(i);
               end;
        exit(0);
    end;


Procedure update;
    var i,vt:longint;
        s1,s2:ansistring;
    begin
        x:=s[t[1]];
        for i:=2 to n do
            begin
                s1:=s[t[i]];
                vt:=find(s1,x);
                if vt<>oo then x:=x+copy(s1,vt+1,length(s1)-vt);
            end;
        if length(x)<res then
            begin res:=length(x);
                  kq:=x;
            end;
    end;

Procedure try(i:longint);
    var j:longint;
    begin
        if i=n+1 then
            begin
                update;
                exit;
            end;
        for j:=1 to n do
            if free[j] then
               begin
                    free[j]:=false;
                    t[i]:=j;
                    try(i+1);
                    free[j]:=true;
               end;
    end;

Procedure process;
    var i:longint;
    begin
        fillchar(free,sizeof(free),true);
        res:=oo;
        try(1);
        assign(fo,fout);rewrite(fo);
        write(fo,kq);
        close(fo);
    end;

BEGIN
    enter;
    process;
END.