# Cod sursa(job #255779)

Utilizator Data 10 februarie 2009 16:50:25 Drumuri minime 0 fpc done Arhiva de probleme 2.85 kb
``````const
inf=1.7e38;
nmax=1500;
type
lista=^elem;
elem=record
v:longint;
c:real;
urm:lista;
end;
var
f,g:text;
d:array[1..1500] of real;
poz:array[1..1500] of longint;
c:array[1..1500] of lista;
viz:array[1..1500] of 0..1;
n,m,x,y,i,j:longint;
min,ct:real;
q:lista;
ok:boolean;
Begin
assign(f,'dmin.in');reset(f);
assign(g,'dmin.out');rewrite(g);
readln(f,n,m);
for i:=1 to n do begin
a[i]:=Nil;
d[i]:=inf;
end;
for i:=1 to m do
begin
readln(f,x,y,ct);
if a[x]=Nil then  begin
new(p);
p^.v:=y;
p^.c:=ln(ct);
p^.urm:=Nil;
c[x]:=p;
end
else  begin
p:=c[x];
new(q);
q^.v:=y;
q^.c:=ln(ct);
q^.urm:=p;
a[x]:=q;
end;
if a[y]=Nil then  begin
new(p);
p^.v:=x;
p^.c:=ln(ct);
p^.urm:=Nil;
a[y]:=p;
end
else  begin
p:=a[y];
new(q);
q^.v:=x;
q^.c:=ln(ct);
q^.urm:=p;
a[y]:=q;
end;
end;
q:=c[1];
while q<>Nil do
begin
d[q^.v]:=q^.c;
poz[q^.v]:=1;
q:=q^.urm;
end;

d[1]:=1;
repeat
ok:=false;
min:=inf;
for i:=1 to n do
if (viz[i]=0) and (d[i]<min) then
begin
min:=d[i];
y:=i;
ok:=true;
end;
if ok then
begin
viz[y]:=1;
q:=a[y];
while q<>Nil do
begin
if viz[q^.v]=0 then
begin
if d[q^.v]>d[y]+q^.c then
begin
d[q^.v]:=d[y]+q^.c;
poz[q^.v]:=poz[y];
end
else if d[q^.v]=d[y]+q^.c then
poz[q^.v]:=poz[q^.v]+t[y];
end;
q:=q^.urm;
end;
end;
until not ok;
for i:=2 to n do write(g,poz[i] mod 104659,' ');
close(f);close(g);
End.``````