记录编号	39417	评测结果	AAAAA
题目名称	868.RCDH外星人	最终得分	100
用户昵称	IMSL77	是否通过	通过
代码语言	Pascal	运行时间	0.038 s
提交时间	2012-07-10 16:27:27	内存使用	7.11 MiB

program et;
type
  integer=longint;
const
  maxn=40000;
  maxm=400000;
  maximp=10;
var
  n,m:integer;
  tot,ans:integer;
  ver:array[1..maxn] of integer;
  en,next:array[1..maxm] of integer;
  l:array[1..maxm] of integer;
  imp:array[1..maxn] of integer;
  d:array[1..maxn] of integer;
  mark,tick:array[1..maxn] of boolean;
  list,ed:array[1..maxn] of integer;
  Q:array[1..maxn*10] of integer;

  procedure Fopen;
  begin
    assign(input,'et.in'); reset(input);
    assign(output,'et.out'); rewrite(output);
  end;

  procedure Fclose;
  begin
    close(input); close(output);
  end;

  procedure addedge(u,v,c:integer);
  begin
    inc(tot);
    en[tot]:=v; next[tot]:=ver[u]; ver[u]:=tot;
    l[tot]:=c;
  end;

  procedure SetGraph;
  var
    i:integer;
    u,v,c:integer;
  begin
    readln(n,m);
    for i:=1 to n do readln(imp[i]);
    fillchar(ver,sizeof(ver),0);
    fillchar(next,sizeof(next),0);
    tot:=0;
    for i:=1 to m do
    begin
      readln(u,v,c);
      addedge(u,v,c); addedge(v,u,c);
    end;
  end;

  procedure Spfa(s:integer);
  var
    head,tail:integer;
    k,x,y:integer;
  begin
    tot:=1; list[1]:=s; tick[s]:=false; ed[1]:=d[s];
    d[s]:=0; mark[s]:=false;
    head:=1; tail:=2;
    Q[1]:=s;
    repeat
      x:=Q[head];
      k:=ver[x];
      while k>0 do
      begin
        y:=en[k];
        if d[x]+l[k]<d[y] then
        begin
          if tick[y] then
          begin
            inc(tot); list[tot]:=y;
            tick[y]:=false; ed[tot]:=d[y];
          end;
          d[y]:=d[x]+l[k];
          if mark[y] then
          begin
            mark[y]:=false;
            Q[tail]:=y; inc(tail);
          end;
        end;
        k:=next[k];
      end;
      mark[x]:=true;
      inc(head);
    until head=tail;
    for k:=1 to tot do begin d[list[k]]:=ed[k]; tick[list[k]]:=true; end;
    inc(ans,tot);
  end;

  procedure Spfa2(p:integer);
  var
    head,tail:integer;
    k,x,y:integer;
  begin
    head:=1; tail:=1;
    for k:=1 to n do if imp[k]=p then
    begin
      d[k]:=0; mark[k]:=false;
      Q[tail]:=k; inc(tail);
    end;
    while head<tail do
    begin
      x:=Q[head];
      k:=ver[x];
      while k>0 do
      begin
        y:=en[k];
        if d[x]+l[k]<d[y] then
        begin
          d[y]:=d[x]+l[k];
          if mark[y] then
          begin
            mark[y]:=false;
            Q[tail]:=y; inc(tail);
          end;
        end;
        k:=next[k];
      end;
      mark[x]:=true;
      inc(head);
    end;
  end;
  procedure Solve;
  var
    i,j:integer;
  begin
    for i:=1 to n do d[i]:=maxlongint shr 1-1;
    fillchar(mark,sizeof(mark),true);
    fillchar(tick,sizeof(tick),true);
    ans:=0;
    for i:=maximp downto 1 do
    begin
      for j:=1 to n do if imp[j]=i then Spfa(j);
      Spfa2(i);
    end;
    writeln(ans);
  end;

begin
  Fopen;
  SetGraph;
  Solve;
  Fclose;
end.