Cod sursa(job #447573)

Utilizator ati90atiNagy Attila ati90ati Data 29 aprilie 2010 03:54:17
Problema Sortare topologica Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 1.15 kb
Program hosszaban;
Var A:array[1..2,1..9000] of 0..1;
    cs,kov:array[1..9000] of integer;
    l:array[1..9000] of 0..1;
    m,n,i,j,k,p,seged:integer;
    r:boolean;
    t:text;
Begin
  assign(t,'sortaret.in');reset(t);
  readln(t,n,m);
  For i:=1 to n do
    l[i]:=0;
  For i:=1 to 2 do
    For j:=1 to n do
      A[i,j]:=0;
  For i:=1 to m do
    readln(t,A[1,i],A[2,i]);
  close(t);
  i:=1;
  cs[1]:=i;
  p:=1;
  l[i]:=1;
  assign(t,'sortaret.out');rewrite(t);
  write(t,i,' ');
  While p>=1 do
    begin
    j:=cs[p];
    k:=kov[j]+1;
    r:=false;
      for seged:=1 to m do
        if ((a[1,seged]=j) and (a[2,seged]=k)) or
           ((a[1,seged]=k) and (a[2,seged]=j)) then
          r:=true;
    While (k<=n) and (not r or (r and (l[k]=1))) do
      begin
      k:=k+1;
      r:=false;
      for seged:=1 to m do
        if ((a[1,seged]=j) and (a[2,seged]=k)) or
           ((a[1,seged]=k) and (a[2,seged]=j)) then
          r:=true;
      end;
    Kov[j]:=k;
    If k=n+1 then
      p:=p-1
    else
      begin
      l[k]:=1;
      p:=p+1;
      cs[p]:=k;
      Write(t,k,' ');
      end;
    end;
  close(t);
End.