Cod sursa(job #342231)

Utilizator sapiensCernov Vladimir sapiens Data 20 august 2009 22:18:06
Problema Sortare prin comparare Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 1.06 kb
Program algsort;
 var f,g:text; h:array[0..1000001]of longint;
     i,n,nh:longint;
 procedure swap (x,y:longint);
  var z:longint;
  begin
   z:=h[x]; h[x]:=h[y]; h[y]:=z;
  end;
 procedure upheap (x:longint);
  begin
   if h[x]<h[x div 2] then begin
     swap (x,x div 2);
     upheap (x div 2);
   end;
  end;
 procedure downheap (x:longint);
  var y:longint;
  begin
   if h[2*x]<h[x] then if h[2*x+1]<h[2*x] then begin
     swap (x,2*x+1);
     downheap (2*x+1);
   end else begin
     swap (x,2*x);
     downheap (2*x);
   end;
  end;
 procedure delete;
  begin
   swap (1,nh);
   write (g,h[nh]+1,' ');
   h[nh]:=maxlongint;
   dec (nh);
   downheap (1);
  end;
 begin
  assign (f,'algsort.in'); reset (f);
  assign (g,'algsort.out'); rewrite (g);
  readln (f,n);
  for i:=1 to n do read (f,h[i]);
  for i:=1 to n do dec (h[i],1);
  h[0]:=-1;
  for i:=n+1 to 1000001 do h[i]:=maxlongint;
  nh:=n;
  for i:=(nh div 2) downto 1 do downheap (i);
  for i:=n downto 2 do delete;
  writeln (g,h[1]+1);
  close (f); close (g);
 end.