Cod sursa(job #543493)

Utilizator david93Demeny David david93 Data 28 februarie 2011 09:39:50
Problema Sortare topologica Scor 80
Compilator fpc Status done
Runda Arhiva educationala Marime 1.29 kb
uses crt;
type
mut=^elem;
elem=record
a:integer;
k:mut;
end;
op2=array[1..50000]of mut;
kl=array[1..50000] of boolean;
op=array[1..50000]of integer;
var
 i,m,n,a,b,c,d:integer;
 f,g:text;
 j:kl;
 v:op2;
 v2:op;
 p:mut;
 jo:boolean;
procedure lep(a:integer);
var i:integer;
 p:mut;
begin
 j[a]:=true;
 p:=v[a];
 while p<>nil do
    begin
     if not(j[p^.a])
      then lep(p^.a);
     p:=p^.k;
    end;
 inc(d);
 v2[d]:=a;
end;
begin
 assign(f,'sortaret.in');
 reset(f);
 assign(g,'sortaret.out');
 rewrite(g);
 readln(f,n,m);
 for i:=1 to m do
   begin
     readln(f,a,b);
     if v[a]<>nil
      then
       begin
        p:=v[a];
        if v[a]^.a<>b then jo:=true
        else jo:=false;
        while (p^.k<>nil)and(jo) do
         begin
          if p^.a=b then jo:=false;
          p:=p^.k;
         end;
        if jo then
        begin
        new(p);
        p^.k:=v[a]^.k;
        v[a]^.k:=p;
        p^.a:=b;
        end;
       end
      else
       begin
        new(v[a]);
        v[a]^.a:=b;
        v[a]^.k:=nil;
       end;
   end;
 d:=0;
 for i:=1 to n do
  j[i]:=false;
 for i:=1 to n do
   if not(j[i])
    then
     begin
      lep(i);
     end;
 for i:=n downto 1   do
  write(g,v2[i],' ');
 close(f);
 close(g);
end.