Cod sursa(job #300409)

Utilizator mlazariLazari Mihai mlazari Data 7 aprilie 2009 13:45:20
Problema Sortare topologica Scor 100
Compilator fpc Status done
Runda Arhiva educationala Marime 1.83 kb
Program Sortaret;
{ sortare topologica }
type PNod=^Nod;
     Nod=record
       x : longint;
       next : PNod;
     end;
     Stiva=PNod;
var n,m : longint;
    gr : array[1..50000] of longint;
    Z : Stiva;
    Q : array[1..50000] of Stiva;

procedure AddInSt(var S : Stiva; x : longint);
var C : Stiva;
begin
  new(C);
  C^.x:=x;
  C^.next:=S;
  S:=C;
end;

function ExtractSt(var S : Stiva) : longint;
var rez : longint;
    C : Stiva;
begin
  rez:=S^.x;
  C:=S;
  S:=S^.next;
  dispose(C);
  ExtractSt:=rez;
end;

procedure DelNext(var S : Stiva);
var C : Stiva;
begin
  C:=S^.next;
  S^.next:=C^.next;
  dispose(C);
end;

procedure AddArc(x,y : longint);
begin
  gr[y]:=gr[y]+1;
  AddInSt(Q[x],y);
end;

procedure Citeste;
var Intrare : text;
    x,y,i : longint;
begin
  assign(Intrare,'sortaret.in');
  reset(Intrare);
  readln(Intrare,n,m);
  for i:=1 to n do begin
    gr[i]:=0;
    Q[i]:=nil;
  end;
  for i:=1 to m do begin
    readln(Intrare,x,y);
    AddArc(x,y);
  end;
  close(Intrare);
end;

procedure Proceseaza;
var Iesire : text;
    x,y,i : longint;
    C : Stiva;
begin
  assign(Iesire,'sortaret.out');
  rewrite(Iesire);
  Z:=nil;
  for i:=1 to n do
   if gr[i]=0 then AddInSt(Z,i);
  for i:=1 to n do begin
    x:=ExtractSt(Z);
    write(Iesire,x,' ');
    while Q[x]<>nil do begin
      gr[Q[x]^.x]:=gr[Q[x]^.x]-1;
      if gr[Q[x]^.x]=0 then begin
        y:=ExtractSt(Q[x]);
        AddInSt(Z,y);
      end
      else break;
    end;
    C:=Q[x];
    if C<>nil then
     while C^.next<>nil do begin
       gr[C^.next^.x]:=gr[C^.next^.x]-1;
       if gr[C^.next^.x]=0 then begin
         AddInSt(Z,C^.next^.x);
         DelNext(C);
       end
       else C:=C^.next;
     end;
  end;
  close(Iesire);
end;

begin
  Citeste;
  Proceseaza;
end.