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.

Download