http://acm.pku.edu.cn/JudgeOnline/problem?id=1206

Код:
program PKU1026;
{$i-, s-, q-, r-}

const
  inf = '';
  ouf = '';
  maxn = 31000;
  maxm = maxn * 10;
  none = 1000000000;

type integer = longint;

var g, q, low, dis, rank, mark, time, dist: array[1 .. maxn] of integer;
    tow, next, cost: array[1 .. maxm] of integer;
    buf: array[0 .. 1 shl 16] of byte;
    n, m, ans, tot: integer;

function min(i, j: integer): integer;
begin
  if i < j then min := i else min := j;
end;

procedure insert(u, v, t: integer);
begin
  tot := tot + 1;
  next[tot] := g[u]; tow[tot] := v;
  cost[tot] := t; g[u] := tot;
end;

procedure prepare;
var i, u, v, t: integer;
begin
  fillchar(g, sizeof(g), 0);
  read(n, m); tot := 0;
  for i := 1 to n do read(rank[i]);
  for i := 1 to m do begin
    read(u, v, t);
    insert(u, v, t);
    insert(v, u, t);
  end;
end;

procedure bfs(k: integer);
var open, closed: integer;
    u, v, t, tmp: integer;
begin
  ans := ans + 1;
  open := 0; closed := 1;
  q[1] := k; dis[k] := 0;
  time[k] := k; dist[k] := 0;
  mark[k] := k;
  while open <> closed do begin
    open := open + 1;
    if open > maxn then open := 1;
    u := q[open]; mark[u] := 0;
    tmp := g[u];
    while tmp <> 0 do begin
      v := tow[tmp]; t := dis[u] + cost[tmp];
      if t < low[v] then
        if (time[v] <> k) or (t < dis[v]) then begin
          dis[v] := t; dist[v] := min(dist[v], dis[v]);
          if time[v] <> k then begin
            ans := ans + 1;
            time[v] := k;
          end;
          if mark[v] <> k then begin
            mark[v] := k;
            closed := closed + 1; if closed > maxn then closed := 1;
            q[closed] := v;
          end;
        end;
      tmp := next[tmp];
    end;
  end;
end;

procedure main;
var i, high: integer;
begin
  ans := 0;
  for i := 1 to n do low[i] := none;
  for high := 10 downto 1 do begin
    fillchar(time, sizeof(time), 0);
    fillchar(mark, sizeof(mark), 0);
    for i := 1 to n do dist[i] := none;
    for i := 1 to n do if rank[i] = high then bfs(i);
    for i := 1 to n do low[i] := min(low[i], dist[i]);
  end;
  writeln(ans);
end;

begin
  assign(input, inf); assign(output, ouf);
  settextbuf(input, buf);
  reset(input); rewrite(output);
  prepare;
  main;
  close(Input); close(output);
end.