V8SORT - Sắp xếp
Tác giả: RR
Ngôn ngữ: Pascal
{$R+,Q+}
const
FINP='';
FOUT='';
MAXN=7;
MAX=5040;
oo=1000000000;
type
arr=array[1..MAXN] of longint;
var
hsize,sl,n:longint;
c:array[1..MAXN,1..MAXN] of longint;
hv:array[1..MAX] of arr;
hpos,h,d:array[1..MAX] of longint;
xet:array[1..MAXN] of longint;
kq,a:arr;
procedure swap(var a,b:longint);
var
temp:longint;
begin
temp:=a; a:=b; b:=temp;
end;
procedure inp;
var
f:text;
i,j:longint;
begin
assign(f,FINP); reset(f);
n:=0;
while not eoln(f) do
begin
inc(n);
read(f,a[n]);
end;
for i:=1 to n do
for j:=1 to n do
read(f,c[i,j]);
close(f);
end;
procedure ans;
var
f:text;
begin
assign(f,FOUT); rewrite(f);
writeln(f,d[1]);
close(f);
end;
procedure luu;
begin
inc(sl); hv[sl]:=kq;
end;
procedure try(i:longint);
var
j:longint;
begin
for j:=1 to n do
if xet[j]=0 then
begin
xet[j]:=1; kq[i]:=j;
if i<n then try(i+1)
else luu;
xet[j]:=0;
end;
end;
operator <(a,b:arr) c:boolean;
var
i:longint;
begin
for i:=1 to n do
if a[i]<b[i] then exit(true)
else if a[i]>b[i] then exit(false);
exit(false);
end;
operator =(a,b:arr) c:boolean;
var
i:longint;
begin
for i:=1 to n do
if a[i]<>b[i] then exit(false);
exit(true);
end;
function find(a:arr):longint;
var
l,r,mid:longint;
begin
l:=1; r:=sl;
repeat
mid:=(l+r) div 2;
if hv[mid]<a then l:=mid
else r:=mid;
until r-1<=l;
if a=hv[l] then exit(l)
else exit(r);
end;
procedure downHeap(i:longint);
var
j:longint;
begin
j:=i shl 1;
while (j<=hsize) do
begin
if (j<hsize) and (d[h[j+1]]<d[h[j]]) then inc(j);
if d[h[j]]<d[h[i]] then
begin
swap(hpos[h[i]],hpos[h[j]]);
swap(h[i],h[j]);
end;
i:=j; j:=i shl 1;
end;
end;
procedure upHeap(i:longint);
var
j:longint;
begin
j:=i shr 1;
while (i>1) and (d[h[i]]<d[h[j]]) do
begin
swap(hpos[h[i]],hpos[h[j]]);
swap(h[i],h[j]);
i:=j; j:=i shr 1;
end;
end;
procedure push(u:longint);
begin
inc(hsize); h[hsize]:=u; hpos[u]:=hsize;
upHeap(hsize);
end;
procedure pop(var u:longint);
begin
u:=h[1]; hpos[u]:=0;
swap(h[1],h[hsize]);
hpos[h[1]]:=1;
dec(hsize);
downHeap(1);
end;
procedure init;
var
u,i:longint;
begin
sl:=0;
try(1);
for i:=1 to sl do d[i]:=oo;
u:=find(a); d[u]:=0;
h[1]:=u; hpos[u]:=1; hsize:=1;
end;
procedure solve;
var
u,v,i,j:longint;
x,y:arr;
begin
while hsize>0 do
begin
pop(u);
if u=1 then exit;
x:=hv[u];
for i:=1 to n-1 do
for j:=i+1 to n do
begin
y:=x;
swap(y[i],y[j]);
v:=find(y);
if d[u]+c[i,j]<d[v] then
begin
d[v]:=d[u]+c[i,j];
if hpos[v]=0 then push(v)
else upHeap(hpos[v]);
end;
end;
end;
end;
begin
inp;
init;
solve;
ans;
end.