uva10986 堆优化单源最短路径(pas)

var n,m,s,t,v,i,a,b,c:longint;//这道题的代码不是这个，在下面
    first,tr,p,q:array[..]of longint;
    next,eb,ew:array[..]of longint;
procedure swap(a,b:longint);
var t:longint;
begin
  t:=tr[a];tr[a]:=tr[b];tr[b]:=t;
  t:=p[a];p[a]:=p[b];p[b]:=t;
  t:=q[p[a]];q[p[a]]:=q[p[b]];q[p[b]]:=t;
end;
procedure sw(var a,b:longint);
var t:longint;
begin
  t:=a;a:=b;b:=t;
end;
procedure up(a:longint);
begin
  if a= then exit;
  if tr[a]<tr[a div ] then
  begin
    swap(a,a div );
    up(a div );
  end;
end;
procedure down(a:longint);
var b,c:longint;
begin
  b:=;
  while(b<=a div )do
  begin
    c:=b*;
    if(tr[c]>tr[c+])and(c<n)then
      c:=c+;
    if tr[c]<tr[b] then
      swap(b,c);
    b:=c;
  end;
end;
procedure input;
begin
  v:=v+;
  eb[v]:=b;
  ew[v]:=c;
  next[v]:=first[a];
  first[a]:=v;
end;
begin
  readln(n,m,s,t);
  v:=;
  fillchar(first,sizeof(first),);
  for i:= to m do
  begin
    readln(a,b,c);
    input;
    sw(a,b);
    input;
  end;
  fillchar(tr,sizeof(tr),$7f);
  tr[s+]:=;
  for i:= to n do
  begin
    p[i]:=i-;
    q[i-]:=i;
  end;
  up(s+);
  write('Case #1: ');
  repeat
    a:=p[]; //top
    if a=t then
    begin
      if tr[]= then
        writeln('unreachable')
      else
        writeln(tr[]);
      break;
    end;
    b:=first[a];
    while(b<>)do
    begin
      c:=eb[b];
      if(tr[q[a]]+ew[b]<tr[q[c]])then
      begin
        tr[q[c]]:=tr[q[a]]+ew[b];
        up(q[c]);
      end;
      b:=next[b];
    end;
    swap(,n);
    n:=n-;
    down(n);
  until false;
end.

单纯的堆优化dijkstra，

加上多组数据以后（该题AC)：

var n,m,s,t,v,i,a,b,c,nn,ii:longint;
    first,tr,p,q:array[..]of longint;
    next,eb,ew:array[..]of longint;
procedure swap(a,b:longint);
var t:longint;
begin
  t:=tr[a];tr[a]:=tr[b];tr[b]:=t;
  t:=p[a];p[a]:=p[b];p[b]:=t;
  t:=q[p[a]];q[p[a]]:=q[p[b]];q[p[b]]:=t;
end;
procedure sw(var a,b:longint);
var t:longint;
begin
  t:=a;a:=b;b:=t;
end;
procedure up(a:longint);
begin
  if a= then exit;
  if tr[a]<tr[a div ] then
  begin
    swap(a,a div );
    up(a div );
  end;
end;
procedure down(a:longint);
var b,c:longint;
begin
  b:=;
  while(b<=a div )do
  begin
    c:=b*;
    if(tr[c]>tr[c+])and(c<n)then
      c:=c+;
    if tr[c]<tr[b] then
      swap(b,c);
    b:=c;
  end;
end;
procedure input;
begin
  v:=v+;
  eb[v]:=b;
  ew[v]:=c;
  next[v]:=first[a];
  first[a]:=v;
end;
begin
readln(nn);
for ii:= to nn do
begin
  readln(n,m,s,t);
  v:=;
  fillchar(first,sizeof(first),);
  for i:= to m do
  begin
    readln(a,b,c);
    input;
    sw(a,b);
    input;
  end;
  fillchar(tr,sizeof(tr),$7f);
  tr[s+]:=;
  for i:= to n do
  begin
    p[i]:=i-;
    q[i-]:=i;
  end;
  up(s+);
  write('Case #',ii,': ');
  repeat
    a:=p[]; //top
    if a=t then
    begin
      if tr[]= then
        writeln('unreachable')
      else
        writeln(tr[]);
      break;
    end;
    b:=first[a];
    while(b<>)do
    begin
      c:=eb[b];
      if(tr[q[a]]+ew[b]<tr[q[c]])then
      begin
        tr[q[c]]:=tr[q[a]]+ew[b];
        up(q[c]);
      end;
      b:=next[b];
    end;
    swap(,n);
    n:=n-;
    down(n);
  until false;
end;
end.