Cod sursa(job #102259)

Utilizator johnyJohny Deep johny Data 14 noiembrie 2007 10:16:13
Problema Algola Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.56 kb
const fis='algola';
      nmax=50;
      max=100000;
var ok:array[1..nmax,1..nmax] of boolean;
    c:array[1..nmax,1..nmax] of longint;
    a:array[1..nmax,1..nmax,0..nmax*nmax] of longint;
    on,ct,cp,p:array[1..nmax] of longint;
    n,m,i,j,rez:longint;

Function path(nod:longint):longint;
var i,j,k:longint;
begin
for i:=1 to n do
    begin
    ct[i]:=-1;
    cp[i]:=max;
    p[i]:=-1;
    end;
cp[nod]:=0;
while ct[1]=-1 do
      begin
      j:=1;
      for i:=2 to n do
          if (ct[i]=-1) and ((ct[j]>-1) or (cp[i]<cp[j]))
          then j:=i;
      ct[j]:=cp[j];
      for i:=1 to n do
          if ok[j,i]
          then begin
               k:=ct[j];
               while a[j,i,k]=c[j,i] do
                     inc(k);
               if cp[i]>k+1
               then begin
                    cp[i]:=k+1;
                    p[i]:=j;
                    end;
               end;
      end;
path:=ct[1];
i:=1;
while (p[i]>-1) do
      begin
      inc(a[p[i],i,ct[i]-1]);
      inc(a[i,p[i],ct[i]-1]);
      i:=p[i];
      end;
end;

begin
assign(input,fis+'.in');
reset(input);
assign(output,fis+'.out');
rewrite(output);
readln(n,m);
for i:=1 to n do
    read(on[i]);
while m>0 do
      begin
      readln(i,j,rez);
      c[i,j]:=rez;
      c[j,i]:=rez;
      ok[i,j]:=true;
      ok[j,i]:=true;
      dec(m);
      end;
rez:=0;
for i:=2 to n do
    for j:=1 to on[i] do
        begin
        m:=path(i);
        if m>rez
        then rez:=m;
        end;
writeln(rez);
close(output);
close(input);
end.