Cod sursa(job #555793)

Utilizator ion_calimanUAIC Ion Caliman ion_caliman Data 15 martie 2011 19:34:02
Problema Sortare topologica Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 2.41 kb
var     a:array[1..2,1..100000]of longint;
        b:array[1..100000] of boolean;
        n,m,x,y:longint;
        i,j:longint;
        f1,f2:text;

procedure sw(var a,b:longint);
var     t:longint;
begin
  t:=a; a:=b; b:=t;
end;

procedure qs1(left,right:longint);
var     i,j,r:longint;
begin
  i:=left;
  j:=right;
  r:=a[1,(i+j) div 2];
  while i<j do
    begin
      while a[1,i]<r do inc(i);
      while a[1,j]>r do dec(j);
      if i<=j then
        begin
          sw(a[1,i],a[1,j]);
          sw(a[2,i],a[2,j]);
          inc(i);
          dec(j);
        end;
    end;
  if i<right then qs1(i,right);
  if j>left then qs1(left,j);
end;

procedure qs(left,right:longint);
var     i,j,r:longint;
begin
  i:=left;
  j:=right;
  r:=a[2,(i+j) div 2];
  while i<j do
    begin
      while a[2,i]<r do inc(i);
      while a[2,j]>r do dec(j);
      if i<=j then begin sw(a[2,i],a[2,j]); inc(i); dec(j); end;
    end;
  if i<right then qs(i,right);
  if j>left then qs(left,j);
end;

begin
  assign(f1,'sortaret.in');
  assign(f2,'sortaret.out');
  reset(f1);
  rewrite(f2);
  readln(f1,n,m);
  for i:=1 to m do
    readln(f1,a[1,i],a[2,i]);

  qs1(1,m);

  i:=1;
  while i<m do
    begin
      j:=i;
      while a[1,j+1]=a[1,i] do inc(j);
      qs(i,j);
      i:=j+1;
    end;
  i:=1;
  j:=1;
  while (i<m)and(j<m) do
    begin
      {while a[1,i]<=a[2,j] do
        begin
          if not b[a[1,i]] then
            begin
              b[a[1,i]]:=true;
              write(f2,a[1,i],' ');
            end;
          inc(i);
        end;}
      if a[1,i]<=a[2,j] then
        begin
          if not b[a[1,i]] then
            begin
              b[a[1,i]]:=true;
              write(f2,a[1,i],' ');
            end;
          inc(i);
        end;
      if a[1,i]>a[2,j] then
        begin
          if not b[a[2,j]] then
            begin
              b[a[2,j]]:=true;
              write(f2,a[2,j],' ');
            end;
          inc(j);
        end;
    end;
  while i<=m do
    begin
      if not b[a[1,i]] then
            begin
              b[a[1,i]]:=true;
              write(f2,a[1,i],' ');
            end;
          inc(i);
    end;
  while j<=m do
    begin
      if not b[a[2,j]] then
            begin
              b[a[2,j]]:=true;
              write(f2,a[2,j],' ');
            end;
          inc(j);
    end;
  close(f2);
end.