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

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