Cod sursa(job #340071)

Utilizator sapiensCernov Vladimir sapiens Data 12 august 2009 22:30:09
Problema Algoritmul lui Dijkstra Scor 10
Compilator fpc Status done
Runda Arhiva educationala Marime 2.37 kb
Program Dijkstra;
 type vecini = ^vecin;
      vecin = record num:longint; dist:integer; next:vecini; end;
 var f,g:text; a:array[1..50000,1..2]of vecini;
     heap:array[1..50000]of longint;
     b:array[1..50000]of longint;
     c:array[1..50000]of longint;
     n,m,num,i:longint;
 procedure initiere;
  var x,y,z:longint; w:integer;
  begin
   assign (f,'dijkstra.in'); reset (f);
   assign (g,'dijkstra.out'); rewrite (g);
   readln (f,n,m);
   for x:=1 to n do begin
     new (a[x,1]);
     a[x,2]:=a[x,1];
   end;
   for x:=1 to m do begin
     readln (f,y,z,w);
     a[y,2]^.num:=z;
     a[y,2]^.dist:=w;
     new (a[y,2]^.next);
     a[y,2]:=a[y,2]^.next;
   end;
  end;
 procedure incheiere;
  begin
   close (f); close (g);
  end;
 procedure init_heap;
  var x:longint;
  begin
   num:=n;
   for x:=2 to num do begin
     heap[x]:=999;
     b[x]:=x;
     c[x]:=x;
   end;
   b[1]:=1; c[1]:=1;
  end;
 procedure swap (x,y:integer);
  var z:integer;
  begin
   z:=heap[x];
   heap[x]:=heap[y];
   heap[y]:=z;
   z:=b[c[x]];
   b[c[x]]:=b[c[y]];
   b[c[y]]:=z;
   z:=c[x];
   c[x]:=c[y];
   c[y]:=z;
  end;
 procedure coboara (x:longint);
  var y:longint;
  begin
   if 2*x<=num then begin
     y:=x;
     if heap[x]>heap[2*x] then y:=2*x;
     if 2*x+1<=num then if heap[y]>heap[2*x+1] then y:=2*x+1;
     if x<>y then begin
       swap (x,y);
       coboara (y);
     end;
   end;
  end;
 procedure urca (x:longint);
  begin
   if x>1 then
     if heap[x div 2]>heap[x] then begin
       swap (x,x div 2);
       urca (x div 2);
     end;
  end;
 function minim (x,y:longint):longint;
  begin
   if x<y then exit (x) else exit (y);
  end;
 procedure sterge;
  begin
   swap (1,num);
   num:=num-1;
   coboara (1);
  end;
 procedure alg_dijkstra;
  var x,y,z:longint;
  begin
   while (heap[1]<>maxlongint) and (num>0) do begin
     x:=c[1];
     a[x,2]:=a[x,1];
     while a[x,2]^.next<>nil do begin
       y:=a[x,2]^.num;
       if c[y]<=num then begin
         heap[b[y]]:=minim (heap[b[y]],heap[b[x]]+a[x,2]^.dist);
         urca (b[y]);
       end;
       a[x,2]:=a[x,2]^.next;
     end;
     sterge;
   end;
  end;
 procedure scrie;
  var x:longint;
  begin
   for x:=2 to n do write (g,heap[b[x]],' ');
   writeln (g);
  end;
 begin
  initiere;
  init_heap;
  alg_dijkstra;
  scrie;
  incheiere;
 end.