Cod sursa(job #408447)

Utilizator saodem74hieu tran saodem74 Data 3 martie 2010 03:08:18
Problema Sortare topologica Scor 10
Compilator fpc Status done
Runda Arhiva educationala Marime 2.15 kb
const tfi='sortaret.in';
      tfo='sortaret.out';
      maxn=50050;
      maxm=100100;
type  ds=record
            u,v:longint;
          end;
var   fi,fo:text;
      last,first,n,m:longint;
      q,dd,bvao,st,ke:array[0..maxn] of longint;
      li:array[0..maxn] of ds;

procedure swap(var u,v:longint);
var tg:longint;
begin
  tg:=u; u:=v; v:=tg;
end;

procedure sort(l,r:longint);
var mid,i,j,m1,m2:longint;
begin
  if l>=r then exit;
  i:=l; j:=r;
  mid:=(l+r) div 2;
  m1:=li[mid].u;
  m2:=li[mid].v;
  repeat
    while (li[i].u<m1) or ((li[i].u=m1) and (li[i].v<m2)) do inc(i);
    while (li[j].u>m1) or ((li[j].u=m1) and (li[j].v>m2)) do dec(j);
    if i<=j then
     begin
      swap(li[i].u,li[j].u);
      swap(li[i].v,li[j].v);
      inc(i);
      dec(j);
     end;
  until i>j;
  sort(i,r);
  sort(l,j);
end;

procedure enter;
var i,j:longint;
begin
  read(fi,n,m);
  for i:=1 to n do
   with li[i] do read(fi,v,u);
end;

procedure init;
var i,j:longint;
begin
  sort(1,m);
  i:=1;
  while i<=m do
   begin
    j:=i+1;
    with li[i] do
    begin
    while (j<=m) and ((li[j].u=u) and (li[j].v=v)) do
     begin
      dd[j]:=1;
      inc(j);
     end;
    inc(st[u]);
    inc(bvao[v]);
    end;
    i:=j;
   end;

   inc(st[1]);
   for i:=2 to n+1 do st[i]:=st[i]+st[i-1];

   for i:=1to m do
    if dd[i]=0 then
     with li[i] do
     begin
      dec(st[u]);
      ke[st[u]]:=v;
     end;
end;

procedure push(u:longint);
begin
  inc(last);
  q[last]:=u;
end;

function pop:longint;
begin
  inc(first);
  pop:=q[first];
end;

procedure process;
var i,j:longint;
begin
  last:=0; first:=0;
  for  i:=1 to n do
   if bvao[i] = 0 then push(i);
  repeat
    i:=pop;
    for j:=st[i] to st[i+1]-1 do
      if (bvao[ke[j]]<>0) then
       begin
        dec(bvao[ke[j]]);
        if bvao[ke[j]]=0 then push(ke[j]);
       end;
  until first=last;
end;

procedure print;
var i:longint;
begin
  for i:=n downto 1 do write(fo,q[i],' ');
end;

begin
  assign(fi,tfi); reset(fi);
  assign(fo,tfo); rewrite(fo);
  enter;
  init;
  process;
  print;
  close(fi); close(fo);
end.