Cod sursa(job #255794)

Utilizator valytgjiu91stancu vlad valytgjiu91 Data 10 februarie 2009 17:11:38
Problema Drumuri minime Scor 20
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.95 kb
{$N+}
const
     inf=9.2e18;
     nmax=1500;
     w=100000;
type
    lista=^elem;
    elem=record
           v:longint;
           c:comp;
           urm:lista;
           end;
var
   f,g:text;
   d:array[1..1500] of comp;
   t:array[1..1500] of longint;
   c:array[1..1500] of lista;
   s:array[1..1500] of 0..1;
   n,m,x,y,i,j:longint;
   min,ct:comp;
   p:lista;
   ok:boolean;
procedure adauga(x,y:integer;ct:comp);
var
   p,q:lista;
begin
     if c[x]=Nil then  begin
                       new(p);
                       p^.v:=y;
                       p^.c:=W*ln(ct);
                       p^.urm:=Nil;
                       c[x]:=p;
                       end
                 else  begin
                       p:=c[x];
                       new(q);
                       q^.v:=y;
                       q^.c:=w*ln(ct);
                       q^.urm:=p;
                       c[x]:=q;
                       end;
     if c[y]=Nil then  begin
                       new(p);
                       p^.v:=x;
                       p^.c:=w*ln(ct);
                       p^.urm:=Nil;
                       c[y]:=p;
                       end
                 else  begin
                       p:=c[y];
                       new(q);
                       q^.v:=x;
                       q^.c:=w*ln(ct);
                       q^.urm:=p;
                       c[y]:=q;
                       end;
end;
Begin
     assign(f,'dmin.in');reset(f);
     assign(g,'dmin.out');rewrite(g);
     readln(f,n,m);
     for i:=1 to n do begin
                      c[i]:=Nil;
                      d[i]:=inf;
                      end;
     for i:=1 to m do
         begin
         readln(f,x,y,ct);
         adauga(x,y,ct);
         end;
     p:=c[1];
     while p<>Nil do
           begin
           d[p^.v]:=p^.c;
           t[p^.v]:=1;
           p:=p^.urm;
           end;
     d[1]:=1;
     repeat
           ok:=false;
           min:=inf;
           for i:=1 to n do
               if (s[i]=0) and (d[i]<min) then
                  begin
                  min:=d[i];
                  y:=i;
                  ok:=true;
                  end;
           if ok then
              begin
              s[y]:=1;
              p:=c[y];
              while p<>Nil do
                    begin
                    if s[p^.v]=0 then
                       begin
                       if d[p^.v]>d[y]+p^.c then
                                   begin
                                   d[p^.v]:=d[y]+p^.c;
                                   t[p^.v]:=t[y];
                                   end
                       else if d[p^.v]=d[y]+p^.c then
                                   t[p^.v]:=t[p^.v]+t[y];
                       end;
                    p:=p^.urm;
                    end;
              end;
     until not ok;
     for i:=2 to n do write(g,t[i] mod 104659,' ');
     close(f);close(g);
End.