Cod sursa(job #255782)

Utilizator valytgjiu91stancu vlad valytgjiu91 Data 10 februarie 2009 16:52:51
Problema Drumuri minime Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.85 kb
const
     inf=1.7e38;
     nmax=1500;
type
    lista=^elem;
    elem=record
           v:longint;
           c:real;
           adu:lista;
           end;
var
   f,g:text;
   d:array[1..1500] of real;
   poz:array[1..1500] of longint;
   a:array[1..1500] of lista;
   viz:array[1..1500] of 0..1;
   n,m,x,y,i,j:longint;
   min,ct:real;
   q,p: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^.adu:=Nil;
                       a[x]:=p;
                       end
                 else  begin
                       p:=a[x];
                       new(q);
                       q^.v:=y;
                       q^.c:=ln(ct);
                       q^.adu:=p;
                       a[x]:=q;
                       end;
     if a[y]=Nil then  begin
                       new(p);
                       p^.v:=x;
                       p^.c:=ln(ct);
                       p^.adu:=Nil;
                       a[y]:=p;
                       end
                 else  begin
                       p:=a[y];
                       new(q);
                       q^.v:=x;
                       q^.c:=ln(ct);
                       q^.adu:=p;
                       a[y]:=q;
                       end;
         end;
     q:=a[1];
     while q<>Nil do
           begin
           d[q^.v]:=q^.c;
           poz[q^.v]:=1;
           q:=q^.adu;
           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]+poz[y];
                       end;
                    q:=q^.adu;
                    end;
              end;
     until not ok;
     for i:=2 to n do write(g,poz[i] mod 104659,' ');
     close(f);close(g);
End.