Cod sursa(job #153493)

Utilizator mihai_floreaFlorea Mihai Alexandru mihai_florea Data 10 martie 2008 16:22:48
Problema Sortare topologica Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 1.65 kb
program Sortare_topologica;
type nod=^ref;
     ref=record
         info:word;
         urm:nod;
         end;
var prim,c:array[1..50001]of nod;
    q:array[1..50001]of word;
    deg:array[1..50001]of Longint;
    n,m,nr:longint;
    f:text;
procedure add(what,where:word);
var p:nod;
begin
new(p);
p^.info:=what;
p^.urm:=nil;
if prim[where]=nil  then begin
                         prim[where]:=p;
                         c[where]:=p;
                         end
                    else begin
                         c[where]^.urm:=p;
                         c[where]:=p;
                         end;
end;
procedure citeste;
var i,j,k:Longint;
begin
assign(f,'sortaret.in');reset(f);
readln(f,n,m);
for i:=1 to n do begin
                 prim[i]:=nil;
                 deg[i]:=0;
                 end;
for i:=1 to m do begin
                 readln(f,j,k);
                 add(k,j);
                 inc(deg[k]);
                 end;
close(f);
end;
procedure sort_topo;
var i:word;
    p:nod;
begin
nr:=0;
for i:=1 to n do
 if deg[i]=0 then begin
                  inc(nr);
                  q[nr]:=i;
                  end;
for i:=1 to n do
 begin
 p:=prim[i];
 while (p<>nil) do begin
                   dec(deg[p^.info]);
                   if deg[p^.info]=0 then begin
                                          inc(nr);
                                          q[nr]:=p^.info;
                                          end;
                   p:=p^.urm;
                   end;
 end;
assign(f,'sortaret.out');rewrite(f);
for i:=1 to n do write(f,q[i],' ');
close(f);
end;
begin
citeste;
sort_topo;
end.