V8SORT - Sắp xếp

Tác giả: ladpro98

Ngôn ngữ: Pascal

{$MODE OBJFPC}
program v8sort;
uses    math;
type    e=record
        v,p:longint;
        end;
const   maxn=10;
        maxl=5555;
        oo=trunc(1e9);
        fi='';
var     c:array[1..maxn,1..maxn] of longint;
        a,s,f:array[0..maxn] of longint;
        check:array[1..maxn] of boolean;
        d,h,pos:array[0..maxl] of longint;
        b:array[1..maxn] of e;
        n,dd,nh:longint;

procedure input;
var     inp:text;
        i,j:longint;
begin
        assign(inp,fi);
        reset(inp);
        while not seekeoln(inp) do
        begin
                inc(n);
                read(inp,b[n].v);
                b[n].p:=n;
        end;
        for i:=1 to n do
        begin
                for j:=1 to n do
                read(inp,c[i,j]);
                readln(inp);
        end;
        close(inp);
end;

procedure init;
var     i,j:longint;
        t:e;
begin
        f[1]:=1;
        for i:=2 to n do f[i]:=i*f[i-1];
        for i:=1 to n do
        for j:=i+1 to n do
        if b[i].v>b[j].v then
        begin
                t:=b[i];
                b[i]:=b[j];
                b[j]:=t;
        end;
        dd:=1;
        for i:=1 to n do
        begin
                s[b[i].p]:=dd;
                inc(dd);
        end;
        for i:=1 to f[n] do d[i]:=oo;
end;

function toNum:longint;
var     i,j,t,sum:longint;
begin
        for i:=1 to n do check[i]:=false;
        sum:=0;
        for i:=1 to n do
        begin
                t:=0;
                for j:=1 to a[i]-1 do
                if not check[j] then inc(t);
                inc(sum,t*f[n-i]);
                check[a[i]]:=true;
        end;
        exit(sum+1);
end;

procedure toMask(p:longint);
var     i,j,t,k:longint;
begin
        for i:=1 to n do check[i]:=false;
        for i:=1 to n do
        begin
                for j:=n-1 downto 0 do
                begin
                        t:=0;
                        for k:=1 to j do
                        if not check[k] then inc(t);
                        if (not check[j+1]) and (t*f[n-i]<p) then break;
                end;
                s[i]:=j+1;
                check[j+1]:=true;
                dec(p,t*f[n-i]);
        end;
end;

procedure update(v:longint);
var     p,c:longint;
begin
        c:=pos[v];
        if c=0 then begin
                inc(nh);
                c:=nh;
        end;
        repeat
                p:=c shr 1;
                if (p=0) or (d[h[p]]<=d[v]) then break;
                h[c]:=h[p];
                pos[h[c]]:=c;
                c:=p;
        until false;
        h[c]:=v;
        pos[v]:=c;
end;

function extract:longint;
var     v,p,c:longint;
begin
        result:=h[1];
        v:=h[nh];
        dec(nh);
        p:=1;
        repeat
                c:=p shl 1;
                if (c<nh) and (d[h[c+1]]<d[h[c]]) then inc(c);
                if (c>nh) or (d[h[c]]>=d[v]) then break;
                h[p]:=h[c];
                pos[h[p]]:=p;
                p:=c;
        until false;
        h[p]:=v;
        pos[v]:=p;
end;

procedure dijkstra;
var     i,j,u,t,v:longint;
begin
        a:=s;
        d[toNum]:=0;
        update(toNum);
        repeat
                u:=extract;
                toMask(u);
                for i:=1 to n-1 do
                for j:=i+1 to n do
                begin
                        a:=s;
                        t:=a[i];
                        a[i]:=a[j];
                        a[j]:=t;
                        v:=toNum;
                        if d[v]>d[u]+c[i,j] then begin
                                d[v]:=d[u]+c[i,j];
                                update(v);
                        end;
                end;
        until nh=0;
end;

procedure output;
var     i:longint;
begin
        for i:=1 to n do a[i]:=i;
        write(d[toNum]);
end;

begin
        input;
        init;
        Dijkstra;
        output;
end.

Download