Cod sursa(job #409262)

Utilizator alexandru92alexandru alexandru92 Data 3 martie 2010 15:40:11
Problema Sortare prin comparare Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 1.22 kb
var h:array [1..500000] of longint;
    buf:array [1..65000] of byte;
    n,k,i,x:longint;
    f,g:text;

procedure inv(var x,y:longint);
var aux:longint;
          begin
          aux:=x;
          x:=y;
          y:=aux;
          end;

procedure siftdown( k,i:longint);
var son : longint;
begin
		  while 1 do begin
			son:=2*i;
			if son > k then begin
				break;
			end;
			if son < k && h[son] < h[son+1] then begin
				++son;
			end;
			if h[i] >= h[son] then begin
			   break;
			end;
			inv( h[i], h[son] );
			i:=son;
		  end;
end;

procedure addheap(x,i:longint);
          begin
          h[i]:=x;
          siftup(i);
          end;

procedure siftup(i:longint);
var f, key:longint;
begin
	key:=h[i];
	while k > 1 && key > h[f] do begin
		inv( h[f], h[k] );
		k:=f;
		f:=f div 2;
	end;
end;
begin
assign(f,'algsort.in');reset(f);
settextbuf(f,buf);
readln(f,n);
for i:=1 to n do
    begin
    read(f,x);
    addheap(x,i);
    end;
close(f);
k:=n;
for i:=1 to n do
    begin
    inv(h[1],h[k]);
    siftdown(1,k-1);
    k:=k-1;
    end;
assign(g,'algsort.out');rewrite(g);
for i:=1 to n do
    write(g,h[i],' ');
close(g);
end.