Cod sursa(job #344947)

Utilizator sapiensCernov Vladimir sapiens Data 1 septembrie 2009 13:30:35
Problema Sortare prin comparare Scor 80
Compilator fpc Status done
Runda Arhiva educationala Marime 0.94 kb
Program algsort;
 var f,g:text; h:array[1..500000]of longint;
     i,n,nn:longint;
 procedure swap (x,y:longint);
  var z:longint;
  begin
   z:=h[x]; h[x]:=h[y]; h[y]:=z;
  end;
 procedure downheap (x:longint);
  var y,z:longint;
  begin
   y:=x;
   repeat
     z:=0;
     if 2*y<=n then begin
       z:=2*y;
       if z+1<=n then if h[z+1]>h[z] then inc (z);
       if h[z]<=h[y] then z:=0;
     end;
     if (z<>0) then begin
       swap (y,z);
       y:=z;
     end;
   until z=0;
  end;
 procedure make_heap;
  var x:longint;
  begin
   for x:=n div 2 downto 1 do downheap (x);
  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]);
  make_heap;
  nn:=n;
  for i:=n downto 2 do begin
    swap (1,n);
    dec (n);
    downheap (1);
  end;
  for i:=1 to nn do write (g,h[i],' '); writeln (g);
  close (f); close (g);
 end.